FM024.f Source File


Contents

Source Code


Source Code

      PROGRAM FM024

C     COMMENT SECTION.                                                  00010024
C                                                                       00020024
C     FM024                                                             00030024
C                                                                       00040024
C                  THREE DIMENSIONED ARRAYS ARE USED IN THIS ROUTINE.   00050024
C         THIS ROUTINE TESTS ARRAYS WITH FIXED DIMENSION AND SIZE LIMITS00060024
C     SET EITHER IN A BLANK COMMON OR DIMENSION STATEMENT.  THE VALUES  00070024
C     OF THE ARRAY ELEMENTS ARE SET IN VARIOUS WAYS SUCH AS SIMPLE      00080024
C     ASSIGNMENT STATEMENTS, SET TO THE VALUES OF OTHER ARRAY ELEMENTS  00090024
C     (EITHER POSITIVE OR NEGATIVE), SET BY INTEGER TO REAL OR REAL TO  00100024
C     INTEGER CONVERSION, SET BY ARITHMETIC EXPRESSIONS, OR SET BY      00110024
C     USE OF THE  EQUIVALENCE  STATEMENT.                               00120024
C                                                                       00130024
C                                                                       00140024
C      REFERENCES                                                       00150024
C        AMERICAN NATIONAL STANDARD PROGRAMMING LANGUAGE FORTRAN,       00160024
C              X3.9-1978                                                00170024
C                                                                       00180024
C        SECTION 8, SPECIFICATION STATEMENTS                            00190024
C        SECTION 8.1, DIMENSION STATEMENT                               00200024
C        SECTION 8.2, EQUIVALENCE STATEMENT                             00210024
C        SECTION 8.3, COMMON STATEMENT                                  00220024
C        SECTION 8.4, TYPE-STATEMENTS                                   00230024
C        SECTION 9, DATA STATEMENT                                      00240024
C                                                                       00250024
      COMMON ICOE01, RCOE01, LCOE01                                     00260024
      COMMON IADE31(3,3,3), RADE31(3,3,3), LADE31(3,3,3)                00270024
      COMMON IADN31(2,2,2), RADN31(2,2,2), LADN31(2,2,2)                00280024
C                                                                       00290024
      DIMENSION IADE32(3,3,3), RADE32(3,3,3), LADE32(3,3,3)             00300024
      DIMENSION IADN32(2,2,2), IADN21(2,2), IADN11(2)                   00310024
      DIMENSION IADE21(2,2), IADE11(4)                                  00320024
C                                                                       00330024
      EQUIVALENCE (IADE31(1,1,1), IADE32(1,1,1) )                       00340024
      EQUIVALENCE ( RADE31(1,1,1), RADE32(1,1,1) )                      00350024
      EQUIVALENCE ( LADE31(1,1,1), LADE32(1,1,1) )                      00360024
      EQUIVALENCE ( IADE31(1,1,1), IADE21(1,1), IADE11(1) )             00370024
      EQUIVALENCE ( ICOE01, ICOE02, ICOE03 )                            00380024
C                                                                       00390024
      LOGICAL LADE31, LADN31, LADE32, LCOE01                            00400024
      INTEGER RADN33(2,2,2), RADN21(2,4), RADN11(8)                     00410024
      REAL IADN33(2,2,2), IADN22(2,4), IADN12(8)                        00420024
