src/numerical/slatec/fortran/dqk15w.f

   1 *DECK DQK15W
   2       SUBROUTINE DQK15W (F, W, P1, P2, P3, P4, KP, A, B, RESULT, ABSERR,
   3      +   RESABS, RESASC)
   4 C***BEGIN PROLOGUE  DQK15W
   5 C***PURPOSE  To compute I = Integral of F*W over (A,B), with error
   6 C                           estimate
   7 C                       J = Integral of ABS(F*W) over (A,B)
   8 C***LIBRARY   SLATEC (QUADPACK)
   9 C***CATEGORY  H2A2A2
  10 C***TYPE      DOUBLE PRECISION (QK15W-S, DQK15W-D)
  11 C***KEYWORDS  15-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE
  12 C***AUTHOR  Piessens, Robert
  13 C             Applied Mathematics and Programming Division
  14 C             K. U. Leuven
  15 C           de Doncker, Elise
  16 C             Applied Mathematics and Programming Division
  17 C             K. U. Leuven
  18 C***DESCRIPTION
  19 C
  20 C           Integration rules
  21 C           Standard fortran subroutine
  22 C           Double precision version
  23 C
  24 C           PARAMETERS
  25 C             ON ENTRY
  26 C              F      - Double precision
  27 C                       Function subprogram defining the integrand
  28 C                       function F(X). The actual name for F needs to be
  29 C                       declared E X T E R N A L in the driver program.
  30 C
  31 C              W      - Double precision
  32 C                       Function subprogram defining the integrand
  33 C                       WEIGHT function W(X). The actual name for W
  34 C                       needs to be declared E X T E R N A L in the
  35 C                       calling program.
  36 C
  37 C              P1, P2, P3, P4 - Double precision
  38 C                       Parameters in the WEIGHT function
  39 C
  40 C              KP     - Integer
  41 C                       Key for indicating the type of WEIGHT function
  42 C
  43 C              A      - Double precision
  44 C                       Lower limit of integration
  45 C
  46 C              B      - Double precision
  47 C                       Upper limit of integration
  48 C
  49 C            ON RETURN
  50 C              RESULT - Double precision
  51 C                       Approximation to the integral I
  52 C                       RESULT is computed by applying the 15-point
  53 C                       Kronrod rule (RESK) obtained by optimal addition
  54 C                       of abscissae to the 7-point Gauss rule (RESG).
  55 C
  56 C              ABSERR - Double precision
  57 C                       Estimate of the modulus of the absolute error,
  58 C                       which should equal or exceed ABS(I-RESULT)
  59 C
  60 C              RESABS - Double precision
  61 C                       Approximation to the integral of ABS(F)
  62 C
  63 C              RESASC - Double precision
  64 C                       Approximation to the integral of ABS(F-I/(B-A))
  65 C
  66 C***REFERENCES  (NONE)
  67 C***ROUTINES CALLED  D1MACH
  68 C***REVISION HISTORY  (YYMMDD)
  69 C   810101  DATE WRITTEN
  70 C   890531  Changed all specific intrinsics to generic.  (WRB)
  71 C   890531  REVISION DATE from Version 3.2
  72 C   891214  Prologue converted to Version 4.0 format.  (BAB)
  73 C***END PROLOGUE  DQK15W
  74 C
  75       DOUBLE PRECISION A,ABSC,ABSC1,ABSC2,ABSERR,B,CENTR,DHLGTH,
  76      1  D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,
  77      2  P1,P2,P3,P4,RESABS,RESASC,RESG,RESK,RESKH,RESULT,UFLOW,W,WG,WGK,
  78      3  XGK
  79       INTEGER J,JTW,JTWM1,KP
  80       EXTERNAL F, W
  81 C
  82       DIMENSION FV1(7),FV2(7),XGK(8),WGK(8),WG(4)
  83 C
  84 C           THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1).
  85 C           BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR
  86 C           CORRESPONDING WEIGHTS ARE GIVEN.
  87 C
  88 C           XGK    - ABSCISSAE OF THE 15-POINT GAUSS-KRONROD RULE
  89 C                    XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT
  90 C                    GAUSS RULE
  91 C                    XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY
  92 C                    ADDED TO THE 7-POINT GAUSS RULE
  93 C
  94 C           WGK    - WEIGHTS OF THE 15-POINT GAUSS-KRONROD RULE
  95 C
  96 C           WG     - WEIGHTS OF THE 7-POINT GAUSS RULE
  97 C
  98       SAVE XGK, WGK, WG
  99       DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8)/
 100      1     0.9914553711208126D+00,     0.9491079123427585D+00,
 101      2     0.8648644233597691D+00,     0.7415311855993944D+00,
 102      3     0.5860872354676911D+00,     0.4058451513773972D+00,
 103      4     0.2077849550078985D+00,     0.0000000000000000D+00/
 104 C
 105       DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8)/
 106      1     0.2293532201052922D-01,     0.6309209262997855D-01,
 107      2     0.1047900103222502D+00,     0.1406532597155259D+00,
 108      3     0.1690047266392679D+00,     0.1903505780647854D+00,
 109      4     0.2044329400752989D+00,     0.2094821410847278D+00/
 110 C
 111       DATA WG(1),WG(2),WG(3),WG(4)/
 112      1     0.1294849661688697D+00,    0.2797053914892767D+00,
 113      2     0.3818300505051889D+00,    0.4179591836734694D+00/
 114 C
 115 C
 116 C           LIST OF MAJOR VARIABLES
 117 C           -----------------------
 118 C
 119 C           CENTR  - MID POINT OF THE INTERVAL
 120 C           HLGTH  - HALF-LENGTH OF THE INTERVAL
 121 C           ABSC*  - ABSCISSA
 122 C           FVAL*  - FUNCTION VALUE
 123 C           RESG   - RESULT OF THE 7-POINT GAUSS FORMULA
 124 C           RESK   - RESULT OF THE 15-POINT KRONROD FORMULA
 125 C           RESKH  - APPROXIMATION TO THE MEAN VALUE OF F*W OVER (A,B),
 126 C                    I.E. TO I/(B-A)
 127 C
 128 C           MACHINE DEPENDENT CONSTANTS
 129 C           ---------------------------
 130 C
 131 C           EPMACH IS THE LARGEST RELATIVE SPACING.
 132 C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
 133 C
 134 C***FIRST EXECUTABLE STATEMENT  DQK15W
 135       EPMACH = D1MACH(4)
 136       UFLOW = D1MACH(1)
 137 C
 138       CENTR = 0.5D+00*(A+B)
 139       HLGTH = 0.5D+00*(B-A)
 140       DHLGTH = ABS(HLGTH)
 141 C
 142 C           COMPUTE THE 15-POINT KRONROD APPROXIMATION TO THE
 143 C           INTEGRAL, AND ESTIMATE THE ERROR.
 144 C
 145       FC = F(CENTR)*W(CENTR,P1,P2,P3,P4,KP)
 146       RESG = WG(4)*FC
 147       RESK = WGK(8)*FC
 148       RESABS = ABS(RESK)
 149       DO 10 J=1,3
 150         JTW = J*2
 151         ABSC = HLGTH*XGK(JTW)
 152         ABSC1 = CENTR-ABSC
 153         ABSC2 = CENTR+ABSC
 154         FVAL1 = F(ABSC1)*W(ABSC1,P1,P2,P3,P4,KP)
 155         FVAL2 = F(ABSC2)*W(ABSC2,P1,P2,P3,P4,KP)
 156         FV1(JTW) = FVAL1
 157         FV2(JTW) = FVAL2
 158         FSUM = FVAL1+FVAL2
 159         RESG = RESG+WG(J)*FSUM
 160         RESK = RESK+WGK(JTW)*FSUM
 161         RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2))
 162    10 CONTINUE
 163       DO 15 J=1,4
 164         JTWM1 = J*2-1
 165         ABSC = HLGTH*XGK(JTWM1)
 166         ABSC1 = CENTR-ABSC
 167         ABSC2 = CENTR+ABSC
 168         FVAL1 = F(ABSC1)*W(ABSC1,P1,P2,P3,P4,KP)
 169         FVAL2 = F(ABSC2)*W(ABSC2,P1,P2,P3,P4,KP)
 170         FV1(JTWM1) = FVAL1
 171         FV2(JTWM1) = FVAL2
 172         FSUM = FVAL1+FVAL2
 173         RESK = RESK+WGK(JTWM1)*FSUM
 174         RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2))
 175    15 CONTINUE
 176       RESKH = RESK*0.5D+00
 177       RESASC = WGK(8)*ABS(FC-RESKH)
 178       DO 20 J=1,7
 179         RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH))
 180    20 CONTINUE
 181       RESULT = RESK*HLGTH
 182       RESABS = RESABS*DHLGTH
 183       RESASC = RESASC*DHLGTH
 184       ABSERR = ABS((RESK-RESG)*HLGTH)
 185       IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00)
 186      1  ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00)
 187       IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX((EPMACH*
 188      1  0.5D+02)*RESABS,ABSERR)
 189       RETURN
 190       END