PROGRAM FM302
C
C
C THIS ROUTINE TESTS THE SUBSET LEVEL FEATURES OF THE COMMON
C SPECIFICATION STATEMENT. INTEGER, REAL AND LOGICAL VARIABLES AND
C ARRAYS ARE PASSED BACK-AND-FORTH BETWEEN THE MAIN PROGRAM,EXTERNAL
C FUNCTIONS AND SUBROUTINES. BOTH NAMED AND UNNAMED (BLANK) COMMON
C ARE TESTED. SPECIFIC TESTS ARE INCLUDED FOR RENAMING ENTITIES IN
C COMMON BETWEEN PROGRAM UNITS, THE PASSING OF DATA THROUGH COMMON
C BY EQUIVALENCE ASSOCIATION, AND THE SPECIFYING OF BLANK COMMON OF
C DIFFERENT LENGTHS IN DIFFERENT PROGRAM UNITS. THE SUBSET LEVEL
C FEATURES OF THE COMMON STATEMENT ARE ALSO TESTED IN FM022 THROUGH
C FM025, FM050 AND FM056.
C
C REFERENCES.
C AMERICAN NATIONAL STANDARD PROGRAMMING LANGUAGE FORTRAN,
C X3.9-1978
C
C SECTION 8.2, EQUIVALENCE STATEMENT
C SECTION 8.3, COMMON STATEMENT
C SECTION 15.5, EXTERNAL FUNCTIONS
C SECTION 15.6, SUBROUTINES
C SECTION 15.9.4, 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
C
C *** SPECIFICATION STATEMENT FOR TEST 001 ***
C
COMMON IVCN01
C
C *** SPECIFICATION STATEMENT FOR TEST 002 ***
C
COMMON //IVCN02,LVCN01
C
C *** SPECIFICATION STATEMENT FOR TEST 003 ***
C
COMMON RVCN01//IVCN03
C
C *** SPECIFICATION STATEMENT FOR TEST 004 ***
C
COMMON IVCN04, IVCN05, // IACN11(4)
C
C *** SPECIFICATION STATEMENT FOR TEST 005 ***
C
COMMON /BLK1/ IVCNA1
C
C *** SPECIFICATION STATEMENT FOR TEST 006 ***
C
COMMON /BLK2/IVCNB1,RVCNB1, /BLK2/IVCNB2
C
C *** SPECIFICATION STATEMENT FOR TEST 007 ***
C
DIMENSION RACN11(10)
COMMON /BLK3/LVCNC1,IVCNC1/BLK4/RACN11,IACN21(2,3)
C
C *** SPECIFICATION STATEMENT FOR TEST 008 ***
C
COMMON /BLK5/IVCND1, IVCND2
C
C *** SPECIFICATION STATEMENT FOR TEST 009 ***
C
COMMON IVCN06/BLK5/RVCND1,LVCND1//IVCN07,IVCN08/BLK6/RVCNE1
C
C *** SPECIFICATION STATEMENT FOR TEST 010 ***
C
DIMENSION IACN1F(3)
COMMON /BLK7/IVCNF1,IVCNF2,IVCNF3,IACN1F
C
C *** SPECIFICATION STATEMENT FOR TEST 011 ***
C
EQUIVALENCE (IVCEH1,IVCEH2)
COMMON /BLK8/IVCEH1
C
C *** SPECIFICATION STATEMENT FOR TEST 012
EQUIVALENCE (IVCE09,IVCE10)
COMMON IVCE09
C
C *** SPECIFICATION STATEMENT FOR TEST 013
C
EQUIVALENCE (IVCEI1,IACE1I)
DIMENSION IACE1I(3)
COMMON /BLK9/IVCEI1
C
C *** SPECIFICATION STATEMENT FOR TEST 014 ***
C
COMMON IVCN12
C
C *** SPECIFICATION STATEMENT FOR TEST 015 ***
C
COMMON /BLK10/IVCNJ1
C
C *** SPECIFICATION STATEMENT FOR TEST 016 ***
C
COMMON /BLKCHR/CVTN01,CVTN02,CATN11
CHARACTER CVTN01*2, CVTN02*3, CATN11(3)*5
INTEGER FF304
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 THE FOLLOWING ASSIGNMENT STATEMENTS INITIALIZE THE DATA
C ENTITIES BEING PASSED THROUGH COMMON TO SUBROUTINE FS303. ONLY
C ONE REFERENCE TO THIS SUBPROGRAM IS MADE FROM THIS PROGRAM. THE
C CONTENTS OF THE DATA ENTITIES BEING RETURNED THROUGH COMMON ARE
C THEN CHECKED IN THIS PROGRAM.
C
C
IVCN01 = 3
IVCN02 = 2
LVCN01 = .FALSE.
IVCNA1 = 25
IVCNB1 = 3
RVCNB1 = 4.0
IVCNB2 = 5
LVCNC1 = .TRUE.
IVCNC1 = 13
RACN11(1) = 1.
RACN11(10) = 10.0
IACN21(1,1) = 11
IACN21(2,3) = 23
IVCNF1 = 41
IVCNF3 = 43
IACN1F(1) = 141
IACN1F(2) = 142
IVCEH1 = 1
IVCEH2 = 5
CVTN01 = 'AB'
CVTN02 = 'CDE'
CATN11(1) = 'FGHIJ'
CATN11(2) = 'KLMNO'
CATN11(3) = 'PQRST'
CALL FS303
C
C THE FOLLOWING ASSIGNMENT STATEMENTS INITIALIZE THE DATA
C ENTITIES BEING PASSED THROUGH COMMON TO EXTERNAL FUNCTION FF304.
C ONLY ONE REFERENCE TO THIS SUBPROGRAM IS MADE FROM THIS PROGRAM.
C THE CONTENTS OF THE DATA ENTITIES BEING RETURNED THROUGH COMMON
C ARE THEN CHECKED IN THIS PROGRAM.
C
RVCN01 = 6.4
IVCN03 = 11
IVCN03 = IVCN03*2
IVCN04 = 16
IVCN05 = 16
IACN11(1) = 1
IACN11(2) = 2
IACN11(3) = 3
IACN11(4) = 4
IVCND1 = +33
IVCND2 = 10
IVCN06 = 6
IVCN07 = 7
IVCN08 = 8
RVCND1 = 1.3
LVCND1 = .FALSE.
RVCNE1 = +3.5
IVCE09 = 9
IVCE10 = 10
IVCEI1 = 5
IACE1I(1) = 10
IACE1I(2) = 15
IACE1I(3) = 20
IVCNJ1 = 1
IVON99 = FF304 ( )
C
C TESTS 001 THROUGH 009 ARE DESIGNED TO TEST VARIOUS
C SYNTACTICAL CONSTRUCTS OF THE COMMON STATEMENT USING NAMED AND
C UNNAMED (BLANK) COMMON IN THE MAIN PROGRAM, A SUBROUTINE AND AN
C EXTERNAL FUNCTION. DATA ENTITIES CONSIST OF INTEGER, REAL AND
C LOGICAL VARIABLES AND INTEGER AND REAL ARRAYS.
C
C **** FCVS PROGRAM 302 - TEST 001 ****
C
C TESTS 001 AND 002 TEST THE USE OF UNNAMED COMMON IN A MAIN
C PROGRAM AND A SUBROUTINE.
C
IVTNUM = 1
IF (ICZERO) 30010, 0010, 30010
0010 CONTINUE
IVCOMP = 0
IVCOMP = IVCN01
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 302 - TEST 002 ****
C
C
IVTNUM = 2
IF (ICZERO) 30020, 0020, 30020
0020 CONTINUE
IVCOMP = 1
IF (IVCN02 .EQ. 7) IVCOMP = IVCOMP * 2
IF (LVCN01) IVCOMP = IVCOMP * 3
IVCORR = 6
C 6 = 2 * 3
40020 IF (IVCOMP - 6) 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 302 - TEST 003 ****
C
C TESTS 003 AND 004 TEST THE USE OF UNNAMED COMMON IN A MAIN
C PROGRAM AND AN EXTERNAL FUNCTION.
C
IVTNUM = 3
IF (ICZERO) 30030, 0030, 30030
0030 CONTINUE
IVCOMP = 1
IF (RVCN01 .GE. 4.1995 .AND. RVCN01 .LE. 4.2005) IVCOMP=IVCOMP*2
IF (IVCN03 .EQ. 23) IVCOMP = IVCOMP * 3
IVCORR = 6
C 6 = 2 * 3
40030 IF (IVCOMP - 6) 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 302 - TEST 004 ****
C
C
IVTNUM = 4
IF (ICZERO) 30040, 0040, 30040
0040 CONTINUE
IVCOMP = 1
IF (IVCN04 .EQ. 8) IVCOMP = IVCOMP * 2
IF (IVCN05 .EQ. 16) IVCOMP = IVCOMP * 3
IF (IACN11(1) .EQ. 5) IVCOMP = IVCOMP * 5
IF (IACN11(2) .EQ. 5) IVCOMP = IVCOMP * 7
IF (IACN11(3) .EQ. 5) IVCOMP = IVCOMP * 11
IF (IACN11(4) .EQ. 5) IVCOMP = IVCOMP * 13
IVCORR = 30030
C 30030 = 2 * 3 * 5 * 7 * 11 * 13
40040 IF (IVCOMP - 30030) 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 302 - TEST 005 ****
C
C TESTS 005 THROUGH 007 TEST THE USE OF NAMED COMMON BLOCKS
C IN A MAIN PROGRAM AND A SUBROUTINE.
C
IVTNUM = 5
IF (ICZERO) 30050, 0050, 30050
0050 CONTINUE
IVCOMP = 0
IVCOMP = IVCNA1
IVCORR = 5
40050 IF (IVCOMP - 5) 20050, 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,80010) IVTNUM, IVCOMP, IVCORR
0061 CONTINUE
C
C **** FCVS PROGRAM 302 - TEST 006 ****
C
C
IVTNUM = 6
IF (ICZERO) 30060, 0060, 30060
0060 CONTINUE
IVCOMP = 1
IF (IVCNB1 .EQ. 8) IVCOMP = IVCOMP * 2
IF (RVCNB1 .GE. 3.4995 .AND. RVCNB1 .LE. 3.5005) IVCOMP=IVCOMP*3
IF (IVCNB2 .EQ. 5) IVCOMP = IVCOMP * 5
IVCORR = 30
C 30 = 2 * 3 * 5
40060 IF (IVCOMP - 30) 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 302 - TEST 007 ****
C
C
IVTNUM = 7
IF (ICZERO) 30070, 0070, 30070
0070 CONTINUE
IVCOMP = 1
IF (.NOT. LVCNC1) IVCOMP = IVCOMP * 2
IF (IVCNC1 .EQ. 12) IVCOMP = IVCOMP * 3
IF (RACN11(1).GE.110.95 .AND. RACN11(1).LE.111.05) IVCOMP=IVCOMP*5
IF (RACN11(10).GE.109.95.AND.RACN11(10).LE.110.05)IVCOMP=IVCOMP*7
IF (IACN21(1,1) .EQ. 12) IVCOMP = IVCOMP * 11
IF (IACN21 (2,3) .EQ. 24) IVCOMP = IVCOMP * 13
IVCORR = 30030
C 30030 = 2* 3 * 5 * 7 * 11 * 13
40070 IF (IVCOMP - 30030) 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 302 - TEST 008 ****
C
C TESTS 008 AND 009 TEST THE USE OF NAMED COMMON BLOCKS IN A
C MAIN PROGRAM AND AN EXTERNAL FUNCTION.
C
IVTNUM = 8
IF (ICZERO) 30080, 0080, 30080
0080 CONTINUE
IVCOMP = 1
IF (IVCND1 .EQ. 34) IVCOMP = IVCOMP * 2
IF (IVCND2 .EQ. 11) IVCOMP = IVCOMP * 3
IVCORR = 6
C 6 = 2 * 3
40080 IF (IVCOMP - 6) 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 302 - TEST 009 ****
C
C
IVTNUM = 9
IF (ICZERO) 30090, 0090, 30090
0090 CONTINUE
IVCOMP = 1
IF (IVCN06 .EQ. 7) IVCOMP = IVCOMP * 2
IF (RVCND1 .GE. 4.4995 .AND. RVCND1 .LE. 4.5005) IVCOMP = IVCOMP*3
IF (LVCND1) IVCOMP = IVCOMP * 5
IF (IVCN07 .EQ. -7) IVCOMP = IVCOMP * 7
IF (IVCN08 .EQ. -3) IVCOMP = IVCOMP * 11
IF (RVCNE1.GE.-6.7005.AND.RVCNE1.LE.-6.6995) IVCOMP=IVCOMP*13
IVCORR = 30030
C 30030 = 2 * 3 * 5 * 7 * 11 * 13
40090 IF (IVCOMP - 30030) 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 302 - TEST 010 ****
C
C TEST 010 IS DESIGNED TO TEST THE ABILITY TO RENAME ENTITIES
C IN NAMED COMMON BETWEEN A MAIN PROGRAM AND A SUBROUTINE.
C
IVTNUM = 10
IF (ICZERO) 30100, 0100, 30100
0100 CONTINUE
IVCOMP = 1
IF (IVCNF1 .EQ. 42) IVCOMP = IVCOMP * 2
IF (IVCNF2 .EQ. 43) IVCOMP = IVCOMP * 3
IF (IVCNF3 .EQ. 44) IVCOMP = IVCOMP * 5
IF (IACN1F(1) .EQ. 142) IVCOMP = IVCOMP * 7
IF (IACN1F(2) .EQ. 143) IVCOMP = IVCOMP * 11
IF (IACN1F(3) .EQ. 144) IVCOMP = IVCOMP * 13
IVCORR = 30030
C 30030 = 2 * 3 * 5 * 7 * 11 * 13
40100 IF (IVCOMP - 30030) 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 302 - TEST 011 ****
C
C TEST 011 IS DESIGNED TO TEST THE STORAGE OF A VARIABLE IN
C NAMED COMMON BY EQUIVALENCE ASSOCIATION.
C
IVTNUM = 11
IF (ICZERO) 30110, 0110, 30110
0110 CONTINUE
IVCOMP = 0
IVCOMP = IVCEH2
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 302 - TEST 012 ****
C
C TEST 012 IS DESIGNED TO TEST THE STORAGE OF A VARIABLE IN
C UNNAMED COMMON BY EQUIVALENCE ASSOCIATION.
C
IVTNUM = 12
IF (ICZERO) 30120, 0120, 30120
0120 CONTINUE
IVCOMP = 1
IF (IVCE09 .EQ. 100) IVCOMP = IVCOMP * 2
IF (IVCE10 .EQ. 100) IVCOMP = IVCOMP * 3
IVCORR = 6
C 6 = 2 * 3
40120 IF (IVCOMP - 6) 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 302 - TEST 013 ****
C
C TEST 013 IS DESIGNED TO TEST THE EXTENSION OF NAMED COMMON
C BLOCK STORAGE BY EQUIVALENCE ASSOCIATION OF A VARIABLE AND AN
C ARRAY.
C
IVTNUM = 13
IF (ICZERO) 30130, 0130, 30130
0130 CONTINUE
IVCOMP = 1
IF (IVCEI1 .EQ. 11) IVCOMP = IVCOMP * 2
IF (IACE1I(1) .EQ. 11) IVCOMP = IVCOMP * 3
IF (IACE1I(2) .EQ. 16) IVCOMP = IVCOMP * 5
IF (IACE1I(3) .EQ. 21) IVCOMP = IVCOMP * 7
IVCORR = 210
C 210 = 2 * 3 * 5 * 7
40130 IF (IVCOMP - 210) 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 302 - TEST 014 ****
C
C TEST 014 IS DESIGNED TO TEST THE ABILITY OF PASSING DATA
C THROUGH UNNAMED COMMON FROM EXTERNAL FUNCTIONS WHICH HAVE MORE
C ENTITIES IN UNNAMED COMMON THAN THE MAIN PROGRAM.
C
IVTNUM = 14
IF (ICZERO) 30140, 0140, 30140
0140 CONTINUE
IVCOMP = 0
IVCOMP = IVCN12
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 302 - TEST 015 ****
C
C TEST 015 IS DESIGNED TO TEST THE ABILITY OF PASSING DATA
C THROUGH NAMED COMMON BETWEEN EXTERNAL FUNCTIONS WHERE THE NAMED
C COMMON BLOCK IS NOT SPECIFIED IN THE MAIN PROGRAM.
C
IVTNUM = 15
IF (ICZERO) 30150, 0150, 30150
0150 CONTINUE
IVCOMP = 0
IVCOMP = IVCNJ1
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 302 - TEST 016 ****
C
C TEST 016 IS DESIGNED TO TEST THE PASSING OF CHARACTER DATA
C IN NAMED COMMON BETWEEN THE MAIN PROGRAM AND A SUBROUTINE.
C
IVTNUM = 16
IF (ICZERO) 30160, 0160, 30160
0160 CONTINUE
IVCOMP = 1
IF (CVTN01 .EQ. 'YZ') IVCOMP = IVCOMP * 2
IF (CVTN02 .EQ. 'UVW') IVCOMP = IVCOMP * 3
IF (CATN11(1) .EQ. 'VWXYZ') IVCOMP = IVCOMP * 5
IF (CATN11(2) .EQ. 'KLMNO') IVCOMP = IVCOMP * 7
IF (CATN11(3) .EQ. 'ABCDE') IVCOMP = IVCOMP * 11
IVCORR = 2310
C 2310 = 2 * 3 * 5 * 7 * 11
40160 IF (IVCOMP - 2310) 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
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,5HFM302)
90000 FORMAT (1H ,20X,20HEND OF PROGRAM FM302)
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 FS303
C
C FS303 IS A SUBROUTINE WHICH IS CALLED ONCE FROM PROGRAM FM302.
C IT IS USED TO MODIFY VARIABLES AND ARRAY PASSED THROUGH NAMED AND
C UNNAMED COMMON FROM FM302. AFTER THE DATA ENTITIES ARE MODIFIED
C CONTROL IS RETURNED TO FM302 WHERE EACH ENTITY IS TESTED.
C
IMPLICIT LOGICAL (L)
DIMENSION RACN11(10)
COMMON IVCN01
COMMON //IVCN02, LVCN01
COMMON RVCN01//IVCN03
COMMON IVCN04,IVCN05, //IACN11(4)
COMMON /BLK1/IVCNA1
COMMON /BLK2/IVCNB1,RVCNB1,/BLK2/IVCNB2
COMMON /BLK3/LVCNC1,IVCNC1/BLK4/RACN11,IACN21(2,3)
COMMON /BLK7/IACN1G(5),IVCNG1
COMMON /BLK8/IVCNH1
COMMON /BLKCHR/CVTN01,CVTN02,CATN11
CHARACTER CVTN01*2, CVTN02*3, CATN11(3)*5
C TEST 001
IVCN01 = IVCN01 + 1
C TEST 002
IVCN02 = IVCN02 + 5
LVCN01 = .NOT. LVCN01
C TEST 005
IVCNA1 = IVCNA1 / 5
C TEST 006
IVCNB1 = IVCNB1 + IVCNB2
RVCNB1 = 3.5
C TEST 007
LVCNC1 = .FALSE.
IVCNC1 = IVCNC1 - 1
RACN11(1) = 111.
RACN11(10) = 110.
IACN21(1,1) = IACN21(1,1) + 1
IACN21(2,3) = IACN21(2,3) + 1
C TEST 010
IACN1G(1) = IACN1G(1) + 1
IACN1G(2) = 43
IACN1G(3) = IACN1G(3) + 1
IACN1G(4) = IACN1G(4) + 1
IACN1G(5) = IACN1G(5) + 1
IVCNG1 = 144
C TEST 011
IVCNH1 = IVCNH1 + 1
C TEST 017
CVTN01 = 'YZ'
CVTN02 = 'UVW'
CATN11(1) = 'VWXYZ'
CATN11(3) = 'ABCDE'
RETURN
END
INTEGER FUNCTION FF304 ()
C
C FF304 IS AN EXTERNAL FUNCTION WHICH IS REFERENCED ONCE FROM
C PROGRAM FM302. IT IS USED TO MODIFY VARIABLES AND ARRAYS PASSED
C THROUGH NAMED AND UNNAMED COMMON FROM FM302. AFTER THE DATA
C ENTITIES ARE MODIFIED CONTROL IS RETURNED TO FM302 WHERE EACH
C ENTITY IS TESTED. A FUNCTION VALUE OF 999 IS RETURNED BUT IT IS
C NOT SIGNIFICANT NOR IS IT TESTED BY FM302.
C
IMPLICIT LOGICAL (L)
DIMENSION IACN11(4)
COMMON IVCN01
COMMON IVCN02, LVCN01
COMMON RVCN01, IVCN03
COMMON IVCN04,IVCN05,IACN11
COMMON /BLK5/IVCND1,IVCND2
COMMON IVCN06
COMMON /BLK5/RVCND1,LVCND1
COMMON IVCN07, IVCN08
COMMON /BLK6/RVCNE1
COMMON IVCN10
COMMON /BLK9/IVCNI1, IVCNI2, IVCNI3
COMMON IVCN12, IVCN13
COMMON /BLK10/IVCNJ1
COMMON /BLK11/IVCNK1
INTEGER FF305
C TEST 003
RVCN01 = 4.2
IVCN03 = IVCN03 + 1
C TEST 004
IVCN04 = 32
IVCN04 = IVCN04 / 4
IVCN05 = IVCN05
IACN11(1) = IACN11(1) + 4
IACN11(2) = IACN11(2) + 3
IACN11(3) = IACN11(3) + 2
IACN11(4) = IACN11(4) + 1
C TEST 008
IVCND1 = IVCND1 + 1
IVCND2 = IVCND2 + 1
C TEST 009
IVCN06 = IVCN06 + 1
RVCND1 = 4.5
LVCND1 = .TRUE.
IVCN07 = -IVCN07
IVCN08 = -3
RVCNE1 = -6.7
C TEST 012
IVCN10 = IVCN10 * IVCN10
C TEST 013
IVCNI1 = IVCNI1 + 1
IVCNI2 = IVCNI2 + 1
IVCNI3 = IVCNI3 + 1
C TEST 014
IVCN13 = 5
C TEST 015
IVCNK1 = 3
C
C FOR TESTS 014 AND 015 EXTERNAL FUNCTION FF305 IS REFERENCED
C
IVON99 = FF305 ()
C TEST 014
IVCN12 = IVCN13
C TEST 015
IVCNJ1 = IVCNK1
FF304 = 999
RETURN
END
INTEGER FUNCTION FF305 ()
C
C FF305 IS AN EXTERNAL FUNCTION WHICH IS USED IN TEST 014 AND
C 015 OF PROGRAM FM302. THIS SUBPROGRAM IS REFERENCED FROM EXTERNAL
C FUNCTION FF304.
C
COMMON IACN11(15)
COMMON IVCN12, IVCN13, IVCN14
COMMON /BLK10/IVCNJ1, /BLK11/IVCNK1
C TEST 014
IVCN14 = 11
IVCN13 = IVCN14
C TEST 015
IVCNK1 = 5
FF305 = 999
RETURN
END