C                                                                       00430024
C                                                                       00440024
C      **********************************************************       00450024
C                                                                       00460024
C         A COMPILER VALIDATION SYSTEM FOR THE FORTRAN LANGUAGE         00470024
C     BASED ON SPECIFICATIONS AS DEFINED IN AMERICAN NATIONAL STANDARD  00480024
C     PROGRAMMING LANGUAGE FORTRAN X3.9-1978, HAS BEEN DEVELOPED BY THE 00490024
C     FEDERAL COBOL COMPILER TESTING SERVICE.  THE FORTRAN COMPILER     00500024
C     VALIDATION SYSTEM (FCVS) CONSISTS OF AUDIT ROUTINES, THEIR RELATED00510024
C     DATA, AND AN EXECUTIVE SYSTEM.  EACH AUDIT ROUTINE IS A FORTRAN   00520024
C     PROGRAM, SUBPROGRAM OR FUNCTION WHICH INCLUDES TESTS OF SPECIFIC  00530024
C     LANGUAGE ELEMENTS AND SUPPORTING PROCEDURES INDICATING THE RESULT 00540024
C     OF EXECUTING THESE TESTS.                                         00550024
C                                                                       00560024
C         THIS PARTICULAR PROGRAM/SUBPROGRAM/FUNCTION CONTAINS FEATURES 00570024
C     FOUND ONLY IN THE SUBSET AS DEFINED IN X3.9-1978.                 00580024
C                                                                       00590024
C         SUGGESTIONS AND COMMENTS SHOULD BE FORWARDED TO -             00600024
C                                                                       00610024
C              NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY           00620024
C                   SOFTWARE STANDARDS VALIDATION GROUP                 00630024
C                          BUILDING 225  RM A266                        00640024
C                         GAITHERSBURG, MD  20899                       00650024
C      **********************************************************       00660024
C                                                                       00670024
C                                                                       00680024
C                                                                       00690024
C     INITIALIZATION SECTION                                            00700024
C                                                                       00710024
C     INITIALIZE CONSTANTS                                              00720024
C      **************                                                   00730024
C     I01 CONTAINS THE LOGICAL UNIT NUMBER FOR THE CARD READER.         00740024
      I01 = 5                                                           00750024
C     I02 CONTAINS THE LOGICAL UNIT NUMBER FOR THE PRINTER.             00760024
      I02 = 6                                                           00770024
C     SYSTEM ENVIRONMENT SECTION                                        00780024
C                                                                       00790024
CX010    THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-010 CONTROL CARD. 00800024
C     THE CX010 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I01 = 5      00810024
C     (UNIT NUMBER FOR CARD READER).                                    00820024
CX011    THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-011 CONTROL CARD. 00830024
C     THE CX011 CARD IS FOR SYSTEMS WHICH REQUIRE ADDITIONAL            00840024
C     FORTRAN STATEMENTS FOR FILES ASSOCIATED WITH CX010 ABOVE.         00850024
C                                                                       00860024
CX020    THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-020 CONTROL CARD. 00870024
C     THE CX020 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I02 = 6      00880024
C     (UNIT NUMBER FOR PRINTER).                                        00890024
CX021    THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-021 CONTROL CARD. 00900024
C     THE CX021 CARD IS FOR SYSTEMS WHICH REQUIRE ADDITIONAL            00910024
C     FORTRAN STATEMENTS FOR FILES ASSOCIATED WITH CX020 ABOVE.         00920024
C                                                                       00930024
      IVPASS=0                                                          00940024
      IVFAIL=0                                                          00950024
      IVDELE=0                                                          00960024
      ICZERO=0                                                          00970024
C                                                                       00980024
C     WRITE PAGE HEADERS                                                00990024
      WRITE (I02,90000)                                                 01000024
      WRITE (I02,90001)                                                 01010024
      WRITE (I02,90002)                                                 01020024
      WRITE (I02, 90002)                                                01030024
      WRITE (I02,90003)                                                 01040024
      WRITE (I02,90002)                                                 01050024
      WRITE (I02,90004)                                                 01060024
      WRITE (I02,90002)                                                 01070024
      WRITE (I02,90011)                                                 01080024
      WRITE (I02,90002)                                                 01090024
      WRITE (I02,90002)                                                 01100024
      WRITE (I02,90005)                                                 01110024
      WRITE (I02,90006)                                                 01120024
      WRITE (I02,90002)                                                 01130024
      IVTNUM = 645                                                      01140024
