|
|
1.1 root 1: C COMMENT SECTION. 00010101
2: C DATE***82/08/02*18.33.46
3: C OWNER PRE/850703/TC-85- -410/ /FSTC/278FCVS*F78UBP20/
4: C AUDIT FCVS78 V2.0
5: C 00020101
6: C FM101 00030101
7: C 00040101
8: C THIS ROUTINE IS A TEST OF THE F FORMAT AND IS TAPE AND PRINTER00050101
9: C ORIENTED. THE ROUTINE CAN ALSO BE USED FOR DISK. BOTH THE READ 00060101
10: C AND WRITE STATEMENTS ARE TESTED. VARIABLES IN THE INPUT AND 00070101
11: C OUTPUT LISTS ARE REAL VARIABLES AND REAL ARRAY ELEMENTS OR 00080101
12: C ARRAY NAME REFERENCES. ALL READ AND WRITE STATEMENTS ARE DONE 00090101
13: C WITH FORMAT STATEMENTS. THE ROUTINE HAS AN OPTIONAL SECTION OF 00100101
14: C CODE TO DUMP THE FILE AFTER IT HAS BEEN WRITTEN. DO LOOPS AND 00110101
15: C DO-IMPLIED LISTS ARE USED IN CONJUNCTION WITH A ONE DIMENSIONAL 00120101
16: C INTEGER ARRAY FOR THE DUMP SECTION. 00130101
17: C 00140101
18: C THIS ROUTINE WRITES A SINGLE SEQUENTIAL FILE WHICH IS 00150101
19: C REWOUND AND READ SEQUENTIALLY FORWARD. EVERY FOURTH RECORD IS 00160101
20: C CHECKED DURING THE READ TEST SECTION PLUS THE LAST TWO RECORDS 00170101
21: C AND THE END OF FILE ON THE LAST RECORD. 00180101
22: C 00190101
23: C THE LINE CONTINUATION IN COLUMN 6 IS USED IN READ, WRITE, 00200101
24: C AND FORMAT STATEMENTS. FOR BOTH SYNTAX AND SEMANTIC TESTS, ALL 00210101
25: C STATEMENTS SHOULD BE CHECKED VISUALLY FOR THE PROPER FUNCTIONING 00220101
26: C OF THE CONTINUATION LINE. 00230101
27: C 00240101
28: C REFERENCES 00250101
29: C AMERICAN NATIONAL STANDARD PROGRAMMING LANGUAGE FORTRAN, 00260101
30: C X3.9-1978 00270101
31: C 00280101
32: C SECTION 8, SPECIFICATION STATEMENTS 00290101
33: C SECTION 9, DATA STATEMENT 00300101
34: C SECTION 11.10, DO STATEMENT 00310101
35: C SECTION 12, INPUT/OUTPUT STATEMENTS 00320101
36: C SECTION 12.8.2, INPUT/OUTPUT LIST 00330101
37: C SECTION 12.9.5.2, FORMATTED DATA TRANSFER 00340101
38: C SECTION 13, FORMAT STATEMENT 00350101
39: C SECTION 13.2.1, EDIT DESCRIPTORS 00360101
40: C 00370101
41: DIMENSION ITEST(7), RTEST(20) 00380101
42: DIMENSION IDUMP(136) 00390101
43: CHARACTER*1 NINE,IDUMP 00400101
44: DATA NINE/'9'/ 00410101
45: C 00420101
46: 77701 FORMAT ( 110A1) 00430101
47: 77702 FORMAT (10X,19HPREMATURE EOF ONLY ,I3,13H RECORDS LUN ,I2,8H OUT O00440101
48: 1F ,I3,8H RECORDS) 00450101
49: 77703 FORMAT (10X,12HFILE ON LUN ,I2,7H OK... ,I3,8H RECORDS) 00460101
50: 77704 FORMAT (10X,12HFILE ON LUN ,I2,20H TOO LONG MORE THAN ,I3,8H RECOR00470101
51: 1DS) 00480101
52: 77705 FORMAT ( 1X,80A1 / 10X, 30A1) 00490101
53: 77706 FORMAT (10X,43HFILE I07 CREATED WITH 31 SEQUENTIAL RECORDS) 00500101
54: 77751 FORMAT (I3,2I2,3I3,I4,F2.0,F2.1,F3.0,F3.1,F3.2,F4.0,F4.1,F4.2,F4.300510101
55: 1,F5.0,F5.1,F5.2,F5.3,F5.4,F6.0,F6.1,F6.2,F6.3,F6.4,F6.5 ) 00520101
56: C 00530101
57: C 00540101
58: C ********************************************************** 00550101
59: C 00560101
60: C A COMPILER VALIDATION SYSTEM FOR THE FORTRAN LANGUAGE 00570101
61: C BASED ON SPECIFICATIONS AS DEFINED IN AMERICAN NATIONAL STANDARD 00580101
62: C PROGRAMMING LANGUAGE FORTRAN X3.9-1978, HAS BEEN DEVELOPED BY THE 00590101
63: C FEDERAL COBOL COMPILER TESTING SERVICE. THE FORTRAN COMPILER 00600101
64: C VALIDATION SYSTEM (FCVS) CONSISTS OF AUDIT ROUTINES, THEIR RELATED00610101
65: C DATA, AND AN EXECUTIVE SYSTEM. EACH AUDIT ROUTINE IS A FORTRAN 00620101
66: C PROGRAM, SUBPROGRAM OR FUNCTION WHICH INCLUDES TESTS OF SPECIFIC 00630101
67: C LANGUAGE ELEMENTS AND SUPPORTING PROCEDURES INDICATING THE RESULT 00640101
68: C OF EXECUTING THESE TESTS. 00650101
69: C 00660101
70: C THIS PARTICULAR PROGRAM/SUBPROGRAM/FUNCTION CONTAINS FEATURES 00670101
71: C FOUND ONLY IN THE SUBSET AS DEFINED IN X3.9-1978. 00680101
72: C 00690101
73: C SUGGESTIONS AND COMMENTS SHOULD BE FORWARDED TO - 00700101
74: C 00710101
75: C DEPARTMENT OF THE NAVY 00720101
76: C FEDERAL COBOL COMPILER TESTING SERVICE 00730101
77: C WASHINGTON, D.C. 20376 00740101
78: C 00750101
79: C ********************************************************** 00760101
80: C 00770101
81: C 00780101
82: C 00790101
83: C INITIALIZATION SECTION 00800101
84: C 00810101
85: C INITIALIZE CONSTANTS 00820101
86: C ************** 00830101
87: C I01 CONTAINS THE LOGICAL UNIT NUMBER FOR THE CARD READER. 00840101
88: I01 = 5 00850101
89: C I02 CONTAINS THE LOGICAL UNIT NUMBER FOR THE PRINTER. 00860101
90: I02 = 6 00870101
91: C SYSTEM ENVIRONMENT SECTION 00880101
92: C 00890101
93: I01 = 5 00900101
94: C THE CX010 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I01 = 5 00910101
95: C (UNIT NUMBER FOR CARD READER). 00920101
96: CX011 THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-011 CONTROL CARD. 00930101
97: C THE CX011 CARD IS FOR SYSTEMS WHICH REQUIRE ADDITIONAL 00940101
98: C FORTRAN STATEMENTS FOR FILES ASSOCIATED WITH CX010 ABOVE. 00950101
99: C 00960101
100: I02 = 6 00970101
101: C THE CX020 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I02 = 6 00980101
102: C (UNIT NUMBER FOR PRINTER). 00990101
103: CX021 THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-021 CONTROL CARD. 01000101
104: C THE CX021 CARD IS FOR SYSTEMS WHICH REQUIRE ADDITIONAL 01010101
105: C FORTRAN STATEMENTS FOR FILES ASSOCIATED WITH CX020 ABOVE. 01020101
106: C 01030101
107: IVPASS=0 01040101
108: IVFAIL=0 01050101
109: IVDELE=0 01060101
110: ICZERO=0 01070101
111: C 01080101
112: C WRITE PAGE HEADERS 01090101
113: WRITE (I02,90000) 01100101
114: WRITE (I02,90001) 01110101
115: WRITE (I02,90002) 01120101
116: WRITE (I02, 90002) 01130101
117: WRITE (I02,90003) 01140101
118: WRITE (I02,90002) 01150101
119: WRITE (I02,90004) 01160101
120: WRITE (I02,90002) 01170101
121: WRITE (I02,90011) 01180101
122: WRITE (I02,90002) 01190101
123: WRITE (I02,90002) 01200101
124: WRITE (I02,90005) 01210101
125: WRITE (I02,90006) 01220101
126: WRITE (I02,90002) 01230101
127: C 01240101
128: I07 = 7 01250101
129: C DEFAULT ASSIGNMENT FOR FILE 02 IS I07 = 7 01260101
130: C 01270101
131: OPEN(UNIT=I07,ACCESS='SEQUENTIAL',FORM='FORMATTED') 01280101
132: CX071 THIS CARD IS REPLACED BY THE CONTENTS OF CARD X-071 01290101
133: C WRITE SECTION.... 01300101
134: C 01310101
135: C THIS SECTION OF CODE BUILDS A UNIT RECORD FILE ON LUN I07 THAT IS 01320101
136: C 110 CHARS. PER RECORD, 31 RECORDS LONG, AND CONSISTS OF ONLY 01330101
137: C REALS ( F FORMAT ). THIS IS THE ONLY FILE TESTED IN THE 01340101
138: C ROUTINE FM101 AND FOR PURPOSES OF IDENTIFICATION IS FILE 02. 01350101
139: C ALL OF THE DATA WITH THE EXCEPTION OF THE 20 CHARACTER INTEGER 01360101
140: C PREAMBLE FOR EACH RECORD, IS COMPRISED OF REAL VARIABLES SET BY 01370101
141: C REAL ASSIGNMENT STATEMENTS TO VARIOUS REAL CONSTANTS. 01380101
142: C 01390101
143: C ALL THE THE REAL CONSTANTS USED ARE POSITIVE, I.E. NO SIGN. 01400101
144: C 01410101
145: IPROG = 101 01420101
146: IFILE = 02 01430101
147: ILUN = I07 01440101
148: ITOTR = 31 01450101
149: IRLGN = 110 01460101
150: IEOF = 0000 01470101
151: RCON21 = 9. 01480101
152: RCON22 = .9 01490101
153: RCON31 = 21. 01500101
154: RCON32 = 2.1 01510101
155: RCON33 = .21 01520101
156: RCON41 = 512. 01530101
157: RCON42 = 51.2 01540101
158: RCON43 = 5.12 01550101
159: RCON44 = .512 01560101
160: RCON51 = 9995. 01570101
161: RCON52 = 999.6 01580101
162: RCON53 = 99.97 01590101
163: RCON54 = 9.998 01600101
164: RCON55 = .9999 01610101
165: RCON61 = 32764. 01620101
166: RCON62 = 3276.5 01630101
167: RCON63 = 327.66 01640101
168: RCON64 = 32.767 01650101
169: RCON65 = 3.2768 01660101
170: RCON66 = .32769 01670101
171: DO 122 IRNUM = 1, 31 01680101
172: IF ( IRNUM .EQ. 31 ) IEOF = 9999 01690101
173: WRITE(I07,77751)IPROG,IFILE,ILUN,IRNUM,ITOTR,IRLGN,IEOF,RCON21,RCO01700101
174: 1N22,RCON31,RCON32,RCON33,RCON41,RCON42,RCON43,RCON44,RCON51,RCON5201710101
175: 2,RCON53,RCON54,RCON55,RCON61,RCON62,RCON63,RCON64,RCON65,RCON66 01720101
176: 122 CONTINUE 01730101
177: WRITE (I02,77706) 01740101
178: C 01750101
179: C REWIND SECTION 01760101
180: C 01770101
181: REWIND I07 01780101
182: C 01790101
183: C READ SECTION.... 01800101
184: C 01810101
185: IVTNUM = 12 01820101
186: C 01830101
187: C **** TEST 12 THRU TEST 19 **** 01840101
188: C TEST 12 THRU TEST 19 - THESE TESTS READ THE SEQUENTIAL FILE 01850101
189: C PREVIOUSLY WRITTEN ON LUN I07 AND CHECK THE FIRST AND EVERY FOURTH01860101
190: C RECORD. THE VALUES CHECKED ARE THE RECORD NUMBER - IRNUM AND 01870101
191: C SEVERAL VALUES WHICH SHOULD REMAIN CONSTANT FOR ALL OF THE 31 01880101
192: C RECORDS. 01890101
193: C 01900101
194: IRTST = 1 01910101
195: READ ( I07, 77751) ITEST, RTEST 01920101
196: C READ THE FIRST RECORD.... 01930101
197: DO 193 I = 1, 8 01940101
198: IVON01 = 0 01950101
199: C THE INTEGER VARIABLE IS INITIALIZED TO ZERO FOR EACH TEST 1 THRU 801960101
200: IF ( ITEST(4) .EQ. IRTST ) IVON01 = IVON01 + 1 01970101
201: C THE ELEMENT (4) SHOULD EQUAL THE RECORD NUMBER.... 01980101
202: C THE TOLERANCE GIVEN IN THE REAL COMPARISONS IS BASED ON 16 BIT01990101
203: C MANTISSAS TO ALLOW FOR INPUT, OUTPUT, AND STORAGE CONVERSION, 02000101
204: C TRUNCATION, OR ROUNDING TECHNIQUES USED BY THE IMPLEMENTOR. 02010101
205: IF(RTEST(1) .GE. 8.9995 .OR. RTEST(1) .LE. 9.0005) IVON01=IVON01+102020101
206: C THE ELEMENT(1) SHOULD EQUAL RCON21 = 9. .... 02030101
207: IF(RTEST(4) .GE. 2.0995 .OR. RTEST(4) .LE. 2.1005) IVON01=IVON01+102040101
208: C THE ELEMENT( 4) SHOULD EQUAL RCON32 = 2.1 .... 02050101
209: IF(RTEST(9) .GE. .51195 .OR. RTEST(9) .LE. .51205) IVON01=IVON01+102060101
210: C THE ELEMENT( 9) SHOULD EQUAL RCON44 = .512 .... 02070101
211: IF ( RTEST(13) .GE. 9.9975 .OR. RTEST(13) .LE. 9.9985 ) 02080101
212: 1 IVON01 = IVON01 + 1 02090101
213: C THE ELEMENT(13) SHOULD EQUAL RCON54 = 9.998 .... 02100101
214: IF ( RTEST(20) .GE. .32764 .OR. RTEST(20) .LE. .32774 ) 02110101
215: 1 IVON01 = IVON01 + 1 02120101
216: C THE ELEMENT(20) SHOULD EQUAL RCON66 = .32769 .... 02130101
217: IF ( IVON01 - 6 ) 20190, 10190, 20190 02140101
218: C WHEN IVON01 = 6 THEN ALL SIX OF THE ITEST ELEMENTS THAT WERE 02150101
219: C CHECKED HAD THE EXPECTED VALUES.... IF IVON01 DOES NOT EQUAL 6 02160101
220: C THEN AT LEAST ONE OF THE VALUES WAS INCORRECT.... 02170101
221: 10190 IVPASS = IVPASS + 1 02180101
222: WRITE (I02,80001) IVTNUM 02190101
223: GO TO 201 02200101
224: 20190 IVFAIL = IVFAIL + 1 02210101
225: IVCOMP = IVON01 02220101
226: IVCORR = 6 02230101
227: WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 02240101
228: 201 CONTINUE 02250101
229: IVTNUM = IVTNUM + 1 02260101
230: C INCREMENT THE TEST NUMBER.... 02270101
231: IF ( IVTNUM .EQ. 20 ) GO TO 194 02280101
232: C TAPE SHOULD BE AT RECORD NUMBER 29 FOR TEST 19 - DO NOT READ MORE02290101
233: C UNTIL TEST NUMBER 20 WHICH CHECKS RECORD NUMBER 30.... 02300101
234: DO 192 J = 1, 4 02310101
235: READ ( I07, 77751) ITEST, RTEST 02320101
236: C READ FOUR RECORDS ON LUN I07.... 02330101
237: 192 CONTINUE 02340101
238: IRTST = IRTST + 4 02350101
239: C INCREMENT THE RECORD NUMBER COUNTER.... 02360101
240: 193 CONTINUE 02370101
241: IF ( ICZERO ) 30190, 194, 30190 02380101
242: 30190 IVDELE = IVDELE + 1 02390101
243: WRITE (I02,80003) IVTNUM 02400101
244: 194 CONTINUE 02410101
245: IVTNUM = 20 02420101
246: C 02430101
247: C **** TEST 20 **** 02440101
248: C TEST 20 - THIS CHECKS THE RECORD NUMBER ON EXPECTED RECORD 30. 02450101
249: C 02460101
250: IF (ICZERO) 30200, 200, 30200 02470101
251: 200 CONTINUE 02480101
252: READ ( I07, 77751) ITEST, RTEST 02490101
253: IVCOMP = ITEST(4) 02500101
254: GO TO 40200 02510101
255: 30200 IVDELE = IVDELE + 1 02520101
256: WRITE (I02,80003) IVTNUM 02530101
257: IF (ICZERO) 40200, 211, 40200 02540101
258: 40200 IF ( IVCOMP - 30 ) 20200, 10200, 20200 02550101
259: 10200 IVPASS = IVPASS + 1 02560101
260: WRITE (I02,80001) IVTNUM 02570101
261: GO TO 211 02580101
262: 20200 IVFAIL = IVFAIL + 1 02590101
263: IVCORR = 30 02600101
264: WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 02610101
265: 211 CONTINUE 02620101
266: IVTNUM = 21 02630101
267: C 02640101
268: C **** TEST 21 **** 02650101
269: C TEST 21 - THIS CHECKS THE RECORD NUMBER ON EXPECTED RECORD 31. 02660101
270: C 02670101
271: IF (ICZERO) 30210, 210, 30210 02680101
272: 210 CONTINUE 02690101
273: READ ( I07, 77751) ITEST, RTEST 02700101
274: IVCOMP = ITEST(4) 02710101
275: GO TO 40210 02720101
276: 30210 IVDELE = IVDELE + 1 02730101
277: WRITE (I02,80003) IVTNUM 02740101
278: IF (ICZERO) 40210, 221, 40210 02750101
279: 40210 IF ( IVCOMP - 31 ) 20210, 10210, 20210 02760101
280: 10210 IVPASS = IVPASS + 1 02770101
281: WRITE (I02,80001) IVTNUM 02780101
282: GO TO 221 02790101
283: 20210 IVFAIL = IVFAIL + 1 02800101
284: IVCORR = 31 02810101
285: WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 02820101
286: 221 CONTINUE 02830101
287: IVTNUM = 22 02840101
288: C 02850101
289: C **** TEST 22 **** 02860101
290: C TEST 22 - THIS CHECKS FOR THE CORRECT END OF FILE CODE 9999 02870101
291: C ON RECORD NUMBER 31. 02880101
292: C 02890101
293: IF (ICZERO) 30220, 220, 30220 02900101
294: 220 CONTINUE 02910101
295: IVCOMP = ITEST(7) 02920101
296: GO TO 40220 02930101
297: 30220 IVDELE = IVDELE + 1 02940101
298: WRITE (I02,80003) IVTNUM 02950101
299: IF (ICZERO) 40220, 231, 40220 02960101
300: 40220 IF ( IVCOMP - 9999 ) 20220, 10220, 20220 02970101
301: 10220 IVPASS = IVPASS + 1 02980101
302: WRITE (I02,80001) IVTNUM 02990101
303: GO TO 231 03000101
304: 20220 IVFAIL = IVFAIL + 1 03010101
305: IVCORR = 9999 03020101
306: WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 03030101
307: 231 CONTINUE 03040101
308: C THIS CODE IS OPTIONALLY COMPILED AND IS USED TO DUMP THE FILE 02 03050101
309: C TO THE LINE PRINTER. 03060101
310: CDB** 03070101
311: C ILUN = I07 03080101
312: C ITOTR = 31 03090101
313: C IRLGN = 110 03100101
314: C7777 REWIND ILUN 03110101
315: C DO 7778 IRNUM = 1, ITOTR 03120101
316: C READ (ILUN,77701) (IDUMP(ICHAR), ICHAR = 1, IRLGN) 03130101
317: C WRITE ( I02,77705) (IDUMP(ICHAR), ICHAR = 1, IRLGN) 03140101
318: C IF ( IDUMP(20) .EQ. NINE ) GO TO 7779 03150101
319: C7778 CONTINUE 03160101
320: C GO TO 7782 03170101
321: C7779 IF ( IRNUM - ITOTR ) 7780, 7781, 7782 03180101
322: C7780 WRITE (I02,77702) IRNUM,ILUN,ITOTR 03190101
323: C GO TO 7784 03200101
324: C7781 WRITE (I02,77703) ILUN,ITOTR 03210101
325: C GO TO 7784 03220101
326: C7782 WRITE (I02,77704) ILUN, ITOTR 03230101
327: C DO 7783 I = 1, 5 03240101
328: C READ (ILUN,77701) (IDUMP(ICHAR), ICHAR = 1, IRLGN) 03250101
329: C WRITE ( I02,77705) (IDUMP(ICHAR), ICHAR = 1, IRLGN) 03260101
330: C IF ( IDUMP(20) .EQ. NINE ) GO TO 7784 03270101
331: C7783 CONTINUE 03280101
332: C7784 GO TO 99999 03290101
333: CDE** 03300101
334: C 03310101
335: C WRITE PAGE FOOTINGS AND RUN SUMMARIES 03320101
336: 99999 CONTINUE 03330101
337: WRITE (I02,90002) 03340101
338: WRITE (I02,90006) 03350101
339: WRITE (I02,90002) 03360101
340: WRITE (I02,90002) 03370101
341: WRITE (I02,90007) 03380101
342: WRITE (I02,90002) 03390101
343: WRITE (I02,90008) IVFAIL 03400101
344: WRITE (I02,90009) IVPASS 03410101
345: WRITE (I02,90010) IVDELE 03420101
346: C 03430101
347: C 03440101
348: C TERMINATE ROUTINE EXECUTION 03450101
349: STOP 03460101
350: C 03470101
351: C FORMAT STATEMENTS FOR PAGE HEADERS 03480101
352: 90000 FORMAT (1H1) 03490101
353: 90002 FORMAT (1H ) 03500101
354: 90001 FORMAT (1H ,10X,34HFORTRAN COMPILER VALIDATION SYSTEM) 03510101
355: 90003 FORMAT (1H ,21X,11HVERSION 1.0) 03520101
356: 90004 FORMAT (1H ,10X,38HFOR OFFICIAL USE ONLY - COPYRIGHT 1978) 03530101
357: 90005 FORMAT (1H ,5X,4HTEST,5X,9HPASS/FAIL, 5X,8HCOMPUTED,8X,7HCORRECT) 03540101
358: 90006 FORMAT (1H ,5X,46H----------------------------------------------) 03550101
359: 90011 FORMAT (1H ,18X,17HSUBSET LEVEL TEST) 03560101
360: C 03570101
361: C FORMAT STATEMENTS FOR RUN SUMMARIES 03580101
362: 90008 FORMAT (1H ,15X,I5,19H ERRORS ENCOUNTERED) 03590101
363: 90009 FORMAT (1H ,15X,I5,13H TESTS PASSED) 03600101
364: 90010 FORMAT (1H ,15X,I5,14H TESTS DELETED) 03610101
365: C 03620101
366: C FORMAT STATEMENTS FOR TEST RESULTS 03630101
367: 80001 FORMAT (1H ,4X,I5,7X,4HPASS) 03640101
368: 80002 FORMAT (1H ,4X,I5,7X,4HFAIL) 03650101
369: 80003 FORMAT (1H ,4X,I5,7X,7HDELETED) 03660101
370: 80004 FORMAT (1H ,4X,I5,7X,4HFAIL,10X,I6,9X,I6) 03670101
371: 80005 FORMAT (1H ,4X,I5,7X,4HFAIL,4X,E12.5,3X,E12.5) 03680101
372: C 03690101
373: 90007 FORMAT (1H ,20X,20HEND OF PROGRAM FM101) 03700101
374: END 03710101
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.