![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fm025.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / usr.bin / f77 / testf77 / tests|
Return to fm025.f CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / usr.bin / f77 / testf77 / tests |
1.1 root 1: c comment section.
2: c
3: c fm025
4: c
5: c this routine tests arrays with if statements, do loops,
6: c assigned and computed go to statements in conjunction with array
7: c elements in common or dimensioned. one, two, and three
8: c dimensioned arrays are used. the subscripts are integer constants
9: c or sometimes integer variables when the elements are in loops
10: c and all arrays have fixed size limits. integer, real, and logical
11: c arrays are used with the type sometimes specified with the
12: c explicit type statement.
13: c
14: c references
15: c american national standard programming language fortran,
16: c x3.9-1978
17: c
18: c section 8, specification statements
19: c section 8.1, dimension statement
20: c section 8.3, common statement
21: c section 8.4, type-statements
22: c section 9, data statement
23: c section 11.2, computed go to statement
24: c section 11.3, assigned go to statement
25: c section 11.10, do statement
26: c
27: common iadn31(2,2,2), radn31(2,2,2), ladn31(2,2,2)
28: c
29: dimension iadn32(2,2,2), iadn21(2,2), iadn11(2)
30: c
31: logical ladn31
32: integer radn33(2,2,2), radn21(2,4), radn11(8)
33: real iadn33(2,2,2), iadn22(2,4), iadn12(8)
34: c
35: c
36: c **********************************************************
37: c
38: c a compiler validation system for the fortran language
39: c based on specifications as defined in american national standard
40: c programming language fortran x3.9-1978, has been developed by the
41: c federal cobol compiler testing service. the fortran compiler
42: c validation system (fcvs) consists of audit routines, their related
43: c data, and an executive system. each audit routine is a fortran
44: c program, subprogram or function which includes tests of specific
45: c language elements and supporting procedures indicating the result
46: c of executing these tests.
47: c
48: c this particular program/subprogram/function contains features
49: c found only in the subset as defined in x3.9-1978.
50: c
51: c suggestions and comments should be forwarded to -
52: c
53: c department of the navy
54: c federal cobol compiler testing service
55: c washington, d.c. 20376
56: c
57: c **********************************************************
58: c
59: c
60: c
61: c initialization section
62: c
63: c initialize constants
64: c **************
65: c i01 contains the logical unit number for the card reader.
66: i01 = 5
67: c i02 contains the logical unit number for the printer.
68: i02 = 6
69: c system environment section
70: c
71: cx010 this card is replaced by contents of fexec x-010 control card.
72: c the cx010 card is for overriding the program default i01 = 5
73: c (unit number for card reader).
74: cx011 this card is replaced by contents of fexec x-011 control card.
75: c the cx011 card is for systems which require additional
76: c fortran statements for files associated with cx010 above.
77: c
78: cx020 this card is replaced by contents of fexec x-020 control card.
79: c the cx020 card is for overriding the program default i02 = 6
80: c (unit number for printer).
81: cx021 this card is replaced by contents of fexec x-021 control card.
82: c the cx021 card is for systems which require additional
83: c fortran statements for files associated with cx020 above.
84: c
85: ivpass=0
86: ivfail=0
87: ivdele=0
88: iczero=0
89: c
90: c write page headers
91: write (i02,90000)
92: write (i02,90001)
93: write (i02,90002)
94: write (i02, 90002)
95: write (i02,90003)
96: write (i02,90002)
97: write (i02,90004)
98: write (i02,90002)
99: write (i02,90011)
100: write (i02,90002)
101: write (i02,90002)
102: write (i02,90005)
103: write (i02,90006)
104: write (i02,90002)
105: ivtnum = 653
106: c
107: c **** test 653 ****
108: c test 653 - test of setting all values of an integer array
109: c by the integer index of a do loop. the array has one dimension.
110: c
111: if (iczero) 36530, 6530, 36530
112: 6530 continue
113: do 6532 i = 1,2,1
114: iadn11(i) = i
115: 6532 continue
116: ivcomp = iadn11(1)
117: go to 46530
118: 36530 ivdele = ivdele + 1
119: write (i02,80003) ivtnum
120: if (iczero) 46530, 6541, 46530
121: 46530 if ( ivcomp - 1 ) 26530, 16530, 26530
122: 16530 ivpass = ivpass + 1
123: write (i02,80001) ivtnum
124: go to 6541
125: 26530 ivfail = ivfail + 1
126: ivcorr = 1
127: write (i02,80004) ivtnum, ivcomp ,ivcorr
128: 6541 continue
129: ivtnum = 654
130: c
131: c **** test 654 ****
132: c test 654 - see test 653. this test checks the second element of
133: c the integer array iadn11(2).
134: c
135: if (iczero) 36540, 6540, 36540
136: 6540 continue
137: ivcomp = iadn11(2)
138: go to 46540
139: 36540 ivdele = ivdele + 1
140: write (i02,80003) ivtnum
141: if (iczero) 46540, 6551, 46540
142: 46540 if ( ivcomp - 2 ) 26540, 16540, 26540
143: 16540 ivpass = ivpass + 1
144: write (i02,80001) ivtnum
145: go to 6551
146: 26540 ivfail = ivfail + 1
147: ivcorr = 2
148: write (i02,80004) ivtnum, ivcomp ,ivcorr
149: 6551 continue
150: ivtnum = 655
151: c
152: c **** test 655 ****
153: c test 655 - test of setting the values of the column of a two
154: c dimension integer array by a do loop. the values for the elements
155: c in a column is the number of the column as set by the do loop
156: c index. row numbers are integer constants.
157: c the values for the elements are as follows
158: c 1 2
159: c 1 2
160: c
161: if (iczero) 36550, 6550, 36550
162: 6550 continue
163: do 6552 j = 1, 2
164: iadn21(1,j) = j
165: iadn21(2,j) = j
166: 6552 continue
167: ivcomp = iadn21(1,1)
168: go to 46550
169: 36550 ivdele = ivdele + 1
170: write (i02,80003) ivtnum
171: if (iczero) 46550, 6561, 46550
172: 46550 if ( ivcomp - 1 ) 26550, 16550, 26550
173: 16550 ivpass = ivpass + 1
174: write (i02,80001) ivtnum
175: go to 6561
176: 26550 ivfail = ivfail + 1
177: ivcorr = 1
178: write (i02,80004) ivtnum, ivcomp ,ivcorr
179: 6561 continue
180: ivtnum = 656
181: c
182: c **** test 656 ****
183: c test 656 - see test 655. this test checks the value of the
184: c integer array iadn21(2,2)
185: c
186: if (iczero) 36560, 6560, 36560
187: 6560 continue
188: ivcomp = iadn21(2,2)
189: go to 46560
190: 36560 ivdele = ivdele + 1
191: write (i02,80003) ivtnum
192: if (iczero) 46560, 6571, 46560
193: 46560 if ( ivcomp - 2 ) 26560, 16560, 26560
194: 16560 ivpass = ivpass + 1
195: write (i02,80001) ivtnum
196: go to 6571
197: 26560 ivfail = ivfail + 1
198: ivcorr = 2
199: write (i02,80004) ivtnum, ivcomp ,ivcorr
200: 6571 continue
201: ivtnum = 657
202: c
203: c **** test 657 ****
204: c test 657 - this tests setting both the row and column subscripts
205: c in a two dimension integer array with a double nested do loop.
206: c the element values are set by an integer counter. element values
207: c are as follows 1 2
208: c 3 4
209: c
210: if (iczero) 36570, 6570, 36570
211: 6570 continue
212: icon01 = 0
213: do 6573 i = 1, 2
214: do 6572 j = 1, 2
215: icon01 = icon01 + 1
216: iadn21(i,j) = icon01
217: 6572 continue
218: 6573 continue
219: ivcomp = iadn21(1,2)
220: go to 46570
221: 36570 ivdele = ivdele + 1
222: write (i02,80003) ivtnum
223: if (iczero) 46570, 6581, 46570
224: 46570 if ( ivcomp - 2 ) 26570, 16570, 26570
225: 16570 ivpass = ivpass + 1
226: write (i02,80001) ivtnum
227: go to 6581
228: 26570 ivfail = ivfail + 1
229: ivcorr = 2
230: write (i02,80004) ivtnum, ivcomp ,ivcorr
231: 6581 continue
232: ivtnum = 658
233: c
234: c **** test 658 ****
235: c test 658 - see test 657. this test checks the value of array
236: c element iadn21(2,1) = 3
237: c
238: if (iczero) 36580, 6580, 36580
239: 6580 continue
240: ivcomp = iadn21(2,1)
241: go to 46580
242: 36580 ivdele = ivdele + 1
243: write (i02,80003) ivtnum
244: if (iczero) 46580, 6591, 46580
245: 46580 if ( ivcomp - 3 ) 26580, 16580, 26580
246: 16580 ivpass = ivpass + 1
247: write (i02,80001) ivtnum
248: go to 6591
249: 26580 ivfail = ivfail + 1
250: ivcorr = 3
251: write (i02,80004) ivtnum, ivcomp ,ivcorr
252: 6591 continue
253: ivtnum = 659
254: c
255: c **** test 659 ****
256: c test 659 - this test uses a triple nested do loop to set the
257: c elements in all three dimensions of an integer array that is
258: c dimensioned. the values for the elements are as follows
259: c for element (i,j,k) = i + j + k
260: c so for element (1,1,2) = 1 + 1 + 2 = 4
261: c
262: if (iczero) 36590, 6590, 36590
263: 6590 continue
264: do 6594 i = 1, 2
265: do 6593 j = 1, 2
266: do 6592 k = 1, 2
267: iadn32( i, j, k ) = i + j + k
268: 6592 continue
269: 6593 continue
270: 6594 continue
271: ivcomp = iadn32(1,1,2)
272: go to 46590
273: 36590 ivdele = ivdele + 1
274: write (i02,80003) ivtnum
275: if (iczero) 46590, 6601, 46590
276: 46590 if ( ivcomp - 4 ) 26590, 16590, 26590
277: 16590 ivpass = ivpass + 1
278: write (i02,80001) ivtnum
279: go to 6601
280: 26590 ivfail = ivfail + 1
281: ivcorr = 4
282: write (i02,80004) ivtnum, ivcomp ,ivcorr
283: 6601 continue
284: ivtnum = 660
285: c
286: c **** test 660 ****
287: c test 660 - see test 659. this checks for iadn32(2,2,2) = 6
288: c
289: if (iczero) 36600, 6600, 36600
290: 6600 continue
291: ivcomp = iadn32(2,2,2)
292: go to 46600
293: 36600 ivdele = ivdele + 1
294: write (i02,80003) ivtnum
295: if (iczero) 46600, 6611, 46600
296: 46600 if ( ivcomp - 6 ) 26600, 16600, 26600
297: 16600 ivpass = ivpass + 1
298: write (i02,80001) ivtnum
299: go to 6611
300: 26600 ivfail = ivfail + 1
301: ivcorr = 6
302: write (i02,80004) ivtnum, ivcomp ,ivcorr
303: 6611 continue
304: ivtnum = 661
305: c
306: c **** test 661 ****
307: c test 661 - this test sets the elements of an integer array in
308: c common to minus the value of the integer array set in test 659.
309: c element iadn32(1,1,2) = 4 so element iadn31(1,1,2) = -4
310: c the same integer assignment statement is used as the terminating
311: c statement for all three do loops used to set the array values
312: c of integer array iadn31.
313: c if test 659 fails, then this test should also fail. however, the
314: c computed values should relate in that the computed value for
315: c test 661 should be minus the computed value for test 659.
316: c
317: if (iczero) 36610, 6610, 36610
318: 6610 continue
319: do 6612 i = 1, 2
320: do 6612 j = 1, 2
321: do 6612 k = 1, 2
322: 6612 iadn31(i,j,k) = - iadn32 ( i, j, k )
323: ivcomp = iadn31(1,1,2)
324: go to 46610
325: 36610 ivdele = ivdele + 1
326: write (i02,80003) ivtnum
327: if (iczero) 46610, 6621, 46610
328: 46610 if ( ivcomp + 4 ) 26610, 16610, 26610
329: 16610 ivpass = ivpass + 1
330: write (i02,80001) ivtnum
331: go to 6621
332: 26610 ivfail = ivfail + 1
333: ivcorr = -4
334: write (i02,80004) ivtnum, ivcomp ,ivcorr
335: 6621 continue
336: ivtnum = 662
337: c
338: c **** test 662 ****
339: c test 662 - this is a test of a triple nested do loop used to
340: c set the values of a logical array ladn31. unlike the other tests
341: c the third dimension is set last, the first dimension is set second
342: c and the second dimension is set first. all array elements are set
343: c to the logical constant .false.
344: c
345: if (iczero) 36620, 6620, 36620
346: 6620 continue
347: do 6622 k = 1, 2
348: do 6622 i = 1, 2
349: do 6622 j = 1, 2
350: ladn31( i, j, k ) = .false.
351: 6622 continue
352: icon01 = 1
353: if ( ladn31(2,1,2) ) icon01 = 0
354: go to 46620
355: 36620 ivdele = ivdele + 1
356: write (i02,80003) ivtnum
357: if (iczero) 46620, 6631, 46620
358: 46620 if ( icon01 - 1 ) 26620, 16620, 26620
359: 16620 ivpass = ivpass + 1
360: write (i02,80001) ivtnum
361: go to 6631
362: 26620 ivfail = ivfail + 1
363: ivcomp = icon01
364: ivcorr = 1
365: write (i02,80004) ivtnum, ivcomp ,ivcorr
366: 6631 continue
367: ivtnum = 663
368: c
369: c note **** test 663 was deleted by fccts.
370: c
371: if (iczero) 36630, 6630, 36630
372: 6630 continue
373: 36630 ivdele = ivdele + 1
374: write (i02,80003) ivtnum
375: if (iczero) 46630, 6641, 46630
376: 46630 if ( icon01 - 6633 ) 26630, 16630, 26630
377: 16630 ivpass = ivpass + 1
378: write (i02,80001) ivtnum
379: go to 6641
380: 26630 ivfail = ivfail + 1
381: ivcomp = icon01
382: ivcorr = 6633
383: write (i02,80004) ivtnum, ivcomp ,ivcorr
384: 6641 continue
385: ivtnum = 664
386: c
387: c note **** test 664 was deleted by fccts.
388: c
389: if (iczero) 36640, 6640, 36640
390: 6640 continue
391: 36640 ivdele = ivdele + 1
392: write (i02,80003) ivtnum
393: if (iczero) 46640, 6651, 46640
394: 46640 if ( icon01 - 6643 ) 26640, 16640, 26640
395: 16640 ivpass = ivpass + 1
396: write (i02,80001) ivtnum
397: go to 6651
398: 26640 ivfail = ivfail + 1
399: ivcomp = icon01
400: ivcorr = 6443
401: write (i02,80004) ivtnum, ivcomp ,ivcorr
402: 6651 continue
403: ivtnum = 665
404: c
405: c **** test 665 ****
406: c test 665 - array elements set to type real by the explicit
407: c real statement are set to the value 0.5 and used to set the value
408: c of an array element set to type integer by the integer statement.
409: c this last integer element is used in a logical if statement
410: c that should compare true. ( .5 + .5 + .5 ) * 2. .eq. 3
411: c
412: if (iczero) 36650, 6650, 36650
413: 6650 continue
414: iadn33(2,2,2) = 0.5
415: iadn22(2,4) = 0.5
416: iadn12(8) = 0.5
417: radn11(8) = ( iadn33(2,2,2) + iadn22(2,4) + iadn12(8) ) * 2.
418: icon01 = 0
419: if ( radn11(8) .eq. 3 ) icon01 = 1
420: go to 46650
421: 36650 ivdele = ivdele + 1
422: write (i02,80003) ivtnum
423: if (iczero) 46650, 6661, 46650
424: 46650 if ( icon01 - 1 ) 26650, 16650, 26650
425: 16650 ivpass = ivpass + 1
426: write (i02,80001) ivtnum
427: go to 6661
428: 26650 ivfail = ivfail + 1
429: ivcomp = icon01
430: ivcorr = 1
431: write (i02,80004) ivtnum, ivcomp ,ivcorr
432: 6661 continue
433: c
434: c write page footings and run summaries
435: 99999 continue
436: write (i02,90002)
437: write (i02,90006)
438: write (i02,90002)
439: write (i02,90002)
440: write (i02,90007)
441: write (i02,90002)
442: write (i02,90008) ivfail
443: write (i02,90009) ivpass
444: write (i02,90010) ivdele
445: c
446: c
447: c terminate routine execution
448: stop
449: c
450: c format statements for page headers
451: 90000 format (1h1)
452: 90002 format (1h )
453: 90001 format (1h ,10x,34hfortran compiler validation system)
454: 90003 format (1h ,21x,11hversion 1.0)
455: 90004 format (1h ,10x,38hfor official use only - copyright 1978)
456: 90005 format (1h ,5x,4htest,5x,9hpass/fail, 5x,8hcomputed,8x,7hcorrect)
457: 90006 format (1h ,5x,46h----------------------------------------------)
458: 90011 format (1h ,18x,17hsubset level test)
459: c
460: c format statements for run summaries
461: 90008 format (1h ,15x,i5,19h errors encountered)
462: 90009 format (1h ,15x,i5,13h tests passed)
463: 90010 format (1h ,15x,i5,14h tests deleted)
464: c
465: c format statements for test results
466: 80001 format (1h ,4x,i5,7x,4hpass)
467: 80002 format (1h ,4x,i5,7x,4hfail)
468: 80003 format (1h ,4x,i5,7x,7hdeleted)
469: 80004 format (1h ,4x,i5,7x,4hfail,10x,i6,9x,i6)
470: 80005 format (1h ,4x,i5,7x,4hfail,4x,e12.5,3x,e12.5)
471: c
472: 90007 format (1h ,20x,20hend of program fm025)
473: end
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.