C                                                                       01150024
C      ****  TEST 645  ****                                             01160024
C     TEST 645  -  TESTS SETTING A THREE DIMENSION INTEGER ARRAY ELEMENT01170024
C     BY A SIMPLE INTEGER ASSIGNMENT STATEMENT.                         01180024
C                                                                       01190024
      IF (ICZERO) 36450, 6450, 36450                                    01200024
 6450 CONTINUE                                                          01210024
      IADN31(2,2,2) = -9999                                             01220024
      IVCOMP = IADN31(2,2,2)                                            01230024
      GO TO 46450                                                       01240024
36450 IVDELE = IVDELE + 1                                               01250024
      WRITE (I02,80003) IVTNUM                                          01260024
      IF (ICZERO) 46450, 6461, 46450                                    01270024
46450 IF ( IVCOMP + 9999 )  26450, 16450, 26450                         01280024
16450 IVPASS = IVPASS + 1                                               01290024
      WRITE (I02,80001) IVTNUM                                          01300024
      GO TO 6461                                                        01310024
26450 IVFAIL = IVFAIL + 1                                               01320024
      IVCORR = -9999                                                    01330024
      WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR                          01340024
 6461 CONTINUE                                                          01350024
      IVTNUM = 646                                                      01360024
C                                                                       01370024
C      ****  TEST 646  ****                                             01380024
C     TEST 646  -  TESTS SETTING A THREE DIMENSION REAL ARRAY ELEMENT   01390024
C     BY A SIMPLE REAL ASSIGNMENT STATEMENT.                            01400024
C                                                                       01410024
      IF (ICZERO) 36460, 6460, 36460                                    01420024
 6460 CONTINUE                                                          01430024
      RADN31(1,2,1) = 512.                                              01440024
      IVCOMP = RADN31(1,2,1)                                            01450024
      GO TO 46460                                                       01460024
36460 IVDELE = IVDELE + 1                                               01470024
      WRITE (I02,80003) IVTNUM                                          01480024
      IF (ICZERO) 46460, 6471, 46460                                    01490024
46460 IF ( IVCOMP - 512 )  26460, 16460, 26460                          01500024
16460 IVPASS = IVPASS + 1                                               01510024
      WRITE (I02,80001) IVTNUM                                          01520024
      GO TO 6471                                                        01530024
26460 IVFAIL = IVFAIL + 1                                               01540024
      IVCORR = 512                                                      01550024
      WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR                          01560024
 6471 CONTINUE                                                          01570024
      IVTNUM = 647                                                      01580024
C                                                                       01590024
C      ****  TEST 647  ****                                             01600024
C     TEST 647  -  TESTS SETTING A THREE DIMENSION LOGICAL ARRAY ELEMENT01610024
C     BY A SIMPLE LOGICAL ASSIGNMENT STATEMENT.                         01620024
C                                                                       01630024
      IF (ICZERO) 36470, 6470, 36470                                    01640024
 6470 CONTINUE                                                          01650024
      LADN31(1,2,2) = .TRUE.                                            01660024
      ICON01 = 0                                                        01670024
      IF ( LADN31(1,2,2) )  ICON01 = 1                                  01680024
      GO TO 46470                                                       01690024
36470 IVDELE = IVDELE + 1                                               01700024
      WRITE (I02,80003) IVTNUM                                          01710024
      IF (ICZERO) 46470, 6481, 46470                                    01720024
46470 IF ( ICON01 - 1 )  26470, 16470, 26470                            01730024
16470 IVPASS = IVPASS + 1                                               01740024
      WRITE (I02,80001) IVTNUM                                          01750024
      GO TO 6481                                                        01760024
26470 IVFAIL = IVFAIL + 1                                               01770024
      IVCOMP = ICON01                                                   01780024
      IVCORR = 1                                                        01790024
      WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR                          01800024
 6481 CONTINUE                                                          01810024
      IVTNUM = 648                                                      01820024
