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 49