*DECK CQRQC SUBROUTINE CQRQC (LUN, KPRINT, NERR) C***BEGIN PROLOGUE CQRQC C***PURPOSE Quick check for CQRDC and CQRSL. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Voorhees, E. A., (LANL) C***DESCRIPTION C C THE RETURNED FLOATING POINT VALUES FROM CQRDC AND CQRSL FOR C FACTORED X, QRAUX, QY, QTY, B, RSD, AND XB ARE COMPARED TO C THEIR CORRESPONDING STORED PRE-COMPUTED VALUES (ENTERED C WITH DATA STATEMENTS). FAILURE OF THE TEST OCCURS WHEN C AGREEMENT TO 3 SIGNIFICANT DIGITS IS NOT ACHIEVED AND AN C ERROR MESSAGE IS THEN PRINTED. C C THE RETURNED INTEGER VALUES OF JPVT AND INFO ARE ALSO CHECKED. C LACK OF AGREEMENT RESULTS IN AN ERROR MESSAGE. A SUMMARY C LINE IS ALWAYS PRINTED. C C NO INPUT ARGUMENTS ARE REQUIRED. ON RETURN, NERR (INTEGER C TYPE) CONTAINS THE TOTAL COUNT OF ALL FAILURES DETECTED. C C***ROUTINES CALLED CQRDC, CQRSL C***REVISION HISTORY (YYMMDD) C 801029 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901010 Restructured using IF-THEN-ELSE-ENDIF, moved an ARITHMETIC C STATEMENT FUNCTION ahead of the FIRST EXECUTABLE STATEMENT C record and cleaned up FORMATs. (RWC) C***END PROLOGUE CQRQC COMPLEX A(4,4),QRAUX(4),WORK(4),Y(4),QY(4),QTY(4),B(4),RSD(4),XB(4 1) COMPLEX AT(5,4),AC(4,4),QRAUXC(4),QYC(4),QTYC(4),BC(4),RSDC(4),XBC 1(4),X1,X2 CHARACTER KPROG*9,KFAIL*75 INTEGER LDX,N,P,JPVT(4),JOB,K,INFO INTEGER JPVTT(4),JPVTC(4),I,J,INDX(5),NERR,L REAL DELX DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), 1 (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 2 (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), 3 (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA JPVT/0,-1,1,0/ DATA Y/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA AC/(-3.16228E0,0.E0),(0.E0,0.E0),(.94868E0,0.E0), 1 (0.E0,.31623E0),(0.E0,2.21359E0),(-3.47851E0,0.E0), 2 (0.E0,.31623E0),(.94868E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), 3 (2.23607E0,0.E0),(0.E0,.70711E0),(0.E0,0.E0),(0.E0,0.E0), 4 (0.E0,-1.78885E0),(-1.34164E0,0.E0)/ DATA QRAUXC/(1.E0,0.E0),(1.E0,0.E0),(1.70711E0,0.E0),(0.E0,0.E0)/ DATA JPVTC/3,4,1,2/ DATA QYC/(0.E0,-5.81378E0),(-2.68328E0,0.E0), 1 (-1.89737E0,-1.58114E0),(1.58114E0,-3.79473E0)/ DATA QTYC/(0.E0,5.37587E0),(-3.47851E0,0.E0), 1 (4.02492E0,2.23607E0),(0.E0,-1.34164E0)/ DATA BC/(0.E0,-1.E0),(1.E0,0.E0),(1.E0,1.E0),(0.E0,1.E0)/ DATA RSDC/(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0)/ DATA XBC/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA KPROG/'QRDC QRSL'/ DATA KFAIL/'FACTOR QRAUX JPVT QY QTY SOLUTION RSD 1 XB INFO'/ C DELX(X1,X2) = ABS(REAL(X1-X2))+ABS(AIMAG(X1-X2)) C***FIRST EXECUTABLE STATEMENT CQRQC LDX = 5 N = 4 P = 4 K = 4 NERR = 0 C C FORM AT AND JPVTT C DO 20 J=1,N JPVTT(J) = JPVT(J) DO 10 I=1,N AT(I,J) = A(I,J) 10 CONTINUE 20 CONTINUE C C TEST CQRDC (FACTOR, QRAUX, JPVT) C JOB = 1 CALL CQRDC(AT,LDX,N,P,QRAUX,JPVTT,WORK,JOB) INDX(1) = 0 DO 40 J=1,N DO 30 I=1,N IF (DELX(AT(I,J),AC(I,J)) .GT. .0001) INDX(1) = INDX(1)+1 30 CONTINUE 40 CONTINUE C IF (INDX(1) .NE. 0) THEN WRITE (LUN, 501) KPROG(1:4),KFAIL(1:6) NERR = NERR + 1 ENDIF C DO 60 I=1,2 INDX(I) = 0 60 CONTINUE C DO 70 I=1,N IF (DELX(QRAUX(I),QRAUXC(I)) .GT. .0001) INDX(1) = INDX(1)+1 IF (JPVTT(I) .NE. JPVTC(I)) INDX(2) = INDX(2)+1 70 CONTINUE C DO 90 I=1,2 L = 7*I+1 IF (INDX(I) .NE. 0) THEN WRITE (LUN,501) KPROG(1:4),KFAIL(L:L+4) NERR = NERR + 1 ENDIF 90 CONTINUE C C TEST CQRSL (QY, QTY, SOLUTION, RSD, XB, INFO) C JOB = 11111 DO 100 I=1,5 INDX(I) = 0 100 CONTINUE C CALL CQRSL(AT,LDX,N,K,QRAUX,Y,QY,QTY,B,RSD,XB,JOB,INFO) DO 110 I=1,N IF (DELX(QY(I),QYC(I)) .GT. .0001) INDX(1) = INDX(1)+1 IF (DELX(QTY(I),QTYC(I)) .GT. .0001) INDX(2) = INDX(2)+1 IF (DELX(B(I),BC(I)) .GT. .0001) INDX(3) = INDX(3)+1 IF (DELX(RSD(I),RSDC(I)) .GT. .0001) INDX(4) = INDX(4)+1 IF (DELX(XB(I),XBC(I)) .GT. .0001) INDX(5) = INDX(5)+1 110 CONTINUE C DO 130 I=1,5 L = 10*I+11 IF (INDX(I) .NE. 0) THEN WRITE (LUN,501) KPROG(6:9),KFAIL(L:L+8) NERR = NERR + 1 ENDIF 130 CONTINUE C IF (INFO .NE. 0) THEN WRITE (LUN,501) KPROG(6:9),KFAIL(71:74) NERR = NERR + 1 ENDIF C IF (KPRINT.GE.2 .OR. NERR.NE.0) WRITE (LUN,500) NERR RETURN C 500 FORMAT(/' * CQRQC - TEST FOR CQRDC AND CQRSL FOUND ', I1, * ' ERRORS.'/) 501 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) END