*DECK CQAGI SUBROUTINE CQAGI (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE CQAGI C***PURPOSE Quick check for QAGI. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (CQAGI-S, CDQAGI-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED CPRIN, QAGI, R1MACH, T0, T1, T2, T3, T4, T5 C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 891009 Removed unreferenced variables. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 901205 Added PASS/FAIL message and changed the name of the first C argument. (RWC) C 910501 Added PURPOSE and TYPE records. (WRB) C***END PROLOGUE CQAGI C C FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC C REAL ABSERR,BOUND,R1MACH,EPMACH,EPSABS, * EPSREL,ERROR,EXACT0,EXACT1,EXACT2,EXACT3,EXACT4, * OFLOW,RESULT,T0,T1,T2,T3,T4,T5,UFLOW,WORK INTEGER IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,LUN,NEVAL DIMENSION WORK(800),IWORK(200),IERV(4) EXTERNAL T0,T1,T2,T3,T4,T5 DATA EXACT0/2.0E+00/,EXACT1/0.115470066904E1/ DATA EXACT2/0.909864525656E-02/ DATA EXACT3/0.31415926535897932E+01/ DATA EXACT4/0.19984914554328673E+04/ C***FIRST EXECUTABLE STATEMENT CQAGI IF (KPRINT.GE.2) WRITE (LUN, '(''1QAGI QUICK CHECK''/)') C C TEST ON IER = 0 C IPASS = 1 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0E+00 EPMACH = R1MACH(4) EPSREL = MAX(SQRT(EPMACH),0.1E-07) BOUND = 0.0E+00 INF = 1 CALL QAGI(T0,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) ERROR = ABS(RESULT-EXACT0) IERV(1) = IER IP = 0 IF(IER.EQ.0.AND.ERROR.LE.ABSERR.AND.ABSERR.LE.EPSREL*ABS(EXACT0)) * IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 1 C CALL QAGI(T1,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * 1,4,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,1,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 2 OR 4 OR 1 C UFLOW = R1MACH(1) CALL QAGI(T2,BOUND,INF,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 IF(IER.EQ.2.OR.IER.EQ.4.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,3) C C TEST ON IER = 3 OR 4 OR 1 C CALL QAGI(T3,BOUND,INF,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 IF(IER.EQ.3.OR.IER.EQ.4.OR.IER.EQ.1) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,3) C C TEST ON IER = 4 OR 3 OR 1 C CALL QAGI(T4,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 3 IERV(3) = 1 IERV(4)=2 IP = 0 IF(IER.EQ.4.OR.IER.EQ.3.OR.IER.EQ.1.OR.IER.EQ.2) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,4,KPRINT,IP,EXACT4,RESULT,ABSERR,NEVAL,IERV,4) C C TEST ON IER = 5 C OFLOW = R1MACH(2) CALL QAGI(T5,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.5) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) C C TEST ON IER = 6 C CALL QAGI(T1,BOUND,INF,EPSABS,0.0E+00,RESULT,ABSERR,NEVAL,IER, * LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 IF(IER.EQ.6.AND.RESULT.EQ.0.0E+00.AND.ABSERR.EQ.0.0E+00.AND. * NEVAL.EQ.0.AND.LAST.EQ.0) IP = 1 IF(IP.EQ.0) IPASS = 0 CALL CPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) C IF (KPRINT.GE.1) THEN IF (IPASS.EQ.0) THEN WRITE(LUN, '(/'' SOME TEST(S) IN CQAGI FAILED''/)') ELSEIF (KPRINT.GE.2) THEN WRITE(LUN, '(/'' ALL TEST(S) IN CQAGI PASSED''/)') ENDIF ENDIF RETURN END