*DECK DQK41 SUBROUTINE DQK41 (F, A, B, RESULT, ABSERR, RESABS, RESASC) C***BEGIN PROLOGUE DQK41 C***PURPOSE To compute I = Integral of F over (A,B), with error C estimate C J = Integral of ABS(F) over (A,B) C***LIBRARY SLATEC (QUADPACK) C***CATEGORY H2A1A2 C***TYPE DOUBLE PRECISION (QK41-S, DQK41-D) C***KEYWORDS 41-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE C***AUTHOR Piessens, Robert C Applied Mathematics and Programming Division C K. U. Leuven C de Doncker, Elise C Applied Mathematics and Programming Division C K. U. Leuven C***DESCRIPTION C C Integration rules C Standard fortran subroutine C Double precision version C C PARAMETERS C ON ENTRY C F - Double precision C Function subprogram defining the integrand C FUNCTION F(X). The actual name for F needs to be C declared E X T E R N A L in the calling program. C C A - Double precision C Lower limit of integration C C B - Double precision C Upper limit of integration C C ON RETURN C RESULT - Double precision C Approximation to the integral I C RESULT is computed by applying the 41-POINT C GAUSS-KRONROD RULE (RESK) obtained by optimal C addition of abscissae to the 20-POINT GAUSS C RULE (RESG). C C ABSERR - Double precision C Estimate of the modulus of the absolute error, C which should not exceed ABS(I-RESULT) C C RESABS - Double precision C Approximation to the integral J C C RESASC - Double precision C Approximation to the integral of ABS(F-I/(B-A)) C over (A,B) C C***REFERENCES (NONE) C***ROUTINES CALLED D1MACH C***REVISION HISTORY (YYMMDD) C 800101 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DQK41 C DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH, 1 D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC, 2 RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK INTEGER J,JTW,JTWM1 EXTERNAL F C DIMENSION FV1(20),FV2(20),XGK(21),WGK(21),WG(10) C C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR C CORRESPONDING WEIGHTS ARE GIVEN. C C XGK - ABSCISSAE OF THE 41-POINT GAUSS-KRONROD RULE C XGK(2), XGK(4), ... ABSCISSAE OF THE 20-POINT C GAUSS RULE C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY C ADDED TO THE 20-POINT GAUSS RULE C C WGK - WEIGHTS OF THE 41-POINT GAUSS-KRONROD RULE C C WG - WEIGHTS OF THE 20-POINT GAUSS RULE C C C GAUSS QUADRATURE WEIGHTS AND KRONROD QUADRATURE ABSCISSAE AND WEIGHTS C AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON, C BELL LABS, NOV. 1981. C SAVE WG, XGK, WGK DATA WG ( 1) / 0.0176140071 3915211831 1861962351 853 D0 / DATA WG ( 2) / 0.0406014298 0038694133 1039952274 932 D0 / DATA WG ( 3) / 0.0626720483 3410906356 9506535187 042 D0 / DATA WG ( 4) / 0.0832767415 7670474872 4758143222 046 D0 / DATA WG ( 5) / 0.1019301198 1724043503 6750135480 350 D0 / DATA WG ( 6) / 0.1181945319 6151841731 2377377711 382 D0 / DATA WG ( 7) / 0.1316886384 4917662689 8494499748 163 D0 / DATA WG ( 8) / 0.1420961093 1838205132 9298325067 165 D0 / DATA WG ( 9) / 0.1491729864 7260374678 7828737001 969 D0 / DATA WG ( 10) / 0.1527533871 3072585069 8084331955 098 D0 / C DATA XGK ( 1) / 0.9988590315 8827766383 8315576545 863 D0 / DATA XGK ( 2) / 0.9931285991 8509492478 6122388471 320 D0 / DATA XGK ( 3) / 0.9815078774 5025025919 3342994720 217 D0 / DATA XGK ( 4) / 0.9639719272 7791379126 7666131197 277 D0 / DATA XGK ( 5) / 0.9408226338 3175475351 9982722212 443 D0 / DATA XGK ( 6) / 0.9122344282 5132590586 7752441203 298 D0 / DATA XGK ( 7) / 0.8782768112 5228197607 7442995113 078 D0 / DATA XGK ( 8) / 0.8391169718 2221882339 4529061701 521 D0 / DATA XGK ( 9) / 0.7950414288 3755119835 0638833272 788 D0 / DATA XGK ( 10) / 0.7463319064 6015079261 4305070355 642 D0 / DATA XGK ( 11) / 0.6932376563 3475138480 5490711845 932 D0 / DATA XGK ( 12) / 0.6360536807 2651502545 2836696226 286 D0 / DATA XGK ( 13) / 0.5751404468 1971031534 2946036586 425 D0 / DATA XGK ( 14) / 0.5108670019 5082709800 4364050955 251 D0 / DATA XGK ( 15) / 0.4435931752 3872510319 9992213492 640 D0 / DATA XGK ( 16) / 0.3737060887 1541956067 2548177024 927 D0 / DATA XGK ( 17) / 0.3016278681 1491300432 0555356858 592 D0 / DATA XGK ( 18) / 0.2277858511 4164507808 0496195368 575 D0 / DATA XGK ( 19) / 0.1526054652 4092267550 5220241022 678 D0 / DATA XGK ( 20) / 0.0765265211 3349733375 4640409398 838 D0 / DATA XGK ( 21) / 0.0000000000 0000000000 0000000000 000 D0 / C DATA WGK ( 1) / 0.0030735837 1852053150 1218293246 031 D0 / DATA WGK ( 2) / 0.0086002698 5564294219 8661787950 102 D0 / DATA WGK ( 3) / 0.0146261692 5697125298 3787960308 868 D0 / DATA WGK ( 4) / 0.0203883734 6126652359 8010231432 755 D0 / DATA WGK ( 5) / 0.0258821336 0495115883 4505067096 153 D0 / DATA WGK ( 6) / 0.0312873067 7703279895 8543119323 801 D0 / DATA WGK ( 7) / 0.0366001697 5820079803 0557240707 211 D0 / DATA WGK ( 8) / 0.0416688733 2797368626 3788305936 895 D0 / DATA WGK ( 9) / 0.0464348218 6749767472 0231880926 108 D0 / DATA WGK ( 10) / 0.0509445739 2372869193 2707670050 345 D0 / DATA WGK ( 11) / 0.0551951053 4828599474 4832372419 777 D0 / DATA WGK ( 12) / 0.0591114008 8063957237 4967220648 594 D0 / DATA WGK ( 13) / 0.0626532375 5478116802 5870122174 255 D0 / DATA WGK ( 14) / 0.0658345971 3361842211 1563556969 398 D0 / DATA WGK ( 15) / 0.0686486729 2852161934 5623411885 368 D0 / DATA WGK ( 16) / 0.0710544235 5344406830 5790361723 210 D0 / DATA WGK ( 17) / 0.0730306903 3278666749 5189417658 913 D0 / DATA WGK ( 18) / 0.0745828754 0049918898 6581418362 488 D0 / DATA WGK ( 19) / 0.0757044976 8455667465 9542775376 617 D0 / DATA WGK ( 20) / 0.0763778676 7208073670 5502835038 061 D0 / DATA WGK ( 21) / 0.0766007119 1799965644 5049901530 102 D0 / C C C LIST OF MAJOR VARIABLES C ----------------------- C C CENTR - MID POINT OF THE INTERVAL C HLGTH - HALF-LENGTH OF THE INTERVAL C ABSC - ABSCISSA C FVAL* - FUNCTION VALUE C RESG - RESULT OF THE 20-POINT GAUSS FORMULA C RESK - RESULT OF THE 41-POINT KRONROD FORMULA C RESKH - APPROXIMATION TO MEAN VALUE OF F OVER (A,B), I.E. C TO I/(B-A) C C MACHINE DEPENDENT CONSTANTS C --------------------------- C C EPMACH IS THE LARGEST RELATIVE SPACING. C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. C C***FIRST EXECUTABLE STATEMENT DQK41 EPMACH = D1MACH(4) UFLOW = D1MACH(1) C CENTR = 0.5D+00*(A+B) HLGTH = 0.5D+00*(B-A) DHLGTH = ABS(HLGTH) C C COMPUTE THE 41-POINT GAUSS-KRONROD APPROXIMATION TO C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. C RESG = 0.0D+00 FC = F(CENTR) RESK = WGK(21)*FC RESABS = ABS(RESK) DO 10 J=1,10 JTW = J*2 ABSC = HLGTH*XGK(JTW) FVAL1 = F(CENTR-ABSC) FVAL2 = F(CENTR+ABSC) FV1(JTW) = FVAL1 FV2(JTW) = FVAL2 FSUM = FVAL1+FVAL2 RESG = RESG+WG(J)*FSUM RESK = RESK+WGK(JTW)*FSUM RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2)) 10 CONTINUE DO 15 J = 1,10 JTWM1 = J*2-1 ABSC = HLGTH*XGK(JTWM1) FVAL1 = F(CENTR-ABSC) FVAL2 = F(CENTR+ABSC) FV1(JTWM1) = FVAL1 FV2(JTWM1) = FVAL2 FSUM = FVAL1+FVAL2 RESK = RESK+WGK(JTWM1)*FSUM RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2)) 15 CONTINUE RESKH = RESK*0.5D+00 RESASC = WGK(21)*ABS(FC-RESKH) DO 20 J=1,20 RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH)) 20 CONTINUE RESULT = RESK*HLGTH RESABS = RESABS*DHLGTH RESASC = RESASC*DHLGTH ABSERR = ABS((RESK-RESG)*HLGTH) IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.D+00) 1 ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00) IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX 1 ((EPMACH*0.5D+02)*RESABS,ABSERR) RETURN END