website/archive/binaries/mac/src/disembl/Tisean_3.0.1/source_f/slatec/dqk15.f

   1 *DECK DQK15
   2       SUBROUTINE DQK15 (F, A, B, RESULT, ABSERR, RESABS, RESASC)
   3 C***BEGIN PROLOGUE  DQK15
   4 C***PURPOSE  To compute I = Integral of F over (A,B), with error
   5 C                           estimate
   6 C                       J = integral of ABS(F) over (A,B)
   7 C***LIBRARY   SLATEC (QUADPACK)
   8 C***CATEGORY  H2A1A2
   9 C***TYPE      DOUBLE PRECISION (QK15-S, DQK15-D)
  10 C***KEYWORDS  15-POINT GAUSS-KRONROD RULES, QUADPACK, QUADRATURE
  11 C***AUTHOR  Piessens, Robert
  12 C             Applied Mathematics and Programming Division
  13 C             K. U. Leuven
  14 C           de Doncker, Elise
  15 C             Applied Mathematics and Programming Division
  16 C             K. U. Leuven
  17 C***DESCRIPTION
  18 C
  19 C           Integration rules
  20 C           Standard fortran subroutine
  21 C           Double precision version
  22 C
  23 C           PARAMETERS
  24 C            ON ENTRY
  25 C              F      - Double precision
  26 C                       Function subprogram defining the integrand
  27 C                       FUNCTION F(X). The actual name for F needs to be
  28 C                       Declared E X T E R N A L in the calling program.
  29 C
  30 C              A      - Double precision
  31 C                       Lower limit of integration
  32 C
  33 C              B      - Double precision
  34 C                       Upper limit of integration
  35 C
  36 C            ON RETURN
  37 C              RESULT - Double precision
  38 C                       Approximation to the integral I
  39 C                       Result is computed by applying the 15-POINT
  40 C                       KRONROD RULE (RESK) obtained by optimal addition
  41 C                       of abscissae to the 7-POINT GAUSS RULE(RESG).
  42 C
  43 C              ABSERR - Double precision
  44 C                       Estimate of the modulus of the absolute error,
  45 C                       which should not exceed ABS(I-RESULT)
  46 C
  47 C              RESABS - Double precision
  48 C                       Approximation to the integral J
  49 C
  50 C              RESASC - Double precision
  51 C                       Approximation to the integral of ABS(F-I/(B-A))
  52 C                       over (A,B)
  53 C
  54 C***REFERENCES  (NONE)
  55 C***ROUTINES CALLED  D1MACH
  56 C***REVISION HISTORY  (YYMMDD)
  57 C   800101  DATE WRITTEN
  58 C   890531  Changed all specific intrinsics to generic.  (WRB)
  59 C   890531  REVISION DATE from Version 3.2
  60 C   891214  Prologue converted to Version 4.0 format.  (BAB)
  61 C***END PROLOGUE  DQK15
  62 C
  63       DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH,
  64      1  D1MACH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC,
  65      2  RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK
  66       INTEGER J,JTW,JTWM1
  67       EXTERNAL F
  68 C
  69       DIMENSION FV1(7),FV2(7),WG(4),WGK(8),XGK(8)
  70 C
  71 C           THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1).
  72 C           BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR
  73 C           CORRESPONDING WEIGHTS ARE GIVEN.
  74 C
  75 C           XGK    - ABSCISSAE OF THE 15-POINT KRONROD RULE
  76 C                    XGK(2), XGK(4), ...  ABSCISSAE OF THE 7-POINT
  77 C                    GAUSS RULE
  78 C                    XGK(1), XGK(3), ...  ABSCISSAE WHICH ARE OPTIMALLY
  79 C                    ADDED TO THE 7-POINT GAUSS RULE
  80 C
  81 C           WGK    - WEIGHTS OF THE 15-POINT KRONROD RULE
  82 C
  83 C           WG     - WEIGHTS OF THE 7-POINT GAUSS RULE
  84 C
  85 C
  86 C GAUSS QUADRATURE WEIGHTS AND KRONROD QUADRATURE ABSCISSAE AND WEIGHTS
  87 C AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON,
  88 C BELL LABS, NOV. 1981.
  89 C
  90       SAVE WG, XGK, WGK
  91       DATA WG  (  1) / 0.1294849661 6886969327 0611432679 082 D0 /
  92       DATA WG  (  2) / 0.2797053914 8927666790 1467771423 780 D0 /
  93       DATA WG  (  3) / 0.3818300505 0511894495 0369775488 975 D0 /
  94       DATA WG  (  4) / 0.4179591836 7346938775 5102040816 327 D0 /
  95 C
  96       DATA XGK (  1) / 0.9914553711 2081263920 6854697526 329 D0 /
  97       DATA XGK (  2) / 0.9491079123 4275852452 6189684047 851 D0 /
  98       DATA XGK (  3) / 0.8648644233 5976907278 9712788640 926 D0 /
  99       DATA XGK (  4) / 0.7415311855 9939443986 3864773280 788 D0 /
 100       DATA XGK (  5) / 0.5860872354 6769113029 4144838258 730 D0 /
 101       DATA XGK (  6) / 0.4058451513 7739716690 6606412076 961 D0 /
 102       DATA XGK (  7) / 0.2077849550 0789846760 0689403773 245 D0 /
 103       DATA XGK (  8) / 0.0000000000 0000000000 0000000000 000 D0 /
 104 C
 105       DATA WGK (  1) / 0.0229353220 1052922496 3732008058 970 D0 /
 106       DATA WGK (  2) / 0.0630920926 2997855329 0700663189 204 D0 /
 107       DATA WGK (  3) / 0.1047900103 2225018383 9876322541 518 D0 /
 108       DATA WGK (  4) / 0.1406532597 1552591874 5189590510 238 D0 /
 109       DATA WGK (  5) / 0.1690047266 3926790282 6583426598 550 D0 /
 110       DATA WGK (  6) / 0.1903505780 6478540991 3256402421 014 D0 /
 111       DATA WGK (  7) / 0.2044329400 7529889241 4161999234 649 D0 /
 112       DATA WGK (  8) / 0.2094821410 8472782801 2999174891 714 D0 /
 113 C
 114 C
 115 C           LIST OF MAJOR VARIABLES
 116 C           -----------------------
 117 C
 118 C           CENTR  - MID POINT OF THE INTERVAL
 119 C           HLGTH  - HALF-LENGTH OF THE INTERVAL
 120 C           ABSC   - ABSCISSA
 121 C           FVAL*  - FUNCTION VALUE
 122 C           RESG   - RESULT OF THE 7-POINT GAUSS FORMULA
 123 C           RESK   - RESULT OF THE 15-POINT KRONROD FORMULA
 124 C           RESKH  - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B),
 125 C                    I.E. TO I/(B-A)
 126 C
 127 C           MACHINE DEPENDENT CONSTANTS
 128 C           ---------------------------
 129 C
 130 C           EPMACH IS THE LARGEST RELATIVE SPACING.
 131 C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
 132 C
 133 C***FIRST EXECUTABLE STATEMENT  DQK15
 134       EPMACH = D1MACH(4)
 135       UFLOW = D1MACH(1)
 136 C
 137       CENTR = 0.5D+00*(A+B)
 138       HLGTH = 0.5D+00*(B-A)
 139       DHLGTH = ABS(HLGTH)
 140 C
 141 C           COMPUTE THE 15-POINT KRONROD APPROXIMATION TO
 142 C           THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR.
 143 C
 144       FC = F(CENTR)
 145       RESG = FC*WG(4)
 146       RESK = FC*WGK(8)
 147       RESABS = ABS(RESK)
 148       DO 10 J=1,3
 149         JTW = J*2
 150         ABSC = HLGTH*XGK(JTW)
 151         FVAL1 = F(CENTR-ABSC)
 152         FVAL2 = F(CENTR+ABSC)
 153         FV1(JTW) = FVAL1
 154         FV2(JTW) = FVAL2
 155         FSUM = FVAL1+FVAL2
 156         RESG = RESG+WG(J)*FSUM
 157         RESK = RESK+WGK(JTW)*FSUM
 158         RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2))
 159    10 CONTINUE
 160       DO 15 J = 1,4
 161         JTWM1 = J*2-1
 162         ABSC = HLGTH*XGK(JTWM1)
 163         FVAL1 = F(CENTR-ABSC)
 164         FVAL2 = F(CENTR+ABSC)
 165         FV1(JTWM1) = FVAL1
 166         FV2(JTWM1) = FVAL2
 167         FSUM = FVAL1+FVAL2
 168         RESK = RESK+WGK(JTWM1)*FSUM
 169         RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2))
 170    15 CONTINUE
 171       RESKH = RESK*0.5D+00
 172       RESASC = WGK(8)*ABS(FC-RESKH)
 173       DO 20 J=1,7
 174         RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH))
 175    20 CONTINUE
 176       RESULT = RESK*HLGTH
 177       RESABS = RESABS*DHLGTH
 178       RESASC = RESASC*DHLGTH
 179       ABSERR = ABS((RESK-RESG)*HLGTH)
 180       IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00)
 181      1  ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00)
 182       IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX
 183      1  ((EPMACH*0.5D+02)*RESABS,ABSERR)
 184       RETURN
 185       END