*DECK CQCK
      SUBROUTINE CQCK (LUN, KPRINT, NERR)
C***BEGIN PROLOGUE  CQCK
C***PURPOSE  Quick check for CPOFS, CPOIR, CNBFS and CNBIR.
C***LIBRARY   SLATEC
C***KEYWORDS  QUICK CHECK
C***AUTHOR  Voorhees, E. A., (LANL)
C***DESCRIPTION
C
C    QUICK CHECK SUBROUTINE CQCK TESTS THE EXECUTION OF THE
C    SLATEC SUBROUTINES CPOFS, CPOIR, CNBFS AND CNBIR.
C    A TITLE LINE AND A SUMMARY LINE ARE ALWAYS OUTPUTTED.
C
C    THE SUMMARY LINE GIVES A COUNT OF THE NUMBER OF
C    PROBLEMS ENCOUNTERED IN THE TEST IF ANY EXIST.  CQCK
C    CHECKS COMPUTED VS. EXACT SOLUTIONS TO AGREE TO
C    WITHIN 0.8 TIMES THE WORD LENGTH OF THE COMPUTER
C    (1.6 IF DOUBLE PRECISION) FOR CASE 1.  CQCK ALSO
C    TESTS ERROR HANDLING BY THE SUBROUTINE (CALLS TO
C    XERMSG (CQCK SETS IFLAG/KONTRL TO 0))
C    USING A SINGULAR MATRIX FOR CASE 2.  EACH EXECUTION
C    PROBLEM DETECTED BY CQCK RESULTS IN AN ADDITIONAL
C    EXPLANATORY LINE OF OUTPUT.
C
C    CQCK REQUIRES NO INPUT ARGUMENTS.
C    ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT
C    OF ALL PROBLEMS DETECTED BY CQCK.
C
C***ROUTINES CALLED  CNBFS, CNBIR, CPOFS, CPOIR, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   801002  DATE WRITTEN
C   891009  Removed unreferenced statement labels.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   901009  Restructured using IF-THEN-ELSE-ENDIF, cleaned up FORMATs,
C           including removing an illegal character from column 1, and
C           editorial changes.  (RWC)
C***END PROLOGUE  CQCK
      REAL R,DELX,DELMAX,R1MACH
      COMPLEX A(4,4),AT(5,4),ABE(5,7),ABET(5,7),B(4),BT(4),C(4),WORK(35)
      CHARACTER*4 LIST(4)
      INTEGER LDA,N,ML,MU,IND,IWORK(4),NERR,I,J,J1,J2,JD,MLP,K,KCASE,
     1 KPROG
      DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0),
     1  (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0),
     2  (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0),
     3  (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/
      DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/
      DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/
      DATA LIST/'POFS', 'POIR', 'NBFS', 'NBIR'/
C***FIRST EXECUTABLE STATEMENT  CQCK
      IF (KPRINT.GE.3) WRITE (LUN,800)
      LDA = 5
      N = 4
      ML = 2
      MU = 1
      JD = 2*ML+MU+1
      NERR = 0
      R = R1MACH(4)**0.8E0
C
C     FORM ABE(NB ARRAY) FROM MATRIX A.
C
      DO 30 J=1,JD
         DO 20 I=1,N
            ABE(I,J) = (0.0E0,0.0E0)
   20    CONTINUE
   30 CONTINUE
C
      MLP = ML+1
      DO 50 I=1,N
         J1 = MAX(1,I-ML)
         J2 = MIN(N,I+MU)
         DO 40 J=J1,J2
            K = J-I+MLP
            ABE(I,K) = A(I,J)
   40    CONTINUE
   50 CONTINUE
C
C     CASE 1 FOR WELL-CONDITIONED MATRIX, CASE 2 FOR SINGULAR MATRIX
C
      DO 170 KCASE=1,2
         DO 140 KPROG=1,4
C           FORM BT FROM B, AT FROM A, AND ABET FROM ABE.
            DO 60 I=1,N
               BT(I) = B(I)
               DO 58 J=1,N
                  AT(I,J) = A(I,J)
   58          CONTINUE
   60       CONTINUE
C
            DO 80 J=1,JD
               DO 70 I=1,N
                  ABET(I,J) = ABE(I,J)
   70          CONTINUE
   80       CONTINUE
C
C           MAKE AT AND ABET SINGULAR FOR CASE  =  2
C
            IF (KCASE.EQ.2) THEN
               DO 88 J=1,N
                  AT(1,J) = (0.0E0,0.0E0)
   88          CONTINUE
C
               DO 90 J=1,JD
                  ABET(1,J) = (0.0E0,0.0E0)
   90          CONTINUE
            ENDIF
C
C           SOLVE FOR X
C
            IF (KPROG.EQ.1) CALL CPOFS (AT,LDA,N,BT,1,IND,WORK)
            IF (KPROG.EQ.2) CALL CPOIR (AT,LDA,N,BT,1,IND,WORK)
            IF (KPROG.EQ.3) CALL CNBFS (ABET,LDA,N,ML,MU,BT,1,IND,WORK,
     *         IWORK)
            IF (KPROG.EQ.4) CALL CNBIR (ABET,LDA,N,ML,MU,BT,1,IND,WORK,
     *         IWORK)
C
C           COMPARE EXACT AND COMPUTED SOLUTIONS FOR CASE 1
C
            IF (KCASE.EQ.1) THEN
               DELMAX = 0.0E0
               DO 110 I=1,N
                  DELX = ABS(REAL(BT(I))-REAL(C(I)))
                  DELMAX = MAX(DELMAX,DELX)
                  DELX = ABS(AIMAG(BT(I))-AIMAG(C(I)))
                  DELMAX = MAX(DELMAX,DELX)
  110          CONTINUE
C
               IF (R.LE.DELMAX) THEN
                  NERR = NERR+1
                  WRITE (LUN,801) LIST(KPROG),KCASE,DELMAX
               ENDIF
            ELSE
C              CHECK CONTROL FOR SINGULAR MATRIX FOR CASE 2
C
               IF (IND.NE.-4) THEN
                  NERR = NERR+1
                  WRITE (LUN,802) LIST(KPROG),KCASE,IND
               ENDIF
            ENDIF
  140    CONTINUE
  170 CONTINUE
C
C     SUMMARY PRINT
C
      IF (NERR.NE.0) WRITE (LUN,803) NERR
      IF (KPRINT.GE.2 .AND. NERR.EQ.0) WRITE (LUN,804)
      RETURN
C
  800 FORMAT (/' *    CQCK - QUICK CHECK FOR CPOFS, CPOIR, CNBFS AND ',
     1   'CNBIR'/)
  801 FORMAT ('   PROBLEM WITH C', A, ', CASE ', I1,
     1   '.  MAX ABS ERROR OF', E11.4/)
  802 FORMAT ('   PROBLEM WITH C', A, ', CASE ', I1, '.  IND = ', I2,
     1   ' INSTEAD OF -4'/)
  803 FORMAT (/' **** CQCK DETECTED A TOTAL OF ', I2,' PROBLEMS. ****'/)
  804 FORMAT ('     CQCK DETECTED NO PROBLEMS.'/)
      END
