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