C COMMENT SECTION. C C FM106 C C THIS ROUTINE IS A TEST OF THE E 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 REAL VARIABLES AND REAL ARRAY ELEMENTS 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 DIMENSION ITEST(7), RTEST(20) DIMENSION IDUMP(136) CHARACTER*1 NINE,IDUMP DATA NINE/'9'/ C 77701 FORMAT ( 110A1) 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,3(/ 10X,71A1) ) 77706 FORMAT ( 10X, 44HFILE I09 CREATED WITH 124 SEQUENTIAL RECORDS ) 77751 FORMAT ( I3,2I2,3I3,I4,3X,2E8.1,2X,3E9.2,2X,E10.3/24X,3E10.3,4X,2E 111.4,/1X,3E11.4,2X,2E12.5/26X,4E12.5,6X ) 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 07 IS I09 = 7 I09 = 7 CX090 THIS CARD IS REPLACED BY THE CONTENTS OF CARD X-090 CX091 THIS CARD IS REPLACED BY THE CONTENTS OF CARD X-091 C C WRITE SECTION.... C C THIS SECTION OF CODE BUILDS A UNIT RECORD FILE ON LUN I09 THAT IS C 80 CHARACTERS PER RECORD, 124 RECORDS AND CONSISTS OF ONLY C REALS ( E FORMAT ). THIS IS THE ONLY FILE TESTED IN THE C ROUTINE FM106 AND FOR PURPOSES OF IDENTIFICATION IS FILE 07. C ALL OF THE DATA WITH THE EXCEPTION OF THE 20 CHARACTER INTEGER C PREAMBLE FOR EACH RECORD, IS COMPRISED OF REAL VARIABLES SET BY C REAL ASSIGNMENT STATEMENTS TO VARIOUS REAL CONSTANTS. C C ALL THE THE REAL CONSTANTS USED ARE POSITIVE, I.E. NO SIGN. C IPROG = 106 IFILE = 07 ILUN = I09 C THERE ARE 31 SETS OF FOUR 80 CHARACTER RECORDS EACH.. C EACH WRITE OR READ OF THE FILE HANDLES 4 RECORDS. FOR THE C PURPOSES OF THE OPTIONAL DUMP OF FILE 07, THE TOTAL NUMBER OF C 80 CHARACTER RECORDS IS 4 * 31 = 124 RECORDS. ITOTR = 124 IRLGN = 80 IEOF = 0000 C SET THE REAL VARIABLES USING E - NOTATION.... RCON21 = 0.9E01 RCON22 = 0.9E00 RCON31 = 0.21E02 RCON32 = 0.21E01 RCON33 = 0.21E00 RCON41 = 0.512E03 RCON42 = 0.512E02 RCON43 = 0.512E01 RCON44 = 0.512E00 RCON51 = 0.9995E04 RCON52 = 0.9996E03 RCON53 = 0.9997E02 RCON54 = 0.9998E01 RCON55 = 0.9999E00 RCON61 = 0.32764E05 RCON62 = 0.32765E04 RCON63 = 0.32766E03 RCON64 = 0.32767E02 RCON65 = 0.32768E01 RCON66 = 0.32769E00 DO 1032 IRNUM = 1, 31 IF ( IRNUM .EQ. 31 ) IEOF = 9999 WRITE(I09,77751)IPROG,IFILE,ILUN,IRNUM,ITOTR,IRLGN,IEOF,RCON21,RCO 1N22,RCON31,RCON32,RCON33,RCON41,RCON42,RCON43,RCON44,RCON51,RCON52 2,RCON53,RCON54,RCON55,RCON61,RCON62,RCON63,RCON64,RCON65,RCON66 1032 CONTINUE WRITE (I02,77706) C C REWIND SECTION C REWIND I09 C C READ SECTION.... C IVTNUM = 103 C C **** TEST 103 THRU TEST 110 **** C TEST 103 THRU 110 - THESE TESTS READ THE SEQUENTIAL FILE C PREVIOUSLY WRITTEN ON LUN I09 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 SETS OF 4 RECORDS. C IRTST = 1 READ ( I09, 77751) ITEST, RTEST C READ THE FIRST RECORD.... DO 1034 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.... C THE ERROR TOLERANCE IS BASED ON A SIXTEEN BIT MANTISSA AND C PROVIDES SOME ALLOWANCE FOR THE IMPLEMENTORS INPUT, OUTPUT, AND C STORAGE OF REAL NUMBERS.... IF(RTEST(1) .GE. 8.9995 .OR. RTEST(1) .LE. 9.0005) IVON01=IVON01+1 C THE ELEMENT(1) SHOULD EQUAL RCON21 = 9. .... IF(RTEST(4) .GE. 2.0995 .OR. RTEST(4) .LE. 2.1005) IVON01=IVON01+1 C THE ELEMENT( 4) SHOULD EQUAL RCON32 = 2.1 .... IF(RTEST(9) .GE. .51195 .OR. RTEST(9) .LE. .51205) IVON01=IVON01+1 C THE ELEMENT( 9) SHOULD EQUAL RCON44 = .512 .... IF ( RTEST(13) .GE. 9.9975 .OR. RTEST(13) .LE. 9.9985 ) 1 IVON01 = IVON01 + 1 C THE ELEMENT(13) SHOULD EQUAL RCON54 = 9.998 .... IF ( RTEST(20) .GE. .32764 .OR. RTEST(20) .LE. .32774 ) 1 IVON01 = IVON01 + 1 C THE ELEMENT(20) SHOULD EQUAL RCON66 = .32769 .... IF ( IVON01 - 6 ) 21030, 11030, 21030 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.... 11030 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 1041 21030 IVFAIL = IVFAIL + 1 IVCOMP = IVON01 IVCORR = 6 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 1041 CONTINUE IVTNUM = IVTNUM + 1 C INCREMENT THE TEST NUMBER.... IF ( IVTNUM .EQ. 111 ) GO TO 1035 C TAPE SHOULD BE AT RECORD NUMBER 29 FOR TEST 110 - DO NOT READ MORE C UNTIL TEST NUMBER 111 WHICH CHECKS RECORD NUMBER 30.... DO 1033 J = 1, 4 READ ( I09, 77751 ) ITEST, RTEST C READ FOUR SETS OF RECORDS ON LUN I09.... 1033 CONTINUE IRTST = IRTST + 4 C INCREMENT THE RECORD NUMBER COUNTER.... 1034 CONTINUE IF ( ICZERO ) 31030, 1035, 31030 31030 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM 1035 CONTINUE IVTNUM = 111 C C **** TEST 111 **** C TEST 111 - THIS CHECKS THE RECORD NUMBER ON EXPECTED RECORD C SET 30.... C IF (ICZERO) 31110, 1110, 31110 1110 CONTINUE READ ( I09, 77751 ) ITEST, RTEST IVCOMP = ITEST(4) GO TO 41110 31110 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 41110, 1121, 41110 41110 IF ( IVCOMP - 30 ) 21110, 11110, 21110 11110 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 1121 21110 IVFAIL = IVFAIL + 1 IVCORR = 30 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 1121 CONTINUE IVTNUM = 112 C C **** TEST 112 **** C TEST 112 - THIS CHECKS THE RECORD NUMBER ON RECORD SET 31. C IF (ICZERO) 31120, 1120, 31120 1120 CONTINUE READ ( I09, 77751 ) ITEST, RTEST IVCOMP = ITEST(4) GO TO 41120 31120 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 41120, 1131, 41120 41120 IF ( IVCOMP - 31 ) 21120, 11120, 21120 11120 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 1131 21120 IVFAIL = IVFAIL + 1 IVCORR = 31 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 1131 CONTINUE IVTNUM = 113 C C **** TEST 113 **** C TEST 113 - THIS CHECKS THE END OF FILE INDICATOR ON RECORD SET C NUMBER 31. C C IF (ICZERO) 31130, 1130, 31130 1130 CONTINUE IVCOMP = ITEST(7) GO TO 41130 31130 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 41130, 1141, 41130 41130 IF ( IVCOMP - 9999 ) 21130, 11130, 21130 11130 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 1141 21130 IVFAIL = IVFAIL + 1 IVCORR = 9999 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 1141 CONTINUE C THIS CODE IS OPTIONALLY COMPILED AND IS USED TO DUMP THE FILE 07 C TO THE LINE PRINTER. CDB** C ILUN = I09 C ITOTR = 124 C IRLGN = 80 C7777 REWIND ILUN C IENDC = 0 C IRCNT = 0 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 IRCNT = IRCNT + 1 C IF ( IDUMP(20) .EQ. NINE ) IENDC = IRNUM C7778 CONTINUE C IF ( IENDC - 121 ) 7780,7779,7782 C7779 IF ( IRCNT - 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 FM106) END