C COMMENT SECTION. C C FM023 C C TWO 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 IADN22(2,2), RADN22(2,2), ICOE01, RCOE01 DIMENSION IADN21(2,2), RADN21(2,2) DIMENSION IADE23(2,2), IADE24(2,2), RADE23(2,2), RADE24(2,2) EQUIVALENCE (IADE23(2,2),IADN22(2,2),IADE24(2,2)) EQUIVALENCE (RADE23(2,2),RADN22(2,2),RADE24(2,2)) EQUIVALENCE (ICOE01,ICOE02,ICOE03,ICOE04), (RCOE01,RCOE02,RCOE03) INTEGER RADN11(2), RADN25(2,2) LOGICAL LADN21(2,2) DATA RADN21(2,2)/-512./ DATA LADN21/4*.TRUE./ 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 = 632 C C **** TEST 632 **** C TEST 632 - TESTS SETTING AN INTEGER ARRAY ELEMENT BY A C SIMPLE ASSIGNMENT STATEMENT TO THE VALUE 9999. C IF (ICZERO) 36320, 6320, 36320 6320 CONTINUE IADN21(1,1) = 9999 IVCOMP = IADN21(1,1) GO TO 46320 36320 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46320, 6331, 46320 46320 IF ( IVCOMP - 9999 ) 26320, 16320, 26320 16320 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6331 26320 IVFAIL = IVFAIL + 1 IVCORR = 9999 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6331 CONTINUE IVTNUM = 633 C C **** TEST 633 **** C TEST 633 - TESTS SETTING A REAL ARRAY ELEMENT BY A SIMPLE C ASSIGNMENT STATEMENT TO THE VALUE -32766. C IF (ICZERO) 36330, 6330, 36330 6330 CONTINUE RADN21(1,2) = -32766. IVCOMP = RADN21(1,2) GO TO 46330 36330 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46330, 6341, 46330 46330 IF ( IVCOMP + 32766 ) 26330, 16330, 26330 16330 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6341 26330 IVFAIL = IVFAIL + 1 IVCORR = -32766 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6341 CONTINUE IVTNUM = 634 C C **** TEST 634 **** C TEST 634 - TEST OF THE DATA INITIALIZATION STATEMENT AND SETTING C AN INTEGER ARRAY ELEMENT EQUAL TO THE VALUE OF A REAL ARRAY C ELEMENT. THE VALUE USED IS -512. C IF (ICZERO) 36340, 6340, 36340 6340 CONTINUE IADN21(2,2) = RADN21(2,2) IVCOMP = IADN21(2,2) GO TO 46340 36340 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46340, 6351, 46340 46340 IF ( IVCOMP + 512 ) 26340, 16340, 26340 16340 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6351 26340 IVFAIL = IVFAIL + 1 IVCORR = -512 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6351 CONTINUE IVTNUM = 635 C C **** TEST 635 **** C TEST 635 - TEST OF SETTING A TWO DIMENSIONED ARRAY ELEMENT C EQUAL TO THE VALUE OF A ONE DIMENSIONED ARRAY ELEMENT. C BOTH ARRAYS ARE SET INTEGER BY THE TYPE STATEMENT AND THE TWO C DIMENSIONED ARRAY ELEMENT IS MINUS THE VALUE OF THE ONE DIMENSION C ELEMENT. THE VALUE USED IS 3. C IF (ICZERO) 36350, 6350, 36350 6350 CONTINUE RADN11(1) = 3 RADN25(2,2) = - RADN11(1) IVCOMP = RADN25(2,2) GO TO 46350 36350 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46350, 6361, 46350 46350 IF ( IVCOMP + 3 ) 26350, 16350, 26350 16350 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6361 26350 IVFAIL = IVFAIL + 1 IVCORR = -3 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6361 CONTINUE IVTNUM = 636 C C **** TEST 636 **** C TEST 636 - TEST OF LOGICAL ARRAY ELEMENTS SET BY DATA STATEMENTS C IF (ICZERO) 36360, 6360, 36360 6360 CONTINUE ICON01 = 0 IF ( LADN21(2,1) ) ICON01 = 1 GO TO 46360 36360 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46360, 6371, 46360 46360 IF ( ICON01 - 1 ) 26360, 16360, 26360 16360 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6371 26360 IVFAIL = IVFAIL + 1 IVCOMP = ICON01 IVCORR = 1 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6371 CONTINUE IVTNUM = 637 C C **** TEST 637 **** C TEST 637 - TEST OF REAL TO INTEGER CONVERSION AND SETTING C INTEGER ARRAY ELEMENTS TO THE VALUE OBTAINED IN AN ARITHMETIC C EXPRESSION USING REAL ARRAY ELEMENTS. .5 + .5 = 1 C IF (ICZERO) 36370, 6370, 36370 6370 CONTINUE RADN21(1,2) = 00000.5 RADN21(2,1) = .500000 IADN21(2,1) = RADN21(1,2) + RADN21(2,1) IVCOMP = IADN21(2,1) GO TO 46370 36370 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46370, 6381, 46370 46370 IF ( IVCOMP - 1 ) 26370, 16370, 26370 16370 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6381 26370 IVFAIL = IVFAIL + 1 IVCORR = 1 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6381 CONTINUE IVTNUM = 638 C C **** TEST 638 **** C TEST 638 - TEST OF EQUIVALENCE OF THREE INTEGER ARRAYS ONE OF C WHICH IS IN COMMON. C IF (ICZERO) 36380, 6380, 36380 6380 CONTINUE IADN22(2,1) = -9999 IVCOMP = IADE23(2,1) GO TO 46380 36380 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46380, 6391, 46380 46380 IF ( IVCOMP + 9999 ) 26380, 16380, 26380 16380 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6391 26380 IVFAIL = IVFAIL + 1 IVCORR = -9999 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6391 CONTINUE IVTNUM = 639 C C **** TEST 639 **** C TEST 639 - LIKE TEST 638 ONLY THE OTHER EQUIVALENCED ARRAY IS C TESTED FOR THE VALUE -9999. C IF (ICZERO) 36390, 6390, 36390 6390 CONTINUE IADE23(2,1) = -9999 IVCOMP = IADE24(2,1) GO TO 46390 36390 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46390, 6401, 46390 46390 IF ( IVCOMP + 9999 ) 26390, 16390, 26390 16390 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6401 26390 IVFAIL = IVFAIL + 1 IVCORR = -9999 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6401 CONTINUE IVTNUM = 640 C C **** TEST 640 **** C TEST 640 - TEST OF THREE REAL ARRAYS THAT ARE EQUIVALENCED. C ONE OF THE ARRAYS IS IN COMMON. THE VALUE 512 IS SET INTO ONE OF C THE DIMENSIONED ARRAY ELEMENTS BY AN INTEGER TO REAL CONVERSION C ASSIGNMENT STATEMENT. C IF (ICZERO) 36400, 6400, 36400 6400 CONTINUE RADE24(2,2) = 512 IVCOMP = RADN22(2,2) GO TO 46400 36400 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46400, 6411, 46400 46400 IF ( IVCOMP - 512 ) 26400, 16400, 26400 16400 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6411 26400 IVFAIL = IVFAIL + 1 IVCORR = 512 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6411 CONTINUE IVTNUM = 641 C C **** TEST 641 **** C TEST 641 - LIKE TEST 640 ONLY THE OTHER EQUIVALENCED ARRAY IS C TESTED FOR THE VALUE 512. C IF (ICZERO) 36410, 6410, 36410 6410 CONTINUE RADN22(2,2) = 512 IVCOMP = RADE23(2,2) GO TO 46410 36410 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46410, 6421, 46410 46410 IF ( IVCOMP - 512 ) 26410, 16410, 26410 16410 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6421 26410 IVFAIL = IVFAIL + 1 IVCORR = 512 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6421 CONTINUE IVTNUM = 642 C C **** TEST 642 **** C TEST 642 - TEST OF FOUR INTEGER VARIABLES THAT ARE EQUIVALENCED. C ONE OF THE INTEGER VARIABLES IS IN BLANK COMMON. THE VALUE USED C IS 3 SET BY AN ASSIGNMENT STATEMENT. C IF (ICZERO) 36420, 6420, 36420 6420 CONTINUE ICOE03 = 3 IVCOMP = ICOE01 GO TO 46420 36420 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46420, 6431, 46420 46420 IF ( IVCOMP - 3 ) 26420, 16420, 26420 16420 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6431 26420 IVFAIL = IVFAIL + 1 IVCORR = 3 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6431 CONTINUE IVTNUM = 643 C C **** TEST 643 **** C TEST 643 - LIKE TEST 642 BUT ANOTHER OF THE ELEMENTS IS TESTED C BY AN ARITHMETIC EXPRESSION USING THE EQUIVALENCED ELEMENTS. C THE VALUE OF ALL OF THE ELEMENTS SHOULD INITITIALLY BE 3 SINCE C THEY ALL SHOULD SHARE THE SAME STORAGE LOCATION. ICOE04 = 3+3+3+3 C ICOE04 = 12 THEN THE ELEMENT ICOE02 IS TESTED FOR THE VALUE 12. C IF (ICZERO) 36430, 6430, 36430 6430 CONTINUE ICOE01 = 3 ICOE04 = ICOE01 + ICOE02 + ICOE03 + ICOE04 IVCOMP = ICOE02 GO TO 46430 36430 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46430, 6441, 46430 46430 IF ( IVCOMP - 12 ) 26430, 16430, 26430 16430 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6441 26430 IVFAIL = IVFAIL + 1 IVCORR = 12 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6441 CONTINUE IVTNUM = 644 C C **** TEST 644 **** C TEST 644 - TEST OF EQUIVALENCE WITH THREE REAL VARIABLES ONE C OF WHICH IS IN BLANK COMMON. THE ELEMENTS ARE SET INITIALLY TO .5 C THEN ALL OF THE ELEMENTS ARE USED IN AN ARITHMETIC EXPRESSION C RCOE01 =(.5 + .5 + .5) * 2. SO RCOE01 = 3. ELEMENT RCOE02 C IS TESTED FOR THE VALUE 3. C IF (ICZERO) 36440, 6440, 36440 6440 CONTINUE RCOE02 = 0.5 RCOE01 = ( RCOE01 + RCOE02 + RCOE03 ) * 2. IVCOMP = RCOE02 GO TO 46440 36440 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 46440, 6451, 46440 46440 IF ( IVCOMP - 3 ) 26440, 16440, 26440 16440 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 6451 26440 IVFAIL = IVFAIL + 1 IVCORR = 3 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 6451 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 FM023) END