C                                                                       01830024
C      ****  TEST 648  ****                                             01840024
C     TEST 648  -  TESTS SETTING A ONE, TWO, AND THREE DIMENSION ARRAY  01850024
C     ELEMENT TO A VALUE IN ARITHMETIC ASSIGNMENT STATEMENTS.  ALL THREE01860024
C     ELEMENTS ARE INTEGERS.  THE INTEGER ARRAY ELEMENTS ARE THEN USED  01870024
C     IN AN ARITHMETIC STATEMENT AND THE RESULT IS STORED BY INTEGER    01880024
C     TO REAL CONVERSION INTO A THREE DIMENSION REAL ARRAY ELEMENT.     01890024
C                                                                       01900024
      IF (ICZERO) 36480, 6480, 36480                                    01910024
 6480 CONTINUE                                                          01920024
      IADN11(2) = 1                                                     01930024
      IADN21(2,2) = 2                                                   01940024
      IADN32(2,2,2) = 3                                                 01950024
      RADN31(2,2,1) = IADN11(2) + IADN21(2,2) + IADN32(2,2,2)           01960024
      IVCOMP = RADN31(2,2,1)                                            01970024
      GO TO 46480                                                       01980024
36480 IVDELE = IVDELE + 1                                               01990024
      WRITE (I02,80003) IVTNUM                                          02000024
      IF (ICZERO) 46480, 6491, 46480                                    02010024
46480 IF ( IVCOMP - 6) 26480, 16480, 26480                              02020024
16480 IVPASS = IVPASS + 1                                               02030024
      WRITE (I02,80001) IVTNUM                                          02040024
      GO TO 6491                                                        02050024
26480 IVFAIL = IVFAIL + 1                                               02060024
      IVCORR = 6                                                        02070024
      WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR                          02080024
 6491 CONTINUE                                                          02090024
      IVTNUM = 649                                                      02100024
C                                                                       02110024
C      ****  TEST 649  ****                                             02120024
C     TEST 649  -  TESTS OF ONE, TWO, AND THREE DIMENSION ARRAY ELEMENTS02130024
C     SET EXPLICITLY INTEGER BY THE INTEGER TYPE STATEMENT.  ALL ELEMENT02140024
C     VALUES SHOULD BE ZERO FROM REAL TO INTEGER TRUNCATION FROM A VALUE02150024
C     OF 0.5.  ALL THREE ELEMENTS ARE USED IN AN ARITHMETIC EXPRESSION. 02160024
C     THE VALUE OF THE SUM OF THE ELEMENTS SHOULD BE ZERO.              02170024
C                                                                       02180024
      IF (ICZERO) 36490, 6490, 36490                                    02190024
 6490 CONTINUE                                                          02200024
      RADN11(8) = 0000.50000                                            02210024
      RADN21(2,4) = .50000                                              02220024
      RADN33(2,2,2) = 00000.5                                           02230024
      RADN11(1) = RADN11(8) + RADN21(2,4) + RADN33(2,2,2)               02240024
      IVCOMP = RADN11(1)                                                02250024
      GO TO 46490                                                       02260024
36490 IVDELE = IVDELE + 1                                               02270024
      WRITE (I02,80003) IVTNUM                                          02280024
      IF (ICZERO) 46490, 6501, 46490                                    02290024
46490 IF ( IVCOMP - 0 )  26490, 16490, 26490                            02300024
16490 IVPASS = IVPASS + 1                                               02310024
      WRITE (I02,80001) IVTNUM                                          02320024
      GO TO 6501                                                        02330024
26490 IVFAIL = IVFAIL + 1                                               02340024
      IVCORR = 0                                                        02350024
      WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR                          02360024
 6501 CONTINUE                                                          02370024
      IVTNUM = 650                                                      02380024
