*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