C COMMENT SECTION. C C FM025 C C THIS ROUTINE TESTS ARRAYS WITH IF STATEMENTS, DO LOOPS, C ASSIGNED AND COMPUTED GO TO STATEMENTS IN CONJUNCTION WITH ARRAY C ELEMENTS IN COMMON OR DIMENSIONED. ONE, TWO, AND THREE C DIMENSIONED ARRAYS ARE USED. THE SUBSCRIPTS ARE INTEGER CONSTANTS C OR SOMETIMES INTEGER VARIABLES WHEN THE ELEMENTS ARE IN LOOPS C AND ALL ARRAYS HAVE FIXED SIZE LIMITS. INTEGER, REAL, AND LOGICAL C ARRAYS ARE USED WITH THE TYPE SOMETIMES SPECIFIED WITH THE C EXPLICIT TYPE STATEMENT. C C REFERENCES C AMERICAN NATIONAL STANDARD PROGRAMMING LANGUAGE FORTRAN, C X3.9-1978 C C SECTION 8, SPECIFICATION STATEMENTS C SECTION 8.1, DIMENSION STATEMENT C SECTION 8.3, COMMON STATEMENT C SECTION 8.4, TYPE-STATEMENTS C SECTION 9, DATA STATEMENT C SECTION 11.2, COMPUTED GO TO STATEMENT C SECTION 11.3, ASSIGNED GO TO STATEMENT C SECTION 11.10, DO STATEMENT C COMMON IADN31(2,2,2), RADN31(2,2,2), LADN31(2,2,2) C DIMENSION IADN32(2,2,2), IADN21(2,2), IADN11(2) C LOGICAL LADN31 INTEGER RADN33(2,2,2), RADN21(2,4), RADN11(8) REAL IADN33(2,2,2), IADN22(2,4), IADN12(8) 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) IVTNUM = 653 C C **** TEST 653 **** C TEST 653 - TEST OF SETTING ALL VALUES OF AN INTEGER ARRAY C BY THE INTEGER INDEX OF A DO LOOP. THE ARRAY HAS ONE DIMENSION. C IF (ICZERO) 36530, 6530, 36530 6530 CONTINUE DO 6532 I = 1,2,1 IADN11(I) = I 6532 CONTINUE IVCOMP = IADN11(1) GO TO 46530 36530 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46530, 6541, 46530 46530 IF ( IVCOMP - 1 ) 26530, 16530, 26530 16530 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6541 26530 IVFAIL = IVFAIL + 1 IVCORR = 1 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6541 CONTINUE IVTNUM = 654 C C **** TEST 654 **** C TEST 654 - SEE TEST 653. THIS TEST CHECKS THE SECOND ELEMENT OF C THE INTEGER ARRAY IADN11(2). C IF (ICZERO) 36540, 6540, 36540 6540 CONTINUE IVCOMP = IADN11(2) GO TO 46540 36540 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46540, 6551, 46540 46540 IF ( IVCOMP - 2 ) 26540, 16540, 26540 16540 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6551 26540 IVFAIL = IVFAIL + 1 IVCORR = 2 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6551 CONTINUE IVTNUM = 655 C C **** TEST 655 **** C TEST 655 - TEST OF SETTING THE VALUES OF THE COLUMN OF A TWO C DIMENSION INTEGER ARRAY BY A DO LOOP. THE VALUES FOR THE ELEMENTS C IN A COLUMN IS THE NUMBER OF THE COLUMN AS SET BY THE DO LOOP C INDEX. ROW NUMBERS ARE INTEGER CONSTANTS. C THE VALUES FOR THE ELEMENTS ARE AS FOLLOWS C 1 2 C 1 2 C IF (ICZERO) 36550, 6550, 36550 6550 CONTINUE DO 6552 J = 1, 2 IADN21(1,J) = J IADN21(2,J) = J 6552 CONTINUE IVCOMP = IADN21(1,1) GO TO 46550 36550 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46550, 6561, 46550 46550 IF ( IVCOMP - 1 ) 26550, 16550, 26550 16550 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6561 26550 IVFAIL = IVFAIL + 1 IVCORR = 1 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6561 CONTINUE IVTNUM = 656 C C **** TEST 656 **** C TEST 656 - SEE TEST 655. THIS TEST CHECKS THE VALUE OF THE C INTEGER ARRAY IADN21(2,2) C IF (ICZERO) 36560, 6560, 36560 6560 CONTINUE IVCOMP = IADN21(2,2) GO TO 46560 36560 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46560, 6571, 46560 46560 IF ( IVCOMP - 2 ) 26560, 16560, 26560 16560 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6571 26560 IVFAIL = IVFAIL + 1 IVCORR = 2 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6571 CONTINUE IVTNUM = 657 C C **** TEST 657 **** C TEST 657 - THIS TESTS SETTING BOTH THE ROW AND COLUMN SUBSCRIPTS C IN A TWO DIMENSION INTEGER ARRAY WITH A DOUBLE NESTED DO LOOP. C THE ELEMENT VALUES ARE SET BY AN INTEGER COUNTER. ELEMENT VALUES C ARE AS FOLLOWS 1 2 C 3 4 C IF (ICZERO) 36570, 6570, 36570 6570 CONTINUE ICON01 = 0 DO 6573 I = 1, 2 DO 6572 J = 1, 2 ICON01 = ICON01 + 1 IADN21(I,J) = ICON01 6572 CONTINUE 6573 CONTINUE IVCOMP = IADN21(1,2) GO TO 46570 36570 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46570, 6581, 46570 46570 IF ( IVCOMP - 2 ) 26570, 16570, 26570 16570 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6581 26570 IVFAIL = IVFAIL + 1 IVCORR = 2 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6581 CONTINUE IVTNUM = 658 C C **** TEST 658 **** C TEST 658 - SEE TEST 657. THIS TEST CHECKS THE VALUE OF ARRAY C ELEMENT IADN21(2,1) = 3 C IF (ICZERO) 36580, 6580, 36580 6580 CONTINUE IVCOMP = IADN21(2,1) GO TO 46580 36580 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46580, 6591, 46580 46580 IF ( IVCOMP - 3 ) 26580, 16580, 26580 16580 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6591 26580 IVFAIL = IVFAIL + 1 IVCORR = 3 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6591 CONTINUE IVTNUM = 659 C C **** TEST 659 **** C TEST 659 - THIS TEST USES A TRIPLE NESTED DO LOOP TO SET THE C ELEMENTS IN ALL THREE DIMENSIONS OF AN INTEGER ARRAY THAT IS C DIMENSIONED. THE VALUES FOR THE ELEMENTS ARE AS FOLLOWS C FOR ELEMENT (I,J,K) = I + J + K C SO FOR ELEMENT (1,1,2) = 1 + 1 + 2 = 4 C IF (ICZERO) 36590, 6590, 36590 6590 CONTINUE DO 6594 I = 1, 2 DO 6593 J = 1, 2 DO 6592 K = 1, 2 IADN32( I, J, K ) = I + J + K 6592 CONTINUE 6593 CONTINUE 6594 CONTINUE IVCOMP = IADN32(1,1,2) GO TO 46590 36590 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46590, 6601, 46590 46590 IF ( IVCOMP - 4 ) 26590, 16590, 26590 16590 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6601 26590 IVFAIL = IVFAIL + 1 IVCORR = 4 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6601 CONTINUE IVTNUM = 660 C C **** TEST 660 **** C TEST 660 - SEE TEST 659. THIS CHECKS FOR IADN32(2,2,2) = 6 C IF (ICZERO) 36600, 6600, 36600 6600 CONTINUE IVCOMP = IADN32(2,2,2) GO TO 46600 36600 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46600, 6611, 46600 46600 IF ( IVCOMP - 6 ) 26600, 16600, 26600 16600 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6611 26600 IVFAIL = IVFAIL + 1 IVCORR = 6 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6611 CONTINUE IVTNUM = 661 C C **** TEST 661 **** C TEST 661 - THIS TEST SETS THE ELEMENTS OF AN INTEGER ARRAY IN C COMMON TO MINUS THE VALUE OF THE INTEGER ARRAY SET IN TEST 659. C ELEMENT IADN32(1,1,2) = 4 SO ELEMENT IADN31(1,1,2) = -4 C THE SAME INTEGER ASSIGNMENT STATEMENT IS USED AS THE TERMINATING C STATEMENT FOR ALL THREE DO LOOPS USED TO SET THE ARRAY VALUES C OF INTEGER ARRAY IADN31. C IF TEST 659 FAILS, THEN THIS TEST SHOULD ALSO FAIL. HOWEVER, THE C COMPUTED VALUES SHOULD RELATE IN THAT THE COMPUTED VALUE FOR C TEST 661 SHOULD BE MINUS THE COMPUTED VALUE FOR TEST 659. C IF (ICZERO) 36610, 6610, 36610 6610 CONTINUE DO 6612 I = 1, 2 DO 6612 J = 1, 2 DO 6612 K = 1, 2 6612 IADN31(I,J,K) = - IADN32 ( I, J, K ) IVCOMP = IADN31(1,1,2) GO TO 46610 36610 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46610, 6621, 46610 46610 IF ( IVCOMP + 4 ) 26610, 16610, 26610 16610 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6621 26610 IVFAIL = IVFAIL + 1 IVCORR = -4 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6621 CONTINUE IVTNUM = 662 C C **** TEST 662 **** C TEST 662 - THIS IS A TEST OF A TRIPLE NESTED DO LOOP USED TO C SET THE VALUES OF A LOGICAL ARRAY LADN31. UNLIKE THE OTHER TESTS C THE THIRD DIMENSION IS SET LAST, THE FIRST DIMENSION IS SET SECOND C AND THE SECOND DIMENSION IS SET FIRST. ALL ARRAY ELEMENTS ARE SET C TO THE LOGICAL CONSTANT .FALSE. C IF (ICZERO) 36620, 6620, 36620 6620 CONTINUE DO 6622 K = 1, 2 DO 6622 I = 1, 2 DO 6622 J = 1, 2 LADN31( I, J, K ) = .FALSE. 6622 CONTINUE ICON01 = 1 IF ( LADN31(2,1,2) ) ICON01 = 0 GO TO 46620 36620 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46620, 6631, 46620 46620 IF ( ICON01 - 1 ) 26620, 16620, 26620 16620 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6631 26620 IVFAIL = IVFAIL + 1 IVCOMP = ICON01 IVCORR = 1 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6631 CONTINUE IVTNUM = 663 C C NOTE **** TEST 663 WAS DELETED BY FCCTS. C IF (ICZERO) 36630, 6630, 36630 6630 CONTINUE 36630 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46630, 6641, 46630 46630 IF ( ICON01 - 6633 ) 26630, 16630, 26630 16630 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6641 26630 IVFAIL = IVFAIL + 1 IVCOMP = ICON01 IVCORR = 6633 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6641 CONTINUE IVTNUM = 664 C C NOTE **** TEST 664 WAS DELETED BY FCCTS. C IF (ICZERO) 36640, 6640, 36640 6640 CONTINUE 36640 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46640, 6651, 46640 46640 IF ( ICON01 - 6643 ) 26640, 16640, 26640 16640 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6651 26640 IVFAIL = IVFAIL + 1 IVCOMP = ICON01 IVCORR = 6443 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6651 CONTINUE IVTNUM = 665 C C **** TEST 665 **** C TEST 665 - ARRAY ELEMENTS SET TO TYPE REAL BY THE EXPLICIT C REAL STATEMENT ARE SET TO THE VALUE 0.5 AND USED TO SET THE VALUE C OF AN ARRAY ELEMENT SET TO TYPE INTEGER BY THE INTEGER STATEMENT. C THIS LAST INTEGER ELEMENT IS USED IN A LOGICAL IF STATEMENT C THAT SHOULD COMPARE TRUE. ( .5 + .5 + .5 ) * 2. .EQ. 3 C IF (ICZERO) 36650, 6650, 36650 6650 CONTINUE IADN33(2,2,2) = 0.5 IADN22(2,4) = 0.5 IADN12(8) = 0.5 RADN11(8) = ( IADN33(2,2,2) + IADN22(2,4) + IADN12(8) ) * 2. ICON01 = 0 IF ( RADN11(8) .EQ. 3 ) ICON01 = 1 GO TO 46650 36650 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46650, 6661, 46650 46650 IF ( ICON01 - 1 ) 26650, 16650, 26650 16650 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6661 26650 IVFAIL = IVFAIL + 1 IVCOMP = ICON01 IVCORR = 1 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6661 CONTINUE C 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 FM025) END