1*DECK CQRTST 2 SUBROUTINE CQRTST (LUN, KPRINT, IPASS) 3C***BEGIN PROLOGUE CQRTST 4C***PURPOSE Quick check for CPQR79. 5C***LIBRARY SLATEC 6C***TYPE COMPLEX (RQRTST-S, CQRTST-C) 7C***AUTHOR (UNKNOWN) 8C***ROUTINES CALLED CPQR79, NUMXER, PASS, R1MACH, XERCLR, XGETF, XSETF 9C***REVISION HISTORY (YYMMDD) 10C ?????? DATE WRITTEN 11C 891214 Prologue converted to Version 4.0 format. (BAB) 12C 901205 Changed usage of R1MACH(3) to R1MACH(4). (RWC) 13C 911010 Code reworked and simplified. (RWC and WRB) 14C***END PROLOGUE CQRTST 15 INTEGER ITEST(2), ITMP(7) 16 REAL WORK(144) 17 COMPLEX COEFF1(9), COEFF2(2), COEFF3(2), ROOT(8), CHK1(8), CHK2 18 LOGICAL FATAL 19C 20 DATA COEFF1 / (1.0,0.0), (-7.0,-2.0), (8.0,6.0), (28.0, 8.0), 21 * (-49.0,-24.0), (7.0,2.0), (-8.0,-6.0), 22 * (-28.0,-8.0), (48.0,24.0)/ 23 DATA COEFF2 / (1.0,1.0), (1.0,3.0) / 24 DATA COEFF3 / (0.0,0.0), (1.0,3.0) / 25 DATA CHK1 / (4.0,2.0), (3.0,0.0), (-2.0,0.0), (2.0,0.0), 26 * (0.0,-1.0), (-1.0,0.0), (0.0,1.0), (1.0,0.0) / 27 DATA CHK2 / (-2.0,-1.0) / 28C***FIRST EXECUTABLE STATEMENT CQRTST 29 IF (KPRINT .GE. 2) WRITE (LUN, 90000) 30 TOL = SQRT(R1MACH(4)) 31 IPASS = 1 32C 33C First test. 34C 35 CALL CPQR79 (8, COEFF1, ROOT, IERR, WORK) 36C 37C Check to see if test passed. 38C 39 DO 10 I=1,7 40 ITMP(I) = 0 41 10 CONTINUE 42C 43C Check for roots in any order. 44C 45 DO 30 I=1,7 46 DO 20 J=1,7 47 IF (ABS(ROOT(I)-CHK1(J)) .LE. TOL) THEN 48 ITMP(J) = 1 49 GOTO 30 50 ENDIF 51 20 CONTINUE 52 30 CONTINUE 53C 54C Check that we found all 7 roots. 55C 56 ITEST(1) = 1 57 DO 40 I=1,7 58 ITEST(1) = ITEST(1)*ITMP(I) 59 40 CONTINUE 60C 61C Print test results. 62C 63 IF (KPRINT.GE.3 .OR. (KPRINT.GE.2.AND.ITEST(1).EQ.0)) THEN 64 WRITE (LUN, 90010) 65 WRITE (LUN, 90020) (J,COEFF1(J), J=1,9) 66 WRITE (LUN, 90030) 67 WRITE (LUN, 90040) (J,ROOT(J), J=1,7) 68 ENDIF 69 IF (KPRINT .GE. 2) THEN 70 CALL PASS (LUN, 1, ITEST(1)) 71 ENDIF 72C 73C Set up next problem. 74C 75 CALL CPQR79 (1, COEFF2, ROOT, IERR, WORK) 76C 77C Check to see if test passed. 78C 79 ITEST(2) = 1 80 IF (ABS(ROOT(1)-CHK2) .GT. TOL) ITEST(2) = 0 81C 82C Print test results for second test. 83C 84 IF (KPRINT.GE.3 .OR. (KPRINT.GE.2.AND.ITEST(1).EQ.0)) THEN 85 WRITE (LUN, 90050) 86 WRITE (LUN, 90010) 87 WRITE (LUN, 90020) (J,COEFF2(J), J=1,2) 88 WRITE (LUN, 90030) 89 WRITE (LUN, 90040) (J,ROOT(J), J=1,1) 90 ENDIF 91 IF (KPRINT .GE. 2) THEN 92 CALL PASS (LUN, 2, ITEST(2)) 93 ENDIF 94C 95C Trigger 2 error conditions 96C 97 CALL XGETF (KONTRL) 98 IF (KPRINT .LE. 2) THEN 99 CALL XSETF (0) 100 ELSE 101 CALL XSETF (1) 102 ENDIF 103 FATAL = .FALSE. 104 CALL XERCLR 105 IF (KPRINT .GE. 3) WRITE (LUN, 90060) 106C 107C CALL CPQR79 with 0 degree polynomial. 108C 109 CALL CPQR79 (0, COEFF2, ROOT, IERR, WORK) 110 IF (NUMXER(NERR) .NE. 3) THEN 111 FATAL = .TRUE. 112 ENDIF 113 CALL XERCLR 114C 115C CALL CPQR79 with zero leading coefficient. 116C 117 CALL CPQR79 (2, COEFF3, ROOT, IERR, WORK) 118 IF (NUMXER(NERR) .NE. 2) THEN 119 FATAL = .TRUE. 120 ENDIF 121 CALL XERCLR 122C 123 CALL XSETF (KONTRL) 124 IF (FATAL) THEN 125 IPASS = 0 126 IF (KPRINT .GE. 2) THEN 127 WRITE (LUN, 90070) 128 ENDIF 129 ELSE 130 IF (KPRINT .GE. 3) THEN 131 WRITE (LUN, 90080) 132 ENDIF 133 ENDIF 134C 135C See if all tests passed. 136C 137 IPASS = IPASS*ITEST(1)*ITEST(2) 138C 139 IF (IPASS.EQ.1 .AND. KPRINT.GT.1) WRITE (LUN,90100) 140 IF (IPASS.EQ.0 .AND. KPRINT.NE.0) WRITE (LUN,90110) 141 RETURN 142C 14390000 FORMAT ('1', /,' CPQR79 QUICK CHECK') 14490010 FORMAT (/, ' CHECK REAL AND IMAGINARY PARTS OF ROOT' / 145 * ' COEFFICIENTS') 14690020 FORMAT (/ (I6, 3X, 1P, 2E22.14)) 14790030 FORMAT (// 25X, 'TABLE of ROOTS' // 148 * ' ROOT REAL PART', 12X, 'IMAG PART' / 149 * ' NUMBER', 8X, 2(' of ZERO ', 12X)) 15090040 FORMAT (I6, 3X, 1P, 2E22.14) 15190050 FORMAT (/, ' TEST SUBSEQUENT RELATED CALL') 15290060 FORMAT (// ' TRIGGER 2 ERROR CONDITIONS' //) 15390070 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 15490080 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 15590100 FORMAT (/' **************CPQR79 PASSED ALL TESTS**************') 15690110 FORMAT (/' **************CPQR79 FAILED SOME TESTS*************') 157 END 158