PROGRAM FM311 C C C THIS ROUTINE TESTS THE USE OF THE FORTRAN IN-LINE STATEMENT C FUNCTION OF TYPES INTEGER, REAL AND LOGICAL. SPECIFIC FEATURES C TESTED INCLUDE, C C A) REAL STATEMENT FUNCTIONS USING REAL CONSTANTS AND VARIABLES C IN THE EXPRESSION AND AS ACTUAL ARGUMENTS. C C B) STATEMENT FUNCTIONS WHICH REQUIRE CONVERSION OF THE C EXPRESSION TO REAL AND INTEGER TYPING. C C C) THE USE OF VARIABLES, ARRAY ELEMENTS, EXTERNAL REFERENCES, C AND INITIALLY DEFINED ENITIIES IN THE EXPRESSION. C C D) VARIOUS DEFINITIONS AND USES OF DUMMY ARGUMENTS. C C E) ACTUAL ARGUMENTS CONSISTING OF EXPRESSIONS, INTRINSIC C FUNCTION REFERENCES, AND EXTERNAL FUNCTION REFERENCES. C C F) CONFIRMING AND OVERRIDING THE TYPING OF STATEMENT FUNCTIONS C AND DUMMY ARGUMENTS. C C G) USE OF STATEMENT FUNCTIONS AND DUMMY ARGUMENTS IN THE MAIN C PROGRAM AND IN EXTERNAL FUNCTION AND SUBROUTINE SUBPROGRAMS. C C THE SUBSET LEVEL FEATURES OF STATEMENT FUNCTIONS ARE ALSO TESTED C IN ROUTINE FM020. C C REFERENCES. C AMERICAN NATIONAL STANDARD PROGRAMMING LANGUAGE FORTRAN, C X3.9-1978 C C SECTION 8.3, COMMON STATEMENT C SECTION 8.4, TYPE-STATEMENT C SECTION 8.5, IMPLICIT STATEMENT C SECTION 8.7, EXTERNAL STATEMENT C SECTION 8.8, INTRINSIC STATEMENT C SECTION 9, DATA STATEMENT C SECTION 15.3, INTRINSIC FUNCTIONS C SECTION 15.4, STATEMENT FUNCTION C SECTION 15.5, EXTERNAL FUNCTIONS C SECTION 15.6, SUBROUTINES C SECTION 15.9.1, DUMMY ARGUMENTS C SECTION 15.9.2, ACTUAL ARGUMENTS C SECTION 15.9.3, ASSOCIATION OF DUMMY AND ACTUAL ARGUMENTS C C C ****************************************************************** C A COMPILER VALIDATION SYSTEM FOR THE FORTRAN LANGUAGE C BASED ON SPECIFICATIONS AS DEFINED IN AMERICAN STANDARD FORTRAN C X3.9-1978, HAS BEEN DEVELOPED BY THE DEPARTMENT OF THE NAVY. THE C FORTRAN COMPILER VALIDATION SYSTEM (FCVS) CONSISTS OF AUDIT C ROUTINES, THEIR RELATED DATA, AND AN EXECUTIVE SYSTEM. EACH AUDIT C ROUTINE IS A FORTRAN PROGRAM OR SUBPROGRAM WHICH INCLUDES TESTS C OF SPECIFIC LANGUAGE ELEMENTS AND SUPPORTING PROCEDURES INDICATING C THE RESULT OF EXECUTING THESE TESTS. C C THIS PARTICULAR PROGRAM OR SUBPROGRAM CONTAINS ONLY FEATURES C FOUND IN THE SUBSET LEVEL OF THE STANDARD. C C SUGGESTIONS AND COMMENTS SHOULD BE FORWARDED TO C DEPARTMENT OF THE NAVY C FEDERAL COBOL COMPILER TESTING SERVICE C WASHINGTON, D.C. 20376 C C ****************************************************************** C C IMPLICIT LOGICAL (L) IMPLICIT CHARACTER*14 (C) C IMPLICIT INTEGER (A) IMPLICIT INTEGER (B) IMPLICIT REAL (K) IMPLICIT REAL (M) REAL NDON01 INTEGER EDON01 INTEGER FF312, FF314 EXTERNAL FF312 INTRINSIC NINT DIMENSION RADN11(4), RADN12(4), RADN13(4) DIMENSION IADN11(4), IADN12(4) DIMENSION LADN11(4) COMMON /IFOS19/IVCN01 DATA IVOND1/6/ C TEST 001 RFOS01(RDON01) = 3.5 C TEST 002 RFOS02(RDON02) = RDON02 C TEST 003 RFOS03(RDON03) = RDON03 + 1.0 C TEST 004 IFOS01(RDON04) = RDON04 + 1.0 C TEST 005 RFOS04(IDON01) = IDON01 + 1 C TEST 006 IFOS02(IDON02) = IDON02 + 1.95 C TEST 007 IFOS03(IDON03) = IDON03 + IVON01 C TEST 008 RFOS05(RDON05) = RDON05 + RVON02 C TEST 009 LFOS01(LDON01) = LDON01 .OR. LVON01 C TEST 010 IFOS04(IDON04) = IDON04 + IADN11(1) C TEST 011 RFOS06(RDON06) = RDON06 + RADN12(3) C TEST 012 LFOS02(LDON02) = .NOT. LDON02 .AND. LADN11(2) C TEST 013 RFOS07(IDON05) = RADN13(IDON05) C TEST 014 IFOS05(IDON06) = IDON06 + FF312(4) C TEST 015 IFOS06(IDON07) = (IDON07 + 1) C TEST 016 IFOS07(IDON08) = IDON08 + IVOND1 C TEST 017 IFOS08(IDON09) = IDON09 + 1 IFOS09(IDON10) = IFOS08(IDON10) + 1 C TEST 018 IFOS10() = IVON02 C TEST 019 IFOS11(IDON11,IDON12,IDON13) = IDON11 + IDON12 + IDON13 C TEST 020 IFOS12(IDON14) = IDON14 + 1 IFOS13(IDON14) = IDON14 + 2 C TEST 021,022,023 IFOS14(IDON15) = IDON15 + 1 C TEST 024 KFOS01(IDON16) = IDON16 + 1.0 C TEST 025 AFOS01(RDON07) = RDON07 + 1.0 C TEST 026 RFOS08(MDON01) = MDON01 / 5 C TEST 027 RFOS09(BDON01) = BDON01 / 5 C TEST 028 RFOS10(NDON01) = NDON01 / 5 C TEST 029 RFOS11(EDON01) = EDON01 / 5 C TEST 030 IFOS15(IVON04) = IVON04 + 1 C TEST 031 IFOS16(IDON17) = IDON17 + 1 C TEST 032 IFOS17(IDON18) = IDON18 + 1 C TEST 037 IFOS19(IDON21) = IDON21 + 1 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 PEPLACED 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 PEPLACED 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 OUT PAGE HEADERS C WRITE (I02,90002) WRITE (I02,90006) WRITE (I02,90008) WRITE (I02,90004) WRITE (I02,90010) WRITE (I02,90004) WRITE (I02,90016) WRITE (I02,90001) WRITE (I02,90004) WRITE (I02,90012) WRITE (I02,90014) WRITE (I02,90004) C C C TEST 001 THROUGH TEST 003 TEST REAL STATEMENT FUNCTIONS WHERE THE C EXPRESSION CONSISTS OF REAL CONSTANTS AND VARIABLES AND THE ACTUAL C ARGUMENTS ARE EITHER REAL CONSTANTS OR VARIABLES. C C C **** FCVS PROGRAM 311 - TEST 001 **** C C EXPRESSION CONSISTS OF REAL CONSTANT (NO DUMMY ARGUMENT). C IVTNUM = 1 IF (ICZERO) 30010, 0010, 30010 0010 CONTINUE RVCOMP = 0.0 RVCOMP = RFOS01(1.0) RVCORR = 3.5 40010 IF (RVCOMP - 3.4995) 20010, 10010, 40011 40011 IF (RVCOMP - 3.5005) 10010, 10010, 20010 30010 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10010, 0021, 20010 10010 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0021 20010 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0021 CONTINUE C C **** FCVS PROGRAM 311 - TEST 002 **** C C DUMMY ARGUMENT USED IN EXPRESSION AND ACTUAL ARGUMENT IS REAL C CONSTANT. C IVTNUM = 2 IF (ICZERO) 30020, 0020, 30020 0020 CONTINUE RVCOMP = 0.0 RVCOMP = RFOS02(1.3333) RVCORR = 1.3333 40020 IF (RVCOMP - 1.3328) 20020, 10020, 40021 40021 IF (RVCOMP - 1.3338) 10020, 10020, 20020 30020 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10020, 0031, 20020 10020 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0031 20020 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0031 CONTINUE C C **** FCVS PROGRAM 311 - TEST 003 **** C C DUMMY ARGUMENT USED IN EXPRESSION AND ACTUAL ARGUMENT IS REAL C VARIABLE. C IVTNUM = 3 IF (ICZERO) 30030, 0030, 30030 0030 CONTINUE RVCOMP = 0.0 RVON01 = 4.5 RVCOMP = RFOS03(RVON01) RVCORR = 5.5 40030 IF (RVCOMP - 5.4995) 20030, 10030, 40031 40031 IF (RVCOMP - 5.5005) 10030, 10030, 20030 30030 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10030, 0041, 20030 10030 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0041 20030 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0041 CONTINUE C C TEST 004 THROUGH TEST 006 TEST STATEMENT FUNCTIONS WHICH REQUIRE C TYPE CONVERSION OF THE EXPRESSION. C C C **** FCVS PROGRAM 311 - TEST 004 **** C C INTEGER STATEMENT FUNCTION WITH REAL EXPRESSION. C IVTNUM = 4 IF (ICZERO) 30040, 0040, 30040 0040 CONTINUE IVCOMP = 0 IVCOMP = IFOS01(2.3) IVCORR = 3 40040 IF (IVCOMP - 3) 20040, 10040, 20040 30040 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10040, 0051, 20040 10040 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0051 20040 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0051 CONTINUE C C **** FCVS PROGRAM 311 - TEST 005 **** C C REAL STATEMENT FUNCTION WITH INTEGER EXPRESSION C IVTNUM = 5 IF (ICZERO) 30050, 0050, 30050 0050 CONTINUE RVCOMP = 0.0 RVCOMP = RFOS04(3) RVCORR = 4.0 40050 IF (RVCOMP - 3.9995) 20050, 10050, 40051 40051 IF (RVCOMP - 4.0005) 10050, 10050, 20050 30050 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10050, 0061, 20050 10050 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0061 20050 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0061 CONTINUE C C **** FCVS PROGRAM 311 - TEST 006 **** C C INTEGER STATEMENT FUNCTION WITH EXPRESSION CONSISTING OF INTEGER C AND REAL PRIMARIES. C IVTNUM = 6 IF (ICZERO) 30060, 0060, 30060 0060 CONTINUE IVCOMP = 0 IVCOMP = IFOS02(2) IVCORR = 3 40060 IF (IVCOMP - 3) 20060, 10060, 20060 30060 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10060, 0071, 20060 10060 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0071 20060 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0071 CONTINUE C C TEST 007 THROUGH TEST 017 TEST THE USAGE OF VARIOUS PRIMARIES C IN THE EXPRESSION OF A STATEMENT FUNCTION. C C C **** FCVS PROGRAM 311 - TEST 007 **** C C USE INTEGER VARIABLE AS PRIMARY C IVTNUM = 7 IF (ICZERO) 30070, 0070, 30070 0070 CONTINUE IVCOMP = 0 IVON01 = 3 IVCOMP = IFOS03(4) IVCORR = 7 40070 IF (IVCOMP - 7) 20070, 10070, 20070 30070 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10070, 0081, 20070 10070 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0081 20070 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0081 CONTINUE C C **** FCVS PROGRAM 311 - TEST 008 **** C C USE REAL VARIABLE AS PRIMARY. C IVTNUM = 8 IF (ICZERO) 30080, 0080, 30080 0080 CONTINUE RVCOMP = 0.0 RVON02 = 1.5 RADN11(2) = 1.3 RVCOMP = RFOS05(RADN11(2)) RVCORR = 2.8 40080 IF (RVCOMP - 2.7995) 20080, 10080, 40081 40081 IF (RVCOMP - 2.8005) 10080, 10080, 20080 30080 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10080, 0091, 20080 10080 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0091 20080 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0091 CONTINUE C C **** FCVS PROGRAM 311 - TEST 009 **** C C USE LOGICAL VARIABLE AS PRIMARY. C IVTNUM = 9 IF (ICZERO) 30090, 0090, 30090 0090 CONTINUE LVON01 = .TRUE. IVCOMP = 0 IF (LFOS01(.FALSE.)) IVCOMP = 1 IVCORR = 1 40090 IF (IVCOMP - 1) 20090, 10090, 20090 30090 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10090, 0101, 20090 10090 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0101 20090 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0101 CONTINUE C C **** FCVS PROGRAM 311 - TEST 010 **** C C USE INTEGER ARRAY ELEMENT NAME AS PRIMARY. C IVTNUM = 10 IF (ICZERO) 30100, 0100, 30100 0100 CONTINUE IVCOMP = 0 IADN11(1) = 7 IVCOMP = IFOS04(-4) IVCORR = 3 40100 IF (IVCOMP - 3) 20100, 10100, 20100 30100 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10100, 0111, 20100 10100 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0111 20100 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0111 CONTINUE C C **** FCVS PROGRAM 311 - TEST 011 **** C C USE REAL ARRAY ELEMENT NAME AS PRIMARY. C IVTNUM = 11 IF (ICZERO) 30110, 0110, 30110 0110 CONTINUE RVCOMP = 0.0 RADN12(3) = 1.23 RVCOMP = RFOS06(3.0) RVCORR = 4.23 40110 IF (RVCOMP - 4.2295) 20110, 10110, 40111 40111 IF (RVCOMP - 4.2305) 10110, 10110, 20110 30110 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10110, 0121, 20110 10110 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0121 20110 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0121 CONTINUE C C **** FCVS PROGRAM 311 - TEST 012 **** C C USE LOGICAL ARRAY ELEMENT NAME AS PRIMARY. C IVTNUM = 12 IF (ICZERO) 30120, 0120, 30120 0120 CONTINUE LADN11(2) = .TRUE. IVCOMP = 0 IF (LFOS02(.FALSE.)) IVCOMP = 1 IVCORR = 1 40120 IF (IVCOMP - 1) 20120, 10120, 20120 30120 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10120, 0131, 20120 10120 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0131 20120 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0131 CONTINUE C C **** FCVS PROGRAM 311 - TEST 013 **** C C USE A REAL ARRAY ELEMENT NAME AS PRIMARY WHERE THE SUBSCRIPT C VALUE IS THE DUMMY ARGUMENT NAME. C IVTNUM = 13 IF (ICZERO) 30130, 0130, 30130 0130 CONTINUE RVCOMP = 0.0 RADN13(4) = 13.4 RVCOMP = RFOS07(4) RVCORR = 13.4 40130 IF (RVCOMP - 13.395) 20130, 10130, 40131 40131 IF (RVCOMP - 13.405) 10130, 10130, 20130 30130 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10130, 0141, 20130 10130 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0141 20130 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0141 CONTINUE C C **** FCVS PROGRAM 311 - TEST 014 **** C C USE EXTERNAL FUNCTION REFERENCE AS PRIMARY. C IVTNUM = 14 IF (ICZERO) 30140, 0140, 30140 0140 CONTINUE IVCOMP = 0 IVCOMP = IFOS05(6) IVCORR = 11 40140 IF (IVCOMP - 11) 20140, 10140, 20140 30140 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10140, 0151, 20140 10140 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0151 20140 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0151 CONTINUE C C **** FCVS PROGRAM 311 - TEST 015 **** C C USE EXPRESSION ENCLOSED IN PARENTHESES. C IVTNUM = 15 IF (ICZERO) 30150, 0150, 30150 0150 CONTINUE IVCOMP = 0 IVCOMP = IFOS06(4) IVCORR = 5 40150 IF (IVCOMP - 5) 20150, 10150, 20150 30150 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10150, 0161, 20150 10150 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0161 20150 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0161 CONTINUE C C **** FCVS PROGRAM 311 - TEST 016 **** C C USE VARIABLE INITIALLY DEFINED IN DATA STATEMENT AS PRIMARY. C IVTNUM = 16 IF (ICZERO) 30160, 0160, 30160 0160 CONTINUE IVCOMP = 0 IVCOMP = IFOS07(3) IVCORR = 9 40160 IF (IVCOMP - 9) 20160, 10160, 20160 30160 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10160, 0171, 20160 10160 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0171 20160 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0171 CONTINUE C C **** FCVS PROGRAM 311 - TEST 017 **** C C USE PREVIOUSLY DEFINED STATEMENT FUNCTION REFERENCE AS PRIMARY. C IVTNUM = 17 IF (ICZERO) 30170, 0170, 30170 0170 CONTINUE IVCOMP = 0 IVCOMP = IFOS09(3) IVCORR = 5 40170 IF (IVCOMP - 5) 20170, 10170, 20170 30170 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10170, 0181, 20170 10170 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0181 20170 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0181 CONTINUE C C TEST 018 THROUGH TEST 020 APPLY TO THE DEFINITION OF THE C STATEMENT FUNCTION DUMMY ARGUMENTS. C C C **** FCVS PROGRAM 311 - TEST 018 **** C C DEFINE STATEMENT FUNCTION WITH NO DUMMY ARGUMENTS. C IVTNUM = 18 IF (ICZERO) 30180, 0180, 30180 0180 CONTINUE IVCOMP = 0 IVON02 = 4 IVCOMP = IFOS10() IVCORR = 4 40180 IF (IVCOMP - 4) 20180, 10180, 20180 30180 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10180, 0191, 20180 10180 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0191 20180 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0191 CONTINUE C C **** FCVS PROGRAM 311 - TEST 019 **** C C DEFINE STATEMENT FUNCTION WITH THREE DUMMY ARGUMENTS. C IVTNUM = 19 IF (ICZERO) 30190, 0190, 30190 0190 CONTINUE IVCOMP = 0 IVCOMP = IFOS11(1,2,3) IVCORR = 6 40190 IF (IVCOMP - 6) 20190, 10190, 20190 30190 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10190, 0201, 20190 10190 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0201 20190 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0201 CONTINUE C C **** FCVS PROGRAM 311 - TEST 020 **** C C USE THE SAME DUMMY ARGUMENT NAME IN TWO DIFFERENT C STATEMENT FUNCTIONS. C IVTNUM = 20 IF (ICZERO) 30200, 0200, 30200 0200 CONTINUE IVCOMP = 1 IF (IFOS12(3) .EQ. 4) IVCOMP = IVCOMP * 2 IF (IFOS13(4) .EQ. 6) IVCOMP = IVCOMP * 3 IVCORR = 6 C 6 = 2 * 3 40200 IF (IVCOMP - 6) 20200, 10200, 20200 30200 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10200, 0211, 20200 10200 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0211 20200 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0211 CONTINUE C C TEST 021 THROUGH TEST 022 TEST THE USAGE OF DIFFERENT TYPES OF C ACTUAL ARGUMENTS IN A STATEMENT FUNCTION REFERENCE. C C C **** FCVS PROGRAM 311 - TEST 021 **** C C USE AN EXPRESSION WITH OPERATORS AS AN ACTUAL ARGUMENT. C IVTNUM = 21 IF (ICZERO) 30210, 0210, 30210 0210 CONTINUE IVCOMP = 0 IVON03 = 4 IVCOMP = IFOS14(IVON03 * 4 + 1) IVCORR = 18 40210 IF (IVCOMP - 18) 20210, 10210, 20210 30210 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10210, 0221, 20210 10210 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0221 20210 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0221 CONTINUE C C **** FCVS PROGRAM 311 - TEST 022 **** C C USE AN INTRINSIC FUNCTION REFERENCE AS AN ACTUAL ARGUMENT. C IVTNUM = 22 IF (ICZERO) 30220, 0220, 30220 0220 CONTINUE IVCOMP = 0 RVON01 = 1.75 IVCOMP = IFOS14(NINT(RVON01)) IVCORR = 3 40220 IF (IVCOMP - 3) 20220, 10220, 20220 30220 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10220, 0231, 20220 10220 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0231 20220 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0231 CONTINUE C C **** FCVS PROGRAM 311 - TEST 023 **** C C USE AN EXTERNAL FUNCTION REFERENCE AS AN ACTUAL ARGUMENT. C IVTNUM = 23 IF (ICZERO) 30230, 0230, 30230 0230 CONTINUE IVCOMP = 0 IVCOMP = IFOS14(FF312(5)) IVCORR = 7 40230 IF (IVCOMP - 7) 20230, 10230, 20230 30230 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10230, 0241, 20230 10230 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0241 20230 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0241 CONTINUE C C TEST 024 THROUGH TEST 029 APPLY TO THE TYPING OF STATEMENT C FUNCTIONS AND THE ASSOCIATED DUMMY ARGUMENT NAMES. C C C **** FCVS PROGRAM 311 - TEST 024 **** C C OVERRIDE THE INTEGER DEFAULT TYPING OF A STATEMENT FUNCTION WITH C THE IMPLICIT STATEMENT TYPING OF REAL. C IVTNUM = 24 IF (ICZERO) 30240, 0240, 30240 0240 CONTINUE RVCOMP = 10.0 RVCOMP = KFOS01(3) / 5 RVCORR = 0.8 40240 IF (RVCOMP - .79995) 20240, 10240, 40241 40241 IF (RVCOMP - .80005) 10240, 10240, 20240 30240 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10240, 0251, 20240 10240 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0251 20240 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0251 CONTINUE C C **** FCVS PROGRAM 311 - TEST 025 **** C C OVERRIDE THE REAL DEFAULT TYPING OF A STATEMENT FUNCTION WITH C THE IMPLICIT STATEMENT TYPING OF INTEGER. C IVTNUM = 25 IF (ICZERO) 30250, 0250, 30250 0250 CONTINUE RVCOMP = 10.0 RVCOMP = AFOS01(3.0) / 5 RVCORR = 0.0 40250 IF (RVCOMP + .00005) 20250, 10250, 40251 40251 IF (RVCOMP - .00005) 10250, 10250, 20250 30250 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10250, 0261, 20250 10250 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0261 20250 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0261 CONTINUE C C **** FCVS PROGRAM 311 - TEST 026 **** C C OVERRIDE THE INTEGER DEFAULT TYPING OF A STATEMENT FUNCTION C DUMMY ARGUMENT WITH THE IMPLICIT STATEMENT TYPING OF REAL. C IVTNUM = 26 IF (ICZERO) 30260, 0260, 30260 0260 CONTINUE RVCOMP = 10.0 RVCOMP = RFOS08(4.0) RVCORR = 0.8 40260 IF (RVCOMP - .79995) 20260, 10260, 40261 40261 IF (RVCOMP - .80005) 10260, 10260, 20260 30260 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10260, 0271, 20260 10260 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0271 20260 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0271 CONTINUE C C **** FCVS PROGRAM 311 - TEST 027 **** C C OVERRIDE THE REAL DEFAULT TYPING OF A STATEMENT FUNCTION DUMMY C ARGUMENT WITH THE IMPLICIT STATEMENT TYPING OF INTEGER. C IVTNUM = 27 IF (ICZERO) 30270, 0270, 30270 0270 CONTINUE RVCOMP = 10.0 RVCOMP = RFOS09(4) RVCORR = 0.0 40270 IF (RVCOMP + .00005) 20270, 10270, 40271 40271 IF (RVCOMP - .00005) 10270, 10270, 20270 30270 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10270, 0281, 20270 10270 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0281 20270 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0281 CONTINUE C C **** FCVS PROGRAM 311 - TEST 028 **** C C OVERRIDE INTEGER DEFAULT TYPING OF A STATEMENT FUNCTION DUMMY C ARGUMENT WITH TYPE-STATEMENT TYPING OF REAL. C IVTNUM = 28 IF (ICZERO) 30280, 0280, 30280 0280 CONTINUE RVCOMP = 10.0 RVCOMP = RFOS10(4.0) RVCORR = 0.8 40280 IF (RVCOMP - .79995) 20280, 10280, 40281 40281 IF (RVCOMP - .80005) 10280, 10280, 20280 30280 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10280, 0291, 20280 10280 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0291 20280 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0291 CONTINUE C C **** FCVS PROGRAM 311 - TEST 029 **** C C OVERRIDE THE REAL DEFAULT TYPING OF A STATEMENT FUNCTION DUMMY C ARGUMENT WITH TYPE-STATEMENT TYPING OF INTEGER. C IVTNUM = 29 IF (ICZERO) 30290, 0290, 30290 0290 CONTINUE RVCOMP = 10.0 RVCOMP = RFOS11(4) RVCORR = 0.0 40290 IF (RVCOMP + .00005) 20290, 10290, 40291 40291 IF (RVCOMP - .00005) 10290, 10290, 20290 30290 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10290, 0301, 20290 10290 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0301 20290 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0301 CONTINUE C C **** FCVS PROGRAM 311 - TEST 030 **** C C TEST 030 TESTS A STATEMENT FUNCTION WHERE THE DUMMY ARGUMENT C NAME IS IDENTICAL TO A VARIABLE NAME WITHIN THE PROGRAM. C IVTNUM = 30 IF (ICZERO) 30300, 0300, 30300 0300 CONTINUE IVON04 = 10 IVCOMP = 1 IF (IFOS15(3) .EQ. 4) IVCOMP = IVCOMP * 2 IF (IVON04 .EQ. 10) IVCOMP = IVCOMP * 3 IVCORR = 6 C 6 = 2 * 3 40300 IF (IVCOMP - 6) 20300, 10300, 20300 30300 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10300, 0311, 20300 10300 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0311 20300 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0311 CONTINUE C C **** FCVS PROGRAM 311 - TEST 031 **** C C TEST 031 TESTS THE ASSIGNMENT OF A STATEMENT FUNCTION TO AN C ARRAY ELEMENT. C IVTNUM = 31 IF (ICZERO) 30310, 0310, 30310 0310 CONTINUE IVCOMP = 0 IADN12(3) = IFOS16(4) IVCOMP = IADN12(3) IVCORR = 5 40310 IF (IVCOMP - 5) 20310, 10310, 20310 30310 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10310, 0321, 20310 10310 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0321 20310 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0321 CONTINUE C C **** FCVS PROGRAM 311 - TEST 032 **** C C TEST 032 TESTS THE USE OF A STATEMENT FUNCTION REFERENCE C IN AN ARITHMETIC EXPRESSION. C IVTNUM = 32 IF (ICZERO) 30320, 0320, 30320 0320 CONTINUE IVCOMP = 0 IVON05 = 12 IVCOMP = IVON05 + IFOS17(4) * 2 - 3 IVCORR = 19 40320 IF (IVCOMP - 19) 20320, 10320, 20320 30320 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10320, 0331, 20320 10320 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0331 20320 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0331 CONTINUE C C **** FCVS PROGRAM 311 - TEST 033 **** C C TEST 033 TESTS THE USE OF A STATEMENT FUNCTION DEFINITION AND C REFERENCE WITHIN AN EXTERNAL FUNCTION. C IVTNUM = 33 IF (ICZERO) 30330, 0330, 30330 0330 CONTINUE RVCOMP = 0.0 RVCOMP = FF313(1.3) RVCORR = 5.8 40330 IF (RVCOMP - 5.7995) 20330, 10330, 40331 40331 IF (RVCOMP - 5.8005) 10330, 10330, 20330 30330 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10330, 0341, 20330 10330 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0341 20330 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0341 CONTINUE C C **** FCVS PROGRAM 311 - TEST 034 **** C C TEST 034 TESTS THE USE OF A STATEMENT FUNCTION DEFINITION AND C REFERENCE WITHIN A SUBROUTINE. C IVTNUM = 34 IF (ICZERO) 30340, 0340, 30340 0340 CONTINUE RVCOMP = 0.0 RVON05 = 10.0 CALL FS316(RVON05) RVCOMP = RVON05 RVCORR = 5.5 40340 IF (RVCOMP - 5.4995) 20340, 10340, 40341 40341 IF (RVCOMP - 5.5005) 10340, 10340, 20340 30340 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10340, 0351, 20340 10340 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0351 20340 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0351 CONTINUE C C **** FCVS PROGRAM 311 - TEST 035 **** C C TEST 035 REFERENCES THE DUMMY ARGUMENT NAME OF AN EXTERNAL C FUNCTION WITHIN THE EXPRESSION OF A STATEMENT FUNCTION DEFINED C IN THAT EXTERNAL FUNCTION. C IVTNUM = 35 IF (ICZERO) 30350, 0350, 30350 0350 CONTINUE IVCOMP = 0 IVCOMP = FF314(4) IVCORR = 7 40350 IF (IVCOMP - 7) 20350, 10350, 20350 30350 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10350, 0361, 20350 10350 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0361 20350 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0361 CONTINUE C C **** FCVS PROGRAM 311 - TEST 036 **** C C TEST 036 TESTS A STATEMENT FUNCTION DEFINED WITHIN AN EXTERNAL C FUNCTION IN WHICH THE STATEMENT FUNCTION DUMMY ARGUMENT NAME IS C IDENTICAL TO THE EXTERNAL FUNCTION DUMMY ARGUMENT NAME. C IVTNUM = 36 IF (ICZERO) 30360, 0360, 30360 0360 CONTINUE RVCOMP = 0.0 RVCOMP = FF315(5.5) RVCORR = 16.7 40360 IF (RVCOMP - 16.695) 20360, 10360, 40361 40361 IF (RVCOMP - 16.705) 10360, 10360, 20360 30360 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10360, 0371, 20360 10360 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0371 20360 IVFAIL = IVFAIL + 1 WRITE (I02,80012) IVTNUM, RVCOMP, RVCORR 0371 CONTINUE C C **** FCVS PROGRAM 311 - TEST 037 **** C C TEST 037 TESTS THE USAGE OF THE NAME OF A COMMON BLOCK AS THE C SYMBOLIC NAME OF A STATEMENT FUNCTION. C IVTNUM = 37 IF (ICZERO) 30370, 0370, 30370 0370 CONTINUE IVCOMP = 0 IVCOMP = IFOS19(4) IVCORR = 5 40370 IF (IVCOMP - 5) 20370, 10370, 20370 30370 IVDELE = IVDELE + 1 WRITE (I02,80000) IVTNUM IF (ICZERO) 10370, 0381, 20370 10370 IVPASS = IVPASS + 1 WRITE (I02,80002) IVTNUM GO TO 0381 20370 IVFAIL = IVFAIL + 1 WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR 0381 CONTINUE C C C WRITE OUT TEST SUMMARY C WRITE (I02,90004) WRITE (I02,90014) WRITE (I02,90004) WRITE (I02,90000) WRITE (I02,90004) WRITE (I02,90020) IVFAIL WRITE (I02,90022) IVPASS WRITE (I02,90024) IVDELE STOP 90001 FORMAT (1H ,24X,5HFM311) 90000 FORMAT (1H ,20X,20HEND OF PROGRAM FM311) C C FORMATS FOR TEST DETAIL LINES C 80000 FORMAT (1H ,4X,I5,6X,7HDELETED) 80002 FORMAT (1H ,4X,I5,7X,4HPASS) 80010 FORMAT (1H ,4X,I5,7X,4HFAIL,10X,I6,9X,I6) 80012 FORMAT (1H ,4X,I5,7X,4HFAIL,4X,E12.5,3X,E12.5) 80018 FORMAT (1H ,4X,I5,7X,4HFAIL,2X,A14,1X,A14) C C FORMAT STATEMENTS FOR PAGE HEADERS C 90002 FORMAT (1H1) 90004 FORMAT (1H ) 90006 FORMAT (1H ,10X,34HFORTRAN COMPILER VALIDATION SYSTEM) 90008 FORMAT (1H ,21X,11HVERSION 1.0) 90010 FORMAT (1H ,8X,38HFOR OFFICIAL USE ONLY - COPYRIGHT 1978) 90012 FORMAT (1H ,5X,4HTEST,5X,9HPASS/FAIL,5X,8HCOMPUTED,8X,7HCORRECT) 90014 FORMAT (1H ,5X,46H----------------------------------------------) 90016 FORMAT (1H ,18X,17HSUBSET LEVEL TEST) C C FORMAT STATEMENTS FOR RUN SUMMARY C 90020 FORMAT (1H ,19X,I5,13H TESTS FAILED) 90022 FORMAT (1H ,19X,I5,13H TESTS PASSED) 90024 FORMAT (1H ,19X,I5,14H TESTS DELETED) END INTEGER FUNCTION FF312(IDONX1) C THIS SUBPROGRAM IS USED BY TESTS 014 AND 023 OF THE MAIN PROGRAM C FM311 TO TEST STATEMENT FUNCTION. IN TEST 014 REFERENCE TO FF312 C IS USED IN THE EXPRESSION OF A STATEMENT FUNCTION. IN TEST 023 C REFERENCE TO FF312 IS USED AS AN ACTUAL ARGUMENT IN A STATEMENT C FUNCTION REFERENCE. THIS ROUTINE MERELY INCREMENTS THE VALUE OF C ACTUAL/DUMMY ARGUMENT BY ONE AND RETURN THE RESULT AS THE C FUNCTION VALUE. IDONX2 = IDONX1 + 1 FF312 = IDONX2 RETURN END REAL FUNCTION FF313(RDON08) C THIS SUBPROGRAM IS USED BY TEST 033 OF THE MAIN PROGRAM FM311 TO C TEST THE DEFINITION AND REFERENCE OF A STATEMENT FUNCTION WITHIN C AN EXTERNAL FUNCTION. RFOS12(RDON09) = RDON09 + 1.0 RVON04 = RFOS12(3.5) FF313 = RDON08 + RVON04 RETURN END INTEGER FUNCTION FF314(IDON19) C THIS SUBPROGRAM IS USED BY TEST 035 OF THE MAIN PROGRAM FM311 TO C TEST THE DEFINITION AND REFERENCE OF A STATEMENT FUNCTION WITHIN C AN EXTERNAL FUNCTION. IN THIS TEST THE EXTERNAL FUNCTION DUMMY C ARGUMENT IS REFERENCED WITHIN THE EXPRESSION OF THE STATEMENT C FUNCTION. IFOS18(IDON20) = IDON19 + IDON20 FF314 = IFOS18(3) RETURN END REAL FUNCTION FF315(RDON12) C THIS SUBPROGRAM IS USED BY TEST 036 OF THE MAIN PROGRAM FM311 TO C TEST THE DEFINITION AND REFERENCE OF A STATEMENT FUNCTION WITHIN C AN EXTERNAL FUNCTION. IN THIS TEST THE EXTERNAL FUNCTION AND C STATEMENT FUNCTION DUMMY ARGUMENTS NAMES ARE IDENTICAL. RFOS14(RDON12) = RDON12 + 1.0 RVON06 = 10.2 RVON07 = RFOS14(RVON06) FF315 = RDON12 + RVON07 RETURN END SUBROUTINE FS316(RDON10) C THIS SUBPROGRAM IS USED BY TEST 034 OF THE MAIN PROGRAM FM311 TO C TEST THE DEFINITION AND REFERENCE OF A STATEMENT FUNCTION WITHIN C A SUBROUTINE. RFOS13(RDON11) = RDON11 + 1.0 RDON10 = RFOS13(3.5) + 1.0 RETURN END