1*DECK CDQAWO 2 SUBROUTINE CDQAWO (LUN, KPRINT, IPASS) 3C***BEGIN PROLOGUE CDQAWO 4C***PURPOSE Quick check for DQAWO. 5C***LIBRARY SLATEC 6C***TYPE DOUBLE PRECISION (CQAWO-S, CDQAWO-D) 7C***AUTHOR (UNKNOWN) 8C***ROUTINES CALLED D1MACH, DF0O, DF1O, DF2O, DPRIN, DQAWO 9C***REVISION HISTORY (YYMMDD) 10C ?????? DATE WRITTEN 11C 891214 Prologue converted to Version 4.0 format. (BAB) 12C 901205 Added PASS/FAIL message and changed the name of the first 13C argument. (RWC) 14C 910501 Added PURPOSE and TYPE records. (WRB) 15C***END PROLOGUE CDQAWO 16C 17C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC 18C 19 DOUBLE PRECISION A,ABSERR,B,EPMACH,EPSABS, 20 * EPSREL,ERROR,EXACT0,DF0O,DF1O,DF2O, 21 * OFLOW,OMEGA,PI,RESULT,D1MACH,UFLOW,WORK 22 INTEGER IER,IERV,INTEGR,IP,IPASS,IWORK,KPRINT,LAST,LENW,LUN, 23 * MAXP1,NEVAL 24 DIMENSION WORK(1325),IWORK(400),IERV(4) 25 EXTERNAL DF0O,DF1O,DF2O 26 DATA EXACT0/0.1042872789432789D+05/ 27 DATA PI/0.31415926535897932D+01/ 28C***FIRST EXECUTABLE STATEMENT CDQAWO 29 IF (KPRINT.GE.2) WRITE (LUN, '(''1DQAWO QUICK CHECK''/)') 30C 31C TEST ON IER = 0 32C 33 IPASS = 1 34 MAXP1 = 21 35 LENIW = 400 36 LENW = LENIW*2+MAXP1*25 37 EPSABS = 0.0D+00 38 EPMACH = D1MACH(4) 39 EPSREL = MAX(SQRT(EPMACH),0.1D-07) 40 A = 0.0D+00 41 B = PI 42 OMEGA = 0.1D+01 43 INTEGR = 2 44 CALL DQAWO(DF0O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, 45 * NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) 46 IERV(1) = IER 47 IP = 0 48 ERROR = ABS(EXACT0-RESULT) 49 IF(IER.EQ.0.AND.ERROR.LE.ABSERR.AND.ABSERR.LE.EPSREL*ABS(EXACT0)) 50 * IP = 1 51 IF(IP.EQ.0) IPASS = 0 52 CALL DPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) 53C 54C TEST ON IER = 1 55C 56 LENIW = 2 57 LENW = LENIW*2+MAXP1*25 58 CALL DQAWO(DF0O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, 59 * NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) 60 IERV(1) = IER 61 IP = 0 62 IF(IER.EQ.1) IP = 1 63 IF(IP.EQ.0) IPASS = 0 64 CALL DPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) 65C 66C TEST ON IER = 2 OR 4 OR 1 67C 68 UFLOW = D1MACH(1) 69 LENIW = 400 70 LENW = LENIW*2+MAXP1*25 71 CALL DQAWO(DF0O,A,B,OMEGA,INTEGR,UFLOW,0.0D+00,RESULT,ABSERR, 72 * NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) 73 IERV(1) = IER 74 IERV(2) = 4 75 IERV(3) = 1 76 IP = 0 77 IF(IER.EQ.2.OR.IER.EQ.4.OR.IER.EQ.1) IP = 1 78 IF(IP.EQ.0) IPASS = 0 79 CALL DPRIN(LUN,2,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,3) 80C 81C TEST ON IER = 3 OR 4 OR 1 OR 2 82C 83 B = 0.5D+01 84 OMEGA = 0.0D+00 85 INTEGR = 1 86 CALL DQAWO(DF1O,A,B,OMEGA,INTEGR,UFLOW,0.0D+00,RESULT,ABSERR, 87 * NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) 88 IERV(1) = IER 89 IERV(2) = 4 90 IERV(3) = 1 91 IERV(4) = 2 92 IP = 0 93 IF(IER.EQ.3.OR.IER.EQ.4.OR.IER.EQ.1.OR.IER.EQ.2) IP = 1 94 IF(IP.EQ.0) IPASS = 0 95 CALL DPRIN(LUN,3,KPRINT,IP,PI,RESULT,ABSERR,NEVAL,IERV,4) 96C 97C TEST ON IER = 5 98C 99 B = 0.1D+01 100 OFLOW = D1MACH(2) 101 CALL DQAWO(DF2O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, 102 * NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) 103 IERV(1) = IER 104 IP = 0 105 IF(IER.EQ.5) IP = 1 106 IF(IP.EQ.0) IPASS = 0 107 CALL DPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) 108C 109C TEST ON IER = 6 110C 111 INTEGR = 3 112 CALL DQAWO(DF0O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, 113 * NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) 114 IERV(1) = IER 115 IP = 0 116 IF(IER.EQ.6.AND.RESULT.EQ.0.0D+00.AND.ABSERR.EQ.0.0D+00.AND. 117 * NEVAL.EQ.0.AND.LAST.EQ.0) IP = 1 118 IF(IP.EQ.0) IPASS = 0 119 CALL DPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) 120C 121 IF (KPRINT.GE.1) THEN 122 IF (IPASS.EQ.0) THEN 123 WRITE(LUN, '(/'' SOME TEST(S) IN CDQAWO FAILED''/)') 124 ELSEIF (KPRINT.GE.2) THEN 125 WRITE(LUN, '(/'' ALL TEST(S) IN CDQAWO PASSED''/)') 126 ENDIF 127 ENDIF 128 RETURN 129 END 130