C                                                                       02390024
C      ****  TEST 650  ****                                             02400024
C     TEST 650  -  TEST OF THE EQUIVALENCE STATEMENT.  A REAL ARRAY     02410024
C     ELEMENT IS SET BY AN ASSIGNMENT STATEMENT.  ITS EQUIVALENT ELEMENT02420024
C     IN COMMON IS USED TO SET THE VALUE OF AN INTEGER ARRAY ELEMENT    02430024
C     ALSO IN COMMON.  FINALLY THE DIMENSIONED EQUIVALENT INTEGER       02440024
C     ARRAY ELEMENT IS TESTED FOR THE VALUE USED THROUGHOUT  32767.     02450024
C                                                                       02460024
      IF (ICZERO) 36500, 6500, 36500                                    02470024
 6500 CONTINUE                                                          02480024
      RADE32(2,2,2) = 32767.                                            02490024
      IADE31(2,2,2) = RADE31(2,2,2)                                     02500024
      IVCOMP = IADE32(2,2,2)                                            02510024
      GO TO 46500                                                       02520024
36500 IVDELE = IVDELE + 1                                               02530024
      WRITE (I02,80003) IVTNUM                                          02540024
      IF (ICZERO) 46500, 6511, 46500                                    02550024
46500 IF ( IVCOMP - 32767 )  26500, 16500, 26500                        02560024
16500 IVPASS = IVPASS + 1                                               02570024
      WRITE (I02,80001) IVTNUM                                          02580024
      GO TO 6511                                                        02590024
26500 IVFAIL = IVFAIL + 1                                               02600024
      IVCORR = 32767                                                    02610024
      WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR                          02620024
 6511 CONTINUE                                                          02630024
      IVTNUM = 651                                                      02640024
C                                                                       02650024
C      ****  TEST 651  ****                                             02660024
C     TEST 651  -  THIS IS A TEST OF COMMON AND DIMENSION AS WELL AS A  02670024
C     TEST OF THE EQUIVALENCE STATEMENT USING LOGICAL ARRAY ELEMENTS    02680024
C     BOTH IN COMMON AND DIMENSIONED.  A LOGICAL VARIABLE IN COMMON IS  02690024
C     SET TO A VALUE OF .NOT. THE VALUE USED IN THE EQUIVALENCED ARRAY  02700024
C     ELEMENTS WHICH WERE SET IN A LOGICAL ASSIGNMENT STATEMENT.        02710024
C                                                                       02720024
      IF (ICZERO) 36510, 6510, 36510                                    02730024
 6510 CONTINUE                                                          02740024
      LADE31(1,2,3) = .FALSE.                                           02750024
      LCOE01 = .NOT. LADE32(1,2,3)                                      02760024
      ICON01 = 0                                                        02770024
      IF ( LCOE01 )  ICON01 = 1                                         02780024
      GO TO 46510                                                       02790024
36510 IVDELE = IVDELE + 1                                               02800024
      WRITE (I02,80003) IVTNUM                                          02810024
      IF (ICZERO) 46510, 6521, 46510                                    02820024
46510 IF ( ICON01 - 1 )  26510, 16510, 26510                            02830024
16510 IVPASS = IVPASS + 1                                               02840024
      WRITE (I02,80001) IVTNUM                                          02850024
      GO TO 6521                                                        02860024
26510 IVFAIL = IVFAIL + 1                                               02870024
      IVCOMP = ICON01                                                   02880024
      IVCORR = 1                                                        02890024
      WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR                          02900024
 6521 CONTINUE                                                          02910024
      IVTNUM = 652                                                      02920024
C                                                                       02930024
C      ****  TEST 652  ****                                             02940024
C     TEST 652  -  TESTS OF ONE, TWO, AND THREE DIMENSION ARRAY ELEMENTS02950024
C     SET EXPLICITLY REAL BY THE REAL TYPE STATEMENT.  ALL ELEMENT      02960024
C     VALUES SHOULD BE 0.5 FROM THE REAL ASSIGNMENT STATEMENT.  THE     02970024
C     ARRAY ELEMENTS ARE SUMMED AND THEN THE SUM MULTIPLIED BY 2.       02980024
C     FINALLY 0.2 IS ADDED TO THE RESULT AND THE FINAL RESULT CONVERTED 02990024
C     TO AN INTEGER  ( ( .5 + .5 + .5 ) * 2. ) + 0.2                    03000024
C                                                                       03010024
      IF (ICZERO) 36520, 6520, 36520                                    03020024
 6520 CONTINUE                                                          03030024
      IADN12(5) = 0.5                                                   03040024
      IADN22(1,3) = 0.5                                                 03050024
      IADN33(1,2,2) = 0.5                                               03060024
      IVCOMP = ( ( IADN12(5) + IADN22(1,3) + IADN33(1,2,2) ) * 2. ) + .203070024
      GO TO 46520                                                       03080024
