qk15w.f
182 lines
| 6.4 KiB
| text/x-fortran
|
FortranFixedLexer
| r1601 | SUBROUTINE QK15W(F,W,P1,P2,P3,P4,KP,A,B,RESULT,ABSERR, | |||
| * RESABS,RESASC) | ||||
| C***BEGIN PROLOGUE QK15W | ||||
| C***DATE WRITTEN 810101 (YYMMDD) | ||||
| C***REVISION DATE 830518 (MMDDYY) | ||||
| C***CATEGORY NO. H2A2A2 | ||||
| C***KEYWORDS 15-POINT GAUSS-KRONROD RULES | ||||
| C***AUTHOR PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN | ||||
| C DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN | ||||
| C***PURPOSE TO COMPUTE I = INTEGRAL OF F*W OVER (A,B), WITH ERROR | ||||
| C ESTIMATE | ||||
| C J = INTEGRAL OF ABS(F*W) OVER (A,B) | ||||
| C***DESCRIPTION | ||||
| C | ||||
| C INTEGRATION RULES | ||||
| C STANDARD FORTRAN SUBROUTINE | ||||
| C REAL VERSION | ||||
| C | ||||
| C PARAMETERS | ||||
| C ON ENTRY | ||||
| C F - REAL | ||||
| 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 DRIVER PROGRAM. | ||||
| C | ||||
| C W - REAL | ||||
| C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND | ||||
| C WEIGHT FUNCTION W(X). THE ACTUAL NAME FOR W | ||||
| C NEEDS TO BE DECLARED E X T E R N A L IN THE | ||||
| C CALLING PROGRAM. | ||||
| C | ||||
| C P1, P2, P3, P4 - REAL | ||||
| C PARAMETERS IN THE WEIGHT FUNCTION | ||||
| C | ||||
| C KP - INTEGER | ||||
| C KEY FOR INDICATING THE TYPE OF WEIGHT FUNCTION | ||||
| C | ||||
| C A - REAL | ||||
| C LOWER LIMIT OF INTEGRATION | ||||
| C | ||||
| C B - REAL | ||||
| C UPPER LIMIT OF INTEGRATION | ||||
| C | ||||
| C ON RETURN | ||||
| C RESULT - REAL | ||||
| C APPROXIMATION TO THE INTEGRAL I | ||||
| C RESULT IS COMPUTED BY APPLYING THE 15-POINT | ||||
| C KRONROD RULE (RESK) OBTAINED BY OPTIMAL ADDITION | ||||
| C OF ABSCISSAE TO THE 7-POINT GAUSS RULE (RESG). | ||||
| C | ||||
| C ABSERR - REAL | ||||
| C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, | ||||
| C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) | ||||
| C | ||||
| C RESABS - REAL | ||||
| C APPROXIMATION TO THE INTEGRAL OF ABS(F) | ||||
| C | ||||
| C RESASC - REAL | ||||
| C APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A)) | ||||
| C | ||||
| C***REFERENCES (NONE) | ||||
| C***ROUTINES CALLED R1MACH | ||||
| C***END PROLOGUE QK15W | ||||
| C | ||||
| REAL A,ABSC,ABSC1,ABSC2,ABSERR,B,CENTR,DHLGTH, | ||||
| * R1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2, | ||||
| * HLGTH,P1,P2,P3,P4,RESABS,RESASC,RESG,RESK,RESKH,RESULT,UFLOW, | ||||
| * W,WG,WGK,XGK | ||||
| INTEGER J,JTW,JTWM1,KP | ||||
| EXTERNAL F,W | ||||
| C | ||||
| DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(4) | ||||
| 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 15-POINT GAUSS-KRONROD RULE | ||||
| C XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT | ||||
| C GAUSS RULE | ||||
| C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY | ||||
| C ADDED TO THE 7-POINT GAUSS RULE | ||||
| C | ||||
| C WGK - WEIGHTS OF THE 15-POINT GAUSS-KRONROD RULE | ||||
| C | ||||
| C WG - WEIGHTS OF THE 7-POINT GAUSS RULE | ||||
| C | ||||
| DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7), | ||||
| * XGK(8)/ | ||||
| * 0.9914553711208126E+00, 0.9491079123427585E+00, | ||||
| * 0.8648644233597691E+00, 0.7415311855993944E+00, | ||||
| * 0.5860872354676911E+00, 0.4058451513773972E+00, | ||||
| * 0.2077849550078985E+00, 0.0000000000000000E+00/ | ||||
| C | ||||
| DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7), | ||||
| * WGK(8)/ | ||||
| * 0.2293532201052922E-01, 0.6309209262997855E-01, | ||||
| * 0.1047900103222502E+00, 0.1406532597155259E+00, | ||||
| * 0.1690047266392679E+00, 0.1903505780647854E+00, | ||||
| * 0.2044329400752989E+00, 0.2094821410847278E+00/ | ||||
| C | ||||
| DATA WG(1),WG(2),WG(3),WG(4)/ | ||||
| * 0.1294849661688697E+00, 0.2797053914892767E+00, | ||||
| * 0.3818300505051889E+00, 0.4179591836734694E+00/ | ||||
| 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 7-POINT GAUSS FORMULA | ||||
| C RESK - RESULT OF THE 15-POINT KRONROD FORMULA | ||||
| C RESKH - APPROXIMATION TO THE MEAN VALUE OF F*W OVER (A,B), | ||||
| C I.E. 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 QK15W | ||||
| EPMACH = R1MACH(4) | ||||
| UFLOW = R1MACH(1) | ||||
| C | ||||
| CENTR = 0.5E+00*(A+B) | ||||
| HLGTH = 0.5E+00*(B-A) | ||||
| DHLGTH = ABS(HLGTH) | ||||
| C | ||||
| C COMPUTE THE 15-POINT KRONROD APPROXIMATION TO THE | ||||
| C INTEGRAL, AND ESTIMATE THE ERROR. | ||||
| C | ||||
| FC = F(CENTR)*W(CENTR,P1,P2,P3,P4,KP) | ||||
| RESG = WG(4)*FC | ||||
| RESK = WGK(8)*FC | ||||
| RESABS = ABS(RESK) | ||||
| DO 10 J=1,3 | ||||
| JTW = J*2 | ||||
| ABSC = HLGTH*XGK(JTW) | ||||
| ABSC1 = CENTR-ABSC | ||||
| ABSC2 = CENTR+ABSC | ||||
| FVAL1 = F(ABSC1)*W(ABSC1,P1,P2,P3,P4,KP) | ||||
| FVAL2 = F(ABSC2)*W(ABSC2,P1,P2,P3,P4,KP) | ||||
| 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,4 | ||||
| JTWM1 = J*2-1 | ||||
| ABSC = HLGTH*XGK(JTWM1) | ||||
| ABSC1 = CENTR-ABSC | ||||
| ABSC2 = CENTR+ABSC | ||||
| FVAL1 = F(ABSC1)*W(ABSC1,P1,P2,P3,P4,KP) | ||||
| FVAL2 = F(ABSC2)*W(ABSC2,P1,P2,P3,P4,KP) | ||||
| 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.5E+00 | ||||
| RESASC = WGK(8)*ABS(FC-RESKH) | ||||
| DO 20 J=1,7 | ||||
| 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.0E+00.AND.ABSERR.NE.0.0E+00) | ||||
| * ABSERR = RESASC*AMIN1(0.1E+01, | ||||
| * (0.2E+03*ABSERR/RESASC)**1.5E+00) | ||||
| IF(RESABS.GT.UFLOW/(0.5E+02*EPMACH)) ABSERR = AMAX1((EPMACH* | ||||
| * 0.5E+02)*RESABS,ABSERR) | ||||
| RETURN | ||||
| END | ||||
