gcc/testsuite/gfortran.dg/vector_subscript_3.f90

   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 !
   8 Program 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
  44 END
  45