relibc_openlibm/slatec/qk61.f

*DECK QK61
      SUBROUTINE QK61 (F, A, B, RESULT, ABSERR, RESABS, RESASC)
C***BEGIN PROLOGUE  QK61
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      SINGLE PRECISION (QK61-S, DQK61-D)
C***KEYWORDS  61-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 rule
C        Standard fortran subroutine
C        Real version
C
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 calling program.
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 61-point
C                    Kronrod rule (RESK) obtained by optimal addition of
C                    abscissae to the 30-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 J
C
C           RESASC - Real
C                    Approximation to the integral of ABS(F-I/(B-A))
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH
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  QK61
C
      REAL A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,F,FC,FSUM,FVAL1,FVAL2,
     1  FV1,FV2,HLGTH,RESABS,RESASC,RESG,RESK,RESKH,RESULT,R1MACH,UFLOW,
     2  WG,WGK,XGK
      INTEGER J,JTW,JTWM1
      EXTERNAL F
C
      DIMENSION FV1(30),FV2(30),XGK(31),WGK(31),WG(15)
C
C           THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE
C           INTERVAL (-1,1). BECAUSE OF SYMMETRY ONLY THE POSITIVE
C           ABSCISSAE AND THEIR CORRESPONDING WEIGHTS ARE GIVEN.
C
C           XGK   - ABSCISSAE OF THE 61-POINT KRONROD RULE
C                   XGK(2), XGK(4)  ... ABSCISSAE OF THE 30-POINT
C                   GAUSS RULE
C                   XGK(1), XGK(3)  ... OPTIMALLY ADDED ABSCISSAE
C                   TO THE 30-POINT GAUSS RULE
C
C           WGK   - WEIGHTS OF THE 61-POINT KRONROD RULE
C
C           WG    - WEIGHTS OF THE 30-POINT GAUSS RULE
C
      SAVE XGK, WGK, WG
      DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),XGK(8),
     1   XGK(9),XGK(10)/
     2     0.9994844100504906E+00,     0.9968934840746495E+00,
     3     0.9916309968704046E+00,     0.9836681232797472E+00,
     4     0.9731163225011263E+00,     0.9600218649683075E+00,
     5     0.9443744447485600E+00,     0.9262000474292743E+00,
     6     0.9055733076999078E+00,     0.8825605357920527E+00/
      DATA XGK(11),XGK(12),XGK(13),XGK(14),XGK(15),XGK(16),
     1  XGK(17),XGK(18),XGK(19),XGK(20)/
     2     0.8572052335460611E+00,     0.8295657623827684E+00,
     3     0.7997278358218391E+00,     0.7677774321048262E+00,
     4     0.7337900624532268E+00,     0.6978504947933158E+00,
     5     0.6600610641266270E+00,     0.6205261829892429E+00,
     6     0.5793452358263617E+00,     0.5366241481420199E+00/
      DATA XGK(21),XGK(22),XGK(23),XGK(24),
     1  XGK(25),XGK(26),XGK(27),XGK(28),XGK(29),XGK(30),XGK(31)/
     2     0.4924804678617786E+00,     0.4470337695380892E+00,
     3     0.4004012548303944E+00,     0.3527047255308781E+00,
     4     0.3040732022736251E+00,     0.2546369261678898E+00,
     5     0.2045251166823099E+00,     0.1538699136085835E+00,
     6     0.1028069379667370E+00,     0.5147184255531770E-01,
     7     0.0E+00                   /
      DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),WGK(8),
     1  WGK(9),WGK(10)/
     2     0.1389013698677008E-02,     0.3890461127099884E-02,
     3     0.6630703915931292E-02,     0.9273279659517763E-02,
     4     0.1182301525349634E-01,     0.1436972950704580E-01,
     5     0.1692088918905327E-01,     0.1941414119394238E-01,
     6     0.2182803582160919E-01,     0.2419116207808060E-01/
      DATA WGK(11),WGK(12),WGK(13),WGK(14),WGK(15),WGK(16),
     1  WGK(17),WGK(18),WGK(19),WGK(20)/
     2     0.2650995488233310E-01,     0.2875404876504129E-01,
     3     0.3090725756238776E-01,     0.3298144705748373E-01,
     4     0.3497933802806002E-01,     0.3688236465182123E-01,
     5     0.3867894562472759E-01,     0.4037453895153596E-01,
     6     0.4196981021516425E-01,     0.4345253970135607E-01/
      DATA WGK(21),WGK(22),WGK(23),WGK(24),
     1  WGK(25),WGK(26),WGK(27),WGK(28),WGK(29),WGK(30),WGK(31)/
     2     0.4481480013316266E-01,     0.4605923827100699E-01,
     3     0.4718554656929915E-01,     0.4818586175708713E-01,
     4     0.4905543455502978E-01,     0.4979568342707421E-01,
     5     0.5040592140278235E-01,     0.5088179589874961E-01,
     6     0.5122154784925877E-01,     0.5142612853745903E-01,
     7     0.5149472942945157E-01/
      DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/
     1     0.7968192496166606E-02,     0.1846646831109096E-01,
     2     0.2878470788332337E-01,     0.3879919256962705E-01,
     3     0.4840267283059405E-01,     0.5749315621761907E-01,
     4     0.6597422988218050E-01,     0.7375597473770521E-01/
      DATA WG(9),WG(10),WG(11),WG(12),WG(13),WG(14),WG(15)/
     1     0.8075589522942022E-01,     0.8689978720108298E-01,
     2     0.9212252223778613E-01,     0.9636873717464426E-01,
     3     0.9959342058679527E-01,     0.1017623897484055E+00,
     4     0.1028526528935588E+00/
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 30-POINT GAUSS RULE
C           RESK   - RESULT OF THE 61-POINT KRONROD RULE
C           RESKH  - APPROXIMATION TO THE MEAN VALUE OF F
C                    OVER (A,B), 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  QK61
      EPMACH = R1MACH(4)
      UFLOW = R1MACH(1)
C
      CENTR = 0.5E+00*(B+A)
      HLGTH = 0.5E+00*(B-A)
      DHLGTH = ABS(HLGTH)
C
C           COMPUTE THE 61-POINT KRONROD APPROXIMATION TO THE
C           INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR.
C
      RESG = 0.0E+00
      FC = F(CENTR)
      RESK = WGK(31)*FC
      RESABS = ABS(RESK)
      DO 10 J=1,15
        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,15
        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.5E+00
      RESASC = WGK(31)*ABS(FC-RESKH)
      DO 20 J=1,30
        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)
     1  ABSERR = RESASC*MIN(0.1E+01,
     2  (0.2E+03*ABSERR/RESASC)**1.5E+00)
      IF(RESABS.GT.UFLOW/(0.5E+02*EPMACH)) ABSERR = MAX
     1  ((EPMACH*0.5E+02)*RESABS,ABSERR)
      RETURN
      END