1! { dg-do run { target fd_truncate } }
2!
3! Test the fix for PR34875, in which the read with a vector index
4! used to do nothing.
5!
6! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
7!
8Program QH0008
9
10  REAL(4) QDA(10)
11  REAL(4) QDA1(10)
12! Scramble the vector up a bit to make the test more interesting
13  integer, dimension(10) ::  nfv1 = (/9,2,1,3,5,4,6,8,7,10/)
14! Set qda1 in ordinal order
15  qda1(nfv1) = nfv1
16  qda = -100
17  OPEN (UNIT = 47,                &
18        STATUS = 'SCRATCH',       &
19        FORM = 'UNFORMATTED',     &
20        ACTION = 'READWRITE')
21  ISTAT = -314
22  REWIND (47, IOSTAT = ISTAT)
23  IF (ISTAT .NE. 0) STOP 1
24  ISTAT = -314
25! write qda1
26  WRITE (47,IOSTAT = ISTAT) QDA1
27  IF (ISTAT .NE. 0) STOP 2
28  ISTAT = -314
29  REWIND (47, IOSTAT = ISTAT)
30  IF (ISTAT .NE. 0) STOP 3
31! Do the vector index read that used to fail
32  READ (47,IOSTAT = ISTAT) QDA(NFV1)
33  IF (ISTAT .NE. 0) STOP 4
34! Unscramble qda using the vector index
35  IF (ANY (QDA(nfv1) .ne. QDA1) ) print *, qda, qda1
36  ISTAT = -314
37  REWIND (47, IOSTAT = ISTAT)
38  IF (ISTAT .NE. 0) STOP 5
39  qda = -200
40! Do the subscript read that was OK
41  READ (47,IOSTAT = ISTAT) QDA(1:10)
42  IF (ISTAT .NE. 0) STOP 6
43  IF (ANY (QDA .ne. QDA1) ) STOP 7
44END
45
46