1*DECK CQRTST
2      SUBROUTINE CQRTST (LUN, KPRINT, IPASS)
3C***BEGIN PROLOGUE  CQRTST
4C***PURPOSE  Quick check for CPQR79.
5C***LIBRARY   SLATEC
6C***TYPE      COMPLEX (RQRTST-S, CQRTST-C)
7C***AUTHOR  (UNKNOWN)
8C***ROUTINES CALLED  CPQR79, NUMXER, PASS, 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   911010  Code reworked and simplified.  (RWC and WRB)
14C***END PROLOGUE  CQRTST
15      INTEGER ITEST(2), ITMP(7)
16      REAL WORK(144)
17      COMPLEX COEFF1(9), COEFF2(2), COEFF3(2), ROOT(8), CHK1(8), CHK2
18      LOGICAL FATAL
19C
20      DATA COEFF1 / (1.0,0.0), (-7.0,-2.0), (8.0,6.0), (28.0, 8.0),
21     *              (-49.0,-24.0), (7.0,2.0), (-8.0,-6.0),
22     *              (-28.0,-8.0), (48.0,24.0)/
23      DATA COEFF2 / (1.0,1.0), (1.0,3.0) /
24      DATA COEFF3 / (0.0,0.0), (1.0,3.0) /
25      DATA CHK1 / (4.0,2.0), (3.0,0.0), (-2.0,0.0), (2.0,0.0),
26     *            (0.0,-1.0), (-1.0,0.0), (0.0,1.0), (1.0,0.0) /
27      DATA CHK2 / (-2.0,-1.0) /
28C***FIRST EXECUTABLE STATEMENT  CQRTST
29      IF (KPRINT .GE. 2) WRITE (LUN, 90000)
30      TOL = SQRT(R1MACH(4))
31      IPASS = 1
32C
33C     First test.
34C
35      CALL CPQR79 (8, COEFF1, ROOT, IERR, WORK)
36C
37C     Check to see if test passed.
38C
39      DO 10 I=1,7
40         ITMP(I) = 0
41   10 CONTINUE
42C
43C     Check for roots in any order.
44C
45      DO 30 I=1,7
46         DO 20 J=1,7
47            IF (ABS(ROOT(I)-CHK1(J)) .LE. TOL) THEN
48               ITMP(J) = 1
49               GOTO 30
50            ENDIF
51   20    CONTINUE
52   30 CONTINUE
53C
54C     Check that we found all 7 roots.
55C
56      ITEST(1) = 1
57      DO 40 I=1,7
58         ITEST(1) = ITEST(1)*ITMP(I)
59   40 CONTINUE
60C
61C     Print test results.
62C
63      IF (KPRINT.GE.3 .OR. (KPRINT.GE.2.AND.ITEST(1).EQ.0)) THEN
64         WRITE (LUN, 90010)
65         WRITE (LUN, 90020) (J,COEFF1(J), J=1,9)
66         WRITE (LUN, 90030)
67         WRITE (LUN, 90040) (J,ROOT(J), J=1,7)
68      ENDIF
69      IF (KPRINT .GE. 2) THEN
70         CALL PASS (LUN, 1, ITEST(1))
71      ENDIF
72C
73C     Set up next problem.
74C
75      CALL CPQR79 (1, COEFF2, ROOT, IERR, WORK)
76C
77C     Check to see if test passed.
78C
79      ITEST(2) = 1
80      IF (ABS(ROOT(1)-CHK2) .GT. TOL) ITEST(2) = 0
81C
82C     Print test results for second test.
83C
84      IF (KPRINT.GE.3 .OR. (KPRINT.GE.2.AND.ITEST(1).EQ.0)) THEN
85         WRITE (LUN, 90050)
86         WRITE (LUN, 90010)
87         WRITE (LUN, 90020) (J,COEFF2(J), J=1,2)
88         WRITE (LUN, 90030)
89         WRITE (LUN, 90040) (J,ROOT(J), J=1,1)
90      ENDIF
91      IF (KPRINT .GE. 2) THEN
92         CALL PASS (LUN, 2, ITEST(2))
93      ENDIF
94C
95C     Trigger 2 error conditions
96C
97      CALL XGETF (KONTRL)
98      IF (KPRINT .LE. 2) THEN
99         CALL XSETF (0)
100      ELSE
101         CALL XSETF (1)
102      ENDIF
103      FATAL = .FALSE.
104      CALL XERCLR
105      IF (KPRINT .GE. 3) WRITE (LUN, 90060)
106C
107C     CALL CPQR79 with 0 degree polynomial.
108C
109      CALL CPQR79 (0, COEFF2, ROOT, IERR, WORK)
110      IF (NUMXER(NERR) .NE. 3) THEN
111         FATAL = .TRUE.
112      ENDIF
113      CALL XERCLR
114C
115C     CALL CPQR79 with zero leading coefficient.
116C
117      CALL CPQR79 (2, COEFF3, ROOT, IERR, WORK)
118      IF (NUMXER(NERR) .NE. 2) THEN
119         FATAL = .TRUE.
120      ENDIF
121      CALL XERCLR
122C
123      CALL XSETF (KONTRL)
124      IF (FATAL) THEN
125         IPASS = 0
126         IF (KPRINT .GE. 2) THEN
127            WRITE (LUN, 90070)
128         ENDIF
129      ELSE
130         IF (KPRINT .GE. 3) THEN
131            WRITE (LUN, 90080)
132         ENDIF
133      ENDIF
134C
135C     See if all tests passed.
136C
137      IPASS = IPASS*ITEST(1)*ITEST(2)
138C
139      IF (IPASS.EQ.1 .AND. KPRINT.GT.1) WRITE (LUN,90100)
140      IF (IPASS.EQ.0 .AND. KPRINT.NE.0) WRITE (LUN,90110)
141      RETURN
142C
14390000 FORMAT ('1', /,' CPQR79 QUICK CHECK')
14490010 FORMAT (/, ' CHECK REAL AND IMAGINARY PARTS OF ROOT' /
145     *          ' COEFFICIENTS')
14690020 FORMAT (/ (I6, 3X, 1P, 2E22.14))
14790030 FORMAT (// 25X, 'TABLE of ROOTS' //
148     *        '   ROOT         REAL  PART', 12X, 'IMAG  PART' /
149     *        '  NUMBER', 8X, 2(' of  ZERO ', 12X))
15090040 FORMAT (I6, 3X, 1P, 2E22.14)
15190050 FORMAT (/, ' TEST SUBSEQUENT RELATED CALL')
15290060 FORMAT (// ' TRIGGER 2 ERROR CONDITIONS' //)
15390070 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED')
15490080 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED')
15590100 FORMAT (/' **************CPQR79 PASSED ALL TESTS**************')
15690110 FORMAT (/' **************CPQR79 FAILED SOME TESTS*************')
157      END
158