C COMMENT SECTION.
C
C FM100
C
C THIS ROUTINE IS A TEST OF THE I FORMAT AND IS TAPE AND PRINTER
C ORIENTED. THE ROUTINE CAN ALSO BE USED FOR DISK. BOTH THE READ
C AND WRITE STATEMENTS ARE TESTED. VARIABLES IN THE INPUT AND
C OUTPUT LISTS ARE INTEGER VARIABLE AND INTEGER ARRAY ELEMENT OR
C ARRAY NAME REFERENCES. ALL READ AND WRITE STATEMENTS ARE DONE
C WITH FORMAT STATEMENTS. THE ROUTINE HAS AN OPTIONAL SECTION OF
C CODE TO DUMP THE FILE AFTER IT HAS BEEN WRITTEN. DO LOOPS AND
C DO-IMPLIED LISTS ARE USED IN CONJUNCTION WITH A ONE DIMENSIONAL
C INTEGER ARRAY FOR THE DUMP SECTION.
C
C THIS ROUTINE WRITES A SINGLE SEQUENTIAL FILE WHICH IS
C REWOUND AND READ SEQUENTIALLY FORWARD. EVERY FOURTH RECORD IS
C CHECKED DURING THE READ TEST SECTION PLUS THE LAST TWO RECORDS
C AND THE END OF FILE ON THE LAST RECORD.
C
C THE LINE CONTINUATION IN COLUMN 6 IS USED IN READ, WRITE,
C AND FORMAT STATEMENTS. FOR BOTH SYNTAX AND SEMANTIC TESTS, ALL
C STATEMENTS SHOULD BE CHECKED VISUALLY FOR THE PROPER FUNCTIONING
C OF THE CONTINUATION LINE.
C
C REFERENCES
C AMERICAN NATIONAL STANDARD PROGRAMMING LANGUAGE FORTRAN,
C X3.9-1978
C
C SECTION 8, SPECIFICATION STATEMENTS
C SECTION 9, DATA STATEMENT
C SECTION 11.10, DO STATEMENT
C SECTION 12, INPUT/OUTPUT STATEMENTS
C SECTION 12.8.2, INPUT/OUTPUT LIST
C SECTION 12.9.5.2, FORMATTED DATA TRANSFER
C SECTION 13, FORMAT STATEMENT
C SECTION 13.2.1, EDIT DESCRIPTORS
C SECTION 13.5.9.1, INTEGER EDITING
C
DIMENSION ITEST(30)
DIMENSION IDUMP(136)
CHARACTER*1 NINE,IDUMP
DATA NINE/'9'/
C
77701 FORMAT ( 80A1 )
77702 FORMAT (10X,19HPREMATURE EOF ONLY ,I3,13H RECORDS LUN ,I2,8H OUT O
1F ,I3,8H RECORDS)
77703 FORMAT (10X,12HFILE ON LUN ,I2,7H OK... ,I3,8H RECORDS)
77704 FORMAT (10X,12HFILE ON LUN ,I2,20H TOO LONG MORE THAN ,I3,8H RECOR
1DS)
77705 FORMAT ( 1X,80A1)
77706 FORMAT (10X,43HFILE I06 CREATED WITH 31 SEQUENTIAL RECORDS)
77751 FORMAT (I3,I2,I2,I3,I3,I3,I4,I1,I1,I1,I1,I1,I1,I1,I1,I1,I1,I2,I2,I
13,I3,I4,I4,I4,I4,I4,I5,I5,I5,I5)
C
C
C **********************************************************
C
C A COMPILER VALIDATION SYSTEM FOR THE FORTRAN LANGUAGE
C BASED ON SPECIFICATIONS AS DEFINED IN AMERICAN NATIONAL STANDARD
C PROGRAMMING LANGUAGE FORTRAN X3.9-1978, HAS BEEN DEVELOPED BY THE
C FEDERAL COBOL COMPILER TESTING SERVICE. THE FORTRAN COMPILER
C VALIDATION SYSTEM (FCVS) CONSISTS OF AUDIT ROUTINES, THEIR RELATED
C DATA, AND AN EXECUTIVE SYSTEM. EACH AUDIT ROUTINE IS A FORTRAN
C PROGRAM, SUBPROGRAM OR FUNCTION WHICH INCLUDES TESTS OF SPECIFIC
C LANGUAGE ELEMENTS AND SUPPORTING PROCEDURES INDICATING THE RESULT
C OF EXECUTING THESE TESTS.
C
C THIS PARTICULAR PROGRAM/SUBPROGRAM/FUNCTION CONTAINS FEATURES
C FOUND ONLY IN THE SUBSET AS DEFINED IN X3.9-1978.
C
C SUGGESTIONS AND COMMENTS SHOULD BE FORWARDED TO -
C
C DEPARTMENT OF THE NAVY
C FEDERAL COBOL COMPILER TESTING SERVICE
C WASHINGTON, D.C. 20376
C
C **********************************************************
C
C
C
C INITIALIZATION SECTION
C
C INITIALIZE CONSTANTS
C **************
C I01 CONTAINS THE LOGICAL UNIT NUMBER FOR THE CARD READER.
I01 = 5
C I02 CONTAINS THE LOGICAL UNIT NUMBER FOR THE PRINTER.
I02 = 6
C SYSTEM ENVIRONMENT SECTION
C
CX010 THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-010 CONTROL CARD.
C THE CX010 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I01 = 5
C (UNIT NUMBER FOR CARD READER).
CX011 THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-011 CONTROL CARD.
C THE CX011 CARD IS FOR SYSTEMS WHICH REQUIRE ADDITIONAL
C FORTRAN STATEMENTS FOR FILES ASSOCIATED WITH CX010 ABOVE.
C
CX020 THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-020 CONTROL CARD.
C THE CX020 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I02 = 6
C (UNIT NUMBER FOR PRINTER).
CX021 THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-021 CONTROL CARD.
C THE CX021 CARD IS FOR SYSTEMS WHICH REQUIRE ADDITIONAL
C FORTRAN STATEMENTS FOR FILES ASSOCIATED WITH CX020 ABOVE.
C
IVPASS=0
IVFAIL=0
IVDELE=0
ICZERO=0
C
C WRITE PAGE HEADERS
WRITE (I02,90000)
WRITE (I02,90001)
WRITE (I02,90002)
WRITE (I02, 90002)
WRITE (I02,90003)
WRITE (I02,90002)
WRITE (I02,90004)
WRITE (I02,90002)
WRITE (I02,90011)
WRITE (I02,90002)
WRITE (I02,90002)
WRITE (I02,90005)
WRITE (I02,90006)
WRITE (I02,90002)
C
C DEFAULT ASSIGNMENT FOR FILE 01 IS I06 = 7
I06 = 7
CX060 THIS CARD IS REPLACED BY THE CONTENTS OF CARD X-060
CX061 THIS CARD IS REPLACED BY THE CONTENTS OF CARD X-061
C
C WRITE SECTION....
C
C THIS SECTION OF CODE BUILDS A UNIT RECORD FILE ON LUN I06 THAT IS
C 80 CHARACTERS PER RECORD, 31 RECORDS LONG, AND CONSISTS OF ONLY
C INTEGERS ( I FORMAT ). THIS IS THE ONLY FILE TESTED IN THE
C ROUTINE FM100 AND FOR PURPOSES OF IDENTIFICATION IS FILE 01.
C ALL OF THE DATA WITH THE EXCEPTION OF THE RECORD NUMBER - IRNUM ,
C INTEGER VARIABLE ICON31 WHICH IS SET TO THE VALUE OF THE RECORD
C NUMBER, AND THE END OF FILE CHECK - IEOF IS SET BY INTEGER
C ASSIGNMENT STATEMENTS TO VARIOUS INTEGER CONSTANTS.
IPROG = 100
IFILE = 01
ILUN = I06
ITOTR = 31
IRLGN = 80
IEOF = 0000
ICON11 = 1
ICON12 = 2
ICON13 = 3
ICON14 = 4
ICON15 = 5
ICON16 = 6
ICON17 = 7
ICON18 = 8
ICON19 = 9
ICON10 = 0
ICON21 = 21
ICON22 = 22
ICON32 = 512
ICON41 = 9995
ICON42 = 9996
ICON43 = 9997
ICON44 = 9998
ICON45 = 9999
ICON51 = 32764
ICON52 = 32765
ICON53 = 32766
ICON54 = 32767
DO 12 IRNUM = 1, 31
ICON31 = IRNUM
IF ( IRNUM .EQ. 31 ) IEOF = 9999
WRITE(I06,77751)IPROG,IFILE,ILUN,IRNUM,ITOTR,IRLGN,IEOF,ICON11,ICO
1N12,ICON13,ICON14,ICON15,ICON16,ICON17,ICON18,ICON19,ICON10,ICON21
2,ICON22,ICON31,ICON32,ICON41,ICON42,ICON43,ICON44,ICON45,ICON51,IC
3ON52,ICON53,ICON54
12 CONTINUE
WRITE (I02,77706)
C
C REWIND SECTION
C
REWIND I06
C
C READ SECTION....
C
IVTNUM = 1
C
C **** TEST 1 THRU TEST 8 ****
C TEST 1 THRU TEST 8 - THESE TESTS READ THE SEQUENTIAL FILE
C PREVIOUSLY WRITTEN ON LUN I06 AND CHECK THE FIRST AND EVERY FOURTH
C RECORD. THE VALUES CHECKED ARE THE RECORD NUMBER - IRNUM AND
C SEVERAL VALUES WHICH SHOULD REMAIN CONSTANT FOR ALL OF THE 31
C RECORDS.
C
IRTST = 1
READ(I06,77751) ITEST
C READ THE FIRST RECORD....
DO 23 I = 1, 8
IVON01 = 0
C THE INTEGER VARIABLE IS INITIALIZED TO ZERO FOR EACH TEST 1 THRU 8
IF ( ITEST(4) .EQ. IRTST ) IVON01 = IVON01 + 1
C THE ELEMENT (4) SHOULD EQUAL THE RECORD NUMBER....
IF ( ITEST(8) .EQ. ICON11 ) IVON01 = IVON01 + 1
C THE ELEMENT (8) SHOULD EQUAL ICON11 = 1....
IF ( ITEST(18) .EQ. ICON21 ) IVON01 = IVON01 + 1
C THE ELEMENT (18) SHOULD EQUAL ICON21 = 21....
IF ( ITEST(20) .EQ. IRTST ) IVON01 = IVON01 + 1
C THE ELEMENT (20) SHOULD ALSO EQUAL THE RECORD NUMBER....
IF ( ITEST(26) .EQ. ICON45 ) IVON01 = IVON01 + 1
C THE ELEMENT (26. SHOULD EQUAL ICON45 = 9999....
IF ( ITEST(30) .EQ. ICON54 ) IVON01 = IVON01 + 1
C THE ELEMENT (30) SHOULD EQUAL ICON54 = 32767....
IF ( IVON01 - 6 ) 20010, 10010, 20010
C WHEN IVON01 = 6 THEN ALL SIX OF THE ITEST ELEMENTS THAT WERE
C CHECKED HAD THE EXPECTED VALUES.... IF IVON01 DOES NOT EQUAL 6
C THEN AT LEAST ONE OF THE VALUES WAS INCORRECT....
10010 IVPASS = IVPASS + 1
WRITE (I02,80001) IVTNUM
GO TO 21
20010 IVFAIL = IVFAIL + 1
IVCOMP = IVON01
IVCORR = 6
WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR
21 CONTINUE
IVTNUM = IVTNUM + 1
C INCREMENT THE TEST NUMBER....
IF ( IVTNUM .EQ. 9 ) GO TO 91
C TAPE SHOULD BE AT RECORD NUMBER 29 FOR TEST 8 - DO NOT READ MORE
C UNTIL TEST NUMBER NINE WHICH CHECKS RECORD NUMBER 30....
DO 22 J = 1, 4
READ(I06,77751) ITEST
C READ FOUR RECORDS ON LUN I06....
22 CONTINUE
IRTST = IRTST + 4
C INCREMENT THE RECORD NUMBER COUNTER....
23 CONTINUE
IF (ICZERO) 30010, 91, 30010
30010 IVDELE = IVDELE + 1
WRITE (I02,80003) IVTNUM
91 CONTINUE
IVTNUM = 9
C
C **** TEST 9 ****
C TEST 9 - THIS CHECKS THE RECORD NUMBER ON EXPECTED RECORD 30.
C
IF (ICZERO) 30090, 90, 30090
90 CONTINUE
READ ( I06, 77751 ) ITEST
IVCOMP = ITEST(4)
GO TO 40090
30090 IVDELE = IVDELE + 1
WRITE (I02,80003) IVTNUM
IF (ICZERO) 40090, 101, 40090
40090 IF ( IVCOMP - 30 ) 20090, 10090, 20090
10090 IVPASS = IVPASS + 1
WRITE (I02,80001) IVTNUM
GO TO 101
20090 IVFAIL = IVFAIL + 1
IVCORR = 30
WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR
101 CONTINUE
IVTNUM = 10
C
C **** TEST 10 ****
C TEST 10 - THIS CHECKS THE RECORD NUMBER ON EXPECTED RECORD 31.
C
IF (ICZERO) 30100, 100, 30100
100 CONTINUE
READ ( I06,77751) ITEST
IVCOMP = ITEST(4)
GO TO 40100
30100 IVDELE = IVDELE + 1
WRITE (I02,80003) IVTNUM
IF (ICZERO) 40100, 111, 40100
40100 IF ( IVCOMP - 31 ) 20100, 10100, 20100
10100 IVPASS = IVPASS + 1
WRITE (I02,80001) IVTNUM
GO TO 111
20100 IVFAIL = IVFAIL + 1
IVCORR = 31
WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR
111 CONTINUE
IVTNUM = 11
C
C **** TEST 11 ****
C TEST 11 - THIS CHECKS FOR THE CORRECT END OF FILE CODE 9999
C ON RECORD NUMBER 31.
C
IF (ICZERO) 30110, 110, 30110
110 CONTINUE
IVCOMP = ITEST(7)
GO TO 40110
30110 IVDELE = IVDELE + 1
WRITE (I02,80003) IVTNUM
IF (ICZERO) 40110, 121, 40110
40110 IF ( IVCOMP - 9999 ) 20110, 10110, 20110
10110 IVPASS = IVPASS + 1
WRITE (I02,80001) IVTNUM
GO TO 121
20110 IVFAIL = IVFAIL + 1
IVCORR = 9999
WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR
121 CONTINUE
C THIS CODE IS OPTIONALLY COMPILED AND IS USED TO DUMP THE FILE 01
C TO THE LINE PRINTER.
CDB**
C ILUN = I06
C ITOTR = 31
C IRLGN = 80
C7777 REWIND ILUN
C DO 7778 IRNUM = 1, ITOTR
C READ (ILUN,77701) (IDUMP(ICHAR), ICHAR = 1, IRLGN)
C WRITE ( I02,77705) (IDUMP(ICHAR), ICHAR = 1, IRLGN)
C IF ( IDUMP(20) .EQ. NINE ) GO TO 7779
C7778 CONTINUE
C GO TO 7782
C7779 IF ( IRNUM - ITOTR ) 7780, 7781, 7782
C7780 WRITE (I02,77702) IRNUM,ILUN,ITOTR
C GO TO 7784
C7781 WRITE (I02,77703) ILUN,ITOTR
C GO TO 7784
C7782 WRITE (I02,77704) ILUN, ITOTR
C DO 7783 I = 1, 5
C READ (ILUN,77701) (IDUMP(ICHAR), ICHAR = 1, IRLGN)
C WRITE ( I02,77705) (IDUMP(ICHAR), ICHAR = 1, IRLGN)
C IF ( IDUMP(20) .EQ. NINE ) GO TO 7784
C7783 CONTINUE
C7784 GO TO 99999
CDE**
C WRITE PAGE FOOTINGS AND RUN SUMMARIES
99999 CONTINUE
WRITE (I02,90002)
WRITE (I02,90006)
WRITE (I02,90002)
WRITE (I02,90002)
WRITE (I02,90007)
WRITE (I02,90002)
WRITE (I02,90008) IVFAIL
WRITE (I02,90009) IVPASS
WRITE (I02,90010) IVDELE
C
C
C TERMINATE ROUTINE EXECUTION
STOP
C
C FORMAT STATEMENTS FOR PAGE HEADERS
90000 FORMAT (1H1)
90002 FORMAT (1H )
90001 FORMAT (1H ,10X,34HFORTRAN COMPILER VALIDATION SYSTEM)
90003 FORMAT (1H ,21X,11HVERSION 1.0)
90004 FORMAT (1H ,10X,38HFOR OFFICIAL USE ONLY - COPYRIGHT 1978)
90005 FORMAT (1H ,5X,4HTEST,5X,9HPASS/FAIL, 5X,8HCOMPUTED,8X,7HCORRECT)
90006 FORMAT (1H ,5X,46H----------------------------------------------)
90011 FORMAT (1H ,18X,17HSUBSET LEVEL TEST)
C
C FORMAT STATEMENTS FOR RUN SUMMARIES
90008 FORMAT (1H ,15X,I5,19H ERRORS ENCOUNTERED)
90009 FORMAT (1H ,15X,I5,13H TESTS PASSED)
90010 FORMAT (1H ,15X,I5,14H TESTS DELETED)
C
C FORMAT STATEMENTS FOR TEST RESULTS
80001 FORMAT (1H ,4X,I5,7X,4HPASS)
80002 FORMAT (1H ,4X,I5,7X,4HFAIL)
80003 FORMAT (1H ,4X,I5,7X,7HDELETED)
80004 FORMAT (1H ,4X,I5,7X,4HFAIL,10X,I6,9X,I6)
80005 FORMAT (1H ,4X,I5,7X,4HFAIL,4X,E12.5,3X,E12.5)
C
90007 FORMAT (1H ,20X,20HEND OF PROGRAM FM100)
END