direct_io_2.f90

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

! { dg-do run }
!
! this testcase derived from NIST test FM413.FOR
! tests writing direct access files in ascending and descending
! REC's.
      PROGRAM FM413
      IMPLICIT LOGICAL (L)
      IMPLICIT CHARACTER*14 (C)
      IMPLICIT INTEGER(4) (I)
      DATA IPROG, IFILE, ITOTR, IRLGN, IRECN, IEOF,ICON21, ICON22, ICON31, ICON32, ICON33, ICON34, ICON55, ICON56 /14*0/
      OPEN (7, ACCESS = 'DIRECT', RECL = 80, STATUS='REPLACE', FILE="FOO" )
      IRECN = 13
      IREC = 13
      DO 4132 I = 1,100
      IREC = IREC + 2
      IRECN = IRECN + 2
      WRITE(7, REC = IREC) IPROG, IFILE, ITOTR, IRLGN, IRECN, IEOF,ICON21, ICON22, ICON31, ICON32, ICON33, ICON34, ICON55, ICON56
 4132 CONTINUE
      IRECN = 216
      IREC = 216
      DO 4133 I=1,100
      IREC = IREC - 2
      IRECN = IRECN - 2
      WRITE(7, REC = IREC) IPROG, IFILE, ITOTR, IRLGN, IRECN, IEOF,ICON21, ICON22, ICON31, ICON32, ICON33, ICON34, ICON55, ICON56
 4133 CONTINUE
      IRECCK = 13
      IRECN = 0
      IREC = 13
      IVCOMP = 0
      DO 4134 I = 1,100
      IREC = IREC + 2
      IRECCK = IRECCK + 2
      READ(7, REC = IREC) IPROG, IFILE, ITOTR, IRLGN, IRECN, IEOF,IVON21, IVON22, IVON31, IVON32, IVON33, IVON34, IVON55, IVON56
      IF (IRECN .NE. IRECCK) CALL ABORT
 4134 CONTINUE
      IRECCK = 216
      IRECN = 0
      IREC = 216
      DO 4135 I = 1,100
      IREC = IREC - 2
      IRECCK = IRECCK - 2
      READ(7, REC = IREC)  IPROG, IFILE, ITOTR, IRLGN, IRECN, IEOF,IVON21, IVON22, IVON31, IVON32, IVON33, IVON34, IVON55, IVON56
      IF (IRECN .NE. IRECCK) CALL ABORT
 4135 CONTINUE
      CLOSE(7, STATUS='DELETE')
      STOP
      END