gcc/testsuite/gfortran.dg/direct_io_2.f90

   1 ! { dg-do run }
   2 !
   3 ! this testcase derived from NIST test FM413.FOR
   4 ! tests writing direct access files in ascending and descending
   5 ! REC's.
   6       PROGRAM FM413
   7       IMPLICIT LOGICAL (L)
   8       IMPLICIT CHARACTER*14 (C)
   9       IMPLICIT INTEGER(4) (I)
  10       DATA IPROG, IFILE, ITOTR, IRLGN, IRECN, IEOF,ICON21, ICON22, ICON31, ICON32, ICON33, ICON34, ICON55, ICON56 /14*0/
  11       OPEN (7, ACCESS = 'DIRECT', RECL = 80, STATUS='REPLACE', FILE="FOO" )
  12       IRECN = 13
  13       IREC = 13
  14       DO 4132 I = 1,100
  15       IREC = IREC + 2
  16       IRECN = IRECN + 2
  17       WRITE(7, REC = IREC) IPROG, IFILE, ITOTR, IRLGN, IRECN, IEOF,ICON21, ICON22, ICON31, ICON32, ICON33, ICON34, ICON55, ICON56
  18  4132 CONTINUE
  19       IRECN = 216
  20       IREC = 216
  21       DO 4133 I=1,100
  22       IREC = IREC - 2
  23       IRECN = IRECN - 2
  24       WRITE(7, REC = IREC) IPROG, IFILE, ITOTR, IRLGN, IRECN, IEOF,ICON21, ICON22, ICON31, ICON32, ICON33, ICON34, ICON55, ICON56
  25  4133 CONTINUE
  26       IRECCK = 13
  27       IRECN = 0
  28       IREC = 13
  29       IVCOMP = 0
  30       DO 4134 I = 1,100
  31       IREC = IREC + 2
  32       IRECCK = IRECCK + 2
  33       READ(7, REC = IREC) IPROG, IFILE, ITOTR, IRLGN, IRECN, IEOF,IVON21, IVON22, IVON31, IVON32, IVON33, IVON34, IVON55, IVON56
  34       IF (IRECN .NE. IRECCK) CALL ABORT
  35  4134 CONTINUE
  36       IRECCK = 216
  37       IRECN = 0
  38       IREC = 216
  39       DO 4135 I = 1,100
  40       IREC = IREC - 2
  41       IRECCK = IRECCK - 2
  42       READ(7, REC = IREC)  IPROG, IFILE, ITOTR, IRLGN, IRECN, IEOF,IVON21, IVON22, IVON31, IVON32, IVON33, IVON34, IVON55, IVON56
  43       IF (IRECN .NE. IRECCK) CALL ABORT
  44  4135 CONTINUE
  45       CLOSE(7, STATUS='DELETE')
  46       STOP
  47       END