|
|
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
|
|
|
|
