blob: fef43ed843af563a214f62b69dd6cd3f9be79e23 [file] [log] [blame]
PROGRAM FM100
C COMMENT SECTION. 00010100
C 00020100
C FM100 00030100
C 00040100
C THIS ROUTINE IS A TEST OF THE I FORMAT AND IS TAPE AND PRINTER00050100
C ORIENTED. THE ROUTINE CAN ALSO BE USED FOR DISK. BOTH THE READ 00060100
C AND WRITE STATEMENTS ARE TESTED. VARIABLES IN THE INPUT AND 00070100
C OUTPUT LISTS ARE INTEGER VARIABLE AND INTEGER ARRAY ELEMENT OR 00080100
C ARRAY NAME REFERENCES. ALL READ AND WRITE STATEMENTS ARE DONE 00090100
C WITH FORMAT STATEMENTS. THE ROUTINE HAS AN OPTIONAL SECTION OF 00100100
C CODE TO DUMP THE FILE AFTER IT HAS BEEN WRITTEN. DO LOOPS AND 00110100
C DO-IMPLIED LISTS ARE USED IN CONJUNCTION WITH A ONE DIMENSIONAL 00120100
C INTEGER ARRAY FOR THE DUMP SECTION. 00130100
C 00140100
C THIS ROUTINE WRITES A SINGLE SEQUENTIAL FILE WHICH IS 00150100
C REWOUND AND READ SEQUENTIALLY FORWARD. EVERY FOURTH RECORD IS 00160100
C CHECKED DURING THE READ TEST SECTION PLUS THE LAST TWO RECORDS 00170100
C AND THE END OF FILE ON THE LAST RECORD. 00180100
C 00190100
C THE LINE CONTINUATION IN COLUMN 6 IS USED IN READ, WRITE, 00200100
C AND FORMAT STATEMENTS. FOR BOTH SYNTAX AND SEMANTIC TESTS, ALL 00210100
C STATEMENTS SHOULD BE CHECKED VISUALLY FOR THE PROPER FUNCTIONING 00220100
C OF THE CONTINUATION LINE. 00230100
C 00240100
C REFERENCES 00250100
C AMERICAN NATIONAL STANDARD PROGRAMMING LANGUAGE FORTRAN, 00260100
C X3.9-1978 00270100
C 00280100
C SECTION 8, SPECIFICATION STATEMENTS 00290100
C SECTION 9, DATA STATEMENT 00300100
C SECTION 11.10, DO STATEMENT 00310100
C SECTION 12, INPUT/OUTPUT STATEMENTS 00320100
C SECTION 12.8.2, INPUT/OUTPUT LIST 00330100
C SECTION 12.9.5.2, FORMATTED DATA TRANSFER 00340100
C SECTION 13, FORMAT STATEMENT 00350100
C SECTION 13.2.1, EDIT DESCRIPTORS 00360100
C SECTION 13.5.9.1, INTEGER EDITING 00370100
C 00380100
DIMENSION ITEST(30) 00390100
DIMENSION IDUMP(136) 00400100
CHARACTER*1 NINE,IDUMP 00410100
DATA NINE/'9'/ 00420100
C 00430100
77701 FORMAT ( 80A1 ) 00440100
77702 FORMAT (10X,"PREMATURE EOF ONLY " ,I3," RECORDS LUN " ,I2, " OUT O00450100
1F ",I3," RECORDS") 00460100
77703 FORMAT (10X,"FILE ON LUN " ,I2," OK... ",I3," RECORDS") 00470100
77704 FORMAT (10X,"FILE ON LUN " ,I2," TOO LONG MORE THAN " ,I3, " RECOR00480100
1DS") 00490100
77705 FORMAT ( 1X,80A1) 00500100
77706 FORMAT (10X,"FILE I06 CREATED WITH 31 SEQUENTIAL RECORDS" ) 00510100
77751 FORMAT (I3,I2,I2,I3,I3,I3,I4,I1,I1,I1,I1,I1,I1,I1,I1,I1,I1,I2,I2,I00520100
13,I3,I4,I4,I4,I4,I4,I5,I5,I5,I5) 00530100
C 00540100
C 00550100
C ********************************************************** 00560100
C 00570100
C A COMPILER VALIDATION SYSTEM FOR THE FORTRAN LANGUAGE 00580100
C BASED ON SPECIFICATIONS AS DEFINED IN AMERICAN NATIONAL STANDARD 00590100
C PROGRAMMING LANGUAGE FORTRAN X3.9-1978, HAS BEEN DEVELOPED BY THE 00600100
C FEDERAL COBOL COMPILER TESTING SERVICE. THE FORTRAN COMPILER 00610100
C VALIDATION SYSTEM (FCVS) CONSISTS OF AUDIT ROUTINES, THEIR RELATED00620100
C DATA, AND AN EXECUTIVE SYSTEM. EACH AUDIT ROUTINE IS A FORTRAN 00630100
C PROGRAM, SUBPROGRAM OR FUNCTION WHICH INCLUDES TESTS OF SPECIFIC 00640100
C LANGUAGE ELEMENTS AND SUPPORTING PROCEDURES INDICATING THE RESULT 00650100
C OF EXECUTING THESE TESTS. 00660100
C 00670100
C THIS PARTICULAR PROGRAM/SUBPROGRAM/FUNCTION CONTAINS FEATURES 00680100
C FOUND ONLY IN THE SUBSET AS DEFINED IN X3.9-1978. 00690100
C 00700100
C SUGGESTIONS AND COMMENTS SHOULD BE FORWARDED TO - 00710100
C 00720100
C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 00730100
C SOFTWARE STANDARDS VALIDATION GROUP 00740100
C BUILDING 225 RM A266 00750100
C GAITHERSBURG, MD 20899 00760100
C ********************************************************** 00770100
C 00780100
C 00790100
C 00800100
C INITIALIZATION SECTION 00810100
C 00820100
C INITIALIZE CONSTANTS 00830100
C ************** 00840100
C I01 CONTAINS THE LOGICAL UNIT NUMBER FOR THE CARD READER. 00850100
I01 = 5 00860100
C I02 CONTAINS THE LOGICAL UNIT NUMBER FOR THE PRINTER. 00870100
I02 = 6 00880100
C SYSTEM ENVIRONMENT SECTION 00890100
C 00900100
CX010 THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-010 CONTROL CARD. 00910100
C THE CX010 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I01 = 5 00920100
C (UNIT NUMBER FOR CARD READER). 00930100
CX011 THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-011 CONTROL CARD. 00940100
C THE CX011 CARD IS FOR SYSTEMS WHICH REQUIRE ADDITIONAL 00950100
C FORTRAN STATEMENTS FOR FILES ASSOCIATED WITH CX010 ABOVE. 00960100
C 00970100
CX020 THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-020 CONTROL CARD. 00980100
C THE CX020 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I02 = 6 00990100
C (UNIT NUMBER FOR PRINTER). 01000100
CX021 THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-021 CONTROL CARD. 01010100
C THE CX021 CARD IS FOR SYSTEMS WHICH REQUIRE ADDITIONAL 01020100
C FORTRAN STATEMENTS FOR FILES ASSOCIATED WITH CX020 ABOVE. 01030100
C 01040100
IVPASS=0 01050100
IVFAIL=0 01060100
IVDELE=0 01070100
ICZERO=0 01080100
C 01090100
C WRITE PAGE HEADERS 01100100
WRITE (I02,90000) 01110100
WRITE (I02,90001) 01120100
WRITE (I02,90002) 01130100
WRITE (I02, 90002) 01140100
WRITE (I02,90003) 01150100
WRITE (I02,90002) 01160100
WRITE (I02,90004) 01170100
WRITE (I02,90002) 01180100
WRITE (I02,90011) 01190100
WRITE (I02,90002) 01200100
WRITE (I02,90002) 01210100
WRITE (I02,90005) 01220100
WRITE (I02,90006) 01230100
WRITE (I02,90002) 01240100
C 01250100
C DEFAULT ASSIGNMENT FOR FILE 01 IS I06 = 7 01260100
I06 = 93 01270100
CX060 THIS CARD IS REPLACED BY THE CONTENTS OF CARD X-060 01280100
CX061 THIS CARD IS REPLACED BY THE CONTENTS OF CARD X-061 01290100
C 01300100
C WRITE SECTION.... 01310100
C 01320100
C THIS SECTION OF CODE BUILDS A UNIT RECORD FILE ON LUN I06 THAT IS 01330100
C 80 CHARACTERS PER RECORD, 31 RECORDS LONG, AND CONSISTS OF ONLY 01340100
C INTEGERS ( I FORMAT ). THIS IS THE ONLY FILE TESTED IN THE 01350100
C ROUTINE FM100 AND FOR PURPOSES OF IDENTIFICATION IS FILE 01. 01360100
C ALL OF THE DATA WITH THE EXCEPTION OF THE RECORD NUMBER - IRNUM , 01370100
C INTEGER VARIABLE ICON31 WHICH IS SET TO THE VALUE OF THE RECORD 01380100
C NUMBER, AND THE END OF FILE CHECK - IEOF IS SET BY INTEGER 01390100
C ASSIGNMENT STATEMENTS TO VARIOUS INTEGER CONSTANTS. 01400100
IPROG = 100 01410100
IFILE = 01 01420100
ILUN = I06 01430100
ITOTR = 31 01440100
IRLGN = 80 01450100
IEOF = 0000 01460100
ICON11 = 1 01470100
ICON12 = 2 01480100
ICON13 = 3 01490100
ICON14 = 4 01500100
ICON15 = 5 01510100
ICON16 = 6 01520100
ICON17 = 7 01530100
ICON18 = 8 01540100
ICON19 = 9 01550100
ICON10 = 0 01560100
ICON21 = 21 01570100
ICON22 = 22 01580100
ICON32 = 512 01590100
ICON41 = 9995 01600100
ICON42 = 9996 01610100
ICON43 = 9997 01620100
ICON44 = 9998 01630100
ICON45 = 9999 01640100
ICON51 = 32764 01650100
ICON52 = 32765 01660100
ICON53 = 32766 01670100
ICON54 = 32767 01680100
DO 12 IRNUM = 1, 31 01690100
ICON31 = IRNUM 01700100
IF ( IRNUM .EQ. 31 ) IEOF = 9999 01710100
WRITE(I06,77751)IPROG,IFILE,ILUN,IRNUM,ITOTR,IRLGN,IEOF,ICON11,ICO01720100
1N12,ICON13,ICON14,ICON15,ICON16,ICON17,ICON18,ICON19,ICON10,ICON2101730100
2,ICON22,ICON31,ICON32,ICON41,ICON42,ICON43,ICON44,ICON45,ICON51,IC01740100
3ON52,ICON53,ICON54 01750100
12 CONTINUE 01760100
WRITE (I02,77706) 01770100
C 01780100
C REWIND SECTION 01790100
C 01800100
REWIND I06 01810100
C 01820100
C READ SECTION.... 01830100
C 01840100
IVTNUM = 1 01850100
C 01860100
C **** TEST 1 THRU TEST 8 **** 01870100
C TEST 1 THRU TEST 8 - THESE TESTS READ THE SEQUENTIAL FILE 01880100
C PREVIOUSLY WRITTEN ON LUN I06 AND CHECK THE FIRST AND EVERY FOURTH01890100
C RECORD. THE VALUES CHECKED ARE THE RECORD NUMBER - IRNUM AND 01900100
C SEVERAL VALUES WHICH SHOULD REMAIN CONSTANT FOR ALL OF THE 31 01910100
C RECORDS. 01920100
C 01930100
IRTST = 1 01940100
READ(I06,77751) ITEST 01950100
C READ THE FIRST RECORD.... 01960100
DO 23 I = 1, 8 01970100
IVON01 = 0 01980100
C THE INTEGER VARIABLE IS INITIALIZED TO ZERO FOR EACH TEST 1 THRU 801990100
IF ( ITEST(4) .EQ. IRTST ) IVON01 = IVON01 + 1 02000100
C THE ELEMENT (4) SHOULD EQUAL THE RECORD NUMBER.... 02010100
IF ( ITEST(8) .EQ. ICON11 ) IVON01 = IVON01 + 1 02020100
C THE ELEMENT (8) SHOULD EQUAL ICON11 = 1.... 02030100
IF ( ITEST(18) .EQ. ICON21 ) IVON01 = IVON01 + 1 02040100
C THE ELEMENT (18) SHOULD EQUAL ICON21 = 21.... 02050100
IF ( ITEST(20) .EQ. IRTST ) IVON01 = IVON01 + 1 02060100
C THE ELEMENT (20) SHOULD ALSO EQUAL THE RECORD NUMBER.... 02070100
IF ( ITEST(26) .EQ. ICON45 ) IVON01 = IVON01 + 1 02080100
C THE ELEMENT (26. SHOULD EQUAL ICON45 = 9999.... 02090100
IF ( ITEST(30) .EQ. ICON54 ) IVON01 = IVON01 + 1 02100100
C THE ELEMENT (30) SHOULD EQUAL ICON54 = 32767.... 02110100
IF ( IVON01 - 6 ) 20010, 10010, 20010 02120100
C WHEN IVON01 = 6 THEN ALL SIX OF THE ITEST ELEMENTS THAT WERE 02130100
C CHECKED HAD THE EXPECTED VALUES.... IF IVON01 DOES NOT EQUAL 6 02140100
C THEN AT LEAST ONE OF THE VALUES WAS INCORRECT.... 02150100
10010 IVPASS = IVPASS + 1 02160100
WRITE (I02,80001) IVTNUM 02170100
GO TO 21 02180100
20010 IVFAIL = IVFAIL + 1 02190100
IVCOMP = IVON01 02200100
IVCORR = 6 02210100
WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 02220100
21 CONTINUE 02230100
IVTNUM = IVTNUM + 1 02240100
C INCREMENT THE TEST NUMBER.... 02250100
IF ( IVTNUM .EQ. 9 ) GO TO 91 02260100
C TAPE SHOULD BE AT RECORD NUMBER 29 FOR TEST 8 - DO NOT READ MORE02270100
C UNTIL TEST NUMBER NINE WHICH CHECKS RECORD NUMBER 30.... 02280100
DO 22 J = 1, 4 02290100
READ(I06,77751) ITEST 02300100
C READ FOUR RECORDS ON LUN I06.... 02310100
22 CONTINUE 02320100
IRTST = IRTST + 4 02330100
C INCREMENT THE RECORD NUMBER COUNTER.... 02340100
23 CONTINUE 02350100
IF (ICZERO) 30010, 91, 30010 02360100
30010 IVDELE = IVDELE + 1 02370100
WRITE (I02,80003) IVTNUM 02380100
91 CONTINUE 02390100
IVTNUM = 9 02400100
C 02410100
C **** TEST 9 **** 02420100
C TEST 9 - THIS CHECKS THE RECORD NUMBER ON EXPECTED RECORD 30. 02430100
C 02440100
IF (ICZERO) 30090, 90, 30090 02450100
90 CONTINUE 02460100
READ ( I06, 77751 ) ITEST 02470100
IVCOMP = ITEST(4) 02480100
GO TO 40090 02490100
30090 IVDELE = IVDELE + 1 02500100
WRITE (I02,80003) IVTNUM 02510100
IF (ICZERO) 40090, 101, 40090 02520100
40090 IF ( IVCOMP - 30 ) 20090, 10090, 20090 02530100
10090 IVPASS = IVPASS + 1 02540100
WRITE (I02,80001) IVTNUM 02550100
GO TO 101 02560100
20090 IVFAIL = IVFAIL + 1 02570100
IVCORR = 30 02580100
WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 02590100
101 CONTINUE 02600100
IVTNUM = 10 02610100
C 02620100
C **** TEST 10 **** 02630100
C TEST 10 - THIS CHECKS THE RECORD NUMBER ON EXPECTED RECORD 31. 02640100
C 02650100
IF (ICZERO) 30100, 100, 30100 02660100
100 CONTINUE 02670100
READ ( I06,77751) ITEST 02680100
IVCOMP = ITEST(4) 02690100
GO TO 40100 02700100
30100 IVDELE = IVDELE + 1 02710100
WRITE (I02,80003) IVTNUM 02720100
IF (ICZERO) 40100, 111, 40100 02730100
40100 IF ( IVCOMP - 31 ) 20100, 10100, 20100 02740100
10100 IVPASS = IVPASS + 1 02750100
WRITE (I02,80001) IVTNUM 02760100
GO TO 111 02770100
20100 IVFAIL = IVFAIL + 1 02780100
IVCORR = 31 02790100
WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 02800100
111 CONTINUE 02810100
IVTNUM = 11 02820100
C 02830100
C **** TEST 11 **** 02840100
C TEST 11 - THIS CHECKS FOR THE CORRECT END OF FILE CODE 9999 02850100
C ON RECORD NUMBER 31. 02860100
C 02870100
IF (ICZERO) 30110, 110, 30110 02880100
110 CONTINUE 02890100
IVCOMP = ITEST(7) 02900100
GO TO 40110 02910100
30110 IVDELE = IVDELE + 1 02920100
WRITE (I02,80003) IVTNUM 02930100
IF (ICZERO) 40110, 121, 40110 02940100
40110 IF ( IVCOMP - 9999 ) 20110, 10110, 20110 02950100
10110 IVPASS = IVPASS + 1 02960100
WRITE (I02,80001) IVTNUM 02970100
GO TO 121 02980100
20110 IVFAIL = IVFAIL + 1 02990100
IVCORR = 9999 03000100
WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 03010100
121 CONTINUE 03020100
C THIS CODE IS OPTIONALLY COMPILED AND IS USED TO DUMP THE FILE 01 03030100
C TO THE LINE PRINTER. 03040100
CDB** 03050100
C ILUN = I06 03060100
C ITOTR = 31 03070100
C IRLGN = 80 03080100
C7777 REWIND ILUN 03090100
C DO 7778 IRNUM = 1, ITOTR 03100100
C READ (ILUN,77701) (IDUMP(ICHAR), ICHAR = 1, IRLGN) 03110100
C WRITE ( I02,77705) (IDUMP(ICHAR), ICHAR = 1, IRLGN) 03120100
C IF ( IDUMP(20) .EQ. NINE ) GO TO 7779 03130100
C7778 CONTINUE 03140100
C GO TO 7782 03150100
C7779 IF ( IRNUM - ITOTR ) 7780, 7781, 7782 03160100
C7780 WRITE (I02,77702) IRNUM,ILUN,ITOTR 03170100
C GO TO 7784 03180100
C7781 WRITE (I02,77703) ILUN,ITOTR 03190100
C GO TO 7784 03200100
C7782 WRITE (I02,77704) ILUN, ITOTR 03210100
C DO 7783 I = 1, 5 03220100
C READ (ILUN,77701) (IDUMP(ICHAR), ICHAR = 1, IRLGN) 03230100
C WRITE ( I02,77705) (IDUMP(ICHAR), ICHAR = 1, IRLGN) 03240100
C IF ( IDUMP(20) .EQ. NINE ) GO TO 7784 03250100
C7783 CONTINUE 03260100
C7784 GO TO 99999 03270100
CDE** 03280100
C WRITE PAGE FOOTINGS AND RUN SUMMARIES 03290100
99999 CONTINUE 03300100
WRITE (I02,90002) 03310100
WRITE (I02,90006) 03320100
WRITE (I02,90002) 03330100
WRITE (I02,90002) 03340100
WRITE (I02,90007) 03350100
WRITE (I02,90002) 03360100
WRITE (I02,90008) IVFAIL 03370100
WRITE (I02,90009) IVPASS 03380100
WRITE (I02,90010) IVDELE 03390100
C 03400100
C 03410100
C TERMINATE ROUTINE EXECUTION 03420100
STOP 03430100
C 03440100
C FORMAT STATEMENTS FOR PAGE HEADERS 03450100
90000 FORMAT ("1") 03460100
90002 FORMAT (" ") 03470100
90001 FORMAT (" ",10X,"FORTRAN COMPILER VALIDATION SYSTEM" ) 03480100
90003 FORMAT (" ",21X,"VERSION 2.1" ) 03490100
90004 FORMAT (" ",10X,"FOR OFFICIAL USE ONLY - COPYRIGHT 1978" ) 03500100
90005 FORMAT (" ",5X,"TEST",5X,"PASS/FAIL", 5X,"COMPUTED",8X,"CORRECT") 03510100
90006 FORMAT (" ",5X,"----------------------------------------------" ) 03520100
90011 FORMAT (" ",18X,"SUBSET LEVEL TEST" ) 03530100
C 03540100
C FORMAT STATEMENTS FOR RUN SUMMARIES 03550100
90008 FORMAT (" ",15X,I5," ERRORS ENCOUNTERED" ) 03560100
90009 FORMAT (" ",15X,I5," TESTS PASSED" ) 03570100
90010 FORMAT (" ",15X,I5," TESTS DELETED" ) 03580100
C 03590100
C FORMAT STATEMENTS FOR TEST RESULTS 03600100
80001 FORMAT (" ",4X,I5,7X,"PASS") 03610100
80002 FORMAT (" ",4X,I5,7X,"FAIL") 03620100
80003 FORMAT (" ",4X,I5,7X,"DELETED") 03630100
80004 FORMAT (" ",4X,I5,7X,"FAIL",10X,I6,9X,I6) 03640100
80005 FORMAT (" ",4X,I5,7X,"FAIL",4X,E12.5,3X,E12.5) 03650100
C 03660100
90007 FORMAT (" ",20X,"END OF PROGRAM FM100" ) 03670100
END 03680100