PROGRAM FM328
C
C
C THIS ROUTINE TEST SUBSET LEVEL FEATURES OF
C SUBROUTINE 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 ALL DATA PASSED TO THE REFERENCED SUBPROGRAMS ARE PASSED VIA
C ARGUMENT VALUES, WHILE ALL RESULTS RETURNED TO FM328 ARE
C RETURNED VIA VARIABLES IN NAMED COMMON. SUBSET LEVEL ROUTINES
C FM026, FM050 AND FM056 ALSO TEST THE USE OF SUBROUTINES.
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 IATN11(2,3)
REAL RATN11(3,4)
INTEGER FF330
DIMENSION IADN11(4), IADN12(4)
DIMENSION RADN11(4), RADN12(4)
DIMENSION LADN11(4)
COMMON /BLK1/IVCN01, RVCN01, LVCN01
COMMON IACN11(6), RACN11(10)
EXTERNAL FF330, FS335
INTRINSIC ABS, IABS, NINT
IFOS01(IDON04) = IDON04 + 1
RFOS01(RDON04) = RDON04 + 1.0
LFOS01(LDON04) = .NOT. LDON04
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 013 ARE DESIGNED TO ASSOCIATE VARIOUS FORMS
C OF ACTUAL ARGUMENTS TO VARIABLE NAMES USED AS SUBROUTINE
C DUMMY ARGUMENTS. INTEGER, REAL AND LOGICAL DUMMY ARGUMENTS ARE
C TESTED.
C
C
C **** FCVS PROGRAM 328 - TEST 001 ****
C
C USE INTEGER, REAL AND LOGICAL CONSTANTS AS ACTUAL ARGUMENTS.
C
IVTNUM = 1
IF (ICZERO) 30010, 0010, 30010
0010 CONTINUE
CALL FS329(3, 3.0, .FALSE.)
IVCOMP = 1
IF (IVCN01 .EQ. 4) IVCOMP = IVCOMP * 2
IF (RVCN01 .GE. 3.9995 .AND. RVCN01 .LE. 4.0005) IVCOMP = IVCOMP*3
IF (LVCN01) IVCOMP = IVCOMP * 5
IVCORR = 30
40010 IF (IVCOMP - 30) 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 328 - TEST 002 ****
C
C USE INTEGER, REAL AND LOGICAL VARIABLES AS ACTUAL ARGUMENTS.
C
IVTNUM = 2
IF (ICZERO) 30020, 0020, 30020
0020 CONTINUE
IVON01 = 7
RVON01 = 7.0
LVON01 = .TRUE.
CALL FS329(IVON01, RVON01, LVON01)
IVCOMP = 1
IF (IVCN01 .EQ. 8) IVCOMP =IVCOMP * 2
IF (RVCN01 .GE. 7.9995 .AND. RVCN01 .LE. 8.0005) IVCOMP = IVCOMP*3
IF (.NOT. LVCN01) IVCOMP = IVCOMP * 5
IVCORR = 30
40020 IF (IVCOMP - 30) 20020, 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,80010) IVTNUM, IVCOMP, IVCORR
0031 CONTINUE
C
C **** FCVS PROGRAM 328 - TEST 003 ****
C
C USE INTEGER, REAL AND LOGICAL ARRAY ELEMENT NAMES AS ACTUAL
C ARGUMENTS.
C
IVTNUM = 3
IF (ICZERO) 30030, 0030, 30030
0030 CONTINUE
IADN11(2) = 2
RADN11(4) = 4.0
LADN11(1) = .FALSE.
CALL FS329(IADN11(2), RADN11(4), LADN11(1))
IVCOMP = 1
IF (IVCN01 .EQ. 3) IVCOMP = IVCOMP * 2
IF (RVCN01 .GE. 4.9995 .AND. RVCN01 .LE. 5.0005) IVCOMP = IVCOMP*3
IF (LVCN01) IVCOMP = IVCOMP * 5
IVCORR = 30
40030 IF (IVCOMP - 30) 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 328 - TEST 004 ****
C
C INTEGER AND REAL EXPRESSIONS INVOLVING OPERATORS AS ACTUAL
C ARGUMENTS.
C
IVTNUM = 4
IF (ICZERO) 30040, 0040, 30040
0040 CONTINUE
IVON02 = 2
IVON03 = 3
RVON02 = 2.
RVON03 = 1.2
CALL FS329(IVON02 + 3 * IVON03 - 7, RVON02 *RVON03 / .6, .TRUE.)
IVCOMP = 1
IF (IVCN01 .EQ. 5) IVCOMP = IVCOMP * 2
IF (RVCN01 .GE. 4.9995 .AND. RVCN01 .LE. 5.0005) IVCOMP = IVCOMP*3
IVCORR = 6
40040 IF (IVCOMP - 6) 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 328 - TEST 005 ****
C
C REAL EXPRESSION INVOLVING INTEGER AND REAL PRIMARIES AND OPERATORS
C AS ACTUAL ARGUMENT.
C
IVTNUM = 5
IF (ICZERO) 30050, 0050, 30050
0050 CONTINUE
RVCOMP = 0.0
IVON01 = 2
RADN11(2) = 2.5
CALL FS329(1, IVON01**3 * (RADN11(2) - 1) + 2.0, .TRUE.)
RVCOMP = RVCN01
RVCORR = 15.0
40050 IF (RVCOMP - 14.995) 20050, 10050, 40051
40051 IF (RVCOMP - 15.005) 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 328 - TEST 006 ****
C
C LOGICAL EXPRESSION INVOLVING LOGICAL OPERATOR (.NOT.) AS ACTUAL
C ARGUMENT.
C
IVTNUM = 6
IF (ICZERO) 30060, 0060, 30060
0060 CONTINUE
LVON01 = .TRUE.
CALL FS329(1, 1.0, .NOT. LVON01)
IVCOMP = 0
IF (LVCN01) 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 328 - TEST 007 ****
C
C LOGICAL EXPRESSION INVOLVING LOGICAL OPERATOR (.OR.) AS ACTIVE
C ARGUMENT.
C
IVTNUM = 7
IF (ICZERO) 30070, 0070, 30070
0070 CONTINUE
LVON01 = .TRUE.
LVON02 = .FALSE.
CALL FS329(1, 1.0, LVON01 .OR. LVON02)
IVCOMP = 0
IF (.NOT. LVCN01) IVCOMP = 1
IVCORR = 1
40070 IF (IVCOMP - 1) 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 328 - TEST 008 ****
C
C LOGICAL EXPRESSION INVOLVING LOGICAL OPERATOR (.AND.) AS ACTUAL
C ARGUMENT.
C
IVTNUM = 8
IF (ICZERO) 30080, 0080, 30080
0080 CONTINUE
LVON01 = .FALSE.
LVON02 = .TRUE.
CALL FS329(1, 1.0, LVON01 .AND. LVON02)
IVCOMP = 0
IF (LVCN01) IVCOMP = 1
IVCORR = 1
40080 IF (IVCOMP - 1) 20080, 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,80010) IVTNUM, IVCOMP, IVCORR
0091 CONTINUE
C
C **** FCVS PROGRAM 328 - TEST 009 ****
C
C EXPRESSION ENCLOSED IN PARENTHESES AS ACTUAL ARGUMENT.
C
IVTNUM = 9
IF (ICZERO) 30090, 0090, 30090
0090 CONTINUE
IVCOMP = 0
IVON01 = 6
CALL FS329((IVON01 + 3), 1.0, .TRUE.)
IVCOMP = IVCN01
IVCORR = 10
40090 IF (IVCOMP - 10) 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 328 - TEST 010 ****
C
C INTEGER AND REAL INTRINSIC FUNCTION REFERENCES AS ACTUAL ARGUMENTS
C
IVTNUM = 10
IF (ICZERO) 30100, 0100, 30100
0100 CONTINUE
RVON01 = 4.7
RVON02 = -5.2
CALL FS329(NINT(RVON01), ABS(RVON02), .TRUE.)
IVCOMP = 1
IF (IVCN01 .EQ. 6) IVCOMP = IVCOMP * 2
IF (RVCN01 .GE. 6.1995 .AND. RVCN01 .LE. 6.2005) IVCOMP = IVCOMP*3
IVCORR = 6
40100 IF (IVCOMP - 6) 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 328 - TEST 011 ****
C
C EXTERNAL FUNCTION REFERENCE AS ACTUAL ARGUMENT.
C
IVTNUM = 11
IF (ICZERO) 30110, 0110, 30110
0110 CONTINUE
IVCOMP = 0
IVON01 = 4
CALL FS329(FF330(IVON01), 1.0, .TRUE.)
IVCOMP = IVCN01
IVCORR = 6
40110 IF (IVCOMP - 6) 20110, 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,80010) IVTNUM, IVCOMP, IVCORR
0121 CONTINUE
C
C **** FCVS PROGRAM 328 - TEST 012 ****
C
C USE ACTUAL ARGUMENT NAMES WHICH ARE IDENTICAL TO THE DUMMY
C ARGUMENT NAMES.
C
IVTNUM = 12
IF (ICZERO) 30120, 0120, 30120
0120 CONTINUE
IDON01 = 10
RDON01 = 10.0
LDON01 = .FALSE.
CALL FS329(IDON01, RDON01, LDON01)
IVCOMP = 1
IF (IVCN01 .EQ. 11) IVCOMP = IVCOMP * 2
IF (RVCN01 .GE. 10.995 .AND. RVCN01 .LE. 11.005) IVCOMP = IVCOMP*3
IF (LVCN01) IVCOMP = IVCOMP * 5
IVCORR = 30
40120 IF (IVCOMP - 30) 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 328 - TEST 013 ****
C
C USE INTEGER, REAL AND LOGICAL STATEMENT FUNCTION REFERENCES AS
C ARGUMENT NAMES.
C
IVTNUM = 13
IF (ICZERO) 30130, 0130, 30130
0130 CONTINUE
RVON01 = 5.0
CALL FS329(IFOS01(4), RFOS01(RVON01), LFOS01(.TRUE.))
IVCOMP = 1
IF (IVCN01 .EQ. 6) IVCOMP = IVCOMP * 2
IF (RVCN01 .GE. 6.9995 .AND. RVCN01 .LE. 7.0005) IVCOMP = IVCOMP*3
IF (LVCN01) IVCOMP = IVCOMP * 5
IVCORR = 30
40130 IF (IVCOMP - 30) 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 TEST 014 THROUGH TEST 019 ARE DESIGNED TO ASSOCIATE VARIOUS FORMS
C OF ACTUAL ARGUMENTS TO ARRAY NAMES USED AS SUBROUTINE DUMMY
C ARGUMENTS.
C
C
C **** FCVS PROGRAM 328 - TEST 014 ****
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 = 14
IF (ICZERO) 30140, 0140, 30140
0140 CONTINUE
IVCOMP = 0
IADN12(1) = 1
IADN12(2) = 10
IADN12(3) = 100
IADN12(4) = 1000
CALL FS331(IADN12)
IVCOMP = IVCN01
IVCORR = 1111
40140 IF (IVCOMP - 1111) 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 328 - TEST 015 ****
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 = 15
IF (ICZERO) 30150, 0150, 30150
0150 CONTINUE
IVCOMP = 0
IACN11(1) = 1
IACN11(2) = 10
IACN11(3) = 100
IACN11(4) = 1000
IACN11(5) = 10000
CALL FS331(IACN11)
IVCOMP = IVCN01
IVCORR = 1111
40150 IF (IVCOMP - 1111) 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 328 - TEST 016 ****
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
IVTNUM = 16
IF (ICZERO) 30160, 0160, 30160
0160 CONTINUE
IVCOMP = 0
IATN11(1,1) = 1
IATN11(2,1) = 10
IATN11(1,2) = 100
IATN11(2,2) = 1000
IATN11(1,3) = 10000
CALL FS331(IATN11)
IVCOMP = IVCN01
IVCORR = 1111
40160 IF (IVCOMP - 1111) 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 328 - TEST 017 ****
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 SUBROUTINE.
C
IVTNUM = 17
IF (ICZERO) 30170, 0170, 30170
0170 CONTINUE
RVCOMP = 0.0
RADN12(1) = 1.
RADN12(2) = 10.
RADN12(3) = 100.
RADN12(4) = 1000.
CALL FS332(RADN12(1))
RVCOMP = RVCN01
RVCORR = 1111.
40170 IF (RVCOMP - 1110.5) 20170, 10170, 40171
40171 IF (RVCOMP - 1111.5) 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 328 - TEST 018 ****
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 ARRAY. ONLY ACTUAL ARRAY
C 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
C THE SUBROUTINE.
C
IVTNUM = 18
IF (ICZERO) 30180, 0180, 30180
0180 CONTINUE
RVCOMP = 0.0
RACN11(4) = 1.
RACN11(5) = 10.
RACN11(6) = 100.
RACN11(7) = 1000.
RACN11(8) = 10000.
RACN11(9) = 100000.
CALL FS332(RACN11(5))
RVCOMP = RVCN01
RVCORR = 11110.
40180 IF (RVCOMP - 11105.) 20180, 10180, 40181
40181 IF (RVCOMP - 11115.) 10180, 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,80012) IVTNUM, RVCOMP, RVCORR
0191 CONTINUE
C
C **** FCVS PROGRAM 328 - TEST 019 ****
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 SUBROUTINE.
C
IVTNUM = 19
IF (ICZERO) 30190, 0190, 30190
0190 CONTINUE
RVCOMP = 0.0
RATN11(2,3) = 1.
RATN11(3,3) = 10.
RATN11(1,4) = 100.
RATN11(2,4) = 1000.
RATN11(3,4) = 10000.
CALL FS332(RATN11(3,3))
RVCOMP = RVCN01
RVCORR = 11110.
40190 IF (RVCOMP - 11105.) 20190, 10190, 40191
40191 IF (RVCOMP - 11115.) 10190, 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,80012) IVTNUM, RVCOMP, RVCORR
0201 CONTINUE
C
C TEST 020 THROUGH TEST 022 ARE DESIGNED TO ASSOCIATE VARIOUS FORMS
C OF ACTUAL ARGUMENTS TO PROCEDURES USED AS SUBROUTINE DUMMY
C ARGUMENTS. ACTUAL ARGUMENTS TESTED INCLUDE THE NAMES OF AN
C EXTERNAL FUNCTION, AN INTRINSIC FUNCTION AND A SUBROUTINE.
C
C
C **** FCVS PROGRAM 328 - TEST 020 ****
C
C USE AN EXTERNAL FUNCTION NAME AS AN ACTUAL ARGUMENT.
C
IVTNUM = 20
IF (ICZERO) 30200, 0200, 30200
0200 CONTINUE
IVCOMP = 0
CALL FS333(FF330, 5)
IVCOMP = IVCN01
IVCORR = 7
40200 IF (IVCOMP - 7) 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 328 - TEST 021 ****
C
C USE AN INTRINSIC FUNCTION NAME AS AN ACTUAL ARGUMENT.
C
IVTNUM = 21
IF (ICZERO) 30210, 0210, 30210
0210 CONTINUE
IVCOMP = 0
CALL FS333(IABS, -7)
IVCOMP = IVCN01
IVCORR = 8
40210 IF (IVCOMP - 8) 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 328 - TEST 022 ****
C
C USE A SUBROUTINE NAME AS AN ACTUAL ARGUMENT.
C
IVTNUM = 22
IF (ICZERO) 30220, 0220, 30220
0220 CONTINUE
RVCOMP = 0.0
RVON01 = 3.5
CALL FS334(FS335, RVON01)
RVCOMP = RVCN01
RVCORR = 5.5
40220 IF (RVCOMP - 5.4995) 20220, 10220, 40221
40221 IF (RVCOMP - 5.5005) 10220, 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,80012) IVTNUM, RVCOMP, RVCORR
0231 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,5HFM328)
90000 FORMAT (1H ,20X,20HEND OF PROGRAM FM328)
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
SUBROUTINE FS329(IDON01, RDON01, LDON01)
C THIS SUBROUTINE IS USED BY VARIOUS TESTS IN THE MAIN PROGRAM
C FM328 TO TEST THE DIFFERENT FORMS OF INTEGER, REAL AND LOGICAL
C ACTUAL ARGUMENTS THAT CAN BE ASSOCIATED WITH INTEGER, REAL AND
C LOGICAL DUMMY ARGUMENTS. THIS ROUTINE INCREMENTS THE INTEGER
C AND REAL ARGUMENTS BY ONE AND NEGATES THE LOGICAL ARGUMENT. ALL
C RESULTS ARE THEN RETURNED TO FM328 VIA VARIABLES IN NAMED COMMON.
IMPLICIT LOGICAL (L)
COMMON /BLK1/ IVCN01, RVCN01, LVCN01
IVCN01 = IDON01 + 1
RVCN01 = RDON01 + 1.0
LVCN01 = .NOT. LDON01
RETURN
END
INTEGER FUNCTION FF330(IDON02)
C THIS FUNCTION IS USED BY TEST 011 OF THE MAIN PROGRAM FM328 TO
C TEST THE USE OF AN EXTERNAL FUNCTION REFERENCE AS AN ACTUAL
C ARGUMENT WHEN THE ASSOCIATED DUMMY ARGUMENT IS A VARIABLE NAME.
C THIS FUNCTION IS ALSO REFERENCED FROM SUBROUTINE FS333 VIA A
C DUMMY PROCEDURE NAME REFERENCE. THIS FUNCTION INCREMENTS THE
C ARGUMENT VALUE BY ONE AND RETURNS THE RESULT AS THE FUNCTION
C VALUE.
FF330 = IDON02 + 1
RETURN
END
SUBROUTINE FS331(IDDN11)
C THIS SUBROUTINE IS USED BY VARIOUS TESTS IN THE MAIN PROGRAM
C FM328 TO TEST THE USE OF AN ARRAY NAME AS AN ACTUAL ARGUMENT WHEN
C THE ASSOCIATED DUMMY ARGUMENT IS AN ARRAY NAME. THIS ROUTINE
C ADDS TOGETHER THE FOUR ELEMENTS IN THE DUMMY ARGUMENT ARRAY AND
C RETURNS THE RESULTS VIA A VARIABLE IN NAMED COMMON.
LOGICAL LVCN01
DIMENSION IDDN11(4)
COMMON /BLK1/IVCN01, RVCN01, LVCN01
IVCN01 = IDDN11(1) + IDDN11(2) + IDDN11(3) + IDDN11(4)
RETURN
END
SUBROUTINE FS332(RDTN21)
C THIS SUBROUTINE IS USED BY VARIOUS TESTS IN THE MAIN PROGRAM
C FM328 TO TEST THE USE OF AN ARRAY ELEMENT NAME AS AN ACTUAL
C ARGUMENT WHEN THE ASSOCIATED DUMMY ARGUMENT IS AN ARRAY NAME.
C THIS ROUTINE ADDS TOGETHER THE FOUR ELEMENTS IN THE DUMMY
C ARGUMENT ARRAY AND RETURNS THE RESULT VIA A VARIABLE IN NAMED
C COMMON.
IMPLICIT LOGICAL (L)
REAL RDTN21(2,2)
COMMON /BLK1/IVCN01, RVCN01, LVCN01
RVCN01 = RDTN21(1,1) + RDTN21(2,1) + RDTN21(1,2) + RDTN21(2,2)
RETURN
END
SUBROUTINE FS333(NINT, IDON03)
C THIS SUBROUTINE IS USED BY TESTS 020 AND 021 OF THE MAIN
C PROGRAM FM328 TO TEST THE USE OF EXTERNAL AND INTRINSIC FUNCTION
C NAMES AS ACTUAL ARGUMENTS WHEN THE ASSOCIATED DUMMY ARGUMENT IS A
C PROCEDURE NAME. THIS SUBROUTINE REFERENCES THE EXTERNAL FUNCTION
C FF330 OR THE INTRINSIC FUNCTION IABS DEPENDING ON THE ACTUAL
C ARGUMENT PASSED TO IT. THE RESULT OF THIS FUNCTION REFERENCE IS
C THEN INCREMENTED BY ONE AND THE RESULT IS RETURNED TO FS328 VIA
C A VARIABLE IN NAMED COMMON.
IMPLICIT LOGICAL (L)
COMMON /BLK1/IVCN01, RVCN01, LVCN01
IVCN01 = NINT(IDON03) + 1
C **** THE NAME NINT IS A DUMMY ARGUMENT NAME
C AND NOT AN INTRINSIC FUNCTION REFERENCE ****
RETURN
END
SUBROUTINE FS334(IDON06, RDON03)
C THIS SUBROUTINE IS USED BY TEST 022 OF THE MAIN PROGRAM
C FM328 TO TEST THE USE OF A SUBROUTINE NAME AS AN ACTUAL ARGUMENT
C WHEN THE ASSOCIATED DUMMY ARGUMENT IS A PROCEDURE NAME. THIS
C SUBROUTINE CALLS THE SUBROUTINE FS335 VIA A DUMMY PROCEDURE NAME
C REFERENCE. THE ARGUMENT VALUE WHICH IS RETURNED FROM THE FS335
C REFERENCE IS THEN INCREMENTED BY ONE AND RETURNED TO FM328 VIA
C A VARIABLE IN NAMED COMMON.
IMPLICIT LOGICAL (L)
COMMON /BLK1/IVCN01, RVCN01, LVCN01
CALL IDON06(RDON03)
RVCN01 = RDON03 + 1.0
RETURN
END
SUBROUTINE FS335(RDON04)
C THIS SUBROUITNE IS USED BY TEST 022 OF THE MAIN PROGRAM FM328
C TO TEST THE USE OF A SUBROUTINE NAME AS AN ACTUAL ARGUMENT WHEN
C THE ASSOCIATED DUMMY ARGUMENT IS A PROCEDURE NAME. FS335 IS
C CALLED FROM SUBROUTINE FS334 VIA A DUMMY PROCEDURE NAME REFERENCE.
C THIS ROUTINE INCREMENTS THE ARGUMENT VALUE BY ONE.
RDON04 = RDON04 + 1.0
RETURN
END