*DECK QCGLSS
      SUBROUTINE QCGLSS (LUN, KPRINT, IPASS)
C***BEGIN PROLOGUE  QCGLSS
C***PURPOSE  Quick check for SGLSS.
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (QCGLSS-S, DQCGLS-D)
C***AUTHOR  Voorhees, E. A., (LANL)
C***DESCRIPTION
C
C      QUICK CHECK SUBROUTINE  QCGLSS  TESTS THE EXECUTION
C      OF THE GENERAL LINEAR SYSTEM SOLVER, SGLSS .  THE
C      SGLSS  SUBROUTINE PACKAGE WAS WRITTEN BY T. MANTEUFFEL
C      (LANL).
C
C      A TITLE LINE AND A SUMMARY LINE ARE ALWAYS OUTPUTTED
C      BY QCGLSS.  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(R1MACH(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      QCGLSS 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  R1MACH, SGLSS
C***REVISION HISTORY  (YYMMDD)
C   811026  DATE WRITTEN
C   820801  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  QCGLSS
      REAL AA(4,4,2),A(4,4),BB(4,2),B(4),XX(4,4),DELMAX,DELX,R
      REAL WORK(20)
      CHARACTER*1 LIST(2)
      INTEGER INF(4),NERR,KPROG,KCASE
      INTEGER IWORK(7),INFO,LUN
      DATA AA/1.,.5,1.,.25,0.,2.,0.,1.,2.,-1.,1.,0.,0.,0.,0.,0.,
     1 1.,2.,-1.,0.,0.,1.,2.,0.,-1.,0.,1.,0.,1.,0.,1.,0./
      DATA BB/3.,1.5,2.,1.25,1.,3.,3.,0./
      DATA XX/.9999999999999787,1.000000000000007,1.000000000000007,
     1 0.,.8095238095238102,1.047619047619044,1.095238095238081,0.,
     1 .7777777777777857,1.444444444444429,.3333333333333393,
     1 .5555555555555500,
     1 .3333333333333321,0.0,-.3333333333333286,.3333333333333286/
      DATA INF/0,1,0,2/
      DATA LIST/'L','U'/
C***FIRST EXECUTABLE STATEMENT  QCGLSS
      INFO = 0
      NERR = 0
      R = SQRT(R1MACH(4))
      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 SGLSS(A,4,4,3,B,4,1,RNORM,WORK,20,
     1         IWORK,7,INFO)
            IF (KPROG .EQ. 2) CALL SGLSS(A,4,3,4,B,4,1,RNORM,WORK,20,
     1         IWORK,7,INFO)
C
C           TEST COMPUTED  X , RNORM , AND  INFO .
C
            KK = 2*(KPROG - 1) + KCASE
            DELMAX = 0.0E0
            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
            IF (KPRINT.GE.3) WRITE (LUN,702) LIST(KPROG),KCASE,RNORM
            IF (RNORM .GT. R) THEN
               NERR = NERR + 1
               IF (KPRINT.GE.2) WRITE (LUN,802) LIST(KPROG),KCASE,RNORM
            ENDIF
C
            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
  701 FORMAT (3X, A, 'LSIA, CASE ', I1, '.  MAX ABS ERROR OF', E11.4/)
  702 FORMAT (3X, A, 'LSIA, CASE ', I1, '.  RNORM IS ', E11.4/)
  703 FORMAT (3X, A, 'LSIA, CASE ', I1, '.  INFO=', I1,
     1   ' (SHOULD = ', I1, ')'/)
  800 FORMAT(/' *    QCGLSS - QUICK CHECK FOR SGLSS (LLSIA AND ULSIA)'/)
  801 FORMAT ('   PROBLEM WITH ', A, 'LSIA, CASE ', I1,
     1   '.  MAX ABS ERROR OF', E11.4/)
  802 FORMAT ('   PROBLEM WITH ', A, 'LSIA, CASE ', I1,
     1   '.  RNORM (TOO LARGE) IS', E11.4/)
  803 FORMAT ('   PROBLEM WITH ', A, 'LSIA, CASE ', I1,
     1   '.  INFO=', I1, ' (SHOULD = ', I1, ')'/)
  804 FORMAT (/' **** QCGLSS DETECTED A TOTAL OF ', I2,
     1   ' PROBLEMS WITH SGLSS. ****'/)
  805 FORMAT ('     QCGLSS DETECTED NO PROBLEMS WITH SGLSS.'/)
      END
