![[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.