PROGRAM FM317 C C C THIS ROUTINE TESTS SUBSET LEVEL FEATURES OF EXTERNAL C FUNCTION SUBPROGRAMS. TESTS ARE DESIGNED TO CHECK THE C ASSOCIATION OF ALL PERMISSIBLE FORMS OF ACTUAL ARGUMENTS WITH C VARIABLE, ARRAY AND PROCEDURE NAME DUMMY ARGUMENTS. THESE C INCLUDE, C C 1) ACTUAL ARGUMENTS ASSOCIATED TO VARIABLE NAME DUMMY C ARGUMENT INCLUDE, C C A) CONSTANT C B) VARIABLE NAME C C) ARRAY ELEMENT NAME C D) EXPRESSION INVOLVING OPERATORS C E) EXPRESSION ENCLOSED IN PARENTHESES C F) INTRINSIC FUNCTION REFERENCE C G) EXTERNAL FUNCTION REFERENCE C H) STATEMENT FUNCTION REFERENCE C I) ACTUAL ARGUMENT NAME SAME AS DUMMY ARGUMENT NAME C C 2) ACTUAL ARGUMENTS ASSOCIATED TO ARRAY NAME DUMMY C ARGUMENT INCLUDE, C C A) ARRAY NAME C B) ARRAY ELEMENT NAME C C 3) ACTUAL ARGUMENTS ASSOCIATED TO PROCEDURE NAME DUMMY C ARGUMENT INCLUDE, C C A) EXTERNAL FUNCTION NAME C B) INTRINSIC FUNCTION NAME C C) SUBROUTINE NAME C C SUBSET LEVEL ROUTINES FM028,FM050 AND FM080 ALSO TEST THE USE OF C EXTERNAL FUNCTIONS. C C REFERENCES. C AMERICAN NATIONAL STANDARD PROGRAMMING LANGUAGE FORTRAN, C X3.9-1978 C C SECTION 2.8, DUMMY ARGUMENTS C SECTION 5.1.2.2, DUMMY ARRAY DECLARATOR C SECTION 5.5, DUMMY AND ACTUAL ARRAYS C SECTION 8.1, DIMENSION STATEMENT C SECTION 8.3, COMMON STATEMENT C SECTION 8.4, TYPE-STATEMENT C SECTION 8.7, EXTERNAL STATEMENT C SECTION 8.8, INTRINSIC STATEMENT C SECTION 15.2, REFERENCING A FUNCTION C SECTION 15.3, INTRINSIC FUNCTIONS C SECTION 15.5, EXTERNAL FUNCTIONS C SECTION 15.6, SUBROUTINES C SECTION 15.9, ARGUMENTS AND COMMON BLOCKS 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 INTEGER FF318, FF321, FF322, FF324, FF325 LOGICAL FF320 INTRINSIC ABS, IABS, NINT EXTERNAL FF318, FF321, FF325, FS327 DIMENSION IADN11(4), IADN12(4) DIMENSION RADN11(4), RADN12(4) DIMENSION LADN11(4) COMMON IACN11(6), RACN11(10) INTEGER IATN11(2,3) REAL RATN11(3,4) IFOS01(IDON04) = IDON04 + 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 022 ARE DESIGNED TO ASSOCIATE VARIOUS FORMS C OF ACTUAL ARGUMENTS TO VARIABLE NAMES USED AS EXTERNAL FUNCTION C DUMMY ARGUMENTS. INTEGER, REAL AND LOGICAL DUMMY ARGUMENTS ARE C TESTED. C C C **** FCVS PROGRAM 317 - TEST 001 **** C C INTEGER CONSTANT AS ACTUAL ARGUMENT C IVTNUM = 1 IF (ICZERO) 30010, 0010, 30010 0010 CONTINUE IVCOMP = 0 IVCOMP = FF318(3) IVCORR = 4 40010 IF (IVCOMP - 4) 20010, 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,80010) IVTNUM, IVCOMP, IVCORR 0021 CONTINUE C C **** FCVS PROGRAM 317 - TEST 002 **** C C REAL CONSTANT AS ACTUAL ARGUMENT C IVTNUM = 2 IF (ICZERO) 30020, 0020, 30020 0020 CONTINUE RVCOMP = 0.0 RVCOMP = FF319(3.0) RVCORR = 4.0 40020 IF (RVCOMP - 3.9995) 20020, 10020, 40021 40021 IF (RVCOMP - 4.0005) 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 317 - TEST 003 **** C C LOGICAL CONSTANT AS ACTUAL ARGUMENT C IVTNUM = 3 IF (ICZERO) 30030, 0030, 30030 0030 CONTINUE IVCOMP = 0 IF (FF320(.FALSE.)) IVCOMP = 1 IVCORR = 1 40030 IF (IVCOMP - 1) 20030, 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,80010) IVTNUM, IVCOMP, IVCORR 0041 CONTINUE C C **** FCVS PROGRAM 317 - TEST 004 **** C C INTEGER VARIABLE AS ACTUAL ARGUMENT C IVTNUM = 4 IF (ICZERO) 30040, 0040, 30040 0040 CONTINUE IVCOMP = 0 IVON01 = 7 IVCOMP = FF318(IVON01) IVCORR = 8 40040 IF (IVCOMP - 8) 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 317 - TEST 005 **** C C REAL VARIABLE AS ACTUAL ARGUMENT C IVTNUM = 5 IF (ICZERO) 30050, 0050, 30050 0050 CONTINUE RVCOMP = 0.0 RVON01 = 7.0 RVCOMP = FF319(RVON01) RVCORR = 8.0 40050 IF (RVCOMP - 7.9995) 20050, 10050, 40051 40051 IF (RVCOMP - 8.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 317 - TEST 006 **** C C LOGICAL VARIABLE AS ACTUAL ARGUMENT C IVTNUM = 6 IF (ICZERO) 30060, 0060, 30060 0060 CONTINUE LVON01 = .TRUE. IVCOMP = 0 IF (.NOT. FF320(LVON01)) IVCOMP = 1 IVCORR = 1 40060 IF (IVCOMP - 1) 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 **** FCVS PROGRAM 317 - TEST 007 **** C C INTEGER ARRAY ELEMENT NAME AS ACTUAL ARGUMENT C IVTNUM = 7 IF (ICZERO) 30070, 0070, 30070 0070 CONTINUE IVCOMP = 0 IADN11(2) = 2 IVCOMP = FF318(IADN11(2)) IVCORR = 3 40070 IF (IVCOMP - 3) 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 317 - TEST 008 **** C C REAL ARRAY ELEMENT NAME AS ACTUAL ARGUMENT C IVTNUM = 8 IF (ICZERO) 30080, 0080, 30080 0080 CONTINUE RVCOMP = 0.0 RADN11(4) = 4.0 RVCOMP = FF319(RADN11(4)) RVCORR = 5.0 40080 IF (RVCOMP - 4.9995) 20080, 10080, 40081 40081 IF (RVCOMP - 5.0005) 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 317 - TEST 009 **** C C LOGICAL ARRAY ELEMENT NAME AS ACTUAL ARGUMENT C IVTNUM = 9 IF (ICZERO) 30090, 0090, 30090 0090 CONTINUE LADN11(1) = .FALSE. IVCOMP = 0 IF (FF320(LADN11(1))) 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 317 - TEST 010 **** C C INTEGER EXPRESSION INVOLVING OPERATORS AS ACTUAL ARGUMENT C IVTNUM = 10 IF (ICZERO) 30100, 0100, 30100 0100 CONTINUE IVCOMP = 0 IVON02 = 2 IVON03 = 3 IVCOMP = FF318(IVON02 + 3 * IVON03 - 7) IVCORR = 5 40100 IF (IVCOMP - 5) 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 317 - TEST 011 **** C C REAL EXPRESSION INVOLVING OPERATORS AS ACTUAL ARGUMENT C IVTNUM = 11 IF (ICZERO) 30110, 0110, 30110 0110 CONTINUE RVCOMP = 0.0 RVON02 = 2. RVON03 = 1.2 RVCOMP = FF319(RVON02 * RVON03 /.6) RVCORR = 5.0 40110 IF (RVCOMP - 4.9995) 20110, 10110, 40111 40111 IF (RVCOMP - 5.0005) 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 317 - TEST 012 **** C C REAL EXPRESSION INVOLVING INTEGER AND REAL PRIMARIES AND OPERATORS C AS ACTUAL ARGUMENT. C IVTNUM = 12 IF (ICZERO) 30120, 0120, 30120 0120 CONTINUE RVCOMP = 0.0 IVON01 = 2 RADN11(2) = 2.5 RVCOMP = FF319(IVON01**3 * (RADN11(2) - 1) + 2.0) RVCORR = 15.0 40120 IF (RVCOMP - 14.995) 20120, 10120, 40121 40121 IF (RVCOMP - 15.005) 10120, 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,80012) IVTNUM, RVCOMP, RVCORR 0131 CONTINUE C C **** FCVS PROGRAM 317 - TEST 013 **** C C LOGICAL EXPRESSION INVOLVING LOGICAL OPERATOR (.NOT.) AS ACTUAL C ARGUMENT. C IVTNUM = 13 IF (ICZERO) 30130, 0130, 30130 0130 CONTINUE LVON01 = .TRUE. IVCOMP = 0 IF (FF320(.NOT. LVON01)) IVCOMP = 1 IVCORR = 1 40130 IF (IVCOMP - 1) 20130, 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,80010) IVTNUM, IVCOMP, IVCORR 0141 CONTINUE C C **** FCVS PROGRAM 317 - TEST 014 **** C C LOGICAL EXPRESSION INVOLVING LOGICAL OPERATOR (.OR.) AS ACTIVE C ARGUMENT. C IVTNUM = 14 IF (ICZERO) 30140, 0140, 30140 0140 CONTINUE LVON01 = .TRUE. LVON02 = .FALSE. IVCOMP = 0 IF (.NOT. FF320(LVON01 .OR. LVON02)) IVCOMP = 1 IVCORR = 1 40140 IF (IVCOMP - 1) 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 317 - TEST 015 **** C C LOGICAL EXPRESSION INVOLVING LOGICAL OPERATOR (.AND.) AS ACTUAL C ARGUMENT. C IVTNUM = 15 IF (ICZERO) 30150, 0150, 30150 0150 CONTINUE LVON01 = .FALSE. LVON02 = .TRUE. IVCOMP = 0 IF (FF320(LVON01 .AND. LVON02)) IVCOMP = 1 IVCORR = 1 40150 IF (IVCOMP - 1) 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 317 - TEST 016 **** C C EXPRESSION ENCLOSED IN PARENTHESES AS ACTUAL ARGUMENT C IVTNUM = 16 IF (ICZERO) 30160, 0160, 30160 0160 CONTINUE IVCOMP = 0 IVON01 = 6 IVCOMP = FF318((IVON01 + 3)) IVCORR = 10 40160 IF (IVCOMP - 10) 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 317 - TEST 017 **** C C REAL INTRINSIC FUNCTION REFERENCE AS ACTUAL ARGUMENT. C IVTNUM = 17 IF (ICZERO) 30170, 0170, 30170 0170 CONTINUE RVCOMP = 0.0 RVON01 = -5.2 RVCOMP = FF319(ABS(RVON01)) RVCORR = 6.2 40170 IF (RVCOMP - 6.1995) 20170, 10170, 40171 40171 IF (RVCOMP - 6.2005) 10170, 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,80012) IVTNUM, RVCOMP, RVCORR 0181 CONTINUE C C **** FCVS PROGRAM 317 - TEST 018 **** C C INTEGER INTRINSIC FUNCTION REFERENCE AS ACTUAL ARGUMENT. C IVTNUM = 18 IF (ICZERO) 30180, 0180, 30180 0180 CONTINUE IVCOMP = 0 RVON01 = 4.7 IVCOMP = FF318(NINT(RVON01)) IVCORR = 6 40180 IF (IVCOMP - 6) 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 317 - TEST 019 **** C C EXTERNAL FUNCTION REFERENCE AS ACTUAL ARGUMENT. C IVTNUM = 19 IF (ICZERO) 30190, 0190, 30190 0190 CONTINUE IVCOMP = 0 IVON01 = 4 IVCOMP = FF318(FF321(IVON01)) 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 317 - TEST 020 **** C C EXTERNAL FUNCTION REFERENCE WHICH USES A REFERENCE TO ITSELF C AS AN ACTUAL ARGUMENT. C IVTNUM = 20 IF (ICZERO) 30200, 0200, 30200 0200 CONTINUE IVCOMP = 0 IVCOMP = FF318(FF318(4)) IVCORR = 6 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 **** FCVS PROGRAM 317 - TEST 021 **** C C USE AN ACTUAL ARGUMENT NAME WHICH IS IDENTICAL TO THE DUMMY C ARGUMENT NAME. C IVTNUM = 21 IF (ICZERO) 30210, 0210, 30210 0210 CONTINUE IVCOMP = 0 IDON01 = 10 IVCOMP = FF318(IDON01) IVCORR = 11 40210 IF (IVCOMP - 11) 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 317 - TEST 022 **** C C USE STATEMENT FUNCTION REFERENCE AS ACTUAL ARGUMENT. C IVTNUM = 22 IF (ICZERO) 30220, 0220, 30220 0220 CONTINUE IVCOMP = 0 IVCOMP = FF318(IFOS01(4)) IVCORR = 6 40220 IF (IVCOMP - 6) 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 TEST 023 THROUGH TEST 028 ARE DESIGNED TO ASSOCIATE VARIOUS C FORMS OF ACTUAL ARGUMENTS TO ARRAY NAMES USED AS EXTERNAL C FUNCTION DUMMY ARGUMENTS. C C C **** FCVS PROGRAM 317 - TEST 023 **** C C USE AN ARRAY NAME AS AN ACTUAL ARGUMENT IN WHICH THE ACTUAL C ARGUMENT ARRAY DECLARATOR IS IDENTICAL TO THE ASSOCIATED DUMMY C ARGUMENT ARRAY DECLARATOR. C IVTNUM = 23 IF (ICZERO) 30230, 0230, 30230 0230 CONTINUE IVCOMP = 0 IADN12(1) = 1 IADN12(2) = 10 IADN12(3) = 100 IADN12(4) = 1000 IVCOMP = FF322(IADN12) IVCORR = 1111 40230 IF (IVCOMP - 1111) 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 **** FCVS PROGRAM 317 - TEST 024 **** C C USE AN ARRAY NAME AS AN ACTUAL ARGUMENT IN WHICH THE SIZE OF THE C ACTUAL ARGUMENT ARRAY IS LARGER THAN THE SIZE OF THE ASSOCIATED C DUMMY ARGUMENT ARRAY. C IVTNUM = 24 IF (ICZERO) 30240, 0240, 30240 0240 CONTINUE IVCOMP = 0 IACN11(1) = 1 IACN11(2) = 10 IACN11(3) = 100 IACN11(4) = 1000 IACN11(5) = 10000 IVCOMP = FF322(IACN11) IVCORR = 1111 40240 IF (IVCOMP - 1111) 20240, 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,80010) IVTNUM, IVCOMP, IVCORR 0251 CONTINUE C C **** FCVS PROGRAM 317 - TEST 025 **** C C USE AN ARRAY NAME AS AN ACTUAL ARGUMENT IN WHICH THE ACTUAL C ARGUMENT ARRAY DECLARATOR IS LARGER AND HAS MORE SUBSCRIPT C EXPRESSIONS THAN THE ASSOCIATED DUMMY ARGUMENT ARRAY DECLARATOR. C THE ASSOCIATED DUMMY ARGUMENT ARRAY DECLARATOR. C IVTNUM = 25 IF (ICZERO) 30250, 0250, 30250 0250 CONTINUE IVCOMP = 0 IATN11(1,1) = 1 IATN11(2,1) = 10 IATN11(1,2) = 100 IATN11(2,2) = 1000 IATN11(1,3) = 10000 IVCOMP = FF322(IATN11) IVCORR = 1111 40250 IF (IVCOMP - 1111) 20250, 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,80010) IVTNUM, IVCOMP, IVCORR 0261 CONTINUE C C **** FCVS PROGRAM 317 - TEST 026 **** C C USE AN ARRAY ELEMENT NAME AS AN ACTUAL ARGUMENT IN WHICH THE C ASSOCIATED ACTUAL AND DUMMY ARRAY DECLARATORS ARE IDENTICAL. ALL C ARRAY ELEMENTS OF THE ACTUAL ARRAY SHOULD BE PASSED TO THE C DUMMY ARRAY OF THE EXTERNAL FUNCTION. C IVTNUM = 26 IF (ICZERO) 30260, 0260, 30260 0260 CONTINUE RVCOMP = 0.0 RADN12(1) = 1. RADN12(2) = 10. RADN12(3) = 100. RADN12(4) = 1000. RVCOMP = FF323(RADN12(1)) RVCORR = 1111. 40260 IF (RVCOMP - 1110.5) 20260, 10260, 40261 40261 IF (RVCOMP - 1111.5) 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 317 - TEST 027 **** C C USE AN ARRAY ELEMENT NAME AS AN ACTUAL ARGUMENT IN WHICH THE SIZE C OF THE ACTUAL ARGUMENT ARRAY IS LARGER AND HAS FEWER SUBSCRIPT C EXPRESSIONS THAN THE ASSOCIATED DUMMY ARGUMENT ARRAY. ONLY ACTUAL C ARRAY ELEMENTS WITH SUBSCRIPT VALUES OF 5, 6, 7 AND 8 (OUT OF A C POSSIBLE 10 ELEMENTS) SHOULD BE PASSED TO THE DUMMY ARRAY OF THE C EXTERNAL FUNCTION. C IVTNUM = 27 IF (ICZERO) 30270, 0270, 30270 0270 CONTINUE RVCOMP = 0.0 RACN11(4) = 1. RACN11(5) = 10. RACN11(6) = 100. RACN11(7) = 1000. RACN11(8) = 10000. RACN11(9) = 100000. RVCORR = 11110. RVCOMP = FF323(RACN11(5)) 40270 IF (RVCOMP - 11105.) 20270, 10270, 40271 40271 IF (RVCOMP - 11115.) 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 317 - TEST 028 **** C C USE AN ARRAY ELEMENT NAME AS AN ACTUAL ARGUMENT IN WHICH THE SIZE C OF THE ACTUAL ARGUMENT ARRAY IS LARGE THAN THE SIZE OF THE C ASSOCIATED DUMMY ARGUMENT ARRAY. ONLY ACTUAL ARRAY ELEMENTS WITH C SUBSCRIPT VALUES OF 9, 10, 11 AND 12 (OUT OF A POSSIBLE 12 C ELEMENTS) SHOULD BE PASSED TO THE DUMMY ARRAY OF THE EXTERNAL C FUNCTION. C IVTNUM = 28 IF (ICZERO) 30280, 0280, 30280 0280 CONTINUE RVCOMP = 0.0 RATN11(2,3) = 1. RATN11(3,3) = 10. RATN11(1,4) = 100. RATN11(2,4) = 1000. RATN11(3,4) = 10000. RVCOMP = FF323(RATN11(3,3)) RVCORR = 11110. 40280 IF (RVCOMP - 11105.) 20280, 10280, 40281 40281 IF (RVCOMP - 11115.) 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 TEST 029 THROUGH TEST 032 ARE DESIGNED TO ASSOCIATE VARIOUS FORMS C OF ACTUAL ARGUMENTS TO PROCEDURES USED AS DUMMY ARGUMENTS. C ACTUAL ARGUMENTS TESTED INCLUDE THE NAMES OF AN EXTERNAL FUNCTION, C AN INTRINSIC FUNCTION, AND A SUBROUTINE. C C C **** FCVS PROGRAM 317 - TEST 029 **** C C USE AN EXTERNAL FUNCTION NAME AS AN ACTUAL ARGUMENT. C IVTNUM = 29 IF (ICZERO) 30290, 0290, 30290 0290 CONTINUE IVCOMP = 0 IVCOMP = FF324(FF325,5) IVCORR = 7 40290 IF (IVCOMP - 7) 20290, 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,80010) IVTNUM, IVCOMP, IVCORR 0301 CONTINUE C C **** FCVS PROGRAM 317 - TEST 030 **** C C USE AN INTRINSIC FUNCTION NAME AS AN ACTUAL ARGUMENT. C IVTNUM = 30 IF (ICZERO) 30300, 0300, 30300 0300 CONTINUE IVCOMP = 0 IVCOMP = FF324(IABS,-7) IVCORR = 8 40300 IF (IVCOMP - 8) 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 317 - TEST 031 **** C C USE AN EXTERNAL FUNCTION NAME AS AN ACTUAL ARGUMENT. THE C INTRINSIC FUNCTION NAME (NINT) IS USED AS THE DUMMY PROCEDURE C NAME IN THE EXTERNAL FUNCTION AND THEREFORE CAN NOT BE USED AS C AN INTRINSIC FUNCTION WITHIN THAT PROGRAM UNIT. HOWEVER IT CAN C BE REFERENCED IN THE MAIN PROGRAM FM317 AND IN THE SUBPROGRAM C FF325. C IVTNUM = 31 IF (ICZERO) 30310, 0310, 30310 0310 CONTINUE IVCOMP = 0 IVCOMP = NINT(3.7) + FF324(FF325,2) IVCORR = 8 40310 IF (IVCOMP - 8) 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 317 - TEST 032 **** C C USE A SUBROUTINE NAME AS AN ACTUAL ARGUMENT. C IVTNUM = 32 IF (ICZERO) 30320, 0320, 30320 0320 CONTINUE RVCOMP = 0.0 RVON01 = 3.5 RVCOMP = FF326(FS327,RVON01) RVCORR = 5.5 40320 IF (RVCOMP - 5.4995) 20320, 10320, 40321 40321 IF (RVCOMP - 5.5005) 10320, 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,80012) IVTNUM, RVCOMP, RVCORR 0331 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,5HFM317) 90000 FORMAT (1H ,20X,20HEND OF PROGRAM FM317) 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 FF318(IDON01) C THIS FUNCTION IS USED BY VARIOUS TESTS IN MAIN PROGRAM FM317 C TO TEST THE ASSOCIATION OF VARIOUS FORMS OF INTEGER ACTUAL C ARGUMENTS TO AN INTEGER VARIABLE NAME USED AS AN EXTERNAL C FUNCTION DUMMY ARGUMENT. THIS ROUTINE INCREMENTS THE ARGUMENT C VALUE BY ONE AND RETURNS THE RESULT AS THE FUNCTION VALUE. FF318 = IDON01 + 1 RETURN END REAL FUNCTION FF319(RDON01) C THIS FUNCTION IS USED BY VARIOUS TESTS IN MAIN PROGRAM FM317 C TO TEST THE ASSOCIATION OF VARIOUS FORMS OF REAL ACTUAL C ARGUMENTS TO A REAL VARIABLE NAME USED AS AN EXTERNAL FUNCTION C DUMMY ARGUMENT. THIS ROUTINE INCREMENTS THE ARGUMENT VALUE BY C ONE AND RETURNS THE RESULT AS THE FUNCTION VALUE. FF319 = RDON01 + 1.0 RETURN END LOGICAL FUNCTION FF320(LDON01) C THIS FUNCTION IS USED BY VARIOUS TESTS IN MAIN PROGRAM FM317 C TO TEST THE ASSOCIATION OF VARIOUS FORMS OF LOGICAL ACTUAL C ARGUMENTS TO A LOGICAL VARIABLE NAME USED AS AN EXTERNAL C FUNCTION DUMMY ARGUMENT. THIS ROUTINE NEGATES THE ARGUMENT C VALUE AND RETURNS THE RESULT AS THE FUNCTION VALUE. LOGICAL LDON01 FF320 = .NOT. LDON01 RETURN END INTEGER FUNCTION FF321(IDON02) C THIS FUNCTION IS USED IN TEST 019 OF MAIN PROGRAM FM317 AS C THE TEST OF THE USE OF AN EXTERNAL FUNCTION REFERENCE AS AN C ACTUAL ARGUMENT TO A VARIABLE NAME USED AS AN EXTERNAL FUNCTION C DUMMY ARGUMENT. THIS ROUTINE INCREMENTS THE ARGUMENT VALUE BY C ONE AND RETURNS THE RESULT AS THE FUNCTION VALUE. FF321 = IDON02 + 1 RETURN END INTEGER FUNCTION FF322(IDDN11) C THIS FUNCTION IS USED BY VARIOUS TESTS IN MAIN PROGRAM FM317 C TO TEST THE ASSOCIATION OF VARIOUS FORMS OF ARRAY NAMES USED AS C ACTUAL ARGUMENTS TO AN ARRAY NAME USED AS AN EXTERNAL FUNCTION C DUMMY ARGUMENT. THIS ROUTINE ADDS TOGETHER THE FOUR ELEMENTS IN C THE DUMMY ARRAY AND RETURNS THE SUM AS THE FUNCTION VALUE. DIMENSION IDDN11(4) FF322 = IDDN11(1) + IDDN11(2) + IDDN11(3) + IDDN11(4) RETURN END REAL FUNCTION FF323(RDTN21) C THIS FUNCTION IS USED BY VARIOUS TESTS IN MAIN PROGRAM FM317 C TO TEST THE ASSOCIATION OF VARIOUS FORMS OF ARRAY ELEMENT NAMES C USED AS ACTUAL ARGUMENTS TO AN ARRAY NAME USED AS AN EXTERNAL C FUNCTION DUMMY ARGUMENT. THIS ROUTINE ADDS TOGETHER THE FOUR C ELEMENTS IN THE DUMMY ARRAY AND RETURNS THE SUM AS THE FUNCTION C VALUE. REAL RDTN21(2,2) FF323 = RDTN21(1,1) + RDTN21(2,1) + RDTN21(1,2) + RDTN21(2,2) RETURN END INTEGER FUNCTION FF324(NINT, IDON03) C THIS FUNCTION IS USED BY TESTS 029, 030 AND 031 OF MAIN C PROGRAM FM317 TO TEST THE ASSOCIATION OF EXTERNAL FUNCTION AND C INTRINSIC FUNCTION NAMES USED AS ACTUAL ARGUMENTS TO A PROCEDURE C NAME USED AS A DUMMY ARGUMENT. THIS FUNCTION REFERENCES THE C EXTERNAL FUNCTION OR INTRINSIC FUNCTION PASSED AS A PROCEDURE C NAME ARGUMENT, INCREMENTING THE RESULT BY ONE BEFORE RETURNING C THE RESULT AS THE FUNCTION VALUE. FF324 = NINT(IDON03) + 1 C **** THE NAME NINT IS A DUMMY ARGUMENT C AND NOT AN INTRINSIC FUNCTION REFERENCE ***** RETURN END INTEGER FUNCTION FF325(IDON05) C THIS FUNCTION IS USED BY TESTS 029 AND 031 OF MAIN PROGRAM C FM317 TO TEST THE ASSOCIATION OF AN EXTERNAL FUNCTION NAME USED AS C AN ACTUAL ARGUMENT TO A PROCEDURE NAME USED AS A DUMMY ARGUMENT. C FF325 IS REFERENCED FROM EXTERNAL FUNCTION FF324 VIA A DUMMY C PROCEDURE NAME REFERENCE. THIS ROUTINE ADDS THE RESULT OF AN C INTRINSIC FUNCTION REFERENCE (NINT) TO THE ARGUMENT VALUE AND C RETURNS THE SUM AS THE FUNCTION VALUE. FF325 = IDON05 + NINT(1.2) RETURN END REAL FUNCTION FF326(RDON02,RDON03) C THIS FUNCTION IS USED BY TEST 032 OF MAIN PROGRAM FM317 TO C TEST THE ASSOCIATION OF A SUBROUTINE NAME USED AS AN ACTUAL C ARGUMENT TO A PROCEDURE NAME USED AS A DUMMY ARGUMENT. THIS C FUNCTION CALLS THE SUBROUTINE (FS327) PASSED AS A PROCEDURE NAME C ARGUMENT. THE VALUE OF THE ARGUMENT RETURNED FROM THIS C REFERENCE IS THEN INCREMENTED BY ONE BEFORE RETURNING THE SUM AS C THE FUNCTION VALUE. CALL RDON02(RDON03) FF326 = RDON03 + 1.0 RETURN END SUBROUTINE FS327(RDON04) C THIS SUBROUTINE IS USED BY TEST 032 OF MAIN PROGRAM FM317 TO C TEST THE ASSOCIATION OF A SUBROUTINE NAME USED AS AN ACTUAL C ARGUMENT TO A PROCEDURE NAME USED AS A DUMMY ARGUMENT. FS327 IS C CALLED FROM EXTERNAL PROGRAM FF326 VIA A DUMMY PROCEDURE NAME C REFERENCE. THIS ROUTINE INCREMENTS THE ARGUMENT VALUE BY ONE. RDON04 = RDON04 + 1.0 RETURN END