+++ /dev/null
-*DECK DQK15
- SUBROUTINE DQK15 (F, A, B, RESULT, ABSERR, RESABS, RESASC)
-C***BEGIN PROLOGUE DQK15
-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 (QK15-S, DQK15-D)
-C***KEYWORDS 15-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 15-POINT
-C KRONROD RULE (RESK) obtained by optimal addition
-C of abscissae to the 7-POINT GAUSS 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 DQK15
-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(7),FV2(7),WG(4),WGK(8),XGK(8)
-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 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 KRONROD RULE
-C
-C WG - WEIGHTS OF THE 7-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.1294849661 6886969327 0611432679 082 D0 /
- DATA WG ( 2) / 0.2797053914 8927666790 1467771423 780 D0 /
- DATA WG ( 3) / 0.3818300505 0511894495 0369775488 975 D0 /
- DATA WG ( 4) / 0.4179591836 7346938775 5102040816 327 D0 /
-C
- DATA XGK ( 1) / 0.9914553711 2081263920 6854697526 329 D0 /
- DATA XGK ( 2) / 0.9491079123 4275852452 6189684047 851 D0 /
- DATA XGK ( 3) / 0.8648644233 5976907278 9712788640 926 D0 /
- DATA XGK ( 4) / 0.7415311855 9939443986 3864773280 788 D0 /
- DATA XGK ( 5) / 0.5860872354 6769113029 4144838258 730 D0 /
- DATA XGK ( 6) / 0.4058451513 7739716690 6606412076 961 D0 /
- DATA XGK ( 7) / 0.2077849550 0789846760 0689403773 245 D0 /
- DATA XGK ( 8) / 0.0000000000 0000000000 0000000000 000 D0 /
-C
- DATA WGK ( 1) / 0.0229353220 1052922496 3732008058 970 D0 /
- DATA WGK ( 2) / 0.0630920926 2997855329 0700663189 204 D0 /
- DATA WGK ( 3) / 0.1047900103 2225018383 9876322541 518 D0 /
- DATA WGK ( 4) / 0.1406532597 1552591874 5189590510 238 D0 /
- DATA WGK ( 5) / 0.1690047266 3926790282 6583426598 550 D0 /
- DATA WGK ( 6) / 0.1903505780 6478540991 3256402421 014 D0 /
- DATA WGK ( 7) / 0.2044329400 7529889241 4161999234 649 D0 /
- DATA WGK ( 8) / 0.2094821410 8472782801 2999174891 714 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 7-POINT GAUSS FORMULA
-C RESK - RESULT OF THE 15-POINT KRONROD FORMULA
-C RESKH - APPROXIMATION TO THE MEAN VALUE OF F 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 DQK15
- 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 15-POINT KRONROD APPROXIMATION TO
-C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR.
-C
- FC = F(CENTR)
- RESG = FC*WG(4)
- RESK = FC*WGK(8)
- RESABS = ABS(RESK)
- DO 10 J=1,3
- 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,4
- 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(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.0D+00.AND.ABSERR.NE.0.0D+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
git://source.jalview.org / jabaws.git / blobdiff