*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