1*DECK CQCK
2      SUBROUTINE CQCK (LUN, KPRINT, NERR)
3C***BEGIN PROLOGUE  CQCK
4C***PURPOSE  Quick check for CPOFS, CPOIR, CNBFS and CNBIR.
5C***LIBRARY   SLATEC
6C***KEYWORDS  QUICK CHECK
7C***AUTHOR  Voorhees, E. A., (LANL)
8C***DESCRIPTION
9C
10C    QUICK CHECK SUBROUTINE CQCK TESTS THE EXECUTION OF THE
11C    SLATEC SUBROUTINES CPOFS, CPOIR, CNBFS AND CNBIR.
12C    A TITLE LINE AND A SUMMARY LINE ARE ALWAYS OUTPUTTED.
13C
14C    THE SUMMARY LINE GIVES A COUNT OF THE NUMBER OF
15C    PROBLEMS ENCOUNTERED IN THE TEST IF ANY EXIST.  CQCK
16C    CHECKS COMPUTED VS. EXACT SOLUTIONS TO AGREE TO
17C    WITHIN 0.8 TIMES THE WORD LENGTH OF THE COMPUTER
18C    (1.6 IF DOUBLE PRECISION) FOR CASE 1.  CQCK ALSO
19C    TESTS ERROR HANDLING BY THE SUBROUTINE (CALLS TO
20C    XERMSG (CQCK SETS IFLAG/KONTRL TO 0))
21C    USING A SINGULAR MATRIX FOR CASE 2.  EACH EXECUTION
22C    PROBLEM DETECTED BY CQCK RESULTS IN AN ADDITIONAL
23C    EXPLANATORY LINE OF OUTPUT.
24C
25C    CQCK REQUIRES NO INPUT ARGUMENTS.
26C    ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT
27C    OF ALL PROBLEMS DETECTED BY CQCK.
28C
29C***ROUTINES CALLED  CNBFS, CNBIR, CPOFS, CPOIR, R1MACH
30C***REVISION HISTORY  (YYMMDD)
31C   801002  DATE WRITTEN
32C   891009  Removed unreferenced statement labels.  (WRB)
33C   891009  REVISION DATE from Version 3.2
34C   891214  Prologue converted to Version 4.0 format.  (BAB)
35C   901009  Restructured using IF-THEN-ELSE-ENDIF, cleaned up FORMATs,
36C           including removing an illegal character from column 1, and
37C           editorial changes.  (RWC)
38C***END PROLOGUE  CQCK
39      REAL R,DELX,DELMAX,R1MACH
40      COMPLEX A(4,4),AT(5,4),ABE(5,7),ABET(5,7),B(4),BT(4),C(4),WORK(35)
41      CHARACTER*4 LIST(4)
42      INTEGER LDA,N,ML,MU,IND,IWORK(4),NERR,I,J,J1,J2,JD,MLP,K,KCASE,
43     1 KPROG
44      DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0),
45     1  (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0),
46     2  (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0),
47     3  (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/
48      DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/
49      DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/
50      DATA LIST/'POFS', 'POIR', 'NBFS', 'NBIR'/
51C***FIRST EXECUTABLE STATEMENT  CQCK
52      IF (KPRINT.GE.3) WRITE (LUN,800)
53      LDA = 5
54      N = 4
55      ML = 2
56      MU = 1
57      JD = 2*ML+MU+1
58      NERR = 0
59      R = R1MACH(4)**0.8E0
60C
61C     FORM ABE(NB ARRAY) FROM MATRIX A.
62C
63      DO 30 J=1,JD
64         DO 20 I=1,N
65            ABE(I,J) = (0.0E0,0.0E0)
66   20    CONTINUE
67   30 CONTINUE
68C
69      MLP = ML+1
70      DO 50 I=1,N
71         J1 = MAX(1,I-ML)
72         J2 = MIN(N,I+MU)
73         DO 40 J=J1,J2
74            K = J-I+MLP
75            ABE(I,K) = A(I,J)
76   40    CONTINUE
77   50 CONTINUE
78C
79C     CASE 1 FOR WELL-CONDITIONED MATRIX, CASE 2 FOR SINGULAR MATRIX
80C
81      DO 170 KCASE=1,2
82         DO 140 KPROG=1,4
83C           FORM BT FROM B, AT FROM A, AND ABET FROM ABE.
84            DO 60 I=1,N
85               BT(I) = B(I)
86               DO 58 J=1,N
87                  AT(I,J) = A(I,J)
88   58          CONTINUE
89   60       CONTINUE
90C
91            DO 80 J=1,JD
92               DO 70 I=1,N
93                  ABET(I,J) = ABE(I,J)
94   70          CONTINUE
95   80       CONTINUE
96C
97C           MAKE AT AND ABET SINGULAR FOR CASE  =  2
98C
99            IF (KCASE.EQ.2) THEN
100               DO 88 J=1,N
101                  AT(1,J) = (0.0E0,0.0E0)
102   88          CONTINUE
103C
104               DO 90 J=1,JD
105                  ABET(1,J) = (0.0E0,0.0E0)
106   90          CONTINUE
107            ENDIF
108C
109C           SOLVE FOR X
110C
111            IF (KPROG.EQ.1) CALL CPOFS (AT,LDA,N,BT,1,IND,WORK)
112            IF (KPROG.EQ.2) CALL CPOIR (AT,LDA,N,BT,1,IND,WORK)
113            IF (KPROG.EQ.3) CALL CNBFS (ABET,LDA,N,ML,MU,BT,1,IND,WORK,
114     *         IWORK)
115            IF (KPROG.EQ.4) CALL CNBIR (ABET,LDA,N,ML,MU,BT,1,IND,WORK,
116     *         IWORK)
117C
118C           COMPARE EXACT AND COMPUTED SOLUTIONS FOR CASE 1
119C
120            IF (KCASE.EQ.1) THEN
121               DELMAX = 0.0E0
122               DO 110 I=1,N
123                  DELX = ABS(REAL(BT(I))-REAL(C(I)))
124                  DELMAX = MAX(DELMAX,DELX)
125                  DELX = ABS(AIMAG(BT(I))-AIMAG(C(I)))
126                  DELMAX = MAX(DELMAX,DELX)
127  110          CONTINUE
128C
129               IF (R.LE.DELMAX) THEN
130                  NERR = NERR+1
131                  WRITE (LUN,801) LIST(KPROG),KCASE,DELMAX
132               ENDIF
133            ELSE
134C              CHECK CONTROL FOR SINGULAR MATRIX FOR CASE 2
135C
136               IF (IND.NE.-4) THEN
137                  NERR = NERR+1
138                  WRITE (LUN,802) LIST(KPROG),KCASE,IND
139               ENDIF
140            ENDIF
141  140    CONTINUE
142  170 CONTINUE
143C
144C     SUMMARY PRINT
145C
146      IF (NERR.NE.0) WRITE (LUN,803) NERR
147      IF (KPRINT.GE.2 .AND. NERR.EQ.0) WRITE (LUN,804)
148      RETURN
149C
150  800 FORMAT (/' *    CQCK - QUICK CHECK FOR CPOFS, CPOIR, CNBFS AND ',
151     1   'CNBIR'/)
152  801 FORMAT ('   PROBLEM WITH C', A, ', CASE ', I1,
153     1   '.  MAX ABS ERROR OF', E11.4/)
154  802 FORMAT ('   PROBLEM WITH C', A, ', CASE ', I1, '.  IND = ', I2,
155     1   ' INSTEAD OF -4'/)
156  803 FORMAT (/' **** CQCK DETECTED A TOTAL OF ', I2,' PROBLEMS. ****'/)
157  804 FORMAT ('     CQCK DETECTED NO PROBLEMS.'/)
158      END
159