C C COMMENT SECTION. C C FM020 C C THIS ROUTINE TESTS THE FORTRAN IN-LINE STATEMENT FUNCTION C OF TYPE LOGICAL AND INTEGER. INTEGER CONSTANTS, LOGICAL CONSTANTS C INTEGER VARIABLES, LOGICAL VARIABLES, INTEGER ARITHMETIC EXPRESS- C IONS ARE ALL USED TO TEST THE STATEMENT FUNCTION DEFINITION AND C THE VALUE RETURNED FOR THE STATEMENT FUNCTION WHEN IT IS USED C IN THE MAIN BODY OF THE PROGRAM. C C REFERENCES C AMERICAN NATIONAL STANDARD PROGRAMMING LANGUAGE FORTRAN, C X3.9-1978 C C SECTION 8.4.1, INTEGER, REAL, DOUBLE PRECISION, COMPLEX, AND C LOGICAL TYPE-STATEMENTS C SECTION 15.3.2, INTRINSIC FUNCTION REFERENCES C SECTION 15.4, STATEMENT FUNCTIONS C SECTION 15.4.1, FORMS OF A FUNCTION STATEMENT C SECTION 15.4.2, REFERENCING A STATEMENT FUNCTION C SECTION 15.5.2, EXTERNAL FUNCTION REFERENCES C LOGICAL LFTN01, LDTN01 LOGICAL LFTN02, LDTN02 LOGICAL LFTN03, LDTN03, LCTN03 LOGICAL LFTN04, LDTN04, LCTN04 DIMENSION IADN11(2) C C..... TEST 553 IFON01(IDON01) = 32767 C C..... TEST 554 LFTN01(LDTN01) = .TRUE. C C..... TEST 555 IFON02 ( IDON02 ) = IDON02 C C..... TEST 556 LFTN02( LDTN02 ) = LDTN02 C C..... TEST 557 IFON03 (IDON03 )= IDON03 C C..... TEST 558 LFTN03(LDTN03) = LDTN03 C C..... TEST 559 LFTN04(LDTN04) = .NOT. LDTN04 C C..... TEST 560 IFON04(IDON04) = IDON04 ** 2 C C..... TEST 561 IFON05(IDON05, IDON06) = IDON05 + IDON06 C C..... TEST 562 IFON06(IDON07, IDON08) = SQRT(FLOAT(IDON07**2)+FLOAT(IDON08**2)) C C..... TEST 563 IFON07(IDON09) = IDON09 ** 2 IFON08(I,J)=SQRT(FLOAT(IFON07(I))+FLOAT(IFON07(J))) C C..... TEST 564 IFON09(K,L) = K / L + K ** L - K * L C 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 = 553 C C **** TEST 553 **** C TEST 553 - THE VALUE OF THE INTEGER FUNCTION IS SET TO A C CONSTANT OF 32767 REGARDLESS OF THE VALUE OF THE ARGUEMENT C SUPPLIED TO THE DUMMY ARGUEMENT. TEST OF POSITIVE INTEGER C CONSTANTS FOR A STATEMENT FUNCTION. C C IF (ICZERO) 35530, 5530, 35530 5530 CONTINUE IVCOMP = IFON01(3) GO TO 45530 35530 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 45530, 5541, 45530 45530 IF ( IVCOMP - 32767 ) 25530, 15530, 25530 15530 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 5541 25530 IVFAIL = IVFAIL + 1 IVCORR = 32767 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 5541 CONTINUE IVTNUM = 554 C C **** TEST 554 **** C TEST 554 - TEST OF THE STATEMENT FUNCTION OF TYPE LOGICAL C SET TO THE LOGICAL CONSTANT .TRUE. REGARDLESS OF THE C ARGUEMENT SUPPLIED TO THE DUMMY ARGUEMENT. C A LOGICAL IF STATEMENT IS USED IN CONJUNCTION WITH THE LOGICAL C STATEMENT FUNCTION. THE TRUE PATH IS TESTED. C C IF (ICZERO) 35540, 5540, 35540 5540 CONTINUE IVON01 = 0 IF ( LFTN01(.FALSE.) ) IVON01 = 1 GO TO 45540 35540 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 45540, 5551, 45540 45540 IF ( IVON01 - 1 ) 25540, 15540, 25540 15540 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 5551 25540 IVFAIL = IVFAIL + 1 IVCOMP = IVON01 IVCORR = 1 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 5551 CONTINUE IVTNUM = 555 C C **** TEST 555 **** C TEST 555 - THE INTEGER STATEMENT FUNCTION IS SET TO THE VALUE C OF THE ARGEUMENT SUPPLIED. C C IF (ICZERO) 35550, 5550, 35550 5550 CONTINUE IVCOMP = IFON02 ( 32767 ) GO TO 45550 35550 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 45550, 5561, 45550 45550 IF ( IVCOMP - 32767 ) 25550, 15550, 25550 15550 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 5561 25550 IVFAIL = IVFAIL + 1 IVCORR = 32767 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 5561 CONTINUE IVTNUM = 556 C C **** TEST 556 **** C TEST 556 - TEST OF A LOGICAL STATEMENT FUNCTION SET TO THE C VALUE OF THE ARGUEMENT SUPPLIED. THE FALSE PATH OF A LOGICAL C IF STATEMENT IS USED IN CONJUNCTION WITH THE LOGICAL C STATEMENT FUNCTION. C C IF (ICZERO) 35560, 5560, 35560 5560 CONTINUE IVON01 = 1 IF ( LFTN02(.FALSE.) ) IVON01 = 0 GO TO 45560 35560 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 45560, 5571, 45560 45560 IF ( IVON01 - 1 ) 25560, 15560, 25560 15560 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 5571 25560 IVFAIL = IVFAIL + 1 IVCOMP = IVON01 IVCORR = 1 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 5571 CONTINUE IVTNUM = 557 C C **** TEST 557 **** C TEST 557 - THE VALUE OF AN INTEGER FUNCTION IS SET EQUAL TO C VALUE OF THE ARGUEMENT SUPPLIED. THIS VALUE IS AN INTEGER C VARIABLE SET TO 32767. C C IF (ICZERO) 35570, 5570, 35570 5570 CONTINUE ICON01 = 32767 IVCOMP = IFON03 ( ICON01 ) GO TO 45570 35570 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 45570, 5581, 45570 45570 IF ( IVCOMP - 32767 ) 25570, 15570, 25570 15570 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 5581 25570 IVFAIL = IVFAIL + 1 IVCORR = 32767 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 5581 CONTINUE IVTNUM = 558 C C **** TEST 558 **** C TEST 558 - A LOGICAL STATEMENT FUNCTION IS SET EQUAL TO THE C VALUE OF THE ARGUEMENT SUPPLIED. THIS VALUE IS A LOGICAL C VARIABLE SET TO .TRUE. THE TRUE PATH OF A LOGICAL IF C STATEMENT IS USED IN CONJUNCTION WITH THE LOGICAL STATEMENT C FUNCTION. C C IF (ICZERO) 35580, 5580, 35580 5580 CONTINUE IVON01 = 0 LCTN03 = .TRUE. IF ( LFTN03(LCTN03) ) IVON01 = 1 GO TO 45580 35580 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 45580, 5591, 45580 45580 IF ( IVON01 - 1 ) 25580, 15580, 25580 15580 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 5591 25580 IVFAIL = IVFAIL + 1 IVCOMP = IVON01 IVCORR = 1 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 5591 CONTINUE IVTNUM = 559 C C **** TEST 559 **** C TEST 559 - LIKE TEST 558 ONLY THE LOGICAL .NOT. IS USED C IN THE LOGICAL STATEMENT FUNCTION DEFINITION THE FALSE PATH C OF A LOGICAL IF STATEMENT IS USED IN CONJUNCTION WITH THE C LOGICAL STATEMENT FUNCTION. C C IF (ICZERO) 35590, 5590, 35590 5590 CONTINUE IVON01 = 1 LCTN04 = .TRUE. IF ( LFTN04(LCTN04) ) IVON01 = 0 GO TO 45590 35590 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 45590, 5601, 45590 45590 IF ( IVON01 - 1 ) 25590, 15590, 25590 15590 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 5601 25590 IVFAIL = IVFAIL + 1 IVCOMP = IVON01 IVCORR = 1 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 5601 CONTINUE IVTNUM = 560 C C **** TEST 560 **** C TEST 560 - INTEGER EXPONIENTIATION USED IN AN INTEGER C STATEMENT FUNCTION. C C IF (ICZERO) 35600, 5600, 35600 5600 CONTINUE ICON04 = 3 IVCOMP = IFON04(ICON04) GO TO 45600 35600 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 45600, 5611, 45600 45600 IF ( IVCOMP - 9 ) 25600, 15600, 25600 15600 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 5611 25600 IVFAIL = IVFAIL + 1 IVCORR = 9 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 5611 CONTINUE IVTNUM = 561 C C **** TEST 561 **** C TEST 561 - TEST OF INTEGER ADDITION USING TWO (2) DUMMY C ARGUEMENTS. C C IF (ICZERO) 35610, 5610, 35610 5610 CONTINUE ICON05 = 9 ICON06 = 16 IVCOMP = IFON05(ICON05, ICON06) GO TO 45610 35610 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 45610, 5621, 45610 45610 IF ( IVCOMP - 25 ) 25610, 15610, 25610 15610 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 5621 25610 IVFAIL = IVFAIL + 1 IVCORR = 25 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 5621 CONTINUE IVTNUM = 562 C C **** TEST 562 **** C TEST 562 - THIS TEST IS THE SOLUTION OF A RIGHT TRIANGLE C USING INTEGER STATEMENT FUNCTIONS WHICH REFERENCE THE C INTRINSIC FUNCTIONS SQRT AND FLOAT. THIS IS A 3-4-5 C RIGHT TRIANGLE. C C IF (ICZERO) 35620, 5620, 35620 5620 CONTINUE ICON07 = 3 ICON08 = 4 IVCOMP = IFON06(ICON07, ICON08) GO TO 45620 35620 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 45620, 5631, 45620 45620 IF ( IVCOMP - 5 ) 5622, 15620, 5622 5622 IF ( IVCOMP - 4 ) 25620, 15620, 25620 15620 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 5631 25620 IVFAIL = IVFAIL + 1 IVCORR = 5 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 5631 CONTINUE IVTNUM = 563 C C **** TEST 563 **** C TEST 563 - SOLUTION OF A 3-4-5 RIGHT TRIANGLE LIKE TEST 562 C EXCEPT THAT BOTH INTRINSIC AND PREVIOUSLY DEFINED STATEMENT C FUNCTIONS ARE USED. C C IF (ICZERO) 35630, 5630, 35630 5630 CONTINUE ICON09 = 3 ICON10 = 4 IVCOMP = IFON08(ICON09, ICON10) GO TO 45630 35630 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 45630, 5641, 45630 45630 IF ( IVCOMP - 5 ) 5632, 15630, 5632 5632 IF ( IVCOMP - 4 ) 25630, 15630, 25630 15630 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 5641 25630 IVFAIL = IVFAIL + 1 IVCORR = 5 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 5641 CONTINUE IVTNUM = 564 C C **** TEST 564 **** C TEST 564 - USE OF ARRAY ELEMENTS IN AN INTEGER STATEMENT C FUNCTION WHICH USES THE OPERATIONS OF + - * / . C C IF (ICZERO) 35640, 5640, 35640 5640 CONTINUE IADN11(1) = 2 IADN11(2) = 2 IVCOMP = IFON09( IADN11(1), IADN11(2) ) GO TO 45640 35640 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 45640, 5651, 45640 45640 IF ( IVCOMP - 1 ) 25640, 15640, 25640 15640 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 5651 25640 IVFAIL = IVFAIL + 1 IVCORR = 1 WRITE (I02,80004) IVTNUM, IVCOMP ,IVCORR 5651 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 FM020) END