1*DECK CQCK 2 SUBROUTINE CQCK (LUN, KPRINT, NERR) 3C***BEGIN PROLOGUE CQCK 4C***PURPOSE Quick check for CPOFS, CPOIR, CNBFS and CNBIR. 5C***LIBRARY SLATEC 6C***KEYWORDS QUICK CHECK 7C***AUTHOR Voorhees, E. A., (LANL) 8C***DESCRIPTION 9C 10C QUICK CHECK SUBROUTINE CQCK TESTS THE EXECUTION OF THE 11C SLATEC SUBROUTINES CPOFS, CPOIR, CNBFS AND CNBIR. 12C A TITLE LINE AND A SUMMARY LINE ARE ALWAYS OUTPUTTED. 13C 14C THE SUMMARY LINE GIVES A COUNT OF THE NUMBER OF 15C PROBLEMS ENCOUNTERED IN THE TEST IF ANY EXIST. CQCK 16C CHECKS COMPUTED VS. EXACT SOLUTIONS TO AGREE TO 17C WITHIN 0.8 TIMES THE WORD LENGTH OF THE COMPUTER 18C (1.6 IF DOUBLE PRECISION) FOR CASE 1. CQCK ALSO 19C TESTS ERROR HANDLING BY THE SUBROUTINE (CALLS TO 20C XERMSG (CQCK SETS IFLAG/KONTRL TO 0)) 21C USING A SINGULAR MATRIX FOR CASE 2. EACH EXECUTION 22C PROBLEM DETECTED BY CQCK RESULTS IN AN ADDITIONAL 23C EXPLANATORY LINE OF OUTPUT. 24C 25C CQCK REQUIRES NO INPUT ARGUMENTS. 26C ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT 27C OF ALL PROBLEMS DETECTED BY CQCK. 28C 29C***ROUTINES CALLED CNBFS, CNBIR, CPOFS, CPOIR, R1MACH 30C***REVISION HISTORY (YYMMDD) 31C 801002 DATE WRITTEN 32C 891009 Removed unreferenced statement labels. (WRB) 33C 891009 REVISION DATE from Version 3.2 34C 891214 Prologue converted to Version 4.0 format. (BAB) 35C 901009 Restructured using IF-THEN-ELSE-ENDIF, cleaned up FORMATs, 36C including removing an illegal character from column 1, and 37C editorial changes. (RWC) 38C***END PROLOGUE CQCK 39 REAL R,DELX,DELMAX,R1MACH 40 COMPLEX A(4,4),AT(5,4),ABE(5,7),ABET(5,7),B(4),BT(4),C(4),WORK(35) 41 CHARACTER*4 LIST(4) 42 INTEGER LDA,N,ML,MU,IND,IWORK(4),NERR,I,J,J1,J2,JD,MLP,K,KCASE, 43 1 KPROG 44 DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), 45 1 (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 46 2 (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), 47 3 (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ 48 DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ 49 DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ 50 DATA LIST/'POFS', 'POIR', 'NBFS', 'NBIR'/ 51C***FIRST EXECUTABLE STATEMENT CQCK 52 IF (KPRINT.GE.3) WRITE (LUN,800) 53 LDA = 5 54 N = 4 55 ML = 2 56 MU = 1 57 JD = 2*ML+MU+1 58 NERR = 0 59 R = R1MACH(4)**0.8E0 60C 61C FORM ABE(NB ARRAY) FROM MATRIX A. 62C 63 DO 30 J=1,JD 64 DO 20 I=1,N 65 ABE(I,J) = (0.0E0,0.0E0) 66 20 CONTINUE 67 30 CONTINUE 68C 69 MLP = ML+1 70 DO 50 I=1,N 71 J1 = MAX(1,I-ML) 72 J2 = MIN(N,I+MU) 73 DO 40 J=J1,J2 74 K = J-I+MLP 75 ABE(I,K) = A(I,J) 76 40 CONTINUE 77 50 CONTINUE 78C 79C CASE 1 FOR WELL-CONDITIONED MATRIX, CASE 2 FOR SINGULAR MATRIX 80C 81 DO 170 KCASE=1,2 82 DO 140 KPROG=1,4 83C FORM BT FROM B, AT FROM A, AND ABET FROM ABE. 84 DO 60 I=1,N 85 BT(I) = B(I) 86 DO 58 J=1,N 87 AT(I,J) = A(I,J) 88 58 CONTINUE 89 60 CONTINUE 90C 91 DO 80 J=1,JD 92 DO 70 I=1,N 93 ABET(I,J) = ABE(I,J) 94 70 CONTINUE 95 80 CONTINUE 96C 97C MAKE AT AND ABET SINGULAR FOR CASE = 2 98C 99 IF (KCASE.EQ.2) THEN 100 DO 88 J=1,N 101 AT(1,J) = (0.0E0,0.0E0) 102 88 CONTINUE 103C 104 DO 90 J=1,JD 105 ABET(1,J) = (0.0E0,0.0E0) 106 90 CONTINUE 107 ENDIF 108C 109C SOLVE FOR X 110C 111 IF (KPROG.EQ.1) CALL CPOFS (AT,LDA,N,BT,1,IND,WORK) 112 IF (KPROG.EQ.2) CALL CPOIR (AT,LDA,N,BT,1,IND,WORK) 113 IF (KPROG.EQ.3) CALL CNBFS (ABET,LDA,N,ML,MU,BT,1,IND,WORK, 114 * IWORK) 115 IF (KPROG.EQ.4) CALL CNBIR (ABET,LDA,N,ML,MU,BT,1,IND,WORK, 116 * IWORK) 117C 118C COMPARE EXACT AND COMPUTED SOLUTIONS FOR CASE 1 119C 120 IF (KCASE.EQ.1) THEN 121 DELMAX = 0.0E0 122 DO 110 I=1,N 123 DELX = ABS(REAL(BT(I))-REAL(C(I))) 124 DELMAX = MAX(DELMAX,DELX) 125 DELX = ABS(AIMAG(BT(I))-AIMAG(C(I))) 126 DELMAX = MAX(DELMAX,DELX) 127 110 CONTINUE 128C 129 IF (R.LE.DELMAX) THEN 130 NERR = NERR+1 131 WRITE (LUN,801) LIST(KPROG),KCASE,DELMAX 132 ENDIF 133 ELSE 134C CHECK CONTROL FOR SINGULAR MATRIX FOR CASE 2 135C 136 IF (IND.NE.-4) THEN 137 NERR = NERR+1 138 WRITE (LUN,802) LIST(KPROG),KCASE,IND 139 ENDIF 140 ENDIF 141 140 CONTINUE 142 170 CONTINUE 143C 144C SUMMARY PRINT 145C 146 IF (NERR.NE.0) WRITE (LUN,803) NERR 147 IF (KPRINT.GE.2 .AND. NERR.EQ.0) WRITE (LUN,804) 148 RETURN 149C 150 800 FORMAT (/' * CQCK - QUICK CHECK FOR CPOFS, CPOIR, CNBFS AND ', 151 1 'CNBIR'/) 152 801 FORMAT (' PROBLEM WITH C', A, ', CASE ', I1, 153 1 '. MAX ABS ERROR OF', E11.4/) 154 802 FORMAT (' PROBLEM WITH C', A, ', CASE ', I1, '. IND = ', I2, 155 1 ' INSTEAD OF -4'/) 156 803 FORMAT (/' **** CQCK DETECTED A TOTAL OF ', I2,' PROBLEMS. ****'/) 157 804 FORMAT (' CQCK DETECTED NO PROBLEMS.'/) 158 END 159