C COMMENT SECTION C C FM097 C C THIS ROUTINE TESTS INTRINSIC FUNCTIONS WHERE THE FUNCTION TYPE IS C REAL AND THE ARGUMENTS ARE EITHER INTEGER OR REAL. THE REAL AND C INTEGER VARIABLES AND THE REAL AND INTEGER CONSTANTS CONTAIN BOTH C POSITIVE AND NEGATIVE VALUES. THE INTRINSIC FUNCTIONS TESTED BY C FM097 INCLUDE C TYPE OF C INTRINSIC FUNCTION NAME ARGUMENT FUNCTION C ------------------ ---- -------- -------- C ABSOLUTE VALUE ABS REAL REAL C TRUNCATION AINT REAL REAL C REMAINDERING AMOD REAL REAL C CHOOSING LARGEST VALUE AMAX0 INTEGER REAL C AMAX1 REAL REAL C CHOOSING SMALLEST VALUE AMIN0 INTEGER REAL C AMIN1 REAL REAL C FLOAT FLOAT INTEGER REAL C TRANSFER OF SIGN SIGN REAL REAL C POSITIVE DIFFERENCE DIM REAL REAL C C REFERENCES C AMERICAN NATIONAL STANDARD PROGRAMMING LANGUAGE FORTRAN, C X3.9-1978 C C SECTION 4.1.2, TYPE RULES FOR DATA AND PROCEDURE IDENTIFIERS C SECTION 15.3, INTRINSIC FUNCTION C SECTION 15.3.2, INTRINSIC FUNCTIONS AND THEIR REFERENCE C C C ********************************************************** C C A COMPILER VALIDATION SYSTEM FOR THE FORTRAN LANGUAGE C BASED ON SPECIFICATIONS AS DEFINED IN AMERICAN NATIONAL STANDARD C PROGRAMMING LANGUAGE FORTRAN X3.9-1978, HAS BEEN DEVELOPED BY THE C FEDERAL COBOL COMPILER TESTING SERVICE. THE FORTRAN COMPILER C VALIDATION SYSTEM (FCVS) CONSISTS OF AUDIT ROUTINES, THEIR RELATED C DATA, AND AN EXECUTIVE SYSTEM. EACH AUDIT ROUTINE IS A FORTRAN C PROGRAM, SUBPROGRAM OR FUNCTION WHICH INCLUDES TESTS OF SPECIFIC C LANGUAGE ELEMENTS AND SUPPORTING PROCEDURES INDICATING THE RESULT C OF EXECUTING THESE TESTS. C C THIS PARTICULAR PROGRAM/SUBPROGRAM/FUNCTION CONTAINS FEATURES C FOUND ONLY IN THE SUBSET AS DEFINED IN X3.9-1978. C C SUGGESTIONS AND COMMENTS SHOULD BE FORWARDED TO - C C DEPARTMENT OF THE NAVY C FEDERAL COBOL COMPILER TESTING SERVICE C WASHINGTON, D.C. 20376 C C ********************************************************** C C C C INITIALIZATION SECTION C C INITIALIZE CONSTANTS C ************** C I01 CONTAINS THE LOGICAL UNIT NUMBER FOR THE CARD READER. I01 = 5 C I02 CONTAINS THE LOGICAL UNIT NUMBER FOR THE PRINTER. I02 = 6 C SYSTEM ENVIRONMENT SECTION C CX010 THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-010 CONTROL CARD. C THE CX010 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I01 = 5 C (UNIT NUMBER FOR CARD READER). CX011 THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-011 CONTROL CARD. C THE CX011 CARD IS FOR SYSTEMS WHICH REQUIRE ADDITIONAL C FORTRAN STATEMENTS FOR FILES ASSOCIATED WITH CX010 ABOVE. C CX020 THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-020 CONTROL CARD. C THE CX020 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I02 = 6 C (UNIT NUMBER FOR PRINTER). CX021 THIS CARD IS REPLACED BY CONTENTS OF FEXEC X-021 CONTROL CARD. C THE CX021 CARD IS FOR SYSTEMS WHICH REQUIRE ADDITIONAL C FORTRAN STATEMENTS FOR FILES ASSOCIATED WITH CX020 ABOVE. C IVPASS=0 IVFAIL=0 IVDELE=0 ICZERO=0 C C WRITE PAGE HEADERS WRITE (I02,90000) WRITE (I02,90001) WRITE (I02,90002) WRITE (I02, 90002) WRITE (I02,90003) WRITE (I02,90002) WRITE (I02,90004) WRITE (I02,90002) WRITE (I02,90011) WRITE (I02,90002) WRITE (I02,90002) WRITE (I02,90005) WRITE (I02,90006) WRITE (I02,90002) C C TEST SECTION C C TEST 875 THROUGH TEST 878 CONTAIN INTRINSIC FUNCTION TESTS FOR C ABSOLUTE VALUE WHERE ARGUMENT AND FUNCTION ARE REAL C IVTNUM = 875 C C **** TEST 875 **** C IF (ICZERO) 38750, 8750, 38750 8750 CONTINUE RVCOMP = ABS (-38.2) GO TO 48750 38750 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48750, 8761, 48750 48750 IF (RVCOMP - 38.195) 28750,18750,48751 48751 IF (RVCOMP - 38.205) 18750,18750,28750 18750 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8761 28750 IVFAIL = IVFAIL + 1 RVCORR = 38.200 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8761 CONTINUE IVTNUM = 876 C C **** TEST 876 **** C IF (ICZERO) 38760, 8760, 38760 8760 CONTINUE RVON01 = 445.06 RVCOMP = ABS (RVON01) GO TO 48760 38760 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48760, 8771, 48760 48760 IF (RVCOMP - 445.01) 28760,18760,48761 48761 IF (RVCOMP - 445.11) 18760,18760,28760 18760 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8771 28760 IVFAIL = IVFAIL + 1 RVCORR = 445.06 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8771 CONTINUE IVTNUM = 877 C C **** TEST 877 **** C IF (ICZERO) 38770, 8770, 38770 8770 CONTINUE RVON01 = -32.176 RVCOMP = ABS (RVON01) GO TO 48770 38770 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48770, 8781, 48770 48770 IF (RVCOMP - 32.171) 28770,18770,48771 48771 IF (RVCOMP - 32.181) 18770,18770,28770 18770 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8781 28770 IVFAIL = IVFAIL + 1 RVCORR = 32.176 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8781 CONTINUE IVTNUM = 878 C C **** TEST 878 **** C IF (ICZERO) 38780, 8780, 38780 8780 CONTINUE RVON01 = -2.2E+2 RVCOMP = ABS (RVON01) GO TO 48780 38780 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48780, 8791, 48780 48780 IF (RVCOMP - 219.95) 28780,18780,48781 48781 IF (RVCOMP - 220.05) 18780,18780,28780 18780 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8791 28780 IVFAIL = IVFAIL + 1 RVCORR = 220.00 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8791 CONTINUE IVTNUM = 879 C C **** TEST 879 **** C C TEST 879 THROUGH TEST 882 CONTAIN INTRINSIC FUNCTION TESTS FOR C TRUNCATION WHERE ARGUMENT AND FUNCTION ARE REAL C C IF (ICZERO) 38790, 8790, 38790 8790 CONTINUE RVCOMP = AINT (38.2) GO TO 48790 38790 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48790, 8801, 48790 48790 IF (RVCOMP - 37.995) 28790,18790,48791 48791 IF (RVCOMP - 38.005) 18790,18790,28790 18790 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8801 28790 IVFAIL = IVFAIL + 1 RVCORR = 38.000 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8801 CONTINUE IVTNUM = 880 C C **** TEST 880 **** C IF (ICZERO) 38800, 8800, 38800 8800 CONTINUE RVON01 = -445.95 RVCOMP = AINT (RVON01) GO TO 48800 38800 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48800, 8811, 48800 48800 IF (RVCOMP + 445.05) 28800,18800,48801 48801 IF (RVCOMP + 444.95) 18800,18800,28800 18800 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8811 28800 IVFAIL = IVFAIL + 1 RVCORR = -445.00 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8811 CONTINUE IVTNUM = 881 C C **** TEST 881 **** C IF (ICZERO) 38810, 8810, 38810 8810 CONTINUE RVON01 = 466.01 RVCOMP = AINT (RVON01) GO TO 48810 38810 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48810, 8821, 48810 48810 IF (RVCOMP - 465.95) 28810,18810,48811 48811 IF (RVCOMP - 466.05) 18810,18810,28810 18810 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8821 28810 IVFAIL = IVFAIL + 1 RVCOMP = 466.00 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8821 CONTINUE IVTNUM = 882 C C **** TEST 882 **** C IF (ICZERO) 38820, 8820, 38820 8820 CONTINUE RVON01 = 382E-1 RVCOMP = AINT (RVON01) GO TO 48820 38820 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48820, 8831, 48820 48820 IF (RVCOMP - 37.995) 28820,18820,48821 48821 IF (RVCOMP - 38.005) 18820,18820,28820 18820 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8831 28820 IVFAIL = IVFAIL + 1 RVCORR = 38.000 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8831 CONTINUE C C TEST 883 THROUGH 886 CONTAIN INTRINSIC FUNCTION TESTS FOR C REMAINDERING WHERE ARGUMENT AND FUNCTION ARE REAL C IVTNUM = 883 C C **** TEST 883 **** C IF (ICZERO) 38830, 8830, 38830 8830 CONTINUE RVCOMP = AMOD (42.0,19.0) GO TO 48830 38830 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48830, 8841, 48830 48830 IF (RVCOMP - 3.9995) 28830,18830,48831 48831 IF (RVCOMP - 4.0005) 18830,18830,28830 18830 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8841 28830 IVFAIL = IVFAIL + 1 RVCORR = 4.0000 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8841 CONTINUE IVTNUM = 884 C C **** TEST 884 **** C IF (ICZERO) 38840, 8840, 38840 8840 CONTINUE RVON01 = 16.27 RVON02 = 2.0 RVCOMP = AMOD (RVON01,RVON02) GO TO 48840 38840 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48840, 8851, 48840 48840 IF (RVCOMP - .26995) 28840,18840,48841 48841 IF (RVCOMP - .27005) 18840,18840,28840 18840 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8851 28840 IVFAIL = IVFAIL + 1 RVCORR = .27000 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8851 CONTINUE IVTNUM = 885 C C **** TEST 885 **** C IF (ICZERO) 38850, 8850, 38850 8850 CONTINUE RVON01 = 225.0 RVON02 = 5.0E1 RVCOMP = AMOD (RVON01,RVON02) GO TO 48850 38850 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48850, 8861, 48850 48850 IF (RVCOMP - 24.995) 28850,18850,48851 48851 IF (RVCOMP - 25.005) 18850,18850,28850 18850 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8861 28850 IVFAIL = IVFAIL + 1 RVCORR = 25.000 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8861 CONTINUE IVTNUM = 886 C C **** TEST 886 **** C IF (ICZERO) 38860, 8860, 38860 8860 CONTINUE RVON01 = -0.390E+2 RVON02 = 5E2 RVCOMP = AMOD (RVON01,RVON02) GO TO 48860 38860 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48860, 8871, 48860 48860 IF (RVCOMP + 39.005) 28860,18860,48861 48861 IF (RVCOMP + 38.995) 18860,18860,28860 18860 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8871 28860 IVFAIL = IVFAIL + 1 RVCORR = -39.000 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8871 CONTINUE C C TEST 887 AND 888 CONTAIN INTRINSIC FUNCTION TESTS FOR CHOOSING C LARGEST VALUE WHERE ARGUMENTS ARE INTEGER AND FUNCTION IS REAL C IVTNUM = 887 C C **** TEST 887 **** C IF (ICZERO) 38870, 8870, 38870 8870 CONTINUE IVON01 = 317 IVON02 = -99 IVON03 = 1 RVCOMP = AMAX0 (263,IVON01,IVON02,IVON03) GO TO 48870 38870 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48870, 8881, 48870 48870 IF (RVCOMP - 316.95) 28870,18870,48871 48871 IF (RVCOMP - 317.05) 18870,18870,28870 18870 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8881 28870 IVFAIL = IVFAIL + 1 RVCORR = 317.00 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8881 CONTINUE IVTNUM = 888 C C **** TEST 888 **** C IF (ICZERO) 38880, 8880, 38880 8880 CONTINUE IVON01 = 2572 IVON02 = 2570 RVCOMP = AMAX0 (IVON01,IVON02) GO TO 48880 38880 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48880, 8891, 48880 48880 IF (RVCOMP - 2571.5) 28880,18880,48881 48881 IF (RVCOMP - 2572.5) 18880,18880,28880 18880 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8891 28880 IVFAIL = IVFAIL + 1 RVCORR = 2572.0 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8891 CONTINUE C C TEST 889 AND 890 CONTAIN INTRINSIC FUNCTION TESTS FOR CHOOSING C LARGEST VALUE WHERE THE ARGUMENTS AND FUNCTION ARE REAL C IVTNUM = 889 C C **** TEST 889 **** C IF (ICZERO) 38890, 8890, 38890 8890 CONTINUE RVON01 = .326E+2 RVON02 = 22.075 RVON03 = 76E-1 RVCOMP = AMAX1 (RVON01,RVON02,RVON03) GO TO 48890 38890 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48890, 8901, 48890 48890 IF (RVCOMP - 32.595) 28890,18890,48891 48891 IF (RVCOMP - 32.605) 18890,18890,28890 18890 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8901 28890 IVFAIL = IVFAIL + 1 RVCORR = 32.600 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8901 CONTINUE IVTNUM = 890 C C **** TEST 890 **** C IF (ICZERO) 38900, 8900, 38900 8900 CONTINUE RVON01 = -6.3E2 RVON02 = -21.0 RVCOMP = AMAX1 (-463.3,RVON01,RVON02) GO TO 48900 38900 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48900, 8911, 48900 48900 IF (RVCOMP + 21.005) 28900,18900,48901 48901 IF (RVCOMP + 20.995) 18900,18900,28900 18900 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8911 28900 IVFAIL = IVFAIL + 1 RVCORR = -21.000 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8911 CONTINUE C C TESTS 891 AND 892 CONTAIN INTRINSIC FUNCTION TESTS FOR CHOOSING C SMALLEST VALUE WHERE ARGUMENTS ARE INTEGER AND FUNCTION IS REAL C IVTNUM = 891 C C **** TEST 891 **** C IF (ICZERO) 38910, 8910, 38910 8910 CONTINUE IVON01 = -75 IVON02 = -243 RVCOMP = AMIN0 (IVON01,IVON02) GO TO 48910 38910 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48910, 8921, 48910 48910 IF (RVCOMP + 243.05) 28910,18910,48911 48911 IF (RVCOMP + 242.95) 18910,18910,28910 18910 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8921 28910 IVFAIL = IVFAIL + 1 RVCORR = -243.00 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8921 CONTINUE IVTNUM = 892 C C **** TEST 892 **** C IF (ICZERO) 38920, 8920, 38920 8920 CONTINUE IVON01 = -11 IVON02 = 11 RVCOMP = AMIN0 (0,IVON01,IVON02) GO TO 48920 38920 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48920, 8931, 48920 48920 IF (RVCOMP + 11.005) 28920,18920,48921 48921 IF (RVCOMP + 10.995) 18920,18920,28920 18920 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8931 28920 IVFAIL = IVFAIL + 1 RVCORR = -11.000 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8931 CONTINUE C C TESTS 893 AND 894 CONTAIN INTRINSIC FUNCTION TESTS FOR CHOOSING C SMALLEST VALUE WHERE ARGUMENTS AND FUNCTION ARE REAL C IVTNUM = 893 C C **** TEST 893 **** C IF (ICZERO) 38930, 8930, 38930 8930 CONTINUE RVON01 = 1.1111 RVON02 = 22.222 RVON03 = 333.33 RVCOMP = AMIN1 (RVON01,RVON02,RVON03) GO TO 48930 38930 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48930, 8941, 48930 48930 IF (RVCOMP - 1.1106) 28930,18930,48931 48931 IF (RVCOMP - 1.1116) 18930,18930,28930 18930 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8941 28930 IVFAIL = IVFAIL + 1 RVCORR = 1.1111 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8941 CONTINUE IVTNUM = 894 C C **** TEST 894 **** C IF (ICZERO) 38940, 8940, 38940 8940 CONTINUE RVON01 = 28.8 RVON02 = 2.88E1 RVON03 = 288E-1 RVON04 = 35.0 RVCOMP = AMIN1 (RVON01,RVON02,RVON03,RVON04) GO TO 48940 38940 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48940, 8951, 48940 48940 IF (RVCOMP - 28.795) 28940,18940,48941 48941 IF (RVCOMP - 28.805) 18940,18940,28940 18940 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8951 28940 IVFAIL = IVFAIL + 1 RVCORR = 28.800 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8951 CONTINUE C C TEST 895 THROUGH TEST 897 CONTAIN INTRINSIC FUNCTION TESTS FOR C FLOAT - CONVERSION OF AN INTEGER ARGUMENT TO REAL FUNCTION C IVTNUM = 895 C C **** TEST 895 **** C IF (ICZERO) 38950, 8950, 38950 8950 CONTINUE RVCOMP = FLOAT (-606) GO TO 48950 38950 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48950, 8961, 48950 48950 IF (RVCOMP + 606.05) 28950,18950,48951 48951 IF (RVCOMP + 605.95) 18950,18950,28950 18950 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8961 28950 IVFAIL = IVFAIL + 1 RVCORR = -606.00 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8961 CONTINUE IVTNUM = 896 C C **** TEST 896 **** C IF (ICZERO) 38960, 8960, 38960 8960 CONTINUE IVON01 = 71 RVCOMP = FLOAT (IVON01) GO TO 48960 38960 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48960, 8971, 48960 48960 IF (RVCOMP - 70.995) 28960,18960,48961 48961 IF (RVCOMP - 71.005) 18960,18960,28960 18960 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8971 28960 IVFAIL = IVFAIL + 1 RVCORR = 71.000 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8971 CONTINUE IVTNUM = 897 C C **** TEST 897 **** C IF (ICZERO) 38970, 8970, 38970 8970 CONTINUE IVON01 = 321 RVCOMP = FLOAT (-IVON01) GO TO 48970 38970 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48970, 8981, 48970 48970 IF (RVCOMP + 321.05) 28970,18970,48971 48971 IF (RVCOMP + 320.95) 18970,18970,28970 18970 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8981 28970 IVFAIL = IVFAIL + 1 RVCORR = -321.00 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8981 CONTINUE C C TEST 898 THROUGH TEST 900 CONTAIN INTRINSIC FUNCTION TESTS FOR C TRANSFER OF SIGN - BOTH ARGUMENTS AND FUNCTION ARE REAL C IVTNUM = 898 C C **** TEST 898 **** C IF (ICZERO) 38980, 8980, 38980 8980 CONTINUE RVON01 = 64.3 RVCOMP = SIGN (RVON01,-1.0) GO TO 48980 38980 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48980, 8991, 48980 48980 IF (RVCOMP + 64.305) 28980,18980,48981 48981 IF (RVCOMP + 64.295) 18980,18980,28980 18980 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 8991 28980 IVFAIL = IVFAIL + 1 RVCORR = -64.300 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 8991 CONTINUE IVTNUM = 899 C C **** TEST 899 **** C IF (ICZERO) 38990, 8990, 38990 8990 CONTINUE RVON01 = -2.2 RVON02 = 7.23E1 RVCOMP = SIGN (RVON01,RVON02) GO TO 48990 38990 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 48990, 9001, 48990 48990 IF (RVCOMP - 2.1995) 28990,18990,48991 48991 IF (RVCOMP - 2.2005) 18990,18990,28990 18990 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 9001 28990 IVFAIL = IVFAIL + 1 RVCORR = 2.2000 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 9001 CONTINUE IVTNUM = 900 C C **** TEST 900 **** C IF (ICZERO) 39000, 9000, 39000 9000 CONTINUE RVON01 = 35.32E+1 RVON02 = 1.0 RVCOMP = SIGN (RVON01,RVON02) GO TO 49000 39000 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 49000, 9011, 49000 49000 IF (RVCOMP - 353.15) 29000,19000,49001 49001 IF (RVCOMP - 353.25) 19000,19000,29000 19000 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 9011 29000 IVFAIL = IVFAIL + 1 RVCORR = 353.20 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 9011 CONTINUE C C TEST 901 THROUGH TEST 904 CONTAIN INTRINSIC FUNCTION TESTS FOR C POSITIVE DIFFERENCE WHERE ARGUMENTS AND FUNCTION ARE REAL C IVTNUM = 901 C C **** TEST 901 **** C IF (ICZERO) 39010, 9010, 39010 9010 CONTINUE RVON01 = 22.2 RVCOMP = DIM (RVON01,1.0) GO TO 49010 39010 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 49010, 9021, 49010 49010 IF (RVCOMP - 21.195) 29010,19010,49011 49011 IF (RVCOMP - 21.205) 19010,19010,29010 19010 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 9021 29010 IVFAIL = IVFAIL + 1 RVCORR = 21.200 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 9021 CONTINUE IVTNUM = 902 C C **** TEST 902 **** C IF (ICZERO) 39020, 9020, 39020 9020 CONTINUE RVON01 = 4.5E1 RVON02 = 41.0 RVCOMP = DIM (RVON01,RVON02) GO TO 49020 39020 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 49020, 9031, 49020 49020 IF (RVCOMP - 3.9995) 29020,19020,49021 49021 IF (RVCOMP - 4.0005) 19020,19020,29020 19020 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 9031 29020 IVFAIL = IVFAIL + 1 RVCORR = 4.0000 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 9031 CONTINUE IVTNUM = 903 C C **** TEST 903 **** C IF (ICZERO) 39030, 9030, 39030 9030 CONTINUE RVON01 = 2.0 RVON02 = 10.0 RVCOMP = DIM (RVON01,RVON02) GO TO 49030 39030 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 49030, 9041, 49030 49030 IF (RVCOMP) 29030,19030,29030 19030 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 9041 29030 IVFAIL = IVFAIL + 1 RVCORR = 0.0000 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 9041 CONTINUE IVTNUM = 904 C C **** TEST 904 **** C IF (ICZERO) 39040, 9040, 39040 9040 CONTINUE RVON01 = 1.65E+1 RVON02 = -2.0 RVCOMP = DIM (RVON01,RVON02) GO TO 49040 39040 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 49040, 9051, 49040 49040 IF (RVCOMP - 18.495) 29040,19040,49041 49041 IF (RVCOMP - 18.505) 19040,19040,29040 19040 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 9051 29040 IVFAIL = IVFAIL + 1 RVCORR = 18.500 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 9051 CONTINUE C C TESTS 905 AND 906 CONTAIN EXPRESSIONS CONTAINING MORE THAN ONE C INTRINSIC FUNCTION - ALL ARGUMENTS AND FUNCTIONS ARE REAL C IVTNUM = 905 C C **** TEST 905 **** C IF (ICZERO) 39050, 9050, 39050 9050 CONTINUE RVON01 = 33.3 RVON02 = -12.1 RVCOMP = AINT (RVON01) + ABS (RVON02) GO TO 49050 39050 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 49050, 9061, 49050 49050 IF (RVCOMP - 45.095) 29050,19050,49051 49051 IF (RVCOMP - 45.105) 19050,19050,29050 19050 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 9061 29050 IVFAIL = IVFAIL + 1 RVCORR = 45.100 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 9061 CONTINUE IVTNUM = 906 C C **** TEST 906 **** C IF (ICZERO) 39060, 9060, 39060 9060 CONTINUE RVON01 = 76.3 RVON02 = 2.1E1 RVON03 = 3E1 RVCOMP = AMAX1(RVON01,RVON02,RVON03)-AMIN1(RVON01,RVON02,RVON03) GO TO 49060 39060 IVDELE = IVDELE + 1 WRITE (I02,80003) IVTNUM IF (ICZERO) 49060, 9071, 49060 49060 IF (RVCOMP - 55.295) 29060,19060,49061 49061 IF (RVCOMP - 55.305) 19060,19060,29060 19060 IVPASS = IVPASS + 1 WRITE (I02,80001) IVTNUM GO TO 9071 29060 IVFAIL = IVFAIL + 1 RVCORR = 55.300 WRITE (I02,80005) IVTNUM, RVCOMP, RVCORR 9071 CONTINUE C C WRITE PAGE FOOTINGS AND RUN SUMMARIES 99999 CONTINUE WRITE (I02,90002) WRITE (I02,90006) WRITE (I02,90002) WRITE (I02,90002) WRITE (I02,90007) WRITE (I02,90002) WRITE (I02,90008) IVFAIL WRITE (I02,90009) IVPASS WRITE (I02,90010) IVDELE C C C TERMINATE ROUTINE EXECUTION STOP C C FORMAT STATEMENTS FOR PAGE HEADERS 90000 FORMAT (1H1) 90002 FORMAT (1H ) 90001 FORMAT (1H ,10X,34HFORTRAN COMPILER VALIDATION SYSTEM) 90003 FORMAT (1H ,21X,11HVERSION 1.0) 90004 FORMAT (1H ,10X,38HFOR OFFICIAL USE ONLY - COPYRIGHT 1978) 90005 FORMAT (1H ,5X,4HTEST,5X,9HPASS/FAIL, 5X,8HCOMPUTED,8X,7HCORRECT) 90006 FORMAT (1H ,5X,46H----------------------------------------------) 90011 FORMAT (1H ,18X,17HSUBSET LEVEL TEST) C C FORMAT STATEMENTS FOR RUN SUMMARIES 90008 FORMAT (1H ,15X,I5,19H ERRORS ENCOUNTERED) 90009 FORMAT (1H ,15X,I5,13H TESTS PASSED) 90010 FORMAT (1H ,15X,I5,14H TESTS DELETED) C C FORMAT STATEMENTS FOR TEST RESULTS 80001 FORMAT (1H ,4X,I5,7X,4HPASS) 80002 FORMAT (1H ,4X,I5,7X,4HFAIL) 80003 FORMAT (1H ,4X,I5,7X,7HDELETED) 80004 FORMAT (1H ,4X,I5,7X,4HFAIL,10X,I6,9X,I6) 80005 FORMAT (1H ,4X,I5,7X,4HFAIL,4X,E12.5,3X,E12.5) C 90007 FORMAT (1H ,20X,20HEND OF PROGRAM FM097) END