GNU Octave: libcruft/quadpack/dqk21.f Source File

Go to the documentation of this file.
00001       SUBROUTINE DQK21(F,A,B,RESULT,ABSERR,RESABS,RESASC,IERR)
00002 C***BEGIN PROLOGUE  DQK21
00003 C***DATE WRITTEN   800101   (YYMMDD)
00004 C***REVISION DATE  830518   (YYMMDD)
00005 C***CATEGORY NO.  H2A1A2
00006 C***KEYWORDS  21-POINT GAUSS-KRONROD RULES
00007 C***AUTHOR  PIESSENS,ROBERT,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
00008 C           DE DONCKER,ELISE,APPL. MATH. & PROGR. DIV. - K.U.LEUVEN
00009 C***PURPOSE  TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR
00010 C                           ESTIMATE
00011 C                       J = INTEGRAL OF ABS(F) OVER (A,B)
00012 C***DESCRIPTION
00013 C
00014 C           INTEGRATION RULES
00015 C           STANDARD FORTRAN SUBROUTINE
00016 C           DOUBLE PRECISION VERSION
00017 C
00018 C           PARAMETERS
00019 C            ON ENTRY
00020 C              F      - SUBROUTINE F(X,IERR,RESULT) DEFINING THE INTEGRAND
00021 C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
00022 C                       DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
00023 C
00024 C              A      - DOUBLE PRECISION
00025 C                       LOWER LIMIT OF INTEGRATION
00026 C
00027 C              B      - DOUBLE PRECISION
00028 C                       UPPER LIMIT OF INTEGRATION
00029 C
00030 C            ON RETURN
00031 C              RESULT - DOUBLE PRECISION
00032 C                       APPROXIMATION TO THE INTEGRAL I
00033 C                       RESULT IS COMPUTED BY APPLYING THE 21-POINT
00034 C                       KRONROD RULE (RESK) OBTAINED BY OPTIMAL ADDITION
00035 C                       OF ABSCISSAE TO THE 10-POINT GAUSS RULE (RESG).
00036 C
00037 C              ABSERR - DOUBLE PRECISION
00038 C                       ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
00039 C                       WHICH SHOULD NOT EXCEED ABS(I-RESULT)
00040 C
00041 C              RESABS - DOUBLE PRECISION
00042 C                       APPROXIMATION TO THE INTEGRAL J
00043 C
00044 C              RESASC - DOUBLE PRECISION
00045 C                       APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A))
00046 C                       OVER (A,B)
00047 C
00048 C***REFERENCES  (NONE)
00049 C***ROUTINES CALLED  D1MACH
00050 C***END PROLOGUE  DQK21
00051 C
00052       DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DABS,DHLGTH,DMAX1,DMIN1,
00053      *  D1MACH,EPMACH,FC,FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESASC,
00054      *  RESG,RESK,RESKH,RESULT,UFLOW,WG,WGK,XGK
00055       INTEGER J,JTW,JTWM1
00056       EXTERNAL F
00057 C
00058       DIMENSION FV1(10),FV2(10),WG(5),WGK(11),XGK(11)
00059 C
00060 C           THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1).
00061 C           BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR
00062 C           CORRESPONDING WEIGHTS ARE GIVEN.
00063 C
00064 C           XGK    - ABSCISSAE OF THE 21-POINT KRONROD RULE
00065 C                    XGK(2), XGK(4), ...  ABSCISSAE OF THE 10-POINT
00066 C                    GAUSS RULE
00067 C                    XGK(1), XGK(3), ...  ABSCISSAE WHICH ARE OPTIMALLY
00068 C                    ADDED TO THE 10-POINT GAUSS RULE
00069 C
00070 C           WGK    - WEIGHTS OF THE 21-POINT KRONROD RULE
00071 C
00072 C           WG     - WEIGHTS OF THE 10-POINT GAUSS RULE
00073 C
00074 C
00075 C GAUSS QUADRATURE WEIGHTS AND KRONRON QUADRATURE ABSCISSAE AND WEIGHTS
00076 C AS EVALUATED WITH 80 DECIMAL DIGIT ARITHMETIC BY L. W. FULLERTON,
00077 C BELL LABS, NOV. 1981.
00078 C
00079       DATA WG  (  1) / 0.0666713443 0868813759 3568809893 332 D0 /
00080       DATA WG  (  2) / 0.1494513491 5058059314 5776339657 697 D0 /
00081       DATA WG  (  3) / 0.2190863625 1598204399 5534934228 163 D0 /
00082       DATA WG  (  4) / 0.2692667193 0999635509 1226921569 469 D0 /
00083       DATA WG  (  5) / 0.2955242247 1475287017 3892994651 338 D0 /
00084 C
00085       DATA XGK (  1) / 0.9956571630 2580808073 5527280689 003 D0 /
00086       DATA XGK (  2) / 0.9739065285 1717172007 7964012084 452 D0 /
00087       DATA XGK (  3) / 0.9301574913 5570822600 1207180059 508 D0 /
00088       DATA XGK (  4) / 0.8650633666 8898451073 2096688423 493 D0 /
00089       DATA XGK (  5) / 0.7808177265 8641689706 3717578345 042 D0 /
00090       DATA XGK (  6) / 0.6794095682 9902440623 4327365114 874 D0 /
00091       DATA XGK (  7) / 0.5627571346 6860468333 9000099272 694 D0 /
00092       DATA XGK (  8) / 0.4333953941 2924719079 9265943165 784 D0 /
00093       DATA XGK (  9) / 0.2943928627 0146019813 1126603103 866 D0 /
00094       DATA XGK ( 10) / 0.1488743389 8163121088 4826001129 720 D0 /
00095       DATA XGK ( 11) / 0.0000000000 0000000000 0000000000 000 D0 /
00096 C
00097       DATA WGK (  1) / 0.0116946388 6737187427 8064396062 192 D0 /
00098       DATA WGK (  2) / 0.0325581623 0796472747 8818972459 390 D0 /
00099       DATA WGK (  3) / 0.0547558965 7435199603 1381300244 580 D0 /
00100       DATA WGK (  4) / 0.0750396748 1091995276 7043140916 190 D0 /
00101       DATA WGK (  5) / 0.0931254545 8369760553 5065465083 366 D0 /
00102       DATA WGK (  6) / 0.1093871588 0229764189 9210590325 805 D0 /
00103       DATA WGK (  7) / 0.1234919762 6206585107 7958109831 074 D0 /
00104       DATA WGK (  8) / 0.1347092173 1147332592 8054001771 707 D0 /
00105       DATA WGK (  9) / 0.1427759385 7706008079 7094273138 717 D0 /
00106       DATA WGK ( 10) / 0.1477391049 0133849137 4841515972 068 D0 /
00107       DATA WGK ( 11) / 0.1494455540 0291690566 4936468389 821 D0 /
00108 C
00109 C
00110 C           LIST OF MAJOR VARIABLES
00111 C           -----------------------
00112 C
00113 C           CENTR  - MID POINT OF THE INTERVAL
00114 C           HLGTH  - HALF-LENGTH OF THE INTERVAL
00115 C           ABSC   - ABSCISSA
00116 C           FVAL*  - FUNCTION VALUE
00117 C           RESG   - RESULT OF THE 10-POINT GAUSS FORMULA
00118 C           RESK   - RESULT OF THE 21-POINT KRONROD FORMULA
00119 C           RESKH  - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B),
00120 C                    I.E. TO I/(B-A)
00121 C
00122 C
00123 C           MACHINE DEPENDENT CONSTANTS
00124 C           ---------------------------
00125 C
00126 C           EPMACH IS THE LARGEST RELATIVE SPACING.
00127 C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
00128 C
00129 C***FIRST EXECUTABLE STATEMENT  DQK21
00130       EPMACH = D1MACH(4)
00131       UFLOW = D1MACH(1)
00132 C
00133       CENTR = 0.5D+00*(A+B)
00134       HLGTH = 0.5D+00*(B-A)
00135       DHLGTH = DABS(HLGTH)
00136 C
00137 C           COMPUTE THE 21-POINT KRONROD APPROXIMATION TO
00138 C           THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR.
00139 C
00140       RESG = 0.0D+00
00141       IERR = 0
00142       CALL F(CENTR,IERR,FC)
00143       IF (IERR .LT. 0) RETURN
00144       RESK = WGK(11)*FC
00145       RESABS = DABS(RESK)
00146       DO 10 J=1,5
00147         JTW = 2*J
00148         ABSC = HLGTH*XGK(JTW)
00149         CALL F(CENTR-ABSC,IERR,FVAL1)
00150         IF (IERR .LT. 0) RETURN
00151         CALL F(CENTR+ABSC,IERR,FVAL2)
00152         IF (IERR .LT. 0) RETURN
00153         FV1(JTW) = FVAL1
00154         FV2(JTW) = FVAL2
00155         FSUM = FVAL1+FVAL2
00156         RESG = RESG+WG(J)*FSUM
00157         RESK = RESK+WGK(JTW)*FSUM
00158         RESABS = RESABS+WGK(JTW)*(DABS(FVAL1)+DABS(FVAL2))
00159    10 CONTINUE
00160       DO 15 J = 1,5
00161         JTWM1 = 2*J-1
00162         ABSC = HLGTH*XGK(JTWM1)
00163         CALL F(CENTR-ABSC,IERR,FVAL1)
00164         IF (IERR .LT. 0) RETURN
00165         CALL F(CENTR+ABSC,IERR,FVAL2)
00166         IF (IERR .LT. 0) RETURN
00167         FV1(JTWM1) = FVAL1
00168         FV2(JTWM1) = FVAL2
00169         FSUM = FVAL1+FVAL2
00170         RESK = RESK+WGK(JTWM1)*FSUM
00171         RESABS = RESABS+WGK(JTWM1)*(DABS(FVAL1)+DABS(FVAL2))
00172    15 CONTINUE
00173       RESKH = RESK*0.5D+00
00174       RESASC = WGK(11)*DABS(FC-RESKH)
00175       DO 20 J=1,10
00176         RESASC = RESASC+WGK(J)*(DABS(FV1(J)-RESKH)+DABS(FV2(J)-RESKH))
00177    20 CONTINUE
00178       RESULT = RESK*HLGTH
00179       RESABS = RESABS*DHLGTH
00180       RESASC = RESASC*DHLGTH
00181       ABSERR = DABS((RESK-RESG)*HLGTH)
00182       IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00)
00183      *  ABSERR = RESASC*DMIN1(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00)
00184       IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = DMAX1
00185      *  ((EPMACH*0.5D+02)*RESABS,ABSERR)
00186       RETURN
00187       END