36520 IVDELE = IVDELE + 1                                               03090024
      WRITE (I02,80003) IVTNUM                                          03100024
      IF (ICZERO) 46520, 6531, 46520                                    03110024
46520 IF ( IVCOMP - 3 )  26520, 16520, 26520                            03120024
16520 IVPASS = IVPASS + 1                                               03130024
      WRITE (I02,80001) IVTNUM                                          03140024
      GO TO 6531                                                        03150024
26520 IVFAIL = IVFAIL + 1                                               03160024
      IVCORR = 3                                                        03170024
      WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR                          03180024
 6531 CONTINUE                                                          03190024
C                                                                       03200024
C     WRITE PAGE FOOTINGS AND RUN SUMMARIES                             03210024
99999 CONTINUE                                                          03220024
      WRITE (I02,90002)                                                 03230024
      WRITE (I02,90006)                                                 03240024
      WRITE (I02,90002)                                                 03250024
      WRITE (I02,90002)                                                 03260024
      WRITE (I02,90007)                                                 03270024
      WRITE (I02,90002)                                                 03280024
      WRITE (I02,90008)  IVFAIL                                         03290024
      WRITE (I02,90009) IVPASS                                          03300024
      WRITE (I02,90010) IVDELE                                          03310024
C                                                                       03320024
C                                                                       03330024
C     TERMINATE ROUTINE EXECUTION                                       03340024
      STOP                                                              03350024
C                                                                       03360024
C     FORMAT STATEMENTS FOR PAGE HEADERS                                03370024
90000 FORMAT ("1")                                                      03380024
90002 FORMAT (" ")                                                      03390024
90001 FORMAT (" ",10X,"FORTRAN COMPILER VALIDATION SYSTEM" )            03400024
90003 FORMAT (" ",21X,"VERSION 2.1" )                                   03410024
90004 FORMAT (" ",10X,"FOR OFFICIAL USE ONLY - COPYRIGHT 1978" )        03420024
90005 FORMAT (" ",5X,"TEST",5X,"PASS/FAIL", 5X,"COMPUTED",8X,"CORRECT") 03430024
90006 FORMAT (" ",5X,"----------------------------------------------" ) 03440024
90011 FORMAT (" ",18X,"SUBSET LEVEL TEST" )                             03450024
C                                                                       03460024
C     FORMAT STATEMENTS FOR RUN SUMMARIES                               03470024
90008 FORMAT (" ",15X,I5," ERRORS ENCOUNTERED" )                        03480024
90009 FORMAT (" ",15X,I5," TESTS PASSED" )                              03490024
90010 FORMAT (" ",15X,I5," TESTS DELETED" )                             03500024
C                                                                       03510024
C     FORMAT STATEMENTS FOR TEST RESULTS                                03520024
80001 FORMAT (" ",4X,I5,7X,"PASS")                                      03530024
80002 FORMAT (" ",4X,I5,7X,"FAIL")                                      03540024
80003 FORMAT (" ",4X,I5,7X,"DELETED")                                   03550024
80004 FORMAT (" ",4X,I5,7X,"FAIL",10X,I6,9X,I6)                         03560024
80005 FORMAT (" ",4X,I5,7X,"FAIL",4X,E12.5,3X,E12.5)                    03570024
C                                                                       03580024
90007 FORMAT (" ",20X,"END OF PROGRAM FM024" )                          03590024
      END                                                               03600024