gcc/testsuite/gfortran.dg/direct_io_2.f90

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