*DECK DQCGLS
      SUBROUTINE DQCGLS (LUN, KPRINT, IPASS)
C***BEGIN PROLOGUE  DQCGLS
C***PURPOSE  Quick check for DGLSS.
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (QCGLSS-S, DQCGLS-D)
C***AUTHOR  Voorhees, E. A., (LANL)
C***DESCRIPTION
C
C      QUICK CHECK SUBROUTINE  DQCGLS  TESTS THE EXECUTION
C      OF THE GENERAL LINEAR SYSTEM SOLVER, DGLSS .  THE
C      DGLSS  SUBROUTINE PACKAGE WAS WRITTEN BY T. MANTEUFFEL
C      (LANL).
C
C      A TITLE LINE AND A SUMMARY LINE ARE ALWAYS OUTPUTTED
C      BY DQCGLS.  THE SUMMARY LINE GIVES A COUNT OF THE
C      NUMBER OF PROBLEMS DETECTED DURING THE TEST.
C
C      THE REAL QUANTITIES FOR THE COMPUTED SOLUTION VECTOR
C      X  AND THE CORRESPONDING  RNORM  ARE COMPARED AGAINST
C      STORED VALUES.  DISAGREEMENT OCCURS IF A DIFFERENCE
C      IS SQRT(D1MACH(4) OR MORE.  THE RETURNED VALUE (INTEGER)
C      OF  INFO  IS ALSO CHECKED.  FOUR CASES ARE RUN, TWO
C      INVOLVING  LLSIA  AND TWO INVOLVING  ULSIA .
C
C      DQCGLS REQUIRES NO INPUT ARGUMENTS.  ON RETURN, NERR
C      (INTEGER TYPE) CONTAINS THE COUNT OF THE NUMBER OF
C      PROBLEMS DETECTED BY  QCGLSS .
C
C***ROUTINES CALLED  D1MACH, DGLSS
C***REVISION HISTORY  (YYMMDD)
C   811026  DATE WRITTEN
C   850601  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   901010  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  DQCGLS
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION AA(4,4,2),A(4,4),BB(4,2),B(4),XX(4,4)
      DIMENSION WORK(50)
      CHARACTER*1 LIST(2)
      INTEGER INF(4),NERR,KPROG,KCASE
      INTEGER IWORK(20),INFO,LUN
      DATA AA/1.D0,.5D0,1.D0,.25D0,0.D0,2.D0,0.D0,1.D0,2.D0,-1.D0,
     11.D0,0.D0,0.D0,0.D0,0.D0,0.D0,1.D0,2.D0,-1.D0,0.D0,0.D0,1.D0,
     22.D0,0.D0,-1.D0,0.D0,1.D0,0.D0,1.D0,0.D0,1.D0,0.D0/
      DATA BB/3.D0,1.5D0,2.D0,1.25D0,1.D0,3.D0,3.D0,0.D0/
      DATA XX/.9999999999999787D0,1.000000000000007D0,
     1 1.000000000000007D0,0.D0,.8095238095238102D0,
     2 1.047619047619044D0,1.095238095238081D0,0.D0,
     3 .7777777777777857D0,1.444444444444429D0,.3333333333333393D0,
     4 .5555555555555500D0,
     5 .3333333333333321D0,0.0D0,-.3333333333333286D0,
     6 .3333333333333286D0/
      DATA INF/0,1,0,2/
      DATA LIST/'L', 'U'/
C***FIRST EXECUTABLE STATEMENT  DQCGLS
      INFO = 0
      NERR = 0
      R = MAX(SQRT(D1MACH(4)),1.D-12)
      IF (KPRINT.GE.2) WRITE(LUN,800)
      DO 60 KPROG=1,2
         DO 50 KCASE=1,2
C
C           FORM BASIC MATRIX  A  AND VECTOR  B .  (CASE 1)
C
            DO 10  I=1,4
               DO 5  J=1,4
                  A(I,J) = AA(I,J,KPROG)
    5          CONTINUE
               B(I) = BB(I,KPROG)
   10       CONTINUE
C
C           MAKE 3 ROWS IDENTICAL FOR CASE 2.
C
            IF (KCASE .NE. 1) THEN
               DO 20  I=2,3
                  DO 15  J=1,4
                     A(I,J) = A(1,J)
   15             CONTINUE
                  B(I) = B(1)
   20          CONTINUE
            ENDIF
C
C           SOLVE FOR VECTOR  X .
C
            INFO = 0
            IF (KPROG .EQ. 1) CALL DGLSS(A,4,4,3,B,4,1,RNORM,WORK,50,
     1         IWORK,20,INFO)
            IF (KPROG .EQ. 2) CALL DGLSS(A,4,3,4,B,4,1,RNORM,WORK,50,
     1         IWORK,20,INFO)
C
C           TEST COMPUTED  X , RNORM , AND  INFO .
C
            KK = 2*(KPROG - 1) + KCASE
            DELMAX = 0.0D0
            DO 30  I=1,4
               DELX = ABS(B(I)-XX(I,KK))
               DELMAX = MAX(DELMAX,DELX)
   30       CONTINUE
C
            IF (KPRINT.GE.3) WRITE (LUN,701) LIST(KPROG),KCASE,DELMAX
            IF (DELMAX .GE. R) THEN
               NERR = NERR + 1
               IF(KPRINT.GE.2) WRITE(LUN,801) LIST(KPROG),KCASE,DELMAX
            ENDIF
C
            IF (KPRINT.GE.3) WRITE (LUN,702) LIST(KPROG),KCASE,RNORM
            IF (RNORM .GE. R) THEN
               NERR = NERR + 1
               IF (KPRINT.GE.2) WRITE (LUN,802) LIST(KPROG),KCASE,RNORM
            ENDIF
            IF (KPRINT.GE.3) WRITE (LUN,703) LIST(KPROG),KCASE,INFO,
     *         INF(KK)
            IF (INFO .NE. INF(KK)) THEN
               NERR = NERR + 1
               IF (KPRINT.GE.2) WRITE (LUN,803) LIST(KPROG),KCASE,INFO,
     *            INF(KK)
            ENDIF
   50    CONTINUE
   60 CONTINUE
C
C     SUMMARY PRINT
C
      IPASS=0
      IF (NERR.EQ.0) IPASS=1
      IF (NERR.NE.0 .AND. KPRINT.NE.0) WRITE (LUN,804) NERR
      IF (NERR.EQ.0 .AND. KPRINT.GT.1) WRITE (LUN,805)
      RETURN
C
  703 FORMAT (3X, A, 'LSIA, CASE ', I1, '.  INFO=', I1, ' (SHOULD = ',
     1   I1, ')'/)
  804 FORMAT (/' **** DQCGLS DETECTED A TOTAL OF ', I2,
     1   ' PROBLEMS WITH DGLSS. ****'/)
  805 FORMAT ('     DQCGLS DETECTED NO PROBLEMS WITH DGLSS.'/)
  801 FORMAT ('   PROBLEM WITH ', A, 'LSIA, CASE ', I1,
     1   '.  MAX ABS ERROR OF', D11.4/)
  800 FORMAT(/' *  DQCGLS - QUICK CHECK FOR DGLSS (DLLSIA AND DULSIA)'/)
  701 FORMAT (3X, A, 'LSIA, CASE ', I1, '.  MAX ABS ERROR OF', D11.4/)
  702 FORMAT (3X, A, 'LSIA, CASE ', I1, '.  RNORM IS ', D11.4/)
  802 FORMAT ('   PROBLEM WITH ', A, 'LSIA, CASE ', I1,
     1   '.  RNORM (TOO LARGE) IS', D11.4/)
  803 FORMAT ('   PROBLEM WITH ', A, 'LSIA, CASE ', I1, '.  INFO=', I1,
     1   ' (SHOULD = ', I1, ')'/)
      END
