dqk21.f

Go to the documentation of this file.

      SUBROUTINE dqk21(F,A,B,RESULT,ABSERR,RESABS,RESASC,IERR)
C***BEGIN PROLOGUE  DQK21
C***DATE WRITTEN   800101   (YYMMDD)
C***REVISION DATE  830518   (YYMMDD)
C***CATEGORY NO.  H2A1A2
C***KEYWORDS  21-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 OVER (A,B), WITH ERROR
C                           ESTIMATE
C                       J = INTEGRAL OF ABS(F) OVER (A,B)
C***DESCRIPTION
C
C           INTEGRATION RULES
C           STANDARD FORTRAN SUBROUTINE
C           DOUBLE PRECISION VERSION
C
C           PARAMETERS
C            ON ENTRY
C              F      - SUBROUTINE F(X,IERR,RESULT) 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              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 21-POINT
C                       KRONROD RULE (RESK) OBTAINED BY OPTIMAL ADDITION
C                       OF ABSCISSAE TO THE 10-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***END PROLOGUE  DQK21
C
      DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DABS,DHLGTH,DMAX1,DMIN1,
     *  d1mach,epmach,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs,resasc,
     *  resg,resk,reskh,result,uflow,wg,wgk,xgk
      INTEGER J,JTW,JTWM1
      EXTERNAL f
C
      dimension fv1(10),fv2(10),wg(5),wgk(11),xgk(11)
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 21-POINT KRONROD RULE
C                    XGK(2), XGK(4), ...  ABSCISSAE OF THE 10-POINT
C                    GAUSS RULE
C                    XGK(1), XGK(3), ...  ABSCISSAE WHICH ARE OPTIMALLY
C                    ADDED TO THE 10-POINT GAUSS RULE
C
C           WGK    - WEIGHTS OF THE 21-POINT KRONROD RULE
C
C           WG     - WEIGHTS OF THE 10-POINT GAUSS RULE
C
C
C GAUSS QUADRATURE WEIGHTS AND KRONRON QUADRATURE ABSCISSAE AND WEIGHTS
C AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON,
C BELL LABS, NOV. 1981.
C
      DATA wg(  1) / 0.0666713443 0868813759 3568809893 332 d0 /
      DATA wg(  2) / 0.1494513491 5058059314 5776339657 697 d0 /
      DATA wg(  3) / 0.2190863625 1598204399 5534934228 163 d0 /
      DATA wg(  4) / 0.2692667193 0999635509 1226921569 469 d0 /
      DATA wg(  5) / 0.2955242247 1475287017 3892994651 338 d0 /
C
      DATA xgk(  1) / 0.9956571630 2580808073 5527280689 003 d0 /
      DATA xgk(  2) / 0.9739065285 1717172007 7964012084 452 d0 /
      DATA xgk(  3) / 0.9301574913 5570822600 1207180059 508 d0 /
      DATA xgk(  4) / 0.8650633666 8898451073 2096688423 493 d0 /
      DATA xgk(  5) / 0.7808177265 8641689706 3717578345 042 d0 /
      DATA xgk(  6) / 0.6794095682 9902440623 4327365114 874 d0 /
      DATA xgk(  7) / 0.5627571346 6860468333 9000099272 694 d0 /
      DATA xgk(  8) / 0.4333953941 2924719079 9265943165 784 d0 /
      DATA xgk(  9) / 0.2943928627 0146019813 1126603103 866 d0 /
      DATA xgk( 10) / 0.1488743389 8163121088 4826001129 720 d0 /
      DATA xgk( 11) / 0.0000000000 0000000000 0000000000 000 d0 /
C
      DATA wgk(  1) / 0.0116946388 6737187427 8064396062 192 d0 /
      DATA wgk(  2) / 0.0325581623 0796472747 8818972459 390 d0 /
      DATA wgk(  3) / 0.0547558965 7435199603 1381300244 580 d0 /
      DATA wgk(  4) / 0.0750396748 1091995276 7043140916 190 d0 /
      DATA wgk(  5) / 0.0931254545 8369760553 5065465083 366 d0 /
      DATA wgk(  6) / 0.1093871588 0229764189 9210590325 805 d0 /
      DATA wgk(  7) / 0.1234919762 6206585107 7958109831 074 d0 /
      DATA wgk(  8) / 0.1347092173 1147332592 8054001771 707 d0 /
      DATA wgk(  9) / 0.1427759385 7706008079 7094273138 717 d0 /
      DATA wgk( 10) / 0.1477391049 0133849137 4841515972 068 d0 /
      DATA wgk( 11) / 0.1494455540 0291690566 4936468389 821 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 10-POINT GAUSS FORMULA
C           RESK   - RESULT OF THE 21-POINT KRONROD FORMULA
C           RESKH  - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B),
C                    I.E. TO I/(B-A)
C
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  DQK21
      epmach = d1mach(4)
      uflow = d1mach(1)
C
      centr = 0.5d+00*(a+b)
      hlgth = 0.5d+00*(b-a)
      dhlgth = dabs(hlgth)
C
C           COMPUTE THE 21-POINT KRONROD APPROXIMATION TO
C           THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR.
C
      resg = 0.0d+00
      ierr = 0
      CALL f(centr,ierr,fc)
      IF (ierr .LT. 0) RETURN
      resk = wgk(11)*fc
      resabs = dabs(resk)
      DO 10 j=1,5
        jtw = 2*j
        absc = hlgth*xgk(jtw)
        CALL f(centr-absc,ierr,fval1)
        IF (ierr .LT. 0) RETURN
        CALL f(centr+absc,ierr,fval2)
        IF (ierr .LT. 0) RETURN
        fv1(jtw) = fval1
        fv2(jtw) = fval2
        fsum = fval1+fval2
        resg = resg+wg(j)*fsum
        resk = resk+wgk(jtw)*fsum
        resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2))
   10 CONTINUE
      DO 15 j = 1,5
        jtwm1 = 2*j-1
        absc = hlgth*xgk(jtwm1)
        CALL f(centr-absc,ierr,fval1)
        IF (ierr .LT. 0) RETURN
        CALL f(centr+absc,ierr,fval2)
        IF (ierr .LT. 0) RETURN
        fv1(jtwm1) = fval1
        fv2(jtwm1) = fval2
        fsum = fval1+fval2
        resk = resk+wgk(jtwm1)*fsum
        resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2))
   15 CONTINUE
      reskh = resk*0.5d+00
      resasc = wgk(11)*dabs(fc-reskh)
      DO 20 j=1,10
        resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh))
   20 CONTINUE
      result = resk*hlgth
      resabs = resabs*dhlgth
      resasc = resasc*dhlgth
      abserr = dabs((resk-resg)*hlgth)
      IF(resasc.NE.0.0d+00.AND.abserr.NE.0.0d+00)
     *  abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00)
      IF(resabs.GT.uflow/(0.5d+02*epmach)) abserr = dmax1
     *  ((epmach*0.5d+02)*resabs,abserr)
      RETURN
      END