*DECK TESTI PROGRAM TESTI C***BEGIN PROLOGUE TESTI C***PURPOSE Driver for testing SLATEC subprogram C Fullerton intrinsics. C***LIBRARY FNLIB C***CATEGORY Z C***TYPE ALL (TESTI-A) C***KEYWORDS FULLERTON INTRINSIC FUNCTIONS, QUICK CHECK DRIVER C***AUTHOR SLATEC Common Mathematical Library Committee C***DESCRIPTION C C *Usage: C One input data record is required C READ (UNIT=LIN, FMT='(I1)') KPRINT C C *Arguments: C KPRINT = 0 Quick checks - No printing. C Driver - Short pass or fail message printed. C 1 Quick checks - No message printed for passed tests, C short message printed for failed tests. C Driver - Short pass or fail message printed. C 2 Quick checks - Print short message for passed tests, C fuller information for failed tests. C Driver - Pass or fail message printed. C 3 Quick checks - Print complete quick check results. C Driver - Pass or fail message printed. C C *Description: C Driver for testing SLATEC subprogram C C***REFERENCES Fong, Kirby W., Jefferson, Thomas H., Suyehiro, C Tokihiko, Walton, Lee, Guidelines to the SLATEC Common C Mathematical Library, March 21, 1989. C***ROUTINES CALLED I1MACH, QCINTC, QCINTD, QCINTS, XERMAX, XSETF, C XSETUN C***REVISION HISTORY (YYMMDD) C 900709 DATE WRITTEN C***END PROLOGUE TESTI C .. Local Scalars .. INTEGER IPASS, KPRINT, LIN, LUN, NFAIL C .. External Functions .. INTEGER I1MACH EXTERNAL I1MACH C .. External Subroutines .. EXTERNAL QCINTC, QCINTD, QCINTS, XERMAX, XSETF, XSETUN C***FIRST EXECUTABLE STATEMENT TESTI LUN = I1MACH(2) LIN = I1MACH(1) NFAIL = 0 C C Read KPRINT parameter C READ (UNIT=LIN, FMT='(I1)') KPRINT CALL XSETUN (LUN) CALL XERMAX (1000) IF (KPRINT .LE. 1) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF C C Test single precision Fullerton intrinsics. C CALL QCINTS (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test double precision Fullerton intrinsics. C CALL QCINTD (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Test complex Fullerton intrinsics. C CALL QCINTC (LUN, KPRINT, IPASS) IF (IPASS .EQ. 0) NFAIL = NFAIL + 1 C C Write PASS or FAIL message C IF (NFAIL .EQ. 0) THEN WRITE (UNIT=LUN, FMT=9000) ELSE WRITE (UNIT=LUN, FMT=9010) NFAIL ENDIF STOP 9000 FORMAT (/' --------------TESTI PASSED ALL TESTS----------------') 9010 FORMAT (/' ************* WARNING -- ', I5, 1 ' TEST(S) FAILED IN PROGRAM TESTI *************') END *DECK QCINTC SUBROUTINE QCINTC (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QCINTC C***PURPOSE Quick check for the complex Fullerton elementary C intrinsic functions. C***LIBRARY FNLIB C***CATEGORY C C***TYPE COMPLEX (QCINTS-S, QCINTD-D, QCINTC-C) C***KEYWORDS QUICK CHECK C***AUTHOR Boland, W. Robert, (LANL) C Rivera, Shawn M., (LANL) C***DESCRIPTION C C This subroutine does a quick check for the complex C Fullerton elementary intrinsic functions. C C Parameter list- C C LUN input INTEGER value to designate the external device unit C for message output C KPRINT input INTEGER value to specify amount of printing to be C done by quick check C IPASS output INTEGER value indicating whether tests passed or C failed C C***ROUTINES CALLED CABS, CCOS, CEXP, CLOG, CSIN, CSQRT, R1MACH, SQRT C***REVISION HISTORY (YYMMDD) C 900717 DATE WRITTEN C***END PROLOGUE QCINTC C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. REAL ERRTOL INTEGER I C .. Local Arrays .. COMPLEX C(20), W(20) C .. External Functions .. COMPLEX CCOS, CEXP, CLOG, CSIN, CSQRT REAL CABS, R1MACH, SQRT EXTERNAL CCOS, CEXP, CLOG, CSIN, CSQRT, CABS, R1MACH, SQRT C .. Intrinsic Functions .. INTRINSIC CMPLX C C Complex values through different calculations are stored in C(*) C C .. Data statements .. DATA C( 1) /( 1.0000000000000, 0.0000000000000) / DATA C( 2) /( 89.00280929194, .0078649202825041) / DATA C( 3) /( 30.00001041666, .024999991319455) / DATA C( 4) /( 6324555.320337, .0000001897366596101) / DATA C( 5) /( -0.8414709848079, 0.0000000000000) / DATA C( 6) /( 27.23982534694, 1.930412376268) / DATA C( 7) /( 0.000000000000000, 1.175201193644) / DATA C( 8) /( 1.127805246806, 1.868618519183) / DATA C( 9) /( 0.5403023058681, 0.0000000000000) / DATA C(10) /( 23.96522893293, 13.0834832507) / DATA C(11) /( 1.543080634815, 0.00000000000000) / DATA C(12) /( 2.064433656761, -1.020830949598) / DATA C(13) /( -2.929427471521, -3.391753471626) / DATA C(14) /( -0.7373937155412, 0.6754631805511) / DATA C(15) /( .1699671429002, .9854497299884) / DATA C(16) /( 0.7055457557766, 9.949196994152) / DATA C(17) /( 3.738352258649, 0.3119690755436) / DATA C(18) /( 4.605747852161, .033986907746255) / DATA C(19) /( 2.313710397461, 0.1488899476095) / DATA C(20) /( 6.907755278982, 0.00000000000000) / C C***FIRST EXECUTABLE STATEMENT QCINTC C IF (KPRINT .GE. 2) WRITE (UNIT=LUN, FMT=9000) C C Exercise routines in Category C2. C W( 1) = CSQRT(CMPLX(1.0, 0.0)) W( 2) = CSQRT(CMPLX(7921.5, 1.4)) W( 3) = CSQRT(CMPLX(900.0, 1.5)) W( 4) = CSQRT(CMPLX(0.4E+14, 2.4)) C C Exercise routines in Category C4A. C W( 5) = CSIN(CMPLX(-1.0, 0.0)) W( 6) = CSIN(CMPLX(1.5, 4.0)) W( 7) = CSIN(CMPLX(0.0, 1.0)) W( 8) = CSIN(CMPLX(0.5, 1.5)) W( 9) = CCOS(CMPLX(-1.0, 0.0)) W(10) = CCOS(CMPLX(-0.5, 4.0)) W(11) = CCOS(CMPLX(0.0, 1.0)) W(12) = CCOS(CMPLX(0.5, 1.5)) C C Exercise routines in Category C4B. C W(13) = CEXP(CMPLX(1.5, 4.0)) W(14) = CEXP(CMPLX(0.0, 2.4)) W(15) = CEXP(CMPLX(0.0, 1.4)) W(16) = CEXP(CMPLX(2.3, 1.5)) W(17) = CLOG(CMPLX(40.0, 12.9)) W(18) = CLOG(CMPLX(100.0, 3.4)) W(19) = CLOG(CMPLX(10.0, 1.5)) W(20) = CLOG(CMPLX(1000.0, 0.0)) C C Check for possible errors. C IPASS = 1 ERRTOL = SQRT(R1MACH(4)) DO 10 I = 1,20 IF (CABS(C(I)-W(I)) .GE. ERRTOL*CABS(C(I))+ERRTOL) THEN IPASS = 0 IF (KPRINT .GE. 2) WRITE (UNIT=LUN, FMT=9020) I, W(I), C(I) ENDIF 10 CONTINUE IF (IPASS.NE.0 .AND. KPRINT.GE.2) WRITE (UNIT=LUN, FMT=9010) RETURN 9000 FORMAT (// ' Test of complex Fullerton intrinsic routines') 9010 FORMAT (' Complex Fullerton intrinsic function routines o.k.') 9020 FORMAT (' For I = ', I3, ' test fails with ', / + ' computed result = (', 1P, E22.14, ', ', E22.14,' ) '/ + ' and true result = (', E22.14, ', ', E22.14, ' )') END *DECK QCINTD SUBROUTINE QCINTD (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QCINTD C***PURPOSE Quick check for the double precision Fullerton C elementary intrinsic functions. C***LIBRARY FNLIB C***CATEGORY C C***TYPE DOUBLE PRECISION (QCINTS-S, QCINTD-D, QCINTC-C) C***KEYWORDS QUICK CHECK C***AUTHOR Boland, W. Robert, (LANL) C Rivera, Shawn M., (LANL) C***DESCRIPTION C C This subroutine does a quick check for the double precision C Fullerton intrinsic functions. C C Parameter list- C C LUN input INTEGER value to designate the external device unit C for message output C KPRINT input INTEGER value to specify amount of printing to be C done by quick check C IPASS output INTEGER value indicating whether tests passed or C failed C C***REFERENCES (NONE) C***ROUTINES CALLED D1MACH, DACOS, DASIN, DATAN, DATAN2, DCOS, DCOSH, C DEXP, DINT, DLOG, DLOG10, DSIN, DSINH, DSQRT, DTAN, C DTANH C***REVISION HISTORY (YYMMDD) C 900717 DATE WRITTEN C***END PROLOGUE QCINTD C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. DOUBLE PRECISION ERRTOL INTEGER I C .. Local Arrays .. DOUBLE PRECISION V(60), Y(60) C .. External Functions .. DOUBLE PRECISION D1MACH, DACOS, DASIN, DATAN, DATAN2, DCOS, DCOSH, + DEXP, DINT, DLOG, DLOG10, DSIN, DSINH, DSQRT, + DTAN, DTANH EXTERNAL D1MACH, DACOS, DASIN, DATAN, DATAN2, DCOS, DCOSH, DEXP, + DINT, DLOG, DLOG10, DSIN, DSINH, DSQRT, DTAN, + DTANH C .. Intrinsic Functions .. INTRINSIC ABS C C Correct values through different calculations are stored in V(*) C C .. Data statements .. DATA V( 1) / 10.0D0 / DATA V( 2) / 79.0D0 / DATA V( 3) / 900.0D0 / DATA V( 4) / 4.0D0 / DATA V( 5) / 1.0D0 / DATA V( 6) / 89.0D0 / DATA V( 7) / 30.0D0 / DATA V( 8) / 6.32455532033675866399778708D06 / DATA V( 9) / 3.1415926535897932846264338D0 / DATA V(10) / 2.09439510239319549230842892D0 / DATA V(11) / 1.57079632679489661923132169D0 / DATA V(12) / 1.04719755119659774615421446D0 / DATA V(13) / -1.57079632679489661923132169D0 / DATA V(14) / -0.52359877559829887307710723D0 / DATA V(15) / 0.0D0 / DATA V(16) / 0.52359877559829887307710723D0 / DATA V(17) / -0.785398163397448309615660845D0 / DATA V(18) / -0.463647609000806116214256231D0 / DATA V(19) / 0.0D0 / DATA V(20) / 0.463647609000806116214256231D0 / DATA V(21) / -0.58800260354756755124561108D0 / DATA V(22) / -0.463647609000806116214256231D0 / DATA V(23) / 2.034443935795702707025611744029D0 / DATA V(24) / 2.158798930342464394982471276307D0 / DATA V(25) / 0.540302305868139717400936607D0 / DATA V(26) / 0.877582561890372716116281582D0 / DATA V(27) / 1.0D0 / DATA V(28) / 0. 877582561890372716116281582D0 / DATA V(29) / -0.841470984807896506652502321D0 / DATA V(30) / -0.479425538604203000273287935D0 / DATA V(31) / 0.0D0 / DATA V(32) / 0.479425538604203000273287935D0 / DATA V(33) / -1.55740772465490223050697485D0 / DATA V(34) / -0.546302489843790513255179465D0 / DATA V(35) / 0.0D0 / DATA V(36) / 0.546302489843790513255179465D0 / DATA V(37) / 2.30258509299404568401799145D0 / DATA V(38) / 2.99573227355399099343522357D0 / DATA V(39) / 3.40119738166215537541323669D0 / DATA V(40) / 3.68887945411393630285245569D0 / DATA V(41) / 1.0D0 / DATA V(42) / 1.30102999566398119521373889D0 / DATA V(43) / 1.4771212547196624372950279D0 / DATA V(44) / 1.60205999132796239042747778D0 / DATA V(45) / 1.00000100530050531421637777D0 / DATA V(46) / 0.999843012323855043126609044D0 / DATA V(47) / 1.00003876575137232151808428D0 / DATA V(48) / 0.992002154326025434343372944D0 / DATA V(49) / 1.54308063481524377847790562D0 / DATA V(50) / 1.12762596520638078522622516D0 / DATA V(51) / 1.0D0 / DATA V(52) / 1.12762596520638078522622516D0 / DATA V(53) / -1.175201193643801456882381851D0 / DATA V(54) / -0.521095305493747361622425626D0 / DATA V(55) / 0.0D0 / DATA V(56) / 0.521095305493747361622425626D0 / DATA V(57) / -0.761594155955764888119458282D0 / DATA V(58) / -0.462117157260009758502318483D0 / DATA V(59) / 0.0D0 / DATA V(60) / 0.462117157260009758592318483D0 / C C***FIRST EXECUTABLE STATEMENT QCINTD C IF (KPRINT .GE. 2) WRITE (UNIT=LUN, FMT=9000) C C Exercise routines in Category C1. C Y( 1) = DINT(10.465890D0) Y( 2) = DINT(79.32178D0) Y( 3) = DINT(900.0D0) Y( 4) = DINT(4.0D0) C C Exercise routines in Category C2. C Y( 5) = DSQRT(1.0D0) Y( 6) = DSQRT(7921.0D0) Y( 7) = DSQRT(900.0D0) Y( 8) = DSQRT(4000D+10) C C Exercise routines in Category C4A. C Y( 9) = DACOS(-1.0D0) Y(10) = DACOS(-0.5D0) Y(11) = DACOS(0.0D0) Y(12) = DACOS(0.5D0) Y(13) = DASIN(-1.0D0) Y(14) = DASIN(-0.5D0) Y(15) = DASIN(0.0D0) Y(16) = DASIN(0.5D0) Y(17) = DATAN(-1.0D0) Y(18) = DATAN(-0.5D0) Y(19) = DATAN(0.0D0) Y(20) = DATAN(0.5D0) Y(21) = DATAN2(-1.0D0,1.5D0) Y(22) = DATAN2(-0.5D0,1.0D0) Y(23) = DATAN2(1.0D0,-0.5D0) Y(24) = DATAN2(1.5D0,-1.0D0) Y(25) = DCOS(-1.0D0) Y(26) = DCOS(-0.5D0) Y(27) = DCOS(0.0D0) Y(28) = DCOS(0.5D0) Y(29) = DSIN(-1.0D0) Y(30) = DSIN(-0.5D0) Y(31) = DSIN(0.0D0) Y(32) = DSIN(0.5D0) Y(33) = DTAN(-1.0D0) Y(34) = DTAN(-0.5D0) Y(35) = DTAN(0.0D0) Y(36) = DTAN(0.5D0) C C Exercise routines in Category C4B. C Y(37) = DLOG(10.0D0) Y(38) = DLOG(20.0D0) Y(39) = DLOG(30.0D0) Y(40) = DLOG(40.0D0) Y(41) = DLOG10(10.0D0) Y(42) = DLOG10(20.0D0) Y(43) = DLOG10(30.0D0) Y(44) = DLOG10(40.0D0) Y(45) = DEXP(1.0053D-06) Y(46) = DEXP(-1.57D-04) Y(47) = DEXP(3.8765D-05) Y(48) = DEXP(-8.03D-03) C C Exercise routines in Category C4C. C Y(49) = DCOSH(-1.0D0) Y(50) = DCOSH(-0.5D0) Y(51) = DCOSH(0.0D0) Y(52) = DCOSH(0.5D0) Y(53) = DSINH(-1.0D0) Y(54) = DSINH(-0.5D0) Y(55) = DSINH(0.0D0) Y(56) = DSINH(0.5D0) Y(57) = DTANH(-1.0D0) Y(58) = DTANH(-0.5D0) Y(59) = DTANH(0.0D0) Y(60) = DTANH(0.5D0) C C Check for possible errors. C IPASS = 1 ERRTOL = DSQRT(D1MACH(4)) DO 10 I = 1,60 IF (ABS(V(I)-Y(I)) .GE. ERRTOL*ABS(V(I))+ERRTOL) THEN IPASS = 0 IF (KPRINT .GE. 2) WRITE (UNIT=LUN, FMT=9020) I, Y(I), V(I) ENDIF 10 CONTINUE IF (IPASS.NE.0 .AND. KPRINT.GE.2) WRITE (UNIT=LUN, FMT=9010) RETURN 9000 FORMAT (// ' Test of double precision Fullerton intrinsic ', + 'routines') 9010 FORMAT (' Double precision Fullerton intrinsic function ', + 'routines o.k.') 9020 FORMAT (' For I = ', I3, ' test fails with ', / + ' computed result = ', 1P, E38.30, / + ' and true result = ', E38.30) END *DECK QCINTS SUBROUTINE QCINTS (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QCINTS C***PURPOSE Quick check for the single precision Fullerton C elementary intrinsic functions. C***LIBRARY FNLIB C***CATEGORY C C***TYPE SINGLE PRECISION (QCINTS-S, QCINTD-D, QCTINC-C) C***KEYWORDS QUICK CHECK C***AUTHOR Boland, W. Robert, (LANL) C Rivera, Shawn M., (LANL) C***DESCRIPTION C C This subroutine does a quick check for the single precision C Fullerton intrinsic functions. C C Parameter list- C C LUN input INTEGER value to designate the external device unit C for message output C KPRINT input INTEGER value to specify amount of printing to be C done by quick check C IPASS output INTEGER value indicating whether tests passed or C failed C C***REFERENCES (NONE) C***ROUTINES CALLED ACOS, ALOG, ALOG10, ASIN, ATAN, ATAN2, CABS, COS, C COSH, EXP, R1MACH, SIN, SINH, SQRT, TAN, TANH C***REVISION HISTORY (YYMMDD) C 900711 DATE WRITTEN C***END PROLOGUE QCINTS C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Local Scalars .. REAL ERRTOL INTEGER I C .. Local Arrays .. REAL V(60), Y(60) C .. External Functions .. REAL ACOS, ALOG, ALOG10, ASIN, ATAN, ATAN2, CABS, COS, COSH, EXP, + R1MACH, SIN, SINH, SQRT, TAN, TANH EXTERNAL ACOS, ALOG, ALOG10, ASIN, ATAN, ATAN2, CABS, COS, COSH, + EXP, R1MACH, SIN, SINH, SQRT, TAN, TANH C .. Intrinsic Functions .. INTRINSIC ABS, CMPLX C C Correct values through different calculations are stored in V(*) C C .. Data statements .. DATA V( 1) / 1.0 / DATA V( 2) / 89.0 / DATA V( 3) / 30.0 / DATA V( 4) / 6.324555320337E+06 / DATA V( 5) / 10.55327437339 / DATA V( 6) / 79.32157587945 / DATA V( 7) / 901.0429556913 / DATA V( 8) / 4.00000E+13 / DATA V( 9) / 3.14159265359 / DATA V(10) / 2.094395102393 / DATA V(11) / 1.570796326795 / DATA V(12) / 1.047197551197 / DATA V(13) / -1.570796326795 / DATA V(14) / -0.5235987755983 / DATA V(15) / 0.0 / DATA V(16) / 0.5235987755983 / DATA V(17) / -0.7853981633974 / DATA V(18) / -0.4636476090008 / DATA V(19) / 0.0 / DATA V(20) / 0.4636476090008 / DATA V(21) / -0.5880026035475 / DATA V(22) / -0.4636476090008 / DATA V(23) / 2.0344438552856 / DATA V(24) / 2.158798930342 / DATA V(25) / 0.5403023058681 / DATA V(26) / 0.8775825618903 / DATA V(27) / 1.0 / DATA V(28) / 0.8775825618903 / DATA V(29) / -0.8414709848079 / DATA V(30) / -0.4794255386042 / DATA V(31) / 0.0 / DATA V(32) / 0.4794255386042 / DATA V(33) / -1.557407724655 / DATA V(34) / -0.5463024898437 / DATA V(35) / 0.0 / DATA V(36) / 0.5463024898437 / DATA V(37) / 2.302585092994 / DATA V(38) / 2.995732273554 / DATA V(39) / 3.401197381662 / DATA V(40) / 3.688879454114 / DATA V(41) / 1.0 / DATA V(42) / 1.301029995664 / DATA V(43) / 1.47712125472 / DATA V(44) / 1.602059991328 / DATA V(45) / 1.000001005301 / DATA V(46) / 0.9998430123238 / DATA V(47) / 1.000038765751 / DATA V(48) / 0.992002154326 / DATA V(49) / 1.543080634815 / DATA V(50) / 1.127625965206 / DATA V(51) / 1.0 / DATA V(52) / 1.127625965206 / DATA V(53) / -1.175201193644 / DATA V(54) / -0.5210953054937 / DATA V(55) / 0.0 / DATA V(56) / 0.5210953054937 / DATA V(57) / -0.7615941559557 / DATA V(58) / -0.46211715726 / DATA V(59) / 0.0 / DATA V(60) / 0.46211715726 / C C***FIRST EXECUTABLE STATEMENT QCINTS C IF (KPRINT .GE. 2) WRITE (UNIT=LUN, FMT=9000) C C Exercise routines in Category C2. C Y( 1) = SQRT(1.0) Y( 2) = SQRT(7921.0) Y( 3) = SQRT(900.0) Y( 4) = SQRT(4.00000E+13) C C Exercise routines in Category C4. C Y( 5) = CABS(CMPLX(10.46,1.4)) Y( 6) = CABS(CMPLX(79.32,0.5)) Y( 7) = CABS(CMPLX(900.999,8.9)) Y( 8) = CABS(CMPLX(4.00000E+13,1.5)) C C Exercise routines in Category C4A. C Y( 9) = ACOS(-1.0) Y(10) = ACOS(-0.5) Y(11) = ACOS(0.0) Y(12) = ACOS(0.5) Y(13) = ASIN(-1.0) Y(14) = ASIN(-0.5) Y(15) = ASIN(0.0) Y(16) = ASIN(0.5) Y(17) = ATAN(-1.0) Y(18) = ATAN(-0.5) Y(19) = ATAN(0.0) Y(20) = ATAN(0.5) Y(21) = ATAN2(-1.0,1.5) Y(22) = ATAN2(-0.5,1.0) Y(23) = ATAN2(1.0,-0.5) Y(24) = ATAN2(1.5,-1.0) Y(25) = COS(-1.0) Y(26) = COS(-0.5) Y(27) = COS(0.0) Y(28) = COS(0.5) Y(29) = SIN(-1.0) Y(30) = SIN(-0.5) Y(31) = SIN(0.0) Y(32) = SIN(0.5) Y(33) = TAN(-1.0) Y(34) = TAN(-0.5) Y(35) = TAN(0.0) Y(36) = TAN(0.5) C C Exercise routines in Category C4B. C Y(37) = ALOG(10.0) Y(38) = ALOG(20.0) Y(39) = ALOG(30.0) Y(40) = ALOG(40.0) Y(41) = ALOG10(10.0) Y(42) = ALOG10(20.0) Y(43) = ALOG10(30.0) Y(44) = ALOG10(40.0) Y(45) = EXP(1.0053E-06) Y(46) = EXP(-1.57000E-04) Y(47) = EXP(3.87650E-05) Y(48) = EXP(-8.03000E-03) C C Exercise routines in Category C4C. C Y(49) = COSH(-1.0) Y(50) = COSH(-0.5) Y(51) = COSH(0.0) Y(52) = COSH(0.5) Y(53) = SINH(-1.00000) Y(54) = SINH(-0.50000) Y(55) = SINH(0.000000) Y(56) = SINH(0.500000) Y(57) = TANH(-1.00000) Y(58) = TANH(-0.50000) Y(59) = TANH(0.000000) Y(60) = TANH(0.500000) C C Check for possible errors. C IPASS = 1 ERRTOL = SQRT(R1MACH(4)) DO 10 I = 1,60 IF (ABS(V(I)-Y(I)) .GE. ERRTOL*ABS(V(I))+ERRTOL) THEN IPASS = 0 IF (KPRINT .GE. 2) WRITE (UNIT=LUN, FMT=9020) I, Y(I), V(I) ENDIF 10 CONTINUE IF (IPASS.NE.0 .AND. KPRINT.GE.2) WRITE (UNIT=LUN, FMT=9010) RETURN 9000 FORMAT (// ' Test of single precision Fullerton intrinsic ', + 'routines') 9010 FORMAT (' Single precision Fullerton intrinsic function ', + 'routines o.k.') 9020 FORMAT (' For I = ', I3, ' test fails with ', / + ' computed result = ', 1P, E22.14, / + ' and true result = ', E22.14) END