dqk21.f 7.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193
  1. *DECK DQK21
  2. SUBROUTINE DQK21 (F, A, B, RESULT, ABSERR, RESABS, RESASC)
  3. C***BEGIN PROLOGUE DQK21
  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 (QK21-S, DQK21-D)
  10. C***KEYWORDS 21-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 driver 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 21-POINT
  40. C KRONROD RULE (RESK) obtained by optimal addition
  41. C of abscissae to the 10-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 DQK21
  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(10),FV2(10),WG(5),WGK(11),XGK(11)
  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 21-POINT KRONROD RULE
  76. C XGK(2), XGK(4), ... ABSCISSAE OF THE 10-POINT
  77. C GAUSS RULE
  78. C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY
  79. C ADDED TO THE 10-POINT GAUSS RULE
  80. C
  81. C WGK - WEIGHTS OF THE 21-POINT KRONROD RULE
  82. C
  83. C WG - WEIGHTS OF THE 10-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.0666713443 0868813759 3568809893 332 D0 /
  92. DATA WG ( 2) / 0.1494513491 5058059314 5776339657 697 D0 /
  93. DATA WG ( 3) / 0.2190863625 1598204399 5534934228 163 D0 /
  94. DATA WG ( 4) / 0.2692667193 0999635509 1226921569 469 D0 /
  95. DATA WG ( 5) / 0.2955242247 1475287017 3892994651 338 D0 /
  96. C
  97. DATA XGK ( 1) / 0.9956571630 2580808073 5527280689 003 D0 /
  98. DATA XGK ( 2) / 0.9739065285 1717172007 7964012084 452 D0 /
  99. DATA XGK ( 3) / 0.9301574913 5570822600 1207180059 508 D0 /
  100. DATA XGK ( 4) / 0.8650633666 8898451073 2096688423 493 D0 /
  101. DATA XGK ( 5) / 0.7808177265 8641689706 3717578345 042 D0 /
  102. DATA XGK ( 6) / 0.6794095682 9902440623 4327365114 874 D0 /
  103. DATA XGK ( 7) / 0.5627571346 6860468333 9000099272 694 D0 /
  104. DATA XGK ( 8) / 0.4333953941 2924719079 9265943165 784 D0 /
  105. DATA XGK ( 9) / 0.2943928627 0146019813 1126603103 866 D0 /
  106. DATA XGK ( 10) / 0.1488743389 8163121088 4826001129 720 D0 /
  107. DATA XGK ( 11) / 0.0000000000 0000000000 0000000000 000 D0 /
  108. C
  109. DATA WGK ( 1) / 0.0116946388 6737187427 8064396062 192 D0 /
  110. DATA WGK ( 2) / 0.0325581623 0796472747 8818972459 390 D0 /
  111. DATA WGK ( 3) / 0.0547558965 7435199603 1381300244 580 D0 /
  112. DATA WGK ( 4) / 0.0750396748 1091995276 7043140916 190 D0 /
  113. DATA WGK ( 5) / 0.0931254545 8369760553 5065465083 366 D0 /
  114. DATA WGK ( 6) / 0.1093871588 0229764189 9210590325 805 D0 /
  115. DATA WGK ( 7) / 0.1234919762 6206585107 7958109831 074 D0 /
  116. DATA WGK ( 8) / 0.1347092173 1147332592 8054001771 707 D0 /
  117. DATA WGK ( 9) / 0.1427759385 7706008079 7094273138 717 D0 /
  118. DATA WGK ( 10) / 0.1477391049 0133849137 4841515972 068 D0 /
  119. DATA WGK ( 11) / 0.1494455540 0291690566 4936468389 821 D0 /
  120. C
  121. C
  122. C LIST OF MAJOR VARIABLES
  123. C -----------------------
  124. C
  125. C CENTR - MID POINT OF THE INTERVAL
  126. C HLGTH - HALF-LENGTH OF THE INTERVAL
  127. C ABSC - ABSCISSA
  128. C FVAL* - FUNCTION VALUE
  129. C RESG - RESULT OF THE 10-POINT GAUSS FORMULA
  130. C RESK - RESULT OF THE 21-POINT KRONROD FORMULA
  131. C RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B),
  132. C I.E. TO I/(B-A)
  133. C
  134. C
  135. C MACHINE DEPENDENT CONSTANTS
  136. C ---------------------------
  137. C
  138. C EPMACH IS THE LARGEST RELATIVE SPACING.
  139. C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
  140. C
  141. C***FIRST EXECUTABLE STATEMENT DQK21
  142. EPMACH = D1MACH(4)
  143. UFLOW = D1MACH(1)
  144. C
  145. CENTR = 0.5D+00*(A+B)
  146. HLGTH = 0.5D+00*(B-A)
  147. DHLGTH = ABS(HLGTH)
  148. C
  149. C COMPUTE THE 21-POINT KRONROD APPROXIMATION TO
  150. C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR.
  151. C
  152. RESG = 0.0D+00
  153. FC = F(CENTR)
  154. RESK = WGK(11)*FC
  155. RESABS = ABS(RESK)
  156. DO 10 J=1,5
  157. JTW = 2*J
  158. ABSC = HLGTH*XGK(JTW)
  159. FVAL1 = F(CENTR-ABSC)
  160. FVAL2 = F(CENTR+ABSC)
  161. FV1(JTW) = FVAL1
  162. FV2(JTW) = FVAL2
  163. FSUM = FVAL1+FVAL2
  164. RESG = RESG+WG(J)*FSUM
  165. RESK = RESK+WGK(JTW)*FSUM
  166. RESABS = RESABS+WGK(JTW)*(ABS(FVAL1)+ABS(FVAL2))
  167. 10 CONTINUE
  168. DO 15 J = 1,5
  169. JTWM1 = 2*J-1
  170. ABSC = HLGTH*XGK(JTWM1)
  171. FVAL1 = F(CENTR-ABSC)
  172. FVAL2 = F(CENTR+ABSC)
  173. FV1(JTWM1) = FVAL1
  174. FV2(JTWM1) = FVAL2
  175. FSUM = FVAL1+FVAL2
  176. RESK = RESK+WGK(JTWM1)*FSUM
  177. RESABS = RESABS+WGK(JTWM1)*(ABS(FVAL1)+ABS(FVAL2))
  178. 15 CONTINUE
  179. RESKH = RESK*0.5D+00
  180. RESASC = WGK(11)*ABS(FC-RESKH)
  181. DO 20 J=1,10
  182. RESASC = RESASC+WGK(J)*(ABS(FV1(J)-RESKH)+ABS(FV2(J)-RESKH))
  183. 20 CONTINUE
  184. RESULT = RESK*HLGTH
  185. RESABS = RESABS*DHLGTH
  186. RESASC = RESASC*DHLGTH
  187. ABSERR = ABS((RESK-RESG)*HLGTH)
  188. IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00)
  189. 1 ABSERR = RESASC*MIN(0.1D+01,(0.2D+03*ABSERR/RESASC)**1.5D+00)
  190. IF(RESABS.GT.UFLOW/(0.5D+02*EPMACH)) ABSERR = MAX
  191. 1 ((EPMACH*0.5D+02)*RESABS,ABSERR)
  192. RETURN
  193. END