! { dg-do run } ! { dg-options "-std=legacy" } ! ! 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