46 lines
1.3 KiB
Fortran
46 lines
1.3 KiB
Fortran
! { dg-do run { target fd_truncate } }
|
|
!
|
|
! Test the fix for PR34875, in which the read with a vector index
|
|
! used to do nothing.
|
|
!
|
|
! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
|
|
!
|
|
Program QH0008
|
|
|
|
REAL(4) QDA(10)
|
|
REAL(4) QDA1(10)
|
|
! Scramble the vector up a bit to make the test more interesting
|
|
integer, dimension(10) :: nfv1 = (/9,2,1,3,5,4,6,8,7,10/)
|
|
! Set qda1 in ordinal order
|
|
qda1(nfv1) = nfv1
|
|
qda = -100
|
|
OPEN (UNIT = 47, &
|
|
STATUS = 'SCRATCH', &
|
|
FORM = 'UNFORMATTED', &
|
|
ACTION = 'READWRITE')
|
|
ISTAT = -314
|
|
REWIND (47, IOSTAT = ISTAT)
|
|
IF (ISTAT .NE. 0) call abort ()
|
|
ISTAT = -314
|
|
! write qda1
|
|
WRITE (47,IOSTAT = ISTAT) QDA1
|
|
IF (ISTAT .NE. 0) call abort ()
|
|
ISTAT = -314
|
|
REWIND (47, IOSTAT = ISTAT)
|
|
IF (ISTAT .NE. 0) call abort ()
|
|
! Do the vector index read that used to fail
|
|
READ (47,IOSTAT = ISTAT) QDA(NFV1)
|
|
IF (ISTAT .NE. 0) call abort ()
|
|
! Unscramble qda using the vector index
|
|
IF (ANY (QDA(nfv1) .ne. QDA1) ) print *, qda, qda1
|
|
ISTAT = -314
|
|
REWIND (47, IOSTAT = ISTAT)
|
|
IF (ISTAT .NE. 0) call abort ()
|
|
qda = -200
|
|
! Do the subscript read that was OK
|
|
READ (47,IOSTAT = ISTAT) QDA(1:10)
|
|
IF (ISTAT .NE. 0) call abort ()
|
|
IF (ANY (QDA .ne. QDA1) ) call abort ()
|
|
END
|
|
|