vector_subscript_3.f90

来自「用于进行gcc测试」· F90 代码 · 共 46 行

! { dg-do run }
!
! Test the fix for PR34875, in which the read with a vector index
! used to do nothing.
!
! Contributed by Dick Hendrickson <[e-mail]>
!
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