1*DECK FZTEST 2 SUBROUTINE FZTEST (LUN, KPRINT, IPASS) 3C***BEGIN PROLOGUE FZTEST 4C***PURPOSE Quick check for FZERO. 5C***LIBRARY SLATEC 6C***TYPE SINGLE PRECISION (FZTEST-S, DFZTST-D) 7C***AUTHOR (UNKNOWN) 8C***ROUTINES CALLED FZERO, R1MACH, XERCLR, XGETF, XSETF 9C***REVISION HISTORY (YYMMDD) 10C ?????? DATE WRITTEN 11C 891214 Prologue converted to Version 4.0 format. (BAB) 12C 901205 Changed usage of R1MACH(3) to R1MACH(4). (RWC) 13C 910501 Added PURPOSE and TYPE records. (WRB) 14C 910708 Minor modifications in use of KPRINT. (WRB) 15C 920212 Code completely restructured to test IFLAG for all values 16C of KPRINT. (WRB) 17C***END PROLOGUE FZTEST 18C .. Scalar Arguments .. 19 INTEGER IPASS, KPRINT, LUN 20C .. Local Scalars .. 21 INTEGER IFLAG, KONTRL 22 REAL AE, B, C, PI, R, RE, TOL 23 LOGICAL FATAL 24C .. External Functions .. 25 REAL R1MACH 26 EXTERNAL R1MACH 27C .. External Subroutines .. 28 EXTERNAL FZERO, XERCLR, XGETF, XSETF 29C .. Intrinsic Functions .. 30 INTRINSIC ABS, ATAN, MAX, SIN, SQRT, TAN 31C***FIRST EXECUTABLE STATEMENT FZTEST 32 IF (KPRINT .GE. 2) WRITE (LUN,9000) 33 IPASS = 1 34 PI = 4.0E0 *ATAN(1.0E0) 35 RE = 1.0E-6 36 AE = 1.0E-6 37 TOL = MAX(1.0E-5,SQRT(R1MACH(4))) 38C 39C Set up and solve example problem 40C 41 B = 0.1E0 42 C = 4.0E0 43 R = C - B 44 CALL FZERO (SIN, B, C, R, RE, AE, IFLAG) 45C 46C See if test was passed. 47C 48 IF (ABS(B-PI).LE.TOL .AND. ABS(C-PI).LE.TOL) THEN 49 IF (KPRINT .GE. 3) WRITE (LUN, 9010) 'PASSED', B, C, IFLAG 50 ELSE 51 IPASS = 0 52 IF (KPRINT .GE. 2) WRITE (LUN, 9010) 'FAILED', B, C, IFLAG 53 ENDIF 54C 55C Trigger 2 error conditions 56C 57 CALL XGETF (KONTRL) 58 IF (KPRINT .LE. 2) THEN 59 CALL XSETF (0) 60 ELSE 61 CALL XSETF (1) 62 ENDIF 63 FATAL = .FALSE. 64 CALL XERCLR 65C 66 IF (KPRINT .GE. 3) WRITE (LUN,9020) 67 B = 1.0E0 68C 69C IFLAG=3 (Singular point) 70C 71 C = 2.0E0 72 R = 0.5E0*(B+C) 73 CALL FZERO (TAN, B, C, B, RE, AE, IFLAG) 74 IF (IFLAG .NE. 3) THEN 75 IPASS = 0 76 FATAL = .TRUE. 77 IF (KPRINT .GE. 2) WRITE (LUN,9030) IFLAG, 2 78 ENDIF 79C 80C IFLAG=4 (No sign change) 81C 82 B = -3.0E0 83 C = -0.1E0 84 R = 0.5E0*(B+C) 85 CALL FZERO (SIN, B, C, R, RE, AE, IFLAG) 86 IF (IFLAG .NE. 4) THEN 87 IPASS = 0 88 FATAL = .TRUE. 89 IF (KPRINT .GE. 2) WRITE (LUN,9030) IFLAG, 4 90 ENDIF 91C 92 CALL XERCLR 93C 94 CALL XSETF (KONTRL) 95 IF (FATAL) THEN 96 IF (KPRINT .GE. 2) THEN 97 WRITE (LUN, 9040) 98 ENDIF 99 ELSE 100 IF (KPRINT .GE. 3) THEN 101 WRITE (LUN, 9050) 102 ENDIF 103 ENDIF 104C 105 IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN,9060) 106 IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN,9070) 107 RETURN 108 9000 FORMAT ('1' / ' FZERO QUICK CHECK') 109 9010 FORMAT (' Accuracy test ', A / 110 + ' Example problem results: (answer = PI), B =', F20.14, 111 + ' C =', F20.14 / ' IFLAG =', I2) 112 9020 FORMAT (/ ' IFLAG 3 and 4 tests') 113 9030 FORMAT (/' IFLAG test FAILED. IFLAG =', I2, ', but should ', 114 + 'have been', I2) 115 9040 FORMAT (/ ' At least IFLAG test failed') 116 9050 FORMAT (/ ' All IFLAG tests passed') 117 9060 FORMAT (/' ***************FZERO PASSED ALL TESTS**************') 118 9070 FORMAT (/' ***************FZERO FAILED SOME TESTS*************') 119 END 120