C COMMENT SECTION. C C FM024 C C THREE DIMENSIONED ARRAYS ARE USED IN THIS ROUTINE. C THIS ROUTINE TESTS ARRAYS WITH FIXED DIMENSION AND SIZE LIMITS C SET EITHER IN A BLANK COMMON OR DIMENSION STATEMENT. THE VALUES C OF THE ARRAY ELEMENTS ARE SET IN VARIOUS WAYS SUCH AS SIMPLE C ASSIGNMENT STATEMENTS, SET TO THE VALUES OF OTHER ARRAY ELEMENTS C (EITHER POSITIVE OR NEGATIVE), SET BY INTEGER TO REAL OR REAL TO C INTEGER CONVERSION, SET BY ARITHMETIC EXPRESSIONS, OR SET BY C USE OF THE EQUIVALENCE STATEMENT. C 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.2, EQUIVALENCE STATEMENT C SECTION 8.3, COMMON STATEMENT C SECTION 8.4, TYPE-STATEMENTS C SECTION 9, DATA STATEMENT C COMMON ICOE01, RCOE01, LCOE01 COMMON IADE31(3,3,3), RADE31(3,3,3), LADE31(3,3,3) COMMON IADN31(2,2,2), RADN31(2,2,2), LADN31(2,2,2) C DIMENSION IADE32(3,3,3), RADE32(3,3,3), LADE32(3,3,3) DIMENSION IADN32(2,2,2), IADN21(2,2), IADN11(2) DIMENSION IADE21(2,2), IADE11(4) C EQUIVALENCE (IADE31(1,1,1), IADE32(1,1,1) ) EQUIVALENCE ( RADE31(1,1,1), RADE32(1,1,1) ) EQUIVALENCE ( LADE31(1,1,1), LADE32(1,1,1) ) EQUIVALENCE ( IADE31(1,1,1), IADE21(1,1), IADE11(1) ) EQUIVALENCE ( ICOE01, ICOE02, ICOE03 ) C LOGICAL LADE31, LADN31, LADE32, LCOE01 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 = 645 C C **** TEST 645 **** C TEST 645 - TESTS SETTING A THREE DIMENSION INTEGER ARRAY ELEMENT C BY A SIMPLE INTEGER ASSIGNMENT STATEMENT. C IF (ICZERO) 36450, 6450, 36450 6450 CONTINUE IADN31(2,2,2) = -9999 IVCOMP = IADN31(2,2,2) GO TO 46450 36450 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46450, 6461, 46450 46450 IF ( IVCOMP + 9999 ) 26450, 16450, 26450 16450 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6461 26450 IVFAIL = IVFAIL + 1 IVCORR = -9999 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6461 CONTINUE IVTNUM = 646 C C **** TEST 646 **** C TEST 646 - TESTS SETTING A THREE DIMENSION REAL ARRAY ELEMENT C BY A SIMPLE REAL ASSIGNMENT STATEMENT. C IF (ICZERO) 36460, 6460, 36460 6460 CONTINUE RADN31(1,2,1) = 512. IVCOMP = RADN31(1,2,1) GO TO 46460 36460 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46460, 6471, 46460 46460 IF ( IVCOMP - 512 ) 26460, 16460, 26460 16460 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6471 26460 IVFAIL = IVFAIL + 1 IVCORR = 512 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6471 CONTINUE IVTNUM = 647 C C **** TEST 647 **** C TEST 647 - TESTS SETTING A THREE DIMENSION LOGICAL ARRAY ELEMENT C BY A SIMPLE LOGICAL ASSIGNMENT STATEMENT. C IF (ICZERO) 36470, 6470, 36470 6470 CONTINUE LADN31(1,2,2) = .TRUE. ICON01 = 0 IF ( LADN31(1,2,2) ) ICON01 = 1 GO TO 46470 36470 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46470, 6481, 46470 46470 IF ( ICON01 - 1 ) 26470, 16470, 26470 16470 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6481 26470 IVFAIL = IVFAIL + 1 IVCOMP = ICON01 IVCORR = 1 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6481 CONTINUE IVTNUM = 648 C C **** TEST 648 **** C TEST 648 - TESTS SETTING A ONE, TWO, AND THREE DIMENSION ARRAY C ELEMENT TO A VALUE IN ARITHMETIC ASSIGNMENT STATEMENTS. ALL THREE C ELEMENTS ARE INTEGERS. THE INTEGER ARRAY ELEMENTS ARE THEN USED C IN AN ARITHMETIC STATEMENT AND THE RESULT IS STORED BY INTEGER C TO REAL CONVERSION INTO A THREE DIMENSION REAL ARRAY ELEMENT. C IF (ICZERO) 36480, 6480, 36480 6480 CONTINUE IADN11(2) = 1 IADN21(2,2) = 2 IADN32(2,2,2) = 3 RADN31(2,2,1) = IADN11(2) + IADN21(2,2) + IADN32(2,2,2) IVCOMP = RADN31(2,2,1) GO TO 46480 36480 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46480, 6491, 46480 46480 IF ( IVCOMP - 6) 26480, 16480, 26480 16480 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6491 26480 IVFAIL = IVFAIL + 1 IVCORR = 6 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6491 CONTINUE IVTNUM = 649 C C **** TEST 649 **** C TEST 649 - TESTS OF ONE, TWO, AND THREE DIMENSION ARRAY ELEMENTS C SET EXPLICITLY INTEGER BY THE INTEGER TYPE STATEMENT. ALL ELEMENT C VALUES SHOULD BE ZERO FROM REAL TO INTEGER TRUNCATION FROM A VALUE C OF 0.5. ALL THREE ELEMENTS ARE USED IN AN ARITHMETIC EXPRESSION. C THE VALUE OF THE SUM OF THE ELEMENTS SHOULD BE ZERO. C IF (ICZERO) 36490, 6490, 36490 6490 CONTINUE RADN11(8) = 0000.50000 RADN21(2,4) = .50000 RADN33(2,2,2) = 00000.5 RADN11(1) = RADN11(8) + RADN21(2,4) + RADN33(2,2,2) IVCOMP = RADN11(1) GO TO 46490 36490 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46490, 6501, 46490 46490 IF ( IVCOMP - 0 ) 26490, 16490, 26490 16490 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6501 26490 IVFAIL = IVFAIL + 1 IVCORR = 0 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6501 CONTINUE IVTNUM = 650 C C **** TEST 650 **** C TEST 650 - TEST OF THE EQUIVALENCE STATEMENT. A REAL ARRAY C ELEMENT IS SET BY AN ASSIGNMENT STATEMENT. ITS EQUIVALENT ELEMENT C IN COMMON IS USED TO SET THE VALUE OF AN INTEGER ARRAY ELEMENT C ALSO IN COMMON. FINALLY THE DIMENSIONED EQUIVALENT INTEGER C ARRAY ELEMENT IS TESTED FOR THE VALUE USED THROUGHOUT 32767. C IF (ICZERO) 36500, 6500, 36500 6500 CONTINUE RADE32(2,2,2) = 32767. IADE31(2,2,2) = RADE31(2,2,2) IVCOMP = IADE32(2,2,2) GO TO 46500 36500 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46500, 6511, 46500 46500 IF ( IVCOMP - 32767 ) 26500, 16500, 26500 16500 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6511 26500 IVFAIL = IVFAIL + 1 IVCORR = 32767 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6511 CONTINUE IVTNUM = 651 C C **** TEST 651 **** C TEST 651 - THIS IS A TEST OF COMMON AND DIMENSION AS WELL AS A C TEST OF THE EQUIVALENCE STATEMENT USING LOGICAL ARRAY ELEMENTS C BOTH IN COMMON AND DIMENSIONED. A LOGICAL VARIABLE IN COMMON IS C SET TO A VALUE OF .NOT. THE VALUE USED IN THE EQUIVALENCED ARRAY C ELEMENTS WHICH WERE SET IN A LOGICAL ASSIGNMENT STATEMENT. C IF (ICZERO) 36510, 6510, 36510 6510 CONTINUE LADE31(1,2,3) = .FALSE. LCOE01 = .NOT. LADE32(1,2,3) ICON01 = 0 IF ( LCOE01 ) ICON01 = 1 GO TO 46510 36510 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46510, 6521, 46510 46510 IF ( ICON01 - 1 ) 26510, 16510, 26510 16510 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6521 26510 IVFAIL = IVFAIL + 1 IVCOMP = ICON01 IVCORR = 1 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6521 CONTINUE IVTNUM = 652 C C **** TEST 652 **** C TEST 652 - TESTS OF ONE, TWO, AND THREE DIMENSION ARRAY ELEMENTS C SET EXPLICITLY REAL BY THE REAL TYPE STATEMENT. ALL ELEMENT C VALUES SHOULD BE 0.5 FROM THE REAL ASSIGNMENT STATEMENT. THE C ARRAY ELEMENTS ARE SUMMED AND THEN THE SUM MULTIPLIED BY 2. C FINALLY 0.2 IS ADDED TO THE RESULT AND THE FINAL RESULT CONVERTED C TO AN INTEGER ( ( .5 + .5 + .5 ) * 2. ) + 0.2 C IF (ICZERO) 36520, 6520, 36520 6520 CONTINUE IADN12(5) = 0.5 IADN22(1,3) = 0.5 IADN33(1,2,2) = 0.5 IVCOMP = ( ( IADN12(5) + IADN22(1,3) + IADN33(1,2,2) ) * 2. ) + .2 GO TO 46520 36520 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46520, 6531, 46520 46520 IF ( IVCOMP - 3 ) 26520, 16520, 26520 16520 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6531 26520 IVFAIL = IVFAIL + 1 IVCORR = 3 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6531 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 FM024) END