1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
|
! { 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
|
