/doc/html/quadpack_8f90_source.html
HTML | 6448 lines | 6446 code | 0 blank | 2 comment | 0 complexity | 491d26045f44fbf5f60793ebf32a1fb0 MD5 | raw file
Possible License(s): LGPL-3.0
- <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
- <html xmlns="http://www.w3.org/1999/xhtml">
- <head>
- <meta http-equiv="Content-Type" content="text/xhtml;charset=UTF-8"/>
- <title>3DEX: /Users/bl/Dropbox/3DEX/src/f90/external/quadpack.f90 Source File</title>
- <link href="tabs.css" rel="stylesheet" type="text/css"/>
- <link href="search/search.css" rel="stylesheet" type="text/css"/>
- <script type="text/javascript" src="search/search.js"></script>
- <link href="doxygen.css" rel="stylesheet" type="text/css"/>
- </head>
- <body onload='searchBox.OnSelectItem(0);'>
- <!-- Generated by Doxygen 1.7.4 -->
- <script type="text/javascript"><!--
- var searchBox = new SearchBox("searchBox", "search",false,'Search');
- --></script>
- <div id="top">
- <div id="titlearea">
- <table cellspacing="0" cellpadding="0">
- <tbody>
- <tr style="height: 56px;">
- <td style="padding-left: 0.5em;">
- <div id="projectname">3DEX <span id="projectnumber">1.0</span></div>
- <div id="projectbrief">Three-dimensional Fourier-Bessel decomposition</div>
- </td>
- </tr>
- </tbody>
- </table>
- </div>
- <div id="navrow1" class="tabs">
- <ul class="tablist">
- <li><a href="index.html"><span>Main Page</span></a></li>
- <li><a href="pages.html"><span>Related Pages</span></a></li>
- <li><a href="namespaces.html"><span>Modules</span></a></li>
- <li><a href="annotated.html"><span>Data Types List</span></a></li>
- <li class="current"><a href="files.html"><span>Files</span></a></li>
- <li id="searchli">
- <div id="MSearchBox" class="MSearchBoxInactive">
- <span class="left">
- <img id="MSearchSelect" src="search/mag_sel.png"
- onmouseover="return searchBox.OnSearchSelectShow()"
- onmouseout="return searchBox.OnSearchSelectHide()"
- alt=""/>
- <input type="text" id="MSearchField" value="Search" accesskey="S"
- onfocus="searchBox.OnSearchFieldFocus(true)"
- onblur="searchBox.OnSearchFieldFocus(false)"
- onkeyup="searchBox.OnSearchFieldChange(event)"/>
- </span><span class="right">
- <a id="MSearchClose" href="javascript:searchBox.CloseResultsWindow()"><img id="MSearchCloseImg" border="0" src="search/close.png" alt=""/></a>
- </span>
- </div>
- </li>
- </ul>
- </div>
- <div id="navrow2" class="tabs2">
- <ul class="tablist">
- <li><a href="files.html"><span>File List</span></a></li>
- <li><a href="globals.html"><span>File Members</span></a></li>
- </ul>
- </div>
- <div class="header">
- <div class="headertitle">
- <div class="title">/Users/bl/Dropbox/3DEX/src/f90/external/quadpack.f90</div> </div>
- </div>
- <div class="contents">
- <a href="quadpack_8f90.html">Go to the documentation of this file.</a><div class="fragment"><pre class="fragment"><a name="l00001"></a><a class="code" href="quadpack_8f90.html#a44906a25a31588f7e4f41f0e5253193a">00001</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#a44906a25a31588f7e4f41f0e5253193a">qag</a> ( f, a, b, epsabs, epsrel, key, result, abserr, neval, ier )
- <a name="l00002"></a>00002
- <a name="l00003"></a>00003 <span class="comment">!*****************************************************************************80</span>
- <a name="l00004"></a>00004 <span class="comment">!</span>
- <a name="l00005"></a>00005 <span class="comment">!! QAG approximates an integral over a finite interval.</span>
- <a name="l00006"></a>00006 <span class="comment">!</span>
- <a name="l00007"></a>00007 <span class="comment">! Discussion:</span>
- <a name="l00008"></a>00008 <span class="comment">!</span>
- <a name="l00009"></a>00009 <span class="comment">! The routine calculates an approximation RESULT to a definite integral </span>
- <a name="l00010"></a>00010 <span class="comment">! I = integral of F over (A,B),</span>
- <a name="l00011"></a>00011 <span class="comment">! hopefully satisfying</span>
- <a name="l00012"></a>00012 <span class="comment">! || I - RESULT || <= max ( EPSABS, EPSREL * ||I|| ).</span>
- <a name="l00013"></a>00013 <span class="comment">!</span>
- <a name="l00014"></a>00014 <span class="comment">! QAG is a simple globally adaptive integrator using the strategy of </span>
- <a name="l00015"></a>00015 <span class="comment">! Aind (Piessens, 1973). It is possible to choose between 6 pairs of</span>
- <a name="l00016"></a>00016 <span class="comment">! Gauss-Kronrod quadrature formulae for the rule evaluation component. </span>
- <a name="l00017"></a>00017 <span class="comment">! The pairs of high degree of precision are suitable for handling</span>
- <a name="l00018"></a>00018 <span class="comment">! integration difficulties due to a strongly oscillating integrand.</span>
- <a name="l00019"></a>00019 <span class="comment">!</span>
- <a name="l00020"></a>00020 <span class="comment">! Author:</span>
- <a name="l00021"></a>00021 <span class="comment">!</span>
- <a name="l00022"></a>00022 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l00023"></a>00023 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l00024"></a>00024 <span class="comment">!</span>
- <a name="l00025"></a>00025 <span class="comment">! Reference:</span>
- <a name="l00026"></a>00026 <span class="comment">!</span>
- <a name="l00027"></a>00027 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l00028"></a>00028 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l00029"></a>00029 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l00030"></a>00030 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l00031"></a>00031 <span class="comment">!</span>
- <a name="l00032"></a>00032 <span class="comment">! Parameters:</span>
- <a name="l00033"></a>00033 <span class="comment">!</span>
- <a name="l00034"></a>00034 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l00035"></a>00035 <span class="comment">! function f ( x )</span>
- <a name="l00036"></a>00036 <span class="comment">! real f</span>
- <a name="l00037"></a>00037 <span class="comment">! real x</span>
- <a name="l00038"></a>00038 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l00039"></a>00039 <span class="comment">!</span>
- <a name="l00040"></a>00040 <span class="comment">! Input, real A, B, the limits of integration.</span>
- <a name="l00041"></a>00041 <span class="comment">!</span>
- <a name="l00042"></a>00042 <span class="comment">! Input, real EPSABS, EPSREL, the absolute and relative accuracy requested.</span>
- <a name="l00043"></a>00043 <span class="comment">!</span>
- <a name="l00044"></a>00044 <span class="comment">! Input, integer KEY, chooses the order of the local integration rule:</span>
- <a name="l00045"></a>00045 <span class="comment">! 1, 7 Gauss points, 15 Gauss-Kronrod points,</span>
- <a name="l00046"></a>00046 <span class="comment">! 2, 10 Gauss points, 21 Gauss-Kronrod points,</span>
- <a name="l00047"></a>00047 <span class="comment">! 3, 15 Gauss points, 31 Gauss-Kronrod points,</span>
- <a name="l00048"></a>00048 <span class="comment">! 4, 20 Gauss points, 41 Gauss-Kronrod points,</span>
- <a name="l00049"></a>00049 <span class="comment">! 5, 25 Gauss points, 51 Gauss-Kronrod points,</span>
- <a name="l00050"></a>00050 <span class="comment">! 6, 30 Gauss points, 61 Gauss-Kronrod points.</span>
- <a name="l00051"></a>00051 <span class="comment">!</span>
- <a name="l00052"></a>00052 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l00053"></a>00053 <span class="comment">!</span>
- <a name="l00054"></a>00054 <span class="comment">! Output, real ABSERR, an estimate of || I - RESULT ||.</span>
- <a name="l00055"></a>00055 <span class="comment">!</span>
- <a name="l00056"></a>00056 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l00057"></a>00057 <span class="comment">!</span>
- <a name="l00058"></a>00058 <span class="comment">! Output, integer IER, return code.</span>
- <a name="l00059"></a>00059 <span class="comment">! 0, normal and reliable termination of the routine. It is assumed that the </span>
- <a name="l00060"></a>00060 <span class="comment">! requested accuracy has been achieved.</span>
- <a name="l00061"></a>00061 <span class="comment">! 1, maximum number of subdivisions allowed has been achieved. One can </span>
- <a name="l00062"></a>00062 <span class="comment">! allow more subdivisions by increasing the value of LIMIT in QAG. </span>
- <a name="l00063"></a>00063 <span class="comment">! However, if this yields no improvement it is advised to analyze the</span>
- <a name="l00064"></a>00064 <span class="comment">! integrand to determine the integration difficulties. If the position</span>
- <a name="l00065"></a>00065 <span class="comment">! of a local difficulty can be determined, such as a singularity or</span>
- <a name="l00066"></a>00066 <span class="comment">! discontinuity within the interval) one will probably gain from </span>
- <a name="l00067"></a>00067 <span class="comment">! splitting up the interval at this point and calling the integrator </span>
- <a name="l00068"></a>00068 <span class="comment">! on the subranges. If possible, an appropriate special-purpose </span>
- <a name="l00069"></a>00069 <span class="comment">! integrator should be used which is designed for handling the type </span>
- <a name="l00070"></a>00070 <span class="comment">! of difficulty involved.</span>
- <a name="l00071"></a>00071 <span class="comment">! 2, the occurrence of roundoff error is detected, which prevents the</span>
- <a name="l00072"></a>00072 <span class="comment">! requested tolerance from being achieved.</span>
- <a name="l00073"></a>00073 <span class="comment">! 3, extremely bad integrand behavior occurs at some points of the</span>
- <a name="l00074"></a>00074 <span class="comment">! integration interval.</span>
- <a name="l00075"></a>00075 <span class="comment">! 6, the input is invalid, because EPSABS < 0 and EPSREL < 0.</span>
- <a name="l00076"></a>00076 <span class="comment">!</span>
- <a name="l00077"></a>00077 <span class="comment">! Local parameters:</span>
- <a name="l00078"></a>00078 <span class="comment">!</span>
- <a name="l00079"></a>00079 <span class="comment">! LIMIT is the maximum number of subintervals allowed in</span>
- <a name="l00080"></a>00080 <span class="comment">! the subdivision process of QAGE.</span>
- <a name="l00081"></a>00081 <span class="comment">!</span>
- <a name="l00082"></a>00082 <span class="keyword">implicit none</span>
- <a name="l00083"></a>00083
- <a name="l00084"></a>00084 <span class="keywordtype">integer</span>, <span class="keywordtype">parameter</span> :: limit = 500
- <a name="l00085"></a>00085
- <a name="l00086"></a>00086 <span class="keywordtype">real</span> a
- <a name="l00087"></a>00087 <span class="keywordtype">real</span> abserr
- <a name="l00088"></a>00088 <span class="keywordtype">real</span> alist(limit)
- <a name="l00089"></a>00089 <span class="keywordtype">real</span> b
- <a name="l00090"></a>00090 <span class="keywordtype">real</span> blist(limit)
- <a name="l00091"></a>00091 <span class="keywordtype">real</span> elist(limit)
- <a name="l00092"></a>00092 <span class="keywordtype">real</span> epsabs
- <a name="l00093"></a>00093 <span class="keywordtype">real</span> epsrel
- <a name="l00094"></a>00094 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l00095"></a>00095 <span class="keywordtype">integer</span> ier
- <a name="l00096"></a>00096 <span class="keywordtype">integer</span> iord(limit)
- <a name="l00097"></a>00097 <span class="keywordtype">integer</span> key
- <a name="l00098"></a>00098 <span class="keywordtype">integer</span> last
- <a name="l00099"></a>00099 <span class="keywordtype">integer</span> neval
- <a name="l00100"></a>00100 <span class="keywordtype">real</span> result
- <a name="l00101"></a>00101 <span class="keywordtype">real</span> rlist(limit)
- <a name="l00102"></a>00102
- <a name="l00103"></a>00103 call <a class="code" href="quadpack_8f90.html#ab602437c218a2c74d6a13f9462f98854">qage </a>( f, a, b, epsabs, epsrel, key, limit, result, abserr, neval, &
- <a name="l00104"></a>00104 ier, alist, blist, rlist, elist, iord, last )
- <a name="l00105"></a>00105
- <a name="l00106"></a>00106 return
- <a name="l00107"></a>00107 <span class="keyword">end</span>
- <a name="l00108"></a><a class="code" href="quadpack_8f90.html#ab602437c218a2c74d6a13f9462f98854">00108</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#ab602437c218a2c74d6a13f9462f98854">qage</a> ( f, a, b, epsabs, epsrel, key, limit, result, abserr, neval, &
- <a name="l00109"></a>00109 ier, alist, blist, rlist, elist, iord, last )
- <a name="l00110"></a>00110
- <a name="l00111"></a>00111 <span class="comment">!*****************************************************************************80</span>
- <a name="l00112"></a>00112 <span class="comment">!</span>
- <a name="l00113"></a>00113 <span class="comment">!! QAGE estimates a definite integral.</span>
- <a name="l00114"></a>00114 <span class="comment">!</span>
- <a name="l00115"></a>00115 <span class="comment">! Discussion:</span>
- <a name="l00116"></a>00116 <span class="comment">!</span>
- <a name="l00117"></a>00117 <span class="comment">! The routine calculates an approximation RESULT to a definite integral </span>
- <a name="l00118"></a>00118 <span class="comment">! I = integral of F over (A,B),</span>
- <a name="l00119"></a>00119 <span class="comment">! hopefully satisfying</span>
- <a name="l00120"></a>00120 <span class="comment">! || I - RESULT || <= max ( EPSABS, EPSREL * ||I|| ).</span>
- <a name="l00121"></a>00121 <span class="comment">!</span>
- <a name="l00122"></a>00122 <span class="comment">! Author:</span>
- <a name="l00123"></a>00123 <span class="comment">!</span>
- <a name="l00124"></a>00124 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l00125"></a>00125 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l00126"></a>00126 <span class="comment">!</span>
- <a name="l00127"></a>00127 <span class="comment">! Reference:</span>
- <a name="l00128"></a>00128 <span class="comment">!</span>
- <a name="l00129"></a>00129 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l00130"></a>00130 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l00131"></a>00131 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l00132"></a>00132 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l00133"></a>00133 <span class="comment">!</span>
- <a name="l00134"></a>00134 <span class="comment">! Parameters:</span>
- <a name="l00135"></a>00135 <span class="comment">!</span>
- <a name="l00136"></a>00136 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l00137"></a>00137 <span class="comment">! function f ( x )</span>
- <a name="l00138"></a>00138 <span class="comment">! real f</span>
- <a name="l00139"></a>00139 <span class="comment">! real x</span>
- <a name="l00140"></a>00140 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l00141"></a>00141 <span class="comment">!</span>
- <a name="l00142"></a>00142 <span class="comment">! Input, real A, B, the limits of integration.</span>
- <a name="l00143"></a>00143 <span class="comment">!</span>
- <a name="l00144"></a>00144 <span class="comment">! Input, real EPSABS, EPSREL, the absolute and relative accuracy requested.</span>
- <a name="l00145"></a>00145 <span class="comment">!</span>
- <a name="l00146"></a>00146 <span class="comment">! Input, integer KEY, chooses the order of the local integration rule:</span>
- <a name="l00147"></a>00147 <span class="comment">! 1, 7 Gauss points, 15 Gauss-Kronrod points,</span>
- <a name="l00148"></a>00148 <span class="comment">! 2, 10 Gauss points, 21 Gauss-Kronrod points,</span>
- <a name="l00149"></a>00149 <span class="comment">! 3, 15 Gauss points, 31 Gauss-Kronrod points,</span>
- <a name="l00150"></a>00150 <span class="comment">! 4, 20 Gauss points, 41 Gauss-Kronrod points,</span>
- <a name="l00151"></a>00151 <span class="comment">! 5, 25 Gauss points, 51 Gauss-Kronrod points,</span>
- <a name="l00152"></a>00152 <span class="comment">! 6, 30 Gauss points, 61 Gauss-Kronrod points.</span>
- <a name="l00153"></a>00153 <span class="comment">!</span>
- <a name="l00154"></a>00154 <span class="comment">! Input, integer LIMIT, the maximum number of subintervals that</span>
- <a name="l00155"></a>00155 <span class="comment">! can be used.</span>
- <a name="l00156"></a>00156 <span class="comment">!</span>
- <a name="l00157"></a>00157 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l00158"></a>00158 <span class="comment">!</span>
- <a name="l00159"></a>00159 <span class="comment">! Output, real ABSERR, an estimate of || I - RESULT ||.</span>
- <a name="l00160"></a>00160 <span class="comment">!</span>
- <a name="l00161"></a>00161 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l00162"></a>00162 <span class="comment">!</span>
- <a name="l00163"></a>00163 <span class="comment">! Output, integer IER, return code.</span>
- <a name="l00164"></a>00164 <span class="comment">! 0, normal and reliable termination of the routine. It is assumed that the </span>
- <a name="l00165"></a>00165 <span class="comment">! requested accuracy has been achieved.</span>
- <a name="l00166"></a>00166 <span class="comment">! 1, maximum number of subdivisions allowed has been achieved. One can </span>
- <a name="l00167"></a>00167 <span class="comment">! allow more subdivisions by increasing the value of LIMIT in QAG. </span>
- <a name="l00168"></a>00168 <span class="comment">! However, if this yields no improvement it is advised to analyze the</span>
- <a name="l00169"></a>00169 <span class="comment">! integrand to determine the integration difficulties. If the position</span>
- <a name="l00170"></a>00170 <span class="comment">! of a local difficulty can be determined, such as a singularity or</span>
- <a name="l00171"></a>00171 <span class="comment">! discontinuity within the interval) one will probably gain from </span>
- <a name="l00172"></a>00172 <span class="comment">! splitting up the interval at this point and calling the integrator </span>
- <a name="l00173"></a>00173 <span class="comment">! on the subranges. If possible, an appropriate special-purpose </span>
- <a name="l00174"></a>00174 <span class="comment">! integrator should be used which is designed for handling the type </span>
- <a name="l00175"></a>00175 <span class="comment">! of difficulty involved.</span>
- <a name="l00176"></a>00176 <span class="comment">! 2, the occurrence of roundoff error is detected, which prevents the</span>
- <a name="l00177"></a>00177 <span class="comment">! requested tolerance from being achieved.</span>
- <a name="l00178"></a>00178 <span class="comment">! 3, extremely bad integrand behavior occurs at some points of the</span>
- <a name="l00179"></a>00179 <span class="comment">! integration interval.</span>
- <a name="l00180"></a>00180 <span class="comment">! 6, the input is invalid, because EPSABS < 0 and EPSREL < 0.</span>
- <a name="l00181"></a>00181 <span class="comment">!</span>
- <a name="l00182"></a>00182 <span class="comment">! Workspace, real ALIST(LIMIT), BLIST(LIMIT), contains in entries 1 </span>
- <a name="l00183"></a>00183 <span class="comment">! through LAST the left and right ends of the partition subintervals.</span>
- <a name="l00184"></a>00184 <span class="comment">!</span>
- <a name="l00185"></a>00185 <span class="comment">! Workspace, real RLIST(LIMIT), contains in entries 1 through LAST</span>
- <a name="l00186"></a>00186 <span class="comment">! the integral approximations on the subintervals.</span>
- <a name="l00187"></a>00187 <span class="comment">!</span>
- <a name="l00188"></a>00188 <span class="comment">! Workspace, real ELIST(LIMIT), contains in entries 1 through LAST</span>
- <a name="l00189"></a>00189 <span class="comment">! the absolute error estimates on the subintervals.</span>
- <a name="l00190"></a>00190 <span class="comment">!</span>
- <a name="l00191"></a>00191 <span class="comment">! Output, integer IORD(LIMIT), the first K elements of which are pointers </span>
- <a name="l00192"></a>00192 <span class="comment">! to the error estimates over the subintervals, such that</span>
- <a name="l00193"></a>00193 <span class="comment">! elist(iord(1)), ..., elist(iord(k)) form a decreasing sequence, with</span>
- <a name="l00194"></a>00194 <span class="comment">! k = last if last <= (limit/2+2), and k = limit+1-last otherwise.</span>
- <a name="l00195"></a>00195 <span class="comment">!</span>
- <a name="l00196"></a>00196 <span class="comment">! Output, integer LAST, the number of subintervals actually produced </span>
- <a name="l00197"></a>00197 <span class="comment">! in the subdivision process.</span>
- <a name="l00198"></a>00198 <span class="comment">!</span>
- <a name="l00199"></a>00199 <span class="comment">! Local parameters:</span>
- <a name="l00200"></a>00200 <span class="comment">!</span>
- <a name="l00201"></a>00201 <span class="comment">! alist - list of left end points of all subintervals</span>
- <a name="l00202"></a>00202 <span class="comment">! considered up to now</span>
- <a name="l00203"></a>00203 <span class="comment">! blist - list of right end points of all subintervals</span>
- <a name="l00204"></a>00204 <span class="comment">! considered up to now</span>
- <a name="l00205"></a>00205 <span class="comment">! elist(i) - error estimate applying to rlist(i)</span>
- <a name="l00206"></a>00206 <span class="comment">! maxerr - pointer to the interval with largest error estimate</span>
- <a name="l00207"></a>00207 <span class="comment">! errmax - elist(maxerr)</span>
- <a name="l00208"></a>00208 <span class="comment">! area - sum of the integrals over the subintervals</span>
- <a name="l00209"></a>00209 <span class="comment">! errsum - sum of the errors over the subintervals</span>
- <a name="l00210"></a>00210 <span class="comment">! errbnd - requested accuracy max(epsabs,epsrel*abs(result))</span>
- <a name="l00211"></a>00211 <span class="comment">! *****1 - variable for the left subinterval</span>
- <a name="l00212"></a>00212 <span class="comment">! *****2 - variable for the right subinterval</span>
- <a name="l00213"></a>00213 <span class="comment">! last - index for subdivision</span>
- <a name="l00214"></a>00214 <span class="comment">!</span>
- <a name="l00215"></a>00215 <span class="keyword">implicit none</span>
- <a name="l00216"></a>00216
- <a name="l00217"></a>00217 <span class="keywordtype">integer</span> limit
- <a name="l00218"></a>00218
- <a name="l00219"></a>00219 <span class="keywordtype">real</span> a
- <a name="l00220"></a>00220 <span class="keywordtype">real</span> abserr
- <a name="l00221"></a>00221 <span class="keywordtype">real</span> alist(limit)
- <a name="l00222"></a>00222 <span class="keywordtype">real</span> area
- <a name="l00223"></a>00223 <span class="keywordtype">real</span> area1
- <a name="l00224"></a>00224 <span class="keywordtype">real</span> area12
- <a name="l00225"></a>00225 <span class="keywordtype">real</span> area2
- <a name="l00226"></a>00226 <span class="keywordtype">real</span> a1
- <a name="l00227"></a>00227 <span class="keywordtype">real</span> a2
- <a name="l00228"></a>00228 <span class="keywordtype">real</span> b
- <a name="l00229"></a>00229 <span class="keywordtype">real</span> blist(limit)
- <a name="l00230"></a>00230 <span class="keywordtype">real</span> b1
- <a name="l00231"></a>00231 <span class="keywordtype">real</span> b2
- <a name="l00232"></a>00232 <span class="keywordtype">real</span> c
- <a name="l00233"></a>00233 <span class="keywordtype">real</span> defabs
- <a name="l00234"></a>00234 <span class="keywordtype">real</span> defab1
- <a name="l00235"></a>00235 <span class="keywordtype">real</span> defab2
- <a name="l00236"></a>00236 <span class="keywordtype">real</span> elist(limit)
- <a name="l00237"></a>00237 <span class="keywordtype">real</span> epsabs
- <a name="l00238"></a>00238 <span class="keywordtype">real</span> epsrel
- <a name="l00239"></a>00239 <span class="keywordtype">real</span> errbnd
- <a name="l00240"></a>00240 <span class="keywordtype">real</span> errmax
- <a name="l00241"></a>00241 <span class="keywordtype">real</span> error1
- <a name="l00242"></a>00242 <span class="keywordtype">real</span> error2
- <a name="l00243"></a>00243 <span class="keywordtype">real</span> erro12
- <a name="l00244"></a>00244 <span class="keywordtype">real</span> errsum
- <a name="l00245"></a>00245 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l00246"></a>00246 <span class="keywordtype">integer</span> ier
- <a name="l00247"></a>00247 <span class="keywordtype">integer</span> iord(limit)
- <a name="l00248"></a>00248 <span class="keywordtype">integer</span> iroff1
- <a name="l00249"></a>00249 <span class="keywordtype">integer</span> iroff2
- <a name="l00250"></a>00250 <span class="keywordtype">integer</span> key
- <a name="l00251"></a>00251 <span class="keywordtype">integer</span> keyf
- <a name="l00252"></a>00252 <span class="keywordtype">integer</span> last
- <a name="l00253"></a>00253 <span class="keywordtype">integer</span> maxerr
- <a name="l00254"></a>00254 <span class="keywordtype">integer</span> neval
- <a name="l00255"></a>00255 <span class="keywordtype">integer</span> nrmax
- <a name="l00256"></a>00256 <span class="keywordtype">real</span> resabs
- <a name="l00257"></a>00257 <span class="keywordtype">real</span> result
- <a name="l00258"></a>00258 <span class="keywordtype">real</span> rlist(limit)
- <a name="l00259"></a>00259 <span class="comment">!</span>
- <a name="l00260"></a>00260 <span class="comment">! Test on validity of parameters.</span>
- <a name="l00261"></a>00261 <span class="comment">!</span>
- <a name="l00262"></a>00262 ier = 0
- <a name="l00263"></a>00263 neval = 0
- <a name="l00264"></a>00264 last = 0
- <a name="l00265"></a>00265 result = 0.0e+00
- <a name="l00266"></a>00266 abserr = 0.0e+00
- <a name="l00267"></a>00267 alist(1) = a
- <a name="l00268"></a>00268 blist(1) = b
- <a name="l00269"></a>00269 rlist(1) = 0.0e+00
- <a name="l00270"></a>00270 elist(1) = 0.0e+00
- <a name="l00271"></a>00271 iord(1) = 0
- <a name="l00272"></a>00272
- <a name="l00273"></a>00273 <span class="keyword">if</span> ( epsabs < 0.0e+00 .and. epsrel < 0.0e+00 ) <span class="keyword">then</span>
- <a name="l00274"></a>00274 ier = 6
- <a name="l00275"></a>00275 return
- <a name="l00276"></a>00276 <span class="keyword">end if</span>
- <a name="l00277"></a>00277 <span class="comment">!</span>
- <a name="l00278"></a>00278 <span class="comment">! First approximation to the integral.</span>
- <a name="l00279"></a>00279 <span class="comment">!</span>
- <a name="l00280"></a>00280 keyf = key
- <a name="l00281"></a>00281 keyf = max ( keyf, 1 )
- <a name="l00282"></a>00282 keyf = min ( keyf, 6 )
- <a name="l00283"></a>00283
- <a name="l00284"></a>00284 c = keyf
- <a name="l00285"></a>00285 neval = 0
- <a name="l00286"></a>00286
- <a name="l00287"></a>00287 <span class="keyword">if</span> ( keyf == 1 ) <span class="keyword">then</span>
- <a name="l00288"></a>00288 call <a class="code" href="quadpack_8f90.html#a1722ad5ba07cec52d38c9ebf9df80a2d">qk15 </a>( f, a, b, result, abserr, defabs, resabs )
- <a name="l00289"></a>00289 <span class="keyword">else</span> <span class="keyword">if</span> ( keyf == 2 ) <span class="keyword">then</span>
- <a name="l00290"></a>00290 call <a class="code" href="quadpack_8f90.html#a27241a527b249e9de59a5ed6bee5f805">qk21 </a>( f, a, b, result, abserr, defabs, resabs )
- <a name="l00291"></a>00291 <span class="keyword">else</span> <span class="keyword">if</span> ( keyf == 3 ) <span class="keyword">then</span>
- <a name="l00292"></a>00292 call <a class="code" href="quadpack_8f90.html#aded2e8dd2218fbd159b78c0e8975a4cd">qk31 </a>( f, a, b, result, abserr, defabs, resabs )
- <a name="l00293"></a>00293 <span class="keyword">else</span> <span class="keyword">if</span> ( keyf == 4 ) <span class="keyword">then</span>
- <a name="l00294"></a>00294 call <a class="code" href="quadpack_8f90.html#aface4edf24710a0b323f5aaeb6bdec34">qk41 </a>( f, a, b, result, abserr, defabs, resabs )
- <a name="l00295"></a>00295 <span class="keyword">else</span> <span class="keyword">if</span> ( keyf == 5 ) <span class="keyword">then</span>
- <a name="l00296"></a>00296 call <a class="code" href="quadpack_8f90.html#a73edb4987a87a40ebf4731ab63d7f03e">qk51 </a>( f, a, b, result, abserr, defabs, resabs )
- <a name="l00297"></a>00297 <span class="keyword">else</span> <span class="keyword">if</span> ( keyf == 6 ) <span class="keyword">then</span>
- <a name="l00298"></a>00298 call <a class="code" href="quadpack_8f90.html#acb4a48f5e54a2c5f951d0828e8f8146d">qk61 </a>( f, a, b, result, abserr, defabs, resabs )
- <a name="l00299"></a>00299 <span class="keyword">end if</span>
- <a name="l00300"></a>00300
- <a name="l00301"></a>00301 last = 1
- <a name="l00302"></a>00302 rlist(1) = result
- <a name="l00303"></a>00303 elist(1) = abserr
- <a name="l00304"></a>00304 iord(1) = 1
- <a name="l00305"></a>00305 <span class="comment">!</span>
- <a name="l00306"></a>00306 <span class="comment">! Test on accuracy.</span>
- <a name="l00307"></a>00307 <span class="comment">!</span>
- <a name="l00308"></a>00308 errbnd = max ( epsabs, epsrel * abs ( result ) )
- <a name="l00309"></a>00309
- <a name="l00310"></a>00310 <span class="keyword">if</span> ( abserr <= 5.0e+01 * epsilon ( defabs ) * defabs .and. &
- <a name="l00311"></a>00311 errbnd < abserr ) <span class="keyword">then</span>
- <a name="l00312"></a>00312 ier = 2
- <a name="l00313"></a>00313 <span class="keyword">end if</span>
- <a name="l00314"></a>00314
- <a name="l00315"></a>00315 <span class="keyword">if</span> ( limit == 1 ) <span class="keyword">then</span>
- <a name="l00316"></a>00316 ier = 1
- <a name="l00317"></a>00317 <span class="keyword">end if</span>
- <a name="l00318"></a>00318
- <a name="l00319"></a>00319 <span class="keyword">if</span> ( ier /= 0 .or. &
- <a name="l00320"></a>00320 ( abserr <= errbnd .and. abserr /= resabs ) .or. &
- <a name="l00321"></a>00321 abserr == 0.0e+00 ) <span class="keyword">then</span>
- <a name="l00322"></a>00322
- <a name="l00323"></a>00323 <span class="keyword">if</span> ( keyf /= 1 ) <span class="keyword">then</span>
- <a name="l00324"></a>00324 neval = (10*keyf+1) * (2*neval+1)
- <a name="l00325"></a>00325 <span class="keyword">else</span>
- <a name="l00326"></a>00326 neval = 30 * neval + 15
- <a name="l00327"></a>00327 <span class="keyword">end if</span>
- <a name="l00328"></a>00328
- <a name="l00329"></a>00329 return
- <a name="l00330"></a>00330
- <a name="l00331"></a>00331 <span class="keyword">end if</span>
- <a name="l00332"></a>00332 <span class="comment">!</span>
- <a name="l00333"></a>00333 <span class="comment">! Initialization.</span>
- <a name="l00334"></a>00334 <span class="comment">!</span>
- <a name="l00335"></a>00335 errmax = abserr
- <a name="l00336"></a>00336 maxerr = 1
- <a name="l00337"></a>00337 area = result
- <a name="l00338"></a>00338 errsum = abserr
- <a name="l00339"></a>00339 nrmax = 1
- <a name="l00340"></a>00340 iroff1 = 0
- <a name="l00341"></a>00341 iroff2 = 0
- <a name="l00342"></a>00342
- <a name="l00343"></a>00343 <span class="keyword">do</span> last = 2, limit
- <a name="l00344"></a>00344 <span class="comment">!</span>
- <a name="l00345"></a>00345 <span class="comment">! Bisect the subinterval with the largest error estimate.</span>
- <a name="l00346"></a>00346 <span class="comment">!</span>
- <a name="l00347"></a>00347 a1 = alist(maxerr)
- <a name="l00348"></a>00348 b1 = 0.5E+00 * ( alist(maxerr) + blist(maxerr) )
- <a name="l00349"></a>00349 a2 = b1
- <a name="l00350"></a>00350 b2 = blist(maxerr)
- <a name="l00351"></a>00351
- <a name="l00352"></a>00352 <span class="keyword">if</span> ( keyf == 1 ) <span class="keyword">then</span>
- <a name="l00353"></a>00353 call <a class="code" href="quadpack_8f90.html#a1722ad5ba07cec52d38c9ebf9df80a2d">qk15 </a>( f, a1, b1, area1, error1, resabs, defab1 )
- <a name="l00354"></a>00354 <span class="keyword">else</span> <span class="keyword">if</span> ( keyf == 2 ) <span class="keyword">then</span>
- <a name="l00355"></a>00355 call <a class="code" href="quadpack_8f90.html#a27241a527b249e9de59a5ed6bee5f805">qk21 </a>( f, a1, b1, area1, error1, resabs, defab1 )
- <a name="l00356"></a>00356 <span class="keyword">else</span> <span class="keyword">if</span> ( keyf == 3 ) <span class="keyword">then</span>
- <a name="l00357"></a>00357 call <a class="code" href="quadpack_8f90.html#aded2e8dd2218fbd159b78c0e8975a4cd">qk31 </a>( f, a1, b1, area1, error1, resabs, defab1 )
- <a name="l00358"></a>00358 <span class="keyword">else</span> <span class="keyword">if</span> ( keyf == 4 ) <span class="keyword">then</span>
- <a name="l00359"></a>00359 call <a class="code" href="quadpack_8f90.html#aface4edf24710a0b323f5aaeb6bdec34">qk41 </a>( f, a1, b1, area1, error1, resabs, defab1)
- <a name="l00360"></a>00360 <span class="keyword">else</span> <span class="keyword">if</span> ( keyf == 5 ) <span class="keyword">then</span>
- <a name="l00361"></a>00361 call <a class="code" href="quadpack_8f90.html#a73edb4987a87a40ebf4731ab63d7f03e">qk51 </a>( f, a1, b1, area1, error1, resabs, defab1 )
- <a name="l00362"></a>00362 <span class="keyword">else</span> <span class="keyword">if</span> ( keyf == 6 ) <span class="keyword">then</span>
- <a name="l00363"></a>00363 call <a class="code" href="quadpack_8f90.html#acb4a48f5e54a2c5f951d0828e8f8146d">qk61 </a>( f, a1, b1, area1, error1, resabs, defab1 )
- <a name="l00364"></a>00364 <span class="keyword">end if</span>
- <a name="l00365"></a>00365
- <a name="l00366"></a>00366 <span class="keyword">if</span> ( keyf == 1 ) <span class="keyword">then</span>
- <a name="l00367"></a>00367 call <a class="code" href="quadpack_8f90.html#a1722ad5ba07cec52d38c9ebf9df80a2d">qk15 </a>( f, a2, b2, area2, error2, resabs, defab2 )
- <a name="l00368"></a>00368 <span class="keyword">else</span> <span class="keyword">if</span> ( keyf == 2 ) <span class="keyword">then</span>
- <a name="l00369"></a>00369 call <a class="code" href="quadpack_8f90.html#a27241a527b249e9de59a5ed6bee5f805">qk21 </a>( f, a2, b2, area2, error2, resabs, defab2 )
- <a name="l00370"></a>00370 <span class="keyword">else</span> <span class="keyword">if</span> ( keyf == 3 ) <span class="keyword">then</span>
- <a name="l00371"></a>00371 call <a class="code" href="quadpack_8f90.html#aded2e8dd2218fbd159b78c0e8975a4cd">qk31 </a>( f, a2, b2, area2, error2, resabs, defab2 )
- <a name="l00372"></a>00372 <span class="keyword">else</span> <span class="keyword">if</span> ( keyf == 4 ) <span class="keyword">then</span>
- <a name="l00373"></a>00373 call <a class="code" href="quadpack_8f90.html#aface4edf24710a0b323f5aaeb6bdec34">qk41 </a>( f, a2, b2, area2, error2, resabs, defab2 )
- <a name="l00374"></a>00374 <span class="keyword">else</span> <span class="keyword">if</span> ( keyf == 5 ) <span class="keyword">then</span>
- <a name="l00375"></a>00375 call <a class="code" href="quadpack_8f90.html#a73edb4987a87a40ebf4731ab63d7f03e">qk51 </a>( f, a2, b2, area2, error2, resabs, defab2 )
- <a name="l00376"></a>00376 <span class="keyword">else</span> <span class="keyword">if</span> ( keyf == 6 ) <span class="keyword">then</span>
- <a name="l00377"></a>00377 call <a class="code" href="quadpack_8f90.html#acb4a48f5e54a2c5f951d0828e8f8146d">qk61 </a>( f, a2, b2, area2, error2, resabs, defab2 )
- <a name="l00378"></a>00378 <span class="keyword">end if</span>
- <a name="l00379"></a>00379 <span class="comment">!</span>
- <a name="l00380"></a>00380 <span class="comment">! Improve previous approximations to integral and error and</span>
- <a name="l00381"></a>00381 <span class="comment">! test for accuracy.</span>
- <a name="l00382"></a>00382 <span class="comment">!</span>
- <a name="l00383"></a>00383 neval = neval + 1
- <a name="l00384"></a>00384 area12 = area1 + area2
- <a name="l00385"></a>00385 erro12 = error1 + error2
- <a name="l00386"></a>00386 errsum = errsum + erro12 - errmax
- <a name="l00387"></a>00387 area = area + area12 - rlist(maxerr)
- <a name="l00388"></a>00388
- <a name="l00389"></a>00389 <span class="keyword">if</span> ( defab1 /= error1 .and. defab2 /= error2 ) <span class="keyword">then</span>
- <a name="l00390"></a>00390
- <a name="l00391"></a>00391 <span class="keyword">if</span> ( abs ( rlist(maxerr) - area12 ) <= 1.0e-05 * abs ( area12 ) &
- <a name="l00392"></a>00392 .and. 9.9e-01 * errmax <= erro12 ) <span class="keyword">then</span>
- <a name="l00393"></a>00393 iroff1 = iroff1 + 1
- <a name="l00394"></a>00394 <span class="keyword">end if</span>
- <a name="l00395"></a>00395
- <a name="l00396"></a>00396 <span class="keyword">if</span> ( 10 < last .and. errmax < erro12 ) <span class="keyword">then</span>
- <a name="l00397"></a>00397 iroff2 = iroff2 + 1
- <a name="l00398"></a>00398 <span class="keyword">end if</span>
- <a name="l00399"></a>00399
- <a name="l00400"></a>00400 <span class="keyword">end if</span>
- <a name="l00401"></a>00401
- <a name="l00402"></a>00402 rlist(maxerr) = area1
- <a name="l00403"></a>00403 rlist(last) = area2
- <a name="l00404"></a>00404 errbnd = max ( epsabs, epsrel * abs ( area ) )
- <a name="l00405"></a>00405 <span class="comment">!</span>
- <a name="l00406"></a>00406 <span class="comment">! Test for roundoff error and eventually set error flag.</span>
- <a name="l00407"></a>00407 <span class="comment">!</span>
- <a name="l00408"></a>00408 <span class="keyword">if</span> ( errbnd < errsum ) <span class="keyword">then</span>
- <a name="l00409"></a>00409
- <a name="l00410"></a>00410 <span class="keyword">if</span> ( 6 <= iroff1 .or. 20 <= iroff2 ) <span class="keyword">then</span>
- <a name="l00411"></a>00411 ier = 2
- <a name="l00412"></a>00412 <span class="keyword">end if</span>
- <a name="l00413"></a>00413 <span class="comment">!</span>
- <a name="l00414"></a>00414 <span class="comment">! Set error flag in the case that the number of subintervals</span>
- <a name="l00415"></a>00415 <span class="comment">! equals limit.</span>
- <a name="l00416"></a>00416 <span class="comment">!</span>
- <a name="l00417"></a>00417 <span class="keyword">if</span> ( last == limit ) <span class="keyword">then</span>
- <a name="l00418"></a>00418 ier = 1
- <a name="l00419"></a>00419 <span class="keyword">end if</span>
- <a name="l00420"></a>00420 <span class="comment">!</span>
- <a name="l00421"></a>00421 <span class="comment">! Set error flag in the case of bad integrand behavior</span>
- <a name="l00422"></a>00422 <span class="comment">! at a point of the integration range.</span>
- <a name="l00423"></a>00423 <span class="comment">!</span>
- <a name="l00424"></a>00424 <span class="keyword">if</span> ( max ( abs ( a1 ), abs ( b2 ) ) <= ( 1.0e+00 + c * 1.0e+03 * &
- <a name="l00425"></a>00425 epsilon ( a1 ) ) * ( abs ( a2 ) + 1.0e+04 * tiny ( a2 ) ) ) <span class="keyword">then</span>
- <a name="l00426"></a>00426 ier = 3
- <a name="l00427"></a>00427 <span class="keyword">end if</span>
- <a name="l00428"></a>00428
- <a name="l00429"></a>00429 <span class="keyword">end if</span>
- <a name="l00430"></a>00430 <span class="comment">!</span>
- <a name="l00431"></a>00431 <span class="comment">! Append the newly-created intervals to the list.</span>
- <a name="l00432"></a>00432 <span class="comment">!</span>
- <a name="l00433"></a>00433 <span class="keyword">if</span> ( error2 <= error1 ) <span class="keyword">then</span>
- <a name="l00434"></a>00434 alist(last) = a2
- <a name="l00435"></a>00435 blist(maxerr) = b1
- <a name="l00436"></a>00436 blist(last) = b2
- <a name="l00437"></a>00437 elist(maxerr) = error1
- <a name="l00438"></a>00438 elist(last) = error2
- <a name="l00439"></a>00439 <span class="keyword">else</span>
- <a name="l00440"></a>00440 alist(maxerr) = a2
- <a name="l00441"></a>00441 alist(last) = a1
- <a name="l00442"></a>00442 blist(last) = b1
- <a name="l00443"></a>00443 rlist(maxerr) = area2
- <a name="l00444"></a>00444 rlist(last) = area1
- <a name="l00445"></a>00445 elist(maxerr) = error2
- <a name="l00446"></a>00446 elist(last) = error1
- <a name="l00447"></a>00447 <span class="keyword">end if</span>
- <a name="l00448"></a>00448 <span class="comment">!</span>
- <a name="l00449"></a>00449 <span class="comment">! Call QSORT to maintain the descending ordering</span>
- <a name="l00450"></a>00450 <span class="comment">! in the list of error estimates and select the subinterval</span>
- <a name="l00451"></a>00451 <span class="comment">! with the largest error estimate (to be bisected next).</span>
- <a name="l00452"></a>00452 <span class="comment">!</span>
- <a name="l00453"></a>00453 call <a class="code" href="quadpack_8f90.html#a55e08a684c5a6315fb37dd0fdc66d8e6">qsort </a>( limit, last, maxerr, errmax, elist, iord, nrmax )
- <a name="l00454"></a>00454
- <a name="l00455"></a>00455 <span class="keyword">if</span> ( ier /= 0 .or. errsum <= errbnd ) <span class="keyword">then</span>
- <a name="l00456"></a>00456 exit
- <a name="l00457"></a>00457 <span class="keyword">end if</span>
- <a name="l00458"></a>00458
- <a name="l00459"></a>00459 <span class="keyword">end do</span>
- <a name="l00460"></a>00460 <span class="comment">!</span>
- <a name="l00461"></a>00461 <span class="comment">! Compute final result.</span>
- <a name="l00462"></a>00462 <span class="comment">!</span>
- <a name="l00463"></a>00463 result = sum ( rlist(1:last) )
- <a name="l00464"></a>00464
- <a name="l00465"></a>00465 abserr = errsum
- <a name="l00466"></a>00466
- <a name="l00467"></a>00467 <span class="keyword">if</span> ( keyf /= 1 ) <span class="keyword">then</span>
- <a name="l00468"></a>00468 neval = ( 10 * keyf + 1 ) * ( 2 * neval + 1 )
- <a name="l00469"></a>00469 <span class="keyword">else</span>
- <a name="l00470"></a>00470 neval = 30 * neval + 15
- <a name="l00471"></a>00471 <span class="keyword">end if</span>
- <a name="l00472"></a>00472
- <a name="l00473"></a>00473 return
- <a name="l00474"></a>00474 <span class="keyword">end</span>
- <a name="l00475"></a><a class="code" href="quadpack_8f90.html#ac59eaf7c56c1d421d129425895fa0107">00475</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#ac59eaf7c56c1d421d129425895fa0107">qagi</a> ( f, bound, inf, epsabs, epsrel, result, abserr, neval, ier )
- <a name="l00476"></a>00476
- <a name="l00477"></a>00477 <span class="comment">!*****************************************************************************80</span>
- <a name="l00478"></a>00478 <span class="comment">!</span>
- <a name="l00479"></a>00479 <span class="comment">!! QAGI estimates an integral over a semi-infinite or infinite interval.</span>
- <a name="l00480"></a>00480 <span class="comment">!</span>
- <a name="l00481"></a>00481 <span class="comment">! Discussion:</span>
- <a name="l00482"></a>00482 <span class="comment">!</span>
- <a name="l00483"></a>00483 <span class="comment">! The routine calculates an approximation RESULT to a definite integral </span>
- <a name="l00484"></a>00484 <span class="comment">! I = integral of F over (A, +Infinity), </span>
- <a name="l00485"></a>00485 <span class="comment">! or </span>
- <a name="l00486"></a>00486 <span class="comment">! I = integral of F over (-Infinity,A)</span>
- <a name="l00487"></a>00487 <span class="comment">! or </span>
- <a name="l00488"></a>00488 <span class="comment">! I = integral of F over (-Infinity,+Infinity),</span>
- <a name="l00489"></a>00489 <span class="comment">! hopefully satisfying</span>
- <a name="l00490"></a>00490 <span class="comment">! || I - RESULT || <= max ( EPSABS, EPSREL * ||I|| ).</span>
- <a name="l00491"></a>00491 <span class="comment">!</span>
- <a name="l00492"></a>00492 <span class="comment">! Author:</span>
- <a name="l00493"></a>00493 <span class="comment">!</span>
- <a name="l00494"></a>00494 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l00495"></a>00495 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l00496"></a>00496 <span class="comment">!</span>
- <a name="l00497"></a>00497 <span class="comment">! Reference:</span>
- <a name="l00498"></a>00498 <span class="comment">!</span>
- <a name="l00499"></a>00499 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l00500"></a>00500 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l00501"></a>00501 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l00502"></a>00502 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l00503"></a>00503 <span class="comment">!</span>
- <a name="l00504"></a>00504 <span class="comment">! Parameters:</span>
- <a name="l00505"></a>00505 <span class="comment">!</span>
- <a name="l00506"></a>00506 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l00507"></a>00507 <span class="comment">! function f ( x )</span>
- <a name="l00508"></a>00508 <span class="comment">! real f</span>
- <a name="l00509"></a>00509 <span class="comment">! real x</span>
- <a name="l00510"></a>00510 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l00511"></a>00511 <span class="comment">!</span>
- <a name="l00512"></a>00512 <span class="comment">! Input, real BOUND, the value of the finite endpoint of the integration</span>
- <a name="l00513"></a>00513 <span class="comment">! range, if any, that is, if INF is 1 or -1.</span>
- <a name="l00514"></a>00514 <span class="comment">!</span>
- <a name="l00515"></a>00515 <span class="comment">! Input, integer INF, indicates the type of integration range.</span>
- <a name="l00516"></a>00516 <span class="comment">! 1: ( BOUND, +Infinity),</span>
- <a name="l00517"></a>00517 <span class="comment">! -1: ( -Infinity, BOUND),</span>
- <a name="l00518"></a>00518 <span class="comment">! 2: ( -Infinity, +Infinity).</span>
- <a name="l00519"></a>00519 <span class="comment">!</span>
- <a name="l00520"></a>00520 <span class="comment">! Input, real EPSABS, EPSREL, the absolute and relative accuracy requested.</span>
- <a name="l00521"></a>00521 <span class="comment">!</span>
- <a name="l00522"></a>00522 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l00523"></a>00523 <span class="comment">!</span>
- <a name="l00524"></a>00524 <span class="comment">! Output, real ABSERR, an estimate of || I - RESULT ||.</span>
- <a name="l00525"></a>00525 <span class="comment">!</span>
- <a name="l00526"></a>00526 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l00527"></a>00527 <span class="comment">!</span>
- <a name="l00528"></a>00528 <span class="comment">! Output, integer IER, error indicator.</span>
- <a name="l00529"></a>00529 <span class="comment">! 0, normal and reliable termination of the routine. It is assumed that </span>
- <a name="l00530"></a>00530 <span class="comment">! the requested accuracy has been achieved.</span>
- <a name="l00531"></a>00531 <span class="comment">! > 0, abnormal termination of the routine. The estimates for result</span>
- <a name="l00532"></a>00532 <span class="comment">! and error are less reliable. It is assumed that the requested</span>
- <a name="l00533"></a>00533 <span class="comment">! accuracy has not been achieved.</span>
- <a name="l00534"></a>00534 <span class="comment">! 1, maximum number of subdivisions allowed has been achieved. One can </span>
- <a name="l00535"></a>00535 <span class="comment">! allow more subdivisions by increasing the data value of LIMIT in QAGI</span>
- <a name="l00536"></a>00536 <span class="comment">! (and taking the according dimension adjustments into account).</span>
- <a name="l00537"></a>00537 <span class="comment">! However, if this yields no improvement it is advised to analyze the</span>
- <a name="l00538"></a>00538 <span class="comment">! integrand in order to determine the integration difficulties. If the</span>
- <a name="l00539"></a>00539 <span class="comment">! position of a local difficulty can be determined (e.g. singularity,</span>
- <a name="l00540"></a>00540 <span class="comment">! discontinuity within the interval) one will probably gain from</span>
- <a name="l00541"></a>00541 <span class="comment">! splitting up the interval at this point and calling the integrator </span>
- <a name="l00542"></a>00542 <span class="comment">! on the subranges. If possible, an appropriate special-purpose </span>
- <a name="l00543"></a>00543 <span class="comment">! integrator should be used, which is designed for handling the type</span>
- <a name="l00544"></a>00544 <span class="comment">! of difficulty involved.</span>
- <a name="l00545"></a>00545 <span class="comment">! 2, the occurrence of roundoff error is detected, which prevents the</span>
- <a name="l00546"></a>00546 <span class="comment">! requested tolerance from being achieved. The error may be</span>
- <a name="l00547"></a>00547 <span class="comment">! under-estimated.</span>
- <a name="l00548"></a>00548 <span class="comment">! 3, extremely bad integrand behavior occurs at some points of the</span>
- <a name="l00549"></a>00549 <span class="comment">! integration interval.</span>
- <a name="l00550"></a>00550 <span class="comment">! 4, the algorithm does not converge. Roundoff error is detected in the</span>
- <a name="l00551"></a>00551 <span class="comment">! extrapolation table. It is assumed that the requested tolerance</span>
- <a name="l00552"></a>00552 <span class="comment">! cannot be achieved, and that the returned result is the best which </span>
- <a name="l00553"></a>00553 <span class="comment">! can be obtained.</span>
- <a name="l00554"></a>00554 <span class="comment">! 5, the integral is probably divergent, or slowly convergent. It must </span>
- <a name="l00555"></a>00555 <span class="comment">! be noted that divergence can occur with any other value of IER.</span>
- <a name="l00556"></a>00556 <span class="comment">! 6, the input is invalid, because INF /= 1 and INF /= -1 and INF /= 2, or</span>
- <a name="l00557"></a>00557 <span class="comment">! epsabs < 0 and epsrel < 0. result, abserr, neval are set to zero.</span>
- <a name="l00558"></a>00558 <span class="comment">!</span>
- <a name="l00559"></a>00559 <span class="comment">! Local parameters:</span>
- <a name="l00560"></a>00560 <span class="comment">!</span>
- <a name="l00561"></a>00561 <span class="comment">! the dimension of rlist2 is determined by the value of</span>
- <a name="l00562"></a>00562 <span class="comment">! limexp in QEXTR.</span>
- <a name="l00563"></a>00563 <span class="comment">!</span>
- <a name="l00564"></a>00564 <span class="comment">! alist - list of left end points of all subintervals</span>
- <a name="l00565"></a>00565 <span class="comment">! considered up to now</span>
- <a name="l00566"></a>00566 <span class="comment">! blist - list of right end points of all subintervals</span>
- <a name="l00567"></a>00567 <span class="comment">! considered up to now</span>
- <a name="l00568"></a>00568 <span class="comment">! rlist(i) - approximation to the integral over</span>
- <a name="l00569"></a>00569 <span class="comment">! (alist(i),blist(i))</span>
- <a name="l00570"></a>00570 <span class="comment">! rlist2 - array of dimension at least (limexp+2),</span>
- <a name="l00571"></a>00571 <span class="comment">! containing the part of the epsilon table</span>
- <a name="l00572"></a>00572 <span class="comment">! which is still needed for further computations</span>
- <a name="l00573"></a>00573 <span class="comment">! elist(i) - error estimate applying to rlist(i)</span>
- <a name="l00574"></a>00574 <span class="comment">! maxerr - pointer to the interval with largest error</span>
- <a name="l00575"></a>00575 <span class="comment">! estimate</span>
- <a name="l00576"></a>00576 <span class="comment">! errmax - elist(maxerr)</span>
- <a name="l00577"></a>00577 <span class="comment">! erlast - error on the interval currently subdivided</span>
- <a name="l00578"></a>00578 <span class="comment">! (before that subdivision has taken place)</span>
- <a name="l00579"></a>00579 <span class="comment">! area - sum of the integrals over the subintervals</span>
- <a name="l00580"></a>00580 <span class="comment">! errsum - sum of the errors over the subintervals</span>
- <a name="l00581"></a>00581 <span class="comment">! errbnd - requested accuracy max(epsabs,epsrel*</span>
- <a name="l00582"></a>00582 <span class="comment">! abs(result))</span>
- <a name="l00583"></a>00583 <span class="comment">! *****1 - variable for the left subinterval</span>
- <a name="l00584"></a>00584 <span class="comment">! *****2 - variable for the right subinterval</span>
- <a name="l00585"></a>00585 <span class="comment">! last - index for subdivision</span>
- <a name="l00586"></a>00586 <span class="comment">! nres - number of calls to the extrapolation routine</span>
- <a name="l00587"></a>00587 <span class="comment">! numrl2 - number of elements currently in rlist2. if an</span>
- <a name="l00588"></a>00588 <span class="comment">! appropriate approximation to the compounded</span>
- <a name="l00589"></a>00589 <span class="comment">! integral has been obtained, it is put in</span>
- <a name="l00590"></a>00590 <span class="comment">! rlist2(numrl2) after numrl2 has been increased</span>
- <a name="l00591"></a>00591 <span class="comment">! by one.</span>
- <a name="l00592"></a>00592 <span class="comment">! small - length of the smallest interval considered up</span>
- <a name="l00593"></a>00593 <span class="comment">! to now, multiplied by 1.5</span>
- <a name="l00594"></a>00594 <span class="comment">! erlarg - sum of the errors over the intervals larger</span>
- <a name="l00595"></a>00595 <span class="comment">! than the smallest interval considered up to now</span>
- <a name="l00596"></a>00596 <span class="comment">! extrap - logical variable denoting that the routine</span>
- <a name="l00597"></a>00597 <span class="comment">! is attempting to perform extrapolation. i.e.</span>
- <a name="l00598"></a>00598 <span class="comment">! before subdividing the smallest interval we</span>
- <a name="l00599"></a>00599 <span class="comment">! try to decrease the value of erlarg.</span>
- <a name="l00600"></a>00600 <span class="comment">! noext - logical variable denoting that extrapolation</span>
- <a name="l00601"></a>00601 <span class="comment">! is no longer allowed (true-value)</span>
- <a name="l00602"></a>00602 <span class="comment">!</span>
- <a name="l00603"></a>00603 <span class="keyword">implicit none</span>
- <a name="l00604"></a>00604
- <a name="l00605"></a>00605 <span class="keywordtype">integer</span>, <span class="keywordtype">parameter</span> :: limit = 500
- <a name="l00606"></a>00606
- <a name="l00607"></a>00607 <span class="keywordtype">real</span> abseps
- <a name="l00608"></a>00608 <span class="keywordtype">real</span> abserr
- <a name="l00609"></a>00609 <span class="keywordtype">real</span> alist(limit)
- <a name="l00610"></a>00610 <span class="keywordtype">real</span> area
- <a name="l00611"></a>00611 <span class="keywordtype">real</span> area1
- <a name="l00612"></a>00612 <span class="keywordtype">real</span> area12
- <a name="l00613"></a>00613 <span class="keywordtype">real</span> area2
- <a name="l00614"></a>00614 <span class="keywordtype">real</span> a1
- <a name="l00615"></a>00615 <span class="keywordtype">real</span> a2
- <a name="l00616"></a>00616 <span class="keywordtype">real</span> blist(limit)
- <a name="l00617"></a>00617 <span class="keywordtype">real</span> boun
- <a name="l00618"></a>00618 <span class="keywordtype">real</span> bound
- <a name="l00619"></a>00619 <span class="keywordtype">real</span> b1
- <a name="l00620"></a>00620 <span class="keywordtype">real</span> b2
- <a name="l00621"></a>00621 <span class="keywordtype">real</span> correc
- <a name="l00622"></a>00622 <span class="keywordtype">real</span> defabs
- <a name="l00623"></a>00623 <span class="keywordtype">real</span> defab1
- <a name="l00624"></a>00624 <span class="keywordtype">real</span> defab2
- <a name="l00625"></a>00625 <span class="keywordtype">real</span> dres
- <a name="l00626"></a>00626 <span class="keywordtype">real</span> elist(limit)
- <a name="l00627"></a>00627 <span class="keywordtype">real</span> epsabs
- <a name="l00628"></a>00628 <span class="keywordtype">real</span> epsrel
- <a name="l00629"></a>00629 <span class="keywordtype">real</span> erlarg
- <a name="l00630"></a>00630 <span class="keywordtype">real</span> erlast
- <a name="l00631"></a>00631 <span class="keywordtype">real</span> errbnd
- <a name="l00632"></a>00632 <span class="keywordtype">real</span> errmax
- <a name="l00633"></a>00633 <span class="keywordtype">real</span> error1
- <a name="l00634"></a>00634 <span class="keywordtype">real</span> error2
- <a name="l00635"></a>00635 <span class="keywordtype">real</span> erro12
- <a name="l00636"></a>00636 <span class="keywordtype">real</span> errsum
- <a name="l00637"></a>00637 <span class="keywordtype">real</span> ertest
- <a name="l00638"></a>00638 <span class="keywordtype">logical</span> extrap
- <a name="l00639"></a>00639 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l00640"></a>00640 <span class="keywordtype">integer</span> id
- <a name="l00641"></a>00641 <span class="keywordtype">integer</span> ier
- <a name="l00642"></a>00642 <span class="keywordtype">integer</span> ierro
- <a name="l00643"></a>00643 <span class="keywordtype">integer</span> inf
- <a name="l00644"></a>00644 <span class="keywordtype">integer</span> iord(limit)
- <a name="l00645"></a>00645 <span class="keywordtype">integer</span> iroff1
- <a name="l00646"></a>00646 <span class="keywordtype">integer</span> iroff2
- <a name="l00647"></a>00647 <span class="keywordtype">integer</span> iroff3
- <a name="l00648"></a>00648 <span class="keywordtype">integer</span> jupbnd
- <a name="l00649"></a>00649 <span class="keywordtype">integer</span> k
- <a name="l00650"></a>00650 <span class="keywordtype">integer</span> ksgn
- <a name="l00651"></a>00651 <span class="keywordtype">integer</span> ktmin
- <a name="l00652"></a>00652 <span class="keywordtype">integer</span> last
- <a name="l00653"></a>00653 <span class="keywordtype">integer</span> maxerr
- <a name="l00654"></a>00654 <span class="keywordtype">integer</span> neval
- <a name="l00655"></a>00655 <span class="keywordtype">logical</span> noext
- <a name="l00656"></a>00656 <span class="keywordtype">integer</span> nres
- <a name="l00657"></a>00657 <span class="keywordtype">integer</span> nrmax
- <a name="l00658"></a>00658 <span class="keywordtype">integer</span> numrl2
- <a name="l00659"></a>00659 <span class="keywordtype">real</span> resabs
- <a name="l00660"></a>00660 <span class="keywordtype">real</span> reseps
- <a name="l00661"></a>00661 <span class="keywordtype">real</span> result
- <a name="l00662"></a>00662 <span class="keywordtype">real</span> res3la(3)
- <a name="l00663"></a>00663 <span class="keywordtype">real</span> rlist(limit)
- <a name="l00664"></a>00664 <span class="keywordtype">real</span> rlist2(52)
- <a name="l00665"></a>00665 <span class="keywordtype">real</span> small
- <a name="l00666"></a>00666 <span class="comment">!</span>
- <a name="l00667"></a>00667 <span class="comment">! Test on validity of parameters.</span>
- <a name="l00668"></a>00668 <span class="comment">!</span>
- <a name="l00669"></a>00669 ier = 0
- <a name="l00670"></a>00670 neval = 0
- <a name="l00671"></a>00671 last = 0
- <a name="l00672"></a>00672 result = 0.0e+00
- <a name="l00673"></a>00673 abserr = 0.0e+00
- <a name="l00674"></a>00674 alist(1) = 0.0e+00
- <a name="l00675"></a>00675 blist(1) = 1.0e+00
- <a name="l00676"></a>00676 rlist(1) = 0.0e+00
- <a name="l00677"></a>00677 elist(1) = 0.0e+00
- <a name="l00678"></a>00678 iord(1) = 0
- <a name="l00679"></a>00679
- <a name="l00680"></a>00680 <span class="keyword">if</span> ( epsabs < 0.0e+00 .and. epsrel < 0.0e+00 ) <span class="keyword">then</span>
- <a name="l00681"></a>00681 ier = 6
- <a name="l00682"></a>00682 return
- <a name="l00683"></a>00683 <span class="keyword">end if</span>
- <a name="l00684"></a>00684 <span class="comment">!</span>
- <a name="l00685"></a>00685 <span class="comment">! First approximation to the integral.</span>
- <a name="l00686"></a>00686 <span class="comment">!</span>
- <a name="l00687"></a>00687 <span class="comment">! Determine the interval to be mapped onto (0,1).</span>
- <a name="l00688"></a>00688 <span class="comment">! If INF = 2 the integral is computed as i = i1+i2, where</span>
- <a name="l00689"></a>00689 <span class="comment">! i1 = integral of f over (-infinity,0),</span>
- <a name="l00690"></a>00690 <span class="comment">! i2 = integral of f over (0,+infinity).</span>
- <a name="l00691"></a>00691 <span class="comment">!</span>
- <a name="l00692"></a>00692 <span class="keyword">if</span> ( inf == 2 ) <span class="keyword">then</span>
- <a name="l00693"></a>00693 boun = 0.0e+00
- <a name="l00694"></a>00694 <span class="keyword">else</span>
- <a name="l00695"></a>00695 boun = bound
- <a name="l00696"></a>00696 <span class="keyword">end if</span>
- <a name="l00697"></a>00697
- <a name="l00698"></a>00698 call <a class="code" href="quadpack_8f90.html#a59164415fc33f2f3bf4ebc4ee2220f7e">qk15i </a>( f, boun, inf, 0.0e+00, 1.0e+00, result, abserr, defabs, resabs )
- <a name="l00699"></a>00699 <span class="comment">!</span>
- <a name="l00700"></a>00700 <span class="comment">! Test on accuracy.</span>
- <a name="l00701"></a>00701 <span class="comment">!</span>
- <a name="l00702"></a>00702 last = 1
- <a name="l00703"></a>00703 rlist(1) = result
- <a name="l00704"></a>00704 elist(1) = abserr
- <a name="l00705"></a>00705 iord(1) = 1
- <a name="l00706"></a>00706 dres = abs ( result )
- <a name="l00707"></a>00707 errbnd = max ( epsabs, epsrel * dres )
- <a name="l00708"></a>00708
- <a name="l00709"></a>00709 <span class="keyword">if</span> ( abserr <= 100.0E+00 * epsilon ( defabs ) * defabs .and. &
- <a name="l00710"></a>00710 errbnd < abserr ) <span class="keyword">then</span>
- <a name="l00711"></a>00711 ier = 2
- <a name="l00712"></a>00712 <span class="keyword">end if</span>
- <a name="l00713"></a>00713
- <a name="l00714"></a>00714 <span class="keyword">if</span> ( limit == 1 ) <span class="keyword">then</span>
- <a name="l00715"></a>00715 ier = 1
- <a name="l00716"></a>00716 <span class="keyword">end if</span>
- <a name="l00717"></a>00717
- <a name="l00718"></a>00718 <span class="keyword">if</span> ( ier /= 0 .or. (abserr <= errbnd .and. abserr /= resabs ) .or. &
- <a name="l00719"></a>00719 abserr == 0.0e+00 ) go to 130
- <a name="l00720"></a>00720 <span class="comment">!</span>
- <a name="l00721"></a>00721 <span class="comment">! Initialization.</span>
- <a name="l00722"></a>00722 <span class="comment">!</span>
- <a name="l00723"></a>00723 rlist2(1) = result
- <a name="l00724"></a>00724 errmax = abserr
- <a name="l00725"></a>00725 maxerr = 1
- <a name="l00726"></a>00726 area = result
- <a name="l00727"></a>00727 errsum = abserr
- <a name="l00728"></a>00728 abserr = huge ( abserr )
- <a name="l00729"></a>00729 nrmax = 1
- <a name="l00730"></a>00730 nres = 0
- <a name="l00731"></a>00731 ktmin = 0
- <a name="l00732"></a>00732 numrl2 = 2
- <a name="l00733"></a>00733 extrap = .false.
- <a name="l00734"></a>00734 noext = .false.
- <a name="l00735"></a>00735 ierro = 0
- <a name="l00736"></a>00736 iroff1 = 0
- <a name="l00737"></a>00737 iroff2 = 0
- <a name="l00738"></a>00738 iroff3 = 0
- <a name="l00739"></a>00739
- <a name="l00740"></a>00740 <span class="keyword">if</span> ( ( 1.0e+00 - 5.0e+01 * epsilon ( defabs ) ) * defabs <= dres ) <span class="keyword">then</span>
- <a name="l00741"></a>00741 ksgn = 1
- <a name="l00742"></a>00742 <span class="keyword">else</span>
- <a name="l00743"></a>00743 ksgn = -1
- <a name="l00744"></a>00744 <span class="keyword">end if</span>
- <a name="l00745"></a>00745
- <a name="l00746"></a>00746 <span class="keyword">do</span> last = 2, limit
- <a name="l00747"></a>00747 <span class="comment">!</span>
- <a name="l00748"></a>00748 <span class="comment">! Bisect the subinterval with nrmax-th largest error estimate.</span>
- <a name="l00749"></a>00749 <span class="comment">!</span>
- <a name="l00750"></a>00750 a1 = alist(maxerr)
- <a name="l00751"></a>00751 b1 = 5.0e-01 * ( alist(maxerr) + blist(maxerr) )
- <a name="l00752"></a>00752 a2 = b1
- <a name="l00753"></a>00753 b2 = blist(maxerr)
- <a name="l00754"></a>00754 erlast = errmax
- <a name="l00755"></a>00755 call <a class="code" href="quadpack_8f90.html#a59164415fc33f2f3bf4ebc4ee2220f7e">qk15i </a>( f, boun, inf, a1, b1, area1, error1, resabs, defab1 )
- <a name="l00756"></a>00756 call <a class="code" href="quadpack_8f90.html#a59164415fc33f2f3bf4ebc4ee2220f7e">qk15i </a>( f, boun, inf, a2, b2, area2, error2, resabs, defab2 )
- <a name="l00757"></a>00757 <span class="comment">!</span>
- <a name="l00758"></a>00758 <span class="comment">! Improve previous approximations to integral and error</span>
- <a name="l00759"></a>00759 <span class="comment">! and test for accuracy.</span>
- <a name="l00760"></a>00760 <span class="comment">!</span>
- <a name="l00761"></a>00761 area12 = area1 + area2
- <a name="l00762"></a>00762 erro12 = error1 + error2
- <a name="l00763"></a>00763 errsum = errsum + erro12 - errmax
- <a name="l00764"></a>00764 area = area + area12 - rlist(maxerr)
- <a name="l00765"></a>00765
- <a name="l00766"></a>00766 <span class="keyword">if</span> ( defab1 /= error1 .and. defab2 /= error2 ) <span class="keyword">then</span>
- <a name="l00767"></a>00767
- <a name="l00768"></a>00768 <span class="keyword">if</span> ( abs ( rlist(maxerr) - area12 ) <= 1.0e-05 * abs ( area12 ) &
- <a name="l00769"></a>00769 .and. 9.9e-01 * errmax <= erro12 ) <span class="keyword">then</span>
- <a name="l00770"></a>00770
- <a name="l00771"></a>00771 <span class="keyword">if</span> ( extrap ) <span class="keyword">then</span>
- <a name="l00772"></a>00772 iroff2 = iroff2 + 1
- <a name="l00773"></a>00773 <span class="keyword">end if</span>
- <a name="l00774"></a>00774
- <a name="l00775"></a>00775 <span class="keyword">if</span> ( .not. extrap ) <span class="keyword">then</span>
- <a name="l00776"></a>00776 iroff1 = iroff1 + 1
- <a name="l00777"></a>00777 <span class="keyword">end if</span>
- <a name="l00778"></a>00778
- <a name="l00779"></a>00779 <span class="keyword">end if</span>
- <a name="l00780"></a>00780
- <a name="l00781"></a>00781 <span class="keyword">if</span> ( 10 < last .and. errmax < erro12 ) <span class="keyword">then</span>
- <a name="l00782"></a>00782 iroff3 = iroff3 + 1
- <a name="l00783"></a>00783 <span class="keyword">end if</span>
- <a name="l00784"></a>00784
- <a name="l00785"></a>00785 <span class="keyword">end if</span>
- <a name="l00786"></a>00786
- <a name="l00787"></a>00787 rlist(maxerr) = area1
- <a name="l00788"></a>00788 rlist(last) = area2
- <a name="l00789"></a>00789 errbnd = max ( epsabs, epsrel * abs ( area ) )
- <a name="l00790"></a>00790 <span class="comment">!</span>
- <a name="l00791"></a>00791 <span class="comment">! Test for roundoff error and eventually set error flag.</span>
- <a name="l00792"></a>00792 <span class="comment">!</span>
- <a name="l00793"></a>00793 <span class="keyword">if</span> ( 10 <= iroff1 + iroff2 .or. 20 <= iroff3 ) <span class="keyword">then</span>
- <a name="l00794"></a>00794 ier = 2
- <a name="l00795"></a>00795 <span class="keyword">end if</span>
- <a name="l00796"></a>00796
- <a name="l00797"></a>00797 <span class="keyword">if</span> ( 5 <= iroff2 ) <span class="keyword">then</span>
- <a name="l00798"></a>00798 ierro = 3
- <a name="l00799"></a>00799 <span class="keyword">end if</span>
- <a name="l00800"></a>00800 <span class="comment">!</span>
- <a name="l00801"></a>00801 <span class="comment">! Set error flag in the case that the number of subintervals equals LIMIT.</span>
- <a name="l00802"></a>00802 <span class="comment">!</span>
- <a name="l00803"></a>00803 <span class="keyword">if</span> ( last == limit ) <span class="keyword">then</span>
- <a name="l00804"></a>00804 ier = 1
- <a name="l00805"></a>00805 <span class="keyword">end if</span>
- <a name="l00806"></a>00806 <span class="comment">!</span>
- <a name="l00807"></a>00807 <span class="comment">! Set error flag in the case of bad integrand behavior</span>
- <a name="l00808"></a>00808 <span class="comment">! at some points of the integration range.</span>
- <a name="l00809"></a>00809 <span class="comment">!</span>
- <a name="l00810"></a>00810 <span class="keyword">if</span> ( max ( abs(a1), abs(b2) ) <= (1.0e+00 + 1.0e+03 * epsilon ( a1 ) ) * &
- <a name="l00811"></a>00811 ( abs(a2) + 1.0e+03 * tiny ( a2 ) )) <span class="keyword">then</span>
- <a name="l00812"></a>00812 ier = 4
- <a name="l00813"></a>00813 <span class="keyword">end if</span>
- <a name="l00814"></a>00814 <span class="comment">!</span>
- <a name="l00815"></a>00815 <span class="comment">! Append the newly-created intervals to the list.</span>
- <a name="l00816"></a>00816 <span class="comment">!</span>
- <a name="l00817"></a>00817 <span class="keyword">if</span> ( error2 <= error1 ) <span class="keyword">then</span>
- <a name="l00818"></a>00818 alist(last) = a2
- <a name="l00819"></a>00819 blist(maxerr) = b1
- <a name="l00820"></a>00820 blist(last) = b2
- <a name="l00821"></a>00821 elist(maxerr) = error1
- <a name="l00822"></a>00822 elist(last) = error2
- <a name="l00823"></a>00823 <span class="keyword">else</span>
- <a name="l00824"></a>00824 alist(maxerr) = a2
- <a name="l00825"></a>00825 alist(last) = a1
- <a name="l00826"></a>00826 blist(last) = b1
- <a name="l00827"></a>00827 rlist(maxerr) = area2
- <a name="l00828"></a>00828 rlist(last) = area1
- <a name="l00829"></a>00829 elist(maxerr) = error2
- <a name="l00830"></a>00830 elist(last) = error1
- <a name="l00831"></a>00831 <span class="keyword">end if</span>
- <a name="l00832"></a>00832 <span class="comment">!</span>
- <a name="l00833"></a>00833 <span class="comment">! Call QSORT to maintain the descending ordering</span>
- <a name="l00834"></a>00834 <span class="comment">! in the list of error estimates and select the subinterval</span>
- <a name="l00835"></a>00835 <span class="comment">! with NRMAX-th largest error estimate (to be bisected next).</span>
- <a name="l00836"></a>00836 <span class="comment">!</span>
- <a name="l00837"></a>00837 call <a class="code" href="quadpack_8f90.html#a55e08a684c5a6315fb37dd0fdc66d8e6">qsort </a>( limit, last, maxerr, errmax, elist, iord, nrmax )
- <a name="l00838"></a>00838
- <a name="l00839"></a>00839 <span class="keyword">if</span> ( errsum <= errbnd ) go to 115
- <a name="l00840"></a>00840
- <a name="l00841"></a>00841 <span class="keyword">if</span> ( ier /= 0 ) <span class="keyword">then</span>
- <a name="l00842"></a>00842 exit
- <a name="l00843"></a>00843 <span class="keyword">end if</span>
- <a name="l00844"></a>00844
- <a name="l00845"></a>00845 <span class="keyword">if</span> ( last == 2 ) <span class="keyword">then</span>
- <a name="l00846"></a>00846 small = 3.75e-01
- <a name="l00847"></a>00847 erlarg = errsum
- <a name="l00848"></a>00848 ertest = errbnd
- <a name="l00849"></a>00849 rlist2(2) = area
- <a name="l00850"></a>00850 cycle
- <a name="l00851"></a>00851 <span class="keyword">end if</span>
- <a name="l00852"></a>00852
- <a name="l00853"></a>00853 <span class="keyword">if</span> ( noext ) <span class="keyword">then</span>
- <a name="l00854"></a>00854 cycle
- <a name="l00855"></a>00855 <span class="keyword">end if</span>
- <a name="l00856"></a>00856
- <a name="l00857"></a>00857 erlarg = erlarg - erlast
- <a name="l00858"></a>00858
- <a name="l00859"></a>00859 <span class="keyword">if</span> ( small < abs ( b1 - a1 ) ) <span class="keyword">then</span>
- <a name="l00860"></a>00860 erlarg = erlarg + erro12
- <a name="l00861"></a>00861 <span class="keyword">end if</span>
- <a name="l00862"></a>00862 <span class="comment">!</span>
- <a name="l00863"></a>00863 <span class="comment">! Test whether the interval to be bisected next is the</span>
- <a name="l00864"></a>00864 <span class="comment">! smallest interval.</span>
- <a name="l00865"></a>00865 <span class="comment">!</span>
- <a name="l00866"></a>00866 <span class="keyword">if</span> ( .not. extrap ) <span class="keyword">then</span>
- <a name="l00867"></a>00867
- <a name="l00868"></a>00868 <span class="keyword">if</span> ( small < abs ( blist(maxerr) - alist(maxerr) ) ) <span class="keyword">then</span>
- <a name="l00869"></a>00869 cycle
- <a name="l00870"></a>00870 <span class="keyword">end if</span>
- <a name="l00871"></a>00871
- <a name="l00872"></a>00872 extrap = .true.
- <a name="l00873"></a>00873 nrmax = 2
- <a name="l00874"></a>00874
- <a name="l00875"></a>00875 <span class="keyword">end if</span>
- <a name="l00876"></a>00876
- <a name="l00877"></a>00877 <span class="keyword">if</span> ( ierro == 3 .or. erlarg <= ertest ) <span class="keyword">then</span>
- <a name="l00878"></a>00878 go to 60
- <a name="l00879"></a>00879 <span class="keyword">end if</span>
- <a name="l00880"></a>00880 <span class="comment">!</span>
- <a name="l00881"></a>00881 <span class="comment">! The smallest interval has the largest error.</span>
- <a name="l00882"></a>00882 <span class="comment">! before bisecting decrease the sum of the errors over the</span>
- <a name="l00883"></a>00883 <span class="comment">! larger intervals (erlarg) and perform extrapolation.</span>
- <a name="l00884"></a>00884 <span class="comment">!</span>
- <a name="l00885"></a>00885 id = nrmax
- <a name="l00886"></a>00886 jupbnd = last
- <a name="l00887"></a>00887
- <a name="l00888"></a>00888 <span class="keyword">if</span> ( (2+limit/2) < last ) <span class="keyword">then</span>
- <a name="l00889"></a>00889 jupbnd = limit + 3 - last
- <a name="l00890"></a>00890 <span class="keyword">end if</span>
- <a name="l00891"></a>00891
- <a name="l00892"></a>00892 <span class="keyword">do</span> k = id, jupbnd
- <a name="l00893"></a>00893 maxerr = iord(nrmax)
- <a name="l00894"></a>00894 errmax = elist(maxerr)
- <a name="l00895"></a>00895 <span class="keyword">if</span> ( small < abs ( blist(maxerr) - alist(maxerr) ) ) <span class="keyword">then</span>
- <a name="l00896"></a>00896 go to 90
- <a name="l00897"></a>00897 <span class="keyword">end if</span>
- <a name="l00898"></a>00898 nrmax = nrmax + 1
- <a name="l00899"></a>00899 <span class="keyword">end do</span>
- <a name="l00900"></a>00900 <span class="comment">!</span>
- <a name="l00901"></a>00901 <span class="comment">! Extrapolate.</span>
- <a name="l00902"></a>00902 <span class="comment">!</span>
- <a name="l00903"></a>00903 60 continue
- <a name="l00904"></a>00904
- <a name="l00905"></a>00905 numrl2 = numrl2 + 1
- <a name="l00906"></a>00906 rlist2(numrl2) = area
- <a name="l00907"></a>00907 call <a class="code" href="quadpack_8f90.html#a5a75101d080f224c63adde98a0e64386">qextr </a>( numrl2, rlist2, reseps, abseps, res3la, nres )
- <a name="l00908"></a>00908 ktmin = ktmin+1
- <a name="l00909"></a>00909
- <a name="l00910"></a>00910 <span class="keyword">if</span> ( 5 < ktmin .and. abserr < 1.0e-03 * errsum ) <span class="keyword">then</span>
- <a name="l00911"></a>00911 ier = 5
- <a name="l00912"></a>00912 <span class="keyword">end if</span>
- <a name="l00913"></a>00913
- <a name="l00914"></a>00914 <span class="keyword">if</span> ( abseps < abserr ) <span class="keyword">then</span>
- <a name="l00915"></a>00915
- <a name="l00916"></a>00916 ktmin = 0
- <a name="l00917"></a>00917 abserr = abseps
- <a name="l00918"></a>00918 result = reseps
- <a name="l00919"></a>00919 correc = erlarg
- <a name="l00920"></a>00920 ertest = max ( epsabs, epsrel * abs(reseps) )
- <a name="l00921"></a>00921
- <a name="l00922"></a>00922 <span class="keyword">if</span> ( abserr <= ertest ) <span class="keyword">then</span>
- <a name="l00923"></a>00923 exit
- <a name="l00924"></a>00924 <span class="keyword">end if</span>
- <a name="l00925"></a>00925
- <a name="l00926"></a>00926 <span class="keyword">end if</span>
- <a name="l00927"></a>00927 <span class="comment">!</span>
- <a name="l00928"></a>00928 <span class="comment">! Prepare bisection of the smallest interval.</span>
- <a name="l00929"></a>00929 <span class="comment">!</span>
- <a name="l00930"></a>00930 <span class="keyword">if</span> ( numrl2 == 1 ) <span class="keyword">then</span>
- <a name="l00931"></a>00931 noext = .true.
- <a name="l00932"></a>00932 <span class="keyword">end if</span>
- <a name="l00933"></a>00933
- <a name="l00934"></a>00934 <span class="keyword">if</span> ( ier == 5 ) <span class="keyword">then</span>
- <a name="l00935"></a>00935 exit
- <a name="l00936"></a>00936 <span class="keyword">end if</span>
- <a name="l00937"></a>00937
- <a name="l00938"></a>00938 maxerr = iord(1)
- <a name="l00939"></a>00939 errmax = elist(maxerr)
- <a name="l00940"></a>00940 nrmax = 1
- <a name="l00941"></a>00941 extrap = .false.
- <a name="l00942"></a>00942 small = small * 5.0e-01
- <a name="l00943"></a>00943 erlarg = errsum
- <a name="l00944"></a>00944
- <a name="l00945"></a>00945 90 continue
- <a name="l00946"></a>00946
- <a name="l00947"></a>00947 <span class="keyword">end do</span>
- <a name="l00948"></a>00948 <span class="comment">!</span>
- <a name="l00949"></a>00949 <span class="comment">! Set final result and error estimate.</span>
- <a name="l00950"></a>00950 <span class="comment">!</span>
- <a name="l00951"></a>00951 <span class="keyword">if</span> ( abserr == huge ( abserr ) ) <span class="keyword">then</span>
- <a name="l00952"></a>00952 go to 115
- <a name="l00953"></a>00953 <span class="keyword">end if</span>
- <a name="l00954"></a>00954
- <a name="l00955"></a>00955 <span class="keyword">if</span> ( ( ier + ierro ) == 0 ) <span class="keyword">then</span>
- <a name="l00956"></a>00956 go to 110
- <a name="l00957"></a>00957 <span class="keyword">end if</span>
- <a name="l00958"></a>00958
- <a name="l00959"></a>00959 <span class="keyword">if</span> ( ierro == 3 ) <span class="keyword">then</span>
- <a name="l00960"></a>00960 abserr = abserr + correc
- <a name="l00961"></a>00961 <span class="keyword">end if</span>
- <a name="l00962"></a>00962
- <a name="l00963"></a>00963 <span class="keyword">if</span> ( ier == 0 ) <span class="keyword">then</span>
- <a name="l00964"></a>00964 ier = 3
- <a name="l00965"></a>00965 <span class="keyword">end if</span>
- <a name="l00966"></a>00966
- <a name="l00967"></a>00967 <span class="keyword">if</span> ( result /= 0.0e+00 .and. area /= 0.0e+00) <span class="keyword">then</span>
- <a name="l00968"></a>00968 go to 105
- <a name="l00969"></a>00969 <span class="keyword">end if</span>
- <a name="l00970"></a>00970
- <a name="l00971"></a>00971 <span class="keyword">if</span> ( errsum < abserr ) <span class="keyword">then</span>
- <a name="l00972"></a>00972 go to 115
- <a name="l00973"></a>00973 <span class="keyword">end if</span>
- <a name="l00974"></a>00974
- <a name="l00975"></a>00975 <span class="keyword">if</span> ( area == 0.0e+00 ) <span class="keyword">then</span>
- <a name="l00976"></a>00976 go to 130
- <a name="l00977"></a>00977 <span class="keyword">end if</span>
- <a name="l00978"></a>00978
- <a name="l00979"></a>00979 go to 110
- <a name="l00980"></a>00980
- <a name="l00981"></a>00981 105 continue
- <a name="l00982"></a>00982
- <a name="l00983"></a>00983 <span class="keyword">if</span> ( errsum / abs ( area ) < abserr / abs ( result ) ) <span class="keyword">then</span>
- <a name="l00984"></a>00984 go to 115
- <a name="l00985"></a>00985 <span class="keyword">end if</span>
- <a name="l00986"></a>00986 <span class="comment">!</span>
- <a name="l00987"></a>00987 <span class="comment">! Test on divergence</span>
- <a name="l00988"></a>00988 <span class="comment">!</span>
- <a name="l00989"></a>00989 110 continue
- <a name="l00990"></a>00990
- <a name="l00991"></a>00991 <span class="keyword">if</span> ( ksgn == (-1) .and. &
- <a name="l00992"></a>00992 max ( abs(result), abs(area) ) <= defabs * 1.0e-02) go to 130
- <a name="l00993"></a>00993
- <a name="l00994"></a>00994 <span class="keyword">if</span> ( 1.0e-02 > (result/area) .or. &
- <a name="l00995"></a>00995 (result/area) > 1.0e+02 .or. &
- <a name="l00996"></a>00996 errsum > abs(area)) <span class="keyword">then</span>
- <a name="l00997"></a>00997 ier = 6
- <a name="l00998"></a>00998 <span class="keyword">end if</span>
- <a name="l00999"></a>00999
- <a name="l01000"></a>01000 go to 130
- <a name="l01001"></a>01001 <span class="comment">!</span>
- <a name="l01002"></a>01002 <span class="comment">! Compute global integral sum.</span>
- <a name="l01003"></a>01003 <span class="comment">!</span>
- <a name="l01004"></a>01004 115 continue
- <a name="l01005"></a>01005
- <a name="l01006"></a>01006 result = sum ( rlist(1:last) )
- <a name="l01007"></a>01007
- <a name="l01008"></a>01008 abserr = errsum
- <a name="l01009"></a>01009 130 continue
- <a name="l01010"></a>01010
- <a name="l01011"></a>01011 neval = 30 * last - 15
- <a name="l01012"></a>01012 <span class="keyword">if</span> ( inf == 2 ) <span class="keyword">then</span>
- <a name="l01013"></a>01013 neval = 2 * neval
- <a name="l01014"></a>01014 <span class="keyword">end if</span>
- <a name="l01015"></a>01015
- <a name="l01016"></a>01016 <span class="keyword">if</span> ( 2 < ier ) <span class="keyword">then</span>
- <a name="l01017"></a>01017 ier = ier - 1
- <a name="l01018"></a>01018 <span class="keyword">end if</span>
- <a name="l01019"></a>01019
- <a name="l01020"></a>01020 return
- <a name="l01021"></a>01021 <span class="keyword">end</span>
- <a name="l01022"></a><a class="code" href="quadpack_8f90.html#a99cf2a02a14029fad4762555f04cac0e">01022</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#a99cf2a02a14029fad4762555f04cac0e">qagp</a> ( f, a, b, npts2, points, epsabs, epsrel, result, abserr, &
- <a name="l01023"></a>01023 neval, ier )
- <a name="l01024"></a>01024
- <a name="l01025"></a>01025 <span class="comment">!*****************************************************************************80</span>
- <a name="l01026"></a>01026 <span class="comment">!</span>
- <a name="l01027"></a>01027 <span class="comment">!! QAGP computes a definite integral.</span>
- <a name="l01028"></a>01028 <span class="comment">!</span>
- <a name="l01029"></a>01029 <span class="comment">! Discussion:</span>
- <a name="l01030"></a>01030 <span class="comment">!</span>
- <a name="l01031"></a>01031 <span class="comment">! The routine calculates an approximation RESULT to a definite integral </span>
- <a name="l01032"></a>01032 <span class="comment">! I = integral of F over (A,B),</span>
- <a name="l01033"></a>01033 <span class="comment">! hopefully satisfying</span>
- <a name="l01034"></a>01034 <span class="comment">! || I - RESULT || <= max ( EPSABS, EPSREL * ||I|| ).</span>
- <a name="l01035"></a>01035 <span class="comment">!</span>
- <a name="l01036"></a>01036 <span class="comment">! Interior break points of the integration interval,</span>
- <a name="l01037"></a>01037 <span class="comment">! where local difficulties of the integrand may occur, such as</span>
- <a name="l01038"></a>01038 <span class="comment">! singularities or discontinuities, are provided by the user.</span>
- <a name="l01039"></a>01039 <span class="comment">!</span>
- <a name="l01040"></a>01040 <span class="comment">! Author:</span>
- <a name="l01041"></a>01041 <span class="comment">!</span>
- <a name="l01042"></a>01042 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l01043"></a>01043 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l01044"></a>01044 <span class="comment">!</span>
- <a name="l01045"></a>01045 <span class="comment">! Reference:</span>
- <a name="l01046"></a>01046 <span class="comment">!</span>
- <a name="l01047"></a>01047 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l01048"></a>01048 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l01049"></a>01049 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l01050"></a>01050 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l01051"></a>01051 <span class="comment">!</span>
- <a name="l01052"></a>01052 <span class="comment">! Parameters:</span>
- <a name="l01053"></a>01053 <span class="comment">!</span>
- <a name="l01054"></a>01054 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l01055"></a>01055 <span class="comment">! function f ( x )</span>
- <a name="l01056"></a>01056 <span class="comment">! real f</span>
- <a name="l01057"></a>01057 <span class="comment">! real x</span>
- <a name="l01058"></a>01058 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l01059"></a>01059 <span class="comment">!</span>
- <a name="l01060"></a>01060 <span class="comment">! Input, real A, B, the limits of integration.</span>
- <a name="l01061"></a>01061 <span class="comment">!</span>
- <a name="l01062"></a>01062 <span class="comment">! Input, integer NPTS2, the number of user-supplied break points within </span>
- <a name="l01063"></a>01063 <span class="comment">! the integration range, plus 2. NPTS2 must be at least 2.</span>
- <a name="l01064"></a>01064 <span class="comment">!</span>
- <a name="l01065"></a>01065 <span class="comment">! Input/output, real POINTS(NPTS2), contains the user provided interior</span>
- <a name="l01066"></a>01066 <span class="comment">! breakpoints in entries 1 through NPTS2-2. If these points are not</span>
- <a name="l01067"></a>01067 <span class="comment">! in ascending order on input, they will be sorted.</span>
- <a name="l01068"></a>01068 <span class="comment">!</span>
- <a name="l01069"></a>01069 <span class="comment">! Input, real EPSABS, EPSREL, the absolute and relative accuracy requested.</span>
- <a name="l01070"></a>01070 <span class="comment">!</span>
- <a name="l01071"></a>01071 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l01072"></a>01072 <span class="comment">!</span>
- <a name="l01073"></a>01073 <span class="comment">! Output, real ABSERR, an estimate of || I - RESULT ||.</span>
- <a name="l01074"></a>01074 <span class="comment">!</span>
- <a name="l01075"></a>01075 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l01076"></a>01076 <span class="comment">!</span>
- <a name="l01077"></a>01077 <span class="comment">! Output, integer IER, return flag.</span>
- <a name="l01078"></a>01078 <span class="comment">! ier = 0 normal and reliable termination of the</span>
- <a name="l01079"></a>01079 <span class="comment">! routine. it is assumed that the requested</span>
- <a name="l01080"></a>01080 <span class="comment">! accuracy has been achieved.</span>
- <a name="l01081"></a>01081 <span class="comment">! ier > 0 abnormal termination of the routine.</span>
- <a name="l01082"></a>01082 <span class="comment">! the estimates for integral and error are</span>
- <a name="l01083"></a>01083 <span class="comment">! less reliable. it is assumed that the</span>
- <a name="l01084"></a>01084 <span class="comment">! requested accuracy has not been achieved.</span>
- <a name="l01085"></a>01085 <span class="comment">! ier = 1 maximum number of subdivisions allowed</span>
- <a name="l01086"></a>01086 <span class="comment">! has been achieved. one can allow more</span>
- <a name="l01087"></a>01087 <span class="comment">! subdivisions by increasing the data value</span>
- <a name="l01088"></a>01088 <span class="comment">! of limit in qagp(and taking the according</span>
- <a name="l01089"></a>01089 <span class="comment">! dimension adjustments into account).</span>
- <a name="l01090"></a>01090 <span class="comment">! however, if this yields no improvement</span>
- <a name="l01091"></a>01091 <span class="comment">! it is advised to analyze the integrand</span>
- <a name="l01092"></a>01092 <span class="comment">! in order to determine the integration</span>
- <a name="l01093"></a>01093 <span class="comment">! difficulties. if the position of a local</span>
- <a name="l01094"></a>01094 <span class="comment">! difficulty can be determined (i.e.</span>
- <a name="l01095"></a>01095 <span class="comment">! singularity, discontinuity within the</span>
- <a name="l01096"></a>01096 <span class="comment">! interval), it should be supplied to the</span>
- <a name="l01097"></a>01097 <span class="comment">! routine as an element of the vector</span>
- <a name="l01098"></a>01098 <span class="comment">! points. if necessary, an appropriate</span>
- <a name="l01099"></a>01099 <span class="comment">! special-purpose integrator must be used,</span>
- <a name="l01100"></a>01100 <span class="comment">! which is designed for handling the type</span>
- <a name="l01101"></a>01101 <span class="comment">! of difficulty involved.</span>
- <a name="l01102"></a>01102 <span class="comment">! = 2 the occurrence of roundoff error is</span>
- <a name="l01103"></a>01103 <span class="comment">! detected, which prevents the requested</span>
- <a name="l01104"></a>01104 <span class="comment">! tolerance from being achieved.</span>
- <a name="l01105"></a>01105 <span class="comment">! the error may be under-estimated.</span>
- <a name="l01106"></a>01106 <span class="comment">! = 3 extremely bad integrand behavior occurs</span>
- <a name="l01107"></a>01107 <span class="comment">! at some points of the integration</span>
- <a name="l01108"></a>01108 <span class="comment">! interval.</span>
- <a name="l01109"></a>01109 <span class="comment">! = 4 the algorithm does not converge. roundoff</span>
- <a name="l01110"></a>01110 <span class="comment">! error is detected in the extrapolation</span>
- <a name="l01111"></a>01111 <span class="comment">! table. it is presumed that the requested</span>
- <a name="l01112"></a>01112 <span class="comment">! tolerance cannot be achieved, and that</span>
- <a name="l01113"></a>01113 <span class="comment">! the returned result is the best which</span>
- <a name="l01114"></a>01114 <span class="comment">! can be obtained.</span>
- <a name="l01115"></a>01115 <span class="comment">! = 5 the integral is probably divergent, or</span>
- <a name="l01116"></a>01116 <span class="comment">! slowly convergent. it must be noted that</span>
- <a name="l01117"></a>01117 <span class="comment">! divergence can occur with any other value</span>
- <a name="l01118"></a>01118 <span class="comment">! of ier > 0.</span>
- <a name="l01119"></a>01119 <span class="comment">! = 6 the input is invalid because</span>
- <a name="l01120"></a>01120 <span class="comment">! npts2 < 2 or</span>
- <a name="l01121"></a>01121 <span class="comment">! break points are specified outside</span>
- <a name="l01122"></a>01122 <span class="comment">! the integration range or</span>
- <a name="l01123"></a>01123 <span class="comment">! epsabs < 0 and epsrel < 0,</span>
- <a name="l01124"></a>01124 <span class="comment">! or limit < npts2.</span>
- <a name="l01125"></a>01125 <span class="comment">! result, abserr, neval are set to zero.</span>
- <a name="l01126"></a>01126 <span class="comment">!</span>
- <a name="l01127"></a>01127 <span class="comment">! Local parameters:</span>
- <a name="l01128"></a>01128 <span class="comment">!</span>
- <a name="l01129"></a>01129 <span class="comment">! the dimension of rlist2 is determined by the value of</span>
- <a name="l01130"></a>01130 <span class="comment">! limexp in QEXTR (rlist2 should be of dimension</span>
- <a name="l01131"></a>01131 <span class="comment">! (limexp+2) at least).</span>
- <a name="l01132"></a>01132 <span class="comment">!</span>
- <a name="l01133"></a>01133 <span class="comment">! alist - list of left end points of all subintervals</span>
- <a name="l01134"></a>01134 <span class="comment">! considered up to now</span>
- <a name="l01135"></a>01135 <span class="comment">! blist - list of right end points of all subintervals</span>
- <a name="l01136"></a>01136 <span class="comment">! considered up to now</span>
- <a name="l01137"></a>01137 <span class="comment">! rlist(i) - approximation to the integral over</span>
- <a name="l01138"></a>01138 <span class="comment">! (alist(i),blist(i))</span>
- <a name="l01139"></a>01139 <span class="comment">! rlist2 - array of dimension at least limexp+2</span>
- <a name="l01140"></a>01140 <span class="comment">! containing the part of the epsilon table which</span>
- <a name="l01141"></a>01141 <span class="comment">! is still needed for further computations</span>
- <a name="l01142"></a>01142 <span class="comment">! elist(i) - error estimate applying to rlist(i)</span>
- <a name="l01143"></a>01143 <span class="comment">! maxerr - pointer to the interval with largest error</span>
- <a name="l01144"></a>01144 <span class="comment">! estimate</span>
- <a name="l01145"></a>01145 <span class="comment">! errmax - elist(maxerr)</span>
- <a name="l01146"></a>01146 <span class="comment">! erlast - error on the interval currently subdivided</span>
- <a name="l01147"></a>01147 <span class="comment">! (before that subdivision has taken place)</span>
- <a name="l01148"></a>01148 <span class="comment">! area - sum of the integrals over the subintervals</span>
- <a name="l01149"></a>01149 <span class="comment">! errsum - sum of the errors over the subintervals</span>
- <a name="l01150"></a>01150 <span class="comment">! errbnd - requested accuracy max(epsabs,epsrel*</span>
- <a name="l01151"></a>01151 <span class="comment">! abs(result))</span>
- <a name="l01152"></a>01152 <span class="comment">! *****1 - variable for the left subinterval</span>
- <a name="l01153"></a>01153 <span class="comment">! *****2 - variable for the right subinterval</span>
- <a name="l01154"></a>01154 <span class="comment">! last - index for subdivision</span>
- <a name="l01155"></a>01155 <span class="comment">! nres - number of calls to the extrapolation routine</span>
- <a name="l01156"></a>01156 <span class="comment">! numrl2 - number of elements in rlist2. if an appropriate</span>
- <a name="l01157"></a>01157 <span class="comment">! approximation to the compounded integral has</span>
- <a name="l01158"></a>01158 <span class="comment">! obtained, it is put in rlist2(numrl2) after</span>
- <a name="l01159"></a>01159 <span class="comment">! numrl2 has been increased by one.</span>
- <a name="l01160"></a>01160 <span class="comment">! erlarg - sum of the errors over the intervals larger</span>
- <a name="l01161"></a>01161 <span class="comment">! than the smallest interval considered up to now</span>
- <a name="l01162"></a>01162 <span class="comment">! extrap - logical variable denoting that the routine</span>
- <a name="l01163"></a>01163 <span class="comment">! is attempting to perform extrapolation. i.e.</span>
- <a name="l01164"></a>01164 <span class="comment">! before subdividing the smallest interval we</span>
- <a name="l01165"></a>01165 <span class="comment">! try to decrease the value of erlarg.</span>
- <a name="l01166"></a>01166 <span class="comment">! noext - logical variable denoting that extrapolation is</span>
- <a name="l01167"></a>01167 <span class="comment">! no longer allowed (true-value)</span>
- <a name="l01168"></a>01168 <span class="comment">!</span>
- <a name="l01169"></a>01169 <span class="keyword">implicit none</span>
- <a name="l01170"></a>01170
- <a name="l01171"></a>01171 <span class="keywordtype">integer</span>, <span class="keywordtype">parameter</span> :: limit = 500
- <a name="l01172"></a>01172
- <a name="l01173"></a>01173 <span class="keywordtype">real</span> a
- <a name="l01174"></a>01174 <span class="keywordtype">real</span> abseps
- <a name="l01175"></a>01175 <span class="keywordtype">real</span> abserr
- <a name="l01176"></a>01176 <span class="keywordtype">real</span> alist(limit)
- <a name="l01177"></a>01177 <span class="keywordtype">real</span> area
- <a name="l01178"></a>01178 <span class="keywordtype">real</span> area1
- <a name="l01179"></a>01179 <span class="keywordtype">real</span> area12
- <a name="l01180"></a>01180 <span class="keywordtype">real</span> area2
- <a name="l01181"></a>01181 <span class="keywordtype">real</span> a1
- <a name="l01182"></a>01182 <span class="keywordtype">real</span> a2
- <a name="l01183"></a>01183 <span class="keywordtype">real</span> b
- <a name="l01184"></a>01184 <span class="keywordtype">real</span> blist(limit)
- <a name="l01185"></a>01185 <span class="keywordtype">real</span> b1
- <a name="l01186"></a>01186 <span class="keywordtype">real</span> b2
- <a name="l01187"></a>01187 <span class="keywordtype">real</span> correc
- <a name="l01188"></a>01188 <span class="keywordtype">real</span> defabs
- <a name="l01189"></a>01189 <span class="keywordtype">real</span> defab1
- <a name="l01190"></a>01190 <span class="keywordtype">real</span> defab2
- <a name="l01191"></a>01191 <span class="keywordtype">real</span> dres
- <a name="l01192"></a>01192 <span class="keywordtype">real</span> elist(limit)
- <a name="l01193"></a>01193 <span class="keywordtype">real</span> epsabs
- <a name="l01194"></a>01194 <span class="keywordtype">real</span> epsrel
- <a name="l01195"></a>01195 <span class="keywordtype">real</span> erlarg
- <a name="l01196"></a>01196 <span class="keywordtype">real</span> erlast
- <a name="l01197"></a>01197 <span class="keywordtype">real</span> errbnd
- <a name="l01198"></a>01198 <span class="keywordtype">real</span> errmax
- <a name="l01199"></a>01199 <span class="keywordtype">real</span> error1
- <a name="l01200"></a>01200 <span class="keywordtype">real</span> erro12
- <a name="l01201"></a>01201 <span class="keywordtype">real</span> error2
- <a name="l01202"></a>01202 <span class="keywordtype">real</span> errsum
- <a name="l01203"></a>01203 <span class="keywordtype">real</span> ertest
- <a name="l01204"></a>01204 <span class="keywordtype">logical</span> extrap
- <a name="l01205"></a>01205 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l01206"></a>01206 <span class="keywordtype">integer</span> i
- <a name="l01207"></a>01207 <span class="keywordtype">integer</span> id
- <a name="l01208"></a>01208 <span class="keywordtype">integer</span> ier
- <a name="l01209"></a>01209 <span class="keywordtype">integer</span> ierro
- <a name="l01210"></a>01210 <span class="keywordtype">integer</span> ind1
- <a name="l01211"></a>01211 <span class="keywordtype">integer</span> ind2
- <a name="l01212"></a>01212 <span class="keywordtype">integer</span> iord(limit)
- <a name="l01213"></a>01213 <span class="keywordtype">integer</span> iroff1
- <a name="l01214"></a>01214 <span class="keywordtype">integer</span> iroff2
- <a name="l01215"></a>01215 <span class="keywordtype">integer</span> iroff3
- <a name="l01216"></a>01216 <span class="keywordtype">integer</span> j
- <a name="l01217"></a>01217 <span class="keywordtype">integer</span> jlow
- <a name="l01218"></a>01218 <span class="keywordtype">integer</span> jupbnd
- <a name="l01219"></a>01219 <span class="keywordtype">integer</span> k
- <a name="l01220"></a>01220 <span class="keywordtype">integer</span> ksgn
- <a name="l01221"></a>01221 <span class="keywordtype">integer</span> ktmin
- <a name="l01222"></a>01222 <span class="keywordtype">integer</span> last
- <a name="l01223"></a>01223 <span class="keywordtype">integer</span> levcur
- <a name="l01224"></a>01224 <span class="keywordtype">integer</span> level(limit)
- <a name="l01225"></a>01225 <span class="keywordtype">integer</span> levmax
- <a name="l01226"></a>01226 <span class="keywordtype">integer</span> maxerr
- <a name="l01227"></a>01227 <span class="keywordtype">integer</span> ndin(40)
- <a name="l01228"></a>01228 <span class="keywordtype">integer</span> neval
- <a name="l01229"></a>01229 <span class="keywordtype">integer</span> nint
- <a name="l01230"></a>01230 <span class="keywordtype">logical</span> noext
- <a name="l01231"></a>01231 <span class="keywordtype">integer</span> npts
- <a name="l01232"></a>01232 <span class="keywordtype">integer</span> npts2
- <a name="l01233"></a>01233 <span class="keywordtype">integer</span> nres
- <a name="l01234"></a>01234 <span class="keywordtype">integer</span> nrmax
- <a name="l01235"></a>01235 <span class="keywordtype">integer</span> numrl2
- <a name="l01236"></a>01236 <span class="keywordtype">real</span> points(40)
- <a name="l01237"></a>01237 <span class="keywordtype">real</span> pts(40)
- <a name="l01238"></a>01238 <span class="keywordtype">real</span> resa
- <a name="l01239"></a>01239 <span class="keywordtype">real</span> resabs
- <a name="l01240"></a>01240 <span class="keywordtype">real</span> reseps
- <a name="l01241"></a>01241 <span class="keywordtype">real</span> result
- <a name="l01242"></a>01242 <span class="keywordtype">real</span> res3la(3)
- <a name="l01243"></a>01243 <span class="keywordtype">real</span> rlist(limit)
- <a name="l01244"></a>01244 <span class="keywordtype">real</span> rlist2(52)
- <a name="l01245"></a>01245 <span class="keywordtype">real</span> sign
- <a name="l01246"></a>01246 <span class="keywordtype">real</span> temp
- <a name="l01247"></a>01247 <span class="comment">!</span>
- <a name="l01248"></a>01248 <span class="comment">! Test on validity of parameters.</span>
- <a name="l01249"></a>01249 <span class="comment">!</span>
- <a name="l01250"></a>01250 ier = 0
- <a name="l01251"></a>01251 neval = 0
- <a name="l01252"></a>01252 last = 0
- <a name="l01253"></a>01253 result = 0.0e+00
- <a name="l01254"></a>01254 abserr = 0.0e+00
- <a name="l01255"></a>01255 alist(1) = a
- <a name="l01256"></a>01256 blist(1) = b
- <a name="l01257"></a>01257 rlist(1) = 0.0e+00
- <a name="l01258"></a>01258 elist(1) = 0.0e+00
- <a name="l01259"></a>01259 iord(1) = 0
- <a name="l01260"></a>01260 level(1) = 0
- <a name="l01261"></a>01261 npts = npts2 - 2
- <a name="l01262"></a>01262
- <a name="l01263"></a>01263 <span class="keyword">if</span> ( npts2 < 2 ) <span class="keyword">then</span>
- <a name="l01264"></a>01264 ier = 6
- <a name="l01265"></a>01265 return
- <a name="l01266"></a>01266 <span class="keyword">else</span> <span class="keyword">if</span> ( limit <= npts .or. ( epsabs < 0.0e+00 .and. &
- <a name="l01267"></a>01267 epsrel < 0.0e+00) ) <span class="keyword">then</span>
- <a name="l01268"></a>01268 ier = 6
- <a name="l01269"></a>01269 return
- <a name="l01270"></a>01270 <span class="keyword">end if</span>
- <a name="l01271"></a>01271 <span class="comment">!</span>
- <a name="l01272"></a>01272 <span class="comment">! If any break points are provided, sort them into an</span>
- <a name="l01273"></a>01273 <span class="comment">! ascending sequence.</span>
- <a name="l01274"></a>01274 <span class="comment">!</span>
- <a name="l01275"></a>01275 <span class="keyword">if</span> ( b < a ) <span class="keyword">then</span>
- <a name="l01276"></a>01276 sign = -1.0e+00
- <a name="l01277"></a>01277 <span class="keyword">else</span>
- <a name="l01278"></a>01278 sign = +1.0E+00
- <a name="l01279"></a>01279 <span class="keyword">end if</span>
- <a name="l01280"></a>01280
- <a name="l01281"></a>01281 pts(1) = min ( a, b )
- <a name="l01282"></a>01282
- <a name="l01283"></a>01283 <span class="keyword">do</span> i = 1, npts
- <a name="l01284"></a>01284 pts(i+1) = points(i)
- <a name="l01285"></a>01285 <span class="keyword">end do</span>
- <a name="l01286"></a>01286
- <a name="l01287"></a>01287 pts(npts+2) = max ( a, b )
- <a name="l01288"></a>01288 nint = npts+1
- <a name="l01289"></a>01289 a1 = pts(1)
- <a name="l01290"></a>01290
- <a name="l01291"></a>01291 <span class="keyword">if</span> ( npts /= 0 ) <span class="keyword">then</span>
- <a name="l01292"></a>01292
- <a name="l01293"></a>01293 <span class="keyword">do</span> i = 1, nint
- <a name="l01294"></a>01294 <span class="keyword">do</span> j = i+1, nint+1
- <a name="l01295"></a>01295 <span class="keyword">if</span> ( pts(j) < pts(i) ) <span class="keyword">then</span>
- <a name="l01296"></a>01296 temp = pts(i)
- <a name="l01297"></a>01297 pts(i) = pts(j)
- <a name="l01298"></a>01298 pts(j) = temp
- <a name="l01299"></a>01299 <span class="keyword">end if</span>
- <a name="l01300"></a>01300 <span class="keyword">end do</span>
- <a name="l01301"></a>01301 <span class="keyword">end do</span>
- <a name="l01302"></a>01302
- <a name="l01303"></a>01303 <span class="keyword">if</span> ( pts(1) /= min ( a, b ) .or. pts(nint+1) /= max ( a, b ) ) <span class="keyword">then</span>
- <a name="l01304"></a>01304 ier = 6
- <a name="l01305"></a>01305 return
- <a name="l01306"></a>01306 <span class="keyword">end if</span>
- <a name="l01307"></a>01307
- <a name="l01308"></a>01308 <span class="keyword">end if</span>
- <a name="l01309"></a>01309 <span class="comment">!</span>
- <a name="l01310"></a>01310 <span class="comment">! Compute first integral and error approximations.</span>
- <a name="l01311"></a>01311 <span class="comment">!</span>
- <a name="l01312"></a>01312 resabs = 0.0e+00
- <a name="l01313"></a>01313
- <a name="l01314"></a>01314 <span class="keyword">do</span> i = 1, nint
- <a name="l01315"></a>01315
- <a name="l01316"></a>01316 b1 = pts(i+1)
- <a name="l01317"></a>01317 call <a class="code" href="quadpack_8f90.html#a27241a527b249e9de59a5ed6bee5f805">qk21 </a>( f, a1, b1, area1, error1, defabs, resa )
- <a name="l01318"></a>01318 abserr = abserr + error1
- <a name="l01319"></a>01319 result = result + area1
- <a name="l01320"></a>01320 ndin(i) = 0
- <a name="l01321"></a>01321
- <a name="l01322"></a>01322 <span class="keyword">if</span> ( error1 == resa .and. error1 /= 0.0e+00 ) <span class="keyword">then</span>
- <a name="l01323"></a>01323 ndin(i) = 1
- <a name="l01324"></a>01324 <span class="keyword">end if</span>
- <a name="l01325"></a>01325
- <a name="l01326"></a>01326 resabs = resabs + defabs
- <a name="l01327"></a>01327 level(i) = 0
- <a name="l01328"></a>01328 elist(i) = error1
- <a name="l01329"></a>01329 alist(i) = a1
- <a name="l01330"></a>01330 blist(i) = b1
- <a name="l01331"></a>01331 rlist(i) = area1
- <a name="l01332"></a>01332 iord(i) = i
- <a name="l01333"></a>01333 a1 = b1
- <a name="l01334"></a>01334
- <a name="l01335"></a>01335 <span class="keyword">end do</span>
- <a name="l01336"></a>01336
- <a name="l01337"></a>01337 errsum = 0.0e+00
- <a name="l01338"></a>01338
- <a name="l01339"></a>01339 <span class="keyword">do</span> i = 1, nint
- <a name="l01340"></a>01340 <span class="keyword">if</span> ( ndin(i) == 1 ) <span class="keyword">then</span>
- <a name="l01341"></a>01341 elist(i) = abserr
- <a name="l01342"></a>01342 <span class="keyword">end if</span>
- <a name="l01343"></a>01343 errsum = errsum + elist(i)
- <a name="l01344"></a>01344 <span class="keyword">end do</span>
- <a name="l01345"></a>01345 <span class="comment">!</span>
- <a name="l01346"></a>01346 <span class="comment">! Test on accuracy.</span>
- <a name="l01347"></a>01347 <span class="comment">!</span>
- <a name="l01348"></a>01348 last = nint
- <a name="l01349"></a>01349 neval = 21 * nint
- <a name="l01350"></a>01350 dres = abs ( result )
- <a name="l01351"></a>01351 errbnd = max ( epsabs, epsrel * dres )
- <a name="l01352"></a>01352
- <a name="l01353"></a>01353 <span class="keyword">if</span> ( abserr <= 1.0e+02 * epsilon ( resabs ) * resabs .and. &
- <a name="l01354"></a>01354 abserr > errbnd ) <span class="keyword">then</span>
- <a name="l01355"></a>01355 ier = 2
- <a name="l01356"></a>01356 <span class="keyword">end if</span>
- <a name="l01357"></a>01357
- <a name="l01358"></a>01358 <span class="keyword">if</span> ( nint /= 1 ) <span class="keyword">then</span>
- <a name="l01359"></a>01359
- <a name="l01360"></a>01360 <span class="keyword">do</span> i = 1, npts
- <a name="l01361"></a>01361
- <a name="l01362"></a>01362 jlow = i+1
- <a name="l01363"></a>01363 ind1 = iord(i)
- <a name="l01364"></a>01364
- <a name="l01365"></a>01365 <span class="keyword">do</span> j = jlow, nint
- <a name="l01366"></a>01366 ind2 = iord(j)
- <a name="l01367"></a>01367 <span class="keyword">if</span> ( elist(ind1) <= elist(ind2) ) <span class="keyword">then</span>
- <a name="l01368"></a>01368 ind1 = ind2
- <a name="l01369"></a>01369 k = j
- <a name="l01370"></a>01370 <span class="keyword">end if</span>
- <a name="l01371"></a>01371 <span class="keyword">end do</span>
- <a name="l01372"></a>01372
- <a name="l01373"></a>01373 <span class="keyword">if</span> ( ind1 /= iord(i) ) <span class="keyword">then</span>
- <a name="l01374"></a>01374 iord(k) = iord(i)
- <a name="l01375"></a>01375 iord(i) = ind1
- <a name="l01376"></a>01376 <span class="keyword">end if</span>
- <a name="l01377"></a>01377
- <a name="l01378"></a>01378 <span class="keyword">end do</span>
- <a name="l01379"></a>01379
- <a name="l01380"></a>01380 <span class="keyword">if</span> ( limit < npts2 ) <span class="keyword">then</span>
- <a name="l01381"></a>01381 ier = 1
- <a name="l01382"></a>01382 <span class="keyword">end if</span>
- <a name="l01383"></a>01383
- <a name="l01384"></a>01384 <span class="keyword">end if</span>
- <a name="l01385"></a>01385
- <a name="l01386"></a>01386 <span class="keyword">if</span> ( ier /= 0 .or. abserr <= errbnd ) <span class="keyword">then</span>
- <a name="l01387"></a>01387 return
- <a name="l01388"></a>01388 <span class="keyword">end if</span>
- <a name="l01389"></a>01389 <span class="comment">!</span>
- <a name="l01390"></a>01390 <span class="comment">! Initialization</span>
- <a name="l01391"></a>01391 <span class="comment">!</span>
- <a name="l01392"></a>01392 rlist2(1) = result
- <a name="l01393"></a>01393 maxerr = iord(1)
- <a name="l01394"></a>01394 errmax = elist(maxerr)
- <a name="l01395"></a>01395 area = result
- <a name="l01396"></a>01396 nrmax = 1
- <a name="l01397"></a>01397 nres = 0
- <a name="l01398"></a>01398 numrl2 = 1
- <a name="l01399"></a>01399 ktmin = 0
- <a name="l01400"></a>01400 extrap = .false.
- <a name="l01401"></a>01401 noext = .false.
- <a name="l01402"></a>01402 erlarg = errsum
- <a name="l01403"></a>01403 ertest = errbnd
- <a name="l01404"></a>01404 levmax = 1
- <a name="l01405"></a>01405 iroff1 = 0
- <a name="l01406"></a>01406 iroff2 = 0
- <a name="l01407"></a>01407 iroff3 = 0
- <a name="l01408"></a>01408 ierro = 0
- <a name="l01409"></a>01409 abserr = huge ( abserr )
- <a name="l01410"></a>01410
- <a name="l01411"></a>01411 <span class="keyword">if</span> ( dres >= ( 1.0e+00 - 0.5E+00 * epsilon ( resabs ) ) * resabs ) <span class="keyword">then</span>
- <a name="l01412"></a>01412 ksgn = 1
- <a name="l01413"></a>01413 <span class="keyword">else</span>
- <a name="l01414"></a>01414 ksgn = -1
- <a name="l01415"></a>01415 <span class="keyword">end if</span>
- <a name="l01416"></a>01416
- <a name="l01417"></a>01417 <span class="keyword">do</span> last = npts2, limit
- <a name="l01418"></a>01418 <span class="comment">!</span>
- <a name="l01419"></a>01419 <span class="comment">! Bisect the subinterval with the NRMAX-th largest error estimate.</span>
- <a name="l01420"></a>01420 <span class="comment">!</span>
- <a name="l01421"></a>01421 levcur = level(maxerr) + 1
- <a name="l01422"></a>01422 a1 = alist(maxerr)
- <a name="l01423"></a>01423 b1 = 0.5E+00 * ( alist(maxerr) + blist(maxerr) )
- <a name="l01424"></a>01424 a2 = b1
- <a name="l01425"></a>01425 b2 = blist(maxerr)
- <a name="l01426"></a>01426 erlast = errmax
- <a name="l01427"></a>01427 call <a class="code" href="quadpack_8f90.html#a27241a527b249e9de59a5ed6bee5f805">qk21 </a>( f, a1, b1, area1, error1, resa, defab1 )
- <a name="l01428"></a>01428 call <a class="code" href="quadpack_8f90.html#a27241a527b249e9de59a5ed6bee5f805">qk21 </a>( f, a2, b2, area2, error2, resa, defab2 )
- <a name="l01429"></a>01429 <span class="comment">!</span>
- <a name="l01430"></a>01430 <span class="comment">! Improve previous approximations to integral and error</span>
- <a name="l01431"></a>01431 <span class="comment">! and test for accuracy.</span>
- <a name="l01432"></a>01432 <span class="comment">!</span>
- <a name="l01433"></a>01433 neval = neval + 42
- <a name="l01434"></a>01434 area12 = area1 + area2
- <a name="l01435"></a>01435 erro12 = error1 + error2
- <a name="l01436"></a>01436 errsum = errsum + erro12 -errmax
- <a name="l01437"></a>01437 area = area + area12 - rlist(maxerr)
- <a name="l01438"></a>01438
- <a name="l01439"></a>01439 <span class="keyword">if</span> ( defab1 /= error1 .and. defab2 /= error2 ) <span class="keyword">then</span>
- <a name="l01440"></a>01440
- <a name="l01441"></a>01441 <span class="keyword">if</span> ( abs ( rlist ( maxerr ) - area12 ) <= 1.0e-05 * abs(area12) .and. &
- <a name="l01442"></a>01442 erro12 >= 9.9e-01 * errmax ) <span class="keyword">then</span>
- <a name="l01443"></a>01443
- <a name="l01444"></a>01444 <span class="keyword">if</span> ( extrap ) <span class="keyword">then</span>
- <a name="l01445"></a>01445 iroff2 = iroff2+1
- <a name="l01446"></a>01446 <span class="keyword">else</span>
- <a name="l01447"></a>01447 iroff1 = iroff1+1
- <a name="l01448"></a>01448 <span class="keyword">end if</span>
- <a name="l01449"></a>01449
- <a name="l01450"></a>01450 <span class="keyword">end if</span>
- <a name="l01451"></a>01451
- <a name="l01452"></a>01452 <span class="keyword">if</span> ( last > 10 .and. erro12 > errmax ) <span class="keyword">then</span>
- <a name="l01453"></a>01453 iroff3 = iroff3 + 1
- <a name="l01454"></a>01454 <span class="keyword">end if</span>
- <a name="l01455"></a>01455
- <a name="l01456"></a>01456 <span class="keyword">end if</span>
- <a name="l01457"></a>01457
- <a name="l01458"></a>01458 level(maxerr) = levcur
- <a name="l01459"></a>01459 level(last) = levcur
- <a name="l01460"></a>01460 rlist(maxerr) = area1
- <a name="l01461"></a>01461 rlist(last) = area2
- <a name="l01462"></a>01462 errbnd = max ( epsabs, epsrel * abs ( area ) )
- <a name="l01463"></a>01463 <span class="comment">!</span>
- <a name="l01464"></a>01464 <span class="comment">! Test for roundoff error and eventually set error flag.</span>
- <a name="l01465"></a>01465 <span class="comment">!</span>
- <a name="l01466"></a>01466 <span class="keyword">if</span> ( 10 <= iroff1 + iroff2 .or. 20 <= iroff3 ) <span class="keyword">then</span>
- <a name="l01467"></a>01467 ier = 2
- <a name="l01468"></a>01468 <span class="keyword">end if</span>
- <a name="l01469"></a>01469
- <a name="l01470"></a>01470 <span class="keyword">if</span> ( 5 <= iroff2 ) <span class="keyword">then</span>
- <a name="l01471"></a>01471 ierro = 3
- <a name="l01472"></a>01472 <span class="keyword">end if</span>
- <a name="l01473"></a>01473 <span class="comment">!</span>
- <a name="l01474"></a>01474 <span class="comment">! Set error flag in the case that the number of subintervals</span>
- <a name="l01475"></a>01475 <span class="comment">! equals limit.</span>
- <a name="l01476"></a>01476 <span class="comment">!</span>
- <a name="l01477"></a>01477 <span class="keyword">if</span> ( last == limit ) <span class="keyword">then</span>
- <a name="l01478"></a>01478 ier = 1
- <a name="l01479"></a>01479 <span class="keyword">end if</span>
- <a name="l01480"></a>01480 <span class="comment">!</span>
- <a name="l01481"></a>01481 <span class="comment">! Set error flag in the case of bad integrand behavior</span>
- <a name="l01482"></a>01482 <span class="comment">! at a point of the integration range</span>
- <a name="l01483"></a>01483 <span class="comment">!</span>
- <a name="l01484"></a>01484 <span class="keyword">if</span> ( max ( abs(a1), abs(b2)) <= ( 1.0e+00 + 1.0e+03 * epsilon ( a1 ) )* &
- <a name="l01485"></a>01485 ( abs ( a2 ) + 1.0e+03 * tiny ( a2 ) ) ) <span class="keyword">then</span>
- <a name="l01486"></a>01486 ier = 4
- <a name="l01487"></a>01487 <span class="keyword">end if</span>
- <a name="l01488"></a>01488 <span class="comment">!</span>
- <a name="l01489"></a>01489 <span class="comment">! Append the newly-created intervals to the list.</span>
- <a name="l01490"></a>01490 <span class="comment">!</span>
- <a name="l01491"></a>01491 <span class="keyword">if</span> ( error2 <= error1 ) <span class="keyword">then</span>
- <a name="l01492"></a>01492 alist(last) = a2
- <a name="l01493"></a>01493 blist(maxerr) = b1
- <a name="l01494"></a>01494 blist(last) = b2
- <a name="l01495"></a>01495 elist(maxerr) = error1
- <a name="l01496"></a>01496 elist(last) = error2
- <a name="l01497"></a>01497 <span class="keyword">else</span>
- <a name="l01498"></a>01498 alist(maxerr) = a2
- <a name="l01499"></a>01499 alist(last) = a1
- <a name="l01500"></a>01500 blist(last) = b1
- <a name="l01501"></a>01501 rlist(maxerr) = area2
- <a name="l01502"></a>01502 rlist(last) = area1
- <a name="l01503"></a>01503 elist(maxerr) = error2
- <a name="l01504"></a>01504 elist(last) = error1
- <a name="l01505"></a>01505 <span class="keyword">end if</span>
- <a name="l01506"></a>01506 <span class="comment">!</span>
- <a name="l01507"></a>01507 <span class="comment">! Call QSORT to maintain the descending ordering</span>
- <a name="l01508"></a>01508 <span class="comment">! in the list of error estimates and select the subinterval</span>
- <a name="l01509"></a>01509 <span class="comment">! with nrmax-th largest error estimate (to be bisected next).</span>
- <a name="l01510"></a>01510 <span class="comment">!</span>
- <a name="l01511"></a>01511 call <a class="code" href="quadpack_8f90.html#a55e08a684c5a6315fb37dd0fdc66d8e6">qsort </a>( limit, last, maxerr, errmax, elist, iord, nrmax )
- <a name="l01512"></a>01512
- <a name="l01513"></a>01513 <span class="keyword">if</span> ( errsum <= errbnd ) <span class="keyword">then</span>
- <a name="l01514"></a>01514 go to 190
- <a name="l01515"></a>01515 <span class="keyword">end if</span>
- <a name="l01516"></a>01516
- <a name="l01517"></a>01517 <span class="keyword">if</span> ( ier /= 0 ) <span class="keyword">then</span>
- <a name="l01518"></a>01518 exit
- <a name="l01519"></a>01519 <span class="keyword">end if</span>
- <a name="l01520"></a>01520
- <a name="l01521"></a>01521 <span class="keyword">if</span> ( noext ) <span class="keyword">then</span>
- <a name="l01522"></a>01522 cycle
- <a name="l01523"></a>01523 <span class="keyword">end if</span>
- <a name="l01524"></a>01524
- <a name="l01525"></a>01525 erlarg = erlarg - erlast
- <a name="l01526"></a>01526
- <a name="l01527"></a>01527 <span class="keyword">if</span> ( levcur+1 <= levmax ) <span class="keyword">then</span>
- <a name="l01528"></a>01528 erlarg = erlarg + erro12
- <a name="l01529"></a>01529 <span class="keyword">end if</span>
- <a name="l01530"></a>01530 <span class="comment">!</span>
- <a name="l01531"></a>01531 <span class="comment">! Test whether the interval to be bisected next is the</span>
- <a name="l01532"></a>01532 <span class="comment">! smallest interval.</span>
- <a name="l01533"></a>01533 <span class="comment">!</span>
- <a name="l01534"></a>01534 <span class="keyword">if</span> ( .not. extrap ) <span class="keyword">then</span>
- <a name="l01535"></a>01535
- <a name="l01536"></a>01536 <span class="keyword">if</span> ( level(maxerr)+1 <= levmax ) <span class="keyword">then</span>
- <a name="l01537"></a>01537 cycle
- <a name="l01538"></a>01538 <span class="keyword">end if</span>
- <a name="l01539"></a>01539
- <a name="l01540"></a>01540 extrap = .true.
- <a name="l01541"></a>01541 nrmax = 2
- <a name="l01542"></a>01542
- <a name="l01543"></a>01543 <span class="keyword">end if</span>
- <a name="l01544"></a>01544 <span class="comment">!</span>
- <a name="l01545"></a>01545 <span class="comment">! The smallest interval has the largest error.</span>
- <a name="l01546"></a>01546 <span class="comment">! Before bisecting decrease the sum of the errors over the</span>
- <a name="l01547"></a>01547 <span class="comment">! larger intervals (erlarg) and perform extrapolation.</span>
- <a name="l01548"></a>01548 <span class="comment">!</span>
- <a name="l01549"></a>01549 <span class="keyword">if</span> ( ierro /= 3 .and. erlarg > ertest ) <span class="keyword">then</span>
- <a name="l01550"></a>01550
- <a name="l01551"></a>01551 id = nrmax
- <a name="l01552"></a>01552 jupbnd = last
- <a name="l01553"></a>01553 <span class="keyword">if</span> ( last > (2+limit/2) ) <span class="keyword">then</span>
- <a name="l01554"></a>01554 jupbnd = limit+3-last
- <a name="l01555"></a>01555 <span class="keyword">end if</span>
- <a name="l01556"></a>01556
- <a name="l01557"></a>01557 <span class="keyword">do</span> k = id, jupbnd
- <a name="l01558"></a>01558 maxerr = iord(nrmax)
- <a name="l01559"></a>01559 errmax = elist(maxerr)
- <a name="l01560"></a>01560 <span class="keyword">if</span> ( level(maxerr)+1 <= levmax ) <span class="keyword">then</span>
- <a name="l01561"></a>01561 go to 160
- <a name="l01562"></a>01562 <span class="keyword">end if</span>
- <a name="l01563"></a>01563 nrmax = nrmax + 1
- <a name="l01564"></a>01564 <span class="keyword">end do</span>
- <a name="l01565"></a>01565
- <a name="l01566"></a>01566 <span class="keyword">end if</span>
- <a name="l01567"></a>01567 <span class="comment">!</span>
- <a name="l01568"></a>01568 <span class="comment">! Perform extrapolation.</span>
- <a name="l01569"></a>01569 <span class="comment">!</span>
- <a name="l01570"></a>01570 numrl2 = numrl2 + 1
- <a name="l01571"></a>01571 rlist2(numrl2) = area
- <a name="l01572"></a>01572
- <a name="l01573"></a>01573 <span class="keyword">if</span> ( numrl2 <= 2 ) <span class="keyword">then</span>
- <a name="l01574"></a>01574 go to 155
- <a name="l01575"></a>01575 <span class="keyword">end if</span>
- <a name="l01576"></a>01576
- <a name="l01577"></a>01577 call <a class="code" href="quadpack_8f90.html#a5a75101d080f224c63adde98a0e64386">qextr </a>( numrl2, rlist2, reseps, abseps, res3la, nres )
- <a name="l01578"></a>01578 ktmin = ktmin+1
- <a name="l01579"></a>01579
- <a name="l01580"></a>01580 <span class="keyword">if</span> ( 5 < ktmin .and. abserr < 1.0e-03 * errsum ) <span class="keyword">then</span>
- <a name="l01581"></a>01581 ier = 5
- <a name="l01582"></a>01582 <span class="keyword">end if</span>
- <a name="l01583"></a>01583
- <a name="l01584"></a>01584 <span class="keyword">if</span> ( abseps < abserr ) <span class="keyword">then</span>
- <a name="l01585"></a>01585
- <a name="l01586"></a>01586 ktmin = 0
- <a name="l01587"></a>01587 abserr = abseps
- <a name="l01588"></a>01588 result = reseps
- <a name="l01589"></a>01589 correc = erlarg
- <a name="l01590"></a>01590 ertest = max ( epsabs, epsrel * abs(reseps) )
- <a name="l01591"></a>01591
- <a name="l01592"></a>01592 <span class="keyword">if</span> ( abserr < ertest ) <span class="keyword">then</span>
- <a name="l01593"></a>01593 exit
- <a name="l01594"></a>01594 <span class="keyword">end if</span>
- <a name="l01595"></a>01595
- <a name="l01596"></a>01596 <span class="keyword">end if</span>
- <a name="l01597"></a>01597 <span class="comment">!</span>
- <a name="l01598"></a>01598 <span class="comment">! Prepare bisection of the smallest interval.</span>
- <a name="l01599"></a>01599 <span class="comment">!</span>
- <a name="l01600"></a>01600 <span class="keyword">if</span> ( numrl2 == 1 ) <span class="keyword">then</span>
- <a name="l01601"></a>01601 noext = .true.
- <a name="l01602"></a>01602 <span class="keyword">end if</span>
- <a name="l01603"></a>01603
- <a name="l01604"></a>01604 <span class="keyword">if</span> ( 5 <= ier ) <span class="keyword">then</span>
- <a name="l01605"></a>01605 exit
- <a name="l01606"></a>01606 <span class="keyword">end if</span>
- <a name="l01607"></a>01607
- <a name="l01608"></a>01608 155 continue
- <a name="l01609"></a>01609
- <a name="l01610"></a>01610 maxerr = iord(1)
- <a name="l01611"></a>01611 errmax = elist(maxerr)
- <a name="l01612"></a>01612 nrmax = 1
- <a name="l01613"></a>01613 extrap = .false.
- <a name="l01614"></a>01614 levmax = levmax + 1
- <a name="l01615"></a>01615 erlarg = errsum
- <a name="l01616"></a>01616
- <a name="l01617"></a>01617 160 continue
- <a name="l01618"></a>01618
- <a name="l01619"></a>01619 <span class="keyword">end do</span>
- <a name="l01620"></a>01620 <span class="comment">!</span>
- <a name="l01621"></a>01621 <span class="comment">! Set the final result.</span>
- <a name="l01622"></a>01622 <span class="comment">!</span>
- <a name="l01623"></a>01623 <span class="keyword">if</span> ( abserr == huge ( abserr ) ) <span class="keyword">then</span>
- <a name="l01624"></a>01624 go to 190
- <a name="l01625"></a>01625 <span class="keyword">end if</span>
- <a name="l01626"></a>01626
- <a name="l01627"></a>01627 <span class="keyword">if</span> ( ( ier + ierro ) == 0 ) <span class="keyword">then</span>
- <a name="l01628"></a>01628 go to 180
- <a name="l01629"></a>01629 <span class="keyword">end if</span>
- <a name="l01630"></a>01630
- <a name="l01631"></a>01631 <span class="keyword">if</span> ( ierro == 3 ) <span class="keyword">then</span>
- <a name="l01632"></a>01632 abserr = abserr + correc
- <a name="l01633"></a>01633 <span class="keyword">end if</span>
- <a name="l01634"></a>01634
- <a name="l01635"></a>01635 <span class="keyword">if</span> ( ier == 0 ) <span class="keyword">then</span>
- <a name="l01636"></a>01636 ier = 3
- <a name="l01637"></a>01637 <span class="keyword">end if</span>
- <a name="l01638"></a>01638
- <a name="l01639"></a>01639 <span class="keyword">if</span> ( result /= 0.0e+00 .and. area /= 0.0e+00 ) <span class="keyword">then</span>
- <a name="l01640"></a>01640 go to 175
- <a name="l01641"></a>01641 <span class="keyword">end if</span>
- <a name="l01642"></a>01642
- <a name="l01643"></a>01643 <span class="keyword">if</span> ( errsum < abserr ) <span class="keyword">then</span>
- <a name="l01644"></a>01644 go to 190
- <a name="l01645"></a>01645 <span class="keyword">end if</span>
- <a name="l01646"></a>01646
- <a name="l01647"></a>01647 <span class="keyword">if</span> ( area == 0.0e+00 ) <span class="keyword">then</span>
- <a name="l01648"></a>01648 go to 210
- <a name="l01649"></a>01649 <span class="keyword">end if</span>
- <a name="l01650"></a>01650
- <a name="l01651"></a>01651 go to 180
- <a name="l01652"></a>01652
- <a name="l01653"></a>01653 175 continue
- <a name="l01654"></a>01654
- <a name="l01655"></a>01655 <span class="keyword">if</span> ( abserr / abs(result) > errsum / abs(area) ) <span class="keyword">then</span>
- <a name="l01656"></a>01656 go to 190
- <a name="l01657"></a>01657 <span class="keyword">end if</span>
- <a name="l01658"></a>01658 <span class="comment">!</span>
- <a name="l01659"></a>01659 <span class="comment">! Test on divergence.</span>
- <a name="l01660"></a>01660 <span class="comment">!</span>
- <a name="l01661"></a>01661 180 continue
- <a name="l01662"></a>01662
- <a name="l01663"></a>01663 <span class="keyword">if</span> ( ksgn == (-1) .and. max ( abs(result),abs(area)) <= &
- <a name="l01664"></a>01664 resabs*1.0e-02 ) go to 210
- <a name="l01665"></a>01665
- <a name="l01666"></a>01666 <span class="keyword">if</span> ( 1.0e-02 > (result/area) .or. (result/area) > 1.0e+02 .or. &
- <a name="l01667"></a>01667 errsum > abs(area) ) <span class="keyword">then</span>
- <a name="l01668"></a>01668 ier = 6
- <a name="l01669"></a>01669 <span class="keyword">end if</span>
- <a name="l01670"></a>01670
- <a name="l01671"></a>01671 go to 210
- <a name="l01672"></a>01672 <span class="comment">!</span>
- <a name="l01673"></a>01673 <span class="comment">! Compute global integral sum.</span>
- <a name="l01674"></a>01674 <span class="comment">!</span>
- <a name="l01675"></a>01675 190 continue
- <a name="l01676"></a>01676
- <a name="l01677"></a>01677 result = sum ( rlist(1:last) )
- <a name="l01678"></a>01678
- <a name="l01679"></a>01679 abserr = errsum
- <a name="l01680"></a>01680
- <a name="l01681"></a>01681 210 continue
- <a name="l01682"></a>01682
- <a name="l01683"></a>01683 <span class="keyword">if</span> ( 2 < ier ) <span class="keyword">then</span>
- <a name="l01684"></a>01684 ier = ier - 1
- <a name="l01685"></a>01685 <span class="keyword">end if</span>
- <a name="l01686"></a>01686
- <a name="l01687"></a>01687 result = result * sign
- <a name="l01688"></a>01688
- <a name="l01689"></a>01689 return
- <a name="l01690"></a>01690 <span class="keyword">end</span>
- <a name="l01691"></a><a class="code" href="quadpack_8f90.html#a00a116a91c0699e57d15abc61dcd531b">01691</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#a00a116a91c0699e57d15abc61dcd531b">qags</a> ( f, a, b, epsabs, epsrel, result, abserr, neval, ier )
- <a name="l01692"></a>01692
- <a name="l01693"></a>01693 <span class="comment">!*****************************************************************************80</span>
- <a name="l01694"></a>01694 <span class="comment">!</span>
- <a name="l01695"></a>01695 <span class="comment">!! QAGS estimates the integral of a function.</span>
- <a name="l01696"></a>01696 <span class="comment">!</span>
- <a name="l01697"></a>01697 <span class="comment">! Discussion:</span>
- <a name="l01698"></a>01698 <span class="comment">!</span>
- <a name="l01699"></a>01699 <span class="comment">! The routine calculates an approximation RESULT to a definite integral </span>
- <a name="l01700"></a>01700 <span class="comment">! I = integral of F over (A,B),</span>
- <a name="l01701"></a>01701 <span class="comment">! hopefully satisfying</span>
- <a name="l01702"></a>01702 <span class="comment">! || I - RESULT || <= max ( EPSABS, EPSREL * ||I|| ).</span>
- <a name="l01703"></a>01703 <span class="comment">!</span>
- <a name="l01704"></a>01704 <span class="comment">! Author:</span>
- <a name="l01705"></a>01705 <span class="comment">!</span>
- <a name="l01706"></a>01706 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l01707"></a>01707 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l01708"></a>01708 <span class="comment">!</span>
- <a name="l01709"></a>01709 <span class="comment">! Reference:</span>
- <a name="l01710"></a>01710 <span class="comment">!</span>
- <a name="l01711"></a>01711 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l01712"></a>01712 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l01713"></a>01713 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l01714"></a>01714 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l01715"></a>01715 <span class="comment">!</span>
- <a name="l01716"></a>01716 <span class="comment">! Parameters:</span>
- <a name="l01717"></a>01717 <span class="comment">!</span>
- <a name="l01718"></a>01718 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l01719"></a>01719 <span class="comment">! function f ( x )</span>
- <a name="l01720"></a>01720 <span class="comment">! real f</span>
- <a name="l01721"></a>01721 <span class="comment">! real x</span>
- <a name="l01722"></a>01722 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l01723"></a>01723 <span class="comment">!</span>
- <a name="l01724"></a>01724 <span class="comment">! Input, real A, B, the limits of integration.</span>
- <a name="l01725"></a>01725 <span class="comment">!</span>
- <a name="l01726"></a>01726 <span class="comment">! Input, real EPSABS, EPSREL, the absolute and relative accuracy requested.</span>
- <a name="l01727"></a>01727 <span class="comment">!</span>
- <a name="l01728"></a>01728 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l01729"></a>01729 <span class="comment">!</span>
- <a name="l01730"></a>01730 <span class="comment">! Output, real ABSERR, an estimate of || I - RESULT ||.</span>
- <a name="l01731"></a>01731 <span class="comment">!</span>
- <a name="l01732"></a>01732 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l01733"></a>01733 <span class="comment">!</span>
- <a name="l01734"></a>01734 <span class="comment">! Output, integer IER, error flag.</span>
- <a name="l01735"></a>01735 <span class="comment">! ier = 0 normal and reliable termination of the</span>
- <a name="l01736"></a>01736 <span class="comment">! routine. it is assumed that the requested</span>
- <a name="l01737"></a>01737 <span class="comment">! accuracy has been achieved.</span>
- <a name="l01738"></a>01738 <span class="comment">! ier > 0 abnormal termination of the routine</span>
- <a name="l01739"></a>01739 <span class="comment">! the estimates for integral and error are</span>
- <a name="l01740"></a>01740 <span class="comment">! less reliable. it is assumed that the</span>
- <a name="l01741"></a>01741 <span class="comment">! requested accuracy has not been achieved.</span>
- <a name="l01742"></a>01742 <span class="comment">! = 1 maximum number of subdivisions allowed</span>
- <a name="l01743"></a>01743 <span class="comment">! has been achieved. one can allow more sub-</span>
- <a name="l01744"></a>01744 <span class="comment">! divisions by increasing the data value of</span>
- <a name="l01745"></a>01745 <span class="comment">! limit in qags (and taking the according</span>
- <a name="l01746"></a>01746 <span class="comment">! dimension adjustments into account).</span>
- <a name="l01747"></a>01747 <span class="comment">! however, if this yields no improvement</span>
- <a name="l01748"></a>01748 <span class="comment">! it is advised to analyze the integrand</span>
- <a name="l01749"></a>01749 <span class="comment">! in order to determine the integration</span>
- <a name="l01750"></a>01750 <span class="comment">! difficulties. if the position of a</span>
- <a name="l01751"></a>01751 <span class="comment">! local difficulty can be determined (e.g.</span>
- <a name="l01752"></a>01752 <span class="comment">! singularity, discontinuity within the</span>
- <a name="l01753"></a>01753 <span class="comment">! interval) one will probably gain from</span>
- <a name="l01754"></a>01754 <span class="comment">! splitting up the interval at this point</span>
- <a name="l01755"></a>01755 <span class="comment">! and calling the integrator on the sub-</span>
- <a name="l01756"></a>01756 <span class="comment">! ranges. if possible, an appropriate</span>
- <a name="l01757"></a>01757 <span class="comment">! special-purpose integrator should be used,</span>
- <a name="l01758"></a>01758 <span class="comment">! which is designed for handling the type</span>
- <a name="l01759"></a>01759 <span class="comment">! of difficulty involved.</span>
- <a name="l01760"></a>01760 <span class="comment">! = 2 the occurrence of roundoff error is detec-</span>
- <a name="l01761"></a>01761 <span class="comment">! ted, which prevents the requested</span>
- <a name="l01762"></a>01762 <span class="comment">! tolerance from being achieved.</span>
- <a name="l01763"></a>01763 <span class="comment">! the error may be under-estimated.</span>
- <a name="l01764"></a>01764 <span class="comment">! = 3 extremely bad integrand behavior occurs</span>
- <a name="l01765"></a>01765 <span class="comment">! at some points of the integration</span>
- <a name="l01766"></a>01766 <span class="comment">! interval.</span>
- <a name="l01767"></a>01767 <span class="comment">! = 4 the algorithm does not converge. roundoff</span>
- <a name="l01768"></a>01768 <span class="comment">! error is detected in the extrapolation</span>
- <a name="l01769"></a>01769 <span class="comment">! table. it is presumed that the requested</span>
- <a name="l01770"></a>01770 <span class="comment">! tolerance cannot be achieved, and that the</span>
- <a name="l01771"></a>01771 <span class="comment">! returned result is the best which can be</span>
- <a name="l01772"></a>01772 <span class="comment">! obtained.</span>
- <a name="l01773"></a>01773 <span class="comment">! = 5 the integral is probably divergent, or</span>
- <a name="l01774"></a>01774 <span class="comment">! slowly convergent. it must be noted that</span>
- <a name="l01775"></a>01775 <span class="comment">! divergence can occur with any other value</span>
- <a name="l01776"></a>01776 <span class="comment">! of ier.</span>
- <a name="l01777"></a>01777 <span class="comment">! = 6 the input is invalid, because</span>
- <a name="l01778"></a>01778 <span class="comment">! epsabs < 0 and epsrel < 0,</span>
- <a name="l01779"></a>01779 <span class="comment">! result, abserr and neval are set to zero.</span>
- <a name="l01780"></a>01780 <span class="comment">!</span>
- <a name="l01781"></a>01781 <span class="comment">! Local Parameters:</span>
- <a name="l01782"></a>01782 <span class="comment">!</span>
- <a name="l01783"></a>01783 <span class="comment">! alist - list of left end points of all subintervals</span>
- <a name="l01784"></a>01784 <span class="comment">! considered up to now</span>
- <a name="l01785"></a>01785 <span class="comment">! blist - list of right end points of all subintervals</span>
- <a name="l01786"></a>01786 <span class="comment">! considered up to now</span>
- <a name="l01787"></a>01787 <span class="comment">! rlist(i) - approximation to the integral over</span>
- <a name="l01788"></a>01788 <span class="comment">! (alist(i),blist(i))</span>
- <a name="l01789"></a>01789 <span class="comment">! rlist2 - array of dimension at least limexp+2 containing</span>
- <a name="l01790"></a>01790 <span class="comment">! the part of the epsilon table which is still</span>
- <a name="l01791"></a>01791 <span class="comment">! needed for further computations</span>
- <a name="l01792"></a>01792 <span class="comment">! elist(i) - error estimate applying to rlist(i)</span>
- <a name="l01793"></a>01793 <span class="comment">! maxerr - pointer to the interval with largest error</span>
- <a name="l01794"></a>01794 <span class="comment">! estimate</span>
- <a name="l01795"></a>01795 <span class="comment">! errmax - elist(maxerr)</span>
- <a name="l01796"></a>01796 <span class="comment">! erlast - error on the interval currently subdivided</span>
- <a name="l01797"></a>01797 <span class="comment">! (before that subdivision has taken place)</span>
- <a name="l01798"></a>01798 <span class="comment">! area - sum of the integrals over the subintervals</span>
- <a name="l01799"></a>01799 <span class="comment">! errsum - sum of the errors over the subintervals</span>
- <a name="l01800"></a>01800 <span class="comment">! errbnd - requested accuracy max(epsabs,epsrel*</span>
- <a name="l01801"></a>01801 <span class="comment">! abs(result))</span>
- <a name="l01802"></a>01802 <span class="comment">! *****1 - variable for the left interval</span>
- <a name="l01803"></a>01803 <span class="comment">! *****2 - variable for the right interval</span>
- <a name="l01804"></a>01804 <span class="comment">! last - index for subdivision</span>
- <a name="l01805"></a>01805 <span class="comment">! nres - number of calls to the extrapolation routine</span>
- <a name="l01806"></a>01806 <span class="comment">! numrl2 - number of elements currently in rlist2. if an</span>
- <a name="l01807"></a>01807 <span class="comment">! appropriate approximation to the compounded</span>
- <a name="l01808"></a>01808 <span class="comment">! integral has been obtained it is put in</span>
- <a name="l01809"></a>01809 <span class="comment">! rlist2(numrl2) after numrl2 has been increased</span>
- <a name="l01810"></a>01810 <span class="comment">! by one.</span>
- <a name="l01811"></a>01811 <span class="comment">! small - length of the smallest interval considered</span>
- <a name="l01812"></a>01812 <span class="comment">! up to now, multiplied by 1.5</span>
- <a name="l01813"></a>01813 <span class="comment">! erlarg - sum of the errors over the intervals larger</span>
- <a name="l01814"></a>01814 <span class="comment">! than the smallest interval considered up to now</span>
- <a name="l01815"></a>01815 <span class="comment">! extrap - logical variable denoting that the routine is</span>
- <a name="l01816"></a>01816 <span class="comment">! attempting to perform extrapolation i.e. before</span>
- <a name="l01817"></a>01817 <span class="comment">! subdividing the smallest interval we try to</span>
- <a name="l01818"></a>01818 <span class="comment">! decrease the value of erlarg.</span>
- <a name="l01819"></a>01819 <span class="comment">! noext - logical variable denoting that extrapolation</span>
- <a name="l01820"></a>01820 <span class="comment">! is no longer allowed (true value)</span>
- <a name="l01821"></a>01821 <span class="comment">!</span>
- <a name="l01822"></a>01822 <span class="keyword">implicit none</span>
- <a name="l01823"></a>01823
- <a name="l01824"></a>01824 <span class="keywordtype">integer</span>, <span class="keywordtype">parameter</span> :: limit = 500
- <a name="l01825"></a>01825
- <a name="l01826"></a>01826 <span class="keywordtype">real</span> a
- <a name="l01827"></a>01827 <span class="keywordtype">real</span> abseps
- <a name="l01828"></a>01828 <span class="keywordtype">real</span> abserr
- <a name="l01829"></a>01829 <span class="keywordtype">real</span> alist(limit)
- <a name="l01830"></a>01830 <span class="keywordtype">real</span> area
- <a name="l01831"></a>01831 <span class="keywordtype">real</span> area1
- <a name="l01832"></a>01832 <span class="keywordtype">real</span> area12
- <a name="l01833"></a>01833 <span class="keywordtype">real</span> area2
- <a name="l01834"></a>01834 <span class="keywordtype">real</span> a1
- <a name="l01835"></a>01835 <span class="keywordtype">real</span> a2
- <a name="l01836"></a>01836 <span class="keywordtype">real</span> b
- <a name="l01837"></a>01837 <span class="keywordtype">real</span> blist(limit)
- <a name="l01838"></a>01838 <span class="keywordtype">real</span> b1
- <a name="l01839"></a>01839 <span class="keywordtype">real</span> b2
- <a name="l01840"></a>01840 <span class="keywordtype">real</span> correc
- <a name="l01841"></a>01841 <span class="keywordtype">real</span> defabs
- <a name="l01842"></a>01842 <span class="keywordtype">real</span> defab1
- <a name="l01843"></a>01843 <span class="keywordtype">real</span> defab2
- <a name="l01844"></a>01844 <span class="keywordtype">real</span> dres
- <a name="l01845"></a>01845 <span class="keywordtype">real</span> elist(limit)
- <a name="l01846"></a>01846 <span class="keywordtype">real</span> epsabs
- <a name="l01847"></a>01847 <span class="keywordtype">real</span> epsrel
- <a name="l01848"></a>01848 <span class="keywordtype">real</span> erlarg
- <a name="l01849"></a>01849 <span class="keywordtype">real</span> erlast
- <a name="l01850"></a>01850 <span class="keywordtype">real</span> errbnd
- <a name="l01851"></a>01851 <span class="keywordtype">real</span> errmax
- <a name="l01852"></a>01852 <span class="keywordtype">real</span> error1
- <a name="l01853"></a>01853 <span class="keywordtype">real</span> error2
- <a name="l01854"></a>01854 <span class="keywordtype">real</span> erro12
- <a name="l01855"></a>01855 <span class="keywordtype">real</span> errsum
- <a name="l01856"></a>01856 <span class="keywordtype">real</span> ertest
- <a name="l01857"></a>01857 <span class="keywordtype">logical</span> extrap
- <a name="l01858"></a>01858 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l01859"></a>01859 <span class="keywordtype">integer</span> id
- <a name="l01860"></a>01860 <span class="keywordtype">integer</span> ier
- <a name="l01861"></a>01861 <span class="keywordtype">integer</span> ierro
- <a name="l01862"></a>01862 <span class="keywordtype">integer</span> iord(limit)
- <a name="l01863"></a>01863 <span class="keywordtype">integer</span> iroff1
- <a name="l01864"></a>01864 <span class="keywordtype">integer</span> iroff2
- <a name="l01865"></a>01865 <span class="keywordtype">integer</span> iroff3
- <a name="l01866"></a>01866 <span class="keywordtype">integer</span> jupbnd
- <a name="l01867"></a>01867 <span class="keywordtype">integer</span> k
- <a name="l01868"></a>01868 <span class="keywordtype">integer</span> ksgn
- <a name="l01869"></a>01869 <span class="keywordtype">integer</span> ktmin
- <a name="l01870"></a>01870 <span class="keywordtype">integer</span> last
- <a name="l01871"></a>01871 <span class="keywordtype">logical</span> noext
- <a name="l01872"></a>01872 <span class="keywordtype">integer</span> maxerr
- <a name="l01873"></a>01873 <span class="keywordtype">integer</span> neval
- <a name="l01874"></a>01874 <span class="keywordtype">integer</span> nres
- <a name="l01875"></a>01875 <span class="keywordtype">integer</span> nrmax
- <a name="l01876"></a>01876 <span class="keywordtype">integer</span> numrl2
- <a name="l01877"></a>01877 <span class="keywordtype">real</span> resabs
- <a name="l01878"></a>01878 <span class="keywordtype">real</span> reseps
- <a name="l01879"></a>01879 <span class="keywordtype">real</span> result
- <a name="l01880"></a>01880 <span class="keywordtype">real</span> res3la(3)
- <a name="l01881"></a>01881 <span class="keywordtype">real</span> rlist(limit)
- <a name="l01882"></a>01882 <span class="keywordtype">real</span> rlist2(52)
- <a name="l01883"></a>01883 <span class="keywordtype">real</span> small
- <a name="l01884"></a>01884 <span class="comment">!</span>
- <a name="l01885"></a>01885 <span class="comment">! The dimension of rlist2 is determined by the value of</span>
- <a name="l01886"></a>01886 <span class="comment">! limexp in QEXTR (rlist2 should be of dimension</span>
- <a name="l01887"></a>01887 <span class="comment">! (limexp+2) at least).</span>
- <a name="l01888"></a>01888 <span class="comment">!</span>
- <a name="l01889"></a>01889 <span class="comment">! Test on validity of parameters.</span>
- <a name="l01890"></a>01890 <span class="comment">!</span>
- <a name="l01891"></a>01891 ier = 0
- <a name="l01892"></a>01892 neval = 0
- <a name="l01893"></a>01893 last = 0
- <a name="l01894"></a>01894 result = 0.0e+00
- <a name="l01895"></a>01895 abserr = 0.0e+00
- <a name="l01896"></a>01896 alist(1) = a
- <a name="l01897"></a>01897 blist(1) = b
- <a name="l01898"></a>01898 rlist(1) = 0.0e+00
- <a name="l01899"></a>01899 elist(1) = 0.0e+00
- <a name="l01900"></a>01900
- <a name="l01901"></a>01901 <span class="keyword">if</span> ( epsabs < 0.0e+00 .and. epsrel < 0.0e+00 ) <span class="keyword">then</span>
- <a name="l01902"></a>01902 ier = 6
- <a name="l01903"></a>01903 return
- <a name="l01904"></a>01904 <span class="keyword">end if</span>
- <a name="l01905"></a>01905 <span class="comment">!</span>
- <a name="l01906"></a>01906 <span class="comment">! First approximation to the integral.</span>
- <a name="l01907"></a>01907 <span class="comment">!</span>
- <a name="l01908"></a>01908 ierro = 0
- <a name="l01909"></a>01909 call <a class="code" href="quadpack_8f90.html#a27241a527b249e9de59a5ed6bee5f805">qk21 </a>( f, a, b, result, abserr, defabs, resabs )
- <a name="l01910"></a>01910 <span class="comment">!</span>
- <a name="l01911"></a>01911 <span class="comment">! Test on accuracy.</span>
- <a name="l01912"></a>01912 <span class="comment">!</span>
- <a name="l01913"></a>01913 dres = abs ( result )
- <a name="l01914"></a>01914 errbnd = max ( epsabs, epsrel * dres )
- <a name="l01915"></a>01915 last = 1
- <a name="l01916"></a>01916 rlist(1) = result
- <a name="l01917"></a>01917 elist(1) = abserr
- <a name="l01918"></a>01918 iord(1) = 1
- <a name="l01919"></a>01919
- <a name="l01920"></a>01920 <span class="keyword">if</span> ( abserr <= 1.0e+02 * epsilon ( defabs ) * defabs .and. &
- <a name="l01921"></a>01921 abserr > errbnd ) <span class="keyword">then</span>
- <a name="l01922"></a>01922 ier = 2
- <a name="l01923"></a>01923 <span class="keyword">end if</span>
- <a name="l01924"></a>01924
- <a name="l01925"></a>01925 <span class="keyword">if</span> ( limit == 1 ) <span class="keyword">then</span>
- <a name="l01926"></a>01926 ier = 1
- <a name="l01927"></a>01927 <span class="keyword">end if</span>
- <a name="l01928"></a>01928
- <a name="l01929"></a>01929 <span class="keyword">if</span> ( ier /= 0 .or. (abserr <= errbnd .and. abserr /= resabs ) .or. &
- <a name="l01930"></a>01930 abserr == 0.0e+00 ) go to 140
- <a name="l01931"></a>01931 <span class="comment">!</span>
- <a name="l01932"></a>01932 <span class="comment">! Initialization.</span>
- <a name="l01933"></a>01933 <span class="comment">!</span>
- <a name="l01934"></a>01934 rlist2(1) = result
- <a name="l01935"></a>01935 errmax = abserr
- <a name="l01936"></a>01936 maxerr = 1
- <a name="l01937"></a>01937 area = result
- <a name="l01938"></a>01938 errsum = abserr
- <a name="l01939"></a>01939 abserr = huge ( abserr )
- <a name="l01940"></a>01940 nrmax = 1
- <a name="l01941"></a>01941 nres = 0
- <a name="l01942"></a>01942 numrl2 = 2
- <a name="l01943"></a>01943 ktmin = 0
- <a name="l01944"></a>01944 extrap = .false.
- <a name="l01945"></a>01945 noext = .false.
- <a name="l01946"></a>01946 iroff1 = 0
- <a name="l01947"></a>01947 iroff2 = 0
- <a name="l01948"></a>01948 iroff3 = 0
- <a name="l01949"></a>01949
- <a name="l01950"></a>01950 <span class="keyword">if</span> ( dres >= (1.0e+00-5.0e+01* epsilon ( defabs ) ) * defabs ) <span class="keyword">then</span>
- <a name="l01951"></a>01951 ksgn = 1
- <a name="l01952"></a>01952 <span class="keyword">else</span>
- <a name="l01953"></a>01953 ksgn = -1
- <a name="l01954"></a>01954 <span class="keyword">end if</span>
- <a name="l01955"></a>01955
- <a name="l01956"></a>01956 <span class="keyword">do</span> last = 2, limit
- <a name="l01957"></a>01957 <span class="comment">!</span>
- <a name="l01958"></a>01958 <span class="comment">! Bisect the subinterval with the nrmax-th largest error estimate.</span>
- <a name="l01959"></a>01959 <span class="comment">!</span>
- <a name="l01960"></a>01960 a1 = alist(maxerr)
- <a name="l01961"></a>01961 b1 = 5.0e-01 * ( alist(maxerr) + blist(maxerr) )
- <a name="l01962"></a>01962 a2 = b1
- <a name="l01963"></a>01963 b2 = blist(maxerr)
- <a name="l01964"></a>01964 erlast = errmax
- <a name="l01965"></a>01965 call <a class="code" href="quadpack_8f90.html#a27241a527b249e9de59a5ed6bee5f805">qk21 </a>( f, a1, b1, area1, error1, resabs, defab1 )
- <a name="l01966"></a>01966 call <a class="code" href="quadpack_8f90.html#a27241a527b249e9de59a5ed6bee5f805">qk21 </a>( f, a2, b2, area2, error2, resabs, defab2 )
- <a name="l01967"></a>01967 <span class="comment">!</span>
- <a name="l01968"></a>01968 <span class="comment">! Improve previous approximations to integral and error</span>
- <a name="l01969"></a>01969 <span class="comment">! and test for accuracy.</span>
- <a name="l01970"></a>01970 <span class="comment">!</span>
- <a name="l01971"></a>01971 area12 = area1+area2
- <a name="l01972"></a>01972 erro12 = error1+error2
- <a name="l01973"></a>01973 errsum = errsum+erro12-errmax
- <a name="l01974"></a>01974 area = area+area12-rlist(maxerr)
- <a name="l01975"></a>01975
- <a name="l01976"></a>01976 <span class="keyword">if</span> ( defab1 == error1 .or. defab2 == error2 ) go to 15
- <a name="l01977"></a>01977
- <a name="l01978"></a>01978 <span class="keyword">if</span> ( abs ( rlist(maxerr) - area12) > 1.0e-05 * abs(area12) &
- <a name="l01979"></a>01979 .or. erro12 < 9.9e-01 * errmax ) go to 10
- <a name="l01980"></a>01980
- <a name="l01981"></a>01981 <span class="keyword">if</span> ( extrap ) <span class="keyword">then</span>
- <a name="l01982"></a>01982 iroff2 = iroff2+1
- <a name="l01983"></a>01983 <span class="keyword">else</span>
- <a name="l01984"></a>01984 iroff1 = iroff1+1
- <a name="l01985"></a>01985 <span class="keyword">end if</span>
- <a name="l01986"></a>01986
- <a name="l01987"></a>01987 10 continue
- <a name="l01988"></a>01988
- <a name="l01989"></a>01989 <span class="keyword">if</span> ( last > 10 .and. erro12 > errmax ) <span class="keyword">then</span>
- <a name="l01990"></a>01990 iroff3 = iroff3+1
- <a name="l01991"></a>01991 <span class="keyword">end if</span>
- <a name="l01992"></a>01992
- <a name="l01993"></a>01993 15 continue
- <a name="l01994"></a>01994
- <a name="l01995"></a>01995 rlist(maxerr) = area1
- <a name="l01996"></a>01996 rlist(last) = area2
- <a name="l01997"></a>01997 errbnd = max ( epsabs, epsrel*abs(area) )
- <a name="l01998"></a>01998 <span class="comment">!</span>
- <a name="l01999"></a>01999 <span class="comment">! Test for roundoff error and eventually set error flag.</span>
- <a name="l02000"></a>02000 <span class="comment">!</span>
- <a name="l02001"></a>02001 <span class="keyword">if</span> ( iroff1+iroff2 >= 10 .or. iroff3 >= 20 ) <span class="keyword">then</span>
- <a name="l02002"></a>02002 ier = 2
- <a name="l02003"></a>02003 <span class="keyword">end if</span>
- <a name="l02004"></a>02004
- <a name="l02005"></a>02005 <span class="keyword">if</span> ( iroff2 >= 5 ) <span class="keyword">then</span>
- <a name="l02006"></a>02006 ierro = 3
- <a name="l02007"></a>02007 <span class="keyword">end if</span>
- <a name="l02008"></a>02008 <span class="comment">!</span>
- <a name="l02009"></a>02009 <span class="comment">! Set error flag in the case that the number of subintervals</span>
- <a name="l02010"></a>02010 <span class="comment">! equals limit.</span>
- <a name="l02011"></a>02011 <span class="comment">!</span>
- <a name="l02012"></a>02012 <span class="keyword">if</span> ( last == limit ) <span class="keyword">then</span>
- <a name="l02013"></a>02013 ier = 1
- <a name="l02014"></a>02014 <span class="keyword">end if</span>
- <a name="l02015"></a>02015 <span class="comment">!</span>
- <a name="l02016"></a>02016 <span class="comment">! Set error flag in the case of bad integrand behavior</span>
- <a name="l02017"></a>02017 <span class="comment">! at a point of the integration range.</span>
- <a name="l02018"></a>02018 <span class="comment">!</span>
- <a name="l02019"></a>02019 <span class="keyword">if</span> ( max ( abs(a1),abs(b2)) <= (1.0e+00+1.0e+03* epsilon ( a1 ) )* &
- <a name="l02020"></a>02020 (abs(a2)+1.0e+03* tiny ( a2 ) ) ) <span class="keyword">then</span>
- <a name="l02021"></a>02021 ier = 4
- <a name="l02022"></a>02022 <span class="keyword">end if</span>
- <a name="l02023"></a>02023 <span class="comment">!</span>
- <a name="l02024"></a>02024 <span class="comment">! Append the newly-created intervals to the list.</span>
- <a name="l02025"></a>02025 <span class="comment">!</span>
- <a name="l02026"></a>02026 <span class="keyword">if</span> ( error2 <= error1 ) <span class="keyword">then</span>
- <a name="l02027"></a>02027 alist(last) = a2
- <a name="l02028"></a>02028 blist(maxerr) = b1
- <a name="l02029"></a>02029 blist(last) = b2
- <a name="l02030"></a>02030 elist(maxerr) = error1
- <a name="l02031"></a>02031 elist(last) = error2
- <a name="l02032"></a>02032 <span class="keyword">else</span>
- <a name="l02033"></a>02033 alist(maxerr) = a2
- <a name="l02034"></a>02034 alist(last) = a1
- <a name="l02035"></a>02035 blist(last) = b1
- <a name="l02036"></a>02036 rlist(maxerr) = area2
- <a name="l02037"></a>02037 rlist(last) = area1
- <a name="l02038"></a>02038 elist(maxerr) = error2
- <a name="l02039"></a>02039 elist(last) = error1
- <a name="l02040"></a>02040 <span class="keyword">end if</span>
- <a name="l02041"></a>02041 <span class="comment">!</span>
- <a name="l02042"></a>02042 <span class="comment">! Call QSORT to maintain the descending ordering</span>
- <a name="l02043"></a>02043 <span class="comment">! in the list of error estimates and select the subinterval</span>
- <a name="l02044"></a>02044 <span class="comment">! with nrmax-th largest error estimate (to be bisected next).</span>
- <a name="l02045"></a>02045 <span class="comment">!</span>
- <a name="l02046"></a>02046 call <a class="code" href="quadpack_8f90.html#a55e08a684c5a6315fb37dd0fdc66d8e6">qsort </a>( limit, last, maxerr, errmax, elist, iord, nrmax )
- <a name="l02047"></a>02047
- <a name="l02048"></a>02048 <span class="keyword">if</span> ( errsum <= errbnd ) go to 115
- <a name="l02049"></a>02049
- <a name="l02050"></a>02050 <span class="keyword">if</span> ( ier /= 0 ) <span class="keyword">then</span>
- <a name="l02051"></a>02051 exit
- <a name="l02052"></a>02052 <span class="keyword">end if</span>
- <a name="l02053"></a>02053
- <a name="l02054"></a>02054 <span class="keyword">if</span> ( last == 2 ) go to 80
- <a name="l02055"></a>02055 <span class="keyword">if</span> ( noext ) go to 90
- <a name="l02056"></a>02056
- <a name="l02057"></a>02057 erlarg = erlarg-erlast
- <a name="l02058"></a>02058
- <a name="l02059"></a>02059 <span class="keyword">if</span> ( abs(b1-a1) > small ) <span class="keyword">then</span>
- <a name="l02060"></a>02060 erlarg = erlarg+erro12
- <a name="l02061"></a>02061 <span class="keyword">end if</span>
- <a name="l02062"></a>02062 <span class="comment">!</span>
- <a name="l02063"></a>02063 <span class="comment">! Test whether the interval to be bisected next is the</span>
- <a name="l02064"></a>02064 <span class="comment">! smallest interval.</span>
- <a name="l02065"></a>02065 <span class="comment">!</span>
- <a name="l02066"></a>02066 <span class="keyword">if</span> ( .not. extrap ) <span class="keyword">then</span>
- <a name="l02067"></a>02067 <span class="keyword">if</span> ( abs(blist(maxerr)-alist(maxerr)) > small ) go to 90
- <a name="l02068"></a>02068 extrap = .true.
- <a name="l02069"></a>02069 nrmax = 2
- <a name="l02070"></a>02070 <span class="keyword">end if</span>
- <a name="l02071"></a>02071
- <a name="l02072"></a>02072 <span class="comment">!40 continue</span>
- <a name="l02073"></a>02073 <span class="comment">!</span>
- <a name="l02074"></a>02074 <span class="comment">! The smallest interval has the largest error.</span>
- <a name="l02075"></a>02075 <span class="comment">! Before bisecting decrease the sum of the errors over the</span>
- <a name="l02076"></a>02076 <span class="comment">! larger intervals (erlarg) and perform extrapolation.</span>
- <a name="l02077"></a>02077 <span class="comment">!</span>
- <a name="l02078"></a>02078 <span class="keyword">if</span> ( ierro /= 3 .and. erlarg > ertest ) <span class="keyword">then</span>
- <a name="l02079"></a>02079
- <a name="l02080"></a>02080 id = nrmax
- <a name="l02081"></a>02081 jupbnd = last
- <a name="l02082"></a>02082
- <a name="l02083"></a>02083 <span class="keyword">if</span> ( last > (2+limit/2) ) <span class="keyword">then</span>
- <a name="l02084"></a>02084 jupbnd = limit+3-last
- <a name="l02085"></a>02085 <span class="keyword">end if</span>
- <a name="l02086"></a>02086
- <a name="l02087"></a>02087 <span class="keyword">do</span> k = id, jupbnd
- <a name="l02088"></a>02088 maxerr = iord(nrmax)
- <a name="l02089"></a>02089 errmax = elist(maxerr)
- <a name="l02090"></a>02090 <span class="keyword">if</span> ( abs(blist(maxerr)-alist(maxerr)) > small ) <span class="keyword">then</span>
- <a name="l02091"></a>02091 go to 90
- <a name="l02092"></a>02092 <span class="keyword">end if</span>
- <a name="l02093"></a>02093 nrmax = nrmax+1
- <a name="l02094"></a>02094 <span class="keyword">end do</span>
- <a name="l02095"></a>02095
- <a name="l02096"></a>02096 <span class="keyword">end if</span>
- <a name="l02097"></a>02097 <span class="comment">!</span>
- <a name="l02098"></a>02098 <span class="comment">! Perform extrapolation.</span>
- <a name="l02099"></a>02099 <span class="comment">!</span>
- <a name="l02100"></a>02100 <span class="comment">!60 continue</span>
- <a name="l02101"></a>02101
- <a name="l02102"></a>02102 numrl2 = numrl2+1
- <a name="l02103"></a>02103 rlist2(numrl2) = area
- <a name="l02104"></a>02104 call <a class="code" href="quadpack_8f90.html#a5a75101d080f224c63adde98a0e64386">qextr </a>( numrl2, rlist2, reseps, abseps, res3la, nres )
- <a name="l02105"></a>02105 ktmin = ktmin+1
- <a name="l02106"></a>02106
- <a name="l02107"></a>02107 <span class="keyword">if</span> ( ktmin > 5 .and. abserr < 1.0e-03 * errsum ) <span class="keyword">then</span>
- <a name="l02108"></a>02108 ier = 5
- <a name="l02109"></a>02109 <span class="keyword">end if</span>
- <a name="l02110"></a>02110
- <a name="l02111"></a>02111 <span class="keyword">if</span> ( abseps < abserr ) <span class="keyword">then</span>
- <a name="l02112"></a>02112
- <a name="l02113"></a>02113 ktmin = 0
- <a name="l02114"></a>02114 abserr = abseps
- <a name="l02115"></a>02115 result = reseps
- <a name="l02116"></a>02116 correc = erlarg
- <a name="l02117"></a>02117 ertest = max ( epsabs,epsrel*abs(reseps))
- <a name="l02118"></a>02118
- <a name="l02119"></a>02119 <span class="keyword">if</span> ( abserr <= ertest ) <span class="keyword">then</span>
- <a name="l02120"></a>02120 exit
- <a name="l02121"></a>02121 <span class="keyword">end if</span>
- <a name="l02122"></a>02122
- <a name="l02123"></a>02123 <span class="keyword">end if</span>
- <a name="l02124"></a>02124 <span class="comment">!</span>
- <a name="l02125"></a>02125 <span class="comment">! Prepare bisection of the smallest interval.</span>
- <a name="l02126"></a>02126 <span class="comment">!</span>
- <a name="l02127"></a>02127 <span class="keyword">if</span> ( numrl2 == 1 ) <span class="keyword">then</span>
- <a name="l02128"></a>02128 noext = .true.
- <a name="l02129"></a>02129 <span class="keyword">end if</span>
- <a name="l02130"></a>02130
- <a name="l02131"></a>02131 <span class="keyword">if</span> ( ier == 5 ) <span class="keyword">then</span>
- <a name="l02132"></a>02132 exit
- <a name="l02133"></a>02133 <span class="keyword">end if</span>
- <a name="l02134"></a>02134
- <a name="l02135"></a>02135 maxerr = iord(1)
- <a name="l02136"></a>02136 errmax = elist(maxerr)
- <a name="l02137"></a>02137 nrmax = 1
- <a name="l02138"></a>02138 extrap = .false.
- <a name="l02139"></a>02139 small = small * 5.0e-01
- <a name="l02140"></a>02140 erlarg = errsum
- <a name="l02141"></a>02141 go to 90
- <a name="l02142"></a>02142
- <a name="l02143"></a>02143 80 continue
- <a name="l02144"></a>02144
- <a name="l02145"></a>02145 small = abs ( b - a ) * 3.75e-01
- <a name="l02146"></a>02146 erlarg = errsum
- <a name="l02147"></a>02147 ertest = errbnd
- <a name="l02148"></a>02148 rlist2(2) = area
- <a name="l02149"></a>02149
- <a name="l02150"></a>02150 90 continue
- <a name="l02151"></a>02151
- <a name="l02152"></a>02152 <span class="keyword">end do</span>
- <a name="l02153"></a>02153 <span class="comment">!</span>
- <a name="l02154"></a>02154 <span class="comment">! Set final result and error estimate.</span>
- <a name="l02155"></a>02155 <span class="comment">!</span>
- <a name="l02156"></a>02156 <span class="keyword">if</span> ( abserr == huge ( abserr ) ) <span class="keyword">then</span>
- <a name="l02157"></a>02157 go to 115
- <a name="l02158"></a>02158 <span class="keyword">end if</span>
- <a name="l02159"></a>02159
- <a name="l02160"></a>02160 <span class="keyword">if</span> ( ier + ierro == 0 ) <span class="keyword">then</span>
- <a name="l02161"></a>02161 go to 110
- <a name="l02162"></a>02162 <span class="keyword">end if</span>
- <a name="l02163"></a>02163
- <a name="l02164"></a>02164 <span class="keyword">if</span> ( ierro == 3 ) <span class="keyword">then</span>
- <a name="l02165"></a>02165 abserr = abserr + correc
- <a name="l02166"></a>02166 <span class="keyword">end if</span>
- <a name="l02167"></a>02167
- <a name="l02168"></a>02168 <span class="keyword">if</span> ( ier == 0 ) <span class="keyword">then</span>
- <a name="l02169"></a>02169 ier = 3
- <a name="l02170"></a>02170 <span class="keyword">end if</span>
- <a name="l02171"></a>02171
- <a name="l02172"></a>02172 <span class="keyword">if</span> ( result /= 0.0e+00.and.area /= 0.0e+00 ) <span class="keyword">then</span>
- <a name="l02173"></a>02173 go to 105
- <a name="l02174"></a>02174 <span class="keyword">end if</span>
- <a name="l02175"></a>02175
- <a name="l02176"></a>02176 <span class="keyword">if</span> ( abserr > errsum ) go to 115
- <a name="l02177"></a>02177 <span class="keyword">if</span> ( area == 0.0e+00 ) go to 130
- <a name="l02178"></a>02178 go to 110
- <a name="l02179"></a>02179
- <a name="l02180"></a>02180 105 continue
- <a name="l02181"></a>02181
- <a name="l02182"></a>02182 <span class="keyword">if</span> ( abserr/abs(result) > errsum/abs(area) ) go to 115
- <a name="l02183"></a>02183 <span class="comment">!</span>
- <a name="l02184"></a>02184 <span class="comment">! Test on divergence.</span>
- <a name="l02185"></a>02185 <span class="comment">!</span>
- <a name="l02186"></a>02186 110 continue
- <a name="l02187"></a>02187
- <a name="l02188"></a>02188 <span class="keyword">if</span> ( ksgn == (-1).and.max ( abs(result),abs(area)) <= &
- <a name="l02189"></a>02189 defabs*1.0e-02 ) go to 130
- <a name="l02190"></a>02190
- <a name="l02191"></a>02191 <span class="keyword">if</span> ( 1.0e-02 > (result/area) .or. (result/area) > 1.0e+02 &
- <a name="l02192"></a>02192 .or. errsum > abs(area) ) <span class="keyword">then</span>
- <a name="l02193"></a>02193 ier = 6
- <a name="l02194"></a>02194 <span class="keyword">end if</span>
- <a name="l02195"></a>02195
- <a name="l02196"></a>02196 go to 130
- <a name="l02197"></a>02197 <span class="comment">!</span>
- <a name="l02198"></a>02198 <span class="comment">! Compute global integral sum.</span>
- <a name="l02199"></a>02199 <span class="comment">!</span>
- <a name="l02200"></a>02200 115 continue
- <a name="l02201"></a>02201
- <a name="l02202"></a>02202 result = sum ( rlist(1:last) )
- <a name="l02203"></a>02203
- <a name="l02204"></a>02204 abserr = errsum
- <a name="l02205"></a>02205
- <a name="l02206"></a>02206 130 continue
- <a name="l02207"></a>02207
- <a name="l02208"></a>02208 <span class="keyword">if</span> ( 2 < ier ) <span class="keyword">then</span>
- <a name="l02209"></a>02209 ier = ier - 1
- <a name="l02210"></a>02210 <span class="keyword">end if</span>
- <a name="l02211"></a>02211
- <a name="l02212"></a>02212 140 continue
- <a name="l02213"></a>02213
- <a name="l02214"></a>02214 neval = 42*last-21
- <a name="l02215"></a>02215
- <a name="l02216"></a>02216 return
- <a name="l02217"></a>02217 <span class="keyword">end</span>
- <a name="l02218"></a><a class="code" href="quadpack_8f90.html#a4cea9ad83248026209e702bb01abb7da">02218</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#a4cea9ad83248026209e702bb01abb7da">qawc</a> ( f, a, b, c, epsabs, epsrel, result, abserr, neval, ier )
- <a name="l02219"></a>02219
- <a name="l02220"></a>02220 <span class="comment">!*****************************************************************************80</span>
- <a name="l02221"></a>02221 <span class="comment">!</span>
- <a name="l02222"></a>02222 <span class="comment">!! QAWC computes a Cauchy principal value.</span>
- <a name="l02223"></a>02223 <span class="comment">!</span>
- <a name="l02224"></a>02224 <span class="comment">! Discussion:</span>
- <a name="l02225"></a>02225 <span class="comment">!</span>
- <a name="l02226"></a>02226 <span class="comment">! The routine calculates an approximation RESULT to a Cauchy principal</span>
- <a name="l02227"></a>02227 <span class="comment">! value </span>
- <a name="l02228"></a>02228 <span class="comment">! I = integral of F*W over (A,B),</span>
- <a name="l02229"></a>02229 <span class="comment">! with</span>
- <a name="l02230"></a>02230 <span class="comment">! W(X) = 1 / (X-C),</span>
- <a name="l02231"></a>02231 <span class="comment">! with C distinct from A and B, hopefully satisfying</span>
- <a name="l02232"></a>02232 <span class="comment">! || I - RESULT || <= max ( EPSABS, EPSREL * ||I|| ).</span>
- <a name="l02233"></a>02233 <span class="comment">!</span>
- <a name="l02234"></a>02234 <span class="comment">! Author:</span>
- <a name="l02235"></a>02235 <span class="comment">!</span>
- <a name="l02236"></a>02236 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l02237"></a>02237 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l02238"></a>02238 <span class="comment">!</span>
- <a name="l02239"></a>02239 <span class="comment">! Reference:</span>
- <a name="l02240"></a>02240 <span class="comment">!</span>
- <a name="l02241"></a>02241 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l02242"></a>02242 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l02243"></a>02243 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l02244"></a>02244 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l02245"></a>02245 <span class="comment">!</span>
- <a name="l02246"></a>02246 <span class="comment">! Parameters:</span>
- <a name="l02247"></a>02247 <span class="comment">!</span>
- <a name="l02248"></a>02248 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l02249"></a>02249 <span class="comment">! function f ( x )</span>
- <a name="l02250"></a>02250 <span class="comment">! real f</span>
- <a name="l02251"></a>02251 <span class="comment">! real x</span>
- <a name="l02252"></a>02252 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l02253"></a>02253 <span class="comment">!</span>
- <a name="l02254"></a>02254 <span class="comment">! Input, real A, B, the limits of integration.</span>
- <a name="l02255"></a>02255 <span class="comment">!</span>
- <a name="l02256"></a>02256 <span class="comment">! Input, real C, a parameter in the weight function, which must</span>
- <a name="l02257"></a>02257 <span class="comment">! not be equal to A or B.</span>
- <a name="l02258"></a>02258 <span class="comment">!</span>
- <a name="l02259"></a>02259 <span class="comment">! Input, real EPSABS, EPSREL, the absolute and relative accuracy requested.</span>
- <a name="l02260"></a>02260 <span class="comment">!</span>
- <a name="l02261"></a>02261 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l02262"></a>02262 <span class="comment">!</span>
- <a name="l02263"></a>02263 <span class="comment">! Output, real ABSERR, an estimate of || I - RESULT ||.</span>
- <a name="l02264"></a>02264 <span class="comment">!</span>
- <a name="l02265"></a>02265 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l02266"></a>02266 <span class="comment">!</span>
- <a name="l02267"></a>02267 <span class="comment">! ier - integer</span>
- <a name="l02268"></a>02268 <span class="comment">! ier = 0 normal and reliable termination of the</span>
- <a name="l02269"></a>02269 <span class="comment">! routine. it is assumed that the requested</span>
- <a name="l02270"></a>02270 <span class="comment">! accuracy has been achieved.</span>
- <a name="l02271"></a>02271 <span class="comment">! ier > 0 abnormal termination of the routine</span>
- <a name="l02272"></a>02272 <span class="comment">! the estimates for integral and error are</span>
- <a name="l02273"></a>02273 <span class="comment">! less reliable. it is assumed that the</span>
- <a name="l02274"></a>02274 <span class="comment">! requested accuracy has not been achieved.</span>
- <a name="l02275"></a>02275 <span class="comment">! ier = 1 maximum number of subdivisions allowed</span>
- <a name="l02276"></a>02276 <span class="comment">! has been achieved. one can allow more sub-</span>
- <a name="l02277"></a>02277 <span class="comment">! divisions by increasing the data value of</span>
- <a name="l02278"></a>02278 <span class="comment">! limit in qawc (and taking the according</span>
- <a name="l02279"></a>02279 <span class="comment">! dimension adjustments into account).</span>
- <a name="l02280"></a>02280 <span class="comment">! however, if this yields no improvement it</span>
- <a name="l02281"></a>02281 <span class="comment">! is advised to analyze the integrand in</span>
- <a name="l02282"></a>02282 <span class="comment">! order to determine the integration</span>
- <a name="l02283"></a>02283 <span class="comment">! difficulties. if the position of a local</span>
- <a name="l02284"></a>02284 <span class="comment">! difficulty can be determined (e.g.</span>
- <a name="l02285"></a>02285 <span class="comment">! singularity, discontinuity within the</span>
- <a name="l02286"></a>02286 <span class="comment">! interval one will probably gain from</span>
- <a name="l02287"></a>02287 <span class="comment">! splitting up the interval at this point</span>
- <a name="l02288"></a>02288 <span class="comment">! and calling appropriate integrators on the</span>
- <a name="l02289"></a>02289 <span class="comment">! subranges.</span>
- <a name="l02290"></a>02290 <span class="comment">! = 2 the occurrence of roundoff error is detec-</span>
- <a name="l02291"></a>02291 <span class="comment">! ted, which prevents the requested</span>
- <a name="l02292"></a>02292 <span class="comment">! tolerance from being achieved.</span>
- <a name="l02293"></a>02293 <span class="comment">! = 3 extremely bad integrand behavior occurs</span>
- <a name="l02294"></a>02294 <span class="comment">! at some points of the integration</span>
- <a name="l02295"></a>02295 <span class="comment">! interval.</span>
- <a name="l02296"></a>02296 <span class="comment">! = 6 the input is invalid, because</span>
- <a name="l02297"></a>02297 <span class="comment">! c = a or c = b or</span>
- <a name="l02298"></a>02298 <span class="comment">! epsabs < 0 and epsrel < 0,</span>
- <a name="l02299"></a>02299 <span class="comment">! result, abserr, neval are set to zero.</span>
- <a name="l02300"></a>02300 <span class="comment">!</span>
- <a name="l02301"></a>02301 <span class="comment">! Local parameters:</span>
- <a name="l02302"></a>02302 <span class="comment">!</span>
- <a name="l02303"></a>02303 <span class="comment">! LIMIT is the maximum number of subintervals allowed in the</span>
- <a name="l02304"></a>02304 <span class="comment">! subdivision process of qawce. take care that limit >= 1.</span>
- <a name="l02305"></a>02305 <span class="comment">!</span>
- <a name="l02306"></a>02306 <span class="keyword">implicit none</span>
- <a name="l02307"></a>02307
- <a name="l02308"></a>02308 <span class="keywordtype">integer</span>, <span class="keywordtype">parameter</span> :: limit = 500
- <a name="l02309"></a>02309
- <a name="l02310"></a>02310 <span class="keywordtype">real</span> a
- <a name="l02311"></a>02311 <span class="keywordtype">real</span> abserr
- <a name="l02312"></a>02312 <span class="keywordtype">real</span> alist(limit)
- <a name="l02313"></a>02313 <span class="keywordtype">real</span> b
- <a name="l02314"></a>02314 <span class="keywordtype">real</span> blist(limit)
- <a name="l02315"></a>02315 <span class="keywordtype">real</span> elist(limit)
- <a name="l02316"></a>02316 <span class="keywordtype">real</span> c
- <a name="l02317"></a>02317 <span class="keywordtype">real</span> epsabs
- <a name="l02318"></a>02318 <span class="keywordtype">real</span> epsrel
- <a name="l02319"></a>02319 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l02320"></a>02320 <span class="keywordtype">integer</span> ier
- <a name="l02321"></a>02321 <span class="keywordtype">integer</span> iord(limit)
- <a name="l02322"></a>02322 <span class="keywordtype">integer</span> last
- <a name="l02323"></a>02323 <span class="keywordtype">integer</span> neval
- <a name="l02324"></a>02324 <span class="keywordtype">real</span> result
- <a name="l02325"></a>02325 <span class="keywordtype">real</span> rlist(limit)
- <a name="l02326"></a>02326
- <a name="l02327"></a>02327 call <a class="code" href="quadpack_8f90.html#a51d7f754a9214f7490c035740fc0aef7">qawce </a>( f, a, b, c, epsabs, epsrel, limit, result, abserr, neval, ier, &
- <a name="l02328"></a>02328 alist, blist, rlist, elist, iord, last )
- <a name="l02329"></a>02329
- <a name="l02330"></a>02330 return
- <a name="l02331"></a>02331 <span class="keyword">end</span>
- <a name="l02332"></a><a class="code" href="quadpack_8f90.html#a51d7f754a9214f7490c035740fc0aef7">02332</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#a51d7f754a9214f7490c035740fc0aef7">qawce</a> ( f, a, b, c, epsabs, epsrel, limit, result, abserr, neval, &
- <a name="l02333"></a>02333 ier, alist, blist, rlist, elist, iord, last )
- <a name="l02334"></a>02334
- <a name="l02335"></a>02335 <span class="comment">!*****************************************************************************80</span>
- <a name="l02336"></a>02336 <span class="comment">!</span>
- <a name="l02337"></a>02337 <span class="comment">!! QAWCE computes a Cauchy principal value.</span>
- <a name="l02338"></a>02338 <span class="comment">!</span>
- <a name="l02339"></a>02339 <span class="comment">! Discussion:</span>
- <a name="l02340"></a>02340 <span class="comment">!</span>
- <a name="l02341"></a>02341 <span class="comment">! The routine calculates an approximation RESULT to a Cauchy principal</span>
- <a name="l02342"></a>02342 <span class="comment">! value </span>
- <a name="l02343"></a>02343 <span class="comment">! I = integral of F*W over (A,B),</span>
- <a name="l02344"></a>02344 <span class="comment">! with</span>
- <a name="l02345"></a>02345 <span class="comment">! W(X) = 1 / ( X - C ),</span>
- <a name="l02346"></a>02346 <span class="comment">! with C distinct from A and B, hopefully satisfying</span>
- <a name="l02347"></a>02347 <span class="comment">! | I - RESULT | <= max ( EPSABS, EPSREL * |I| ).</span>
- <a name="l02348"></a>02348 <span class="comment">!</span>
- <a name="l02349"></a>02349 <span class="comment">! Author:</span>
- <a name="l02350"></a>02350 <span class="comment">!</span>
- <a name="l02351"></a>02351 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l02352"></a>02352 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l02353"></a>02353 <span class="comment">!</span>
- <a name="l02354"></a>02354 <span class="comment">! Reference:</span>
- <a name="l02355"></a>02355 <span class="comment">!</span>
- <a name="l02356"></a>02356 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l02357"></a>02357 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l02358"></a>02358 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l02359"></a>02359 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l02360"></a>02360 <span class="comment">!</span>
- <a name="l02361"></a>02361 <span class="comment">! Parameters:</span>
- <a name="l02362"></a>02362 <span class="comment">!</span>
- <a name="l02363"></a>02363 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l02364"></a>02364 <span class="comment">! function f ( x )</span>
- <a name="l02365"></a>02365 <span class="comment">! real f</span>
- <a name="l02366"></a>02366 <span class="comment">! real x</span>
- <a name="l02367"></a>02367 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l02368"></a>02368 <span class="comment">!</span>
- <a name="l02369"></a>02369 <span class="comment">! Input, real A, B, the limits of integration.</span>
- <a name="l02370"></a>02370 <span class="comment">!</span>
- <a name="l02371"></a>02371 <span class="comment">! Input, real C, a parameter in the weight function, which cannot be</span>
- <a name="l02372"></a>02372 <span class="comment">! equal to A or B.</span>
- <a name="l02373"></a>02373 <span class="comment">!</span>
- <a name="l02374"></a>02374 <span class="comment">! Input, real EPSABS, EPSREL, the absolute and relative accuracy requested.</span>
- <a name="l02375"></a>02375 <span class="comment">!</span>
- <a name="l02376"></a>02376 <span class="comment">! Input, integer LIMIT, the upper bound on the number of subintervals that</span>
- <a name="l02377"></a>02377 <span class="comment">! will be used in the partition of [A,B]. LIMIT is typically 500.</span>
- <a name="l02378"></a>02378 <span class="comment">!</span>
- <a name="l02379"></a>02379 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l02380"></a>02380 <span class="comment">!</span>
- <a name="l02381"></a>02381 <span class="comment">! Output, real ABSERR, an estimate of || I - RESULT ||.</span>
- <a name="l02382"></a>02382 <span class="comment">!</span>
- <a name="l02383"></a>02383 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l02384"></a>02384 <span class="comment">!</span>
- <a name="l02385"></a>02385 <span class="comment">! ier - integer</span>
- <a name="l02386"></a>02386 <span class="comment">! ier = 0 normal and reliable termination of the</span>
- <a name="l02387"></a>02387 <span class="comment">! routine. it is assumed that the requested</span>
- <a name="l02388"></a>02388 <span class="comment">! accuracy has been achieved.</span>
- <a name="l02389"></a>02389 <span class="comment">! ier > 0 abnormal termination of the routine</span>
- <a name="l02390"></a>02390 <span class="comment">! the estimates for integral and error are</span>
- <a name="l02391"></a>02391 <span class="comment">! less reliable. it is assumed that the</span>
- <a name="l02392"></a>02392 <span class="comment">! requested accuracy has not been achieved.</span>
- <a name="l02393"></a>02393 <span class="comment">! ier = 1 maximum number of subdivisions allowed</span>
- <a name="l02394"></a>02394 <span class="comment">! has been achieved. one can allow more sub-</span>
- <a name="l02395"></a>02395 <span class="comment">! divisions by increasing the value of</span>
- <a name="l02396"></a>02396 <span class="comment">! limit. however, if this yields no</span>
- <a name="l02397"></a>02397 <span class="comment">! improvement it is advised to analyze the</span>
- <a name="l02398"></a>02398 <span class="comment">! integrand, in order to determine the</span>
- <a name="l02399"></a>02399 <span class="comment">! integration difficulties. if the position</span>
- <a name="l02400"></a>02400 <span class="comment">! of a local difficulty can be determined</span>
- <a name="l02401"></a>02401 <span class="comment">! (e.g. singularity, discontinuity within</span>
- <a name="l02402"></a>02402 <span class="comment">! the interval) one will probably gain</span>
- <a name="l02403"></a>02403 <span class="comment">! from splitting up the interval at this</span>
- <a name="l02404"></a>02404 <span class="comment">! point and calling appropriate integrators</span>
- <a name="l02405"></a>02405 <span class="comment">! on the subranges.</span>
- <a name="l02406"></a>02406 <span class="comment">! = 2 the occurrence of roundoff error is detec-</span>
- <a name="l02407"></a>02407 <span class="comment">! ted, which prevents the requested</span>
- <a name="l02408"></a>02408 <span class="comment">! tolerance from being achieved.</span>
- <a name="l02409"></a>02409 <span class="comment">! = 3 extremely bad integrand behavior occurs</span>
- <a name="l02410"></a>02410 <span class="comment">! at some interior points of the integration</span>
- <a name="l02411"></a>02411 <span class="comment">! interval.</span>
- <a name="l02412"></a>02412 <span class="comment">! = 6 the input is invalid, because</span>
- <a name="l02413"></a>02413 <span class="comment">! c = a or c = b or</span>
- <a name="l02414"></a>02414 <span class="comment">! epsabs < 0 and epsrel < 0,</span>
- <a name="l02415"></a>02415 <span class="comment">! or limit < 1.</span>
- <a name="l02416"></a>02416 <span class="comment">! result, abserr, neval, rlist(1), elist(1),</span>
- <a name="l02417"></a>02417 <span class="comment">! iord(1) and last are set to zero.</span>
- <a name="l02418"></a>02418 <span class="comment">! alist(1) and blist(1) are set to a and b</span>
- <a name="l02419"></a>02419 <span class="comment">! respectively.</span>
- <a name="l02420"></a>02420 <span class="comment">!</span>
- <a name="l02421"></a>02421 <span class="comment">! Workspace, real ALIST(LIMIT), BLIST(LIMIT), contains in entries 1 </span>
- <a name="l02422"></a>02422 <span class="comment">! through LAST the left and right ends of the partition subintervals.</span>
- <a name="l02423"></a>02423 <span class="comment">!</span>
- <a name="l02424"></a>02424 <span class="comment">! Workspace, real RLIST(LIMIT), contains in entries 1 through LAST</span>
- <a name="l02425"></a>02425 <span class="comment">! the integral approximations on the subintervals.</span>
- <a name="l02426"></a>02426 <span class="comment">!</span>
- <a name="l02427"></a>02427 <span class="comment">! Workspace, real ELIST(LIMIT), contains in entries 1 through LAST</span>
- <a name="l02428"></a>02428 <span class="comment">! the absolute error estimates on the subintervals.</span>
- <a name="l02429"></a>02429 <span class="comment">!</span>
- <a name="l02430"></a>02430 <span class="comment">! iord - integer</span>
- <a name="l02431"></a>02431 <span class="comment">! vector of dimension at least limit, the first k</span>
- <a name="l02432"></a>02432 <span class="comment">! elements of which are pointers to the error</span>
- <a name="l02433"></a>02433 <span class="comment">! estimates over the subintervals, so that</span>
- <a name="l02434"></a>02434 <span class="comment">! elist(iord(1)), ..., elist(iord(k)) with</span>
- <a name="l02435"></a>02435 <span class="comment">! k = last if last <= (limit/2+2), and</span>
- <a name="l02436"></a>02436 <span class="comment">! k = limit+1-last otherwise, form a decreasing</span>
- <a name="l02437"></a>02437 <span class="comment">! sequence.</span>
- <a name="l02438"></a>02438 <span class="comment">!</span>
- <a name="l02439"></a>02439 <span class="comment">! last - integer</span>
- <a name="l02440"></a>02440 <span class="comment">! number of subintervals actually produced in</span>
- <a name="l02441"></a>02441 <span class="comment">! the subdivision process</span>
- <a name="l02442"></a>02442 <span class="comment">!</span>
- <a name="l02443"></a>02443 <span class="comment">! Local parameters:</span>
- <a name="l02444"></a>02444 <span class="comment">!</span>
- <a name="l02445"></a>02445 <span class="comment">! alist - list of left end points of all subintervals</span>
- <a name="l02446"></a>02446 <span class="comment">! considered up to now</span>
- <a name="l02447"></a>02447 <span class="comment">! blist - list of right end points of all subintervals</span>
- <a name="l02448"></a>02448 <span class="comment">! considered up to now</span>
- <a name="l02449"></a>02449 <span class="comment">! rlist(i) - approximation to the integral over</span>
- <a name="l02450"></a>02450 <span class="comment">! (alist(i),blist(i))</span>
- <a name="l02451"></a>02451 <span class="comment">! elist(i) - error estimate applying to rlist(i)</span>
- <a name="l02452"></a>02452 <span class="comment">! maxerr - pointer to the interval with largest error</span>
- <a name="l02453"></a>02453 <span class="comment">! estimate</span>
- <a name="l02454"></a>02454 <span class="comment">! errmax - elist(maxerr)</span>
- <a name="l02455"></a>02455 <span class="comment">! area - sum of the integrals over the subintervals</span>
- <a name="l02456"></a>02456 <span class="comment">! errsum - sum of the errors over the subintervals</span>
- <a name="l02457"></a>02457 <span class="comment">! errbnd - requested accuracy max(epsabs,epsrel*</span>
- <a name="l02458"></a>02458 <span class="comment">! abs(result))</span>
- <a name="l02459"></a>02459 <span class="comment">! *****1 - variable for the left subinterval</span>
- <a name="l02460"></a>02460 <span class="comment">! *****2 - variable for the right subinterval</span>
- <a name="l02461"></a>02461 <span class="comment">! last - index for subdivision</span>
- <a name="l02462"></a>02462 <span class="comment">!</span>
- <a name="l02463"></a>02463 <span class="keyword">implicit none</span>
- <a name="l02464"></a>02464
- <a name="l02465"></a>02465 <span class="keywordtype">integer</span> limit
- <a name="l02466"></a>02466
- <a name="l02467"></a>02467 <span class="keywordtype">real</span> a
- <a name="l02468"></a>02468 <span class="keywordtype">real</span> aa
- <a name="l02469"></a>02469 <span class="keywordtype">real</span> abserr
- <a name="l02470"></a>02470 <span class="keywordtype">real</span> alist(limit)
- <a name="l02471"></a>02471 <span class="keywordtype">real</span> area
- <a name="l02472"></a>02472 <span class="keywordtype">real</span> area1
- <a name="l02473"></a>02473 <span class="keywordtype">real</span> area12
- <a name="l02474"></a>02474 <span class="keywordtype">real</span> area2
- <a name="l02475"></a>02475 <span class="keywordtype">real</span> a1
- <a name="l02476"></a>02476 <span class="keywordtype">real</span> a2
- <a name="l02477"></a>02477 <span class="keywordtype">real</span> b
- <a name="l02478"></a>02478 <span class="keywordtype">real</span> bb
- <a name="l02479"></a>02479 <span class="keywordtype">real</span> blist(limit)
- <a name="l02480"></a>02480 <span class="keywordtype">real</span> b1
- <a name="l02481"></a>02481 <span class="keywordtype">real</span> b2
- <a name="l02482"></a>02482 <span class="keywordtype">real</span> c
- <a name="l02483"></a>02483 <span class="keywordtype">real</span> elist(limit)
- <a name="l02484"></a>02484 <span class="keywordtype">real</span> epsabs
- <a name="l02485"></a>02485 <span class="keywordtype">real</span> epsrel
- <a name="l02486"></a>02486 <span class="keywordtype">real</span> errbnd
- <a name="l02487"></a>02487 <span class="keywordtype">real</span> errmax
- <a name="l02488"></a>02488 <span class="keywordtype">real</span> error1
- <a name="l02489"></a>02489 <span class="keywordtype">real</span> error2
- <a name="l02490"></a>02490 <span class="keywordtype">real</span> erro12
- <a name="l02491"></a>02491 <span class="keywordtype">real</span> errsum
- <a name="l02492"></a>02492 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l02493"></a>02493 <span class="keywordtype">integer</span> ier
- <a name="l02494"></a>02494 <span class="keywordtype">integer</span> iord(limit)
- <a name="l02495"></a>02495 <span class="keywordtype">integer</span> iroff1
- <a name="l02496"></a>02496 <span class="keywordtype">integer</span> iroff2
- <a name="l02497"></a>02497 <span class="keywordtype">integer</span> krule
- <a name="l02498"></a>02498 <span class="keywordtype">integer</span> last
- <a name="l02499"></a>02499 <span class="keywordtype">integer</span> maxerr
- <a name="l02500"></a>02500 <span class="keywordtype">integer</span> nev
- <a name="l02501"></a>02501 <span class="keywordtype">integer</span> neval
- <a name="l02502"></a>02502 <span class="keywordtype">integer</span> nrmax
- <a name="l02503"></a>02503 <span class="keywordtype">real</span> result
- <a name="l02504"></a>02504 <span class="keywordtype">real</span> rlist(limit)
- <a name="l02505"></a>02505 <span class="comment">!</span>
- <a name="l02506"></a>02506 <span class="comment">! Test on validity of parameters.</span>
- <a name="l02507"></a>02507 <span class="comment">!</span>
- <a name="l02508"></a>02508 ier = 0
- <a name="l02509"></a>02509 neval = 0
- <a name="l02510"></a>02510 last = 0
- <a name="l02511"></a>02511 alist(1) = a
- <a name="l02512"></a>02512 blist(1) = b
- <a name="l02513"></a>02513 rlist(1) = 0.0e+00
- <a name="l02514"></a>02514 elist(1) = 0.0e+00
- <a name="l02515"></a>02515 iord(1) = 0
- <a name="l02516"></a>02516 result = 0.0e+00
- <a name="l02517"></a>02517 abserr = 0.0e+00
- <a name="l02518"></a>02518
- <a name="l02519"></a>02519 <span class="keyword">if</span> ( c == a ) <span class="keyword">then</span>
- <a name="l02520"></a>02520 ier = 6
- <a name="l02521"></a>02521 return
- <a name="l02522"></a>02522 <span class="keyword">else</span> <span class="keyword">if</span> ( c == b ) <span class="keyword">then</span>
- <a name="l02523"></a>02523 ier = 6
- <a name="l02524"></a>02524 return
- <a name="l02525"></a>02525 <span class="keyword">else</span> <span class="keyword">if</span> ( epsabs < 0.0e+00 .and. epsrel < 0.0e+00 ) <span class="keyword">then</span>
- <a name="l02526"></a>02526 ier = 6
- <a name="l02527"></a>02527 return
- <a name="l02528"></a>02528 <span class="keyword">end if</span>
- <a name="l02529"></a>02529 <span class="comment">!</span>
- <a name="l02530"></a>02530 <span class="comment">! First approximation to the integral.</span>
- <a name="l02531"></a>02531 <span class="comment">!</span>
- <a name="l02532"></a>02532 <span class="keyword">if</span> ( a <= b ) <span class="keyword">then</span>
- <a name="l02533"></a>02533 aa = a
- <a name="l02534"></a>02534 bb = b
- <a name="l02535"></a>02535 <span class="keyword">else</span>
- <a name="l02536"></a>02536 aa = b
- <a name="l02537"></a>02537 bb = a
- <a name="l02538"></a>02538 <span class="keyword">end if</span>
- <a name="l02539"></a>02539
- <a name="l02540"></a>02540 krule = 1
- <a name="l02541"></a>02541 call <a class="code" href="quadpack_8f90.html#af8148c1623b7cf59159c491cfb1856f4">qc25c </a>( f, aa, bb, c, result, abserr, krule, neval )
- <a name="l02542"></a>02542 last = 1
- <a name="l02543"></a>02543 rlist(1) = result
- <a name="l02544"></a>02544 elist(1) = abserr
- <a name="l02545"></a>02545 iord(1) = 1
- <a name="l02546"></a>02546 alist(1) = a
- <a name="l02547"></a>02547 blist(1) = b
- <a name="l02548"></a>02548 <span class="comment">!</span>
- <a name="l02549"></a>02549 <span class="comment">! Test on accuracy.</span>
- <a name="l02550"></a>02550 <span class="comment">!</span>
- <a name="l02551"></a>02551 errbnd = max ( epsabs, epsrel * abs(result) )
- <a name="l02552"></a>02552
- <a name="l02553"></a>02553 <span class="keyword">if</span> ( limit == 1 ) <span class="keyword">then</span>
- <a name="l02554"></a>02554 ier = 1
- <a name="l02555"></a>02555 go to 70
- <a name="l02556"></a>02556 <span class="keyword">end if</span>
- <a name="l02557"></a>02557
- <a name="l02558"></a>02558 <span class="keyword">if</span> ( abserr < min ( 1.0e-02 * abs(result), errbnd) ) <span class="keyword">then</span>
- <a name="l02559"></a>02559 go to 70
- <a name="l02560"></a>02560 <span class="keyword">end if</span>
- <a name="l02561"></a>02561 <span class="comment">!</span>
- <a name="l02562"></a>02562 <span class="comment">! Initialization</span>
- <a name="l02563"></a>02563 <span class="comment">!</span>
- <a name="l02564"></a>02564 alist(1) = aa
- <a name="l02565"></a>02565 blist(1) = bb
- <a name="l02566"></a>02566 rlist(1) = result
- <a name="l02567"></a>02567 errmax = abserr
- <a name="l02568"></a>02568 maxerr = 1
- <a name="l02569"></a>02569 area = result
- <a name="l02570"></a>02570 errsum = abserr
- <a name="l02571"></a>02571 nrmax = 1
- <a name="l02572"></a>02572 iroff1 = 0
- <a name="l02573"></a>02573 iroff2 = 0
- <a name="l02574"></a>02574
- <a name="l02575"></a>02575 <span class="keyword">do</span> last = 2, limit
- <a name="l02576"></a>02576 <span class="comment">!</span>
- <a name="l02577"></a>02577 <span class="comment">! Bisect the subinterval with nrmax-th largest error estimate.</span>
- <a name="l02578"></a>02578 <span class="comment">!</span>
- <a name="l02579"></a>02579 a1 = alist(maxerr)
- <a name="l02580"></a>02580 b1 = 5.0e-01*(alist(maxerr)+blist(maxerr))
- <a name="l02581"></a>02581 b2 = blist(maxerr)
- <a name="l02582"></a>02582
- <a name="l02583"></a>02583 <span class="keyword">if</span> ( c <= b1 .and. a1 < c ) <span class="keyword">then</span>
- <a name="l02584"></a>02584 b1 = 5.0e-01*(c+b2)
- <a name="l02585"></a>02585 <span class="keyword">end if</span>
- <a name="l02586"></a>02586
- <a name="l02587"></a>02587 <span class="keyword">if</span> ( b1 < c .and. c < b2 ) <span class="keyword">then</span>
- <a name="l02588"></a>02588 b1 = 5.0e-01 * ( a1 + c )
- <a name="l02589"></a>02589 <span class="keyword">end if</span>
- <a name="l02590"></a>02590
- <a name="l02591"></a>02591 a2 = b1
- <a name="l02592"></a>02592 krule = 2
- <a name="l02593"></a>02593
- <a name="l02594"></a>02594 call <a class="code" href="quadpack_8f90.html#af8148c1623b7cf59159c491cfb1856f4">qc25c </a>( f, a1, b1, c, area1, error1, krule, nev )
- <a name="l02595"></a>02595 neval = neval+nev
- <a name="l02596"></a>02596
- <a name="l02597"></a>02597 call <a class="code" href="quadpack_8f90.html#af8148c1623b7cf59159c491cfb1856f4">qc25c </a>( f, a2, b2, c, area2, error2, krule, nev )
- <a name="l02598"></a>02598 neval = neval+nev
- <a name="l02599"></a>02599 <span class="comment">!</span>
- <a name="l02600"></a>02600 <span class="comment">! Improve previous approximations to integral and error</span>
- <a name="l02601"></a>02601 <span class="comment">! and test for accuracy.</span>
- <a name="l02602"></a>02602 <span class="comment">!</span>
- <a name="l02603"></a>02603 area12 = area1 + area2
- <a name="l02604"></a>02604 erro12 = error1 + error2
- <a name="l02605"></a>02605 errsum = errsum + erro12 - errmax
- <a name="l02606"></a>02606 area = area + area12 - rlist(maxerr)
- <a name="l02607"></a>02607
- <a name="l02608"></a>02608 <span class="keyword">if</span> ( abs ( rlist(maxerr)-area12) < 1.0e-05 * abs(area12) &
- <a name="l02609"></a>02609 .and. erro12 >= 9.9e-01 * errmax .and. krule == 0 ) &
- <a name="l02610"></a>02610 iroff1 = iroff1+1
- <a name="l02611"></a>02611
- <a name="l02612"></a>02612 <span class="keyword">if</span> ( last > 10.and.erro12 > errmax .and. krule == 0 ) <span class="keyword">then</span>
- <a name="l02613"></a>02613 iroff2 = iroff2+1
- <a name="l02614"></a>02614 <span class="keyword">end if</span>
- <a name="l02615"></a>02615
- <a name="l02616"></a>02616 rlist(maxerr) = area1
- <a name="l02617"></a>02617 rlist(last) = area2
- <a name="l02618"></a>02618 errbnd = max ( epsabs, epsrel * abs(area) )
- <a name="l02619"></a>02619
- <a name="l02620"></a>02620 <span class="keyword">if</span> ( errsum > errbnd ) <span class="keyword">then</span>
- <a name="l02621"></a>02621 <span class="comment">!</span>
- <a name="l02622"></a>02622 <span class="comment">! Test for roundoff error and eventually set error flag.</span>
- <a name="l02623"></a>02623 <span class="comment">!</span>
- <a name="l02624"></a>02624 <span class="keyword">if</span> ( iroff1 >= 6 .and. iroff2 > 20 ) <span class="keyword">then</span>
- <a name="l02625"></a>02625 ier = 2
- <a name="l02626"></a>02626 <span class="keyword">end if</span>
- <a name="l02627"></a>02627 <span class="comment">!</span>
- <a name="l02628"></a>02628 <span class="comment">! Set error flag in the case that number of interval</span>
- <a name="l02629"></a>02629 <span class="comment">! bisections exceeds limit.</span>
- <a name="l02630"></a>02630 <span class="comment">!</span>
- <a name="l02631"></a>02631 <span class="keyword">if</span> ( last == limit ) <span class="keyword">then</span>
- <a name="l02632"></a>02632 ier = 1
- <a name="l02633"></a>02633 <span class="keyword">end if</span>
- <a name="l02634"></a>02634 <span class="comment">!</span>
- <a name="l02635"></a>02635 <span class="comment">! Set error flag in the case of bad integrand behavior at</span>
- <a name="l02636"></a>02636 <span class="comment">! a point of the integration range.</span>
- <a name="l02637"></a>02637 <span class="comment">!</span>
- <a name="l02638"></a>02638 <span class="keyword">if</span> ( max ( abs(a1), abs(b2) ) <= ( 1.0e+00 + 1.0e+03 * epsilon ( a1 ) ) &
- <a name="l02639"></a>02639 *( abs(a2)+1.0e+03* tiny ( a2 ) )) <span class="keyword">then</span>
- <a name="l02640"></a>02640 ier = 3
- <a name="l02641"></a>02641 <span class="keyword">end if</span>
- <a name="l02642"></a>02642
- <a name="l02643"></a>02643 <span class="keyword">end if</span>
- <a name="l02644"></a>02644 <span class="comment">!</span>
- <a name="l02645"></a>02645 <span class="comment">! Append the newly-created intervals to the list.</span>
- <a name="l02646"></a>02646 <span class="comment">!</span>
- <a name="l02647"></a>02647 <span class="keyword">if</span> ( error2 <= error1 ) <span class="keyword">then</span>
- <a name="l02648"></a>02648 alist(last) = a2
- <a name="l02649"></a>02649 blist(maxerr) = b1
- <a name="l02650"></a>02650 blist(last) = b2
- <a name="l02651"></a>02651 elist(maxerr) = error1
- <a name="l02652"></a>02652 elist(last) = error2
- <a name="l02653"></a>02653 <span class="keyword">else</span>
- <a name="l02654"></a>02654 alist(maxerr) = a2
- <a name="l02655"></a>02655 alist(last) = a1
- <a name="l02656"></a>02656 blist(last) = b1
- <a name="l02657"></a>02657 rlist(maxerr) = area2
- <a name="l02658"></a>02658 rlist(last) = area1
- <a name="l02659"></a>02659 elist(maxerr) = error2
- <a name="l02660"></a>02660 elist(last) = error1
- <a name="l02661"></a>02661 <span class="keyword">end if</span>
- <a name="l02662"></a>02662 <span class="comment">!</span>
- <a name="l02663"></a>02663 <span class="comment">! Call QSORT to maintain the descending ordering</span>
- <a name="l02664"></a>02664 <span class="comment">! in the list of error estimates and select the subinterval</span>
- <a name="l02665"></a>02665 <span class="comment">! with NRMAX-th largest error estimate (to be bisected next).</span>
- <a name="l02666"></a>02666 <span class="comment">!</span>
- <a name="l02667"></a>02667 call <a class="code" href="quadpack_8f90.html#a55e08a684c5a6315fb37dd0fdc66d8e6">qsort </a>( limit, last, maxerr, errmax, elist, iord, nrmax )
- <a name="l02668"></a>02668
- <a name="l02669"></a>02669 <span class="keyword">if</span> ( ier /= 0 .or. errsum <= errbnd ) <span class="keyword">then</span>
- <a name="l02670"></a>02670 exit
- <a name="l02671"></a>02671 <span class="keyword">end if</span>
- <a name="l02672"></a>02672
- <a name="l02673"></a>02673 <span class="keyword">end do</span>
- <a name="l02674"></a>02674 <span class="comment">!</span>
- <a name="l02675"></a>02675 <span class="comment">! Compute final result.</span>
- <a name="l02676"></a>02676 <span class="comment">!</span>
- <a name="l02677"></a>02677 result = sum ( rlist(1:last) )
- <a name="l02678"></a>02678
- <a name="l02679"></a>02679 abserr = errsum
- <a name="l02680"></a>02680
- <a name="l02681"></a>02681 70 continue
- <a name="l02682"></a>02682
- <a name="l02683"></a>02683 <span class="keyword">if</span> ( aa == b ) <span class="keyword">then</span>
- <a name="l02684"></a>02684 result = - result
- <a name="l02685"></a>02685 <span class="keyword">end if</span>
- <a name="l02686"></a>02686
- <a name="l02687"></a>02687 return
- <a name="l02688"></a>02688 <span class="keyword">end</span>
- <a name="l02689"></a><a class="code" href="quadpack_8f90.html#aefd54eff8d0418a0f533f571d80ec5e5">02689</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#aefd54eff8d0418a0f533f571d80ec5e5">qawf</a> ( f, a, omega, integr, epsabs, result, abserr, neval, ier )
- <a name="l02690"></a>02690
- <a name="l02691"></a>02691 <span class="comment">!*****************************************************************************80</span>
- <a name="l02692"></a>02692 <span class="comment">!</span>
- <a name="l02693"></a>02693 <span class="comment">!! QAWF computes Fourier integrals over the interval [ A, +Infinity ).</span>
- <a name="l02694"></a>02694 <span class="comment">!</span>
- <a name="l02695"></a>02695 <span class="comment">! Discussion:</span>
- <a name="l02696"></a>02696 <span class="comment">!</span>
- <a name="l02697"></a>02697 <span class="comment">! The routine calculates an approximation RESULT to a definite integral </span>
- <a name="l02698"></a>02698 <span class="comment">! </span>
- <a name="l02699"></a>02699 <span class="comment">! I = integral of F*COS(OMEGA*X) </span>
- <a name="l02700"></a>02700 <span class="comment">! or </span>
- <a name="l02701"></a>02701 <span class="comment">! I = integral of F*SIN(OMEGA*X) </span>
- <a name="l02702"></a>02702 <span class="comment">!</span>
- <a name="l02703"></a>02703 <span class="comment">! over the interval [A,+Infinity), hopefully satisfying</span>
- <a name="l02704"></a>02704 <span class="comment">!</span>
- <a name="l02705"></a>02705 <span class="comment">! || I - RESULT || <= EPSABS.</span>
- <a name="l02706"></a>02706 <span class="comment">!</span>
- <a name="l02707"></a>02707 <span class="comment">! If OMEGA = 0 and INTEGR = 1, the integral is calculated by means </span>
- <a name="l02708"></a>02708 <span class="comment">! of QAGI, and IER has the meaning as described in the comments of QAGI.</span>
- <a name="l02709"></a>02709 <span class="comment">!</span>
- <a name="l02710"></a>02710 <span class="comment">! Author:</span>
- <a name="l02711"></a>02711 <span class="comment">!</span>
- <a name="l02712"></a>02712 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l02713"></a>02713 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l02714"></a>02714 <span class="comment">!</span>
- <a name="l02715"></a>02715 <span class="comment">! Reference:</span>
- <a name="l02716"></a>02716 <span class="comment">!</span>
- <a name="l02717"></a>02717 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l02718"></a>02718 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l02719"></a>02719 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l02720"></a>02720 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l02721"></a>02721 <span class="comment">!</span>
- <a name="l02722"></a>02722 <span class="comment">! Parameters:</span>
- <a name="l02723"></a>02723 <span class="comment">!</span>
- <a name="l02724"></a>02724 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l02725"></a>02725 <span class="comment">! function f ( x )</span>
- <a name="l02726"></a>02726 <span class="comment">! real f</span>
- <a name="l02727"></a>02727 <span class="comment">! real x</span>
- <a name="l02728"></a>02728 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l02729"></a>02729 <span class="comment">!</span>
- <a name="l02730"></a>02730 <span class="comment">! Input, real A, the lower limit of integration.</span>
- <a name="l02731"></a>02731 <span class="comment">!</span>
- <a name="l02732"></a>02732 <span class="comment">! Input, real OMEGA, the parameter in the weight function.</span>
- <a name="l02733"></a>02733 <span class="comment">!</span>
- <a name="l02734"></a>02734 <span class="comment">! Input, integer INTEGR, indicates which weight functions is used</span>
- <a name="l02735"></a>02735 <span class="comment">! = 1, w(x) = cos(omega*x)</span>
- <a name="l02736"></a>02736 <span class="comment">! = 2, w(x) = sin(omega*x)</span>
- <a name="l02737"></a>02737 <span class="comment">!</span>
- <a name="l02738"></a>02738 <span class="comment">! Input, real EPSABS, the absolute accuracy requested.</span>
- <a name="l02739"></a>02739 <span class="comment">!</span>
- <a name="l02740"></a>02740 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l02741"></a>02741 <span class="comment">!</span>
- <a name="l02742"></a>02742 <span class="comment">! Output, real ABSERR, an estimate of || I - RESULT ||.</span>
- <a name="l02743"></a>02743 <span class="comment">!</span>
- <a name="l02744"></a>02744 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l02745"></a>02745 <span class="comment">!</span>
- <a name="l02746"></a>02746 <span class="comment">! ier - integer</span>
- <a name="l02747"></a>02747 <span class="comment">! ier = 0 normal and reliable termination of the</span>
- <a name="l02748"></a>02748 <span class="comment">! routine. it is assumed that the</span>
- <a name="l02749"></a>02749 <span class="comment">! requested accuracy has been achieved.</span>
- <a name="l02750"></a>02750 <span class="comment">! ier > 0 abnormal termination of the routine.</span>
- <a name="l02751"></a>02751 <span class="comment">! the estimates for integral and error are</span>
- <a name="l02752"></a>02752 <span class="comment">! less reliable. it is assumed that the</span>
- <a name="l02753"></a>02753 <span class="comment">! requested accuracy has not been achieved.</span>
- <a name="l02754"></a>02754 <span class="comment">! if omega /= 0</span>
- <a name="l02755"></a>02755 <span class="comment">! ier = 6 the input is invalid because</span>
- <a name="l02756"></a>02756 <span class="comment">! (integr /= 1 and integr /= 2) or</span>
- <a name="l02757"></a>02757 <span class="comment">! epsabs <= 0</span>
- <a name="l02758"></a>02758 <span class="comment">! result, abserr, neval, lst are set to</span>
- <a name="l02759"></a>02759 <span class="comment">! zero.</span>
- <a name="l02760"></a>02760 <span class="comment">! = 7 abnormal termination of the computation</span>
- <a name="l02761"></a>02761 <span class="comment">! of one or more subintegrals</span>
- <a name="l02762"></a>02762 <span class="comment">! = 8 maximum number of cycles allowed</span>
- <a name="l02763"></a>02763 <span class="comment">! has been achieved, i.e. of subintervals</span>
- <a name="l02764"></a>02764 <span class="comment">! (a+(k-1)c,a+kc) where</span>
- <a name="l02765"></a>02765 <span class="comment">! c = (2*int(abs(omega))+1)*pi/abs(omega),</span>
- <a name="l02766"></a>02766 <span class="comment">! for k = 1, 2, ...</span>
- <a name="l02767"></a>02767 <span class="comment">! = 9 the extrapolation table constructed for</span>
- <a name="l02768"></a>02768 <span class="comment">! convergence acceleration of the series</span>
- <a name="l02769"></a>02769 <span class="comment">! formed by the integral contributions</span>
- <a name="l02770"></a>02770 <span class="comment">! over the cycles, does not converge to</span>
- <a name="l02771"></a>02771 <span class="comment">! within the requested accuracy.</span>
- <a name="l02772"></a>02772 <span class="comment">!</span>
- <a name="l02773"></a>02773 <span class="comment">! Local parameters:</span>
- <a name="l02774"></a>02774 <span class="comment">!</span>
- <a name="l02775"></a>02775 <span class="comment">! Integer LIMLST, gives an upper bound on the number of cycles, LIMLST >= 3.</span>
- <a name="l02776"></a>02776 <span class="comment">! if limlst < 3, the routine will end with ier = 6.</span>
- <a name="l02777"></a>02777 <span class="comment">!</span>
- <a name="l02778"></a>02778 <span class="comment">! Integer MAXP1, an upper bound on the number of Chebyshev moments which </span>
- <a name="l02779"></a>02779 <span class="comment">! can be stored, i.e. for the intervals of lengths abs(b-a)*2**(-l), </span>
- <a name="l02780"></a>02780 <span class="comment">! l = 0,1, ..., maxp1-2, maxp1 >= 1. if maxp1 < 1, the routine will end</span>
- <a name="l02781"></a>02781 <span class="comment">! with ier = 6.</span>
- <a name="l02782"></a>02782 <span class="comment">!</span>
- <a name="l02783"></a>02783 <span class="keyword">implicit none</span>
- <a name="l02784"></a>02784
- <a name="l02785"></a>02785 <span class="keywordtype">integer</span>, <span class="keywordtype">parameter</span> :: limit = 500
- <a name="l02786"></a>02786 <span class="keywordtype">integer</span>, <span class="keywordtype">parameter</span> :: limlst = 50
- <a name="l02787"></a>02787 <span class="keywordtype">integer</span>, <span class="keywordtype">parameter</span> :: maxp1 = 21
- <a name="l02788"></a>02788
- <a name="l02789"></a>02789 <span class="keywordtype">real</span> a
- <a name="l02790"></a>02790 <span class="keywordtype">real</span> abserr
- <a name="l02791"></a>02791 <span class="keywordtype">real</span> alist(limit)
- <a name="l02792"></a>02792 <span class="keywordtype">real</span> blist(limit)
- <a name="l02793"></a>02793 <span class="keywordtype">real</span> chebmo(maxp1,25)
- <a name="l02794"></a>02794 <span class="keywordtype">real</span> elist(limit)
- <a name="l02795"></a>02795 <span class="keywordtype">real</span> epsabs
- <a name="l02796"></a>02796 <span class="keywordtype">real</span> erlst(limlst)
- <a name="l02797"></a>02797 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l02798"></a>02798 <span class="keywordtype">integer</span> ier
- <a name="l02799"></a>02799 <span class="keywordtype">integer</span> integr
- <a name="l02800"></a>02800 <span class="keywordtype">integer</span> iord(limit)
- <a name="l02801"></a>02801 <span class="keywordtype">integer</span> ierlst(limlst)
- <a name="l02802"></a>02802 <span class="keywordtype">integer</span> lst
- <a name="l02803"></a>02803 <span class="keywordtype">integer</span> neval
- <a name="l02804"></a>02804 <span class="keywordtype">integer</span> nnlog(limit)
- <a name="l02805"></a>02805 <span class="keywordtype">real</span> omega
- <a name="l02806"></a>02806 <span class="keywordtype">real</span> result
- <a name="l02807"></a>02807 <span class="keywordtype">real</span> rlist(limit)
- <a name="l02808"></a>02808 <span class="keywordtype">real</span> rslst(limlst)
- <a name="l02809"></a>02809
- <a name="l02810"></a>02810 ier = 6
- <a name="l02811"></a>02811 neval = 0
- <a name="l02812"></a>02812 result = 0.0e+00
- <a name="l02813"></a>02813 abserr = 0.0e+00
- <a name="l02814"></a>02814
- <a name="l02815"></a>02815 <span class="keyword">if</span> ( limlst < 3 .or. maxp1 < 1 ) <span class="keyword">then</span>
- <a name="l02816"></a>02816 return
- <a name="l02817"></a>02817 <span class="keyword">end if</span>
- <a name="l02818"></a>02818
- <a name="l02819"></a>02819 call <a class="code" href="quadpack_8f90.html#abe17af7f3ad5cf264791d326bbd15192">qawfe </a>( f, a, omega, integr, epsabs, limlst, limit, maxp1, &
- <a name="l02820"></a>02820 result, abserr, neval, ier, rslst, erlst, ierlst, lst, alist, blist, &
- <a name="l02821"></a>02821 rlist, elist, iord, nnlog, chebmo )
- <a name="l02822"></a>02822
- <a name="l02823"></a>02823 return
- <a name="l02824"></a>02824 <span class="keyword">end</span>
- <a name="l02825"></a><a class="code" href="quadpack_8f90.html#abe17af7f3ad5cf264791d326bbd15192">02825</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#abe17af7f3ad5cf264791d326bbd15192">qawfe</a> ( f, a, omega, integr, epsabs, limlst, limit, maxp1, &
- <a name="l02826"></a>02826 result, abserr, neval, ier, rslst, erlst, ierlst, lst, alist, blist, &
- <a name="l02827"></a>02827 rlist, elist, iord, nnlog, chebmo )
- <a name="l02828"></a>02828
- <a name="l02829"></a>02829 <span class="comment">!*****************************************************************************80</span>
- <a name="l02830"></a>02830 <span class="comment">!</span>
- <a name="l02831"></a>02831 <span class="comment">!! QAWFE computes Fourier integrals.</span>
- <a name="l02832"></a>02832 <span class="comment">!</span>
- <a name="l02833"></a>02833 <span class="comment">! Discussion:</span>
- <a name="l02834"></a>02834 <span class="comment">!</span>
- <a name="l02835"></a>02835 <span class="comment">! The routine calculates an approximation RESULT to a definite integral </span>
- <a name="l02836"></a>02836 <span class="comment">! I = integral of F*COS(OMEGA*X) or F*SIN(OMEGA*X) over (A,+Infinity),</span>
- <a name="l02837"></a>02837 <span class="comment">! hopefully satisfying</span>
- <a name="l02838"></a>02838 <span class="comment">! || I - RESULT || <= EPSABS.</span>
- <a name="l02839"></a>02839 <span class="comment">!</span>
- <a name="l02840"></a>02840 <span class="comment">! Author:</span>
- <a name="l02841"></a>02841 <span class="comment">!</span>
- <a name="l02842"></a>02842 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l02843"></a>02843 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l02844"></a>02844 <span class="comment">!</span>
- <a name="l02845"></a>02845 <span class="comment">! Reference:</span>
- <a name="l02846"></a>02846 <span class="comment">!</span>
- <a name="l02847"></a>02847 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l02848"></a>02848 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l02849"></a>02849 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l02850"></a>02850 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l02851"></a>02851 <span class="comment">!</span>
- <a name="l02852"></a>02852 <span class="comment">! Parameters:</span>
- <a name="l02853"></a>02853 <span class="comment">!</span>
- <a name="l02854"></a>02854 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l02855"></a>02855 <span class="comment">! function f ( x )</span>
- <a name="l02856"></a>02856 <span class="comment">! real f</span>
- <a name="l02857"></a>02857 <span class="comment">! real x</span>
- <a name="l02858"></a>02858 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l02859"></a>02859 <span class="comment">!</span>
- <a name="l02860"></a>02860 <span class="comment">! Input, real A, the lower limit of integration.</span>
- <a name="l02861"></a>02861 <span class="comment">!</span>
- <a name="l02862"></a>02862 <span class="comment">! Input, real OMEGA, the parameter in the weight function.</span>
- <a name="l02863"></a>02863 <span class="comment">!</span>
- <a name="l02864"></a>02864 <span class="comment">! Input, integer INTEGR, indicates which weight function is used</span>
- <a name="l02865"></a>02865 <span class="comment">! = 1 w(x) = cos(omega*x)</span>
- <a name="l02866"></a>02866 <span class="comment">! = 2 w(x) = sin(omega*x)</span>
- <a name="l02867"></a>02867 <span class="comment">!</span>
- <a name="l02868"></a>02868 <span class="comment">! Input, real EPSABS, the absolute accuracy requested.</span>
- <a name="l02869"></a>02869 <span class="comment">!</span>
- <a name="l02870"></a>02870 <span class="comment">! Input, integer LIMLST, an upper bound on the number of cycles.</span>
- <a name="l02871"></a>02871 <span class="comment">! LIMLST must be at least 1. In fact, if LIMLST < 3, the routine </span>
- <a name="l02872"></a>02872 <span class="comment">! will end with IER= 6.</span>
- <a name="l02873"></a>02873 <span class="comment">!</span>
- <a name="l02874"></a>02874 <span class="comment">! Input, integer LIMIT, an upper bound on the number of subintervals </span>
- <a name="l02875"></a>02875 <span class="comment">! allowed in the partition of each cycle, limit >= 1.</span>
- <a name="l02876"></a>02876 <span class="comment">!</span>
- <a name="l02877"></a>02877 <span class="comment">! maxp1 - integer</span>
- <a name="l02878"></a>02878 <span class="comment">! gives an upper bound on the number of</span>
- <a name="l02879"></a>02879 <span class="comment">! Chebyshev moments which can be stored, i.e.</span>
- <a name="l02880"></a>02880 <span class="comment">! for the intervals of lengths abs(b-a)*2**(-l),</span>
- <a name="l02881"></a>02881 <span class="comment">! l=0,1, ..., maxp1-2, maxp1 >= 1</span>
- <a name="l02882"></a>02882 <span class="comment">!</span>
- <a name="l02883"></a>02883 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l02884"></a>02884 <span class="comment">!</span>
- <a name="l02885"></a>02885 <span class="comment">! Output, real ABSERR, an estimate of || I - RESULT ||.</span>
- <a name="l02886"></a>02886 <span class="comment">!</span>
- <a name="l02887"></a>02887 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l02888"></a>02888 <span class="comment">!</span>
- <a name="l02889"></a>02889 <span class="comment">! ier - ier = 0 normal and reliable termination of</span>
- <a name="l02890"></a>02890 <span class="comment">! the routine. it is assumed that the</span>
- <a name="l02891"></a>02891 <span class="comment">! requested accuracy has been achieved.</span>
- <a name="l02892"></a>02892 <span class="comment">! ier > 0 abnormal termination of the routine</span>
- <a name="l02893"></a>02893 <span class="comment">! the estimates for integral and error</span>
- <a name="l02894"></a>02894 <span class="comment">! are less reliable. it is assumed that</span>
- <a name="l02895"></a>02895 <span class="comment">! the requested accuracy has not been</span>
- <a name="l02896"></a>02896 <span class="comment">! achieved.</span>
- <a name="l02897"></a>02897 <span class="comment">! if omega /= 0</span>
- <a name="l02898"></a>02898 <span class="comment">! ier = 6 the input is invalid because</span>
- <a name="l02899"></a>02899 <span class="comment">! (integr /= 1 and integr /= 2) or</span>
- <a name="l02900"></a>02900 <span class="comment">! epsabs <= 0 or limlst < 3.</span>
- <a name="l02901"></a>02901 <span class="comment">! result, abserr, neval, lst are set</span>
- <a name="l02902"></a>02902 <span class="comment">! to zero.</span>
- <a name="l02903"></a>02903 <span class="comment">! = 7 bad integrand behavior occurs within</span>
- <a name="l02904"></a>02904 <span class="comment">! one or more of the cycles. location</span>
- <a name="l02905"></a>02905 <span class="comment">! and type of the difficulty involved</span>
- <a name="l02906"></a>02906 <span class="comment">! can be determined from the vector ierlst.</span>
- <a name="l02907"></a>02907 <span class="comment">! here lst is the number of cycles actually</span>
- <a name="l02908"></a>02908 <span class="comment">! needed (see below).</span>
- <a name="l02909"></a>02909 <span class="comment">! ierlst(k) = 1 the maximum number of</span>
- <a name="l02910"></a>02910 <span class="comment">! subdivisions (= limit)</span>
- <a name="l02911"></a>02911 <span class="comment">! has been achieved on the</span>
- <a name="l02912"></a>02912 <span class="comment">! k th cycle.</span>
- <a name="l02913"></a>02913 <span class="comment">! = 2 occurence of roundoff</span>
- <a name="l02914"></a>02914 <span class="comment">! error is detected and</span>
- <a name="l02915"></a>02915 <span class="comment">! prevents the tolerance</span>
- <a name="l02916"></a>02916 <span class="comment">! imposed on the k th cycle</span>
- <a name="l02917"></a>02917 <span class="comment">! from being acheived.</span>
- <a name="l02918"></a>02918 <span class="comment">! = 3 extremely bad integrand</span>
- <a name="l02919"></a>02919 <span class="comment">! behavior occurs at some</span>
- <a name="l02920"></a>02920 <span class="comment">! points of the k th cycle.</span>
- <a name="l02921"></a>02921 <span class="comment">! = 4 the integration procedure</span>
- <a name="l02922"></a>02922 <span class="comment">! over the k th cycle does</span>
- <a name="l02923"></a>02923 <span class="comment">! not converge (to within the</span>
- <a name="l02924"></a>02924 <span class="comment">! required accuracy) due to</span>
- <a name="l02925"></a>02925 <span class="comment">! roundoff in the</span>
- <a name="l02926"></a>02926 <span class="comment">! extrapolation procedure</span>
- <a name="l02927"></a>02927 <span class="comment">! invoked on this cycle. it</span>
- <a name="l02928"></a>02928 <span class="comment">! is assumed that the result</span>
- <a name="l02929"></a>02929 <span class="comment">! on this interval is the</span>
- <a name="l02930"></a>02930 <span class="comment">! best which can be obtained.</span>
- <a name="l02931"></a>02931 <span class="comment">! = 5 the integral over the k th</span>
- <a name="l02932"></a>02932 <span class="comment">! cycle is probably divergent</span>
- <a name="l02933"></a>02933 <span class="comment">! or slowly convergent. it</span>
- <a name="l02934"></a>02934 <span class="comment">! must be noted that</span>
- <a name="l02935"></a>02935 <span class="comment">! divergence can occur with</span>
- <a name="l02936"></a>02936 <span class="comment">! any other value of</span>
- <a name="l02937"></a>02937 <span class="comment">! ierlst(k).</span>
- <a name="l02938"></a>02938 <span class="comment">! = 8 maximum number of cycles allowed</span>
- <a name="l02939"></a>02939 <span class="comment">! has been achieved, i.e. of subintervals</span>
- <a name="l02940"></a>02940 <span class="comment">! (a+(k-1)c,a+kc) where</span>
- <a name="l02941"></a>02941 <span class="comment">! c = (2*int(abs(omega))+1)*pi/abs(omega),</span>
- <a name="l02942"></a>02942 <span class="comment">! for k = 1, 2, ..., lst.</span>
- <a name="l02943"></a>02943 <span class="comment">! one can allow more cycles by increasing</span>
- <a name="l02944"></a>02944 <span class="comment">! the value of limlst (and taking the</span>
- <a name="l02945"></a>02945 <span class="comment">! according dimension adjustments into</span>
- <a name="l02946"></a>02946 <span class="comment">! account).</span>
- <a name="l02947"></a>02947 <span class="comment">! examine the array iwork which contains</span>
- <a name="l02948"></a>02948 <span class="comment">! the error flags over the cycles, in order</span>
- <a name="l02949"></a>02949 <span class="comment">! to eventual look for local integration</span>
- <a name="l02950"></a>02950 <span class="comment">! difficulties.</span>
- <a name="l02951"></a>02951 <span class="comment">! if the position of a local difficulty can</span>
- <a name="l02952"></a>02952 <span class="comment">! be determined (e.g. singularity,</span>
- <a name="l02953"></a>02953 <span class="comment">! discontinuity within the interval)</span>
- <a name="l02954"></a>02954 <span class="comment">! one will probably gain from splitting</span>
- <a name="l02955"></a>02955 <span class="comment">! up the interval at this point and</span>
- <a name="l02956"></a>02956 <span class="comment">! calling appopriate integrators on the</span>
- <a name="l02957"></a>02957 <span class="comment">! subranges.</span>
- <a name="l02958"></a>02958 <span class="comment">! = 9 the extrapolation table constructed for</span>
- <a name="l02959"></a>02959 <span class="comment">! convergence acceleration of the series</span>
- <a name="l02960"></a>02960 <span class="comment">! formed by the integral contributions</span>
- <a name="l02961"></a>02961 <span class="comment">! over the cycles, does not converge to</span>
- <a name="l02962"></a>02962 <span class="comment">! within the required accuracy.</span>
- <a name="l02963"></a>02963 <span class="comment">! as in the case of ier = 8, it is advised</span>
- <a name="l02964"></a>02964 <span class="comment">! to examine the array iwork which contains</span>
- <a name="l02965"></a>02965 <span class="comment">! the error flags on the cycles.</span>
- <a name="l02966"></a>02966 <span class="comment">! if omega = 0 and integr = 1,</span>
- <a name="l02967"></a>02967 <span class="comment">! the integral is calculated by means of qagi</span>
- <a name="l02968"></a>02968 <span class="comment">! and ier = ierlst(1) (with meaning as described</span>
- <a name="l02969"></a>02969 <span class="comment">! for ierlst(k), k = 1).</span>
- <a name="l02970"></a>02970 <span class="comment">!</span>
- <a name="l02971"></a>02971 <span class="comment">! rslst - real</span>
- <a name="l02972"></a>02972 <span class="comment">! vector of dimension at least limlst</span>
- <a name="l02973"></a>02973 <span class="comment">! rslst(k) contains the integral contribution</span>
- <a name="l02974"></a>02974 <span class="comment">! over the interval (a+(k-1)c,a+kc) where</span>
- <a name="l02975"></a>02975 <span class="comment">! c = (2*int(abs(omega))+1)*pi/abs(omega),</span>
- <a name="l02976"></a>02976 <span class="comment">! k = 1, 2, ..., lst.</span>
- <a name="l02977"></a>02977 <span class="comment">! note that, if omega = 0, rslst(1) contains</span>
- <a name="l02978"></a>02978 <span class="comment">! the value of the integral over (a,infinity).</span>
- <a name="l02979"></a>02979 <span class="comment">!</span>
- <a name="l02980"></a>02980 <span class="comment">! erlst - real</span>
- <a name="l02981"></a>02981 <span class="comment">! vector of dimension at least limlst</span>
- <a name="l02982"></a>02982 <span class="comment">! erlst(k) contains the error estimate</span>
- <a name="l02983"></a>02983 <span class="comment">! corresponding with rslst(k).</span>
- <a name="l02984"></a>02984 <span class="comment">!</span>
- <a name="l02985"></a>02985 <span class="comment">! ierlst - integer</span>
- <a name="l02986"></a>02986 <span class="comment">! vector of dimension at least limlst</span>
- <a name="l02987"></a>02987 <span class="comment">! ierlst(k) contains the error flag corresponding</span>
- <a name="l02988"></a>02988 <span class="comment">! with rslst(k). for the meaning of the local error</span>
- <a name="l02989"></a>02989 <span class="comment">! flags see description of output parameter ier.</span>
- <a name="l02990"></a>02990 <span class="comment">!</span>
- <a name="l02991"></a>02991 <span class="comment">! lst - integer</span>
- <a name="l02992"></a>02992 <span class="comment">! number of subintervals needed for the integration</span>
- <a name="l02993"></a>02993 <span class="comment">! if omega = 0 then lst is set to 1.</span>
- <a name="l02994"></a>02994 <span class="comment">!</span>
- <a name="l02995"></a>02995 <span class="comment">! alist, blist, rlist, elist - real</span>
- <a name="l02996"></a>02996 <span class="comment">! vector of dimension at least limit,</span>
- <a name="l02997"></a>02997 <span class="comment">!</span>
- <a name="l02998"></a>02998 <span class="comment">! iord, nnlog - integer</span>
- <a name="l02999"></a>02999 <span class="comment">! vector of dimension at least limit, providing</span>
- <a name="l03000"></a>03000 <span class="comment">! space for the quantities needed in the</span>
- <a name="l03001"></a>03001 <span class="comment">! subdivision process of each cycle</span>
- <a name="l03002"></a>03002 <span class="comment">!</span>
- <a name="l03003"></a>03003 <span class="comment">! chebmo - real</span>
- <a name="l03004"></a>03004 <span class="comment">! array of dimension at least (maxp1,25),</span>
- <a name="l03005"></a>03005 <span class="comment">! providing space for the Chebyshev moments</span>
- <a name="l03006"></a>03006 <span class="comment">! needed within the cycles</span>
- <a name="l03007"></a>03007 <span class="comment">!</span>
- <a name="l03008"></a>03008 <span class="comment">! Local parameters:</span>
- <a name="l03009"></a>03009 <span class="comment">!</span>
- <a name="l03010"></a>03010 <span class="comment">! c1, c2 - end points of subinterval (of length</span>
- <a name="l03011"></a>03011 <span class="comment">! cycle)</span>
- <a name="l03012"></a>03012 <span class="comment">! cycle - (2*int(abs(omega))+1)*pi/abs(omega)</span>
- <a name="l03013"></a>03013 <span class="comment">! psum - vector of dimension at least (limexp+2)</span>
- <a name="l03014"></a>03014 <span class="comment">! (see routine qextr)</span>
- <a name="l03015"></a>03015 <span class="comment">! psum contains the part of the epsilon table</span>
- <a name="l03016"></a>03016 <span class="comment">! which is still needed for further computations.</span>
- <a name="l03017"></a>03017 <span class="comment">! each element of psum is a partial sum of</span>
- <a name="l03018"></a>03018 <span class="comment">! the series which should sum to the value of</span>
- <a name="l03019"></a>03019 <span class="comment">! the integral.</span>
- <a name="l03020"></a>03020 <span class="comment">! errsum - sum of error estimates over the</span>
- <a name="l03021"></a>03021 <span class="comment">! subintervals, calculated cumulatively</span>
- <a name="l03022"></a>03022 <span class="comment">! epsa - absolute tolerance requested over current</span>
- <a name="l03023"></a>03023 <span class="comment">! subinterval</span>
- <a name="l03024"></a>03024 <span class="comment">! chebmo - array containing the modified Chebyshev</span>
- <a name="l03025"></a>03025 <span class="comment">! moments (see also routine qc25o)</span>
- <a name="l03026"></a>03026 <span class="comment">!</span>
- <a name="l03027"></a>03027 <span class="keyword">implicit none</span>
- <a name="l03028"></a>03028
- <a name="l03029"></a>03029 <span class="keywordtype">integer</span> limit
- <a name="l03030"></a>03030 <span class="keywordtype">integer</span> limlst
- <a name="l03031"></a>03031 <span class="keywordtype">integer</span> maxp1
- <a name="l03032"></a>03032
- <a name="l03033"></a>03033 <span class="keywordtype">real</span> a
- <a name="l03034"></a>03034 <span class="keywordtype">real</span> abseps
- <a name="l03035"></a>03035 <span class="keywordtype">real</span> abserr
- <a name="l03036"></a>03036 <span class="keywordtype">real</span> alist(limit)
- <a name="l03037"></a>03037 <span class="keywordtype">real</span> blist(limit)
- <a name="l03038"></a>03038 <span class="keywordtype">real</span> chebmo(maxp1,25)
- <a name="l03039"></a>03039 <span class="keywordtype">real</span> correc
- <a name="l03040"></a>03040 <span class="keywordtype">real</span> cycle
- <a name="l03041"></a>03041 <span class="keywordtype">real</span> c1
- <a name="l03042"></a>03042 <span class="keywordtype">real</span> c2
- <a name="l03043"></a>03043 <span class="keywordtype">real</span> dl
- <a name="l03044"></a>03044 <span class="comment">! real dla</span>
- <a name="l03045"></a>03045 <span class="keywordtype">real</span> drl
- <a name="l03046"></a>03046 <span class="keywordtype">real</span> elist(limit)
- <a name="l03047"></a>03047 <span class="keywordtype">real</span> ep
- <a name="l03048"></a>03048 <span class="keywordtype">real</span> eps
- <a name="l03049"></a>03049 <span class="keywordtype">real</span> epsa
- <a name="l03050"></a>03050 <span class="keywordtype">real</span> epsabs
- <a name="l03051"></a>03051 <span class="keywordtype">real</span> erlst(limlst)
- <a name="l03052"></a>03052 <span class="keywordtype">real</span> errsum
- <a name="l03053"></a>03053 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l03054"></a>03054 <span class="keywordtype">real</span> fact
- <a name="l03055"></a>03055 <span class="keywordtype">integer</span> ier
- <a name="l03056"></a>03056 <span class="keywordtype">integer</span> ierlst(limlst)
- <a name="l03057"></a>03057 <span class="keywordtype">integer</span> integr
- <a name="l03058"></a>03058 <span class="keywordtype">integer</span> iord(limit)
- <a name="l03059"></a>03059 <span class="keywordtype">integer</span> ktmin
- <a name="l03060"></a>03060 <span class="keywordtype">integer</span> l
- <a name="l03061"></a>03061 <span class="keywordtype">integer</span> ll
- <a name="l03062"></a>03062 <span class="keywordtype">integer</span> lst
- <a name="l03063"></a>03063 <span class="keywordtype">integer</span> momcom
- <a name="l03064"></a>03064 <span class="keywordtype">integer</span> nev
- <a name="l03065"></a>03065 <span class="keywordtype">integer</span> neval
- <a name="l03066"></a>03066 <span class="keywordtype">integer</span> nnlog(limit)
- <a name="l03067"></a>03067 <span class="keywordtype">integer</span> nres
- <a name="l03068"></a>03068 <span class="keywordtype">integer</span> numrl2
- <a name="l03069"></a>03069 <span class="keywordtype">real</span> omega
- <a name="l03070"></a>03070 <span class="keywordtype">real</span>, <span class="keywordtype">parameter</span> :: p = 0.9E+00
- <a name="l03071"></a>03071 <span class="keywordtype">real</span>, <span class="keywordtype">parameter</span> :: pi = 3.1415926535897932E+00
- <a name="l03072"></a>03072 <span class="keywordtype">real</span> p1
- <a name="l03073"></a>03073 <span class="keywordtype">real</span> psum(52)
- <a name="l03074"></a>03074 <span class="keywordtype">real</span> reseps
- <a name="l03075"></a>03075 <span class="keywordtype">real</span> result
- <a name="l03076"></a>03076 <span class="keywordtype">real</span> res3la(3)
- <a name="l03077"></a>03077 <span class="keywordtype">real</span> rlist(limit)
- <a name="l03078"></a>03078 <span class="keywordtype">real</span> rslst(limlst)
- <a name="l03079"></a>03079 <span class="comment">!</span>
- <a name="l03080"></a>03080 <span class="comment">! The dimension of psum is determined by the value of</span>
- <a name="l03081"></a>03081 <span class="comment">! limexp in QEXTR (psum must be</span>
- <a name="l03082"></a>03082 <span class="comment">! of dimension (limexp+2) at least).</span>
- <a name="l03083"></a>03083 <span class="comment">!</span>
- <a name="l03084"></a>03084 <span class="comment">! Test on validity of parameters.</span>
- <a name="l03085"></a>03085 <span class="comment">!</span>
- <a name="l03086"></a>03086 result = 0.0e+00
- <a name="l03087"></a>03087 abserr = 0.0e+00
- <a name="l03088"></a>03088 neval = 0
- <a name="l03089"></a>03089 lst = 0
- <a name="l03090"></a>03090 ier = 0
- <a name="l03091"></a>03091
- <a name="l03092"></a>03092 <span class="keyword">if</span> ( (integr /= 1 .and. integr /= 2 ) .or. &
- <a name="l03093"></a>03093 epsabs <= 0.0e+00 .or. &
- <a name="l03094"></a>03094 limlst < 3 ) <span class="keyword">then</span>
- <a name="l03095"></a>03095 ier = 6
- <a name="l03096"></a>03096 return
- <a name="l03097"></a>03097 <span class="keyword">end if</span>
- <a name="l03098"></a>03098
- <a name="l03099"></a>03099 <span class="keyword">if</span> ( omega == 0.0e+00 ) <span class="keyword">then</span>
- <a name="l03100"></a>03100
- <a name="l03101"></a>03101 <span class="keyword">if</span> ( integr == 1 ) <span class="keyword">then</span>
- <a name="l03102"></a>03102 call <a class="code" href="quadpack_8f90.html#ac59eaf7c56c1d421d129425895fa0107">qagi </a>( f, 0.0e+00, 1, epsabs, 0.0e+00, result, abserr, neval, ier )
- <a name="l03103"></a>03103 <span class="keyword">else</span>
- <a name="l03104"></a>03104 result = 0.0E+00
- <a name="l03105"></a>03105 abserr = 0.0E+00
- <a name="l03106"></a>03106 neval = 0
- <a name="l03107"></a>03107 ier = 0
- <a name="l03108"></a>03108 <span class="keyword">end if</span>
- <a name="l03109"></a>03109
- <a name="l03110"></a>03110 rslst(1) = result
- <a name="l03111"></a>03111 erlst(1) = abserr
- <a name="l03112"></a>03112 ierlst(1) = ier
- <a name="l03113"></a>03113 lst = 1
- <a name="l03114"></a>03114
- <a name="l03115"></a>03115 return
- <a name="l03116"></a>03116 <span class="keyword">end if</span>
- <a name="l03117"></a>03117 <span class="comment">!</span>
- <a name="l03118"></a>03118 <span class="comment">! Initializations.</span>
- <a name="l03119"></a>03119 <span class="comment">!</span>
- <a name="l03120"></a>03120 l = int ( abs ( omega ) )
- <a name="l03121"></a>03121 dl = 2 * l + 1
- <a name="l03122"></a>03122 cycle = dl * pi / abs ( omega )
- <a name="l03123"></a>03123 ier = 0
- <a name="l03124"></a>03124 ktmin = 0
- <a name="l03125"></a>03125 neval = 0
- <a name="l03126"></a>03126 numrl2 = 0
- <a name="l03127"></a>03127 nres = 0
- <a name="l03128"></a>03128 c1 = a
- <a name="l03129"></a>03129 c2 = cycle+a
- <a name="l03130"></a>03130 p1 = 1.0e+00-p
- <a name="l03131"></a>03131 eps = epsabs
- <a name="l03132"></a>03132
- <a name="l03133"></a>03133 <span class="keyword">if</span> ( epsabs > tiny ( epsabs ) / p1 ) <span class="keyword">then</span>
- <a name="l03134"></a>03134 eps = epsabs * p1
- <a name="l03135"></a>03135 <span class="keyword">end if</span>
- <a name="l03136"></a>03136
- <a name="l03137"></a>03137 ep = eps
- <a name="l03138"></a>03138 fact = 1.0e+00
- <a name="l03139"></a>03139 correc = 0.0e+00
- <a name="l03140"></a>03140 abserr = 0.0e+00
- <a name="l03141"></a>03141 errsum = 0.0e+00
- <a name="l03142"></a>03142
- <a name="l03143"></a>03143 <span class="keyword">do</span> lst = 1, limlst
- <a name="l03144"></a>03144 <span class="comment">!</span>
- <a name="l03145"></a>03145 <span class="comment">! Integrate over current subinterval.</span>
- <a name="l03146"></a>03146 <span class="comment">!</span>
- <a name="l03147"></a>03147 <span class="comment">! dla = lst</span>
- <a name="l03148"></a>03148 epsa = eps * fact
- <a name="l03149"></a>03149
- <a name="l03150"></a>03150 call <a class="code" href="quadpack_8f90.html#abbba06307e0e8c4daa2651945570ba1c">qfour </a>( f, c1, c2, omega, integr, epsa, 0.0e+00, limit, lst, maxp1, &
- <a name="l03151"></a>03151 rslst(lst), erlst(lst), nev, ierlst(lst), alist, blist, rlist, elist, &
- <a name="l03152"></a>03152 iord, nnlog, momcom, chebmo )
- <a name="l03153"></a>03153
- <a name="l03154"></a>03154 neval = neval + nev
- <a name="l03155"></a>03155 fact = fact * p
- <a name="l03156"></a>03156 errsum = errsum + erlst(lst)
- <a name="l03157"></a>03157 drl = 5.0e+01 * abs(rslst(lst))
- <a name="l03158"></a>03158 <span class="comment">!</span>
- <a name="l03159"></a>03159 <span class="comment">! Test on accuracy with partial sum.</span>
- <a name="l03160"></a>03160 <span class="comment">!</span>
- <a name="l03161"></a>03161 <span class="keyword">if</span> ((errsum+drl) <= epsabs.and.lst >= 6) <span class="keyword">then</span>
- <a name="l03162"></a>03162 go to 80
- <a name="l03163"></a>03163 <span class="keyword">end if</span>
- <a name="l03164"></a>03164
- <a name="l03165"></a>03165 correc = max ( correc,erlst(lst))
- <a name="l03166"></a>03166
- <a name="l03167"></a>03167 <span class="keyword">if</span> ( ierlst(lst) /= 0 ) <span class="keyword">then</span>
- <a name="l03168"></a>03168 eps = max ( ep,correc*p1)
- <a name="l03169"></a>03169 ier = 7
- <a name="l03170"></a>03170 <span class="keyword">end if</span>
- <a name="l03171"></a>03171
- <a name="l03172"></a>03172 <span class="keyword">if</span> ( ier == 7 .and. (errsum+drl) <= correc*1.0e+01.and. lst > 5) go to 80
- <a name="l03173"></a>03173
- <a name="l03174"></a>03174 numrl2 = numrl2+1
- <a name="l03175"></a>03175
- <a name="l03176"></a>03176 <span class="keyword">if</span> ( lst <= 1 ) <span class="keyword">then</span>
- <a name="l03177"></a>03177 psum(1) = rslst(1)
- <a name="l03178"></a>03178 go to 40
- <a name="l03179"></a>03179 <span class="keyword">end if</span>
- <a name="l03180"></a>03180
- <a name="l03181"></a>03181 psum(numrl2) = psum(ll) + rslst(lst)
- <a name="l03182"></a>03182
- <a name="l03183"></a>03183 <span class="keyword">if</span> ( lst == 2 ) <span class="keyword">then</span>
- <a name="l03184"></a>03184 go to 40
- <a name="l03185"></a>03185 <span class="keyword">end if</span>
- <a name="l03186"></a>03186 <span class="comment">!</span>
- <a name="l03187"></a>03187 <span class="comment">! Test on maximum number of subintervals</span>
- <a name="l03188"></a>03188 <span class="comment">!</span>
- <a name="l03189"></a>03189 <span class="keyword">if</span> ( lst == limlst ) <span class="keyword">then</span>
- <a name="l03190"></a>03190 ier = 8
- <a name="l03191"></a>03191 <span class="keyword">end if</span>
- <a name="l03192"></a>03192 <span class="comment">!</span>
- <a name="l03193"></a>03193 <span class="comment">! Perform new extrapolation</span>
- <a name="l03194"></a>03194 <span class="comment">!</span>
- <a name="l03195"></a>03195 call <a class="code" href="quadpack_8f90.html#a5a75101d080f224c63adde98a0e64386">qextr </a>( numrl2, psum, reseps, abseps, res3la, nres )
- <a name="l03196"></a>03196 <span class="comment">!</span>
- <a name="l03197"></a>03197 <span class="comment">! Test whether extrapolated result is influenced by roundoff</span>
- <a name="l03198"></a>03198 <span class="comment">!</span>
- <a name="l03199"></a>03199 ktmin = ktmin + 1
- <a name="l03200"></a>03200
- <a name="l03201"></a>03201 <span class="keyword">if</span> ( ktmin >= 15 .and. abserr <= 1.0e-03 * (errsum+drl) ) <span class="keyword">then</span>
- <a name="l03202"></a>03202 ier = 9
- <a name="l03203"></a>03203 <span class="keyword">end if</span>
- <a name="l03204"></a>03204
- <a name="l03205"></a>03205 <span class="keyword">if</span> ( abseps <= abserr .or. lst == 3 ) <span class="keyword">then</span>
- <a name="l03206"></a>03206
- <a name="l03207"></a>03207 abserr = abseps
- <a name="l03208"></a>03208 result = reseps
- <a name="l03209"></a>03209 ktmin = 0
- <a name="l03210"></a>03210 <span class="comment">!</span>
- <a name="l03211"></a>03211 <span class="comment">! If IER is not 0, check whether direct result (partial</span>
- <a name="l03212"></a>03212 <span class="comment">! sum) or extrapolated result yields the best integral</span>
- <a name="l03213"></a>03213 <span class="comment">! approximation</span>
- <a name="l03214"></a>03214 <span class="comment">!</span>
- <a name="l03215"></a>03215 <span class="keyword">if</span> ( ( abserr + 1.0e+01 * correc ) <= epsabs ) <span class="keyword">then</span>
- <a name="l03216"></a>03216 exit
- <a name="l03217"></a>03217 <span class="keyword">end if</span>
- <a name="l03218"></a>03218
- <a name="l03219"></a>03219 <span class="keyword">if</span> ( abserr <= epsabs .and. 1.0e+01 * correc >= epsabs ) <span class="keyword">then</span>
- <a name="l03220"></a>03220 exit
- <a name="l03221"></a>03221 <span class="keyword">end if</span>
- <a name="l03222"></a>03222
- <a name="l03223"></a>03223 <span class="keyword">end if</span>
- <a name="l03224"></a>03224
- <a name="l03225"></a>03225 <span class="keyword">if</span> ( ier /= 0 .and. ier /= 7 ) <span class="keyword">then</span>
- <a name="l03226"></a>03226 exit
- <a name="l03227"></a>03227 <span class="keyword">end if</span>
- <a name="l03228"></a>03228
- <a name="l03229"></a>03229 40 continue
- <a name="l03230"></a>03230
- <a name="l03231"></a>03231 ll = numrl2
- <a name="l03232"></a>03232 c1 = c2
- <a name="l03233"></a>03233 c2 = c2+cycle
- <a name="l03234"></a>03234
- <a name="l03235"></a>03235 <span class="keyword">end do</span>
- <a name="l03236"></a>03236 <span class="comment">!</span>
- <a name="l03237"></a>03237 <span class="comment">! Set final result and error estimate.</span>
- <a name="l03238"></a>03238 <span class="comment">!</span>
- <a name="l03239"></a>03239 <span class="comment">!60 continue</span>
- <a name="l03240"></a>03240
- <a name="l03241"></a>03241 abserr = abserr + 1.0e+01 * correc
- <a name="l03242"></a>03242
- <a name="l03243"></a>03243 <span class="keyword">if</span> ( ier == 0 ) <span class="keyword">then</span>
- <a name="l03244"></a>03244 return
- <a name="l03245"></a>03245 <span class="keyword">end if</span>
- <a name="l03246"></a>03246
- <a name="l03247"></a>03247 <span class="keyword">if</span> ( result /= 0.0e+00 .and. psum(numrl2) /= 0.0e+00) go to 70
- <a name="l03248"></a>03248
- <a name="l03249"></a>03249 <span class="keyword">if</span> ( abserr > errsum ) <span class="keyword">then</span>
- <a name="l03250"></a>03250 go to 80
- <a name="l03251"></a>03251 <span class="keyword">end if</span>
- <a name="l03252"></a>03252
- <a name="l03253"></a>03253 <span class="keyword">if</span> ( psum(numrl2) == 0.0e+00 ) <span class="keyword">then</span>
- <a name="l03254"></a>03254 return
- <a name="l03255"></a>03255 <span class="keyword">end if</span>
- <a name="l03256"></a>03256
- <a name="l03257"></a>03257 70 continue
- <a name="l03258"></a>03258
- <a name="l03259"></a>03259 <span class="keyword">if</span> ( abserr / abs(result) <= (errsum+drl)/abs(psum(numrl2)) ) <span class="keyword">then</span>
- <a name="l03260"></a>03260
- <a name="l03261"></a>03261 <span class="keyword">if</span> ( ier >= 1 .and. ier /= 7 ) <span class="keyword">then</span>
- <a name="l03262"></a>03262 abserr = abserr + drl
- <a name="l03263"></a>03263 <span class="keyword">end if</span>
- <a name="l03264"></a>03264
- <a name="l03265"></a>03265 return
- <a name="l03266"></a>03266
- <a name="l03267"></a>03267 <span class="keyword">end if</span>
- <a name="l03268"></a>03268
- <a name="l03269"></a>03269 80 continue
- <a name="l03270"></a>03270
- <a name="l03271"></a>03271 result = psum(numrl2)
- <a name="l03272"></a>03272 abserr = errsum + drl
- <a name="l03273"></a>03273
- <a name="l03274"></a>03274 return
- <a name="l03275"></a>03275 <span class="keyword">end</span>
- <a name="l03276"></a><a class="code" href="quadpack_8f90.html#aaa4f15baf0dadd3383219f0d42a62752">03276</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#aaa4f15baf0dadd3383219f0d42a62752">qawo</a> ( f, a, b, omega, integr, epsabs, epsrel, result, abserr, &
- <a name="l03277"></a>03277 neval, ier )
- <a name="l03278"></a>03278
- <a name="l03279"></a>03279 <span class="comment">!*****************************************************************************80</span>
- <a name="l03280"></a>03280 <span class="comment">!</span>
- <a name="l03281"></a>03281 <span class="comment">!! QAWO computes the integrals of oscillatory integrands.</span>
- <a name="l03282"></a>03282 <span class="comment">!</span>
- <a name="l03283"></a>03283 <span class="comment">! Discussion:</span>
- <a name="l03284"></a>03284 <span class="comment">!</span>
- <a name="l03285"></a>03285 <span class="comment">! The routine calculates an approximation RESULT to a given</span>
- <a name="l03286"></a>03286 <span class="comment">! definite integral</span>
- <a name="l03287"></a>03287 <span class="comment">! I = Integral ( A <= X <= B ) F(X) * cos ( OMEGA * X ) dx</span>
- <a name="l03288"></a>03288 <span class="comment">! or </span>
- <a name="l03289"></a>03289 <span class="comment">! I = Integral ( A <= X <= B ) F(X) * sin ( OMEGA * X ) dx</span>
- <a name="l03290"></a>03290 <span class="comment">! hopefully satisfying following claim for accuracy</span>
- <a name="l03291"></a>03291 <span class="comment">! | I - RESULT | <= max ( epsabs, epsrel * |I| ).</span>
- <a name="l03292"></a>03292 <span class="comment">!</span>
- <a name="l03293"></a>03293 <span class="comment">! Author:</span>
- <a name="l03294"></a>03294 <span class="comment">!</span>
- <a name="l03295"></a>03295 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l03296"></a>03296 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l03297"></a>03297 <span class="comment">!</span>
- <a name="l03298"></a>03298 <span class="comment">! Reference:</span>
- <a name="l03299"></a>03299 <span class="comment">!</span>
- <a name="l03300"></a>03300 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l03301"></a>03301 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l03302"></a>03302 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l03303"></a>03303 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l03304"></a>03304 <span class="comment">!</span>
- <a name="l03305"></a>03305 <span class="comment">! Parameters:</span>
- <a name="l03306"></a>03306 <span class="comment">!</span>
- <a name="l03307"></a>03307 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l03308"></a>03308 <span class="comment">! function f ( x )</span>
- <a name="l03309"></a>03309 <span class="comment">! real f</span>
- <a name="l03310"></a>03310 <span class="comment">! real x</span>
- <a name="l03311"></a>03311 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l03312"></a>03312 <span class="comment">!</span>
- <a name="l03313"></a>03313 <span class="comment">! Input, real A, B, the limits of integration.</span>
- <a name="l03314"></a>03314 <span class="comment">!</span>
- <a name="l03315"></a>03315 <span class="comment">! Input, real OMEGA, the parameter in the weight function.</span>
- <a name="l03316"></a>03316 <span class="comment">!</span>
- <a name="l03317"></a>03317 <span class="comment">! Input, integer INTEGR, specifies the weight function:</span>
- <a name="l03318"></a>03318 <span class="comment">! 1, W(X) = cos ( OMEGA * X )</span>
- <a name="l03319"></a>03319 <span class="comment">! 2, W(X) = sin ( OMEGA * X )</span>
- <a name="l03320"></a>03320 <span class="comment">!</span>
- <a name="l03321"></a>03321 <span class="comment">! Input, real EPSABS, EPSREL, the absolute and relative accuracy requested.</span>
- <a name="l03322"></a>03322 <span class="comment">!</span>
- <a name="l03323"></a>03323 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l03324"></a>03324 <span class="comment">!</span>
- <a name="l03325"></a>03325 <span class="comment">! Output, real ABSERR, an estimate of || I - RESULT ||.</span>
- <a name="l03326"></a>03326 <span class="comment">!</span>
- <a name="l03327"></a>03327 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l03328"></a>03328 <span class="comment">!</span>
- <a name="l03329"></a>03329 <span class="comment">! ier - integer</span>
- <a name="l03330"></a>03330 <span class="comment">! ier = 0 normal and reliable termination of the</span>
- <a name="l03331"></a>03331 <span class="comment">! routine. it is assumed that the</span>
- <a name="l03332"></a>03332 <span class="comment">! requested accuracy has been achieved.</span>
- <a name="l03333"></a>03333 <span class="comment">! - ier > 0 abnormal termination of the routine.</span>
- <a name="l03334"></a>03334 <span class="comment">! the estimates for integral and error are</span>
- <a name="l03335"></a>03335 <span class="comment">! less reliable. it is assumed that the</span>
- <a name="l03336"></a>03336 <span class="comment">! requested accuracy has not been achieved.</span>
- <a name="l03337"></a>03337 <span class="comment">! ier = 1 maximum number of subdivisions allowed</span>
- <a name="l03338"></a>03338 <span class="comment">! (= leniw/2) has been achieved. one can</span>
- <a name="l03339"></a>03339 <span class="comment">! allow more subdivisions by increasing the</span>
- <a name="l03340"></a>03340 <span class="comment">! value of leniw (and taking the according</span>
- <a name="l03341"></a>03341 <span class="comment">! dimension adjustments into account).</span>
- <a name="l03342"></a>03342 <span class="comment">! however, if this yields no improvement it</span>
- <a name="l03343"></a>03343 <span class="comment">! is advised to analyze the integrand in</span>
- <a name="l03344"></a>03344 <span class="comment">! order to determine the integration</span>
- <a name="l03345"></a>03345 <span class="comment">! difficulties. if the position of a local</span>
- <a name="l03346"></a>03346 <span class="comment">! difficulty can be determined (e.g.</span>
- <a name="l03347"></a>03347 <span class="comment">! singularity, discontinuity within the</span>
- <a name="l03348"></a>03348 <span class="comment">! interval) one will probably gain from</span>
- <a name="l03349"></a>03349 <span class="comment">! splitting up the interval at this point</span>
- <a name="l03350"></a>03350 <span class="comment">! and calling the integrator on the</span>
- <a name="l03351"></a>03351 <span class="comment">! subranges. if possible, an appropriate</span>
- <a name="l03352"></a>03352 <span class="comment">! special-purpose integrator should</span>
- <a name="l03353"></a>03353 <span class="comment">! be used which is designed for handling</span>
- <a name="l03354"></a>03354 <span class="comment">! the type of difficulty involved.</span>
- <a name="l03355"></a>03355 <span class="comment">! = 2 the occurrence of roundoff error is</span>
- <a name="l03356"></a>03356 <span class="comment">! detected, which prevents the requested</span>
- <a name="l03357"></a>03357 <span class="comment">! tolerance from being achieved.</span>
- <a name="l03358"></a>03358 <span class="comment">! the error may be under-estimated.</span>
- <a name="l03359"></a>03359 <span class="comment">! = 3 extremely bad integrand behavior occurs</span>
- <a name="l03360"></a>03360 <span class="comment">! at some interior points of the integration</span>
- <a name="l03361"></a>03361 <span class="comment">! interval.</span>
- <a name="l03362"></a>03362 <span class="comment">! = 4 the algorithm does not converge. roundoff</span>
- <a name="l03363"></a>03363 <span class="comment">! error is detected in the extrapolation</span>
- <a name="l03364"></a>03364 <span class="comment">! table. it is presumed that the requested</span>
- <a name="l03365"></a>03365 <span class="comment">! tolerance cannot be achieved due to</span>
- <a name="l03366"></a>03366 <span class="comment">! roundoff in the extrapolation table,</span>
- <a name="l03367"></a>03367 <span class="comment">! and that the returned result is the best</span>
- <a name="l03368"></a>03368 <span class="comment">! which can be obtained.</span>
- <a name="l03369"></a>03369 <span class="comment">! = 5 the integral is probably divergent, or</span>
- <a name="l03370"></a>03370 <span class="comment">! slowly convergent. it must be noted that</span>
- <a name="l03371"></a>03371 <span class="comment">! divergence can occur with any other value</span>
- <a name="l03372"></a>03372 <span class="comment">! of ier.</span>
- <a name="l03373"></a>03373 <span class="comment">! = 6 the input is invalid, because</span>
- <a name="l03374"></a>03374 <span class="comment">! epsabs < 0 and epsrel < 0,</span>
- <a name="l03375"></a>03375 <span class="comment">! result, abserr, neval are set to zero.</span>
- <a name="l03376"></a>03376 <span class="comment">!</span>
- <a name="l03377"></a>03377 <span class="comment">! Local parameters:</span>
- <a name="l03378"></a>03378 <span class="comment">!</span>
- <a name="l03379"></a>03379 <span class="comment">! limit is the maximum number of subintervals allowed in the</span>
- <a name="l03380"></a>03380 <span class="comment">! subdivision process of QFOUR. take care that limit >= 1.</span>
- <a name="l03381"></a>03381 <span class="comment">!</span>
- <a name="l03382"></a>03382 <span class="comment">! maxp1 gives an upper bound on the number of Chebyshev moments</span>
- <a name="l03383"></a>03383 <span class="comment">! which can be stored, i.e. for the intervals of lengths</span>
- <a name="l03384"></a>03384 <span class="comment">! abs(b-a)*2**(-l), l = 0, 1, ... , maxp1-2. take care that</span>
- <a name="l03385"></a>03385 <span class="comment">! maxp1 >= 1.</span>
- <a name="l03386"></a>03386
- <a name="l03387"></a>03387 <span class="keyword">implicit none</span>
- <a name="l03388"></a>03388
- <a name="l03389"></a>03389 <span class="keywordtype">integer</span>, <span class="keywordtype">parameter</span> :: limit = 500
- <a name="l03390"></a>03390 <span class="keywordtype">integer</span>, <span class="keywordtype">parameter</span> :: maxp1 = 21
- <a name="l03391"></a>03391
- <a name="l03392"></a>03392 <span class="keywordtype">real</span> a
- <a name="l03393"></a>03393 <span class="keywordtype">real</span> abserr
- <a name="l03394"></a>03394 <span class="keywordtype">real</span> alist(limit)
- <a name="l03395"></a>03395 <span class="keywordtype">real</span> b
- <a name="l03396"></a>03396 <span class="keywordtype">real</span> blist(limit)
- <a name="l03397"></a>03397 <span class="keywordtype">real</span> chebmo(maxp1,25)
- <a name="l03398"></a>03398 <span class="keywordtype">real</span> elist(limit)
- <a name="l03399"></a>03399 <span class="keywordtype">real</span> epsabs
- <a name="l03400"></a>03400 <span class="keywordtype">real</span> epsrel
- <a name="l03401"></a>03401 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l03402"></a>03402 <span class="keywordtype">integer</span> ier
- <a name="l03403"></a>03403 <span class="keywordtype">integer</span> integr
- <a name="l03404"></a>03404 <span class="keywordtype">integer</span> iord(limit)
- <a name="l03405"></a>03405 <span class="keywordtype">integer</span> momcom
- <a name="l03406"></a>03406 <span class="keywordtype">integer</span> neval
- <a name="l03407"></a>03407 <span class="keywordtype">integer</span> nnlog(limit)
- <a name="l03408"></a>03408 <span class="keywordtype">real</span> omega
- <a name="l03409"></a>03409 <span class="keywordtype">real</span> result
- <a name="l03410"></a>03410 <span class="keywordtype">real</span> rlist(limit)
- <a name="l03411"></a>03411
- <a name="l03412"></a>03412 call <a class="code" href="quadpack_8f90.html#abbba06307e0e8c4daa2651945570ba1c">qfour </a>( f, a, b, omega, integr, epsabs, epsrel, limit, 1, maxp1, &
- <a name="l03413"></a>03413 result, abserr, neval, ier, alist, blist, rlist, elist, iord, nnlog, &
- <a name="l03414"></a>03414 momcom, chebmo )
- <a name="l03415"></a>03415
- <a name="l03416"></a>03416 return
- <a name="l03417"></a>03417 <span class="keyword">end</span>
- <a name="l03418"></a><a class="code" href="quadpack_8f90.html#a22846cb66e25f85c2eaa2b7fc1d6c81b">03418</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#a22846cb66e25f85c2eaa2b7fc1d6c81b">qaws</a> ( f, a, b, alfa, beta, integr, epsabs, epsrel, result, &
- <a name="l03419"></a>03419 abserr, neval, ier )
- <a name="l03420"></a>03420
- <a name="l03421"></a>03421 <span class="comment">!*****************************************************************************80</span>
- <a name="l03422"></a>03422 <span class="comment">!</span>
- <a name="l03423"></a>03423 <span class="comment">!! QAWS estimates integrals with algebraico-logarithmic endpoint singularities.</span>
- <a name="l03424"></a>03424 <span class="comment">!</span>
- <a name="l03425"></a>03425 <span class="comment">! Discussion:</span>
- <a name="l03426"></a>03426 <span class="comment">!</span>
- <a name="l03427"></a>03427 <span class="comment">! This routine calculates an approximation RESULT to a given</span>
- <a name="l03428"></a>03428 <span class="comment">! definite integral </span>
- <a name="l03429"></a>03429 <span class="comment">! I = integral of f*w over (a,b) </span>
- <a name="l03430"></a>03430 <span class="comment">! where w shows a singular behavior at the end points, see parameter</span>
- <a name="l03431"></a>03431 <span class="comment">! integr, hopefully satisfying following claim for accuracy</span>
- <a name="l03432"></a>03432 <span class="comment">! abs(i-result) <= max(epsabs,epsrel*abs(i)).</span>
- <a name="l03433"></a>03433 <span class="comment">!</span>
- <a name="l03434"></a>03434 <span class="comment">! Author:</span>
- <a name="l03435"></a>03435 <span class="comment">!</span>
- <a name="l03436"></a>03436 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l03437"></a>03437 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l03438"></a>03438 <span class="comment">!</span>
- <a name="l03439"></a>03439 <span class="comment">! Reference:</span>
- <a name="l03440"></a>03440 <span class="comment">!</span>
- <a name="l03441"></a>03441 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l03442"></a>03442 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l03443"></a>03443 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l03444"></a>03444 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l03445"></a>03445 <span class="comment">!</span>
- <a name="l03446"></a>03446 <span class="comment">! Parameters:</span>
- <a name="l03447"></a>03447 <span class="comment">!</span>
- <a name="l03448"></a>03448 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l03449"></a>03449 <span class="comment">! function f ( x )</span>
- <a name="l03450"></a>03450 <span class="comment">! real f</span>
- <a name="l03451"></a>03451 <span class="comment">! real x</span>
- <a name="l03452"></a>03452 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l03453"></a>03453 <span class="comment">!</span>
- <a name="l03454"></a>03454 <span class="comment">! Input, real A, B, the limits of integration.</span>
- <a name="l03455"></a>03455 <span class="comment">!</span>
- <a name="l03456"></a>03456 <span class="comment">! Input, real ALFA, BETA, parameters used in the weight function.</span>
- <a name="l03457"></a>03457 <span class="comment">! ALFA and BETA should be greater than -1.</span>
- <a name="l03458"></a>03458 <span class="comment">!</span>
- <a name="l03459"></a>03459 <span class="comment">! Input, integer INTEGR, indicates which weight function is to be used</span>
- <a name="l03460"></a>03460 <span class="comment">! = 1 (x-a)**alfa*(b-x)**beta</span>
- <a name="l03461"></a>03461 <span class="comment">! = 2 (x-a)**alfa*(b-x)**beta*log(x-a)</span>
- <a name="l03462"></a>03462 <span class="comment">! = 3 (x-a)**alfa*(b-x)**beta*log(b-x)</span>
- <a name="l03463"></a>03463 <span class="comment">! = 4 (x-a)**alfa*(b-x)**beta*log(x-a)*log(b-x)</span>
- <a name="l03464"></a>03464 <span class="comment">!</span>
- <a name="l03465"></a>03465 <span class="comment">! Input, real EPSABS, EPSREL, the absolute and relative accuracy requested.</span>
- <a name="l03466"></a>03466 <span class="comment">!</span>
- <a name="l03467"></a>03467 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l03468"></a>03468 <span class="comment">!</span>
- <a name="l03469"></a>03469 <span class="comment">! Output, real ABSERR, an estimate of || I - RESULT ||.</span>
- <a name="l03470"></a>03470 <span class="comment">!</span>
- <a name="l03471"></a>03471 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l03472"></a>03472 <span class="comment">!</span>
- <a name="l03473"></a>03473 <span class="comment">! ier - integer</span>
- <a name="l03474"></a>03474 <span class="comment">! ier = 0 normal and reliable termination of the</span>
- <a name="l03475"></a>03475 <span class="comment">! routine. it is assumed that the requested</span>
- <a name="l03476"></a>03476 <span class="comment">! accuracy has been achieved.</span>
- <a name="l03477"></a>03477 <span class="comment">! ier > 0 abnormal termination of the routine</span>
- <a name="l03478"></a>03478 <span class="comment">! the estimates for the integral and error</span>
- <a name="l03479"></a>03479 <span class="comment">! are less reliable. it is assumed that the</span>
- <a name="l03480"></a>03480 <span class="comment">! requested accuracy has not been achieved.</span>
- <a name="l03481"></a>03481 <span class="comment">! ier = 1 maximum number of subdivisions allowed</span>
- <a name="l03482"></a>03482 <span class="comment">! has been achieved. one can allow more</span>
- <a name="l03483"></a>03483 <span class="comment">! subdivisions by increasing the data value</span>
- <a name="l03484"></a>03484 <span class="comment">! of limit in qaws (and taking the according</span>
- <a name="l03485"></a>03485 <span class="comment">! dimension adjustments into account).</span>
- <a name="l03486"></a>03486 <span class="comment">! however, if this yields no improvement it</span>
- <a name="l03487"></a>03487 <span class="comment">! is advised to analyze the integrand, in</span>
- <a name="l03488"></a>03488 <span class="comment">! order to determine the integration</span>
- <a name="l03489"></a>03489 <span class="comment">! difficulties which prevent the requested</span>
- <a name="l03490"></a>03490 <span class="comment">! tolerance from being achieved. in case of</span>
- <a name="l03491"></a>03491 <span class="comment">! a jump discontinuity or a local</span>
- <a name="l03492"></a>03492 <span class="comment">! singularity of algebraico-logarithmic type</span>
- <a name="l03493"></a>03493 <span class="comment">! at one or more interior points of the</span>
- <a name="l03494"></a>03494 <span class="comment">! integration range, one should proceed by</span>
- <a name="l03495"></a>03495 <span class="comment">! splitting up the interval at these points</span>
- <a name="l03496"></a>03496 <span class="comment">! and calling the integrator on the</span>
- <a name="l03497"></a>03497 <span class="comment">! subranges.</span>
- <a name="l03498"></a>03498 <span class="comment">! = 2 the occurrence of roundoff error is</span>
- <a name="l03499"></a>03499 <span class="comment">! detected, which prevents the requested</span>
- <a name="l03500"></a>03500 <span class="comment">! tolerance from being achieved.</span>
- <a name="l03501"></a>03501 <span class="comment">! = 3 extremely bad integrand behavior occurs</span>
- <a name="l03502"></a>03502 <span class="comment">! at some points of the integration</span>
- <a name="l03503"></a>03503 <span class="comment">! interval.</span>
- <a name="l03504"></a>03504 <span class="comment">! = 6 the input is invalid, because</span>
- <a name="l03505"></a>03505 <span class="comment">! b <= a or alfa <= (-1) or beta <= (-1) or</span>
- <a name="l03506"></a>03506 <span class="comment">! integr < 1 or integr > 4 or</span>
- <a name="l03507"></a>03507 <span class="comment">! epsabs < 0 and epsrel < 0,</span>
- <a name="l03508"></a>03508 <span class="comment">! result, abserr, neval are set to zero.</span>
- <a name="l03509"></a>03509 <span class="comment">!</span>
- <a name="l03510"></a>03510 <span class="comment">! Local parameters:</span>
- <a name="l03511"></a>03511 <span class="comment">!</span>
- <a name="l03512"></a>03512 <span class="comment">! LIMIT is the maximum number of subintervals allowed in the</span>
- <a name="l03513"></a>03513 <span class="comment">! subdivision process of qawse. take care that limit >= 2.</span>
- <a name="l03514"></a>03514 <span class="comment">!</span>
- <a name="l03515"></a>03515 <span class="keyword">implicit none</span>
- <a name="l03516"></a>03516
- <a name="l03517"></a>03517 <span class="keywordtype">integer</span>, <span class="keywordtype">parameter</span> :: limit = 500
- <a name="l03518"></a>03518
- <a name="l03519"></a>03519 <span class="keywordtype">real</span> a
- <a name="l03520"></a>03520 <span class="keywordtype">real</span> abserr
- <a name="l03521"></a>03521 <span class="keywordtype">real</span> alfa
- <a name="l03522"></a>03522 <span class="keywordtype">real</span> alist(limit)
- <a name="l03523"></a>03523 <span class="keywordtype">real</span> b
- <a name="l03524"></a>03524 <span class="keywordtype">real</span> blist(limit)
- <a name="l03525"></a>03525 <span class="keywordtype">real</span> beta
- <a name="l03526"></a>03526 <span class="keywordtype">real</span> elist(limit)
- <a name="l03527"></a>03527 <span class="keywordtype">real</span> epsabs
- <a name="l03528"></a>03528 <span class="keywordtype">real</span> epsrel
- <a name="l03529"></a>03529 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l03530"></a>03530 <span class="keywordtype">integer</span> ier
- <a name="l03531"></a>03531 <span class="keywordtype">integer</span> integr
- <a name="l03532"></a>03532 <span class="keywordtype">integer</span> iord(limit)
- <a name="l03533"></a>03533 <span class="keywordtype">integer</span> last
- <a name="l03534"></a>03534 <span class="keywordtype">integer</span> neval
- <a name="l03535"></a>03535 <span class="keywordtype">real</span> result
- <a name="l03536"></a>03536 <span class="keywordtype">real</span> rlist(limit)
- <a name="l03537"></a>03537
- <a name="l03538"></a>03538 call <a class="code" href="quadpack_8f90.html#adf40beeb87b948ed57824e42c023f518">qawse </a>( f, a, b, alfa, beta, integr, epsabs, epsrel, limit, result, &
- <a name="l03539"></a>03539 abserr, neval, ier, alist, blist, rlist, elist, iord, last )
- <a name="l03540"></a>03540
- <a name="l03541"></a>03541 return
- <a name="l03542"></a>03542 <span class="keyword">end</span>
- <a name="l03543"></a><a class="code" href="quadpack_8f90.html#adf40beeb87b948ed57824e42c023f518">03543</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#adf40beeb87b948ed57824e42c023f518">qawse</a> ( f, a, b, alfa, beta, integr, epsabs, epsrel, limit, &
- <a name="l03544"></a>03544 result, abserr, neval, ier, alist, blist, rlist, elist, iord, last )
- <a name="l03545"></a>03545
- <a name="l03546"></a>03546 <span class="comment">!*****************************************************************************80</span>
- <a name="l03547"></a>03547 <span class="comment">!</span>
- <a name="l03548"></a>03548 <span class="comment">!! QAWSE estimates integrals with algebraico-logarithmic endpoint singularities.</span>
- <a name="l03549"></a>03549 <span class="comment">!</span>
- <a name="l03550"></a>03550 <span class="comment">! Discussion:</span>
- <a name="l03551"></a>03551 <span class="comment">!</span>
- <a name="l03552"></a>03552 <span class="comment">! This routine calculates an approximation RESULT to an integral</span>
- <a name="l03553"></a>03553 <span class="comment">! I = integral of F(X) * W(X) over (a,b), </span>
- <a name="l03554"></a>03554 <span class="comment">! where W(X) shows a singular behavior at the endpoints, hopefully </span>
- <a name="l03555"></a>03555 <span class="comment">! satisfying:</span>
- <a name="l03556"></a>03556 <span class="comment">! | I - RESULT | <= max ( epsabs, epsrel * |I| ).</span>
- <a name="l03557"></a>03557 <span class="comment">!</span>
- <a name="l03558"></a>03558 <span class="comment">! Author:</span>
- <a name="l03559"></a>03559 <span class="comment">!</span>
- <a name="l03560"></a>03560 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l03561"></a>03561 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l03562"></a>03562 <span class="comment">!</span>
- <a name="l03563"></a>03563 <span class="comment">! Reference:</span>
- <a name="l03564"></a>03564 <span class="comment">!</span>
- <a name="l03565"></a>03565 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l03566"></a>03566 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l03567"></a>03567 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l03568"></a>03568 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l03569"></a>03569 <span class="comment">!</span>
- <a name="l03570"></a>03570 <span class="comment">! Parameters:</span>
- <a name="l03571"></a>03571 <span class="comment">!</span>
- <a name="l03572"></a>03572 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l03573"></a>03573 <span class="comment">! function f ( x )</span>
- <a name="l03574"></a>03574 <span class="comment">! real f</span>
- <a name="l03575"></a>03575 <span class="comment">! real x</span>
- <a name="l03576"></a>03576 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l03577"></a>03577 <span class="comment">!</span>
- <a name="l03578"></a>03578 <span class="comment">! Input, real A, B, the limits of integration.</span>
- <a name="l03579"></a>03579 <span class="comment">!</span>
- <a name="l03580"></a>03580 <span class="comment">! Input, real ALFA, BETA, parameters used in the weight function.</span>
- <a name="l03581"></a>03581 <span class="comment">! ALFA and BETA should be greater than -1.</span>
- <a name="l03582"></a>03582 <span class="comment">!</span>
- <a name="l03583"></a>03583 <span class="comment">! Input, integer INTEGR, indicates which weight function is used:</span>
- <a name="l03584"></a>03584 <span class="comment">! = 1 (x-a)**alfa*(b-x)**beta</span>
- <a name="l03585"></a>03585 <span class="comment">! = 2 (x-a)**alfa*(b-x)**beta*log(x-a)</span>
- <a name="l03586"></a>03586 <span class="comment">! = 3 (x-a)**alfa*(b-x)**beta*log(b-x)</span>
- <a name="l03587"></a>03587 <span class="comment">! = 4 (x-a)**alfa*(b-x)**beta*log(x-a)*log(b-x)</span>
- <a name="l03588"></a>03588 <span class="comment">!</span>
- <a name="l03589"></a>03589 <span class="comment">! Input, real EPSABS, EPSREL, the absolute and relative accuracy requested.</span>
- <a name="l03590"></a>03590 <span class="comment">!</span>
- <a name="l03591"></a>03591 <span class="comment">! Input, integer LIMIT, an upper bound on the number of subintervals</span>
- <a name="l03592"></a>03592 <span class="comment">! in the partition of (A,B), LIMIT >= 2. If LIMIT < 2, the routine </span>
- <a name="l03593"></a>03593 <span class="comment">! will end with IER = 6.</span>
- <a name="l03594"></a>03594 <span class="comment">!</span>
- <a name="l03595"></a>03595 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l03596"></a>03596 <span class="comment">!</span>
- <a name="l03597"></a>03597 <span class="comment">! Output, real ABSERR, an estimate of || I - RESULT ||.</span>
- <a name="l03598"></a>03598 <span class="comment">!</span>
- <a name="l03599"></a>03599 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l03600"></a>03600 <span class="comment">!</span>
- <a name="l03601"></a>03601 <span class="comment">! ier - integer</span>
- <a name="l03602"></a>03602 <span class="comment">! ier = 0 normal and reliable termination of the</span>
- <a name="l03603"></a>03603 <span class="comment">! routine. it is assumed that the requested</span>
- <a name="l03604"></a>03604 <span class="comment">! accuracy has been achieved.</span>
- <a name="l03605"></a>03605 <span class="comment">! ier > 0 abnormal termination of the routine</span>
- <a name="l03606"></a>03606 <span class="comment">! the estimates for the integral and error</span>
- <a name="l03607"></a>03607 <span class="comment">! are less reliable. it is assumed that the</span>
- <a name="l03608"></a>03608 <span class="comment">! requested accuracy has not been achieved.</span>
- <a name="l03609"></a>03609 <span class="comment">! = 1 maximum number of subdivisions allowed</span>
- <a name="l03610"></a>03610 <span class="comment">! has been achieved. one can allow more</span>
- <a name="l03611"></a>03611 <span class="comment">! subdivisions by increasing the value of</span>
- <a name="l03612"></a>03612 <span class="comment">! limit. however, if this yields no</span>
- <a name="l03613"></a>03613 <span class="comment">! improvement it is advised to analyze the</span>
- <a name="l03614"></a>03614 <span class="comment">! integrand, in order to determine the</span>
- <a name="l03615"></a>03615 <span class="comment">! integration difficulties which prevent</span>
- <a name="l03616"></a>03616 <span class="comment">! the requested tolerance from being</span>
- <a name="l03617"></a>03617 <span class="comment">! achieved. in case of a jump discontinuity</span>
- <a name="l03618"></a>03618 <span class="comment">! or a local singularity of algebraico-</span>
- <a name="l03619"></a>03619 <span class="comment">! logarithmic type at one or more interior</span>
- <a name="l03620"></a>03620 <span class="comment">! points of the integration range, one</span>
- <a name="l03621"></a>03621 <span class="comment">! should proceed by splitting up the</span>
- <a name="l03622"></a>03622 <span class="comment">! interval at these points and calling the</span>
- <a name="l03623"></a>03623 <span class="comment">! integrator on the subranges.</span>
- <a name="l03624"></a>03624 <span class="comment">! = 2 the occurrence of roundoff error is</span>
- <a name="l03625"></a>03625 <span class="comment">! detected, which prevents the requested</span>
- <a name="l03626"></a>03626 <span class="comment">! tolerance from being achieved.</span>
- <a name="l03627"></a>03627 <span class="comment">! = 3 extremely bad integrand behavior occurs</span>
- <a name="l03628"></a>03628 <span class="comment">! at some points of the integration</span>
- <a name="l03629"></a>03629 <span class="comment">! interval.</span>
- <a name="l03630"></a>03630 <span class="comment">! = 6 the input is invalid, because</span>
- <a name="l03631"></a>03631 <span class="comment">! b <= a or alfa <= (-1) or beta <= (-1) or</span>
- <a name="l03632"></a>03632 <span class="comment">! integr < 1 or integr > 4, or</span>
- <a name="l03633"></a>03633 <span class="comment">! epsabs < 0 and epsrel < 0,</span>
- <a name="l03634"></a>03634 <span class="comment">! or limit < 2.</span>
- <a name="l03635"></a>03635 <span class="comment">! result, abserr, neval, rlist(1), elist(1),</span>
- <a name="l03636"></a>03636 <span class="comment">! iord(1) and last are set to zero.</span>
- <a name="l03637"></a>03637 <span class="comment">! alist(1) and blist(1) are set to a and b</span>
- <a name="l03638"></a>03638 <span class="comment">! respectively.</span>
- <a name="l03639"></a>03639 <span class="comment">!</span>
- <a name="l03640"></a>03640 <span class="comment">! Workspace, real ALIST(LIMIT), BLIST(LIMIT), contains in entries 1 </span>
- <a name="l03641"></a>03641 <span class="comment">! through LAST the left and right ends of the partition subintervals.</span>
- <a name="l03642"></a>03642 <span class="comment">!</span>
- <a name="l03643"></a>03643 <span class="comment">! Workspace, real RLIST(LIMIT), contains in entries 1 through LAST</span>
- <a name="l03644"></a>03644 <span class="comment">! the integral approximations on the subintervals.</span>
- <a name="l03645"></a>03645 <span class="comment">!</span>
- <a name="l03646"></a>03646 <span class="comment">! Workspace, real ELIST(LIMIT), contains in entries 1 through LAST</span>
- <a name="l03647"></a>03647 <span class="comment">! the absolute error estimates on the subintervals.</span>
- <a name="l03648"></a>03648 <span class="comment">!</span>
- <a name="l03649"></a>03649 <span class="comment">! iord - integer</span>
- <a name="l03650"></a>03650 <span class="comment">! vector of dimension at least limit, the first k</span>
- <a name="l03651"></a>03651 <span class="comment">! elements of which are pointers to the error</span>
- <a name="l03652"></a>03652 <span class="comment">! estimates over the subintervals, so that</span>
- <a name="l03653"></a>03653 <span class="comment">! elist(iord(1)), ..., elist(iord(k)) with k = last</span>
- <a name="l03654"></a>03654 <span class="comment">! if last <= (limit/2+2), and k = limit+1-last</span>
- <a name="l03655"></a>03655 <span class="comment">! otherwise, form a decreasing sequence.</span>
- <a name="l03656"></a>03656 <span class="comment">!</span>
- <a name="l03657"></a>03657 <span class="comment">! Output, integer LAST, the number of subintervals actually produced in </span>
- <a name="l03658"></a>03658 <span class="comment">! the subdivision process.</span>
- <a name="l03659"></a>03659 <span class="comment">!</span>
- <a name="l03660"></a>03660 <span class="comment">! Local parameters:</span>
- <a name="l03661"></a>03661 <span class="comment">!</span>
- <a name="l03662"></a>03662 <span class="comment">! alist - list of left end points of all subintervals</span>
- <a name="l03663"></a>03663 <span class="comment">! considered up to now</span>
- <a name="l03664"></a>03664 <span class="comment">! blist - list of right end points of all subintervals</span>
- <a name="l03665"></a>03665 <span class="comment">! considered up to now</span>
- <a name="l03666"></a>03666 <span class="comment">! rlist(i) - approximation to the integral over</span>
- <a name="l03667"></a>03667 <span class="comment">! (alist(i),blist(i))</span>
- <a name="l03668"></a>03668 <span class="comment">! elist(i) - error estimate applying to rlist(i)</span>
- <a name="l03669"></a>03669 <span class="comment">! maxerr - pointer to the interval with largest error</span>
- <a name="l03670"></a>03670 <span class="comment">! estimate</span>
- <a name="l03671"></a>03671 <span class="comment">! errmax - elist(maxerr)</span>
- <a name="l03672"></a>03672 <span class="comment">! area - sum of the integrals over the subintervals</span>
- <a name="l03673"></a>03673 <span class="comment">! errsum - sum of the errors over the subintervals</span>
- <a name="l03674"></a>03674 <span class="comment">! errbnd - requested accuracy max(epsabs,epsrel*</span>
- <a name="l03675"></a>03675 <span class="comment">! abs(result))</span>
- <a name="l03676"></a>03676 <span class="comment">! *****1 - variable for the left subinterval</span>
- <a name="l03677"></a>03677 <span class="comment">! *****2 - variable for the right subinterval</span>
- <a name="l03678"></a>03678 <span class="comment">! last - index for subdivision</span>
- <a name="l03679"></a>03679 <span class="comment">!</span>
- <a name="l03680"></a>03680 <span class="keyword">implicit none</span>
- <a name="l03681"></a>03681
- <a name="l03682"></a>03682 <span class="keywordtype">integer</span> limit
- <a name="l03683"></a>03683
- <a name="l03684"></a>03684 <span class="keywordtype">real</span> a
- <a name="l03685"></a>03685 <span class="keywordtype">real</span> abserr
- <a name="l03686"></a>03686 <span class="keywordtype">real</span> alfa
- <a name="l03687"></a>03687 <span class="keywordtype">real</span> alist(limit)
- <a name="l03688"></a>03688 <span class="keywordtype">real</span> area
- <a name="l03689"></a>03689 <span class="keywordtype">real</span> area1
- <a name="l03690"></a>03690 <span class="keywordtype">real</span> area12
- <a name="l03691"></a>03691 <span class="keywordtype">real</span> area2
- <a name="l03692"></a>03692 <span class="keywordtype">real</span> a1
- <a name="l03693"></a>03693 <span class="keywordtype">real</span> a2
- <a name="l03694"></a>03694 <span class="keywordtype">real</span> b
- <a name="l03695"></a>03695 <span class="keywordtype">real</span> beta
- <a name="l03696"></a>03696 <span class="keywordtype">real</span> blist(limit)
- <a name="l03697"></a>03697 <span class="keywordtype">real</span> b1
- <a name="l03698"></a>03698 <span class="keywordtype">real</span> b2
- <a name="l03699"></a>03699 <span class="keywordtype">real</span> centre
- <a name="l03700"></a>03700 <span class="keywordtype">real</span> elist(limit)
- <a name="l03701"></a>03701 <span class="keywordtype">real</span> epsabs
- <a name="l03702"></a>03702 <span class="keywordtype">real</span> epsrel
- <a name="l03703"></a>03703 <span class="keywordtype">real</span> errbnd
- <a name="l03704"></a>03704 <span class="keywordtype">real</span> errmax
- <a name="l03705"></a>03705 <span class="keywordtype">real</span> error1
- <a name="l03706"></a>03706 <span class="keywordtype">real</span> erro12
- <a name="l03707"></a>03707 <span class="keywordtype">real</span> error2
- <a name="l03708"></a>03708 <span class="keywordtype">real</span> errsum
- <a name="l03709"></a>03709 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l03710"></a>03710 <span class="keywordtype">integer</span> ier
- <a name="l03711"></a>03711 <span class="keywordtype">integer</span> integr
- <a name="l03712"></a>03712 <span class="keywordtype">integer</span> iord(limit)
- <a name="l03713"></a>03713 <span class="keywordtype">integer</span> iroff1
- <a name="l03714"></a>03714 <span class="keywordtype">integer</span> iroff2
- <a name="l03715"></a>03715 <span class="keywordtype">integer</span> last
- <a name="l03716"></a>03716 <span class="keywordtype">integer</span> maxerr
- <a name="l03717"></a>03717 <span class="keywordtype">integer</span> nev
- <a name="l03718"></a>03718 <span class="keywordtype">integer</span> neval
- <a name="l03719"></a>03719 <span class="keywordtype">integer</span> nrmax
- <a name="l03720"></a>03720 <span class="keywordtype">real</span> resas1
- <a name="l03721"></a>03721 <span class="keywordtype">real</span> resas2
- <a name="l03722"></a>03722 <span class="keywordtype">real</span> result
- <a name="l03723"></a>03723 <span class="keywordtype">real</span> rg(25)
- <a name="l03724"></a>03724 <span class="keywordtype">real</span> rh(25)
- <a name="l03725"></a>03725 <span class="keywordtype">real</span> ri(25)
- <a name="l03726"></a>03726 <span class="keywordtype">real</span> rj(25)
- <a name="l03727"></a>03727 <span class="keywordtype">real</span> rlist(limit)
- <a name="l03728"></a>03728 <span class="comment">!</span>
- <a name="l03729"></a>03729 <span class="comment">! Test on validity of parameters.</span>
- <a name="l03730"></a>03730 <span class="comment">!</span>
- <a name="l03731"></a>03731 ier = 0
- <a name="l03732"></a>03732 neval = 0
- <a name="l03733"></a>03733 last = 0
- <a name="l03734"></a>03734 rlist(1) = 0.0e+00
- <a name="l03735"></a>03735 elist(1) = 0.0e+00
- <a name="l03736"></a>03736 iord(1) = 0
- <a name="l03737"></a>03737 result = 0.0e+00
- <a name="l03738"></a>03738 abserr = 0.0e+00
- <a name="l03739"></a>03739
- <a name="l03740"></a>03740 <span class="keyword">if</span> ( b <= a .or. &
- <a name="l03741"></a>03741 (epsabs < 0.0e+00 .and. epsrel < 0.0e+00) .or. &
- <a name="l03742"></a>03742 alfa <= (-1.0e+00) .or. &
- <a name="l03743"></a>03743 beta <= (-1.0e+00) .or. &
- <a name="l03744"></a>03744 integr < 1 .or. &
- <a name="l03745"></a>03745 integr > 4 .or. &
- <a name="l03746"></a>03746 limit < 2 ) <span class="keyword">then</span>
- <a name="l03747"></a>03747 ier = 6
- <a name="l03748"></a>03748 return
- <a name="l03749"></a>03749 <span class="keyword">end if</span>
- <a name="l03750"></a>03750 <span class="comment">!</span>
- <a name="l03751"></a>03751 <span class="comment">! Compute the modified Chebyshev moments.</span>
- <a name="l03752"></a>03752 <span class="comment">!</span>
- <a name="l03753"></a>03753 call <a class="code" href="quadpack_8f90.html#aa732651ae77f9486d6e3d17999c699ab">qmomo </a>( alfa, beta, ri, rj, rg, rh, integr )
- <a name="l03754"></a>03754 <span class="comment">!</span>
- <a name="l03755"></a>03755 <span class="comment">! Integrate over the intervals (a,(a+b)/2) and ((a+b)/2,b).</span>
- <a name="l03756"></a>03756 <span class="comment">!</span>
- <a name="l03757"></a>03757 centre = 5.0e-01 * ( b + a )
- <a name="l03758"></a>03758
- <a name="l03759"></a>03759 call <a class="code" href="quadpack_8f90.html#a034546450320f53f05096bc12af9b5bc">qc25s </a>( f, a, b, a, centre, alfa, beta, ri, rj, rg, rh, area1, &
- <a name="l03760"></a>03760 error1, resas1, integr, nev )
- <a name="l03761"></a>03761
- <a name="l03762"></a>03762 neval = nev
- <a name="l03763"></a>03763
- <a name="l03764"></a>03764 call <a class="code" href="quadpack_8f90.html#a034546450320f53f05096bc12af9b5bc">qc25s </a>( f, a, b, centre, b, alfa, beta, ri, rj, rg, rh, area2, &
- <a name="l03765"></a>03765 error2, resas2, integr, nev )
- <a name="l03766"></a>03766
- <a name="l03767"></a>03767 last = 2
- <a name="l03768"></a>03768 neval = neval+nev
- <a name="l03769"></a>03769 result = area1+area2
- <a name="l03770"></a>03770 abserr = error1+error2
- <a name="l03771"></a>03771 <span class="comment">!</span>
- <a name="l03772"></a>03772 <span class="comment">! Test on accuracy.</span>
- <a name="l03773"></a>03773 <span class="comment">!</span>
- <a name="l03774"></a>03774 errbnd = max ( epsabs, epsrel * abs ( result ) )
- <a name="l03775"></a>03775 <span class="comment">!</span>
- <a name="l03776"></a>03776 <span class="comment">! Initialization.</span>
- <a name="l03777"></a>03777 <span class="comment">!</span>
- <a name="l03778"></a>03778 <span class="keyword">if</span> ( error2 <= error1 ) <span class="keyword">then</span>
- <a name="l03779"></a>03779 alist(1) = a
- <a name="l03780"></a>03780 alist(2) = centre
- <a name="l03781"></a>03781 blist(1) = centre
- <a name="l03782"></a>03782 blist(2) = b
- <a name="l03783"></a>03783 rlist(1) = area1
- <a name="l03784"></a>03784 rlist(2) = area2
- <a name="l03785"></a>03785 elist(1) = error1
- <a name="l03786"></a>03786 elist(2) = error2
- <a name="l03787"></a>03787 <span class="keyword">else</span>
- <a name="l03788"></a>03788 alist(1) = centre
- <a name="l03789"></a>03789 alist(2) = a
- <a name="l03790"></a>03790 blist(1) = b
- <a name="l03791"></a>03791 blist(2) = centre
- <a name="l03792"></a>03792 rlist(1) = area2
- <a name="l03793"></a>03793 rlist(2) = area1
- <a name="l03794"></a>03794 elist(1) = error2
- <a name="l03795"></a>03795 elist(2) = error1
- <a name="l03796"></a>03796 <span class="keyword">end if</span>
- <a name="l03797"></a>03797
- <a name="l03798"></a>03798 iord(1) = 1
- <a name="l03799"></a>03799 iord(2) = 2
- <a name="l03800"></a>03800
- <a name="l03801"></a>03801 <span class="keyword">if</span> ( limit == 2 ) <span class="keyword">then</span>
- <a name="l03802"></a>03802 ier = 1
- <a name="l03803"></a>03803 return
- <a name="l03804"></a>03804 <span class="keyword">end if</span>
- <a name="l03805"></a>03805
- <a name="l03806"></a>03806 <span class="keyword">if</span> ( abserr <= errbnd ) <span class="keyword">then</span>
- <a name="l03807"></a>03807 return
- <a name="l03808"></a>03808 <span class="keyword">end if</span>
- <a name="l03809"></a>03809
- <a name="l03810"></a>03810 errmax = elist(1)
- <a name="l03811"></a>03811 maxerr = 1
- <a name="l03812"></a>03812 nrmax = 1
- <a name="l03813"></a>03813 area = result
- <a name="l03814"></a>03814 errsum = abserr
- <a name="l03815"></a>03815 iroff1 = 0
- <a name="l03816"></a>03816 iroff2 = 0
- <a name="l03817"></a>03817
- <a name="l03818"></a>03818 <span class="keyword">do</span> last = 3, limit
- <a name="l03819"></a>03819 <span class="comment">!</span>
- <a name="l03820"></a>03820 <span class="comment">! Bisect the subinterval with largest error estimate.</span>
- <a name="l03821"></a>03821 <span class="comment">!</span>
- <a name="l03822"></a>03822 a1 = alist(maxerr)
- <a name="l03823"></a>03823 b1 = 5.0e-01 * ( alist(maxerr) + blist(maxerr) )
- <a name="l03824"></a>03824 a2 = b1
- <a name="l03825"></a>03825 b2 = blist(maxerr)
- <a name="l03826"></a>03826
- <a name="l03827"></a>03827 call <a class="code" href="quadpack_8f90.html#a034546450320f53f05096bc12af9b5bc">qc25s </a>( f, a, b, a1, b1, alfa, beta, ri, rj, rg, rh, area1, &
- <a name="l03828"></a>03828 error1, resas1, integr, nev )
- <a name="l03829"></a>03829
- <a name="l03830"></a>03830 neval = neval + nev
- <a name="l03831"></a>03831
- <a name="l03832"></a>03832 call <a class="code" href="quadpack_8f90.html#a034546450320f53f05096bc12af9b5bc">qc25s </a>( f, a, b, a2, b2, alfa, beta, ri, rj, rg, rh, area2, &
- <a name="l03833"></a>03833 error2, resas2, integr, nev )
- <a name="l03834"></a>03834
- <a name="l03835"></a>03835 neval = neval + nev
- <a name="l03836"></a>03836 <span class="comment">!</span>
- <a name="l03837"></a>03837 <span class="comment">! Improve previous approximations integral and error and</span>
- <a name="l03838"></a>03838 <span class="comment">! test for accuracy.</span>
- <a name="l03839"></a>03839 <span class="comment">!</span>
- <a name="l03840"></a>03840 area12 = area1+area2
- <a name="l03841"></a>03841 erro12 = error1+error2
- <a name="l03842"></a>03842 errsum = errsum+erro12-errmax
- <a name="l03843"></a>03843 area = area+area12-rlist(maxerr)
- <a name="l03844"></a>03844 <span class="comment">!</span>
- <a name="l03845"></a>03845 <span class="comment">! Test for roundoff error.</span>
- <a name="l03846"></a>03846 <span class="comment">!</span>
- <a name="l03847"></a>03847 <span class="keyword">if</span> ( a /= a1 .and. b /= b2 ) <span class="keyword">then</span>
- <a name="l03848"></a>03848
- <a name="l03849"></a>03849 <span class="keyword">if</span> ( resas1 /= error1 .and. resas2 /= error2 ) <span class="keyword">then</span>
- <a name="l03850"></a>03850
- <a name="l03851"></a>03851 <span class="keyword">if</span> ( abs ( rlist(maxerr) - area12 ) < 1.0e-05 * abs ( area12 ) &
- <a name="l03852"></a>03852 .and.erro12 >= 9.9e-01*errmax ) <span class="keyword">then</span>
- <a name="l03853"></a>03853 iroff1 = iroff1 + 1
- <a name="l03854"></a>03854 <span class="keyword">end if</span>
- <a name="l03855"></a>03855
- <a name="l03856"></a>03856 <span class="keyword">if</span> ( last > 10 .and. erro12 > errmax ) <span class="keyword">then</span>
- <a name="l03857"></a>03857 iroff2 = iroff2 + 1
- <a name="l03858"></a>03858 <span class="keyword">end if</span>
- <a name="l03859"></a>03859
- <a name="l03860"></a>03860 <span class="keyword">end if</span>
- <a name="l03861"></a>03861
- <a name="l03862"></a>03862 <span class="keyword">end if</span>
- <a name="l03863"></a>03863
- <a name="l03864"></a>03864 rlist(maxerr) = area1
- <a name="l03865"></a>03865 rlist(last) = area2
- <a name="l03866"></a>03866 <span class="comment">!</span>
- <a name="l03867"></a>03867 <span class="comment">! Test on accuracy.</span>
- <a name="l03868"></a>03868 <span class="comment">!</span>
- <a name="l03869"></a>03869 errbnd = max ( epsabs, epsrel * abs ( area ) )
- <a name="l03870"></a>03870
- <a name="l03871"></a>03871 <span class="keyword">if</span> ( errsum > errbnd ) <span class="keyword">then</span>
- <a name="l03872"></a>03872 <span class="comment">!</span>
- <a name="l03873"></a>03873 <span class="comment">! Set error flag in the case that the number of interval</span>
- <a name="l03874"></a>03874 <span class="comment">! bisections exceeds limit.</span>
- <a name="l03875"></a>03875 <span class="comment">!</span>
- <a name="l03876"></a>03876 <span class="keyword">if</span> ( last == limit ) <span class="keyword">then</span>
- <a name="l03877"></a>03877 ier = 1
- <a name="l03878"></a>03878 <span class="keyword">end if</span>
- <a name="l03879"></a>03879 <span class="comment">!</span>
- <a name="l03880"></a>03880 <span class="comment">! Set error flag in the case of roundoff error.</span>
- <a name="l03881"></a>03881 <span class="comment">!</span>
- <a name="l03882"></a>03882 <span class="keyword">if</span> ( iroff1 >= 6 .or. iroff2 >= 20 ) <span class="keyword">then</span>
- <a name="l03883"></a>03883 ier = 2
- <a name="l03884"></a>03884 <span class="keyword">end if</span>
- <a name="l03885"></a>03885 <span class="comment">!</span>
- <a name="l03886"></a>03886 <span class="comment">! Set error flag in the case of bad integrand behavior</span>
- <a name="l03887"></a>03887 <span class="comment">! at interior points of integration range.</span>
- <a name="l03888"></a>03888 <span class="comment">!</span>
- <a name="l03889"></a>03889 <span class="keyword">if</span> ( max ( abs(a1),abs(b2)) <= (1.0e+00+1.0e+03* epsilon ( a1 ) )* &
- <a name="l03890"></a>03890 ( abs(a2) + 1.0e+03* tiny ( a2) )) <span class="keyword">then</span>
- <a name="l03891"></a>03891 ier = 3
- <a name="l03892"></a>03892 <span class="keyword">end if</span>
- <a name="l03893"></a>03893
- <a name="l03894"></a>03894 <span class="keyword">end if</span>
- <a name="l03895"></a>03895 <span class="comment">!</span>
- <a name="l03896"></a>03896 <span class="comment">! Append the newly-created intervals to the list.</span>
- <a name="l03897"></a>03897 <span class="comment">!</span>
- <a name="l03898"></a>03898 <span class="keyword">if</span> ( error2 <= error1 ) <span class="keyword">then</span>
- <a name="l03899"></a>03899 alist(last) = a2
- <a name="l03900"></a>03900 blist(maxerr) = b1
- <a name="l03901"></a>03901 blist(last) = b2
- <a name="l03902"></a>03902 elist(maxerr) = error1
- <a name="l03903"></a>03903 elist(last) = error2
- <a name="l03904"></a>03904 <span class="keyword">else</span>
- <a name="l03905"></a>03905 alist(maxerr) = a2
- <a name="l03906"></a>03906 alist(last) = a1
- <a name="l03907"></a>03907 blist(last) = b1
- <a name="l03908"></a>03908 rlist(maxerr) = area2
- <a name="l03909"></a>03909 rlist(last) = area1
- <a name="l03910"></a>03910 elist(maxerr) = error2
- <a name="l03911"></a>03911 elist(last) = error1
- <a name="l03912"></a>03912 <span class="keyword">end if</span>
- <a name="l03913"></a>03913 <span class="comment">!</span>
- <a name="l03914"></a>03914 <span class="comment">! Call QSORT to maintain the descending ordering</span>
- <a name="l03915"></a>03915 <span class="comment">! in the list of error estimates and select the subinterval</span>
- <a name="l03916"></a>03916 <span class="comment">! with largest error estimate (to be bisected next).</span>
- <a name="l03917"></a>03917 <span class="comment">!</span>
- <a name="l03918"></a>03918 call <a class="code" href="quadpack_8f90.html#a55e08a684c5a6315fb37dd0fdc66d8e6">qsort </a>( limit, last, maxerr, errmax, elist, iord, nrmax )
- <a name="l03919"></a>03919
- <a name="l03920"></a>03920 <span class="keyword">if</span> ( ier /= 0 .or. errsum <= errbnd ) <span class="keyword">then</span>
- <a name="l03921"></a>03921 exit
- <a name="l03922"></a>03922 <span class="keyword">end if</span>
- <a name="l03923"></a>03923
- <a name="l03924"></a>03924 <span class="keyword">end do</span>
- <a name="l03925"></a>03925 <span class="comment">!</span>
- <a name="l03926"></a>03926 <span class="comment">! Compute final result.</span>
- <a name="l03927"></a>03927 <span class="comment">!</span>
- <a name="l03928"></a>03928 result = sum ( rlist(1:last) )
- <a name="l03929"></a>03929
- <a name="l03930"></a>03930 abserr = errsum
- <a name="l03931"></a>03931
- <a name="l03932"></a>03932 return
- <a name="l03933"></a>03933 <span class="keyword">end</span>
- <a name="l03934"></a><a class="code" href="quadpack_8f90.html#af8148c1623b7cf59159c491cfb1856f4">03934</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#af8148c1623b7cf59159c491cfb1856f4">qc25c</a> ( f, a, b, c, result, abserr, krul, neval )
- <a name="l03935"></a>03935
- <a name="l03936"></a>03936 <span class="comment">!*****************************************************************************80</span>
- <a name="l03937"></a>03937 <span class="comment">!</span>
- <a name="l03938"></a>03938 <span class="comment">!! QC25C returns integration rules for Cauchy Principal Value integrals.</span>
- <a name="l03939"></a>03939 <span class="comment">!</span>
- <a name="l03940"></a>03940 <span class="comment">! Discussion:</span>
- <a name="l03941"></a>03941 <span class="comment">!</span>
- <a name="l03942"></a>03942 <span class="comment">! This routine estimates </span>
- <a name="l03943"></a>03943 <span class="comment">! I = integral of F(X) * W(X) over (a,b) </span>
- <a name="l03944"></a>03944 <span class="comment">! with error estimate, where </span>
- <a name="l03945"></a>03945 <span class="comment">! w(x) = 1/(x-c)</span>
- <a name="l03946"></a>03946 <span class="comment">!</span>
- <a name="l03947"></a>03947 <span class="comment">! Author:</span>
- <a name="l03948"></a>03948 <span class="comment">!</span>
- <a name="l03949"></a>03949 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l03950"></a>03950 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l03951"></a>03951 <span class="comment">!</span>
- <a name="l03952"></a>03952 <span class="comment">! Reference:</span>
- <a name="l03953"></a>03953 <span class="comment">!</span>
- <a name="l03954"></a>03954 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l03955"></a>03955 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l03956"></a>03956 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l03957"></a>03957 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l03958"></a>03958 <span class="comment">!</span>
- <a name="l03959"></a>03959 <span class="comment">! Parameters:</span>
- <a name="l03960"></a>03960 <span class="comment">!</span>
- <a name="l03961"></a>03961 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l03962"></a>03962 <span class="comment">! function f ( x )</span>
- <a name="l03963"></a>03963 <span class="comment">! real f</span>
- <a name="l03964"></a>03964 <span class="comment">! real x</span>
- <a name="l03965"></a>03965 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l03966"></a>03966 <span class="comment">!</span>
- <a name="l03967"></a>03967 <span class="comment">! Input, real A, B, the limits of integration.</span>
- <a name="l03968"></a>03968 <span class="comment">!</span>
- <a name="l03969"></a>03969 <span class="comment">! Input, real C, the parameter in the weight function.</span>
- <a name="l03970"></a>03970 <span class="comment">!</span>
- <a name="l03971"></a>03971 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l03972"></a>03972 <span class="comment">! RESULT is computed by using a generalized Clenshaw-Curtis method if</span>
- <a name="l03973"></a>03973 <span class="comment">! C lies within ten percent of the integration interval. In the </span>
- <a name="l03974"></a>03974 <span class="comment">! other case the 15-point Kronrod rule obtained by optimal addition</span>
- <a name="l03975"></a>03975 <span class="comment">! of abscissae to the 7-point Gauss rule, is applied.</span>
- <a name="l03976"></a>03976 <span class="comment">!</span>
- <a name="l03977"></a>03977 <span class="comment">! Output, real ABSERR, an estimate of || I - RESULT ||.</span>
- <a name="l03978"></a>03978 <span class="comment">!</span>
- <a name="l03979"></a>03979 <span class="comment">! krul - integer</span>
- <a name="l03980"></a>03980 <span class="comment">! key which is decreased by 1 if the 15-point</span>
- <a name="l03981"></a>03981 <span class="comment">! Gauss-Kronrod scheme has been used</span>
- <a name="l03982"></a>03982 <span class="comment">!</span>
- <a name="l03983"></a>03983 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l03984"></a>03984 <span class="comment">!</span>
- <a name="l03985"></a>03985 <span class="comment">! Local parameters:</span>
- <a name="l03986"></a>03986 <span class="comment">!</span>
- <a name="l03987"></a>03987 <span class="comment">! fval - value of the function f at the points</span>
- <a name="l03988"></a>03988 <span class="comment">! cos(k*pi/24), k = 0, ..., 24</span>
- <a name="l03989"></a>03989 <span class="comment">! cheb12 - Chebyshev series expansion coefficients, for the</span>
- <a name="l03990"></a>03990 <span class="comment">! function f, of degree 12</span>
- <a name="l03991"></a>03991 <span class="comment">! cheb24 - Chebyshev series expansion coefficients, for the</span>
- <a name="l03992"></a>03992 <span class="comment">! function f, of degree 24</span>
- <a name="l03993"></a>03993 <span class="comment">! res12 - approximation to the integral corresponding to the</span>
- <a name="l03994"></a>03994 <span class="comment">! use of cheb12</span>
- <a name="l03995"></a>03995 <span class="comment">! res24 - approximation to the integral corresponding to the</span>
- <a name="l03996"></a>03996 <span class="comment">! use of cheb24</span>
- <a name="l03997"></a>03997 <span class="comment">! qwgtc - external function subprogram defining the weight</span>
- <a name="l03998"></a>03998 <span class="comment">! function</span>
- <a name="l03999"></a>03999 <span class="comment">! hlgth - half-length of the interval</span>
- <a name="l04000"></a>04000 <span class="comment">! centr - mid point of the interval</span>
- <a name="l04001"></a>04001 <span class="comment">!</span>
- <a name="l04002"></a>04002 <span class="keyword">implicit none</span>
- <a name="l04003"></a>04003
- <a name="l04004"></a>04004 <span class="keywordtype">real</span> a
- <a name="l04005"></a>04005 <span class="keywordtype">real</span> abserr
- <a name="l04006"></a>04006 <span class="keywordtype">real</span> ak22
- <a name="l04007"></a>04007 <span class="keywordtype">real</span> amom0
- <a name="l04008"></a>04008 <span class="keywordtype">real</span> amom1
- <a name="l04009"></a>04009 <span class="keywordtype">real</span> amom2
- <a name="l04010"></a>04010 <span class="keywordtype">real</span> b
- <a name="l04011"></a>04011 <span class="keywordtype">real</span> c
- <a name="l04012"></a>04012 <span class="keywordtype">real</span> cc
- <a name="l04013"></a>04013 <span class="keywordtype">real</span> centr
- <a name="l04014"></a>04014 <span class="keywordtype">real</span> cheb12(13)
- <a name="l04015"></a>04015 <span class="keywordtype">real</span> cheb24(25)
- <a name="l04016"></a>04016 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l04017"></a>04017 <span class="keywordtype">real</span> fval(25)
- <a name="l04018"></a>04018 <span class="keywordtype">real</span> hlgth
- <a name="l04019"></a>04019 <span class="keywordtype">integer</span> i
- <a name="l04020"></a>04020 <span class="keywordtype">integer</span> isym
- <a name="l04021"></a>04021 <span class="keywordtype">integer</span> k
- <a name="l04022"></a>04022 <span class="keywordtype">integer</span> kp
- <a name="l04023"></a>04023 <span class="keywordtype">integer</span> krul
- <a name="l04024"></a>04024 <span class="keywordtype">integer</span> neval
- <a name="l04025"></a>04025 <span class="keywordtype">real</span> p2
- <a name="l04026"></a>04026 <span class="keywordtype">real</span> p3
- <a name="l04027"></a>04027 <span class="keywordtype">real</span> p4
- <a name="l04028"></a>04028 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: qwgtc
- <a name="l04029"></a>04029 <span class="keywordtype">real</span> resabs
- <a name="l04030"></a>04030 <span class="keywordtype">real</span> resasc
- <a name="l04031"></a>04031 <span class="keywordtype">real</span> result
- <a name="l04032"></a>04032 <span class="keywordtype">real</span> res12
- <a name="l04033"></a>04033 <span class="keywordtype">real</span> res24
- <a name="l04034"></a>04034 <span class="keywordtype">real</span> u
- <a name="l04035"></a>04035 <span class="keywordtype">real</span>, <span class="keywordtype">parameter</span>, <span class="keywordtype">dimension ( 11 )</span> :: x = (/
- <a name="l04036"></a>04036 9.914448613738104e-01, 9.659258262890683e-01,
- <a name="l04037"></a>04037 9.238795325112868e-01, 8.660254037844386e-01,
- <a name="l04038"></a>04038 7.933533402912352e-01, 7.071067811865475e-01,
- <a name="l04039"></a>04039 6.087614290087206e-01, 5.000000000000000e-01,
- <a name="l04040"></a>04040 3.826834323650898e-01, 2.588190451025208e-01,
- <a name="l04041"></a>04041 1.305261922200516e-01 /)
- <a name="l04042"></a>04042 <span class="comment">!</span>
- <a name="l04043"></a>04043 <span class="comment">! Check the position of C.</span>
- <a name="l04044"></a>04044 <span class="comment">!</span>
- <a name="l04045"></a>04045 cc = ( 2.0e+00 * c - b - a ) / ( b - a )
- <a name="l04046"></a>04046 <span class="comment">!</span>
- <a name="l04047"></a>04047 <span class="comment">! Apply the 15-point Gauss-Kronrod scheme.</span>
- <a name="l04048"></a>04048 <span class="comment">!</span>
- <a name="l04049"></a>04049 <span class="keyword">if</span> ( abs ( cc ) >= 1.1e+00 ) <span class="keyword">then</span>
- <a name="l04050"></a>04050 krul = krul - 1
- <a name="l04051"></a>04051 call <a class="code" href="quadpack_8f90.html#a0c083838940925726abd5bc85fa29587">qk15w </a>( f, qwgtc, c, p2, p3, p4, kp, a, b, result, abserr, &
- <a name="l04052"></a>04052 resabs, resasc )
- <a name="l04053"></a>04053 neval = 15
- <a name="l04054"></a>04054 <span class="keyword">if</span> ( resasc == abserr ) <span class="keyword">then</span>
- <a name="l04055"></a>04055 krul = krul+1
- <a name="l04056"></a>04056 <span class="keyword">end if</span>
- <a name="l04057"></a>04057 return
- <a name="l04058"></a>04058 <span class="keyword">end if</span>
- <a name="l04059"></a>04059 <span class="comment">!</span>
- <a name="l04060"></a>04060 <span class="comment">! Use the generalized Clenshaw-Curtis method.</span>
- <a name="l04061"></a>04061 <span class="comment">!</span>
- <a name="l04062"></a>04062 hlgth = 5.0e-01 * ( b - a )
- <a name="l04063"></a>04063 centr = 5.0e-01 * ( b + a )
- <a name="l04064"></a>04064 neval = 25
- <a name="l04065"></a>04065 fval(1) = 5.0e-01 * f(hlgth+centr)
- <a name="l04066"></a>04066 fval(13) = f(centr)
- <a name="l04067"></a>04067 fval(25) = 5.0e-01 * f(centr-hlgth)
- <a name="l04068"></a>04068
- <a name="l04069"></a>04069 <span class="keyword">do</span> i = 2, 12
- <a name="l04070"></a>04070 u = hlgth * x(i-1)
- <a name="l04071"></a>04071 isym = 26 - i
- <a name="l04072"></a>04072 fval(i) = f(u+centr)
- <a name="l04073"></a>04073 fval(isym) = f(centr-u)
- <a name="l04074"></a>04074 <span class="keyword">end do</span>
- <a name="l04075"></a>04075 <span class="comment">!</span>
- <a name="l04076"></a>04076 <span class="comment">! Compute the Chebyshev series expansion.</span>
- <a name="l04077"></a>04077 <span class="comment">!</span>
- <a name="l04078"></a>04078 call <a class="code" href="quadpack_8f90.html#ad5beefcfdb335ea68ccf8397536c8c36">qcheb </a>( x, fval, cheb12, cheb24 )
- <a name="l04079"></a>04079 <span class="comment">!</span>
- <a name="l04080"></a>04080 <span class="comment">! The modified Chebyshev moments are computed by forward</span>
- <a name="l04081"></a>04081 <span class="comment">! recursion, using AMOM0 and AMOM1 as starting values.</span>
- <a name="l04082"></a>04082 <span class="comment">!</span>
- <a name="l04083"></a>04083 amom0 = log ( abs ( ( 1.0e+00 - cc ) / ( 1.0e+00 + cc ) ) )
- <a name="l04084"></a>04084 amom1 = 2.0e+00 + cc * amom0
- <a name="l04085"></a>04085 res12 = cheb12(1) * amom0 + cheb12(2) * amom1
- <a name="l04086"></a>04086 res24 = cheb24(1) * amom0 + cheb24(2) * amom1
- <a name="l04087"></a>04087
- <a name="l04088"></a>04088 <span class="keyword">do</span> k = 3, 13
- <a name="l04089"></a>04089 amom2 = 2.0e+00 * cc * amom1 - amom0
- <a name="l04090"></a>04090 ak22 = ( k - 2 ) * ( k - 2 )
- <a name="l04091"></a>04091 <span class="keyword">if</span> ( ( k / 2 ) * 2 == k ) <span class="keyword">then</span>
- <a name="l04092"></a>04092 amom2 = amom2 - 4.0e+00 / ( ak22 - 1.0e+00 )
- <a name="l04093"></a>04093 <span class="keyword">end if</span>
- <a name="l04094"></a>04094 res12 = res12 + cheb12(k) * amom2
- <a name="l04095"></a>04095 res24 = res24 + cheb24(k) * amom2
- <a name="l04096"></a>04096 amom0 = amom1
- <a name="l04097"></a>04097 amom1 = amom2
- <a name="l04098"></a>04098 <span class="keyword">end do</span>
- <a name="l04099"></a>04099
- <a name="l04100"></a>04100 <span class="keyword">do</span> k = 14, 25
- <a name="l04101"></a>04101 amom2 = 2.0e+00 * cc * amom1 - amom0
- <a name="l04102"></a>04102 ak22 = ( k - 2 ) * ( k - 2 )
- <a name="l04103"></a>04103 <span class="keyword">if</span> ( ( k / 2 ) * 2 == k ) <span class="keyword">then</span>
- <a name="l04104"></a>04104 amom2 = amom2 - 4.0e+00 / ( ak22 - 1.0e+00 )
- <a name="l04105"></a>04105 <span class="keyword">end if</span>
- <a name="l04106"></a>04106 res24 = res24 + cheb24(k) * amom2
- <a name="l04107"></a>04107 amom0 = amom1
- <a name="l04108"></a>04108 amom1 = amom2
- <a name="l04109"></a>04109 <span class="keyword">end do</span>
- <a name="l04110"></a>04110
- <a name="l04111"></a>04111 result = res24
- <a name="l04112"></a>04112 abserr = abs ( res24 - res12 )
- <a name="l04113"></a>04113
- <a name="l04114"></a>04114 return
- <a name="l04115"></a>04115 <span class="keyword">end</span>
- <a name="l04116"></a><a class="code" href="quadpack_8f90.html#ab0843f4831942d2c9bf3430cb71aca06">04116</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#ab0843f4831942d2c9bf3430cb71aca06">qc25o</a> ( f, a, b, omega, integr, nrmom, maxp1, ksave, result, &
- <a name="l04117"></a>04117 abserr, neval, resabs, resasc, momcom, chebmo )
- <a name="l04118"></a>04118
- <a name="l04119"></a>04119 <span class="comment">!*****************************************************************************80</span>
- <a name="l04120"></a>04120 <span class="comment">!</span>
- <a name="l04121"></a>04121 <span class="comment">!! QC25O returns integration rules for integrands with a COS or SIN factor.</span>
- <a name="l04122"></a>04122 <span class="comment">!</span>
- <a name="l04123"></a>04123 <span class="comment">! Discussion:</span>
- <a name="l04124"></a>04124 <span class="comment">!</span>
- <a name="l04125"></a>04125 <span class="comment">! This routine estimates the integral</span>
- <a name="l04126"></a>04126 <span class="comment">! I = integral of f(x) * w(x) over (a,b)</span>
- <a name="l04127"></a>04127 <span class="comment">! where</span>
- <a name="l04128"></a>04128 <span class="comment">! w(x) = cos(omega*x)</span>
- <a name="l04129"></a>04129 <span class="comment">! or </span>
- <a name="l04130"></a>04130 <span class="comment">! w(x) = sin(omega*x),</span>
- <a name="l04131"></a>04131 <span class="comment">! and estimates</span>
- <a name="l04132"></a>04132 <span class="comment">! J = integral ( A <= X <= B ) |F(X)| dx.</span>
- <a name="l04133"></a>04133 <span class="comment">!</span>
- <a name="l04134"></a>04134 <span class="comment">! For small values of OMEGA or small intervals (a,b) the 15-point</span>
- <a name="l04135"></a>04135 <span class="comment">! Gauss-Kronrod rule is used. In all other cases a generalized</span>
- <a name="l04136"></a>04136 <span class="comment">! Clenshaw-Curtis method is used, that is, a truncated Chebyshev </span>
- <a name="l04137"></a>04137 <span class="comment">! expansion of the function F is computed on (a,b), so that the </span>
- <a name="l04138"></a>04138 <span class="comment">! integrand can be written as a sum of terms of the form W(X)*T(K,X), </span>
- <a name="l04139"></a>04139 <span class="comment">! where T(K,X) is the Chebyshev polynomial of degree K. The Chebyshev</span>
- <a name="l04140"></a>04140 <span class="comment">! moments are computed with use of a linear recurrence relation.</span>
- <a name="l04141"></a>04141 <span class="comment">!</span>
- <a name="l04142"></a>04142 <span class="comment">! Author:</span>
- <a name="l04143"></a>04143 <span class="comment">!</span>
- <a name="l04144"></a>04144 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l04145"></a>04145 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l04146"></a>04146 <span class="comment">!</span>
- <a name="l04147"></a>04147 <span class="comment">! Reference:</span>
- <a name="l04148"></a>04148 <span class="comment">!</span>
- <a name="l04149"></a>04149 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l04150"></a>04150 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l04151"></a>04151 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l04152"></a>04152 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l04153"></a>04153 <span class="comment">!</span>
- <a name="l04154"></a>04154 <span class="comment">! Parameters:</span>
- <a name="l04155"></a>04155 <span class="comment">!</span>
- <a name="l04156"></a>04156 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l04157"></a>04157 <span class="comment">! function f ( x )</span>
- <a name="l04158"></a>04158 <span class="comment">! real f</span>
- <a name="l04159"></a>04159 <span class="comment">! real x</span>
- <a name="l04160"></a>04160 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l04161"></a>04161 <span class="comment">!</span>
- <a name="l04162"></a>04162 <span class="comment">! Input, real A, B, the limits of integration.</span>
- <a name="l04163"></a>04163 <span class="comment">!</span>
- <a name="l04164"></a>04164 <span class="comment">! Input, real OMEGA, the parameter in the weight function.</span>
- <a name="l04165"></a>04165 <span class="comment">!</span>
- <a name="l04166"></a>04166 <span class="comment">! Input, integer INTEGR, indicates which weight function is to be used</span>
- <a name="l04167"></a>04167 <span class="comment">! = 1, w(x) = cos(omega*x)</span>
- <a name="l04168"></a>04168 <span class="comment">! = 2, w(x) = sin(omega*x)</span>
- <a name="l04169"></a>04169 <span class="comment">!</span>
- <a name="l04170"></a>04170 <span class="comment">! ?, integer NRMOM, the length of interval (a,b) is equal to the length</span>
- <a name="l04171"></a>04171 <span class="comment">! of the original integration interval divided by</span>
- <a name="l04172"></a>04172 <span class="comment">! 2**nrmom (we suppose that the routine is used in an</span>
- <a name="l04173"></a>04173 <span class="comment">! adaptive integration process, otherwise set</span>
- <a name="l04174"></a>04174 <span class="comment">! nrmom = 0). nrmom must be zero at the first call.</span>
- <a name="l04175"></a>04175 <span class="comment">!</span>
- <a name="l04176"></a>04176 <span class="comment">! maxp1 - integer</span>
- <a name="l04177"></a>04177 <span class="comment">! gives an upper bound on the number of Chebyshev</span>
- <a name="l04178"></a>04178 <span class="comment">! moments which can be stored, i.e. for the intervals</span>
- <a name="l04179"></a>04179 <span class="comment">! of lengths abs(bb-aa)*2**(-l), l = 0,1,2, ...,</span>
- <a name="l04180"></a>04180 <span class="comment">! maxp1-2.</span>
- <a name="l04181"></a>04181 <span class="comment">!</span>
- <a name="l04182"></a>04182 <span class="comment">! ksave - integer</span>
- <a name="l04183"></a>04183 <span class="comment">! key which is one when the moments for the</span>
- <a name="l04184"></a>04184 <span class="comment">! current interval have been computed</span>
- <a name="l04185"></a>04185 <span class="comment">!</span>
- <a name="l04186"></a>04186 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l04187"></a>04187 <span class="comment">!</span>
- <a name="l04188"></a>04188 <span class="comment">! abserr - real</span>
- <a name="l04189"></a>04189 <span class="comment">! estimate of the modulus of the absolute</span>
- <a name="l04190"></a>04190 <span class="comment">! error, which should equal or exceed abs(i-result)</span>
- <a name="l04191"></a>04191 <span class="comment">!</span>
- <a name="l04192"></a>04192 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l04193"></a>04193 <span class="comment">!</span>
- <a name="l04194"></a>04194 <span class="comment">! Output, real RESABS, approximation to the integral J.</span>
- <a name="l04195"></a>04195 <span class="comment">!</span>
- <a name="l04196"></a>04196 <span class="comment">! Output, real RESASC, approximation to the integral of abs(F-I/(B-A)).</span>
- <a name="l04197"></a>04197 <span class="comment">!</span>
- <a name="l04198"></a>04198 <span class="comment">! on entry and return</span>
- <a name="l04199"></a>04199 <span class="comment">! momcom - integer</span>
- <a name="l04200"></a>04200 <span class="comment">! for each interval length we need to compute</span>
- <a name="l04201"></a>04201 <span class="comment">! the Chebyshev moments. momcom counts the number</span>
- <a name="l04202"></a>04202 <span class="comment">! of intervals for which these moments have already</span>
- <a name="l04203"></a>04203 <span class="comment">! been computed. if nrmom < momcom or ksave = 1,</span>
- <a name="l04204"></a>04204 <span class="comment">! the Chebyshev moments for the interval (a,b)</span>
- <a name="l04205"></a>04205 <span class="comment">! have already been computed and stored, otherwise</span>
- <a name="l04206"></a>04206 <span class="comment">! we compute them and we increase momcom.</span>
- <a name="l04207"></a>04207 <span class="comment">!</span>
- <a name="l04208"></a>04208 <span class="comment">! chebmo - real</span>
- <a name="l04209"></a>04209 <span class="comment">! array of dimension at least (maxp1,25) containing</span>
- <a name="l04210"></a>04210 <span class="comment">! the modified Chebyshev moments for the first momcom</span>
- <a name="l04211"></a>04211 <span class="comment">! interval lengths</span>
- <a name="l04212"></a>04212 <span class="comment">!</span>
- <a name="l04213"></a>04213 <span class="comment">! Local parameters:</span>
- <a name="l04214"></a>04214 <span class="comment">!</span>
- <a name="l04215"></a>04215 <span class="comment">! maxp1 gives an upper bound</span>
- <a name="l04216"></a>04216 <span class="comment">! on the number of Chebyshev moments which can be</span>
- <a name="l04217"></a>04217 <span class="comment">! computed, i.e. for the interval (bb-aa), ...,</span>
- <a name="l04218"></a>04218 <span class="comment">! (bb-aa)/2**(maxp1-2).</span>
- <a name="l04219"></a>04219 <span class="comment">! should this number be altered, the first dimension of</span>
- <a name="l04220"></a>04220 <span class="comment">! chebmo needs to be adapted.</span>
- <a name="l04221"></a>04221 <span class="comment">!</span>
- <a name="l04222"></a>04222 <span class="comment">! x contains the values cos(k*pi/24)</span>
- <a name="l04223"></a>04223 <span class="comment">! k = 1, ...,11, to be used for the Chebyshev expansion of f</span>
- <a name="l04224"></a>04224 <span class="comment">!</span>
- <a name="l04225"></a>04225 <span class="comment">! centr - mid point of the integration interval</span>
- <a name="l04226"></a>04226 <span class="comment">! hlgth - half length of the integration interval</span>
- <a name="l04227"></a>04227 <span class="comment">! fval - value of the function f at the points</span>
- <a name="l04228"></a>04228 <span class="comment">! (b-a)*0.5*cos(k*pi/12) + (b+a)*0.5</span>
- <a name="l04229"></a>04229 <span class="comment">! k = 0, ...,24</span>
- <a name="l04230"></a>04230 <span class="comment">! cheb12 - coefficients of the Chebyshev series expansion</span>
- <a name="l04231"></a>04231 <span class="comment">! of degree 12, for the function f, in the</span>
- <a name="l04232"></a>04232 <span class="comment">! interval (a,b)</span>
- <a name="l04233"></a>04233 <span class="comment">! cheb24 - coefficients of the Chebyshev series expansion</span>
- <a name="l04234"></a>04234 <span class="comment">! of degree 24, for the function f, in the</span>
- <a name="l04235"></a>04235 <span class="comment">! interval (a,b)</span>
- <a name="l04236"></a>04236 <span class="comment">! resc12 - approximation to the integral of</span>
- <a name="l04237"></a>04237 <span class="comment">! cos(0.5*(b-a)*omega*x)*f(0.5*(b-a)*x+0.5*(b+a))</span>
- <a name="l04238"></a>04238 <span class="comment">! over (-1,+1), using the Chebyshev series</span>
- <a name="l04239"></a>04239 <span class="comment">! expansion of degree 12</span>
- <a name="l04240"></a>04240 <span class="comment">! resc24 - approximation to the same integral, using the</span>
- <a name="l04241"></a>04241 <span class="comment">! Chebyshev series expansion of degree 24</span>
- <a name="l04242"></a>04242 <span class="comment">! ress12 - the analogue of resc12 for the sine</span>
- <a name="l04243"></a>04243 <span class="comment">! ress24 - the analogue of resc24 for the sine</span>
- <a name="l04244"></a>04244 <span class="comment">!</span>
- <a name="l04245"></a>04245 <span class="keyword">implicit none</span>
- <a name="l04246"></a>04246
- <a name="l04247"></a>04247 <span class="keywordtype">integer</span> maxp1
- <a name="l04248"></a>04248
- <a name="l04249"></a>04249 <span class="keywordtype">real</span> a
- <a name="l04250"></a>04250 <span class="keywordtype">real</span> abserr
- <a name="l04251"></a>04251 <span class="keywordtype">real</span> ac
- <a name="l04252"></a>04252 <span class="keywordtype">real</span> an
- <a name="l04253"></a>04253 <span class="keywordtype">real</span> an2
- <a name="l04254"></a>04254 <span class="keywordtype">real</span> as
- <a name="l04255"></a>04255 <span class="keywordtype">real</span> asap
- <a name="l04256"></a>04256 <span class="keywordtype">real</span> ass
- <a name="l04257"></a>04257 <span class="keywordtype">real</span> b
- <a name="l04258"></a>04258 <span class="keywordtype">real</span> centr
- <a name="l04259"></a>04259 <span class="keywordtype">real</span> chebmo(maxp1,25)
- <a name="l04260"></a>04260 <span class="keywordtype">real</span> cheb12(13)
- <a name="l04261"></a>04261 <span class="keywordtype">real</span> cheb24(25)
- <a name="l04262"></a>04262 <span class="keywordtype">real</span> conc
- <a name="l04263"></a>04263 <span class="keywordtype">real</span> cons
- <a name="l04264"></a>04264 <span class="keywordtype">real</span> cospar
- <a name="l04265"></a>04265 <span class="keywordtype">real</span> d(28)
- <a name="l04266"></a>04266 <span class="keywordtype">real</span> d1(28)
- <a name="l04267"></a>04267 <span class="keywordtype">real</span> d2(28)
- <a name="l04268"></a>04268 <span class="keywordtype">real</span> d3(28)
- <a name="l04269"></a>04269 <span class="keywordtype">real</span> estc
- <a name="l04270"></a>04270 <span class="keywordtype">real</span> ests
- <a name="l04271"></a>04271 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l04272"></a>04272 <span class="keywordtype">real</span> fval(25)
- <a name="l04273"></a>04273 <span class="keywordtype">real</span> hlgth
- <a name="l04274"></a>04274 <span class="keywordtype">integer</span> i
- <a name="l04275"></a>04275 <span class="keywordtype">integer</span> integr
- <a name="l04276"></a>04276 <span class="keywordtype">integer</span> isym
- <a name="l04277"></a>04277 <span class="keywordtype">integer</span> j
- <a name="l04278"></a>04278 <span class="keywordtype">integer</span> k
- <a name="l04279"></a>04279 <span class="keywordtype">integer</span> ksave
- <a name="l04280"></a>04280 <span class="keywordtype">integer</span> m
- <a name="l04281"></a>04281 <span class="keywordtype">integer</span> momcom
- <a name="l04282"></a>04282 <span class="keywordtype">integer</span> neval
- <a name="l04283"></a>04283 <span class="keywordtype">integer</span>, <span class="keywordtype">parameter</span> :: nmac = 28
- <a name="l04284"></a>04284 <span class="keywordtype">integer</span> noeq1
- <a name="l04285"></a>04285 <span class="keywordtype">integer</span> noequ
- <a name="l04286"></a>04286 <span class="keywordtype">integer</span> nrmom
- <a name="l04287"></a>04287 <span class="keywordtype">real</span> omega
- <a name="l04288"></a>04288 <span class="keywordtype">real</span> parint
- <a name="l04289"></a>04289 <span class="keywordtype">real</span> par2
- <a name="l04290"></a>04290 <span class="keywordtype">real</span> par22
- <a name="l04291"></a>04291 <span class="keywordtype">real</span> p2
- <a name="l04292"></a>04292 <span class="keywordtype">real</span> p3
- <a name="l04293"></a>04293 <span class="keywordtype">real</span> p4
- <a name="l04294"></a>04294 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: qwgto
- <a name="l04295"></a>04295 <span class="keywordtype">real</span> resabs
- <a name="l04296"></a>04296 <span class="keywordtype">real</span> resasc
- <a name="l04297"></a>04297 <span class="keywordtype">real</span> resc12
- <a name="l04298"></a>04298 <span class="keywordtype">real</span> resc24
- <a name="l04299"></a>04299 <span class="keywordtype">real</span> ress12
- <a name="l04300"></a>04300 <span class="keywordtype">real</span> ress24
- <a name="l04301"></a>04301 <span class="keywordtype">real</span> result
- <a name="l04302"></a>04302 <span class="keywordtype">real</span> sinpar
- <a name="l04303"></a>04303 <span class="keywordtype">real</span> v(28)
- <a name="l04304"></a>04304 <span class="keywordtype">real</span>, <span class="keywordtype">dimension ( 11 )</span> :: x = (/
- <a name="l04305"></a>04305 9.914448613738104e-01, 9.659258262890683e-01,
- <a name="l04306"></a>04306 9.238795325112868e-01, 8.660254037844386e-01,
- <a name="l04307"></a>04307 7.933533402912352e-01, 7.071067811865475e-01,
- <a name="l04308"></a>04308 6.087614290087206e-01, 5.000000000000000e-01,
- <a name="l04309"></a>04309 3.826834323650898e-01, 2.588190451025208e-01,
- <a name="l04310"></a>04310 1.305261922200516e-01 /)
- <a name="l04311"></a>04311
- <a name="l04312"></a>04312 centr = 5.0e-01 * ( b + a )
- <a name="l04313"></a>04313 hlgth = 5.0e-01 * ( b - a )
- <a name="l04314"></a>04314 parint = omega * hlgth
- <a name="l04315"></a>04315 <span class="comment">!</span>
- <a name="l04316"></a>04316 <span class="comment">! Compute the integral using the 15-point Gauss-Kronrod</span>
- <a name="l04317"></a>04317 <span class="comment">! formula if the value of the parameter in the integrand</span>
- <a name="l04318"></a>04318 <span class="comment">! is small or if the length of the integration interval</span>
- <a name="l04319"></a>04319 <span class="comment">! is less than (bb-aa)/2**(maxp1-2), where (aa,bb) is the</span>
- <a name="l04320"></a>04320 <span class="comment">! original integration interval.</span>
- <a name="l04321"></a>04321 <span class="comment">!</span>
- <a name="l04322"></a>04322 <span class="keyword">if</span> ( abs ( parint ) <= 2.0e+00 ) <span class="keyword">then</span>
- <a name="l04323"></a>04323
- <a name="l04324"></a>04324 call <a class="code" href="quadpack_8f90.html#a0c083838940925726abd5bc85fa29587">qk15w </a>( f, qwgto, omega, p2, p3, p4, integr, a, b, result, &
- <a name="l04325"></a>04325 abserr, resabs, resasc )
- <a name="l04326"></a>04326
- <a name="l04327"></a>04327 neval = 15
- <a name="l04328"></a>04328 return
- <a name="l04329"></a>04329
- <a name="l04330"></a>04330 <span class="keyword">end if</span>
- <a name="l04331"></a>04331 <span class="comment">!</span>
- <a name="l04332"></a>04332 <span class="comment">! Compute the integral using the generalized clenshaw-curtis method.</span>
- <a name="l04333"></a>04333 <span class="comment">!</span>
- <a name="l04334"></a>04334 conc = hlgth * cos(centr*omega)
- <a name="l04335"></a>04335 cons = hlgth * sin(centr*omega)
- <a name="l04336"></a>04336 resasc = huge ( resasc )
- <a name="l04337"></a>04337 neval = 25
- <a name="l04338"></a>04338 <span class="comment">!</span>
- <a name="l04339"></a>04339 <span class="comment">! Check whether the Chebyshev moments for this interval</span>
- <a name="l04340"></a>04340 <span class="comment">! have already been computed.</span>
- <a name="l04341"></a>04341 <span class="comment">!</span>
- <a name="l04342"></a>04342 <span class="keyword">if</span> ( nrmom < momcom .or. ksave == 1 ) <span class="keyword">then</span>
- <a name="l04343"></a>04343 go to 140
- <a name="l04344"></a>04344 <span class="keyword">end if</span>
- <a name="l04345"></a>04345 <span class="comment">!</span>
- <a name="l04346"></a>04346 <span class="comment">! Compute a new set of Chebyshev moments.</span>
- <a name="l04347"></a>04347 <span class="comment">!</span>
- <a name="l04348"></a>04348 m = momcom + 1
- <a name="l04349"></a>04349 par2 = parint * parint
- <a name="l04350"></a>04350 par22 = par2 + 2.0e+00
- <a name="l04351"></a>04351 sinpar = sin(parint)
- <a name="l04352"></a>04352 cospar = cos(parint)
- <a name="l04353"></a>04353 <span class="comment">!</span>
- <a name="l04354"></a>04354 <span class="comment">! Compute the Chebyshev moments with respect to cosine.</span>
- <a name="l04355"></a>04355 <span class="comment">!</span>
- <a name="l04356"></a>04356 v(1) = 2.0e+00 * sinpar / parint
- <a name="l04357"></a>04357 v(2) = (8.0e+00*cospar+(par2+par2-8.0e+00)*sinpar/ parint)/par2
- <a name="l04358"></a>04358 v(3) = (3.2e+01*(par2-1.2e+01)*cospar+(2.0e+00* &
- <a name="l04359"></a>04359 ((par2-8.0e+01)*par2+1.92e+02)*sinpar)/ &
- <a name="l04360"></a>04360 parint)/(par2*par2)
- <a name="l04361"></a>04361 ac = 8.0e+00*cospar
- <a name="l04362"></a>04362 as = 2.4e+01*parint*sinpar
- <a name="l04363"></a>04363
- <a name="l04364"></a>04364 <span class="keyword">if</span> ( abs ( parint ) > 2.4e+01 ) <span class="keyword">then</span>
- <a name="l04365"></a>04365 go to 70
- <a name="l04366"></a>04366 <span class="keyword">end if</span>
- <a name="l04367"></a>04367 <span class="comment">!</span>
- <a name="l04368"></a>04368 <span class="comment">! Compute the Chebyshev moments as the solutions of a boundary value </span>
- <a name="l04369"></a>04369 <span class="comment">! problem with one initial value (v(3)) and one end value computed</span>
- <a name="l04370"></a>04370 <span class="comment">! using an asymptotic formula.</span>
- <a name="l04371"></a>04371 <span class="comment">!</span>
- <a name="l04372"></a>04372 noequ = nmac-3
- <a name="l04373"></a>04373 noeq1 = noequ-1
- <a name="l04374"></a>04374 an = 6.0e+00
- <a name="l04375"></a>04375
- <a name="l04376"></a>04376 <span class="keyword">do</span> k = 1, noeq1
- <a name="l04377"></a>04377 an2 = an*an
- <a name="l04378"></a>04378 d(k) = -2.0e+00*(an2-4.0e+00) * (par22-an2-an2)
- <a name="l04379"></a>04379 d2(k) = (an-1.0e+00)*(an-2.0e+00) * par2
- <a name="l04380"></a>04380 d1(k) = (an+3.0e+00)*(an+4.0e+00) * par2
- <a name="l04381"></a>04381 v(k+3) = as-(an2-4.0e+00) * ac
- <a name="l04382"></a>04382 an = an+2.0e+00
- <a name="l04383"></a>04383 <span class="keyword">end do</span>
- <a name="l04384"></a>04384
- <a name="l04385"></a>04385 an2 = an*an
- <a name="l04386"></a>04386 d(noequ) = -2.0e+00*(an2-4.0e+00) * (par22-an2-an2)
- <a name="l04387"></a>04387 v(noequ+3) = as - ( an2 - 4.0e+00 ) * ac
- <a name="l04388"></a>04388 v(4) = v(4) - 5.6e+01 * par2 * v(3)
- <a name="l04389"></a>04389 ass = parint * sinpar
- <a name="l04390"></a>04390 asap = (((((2.10e+02*par2-1.0e+00)*cospar-(1.05e+02*par2 &
- <a name="l04391"></a>04391 -6.3e+01)*ass)/an2-(1.0e+00-1.5e+01*par2)*cospar &
- <a name="l04392"></a>04392 +1.5e+01*ass)/an2-cospar+3.0e+00*ass)/an2-cospar)/an2
- <a name="l04393"></a>04393 v(noequ+3) = v(noequ+3)-2.0e+00*asap*par2*(an-1.0e+00)* &
- <a name="l04394"></a>04394 (an-2.0e+00)
- <a name="l04395"></a>04395 <span class="comment">!</span>
- <a name="l04396"></a>04396 <span class="comment">! Solve the tridiagonal system by means of Gaussian</span>
- <a name="l04397"></a>04397 <span class="comment">! elimination with partial pivoting.</span>
- <a name="l04398"></a>04398 <span class="comment">!</span>
- <a name="l04399"></a>04399 d3(1:noequ) = 0.0e+00
- <a name="l04400"></a>04400
- <a name="l04401"></a>04401 d2(noequ) = 0.0e+00
- <a name="l04402"></a>04402
- <a name="l04403"></a>04403 <span class="keyword">do</span> i = 1, noeq1
- <a name="l04404"></a>04404
- <a name="l04405"></a>04405 <span class="keyword">if</span> ( abs(d1(i)) > abs(d(i)) ) <span class="keyword">then</span>
- <a name="l04406"></a>04406 an = d1(i)
- <a name="l04407"></a>04407 d1(i) = d(i)
- <a name="l04408"></a>04408 d(i) = an
- <a name="l04409"></a>04409 an = d2(i)
- <a name="l04410"></a>04410 d2(i) = d(i+1)
- <a name="l04411"></a>04411 d(i+1) = an
- <a name="l04412"></a>04412 d3(i) = d2(i+1)
- <a name="l04413"></a>04413 d2(i+1) = 0.0e+00
- <a name="l04414"></a>04414 an = v(i+4)
- <a name="l04415"></a>04415 v(i+4) = v(i+3)
- <a name="l04416"></a>04416 v(i+3) = an
- <a name="l04417"></a>04417 <span class="keyword">end if</span>
- <a name="l04418"></a>04418
- <a name="l04419"></a>04419 d(i+1) = d(i+1)-d2(i)*d1(i)/d(i)
- <a name="l04420"></a>04420 d2(i+1) = d2(i+1)-d3(i)*d1(i)/d(i)
- <a name="l04421"></a>04421 v(i+4) = v(i+4)-v(i+3)*d1(i)/d(i)
- <a name="l04422"></a>04422
- <a name="l04423"></a>04423 <span class="keyword">end do</span>
- <a name="l04424"></a>04424
- <a name="l04425"></a>04425 v(noequ+3) = v(noequ+3) / d(noequ)
- <a name="l04426"></a>04426 v(noequ+2) = (v(noequ+2)-d2(noeq1)*v(noequ+3))/d(noeq1)
- <a name="l04427"></a>04427
- <a name="l04428"></a>04428 <span class="keyword">do</span> i = 2, noeq1
- <a name="l04429"></a>04429 k = noequ-i
- <a name="l04430"></a>04430 v(k+3) = (v(k+3)-d3(k)*v(k+5)-d2(k)*v(k+4))/d(k)
- <a name="l04431"></a>04431 <span class="keyword">end do</span>
- <a name="l04432"></a>04432
- <a name="l04433"></a>04433 go to 90
- <a name="l04434"></a>04434 <span class="comment">!</span>
- <a name="l04435"></a>04435 <span class="comment">! Compute the Chebyshev moments by means of forward recursion</span>
- <a name="l04436"></a>04436 <span class="comment">!</span>
- <a name="l04437"></a>04437 70 continue
- <a name="l04438"></a>04438
- <a name="l04439"></a>04439 an = 4.0e+00
- <a name="l04440"></a>04440
- <a name="l04441"></a>04441 <span class="keyword">do</span> i = 4, 13
- <a name="l04442"></a>04442 an2 = an*an
- <a name="l04443"></a>04443 v(i) = ((an2-4.0e+00)*(2.0e+00*(par22-an2-an2)*v(i-1)-ac) &
- <a name="l04444"></a>04444 +as-par2*(an+1.0e+00)*(an+2.0e+00)*v(i-2))/ &
- <a name="l04445"></a>04445 (par2*(an-1.0e+00)*(an-2.0e+00))
- <a name="l04446"></a>04446 an = an+2.0e+00
- <a name="l04447"></a>04447 <span class="keyword">end do</span>
- <a name="l04448"></a>04448
- <a name="l04449"></a>04449 90 continue
- <a name="l04450"></a>04450
- <a name="l04451"></a>04451 <span class="keyword">do</span> j = 1, 13
- <a name="l04452"></a>04452 chebmo(m,2*j-1) = v(j)
- <a name="l04453"></a>04453 <span class="keyword">end do</span>
- <a name="l04454"></a>04454 <span class="comment">!</span>
- <a name="l04455"></a>04455 <span class="comment">! Compute the Chebyshev moments with respect to sine.</span>
- <a name="l04456"></a>04456 <span class="comment">!</span>
- <a name="l04457"></a>04457 v(1) = 2.0e+00*(sinpar-parint*cospar)/par2
- <a name="l04458"></a>04458 v(2) = (1.8e+01-4.8e+01/par2)*sinpar/par2 &
- <a name="l04459"></a>04459 +(-2.0e+00+4.8e+01/par2)*cospar/parint
- <a name="l04460"></a>04460 ac = -2.4e+01*parint*cospar
- <a name="l04461"></a>04461 as = -8.0e+00*sinpar
- <a name="l04462"></a>04462 chebmo(m,2) = v(1)
- <a name="l04463"></a>04463 chebmo(m,4) = v(2)
- <a name="l04464"></a>04464
- <a name="l04465"></a>04465 <span class="keyword">if</span> ( abs(parint) <= 2.4e+01 ) <span class="keyword">then</span>
- <a name="l04466"></a>04466
- <a name="l04467"></a>04467 <span class="keyword">do</span> k = 3, 12
- <a name="l04468"></a>04468 an = k
- <a name="l04469"></a>04469 chebmo(m,2*k) = -sinpar/(an*(2.0e+00*an-2.0e+00)) &
- <a name="l04470"></a>04470 -2.5e-01*parint*(v(k+1)/an-v(k)/(an-1.0e+00))
- <a name="l04471"></a>04471 <span class="keyword">end do</span>
- <a name="l04472"></a>04472 <span class="comment">!</span>
- <a name="l04473"></a>04473 <span class="comment">! Compute the Chebyshev moments by means of forward recursion.</span>
- <a name="l04474"></a>04474 <span class="comment">!</span>
- <a name="l04475"></a>04475 <span class="keyword">else</span>
- <a name="l04476"></a>04476
- <a name="l04477"></a>04477 an = 3.0e+00
- <a name="l04478"></a>04478
- <a name="l04479"></a>04479 <span class="keyword">do</span> i = 3, 12
- <a name="l04480"></a>04480 an2 = an*an
- <a name="l04481"></a>04481 v(i) = ((an2-4.0e+00)*(2.0e+00*(par22-an2-an2)*v(i-1)+as) &
- <a name="l04482"></a>04482 +ac-par2*(an+1.0e+00)*(an+2.0e+00)*v(i-2)) &
- <a name="l04483"></a>04483 /(par2*(an-1.0e+00)*(an-2.0e+00))
- <a name="l04484"></a>04484 an = an+2.0e+00
- <a name="l04485"></a>04485 chebmo(m,2*i) = v(i)
- <a name="l04486"></a>04486 <span class="keyword">end do</span>
- <a name="l04487"></a>04487
- <a name="l04488"></a>04488 <span class="keyword">end if</span>
- <a name="l04489"></a>04489
- <a name="l04490"></a>04490 140 continue
- <a name="l04491"></a>04491
- <a name="l04492"></a>04492 <span class="keyword">if</span> ( nrmom < momcom ) <span class="keyword">then</span>
- <a name="l04493"></a>04493 m = nrmom + 1
- <a name="l04494"></a>04494 <span class="keyword">end if</span>
- <a name="l04495"></a>04495
- <a name="l04496"></a>04496 <span class="keyword">if</span> ( momcom < maxp1 - 1 .and. nrmom >= momcom ) <span class="keyword">then</span>
- <a name="l04497"></a>04497 momcom = momcom + 1
- <a name="l04498"></a>04498 <span class="keyword">end if</span>
- <a name="l04499"></a>04499 <span class="comment">!</span>
- <a name="l04500"></a>04500 <span class="comment">! Compute the coefficients of the Chebyshev expansions</span>
- <a name="l04501"></a>04501 <span class="comment">! of degrees 12 and 24 of the function F.</span>
- <a name="l04502"></a>04502 <span class="comment">!</span>
- <a name="l04503"></a>04503 fval(1) = 5.0e-01 * f(centr+hlgth)
- <a name="l04504"></a>04504 fval(13) = f(centr)
- <a name="l04505"></a>04505 fval(25) = 5.0e-01 * f(centr-hlgth)
- <a name="l04506"></a>04506
- <a name="l04507"></a>04507 <span class="keyword">do</span> i = 2, 12
- <a name="l04508"></a>04508 isym = 26-i
- <a name="l04509"></a>04509 fval(i) = f(hlgth*x(i-1)+centr)
- <a name="l04510"></a>04510 fval(isym) = f(centr-hlgth*x(i-1))
- <a name="l04511"></a>04511 <span class="keyword">end do</span>
- <a name="l04512"></a>04512
- <a name="l04513"></a>04513 call <a class="code" href="quadpack_8f90.html#ad5beefcfdb335ea68ccf8397536c8c36">qcheb </a>( x, fval, cheb12, cheb24 )
- <a name="l04514"></a>04514 <span class="comment">!</span>
- <a name="l04515"></a>04515 <span class="comment">! Compute the integral and error estimates.</span>
- <a name="l04516"></a>04516 <span class="comment">!</span>
- <a name="l04517"></a>04517 resc12 = cheb12(13) * chebmo(m,13)
- <a name="l04518"></a>04518 ress12 = 0.0e+00
- <a name="l04519"></a>04519 estc = abs ( cheb24(25)*chebmo(m,25))+abs((cheb12(13)- &
- <a name="l04520"></a>04520 cheb24(13))*chebmo(m,13) )
- <a name="l04521"></a>04521 ests = 0.0e+00
- <a name="l04522"></a>04522 k = 11
- <a name="l04523"></a>04523
- <a name="l04524"></a>04524 <span class="keyword">do</span> j = 1, 6
- <a name="l04525"></a>04525 resc12 = resc12+cheb12(k)*chebmo(m,k)
- <a name="l04526"></a>04526 ress12 = ress12+cheb12(k+1)*chebmo(m,k+1)
- <a name="l04527"></a>04527 estc = estc+abs((cheb12(k)-cheb24(k))*chebmo(m,k))
- <a name="l04528"></a>04528 ests = ests+abs((cheb12(k+1)-cheb24(k+1))*chebmo(m,k+1))
- <a name="l04529"></a>04529 k = k-2
- <a name="l04530"></a>04530 <span class="keyword">end do</span>
- <a name="l04531"></a>04531
- <a name="l04532"></a>04532 resc24 = cheb24(25)*chebmo(m,25)
- <a name="l04533"></a>04533 ress24 = 0.0e+00
- <a name="l04534"></a>04534 resabs = abs(cheb24(25))
- <a name="l04535"></a>04535 k = 23
- <a name="l04536"></a>04536
- <a name="l04537"></a>04537 <span class="keyword">do</span> j = 1, 12
- <a name="l04538"></a>04538
- <a name="l04539"></a>04539 resc24 = resc24+cheb24(k)*chebmo(m,k)
- <a name="l04540"></a>04540 ress24 = ress24+cheb24(k+1)*chebmo(m,k+1)
- <a name="l04541"></a>04541 resabs = resabs+abs(cheb24(k))+abs(cheb24(k+1))
- <a name="l04542"></a>04542
- <a name="l04543"></a>04543 <span class="keyword">if</span> ( j <= 5 ) <span class="keyword">then</span>
- <a name="l04544"></a>04544 estc = estc+abs(cheb24(k)*chebmo(m,k))
- <a name="l04545"></a>04545 ests = ests+abs(cheb24(k+1)*chebmo(m,k+1))
- <a name="l04546"></a>04546 <span class="keyword">end if</span>
- <a name="l04547"></a>04547
- <a name="l04548"></a>04548 k = k-2
- <a name="l04549"></a>04549
- <a name="l04550"></a>04550 <span class="keyword">end do</span>
- <a name="l04551"></a>04551
- <a name="l04552"></a>04552 resabs = resabs * abs ( hlgth )
- <a name="l04553"></a>04553
- <a name="l04554"></a>04554 <span class="keyword">if</span> ( integr == 1 ) <span class="keyword">then</span>
- <a name="l04555"></a>04555 result = conc * resc24-cons*ress24
- <a name="l04556"></a>04556 abserr = abs ( conc * estc ) + abs ( cons * ests )
- <a name="l04557"></a>04557 <span class="keyword">else</span>
- <a name="l04558"></a>04558 result = conc*ress24+cons*resc24
- <a name="l04559"></a>04559 abserr = abs(conc*ests)+abs(cons*estc)
- <a name="l04560"></a>04560 <span class="keyword">end if</span>
- <a name="l04561"></a>04561
- <a name="l04562"></a>04562 return
- <a name="l04563"></a>04563 <span class="keyword">end</span>
- <a name="l04564"></a><a class="code" href="quadpack_8f90.html#a034546450320f53f05096bc12af9b5bc">04564</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#a034546450320f53f05096bc12af9b5bc">qc25s</a> ( f, a, b, bl, br, alfa, beta, ri, rj, rg, rh, result, &
- <a name="l04565"></a>04565 abserr, resasc, integr, neval )
- <a name="l04566"></a>04566
- <a name="l04567"></a>04567 <span class="comment">!*****************************************************************************80</span>
- <a name="l04568"></a>04568 <span class="comment">!</span>
- <a name="l04569"></a>04569 <span class="comment">!! QC25S returns rules for algebraico-logarithmic end point singularities.</span>
- <a name="l04570"></a>04570 <span class="comment">!</span>
- <a name="l04571"></a>04571 <span class="comment">! Discussion:</span>
- <a name="l04572"></a>04572 <span class="comment">!</span>
- <a name="l04573"></a>04573 <span class="comment">! This routine computes </span>
- <a name="l04574"></a>04574 <span class="comment">! i = integral of F(X) * W(X) over (bl,br), </span>
- <a name="l04575"></a>04575 <span class="comment">! with error estimate, where the weight function W(X) has a singular</span>
- <a name="l04576"></a>04576 <span class="comment">! behavior of algebraico-logarithmic type at the points</span>
- <a name="l04577"></a>04577 <span class="comment">! a and/or b. </span>
- <a name="l04578"></a>04578 <span class="comment">!</span>
- <a name="l04579"></a>04579 <span class="comment">! The interval (bl,br) is a subinterval of (a,b).</span>
- <a name="l04580"></a>04580 <span class="comment">!</span>
- <a name="l04581"></a>04581 <span class="comment">! Author:</span>
- <a name="l04582"></a>04582 <span class="comment">!</span>
- <a name="l04583"></a>04583 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l04584"></a>04584 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l04585"></a>04585 <span class="comment">!</span>
- <a name="l04586"></a>04586 <span class="comment">! Reference:</span>
- <a name="l04587"></a>04587 <span class="comment">!</span>
- <a name="l04588"></a>04588 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l04589"></a>04589 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l04590"></a>04590 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l04591"></a>04591 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l04592"></a>04592 <span class="comment">!</span>
- <a name="l04593"></a>04593 <span class="comment">! Parameters:</span>
- <a name="l04594"></a>04594 <span class="comment">!</span>
- <a name="l04595"></a>04595 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l04596"></a>04596 <span class="comment">! function f ( x )</span>
- <a name="l04597"></a>04597 <span class="comment">! real f</span>
- <a name="l04598"></a>04598 <span class="comment">! real x</span>
- <a name="l04599"></a>04599 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l04600"></a>04600 <span class="comment">!</span>
- <a name="l04601"></a>04601 <span class="comment">! Input, real A, B, the limits of integration.</span>
- <a name="l04602"></a>04602 <span class="comment">!</span>
- <a name="l04603"></a>04603 <span class="comment">! Input, real BL, BR, the lower and upper limits of integration.</span>
- <a name="l04604"></a>04604 <span class="comment">! A <= BL < BR <= B.</span>
- <a name="l04605"></a>04605 <span class="comment">!</span>
- <a name="l04606"></a>04606 <span class="comment">! Input, real ALFA, BETA, parameters in the weight function.</span>
- <a name="l04607"></a>04607 <span class="comment">!</span>
- <a name="l04608"></a>04608 <span class="comment">! Input, real RI(25), RJ(25), RG(25), RH(25), modified Chebyshev moments </span>
- <a name="l04609"></a>04609 <span class="comment">! for the application of the generalized Clenshaw-Curtis method,</span>
- <a name="l04610"></a>04610 <span class="comment">! computed in QMOMO.</span>
- <a name="l04611"></a>04611 <span class="comment">!</span>
- <a name="l04612"></a>04612 <span class="comment">! Output, real RESULT, the estimated value of the integral, computed by </span>
- <a name="l04613"></a>04613 <span class="comment">! using a generalized clenshaw-curtis method if b1 = a or br = b.</span>
- <a name="l04614"></a>04614 <span class="comment">! In all other cases the 15-point Kronrod rule is applied, obtained by</span>
- <a name="l04615"></a>04615 <span class="comment">! optimal addition of abscissae to the 7-point Gauss rule.</span>
- <a name="l04616"></a>04616 <span class="comment">!</span>
- <a name="l04617"></a>04617 <span class="comment">! Output, real ABSERR, an estimate of || I - RESULT ||.</span>
- <a name="l04618"></a>04618 <span class="comment">!</span>
- <a name="l04619"></a>04619 <span class="comment">! Output, real RESASC, approximation to the integral of abs(F*W-I/(B-A)).</span>
- <a name="l04620"></a>04620 <span class="comment">!</span>
- <a name="l04621"></a>04621 <span class="comment">! Input, integer INTEGR, determines the weight function</span>
- <a name="l04622"></a>04622 <span class="comment">! 1, w(x) = (x-a)**alfa*(b-x)**beta</span>
- <a name="l04623"></a>04623 <span class="comment">! 2, w(x) = (x-a)**alfa*(b-x)**beta*log(x-a)</span>
- <a name="l04624"></a>04624 <span class="comment">! 3, w(x) = (x-a)**alfa*(b-x)**beta*log(b-x)</span>
- <a name="l04625"></a>04625 <span class="comment">! 4, w(x) = (x-a)**alfa*(b-x)**beta*log(x-a)*log(b-x)</span>
- <a name="l04626"></a>04626 <span class="comment">!</span>
- <a name="l04627"></a>04627 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l04628"></a>04628 <span class="comment">!</span>
- <a name="l04629"></a>04629 <span class="comment">! Local Parameters:</span>
- <a name="l04630"></a>04630 <span class="comment">!</span>
- <a name="l04631"></a>04631 <span class="comment">! fval - value of the function f at the points</span>
- <a name="l04632"></a>04632 <span class="comment">! (br-bl)*0.5*cos(k*pi/24)+(br+bl)*0.5</span>
- <a name="l04633"></a>04633 <span class="comment">! k = 0, ..., 24</span>
- <a name="l04634"></a>04634 <span class="comment">! cheb12 - coefficients of the Chebyshev series expansion</span>
- <a name="l04635"></a>04635 <span class="comment">! of degree 12, for the function f, in the interval</span>
- <a name="l04636"></a>04636 <span class="comment">! (bl,br)</span>
- <a name="l04637"></a>04637 <span class="comment">! cheb24 - coefficients of the Chebyshev series expansion</span>
- <a name="l04638"></a>04638 <span class="comment">! of degree 24, for the function f, in the interval</span>
- <a name="l04639"></a>04639 <span class="comment">! (bl,br)</span>
- <a name="l04640"></a>04640 <span class="comment">! res12 - approximation to the integral obtained from cheb12</span>
- <a name="l04641"></a>04641 <span class="comment">! res24 - approximation to the integral obtained from cheb24</span>
- <a name="l04642"></a>04642 <span class="comment">! qwgts - external function subprogram defining the four</span>
- <a name="l04643"></a>04643 <span class="comment">! possible weight functions</span>
- <a name="l04644"></a>04644 <span class="comment">! hlgth - half-length of the interval (bl,br)</span>
- <a name="l04645"></a>04645 <span class="comment">! centr - mid point of the interval (bl,br)</span>
- <a name="l04646"></a>04646 <span class="comment">!</span>
- <a name="l04647"></a>04647 <span class="comment">! the vector x contains the values cos(k*pi/24)</span>
- <a name="l04648"></a>04648 <span class="comment">! k = 1, ..., 11, to be used for the computation of the</span>
- <a name="l04649"></a>04649 <span class="comment">! Chebyshev series expansion of f.</span>
- <a name="l04650"></a>04650 <span class="comment">!</span>
- <a name="l04651"></a>04651 <span class="keyword">implicit none</span>
- <a name="l04652"></a>04652
- <a name="l04653"></a>04653 <span class="keywordtype">real</span> a
- <a name="l04654"></a>04654 <span class="keywordtype">real</span> abserr
- <a name="l04655"></a>04655 <span class="keywordtype">real</span> alfa
- <a name="l04656"></a>04656 <span class="keywordtype">real</span> b
- <a name="l04657"></a>04657 <span class="keywordtype">real</span> beta
- <a name="l04658"></a>04658 <span class="keywordtype">real</span> bl
- <a name="l04659"></a>04659 <span class="keywordtype">real</span> br
- <a name="l04660"></a>04660 <span class="keywordtype">real</span> centr
- <a name="l04661"></a>04661 <span class="keywordtype">real</span> cheb12(13)
- <a name="l04662"></a>04662 <span class="keywordtype">real</span> cheb24(25)
- <a name="l04663"></a>04663 <span class="keywordtype">real</span> dc
- <a name="l04664"></a>04664 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l04665"></a>04665 <span class="keywordtype">real</span> factor
- <a name="l04666"></a>04666 <span class="keywordtype">real</span> fix
- <a name="l04667"></a>04667 <span class="keywordtype">real</span> fval(25)
- <a name="l04668"></a>04668 <span class="keywordtype">real</span> hlgth
- <a name="l04669"></a>04669 <span class="keywordtype">integer</span> i
- <a name="l04670"></a>04670 <span class="keywordtype">integer</span> integr
- <a name="l04671"></a>04671 <span class="keywordtype">integer</span> isym
- <a name="l04672"></a>04672 <span class="keywordtype">integer</span> neval
- <a name="l04673"></a>04673 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: qwgts
- <a name="l04674"></a>04674 <span class="keywordtype">real</span> resabs
- <a name="l04675"></a>04675 <span class="keywordtype">real</span> resasc
- <a name="l04676"></a>04676 <span class="keywordtype">real</span> result
- <a name="l04677"></a>04677 <span class="keywordtype">real</span> res12
- <a name="l04678"></a>04678 <span class="keywordtype">real</span> res24
- <a name="l04679"></a>04679 <span class="keywordtype">real</span> rg(25)
- <a name="l04680"></a>04680 <span class="keywordtype">real</span> rh(25)
- <a name="l04681"></a>04681 <span class="keywordtype">real</span> ri(25)
- <a name="l04682"></a>04682 <span class="keywordtype">real</span> rj(25)
- <a name="l04683"></a>04683 <span class="keywordtype">real</span> u
- <a name="l04684"></a>04684 <span class="keywordtype">real</span>, <span class="keywordtype">dimension ( 11 )</span> :: x = (/
- <a name="l04685"></a>04685 9.914448613738104e-01, 9.659258262890683e-01,
- <a name="l04686"></a>04686 9.238795325112868e-01, 8.660254037844386e-01,
- <a name="l04687"></a>04687 7.933533402912352e-01, 7.071067811865475e-01,
- <a name="l04688"></a>04688 6.087614290087206e-01, 5.000000000000000e-01,
- <a name="l04689"></a>04689 3.826834323650898e-01, 2.588190451025208e-01,
- <a name="l04690"></a>04690 1.305261922200516e-01 /)
- <a name="l04691"></a>04691
- <a name="l04692"></a>04692 neval = 25
- <a name="l04693"></a>04693
- <a name="l04694"></a>04694 <span class="keyword">if</span> ( bl == a .and. (alfa /= 0.0e+00 .or. integr == 2 .or. integr == 4)) <span class="keyword">then</span>
- <a name="l04695"></a>04695 go to 10
- <a name="l04696"></a>04696 <span class="keyword">end if</span>
- <a name="l04697"></a>04697
- <a name="l04698"></a>04698 <span class="keyword">if</span> ( br == b .and. (beta /= 0.0e+00 .or. integr == 3 .or. integr == 4)) &
- <a name="l04699"></a>04699 go to 140
- <a name="l04700"></a>04700 <span class="comment">!</span>
- <a name="l04701"></a>04701 <span class="comment">! If a > bl and b < br, apply the 15-point Gauss-Kronrod scheme.</span>
- <a name="l04702"></a>04702 <span class="comment">!</span>
- <a name="l04703"></a>04703 call <a class="code" href="quadpack_8f90.html#a0c083838940925726abd5bc85fa29587">qk15w </a>( f, qwgts, a, b, alfa, beta, integr, bl, br, result, abserr, &
- <a name="l04704"></a>04704 resabs, resasc )
- <a name="l04705"></a>04705
- <a name="l04706"></a>04706 neval = 15
- <a name="l04707"></a>04707 return
- <a name="l04708"></a>04708 <span class="comment">!</span>
- <a name="l04709"></a>04709 <span class="comment">! This part of the program is executed only if a = bl.</span>
- <a name="l04710"></a>04710 <span class="comment">!</span>
- <a name="l04711"></a>04711 <span class="comment">! Compute the Chebyshev series expansion of the function</span>
- <a name="l04712"></a>04712 <span class="comment">! f1 = (0.5*(b+b-br-a)-0.5*(br-a)*x)**beta*f(0.5*(br-a)*x+0.5*(br+a))</span>
- <a name="l04713"></a>04713 <span class="comment">!</span>
- <a name="l04714"></a>04714 10 continue
- <a name="l04715"></a>04715
- <a name="l04716"></a>04716 hlgth = 5.0e-01*(br-bl)
- <a name="l04717"></a>04717 centr = 5.0e-01*(br+bl)
- <a name="l04718"></a>04718 fix = b-centr
- <a name="l04719"></a>04719 fval(1) = 5.0e-01*f(hlgth+centr)*(fix-hlgth)**beta
- <a name="l04720"></a>04720 fval(13) = f(centr)*(fix**beta)
- <a name="l04721"></a>04721 fval(25) = 5.0e-01*f(centr-hlgth)*(fix+hlgth)**beta
- <a name="l04722"></a>04722
- <a name="l04723"></a>04723 <span class="keyword">do</span> i = 2, 12
- <a name="l04724"></a>04724 u = hlgth*x(i-1)
- <a name="l04725"></a>04725 isym = 26-i
- <a name="l04726"></a>04726 fval(i) = f(u+centr)*(fix-u)**beta
- <a name="l04727"></a>04727 fval(isym) = f(centr-u)*(fix+u)**beta
- <a name="l04728"></a>04728 <span class="keyword">end do</span>
- <a name="l04729"></a>04729
- <a name="l04730"></a>04730 factor = hlgth**(alfa+1.0e+00)
- <a name="l04731"></a>04731 result = 0.0e+00
- <a name="l04732"></a>04732 abserr = 0.0e+00
- <a name="l04733"></a>04733 res12 = 0.0e+00
- <a name="l04734"></a>04734 res24 = 0.0e+00
- <a name="l04735"></a>04735
- <a name="l04736"></a>04736 <span class="keyword">if</span> ( integr > 2 ) go to 70
- <a name="l04737"></a>04737
- <a name="l04738"></a>04738 call <a class="code" href="quadpack_8f90.html#ad5beefcfdb335ea68ccf8397536c8c36">qcheb </a>( x, fval, cheb12, cheb24 )
- <a name="l04739"></a>04739 <span class="comment">!</span>
- <a name="l04740"></a>04740 <span class="comment">! integr = 1 (or 2)</span>
- <a name="l04741"></a>04741 <span class="comment">!</span>
- <a name="l04742"></a>04742 <span class="keyword">do</span> i = 1, 13
- <a name="l04743"></a>04743 res12 = res12+cheb12(i)*ri(i)
- <a name="l04744"></a>04744 res24 = res24+cheb24(i)*ri(i)
- <a name="l04745"></a>04745 <span class="keyword">end do</span>
- <a name="l04746"></a>04746
- <a name="l04747"></a>04747 <span class="keyword">do</span> i = 14, 25
- <a name="l04748"></a>04748 res24 = res24 + cheb24(i) * ri(i)
- <a name="l04749"></a>04749 <span class="keyword">end do</span>
- <a name="l04750"></a>04750
- <a name="l04751"></a>04751 <span class="keyword">if</span> ( integr == 1 ) go to 130
- <a name="l04752"></a>04752 <span class="comment">!</span>
- <a name="l04753"></a>04753 <span class="comment">! integr = 2</span>
- <a name="l04754"></a>04754 <span class="comment">!</span>
- <a name="l04755"></a>04755 dc = log ( br - bl )
- <a name="l04756"></a>04756 result = res24 * dc
- <a name="l04757"></a>04757 abserr = abs((res24-res12)*dc)
- <a name="l04758"></a>04758 res12 = 0.0e+00
- <a name="l04759"></a>04759 res24 = 0.0e+00
- <a name="l04760"></a>04760
- <a name="l04761"></a>04761 <span class="keyword">do</span> i = 1, 13
- <a name="l04762"></a>04762 res12 = res12+cheb12(i)*rg(i)
- <a name="l04763"></a>04763 res24 = res24+cheb24(i)*rg(i)
- <a name="l04764"></a>04764 <span class="keyword">end do</span>
- <a name="l04765"></a>04765
- <a name="l04766"></a>04766 <span class="keyword">do</span> i = 14, 25
- <a name="l04767"></a>04767 res24 = res24+cheb24(i)*rg(i)
- <a name="l04768"></a>04768 <span class="keyword">end do</span>
- <a name="l04769"></a>04769
- <a name="l04770"></a>04770 go to 130
- <a name="l04771"></a>04771 <span class="comment">!</span>
- <a name="l04772"></a>04772 <span class="comment">! Compute the Chebyshev series expansion of the function</span>
- <a name="l04773"></a>04773 <span class="comment">! F4 = f1*log(0.5*(b+b-br-a)-0.5*(br-a)*x)</span>
- <a name="l04774"></a>04774 <span class="comment">!</span>
- <a name="l04775"></a>04775 70 continue
- <a name="l04776"></a>04776
- <a name="l04777"></a>04777 fval(1) = fval(1) * log ( fix - hlgth )
- <a name="l04778"></a>04778 fval(13) = fval(13) * log ( fix )
- <a name="l04779"></a>04779 fval(25) = fval(25) * log ( fix + hlgth )
- <a name="l04780"></a>04780
- <a name="l04781"></a>04781 <span class="keyword">do</span> i = 2, 12
- <a name="l04782"></a>04782 u = hlgth*x(i-1)
- <a name="l04783"></a>04783 isym = 26-i
- <a name="l04784"></a>04784 fval(i) = fval(i) * log ( fix - u )
- <a name="l04785"></a>04785 fval(isym) = fval(isym) * log ( fix + u )
- <a name="l04786"></a>04786 <span class="keyword">end do</span>
- <a name="l04787"></a>04787
- <a name="l04788"></a>04788 call <a class="code" href="quadpack_8f90.html#ad5beefcfdb335ea68ccf8397536c8c36">qcheb </a>( x, fval, cheb12, cheb24 )
- <a name="l04789"></a>04789 <span class="comment">!</span>
- <a name="l04790"></a>04790 <span class="comment">! integr = 3 (or 4)</span>
- <a name="l04791"></a>04791 <span class="comment">!</span>
- <a name="l04792"></a>04792 <span class="keyword">do</span> i = 1, 13
- <a name="l04793"></a>04793 res12 = res12+cheb12(i)*ri(i)
- <a name="l04794"></a>04794 res24 = res24+cheb24(i)*ri(i)
- <a name="l04795"></a>04795 <span class="keyword">end do</span>
- <a name="l04796"></a>04796
- <a name="l04797"></a>04797 <span class="keyword">do</span> i = 14, 25
- <a name="l04798"></a>04798 res24 = res24+cheb24(i)*ri(i)
- <a name="l04799"></a>04799 <span class="keyword">end do</span>
- <a name="l04800"></a>04800
- <a name="l04801"></a>04801 <span class="keyword">if</span> ( integr == 3 ) <span class="keyword">then</span>
- <a name="l04802"></a>04802 go to 130
- <a name="l04803"></a>04803 <span class="keyword">end if</span>
- <a name="l04804"></a>04804 <span class="comment">!</span>
- <a name="l04805"></a>04805 <span class="comment">! integr = 4</span>
- <a name="l04806"></a>04806 <span class="comment">!</span>
- <a name="l04807"></a>04807 dc = log ( br - bl )
- <a name="l04808"></a>04808 result = res24*dc
- <a name="l04809"></a>04809 abserr = abs((res24-res12)*dc)
- <a name="l04810"></a>04810 res12 = 0.0e+00
- <a name="l04811"></a>04811 res24 = 0.0e+00
- <a name="l04812"></a>04812
- <a name="l04813"></a>04813 <span class="keyword">do</span> i = 1, 13
- <a name="l04814"></a>04814 res12 = res12+cheb12(i)*rg(i)
- <a name="l04815"></a>04815 res24 = res24+cheb24(i)*rg(i)
- <a name="l04816"></a>04816 <span class="keyword">end do</span>
- <a name="l04817"></a>04817
- <a name="l04818"></a>04818 <span class="keyword">do</span> i = 14, 25
- <a name="l04819"></a>04819 res24 = res24+cheb24(i)*rg(i)
- <a name="l04820"></a>04820 <span class="keyword">end do</span>
- <a name="l04821"></a>04821
- <a name="l04822"></a>04822 130 continue
- <a name="l04823"></a>04823
- <a name="l04824"></a>04824 result = (result+res24)*factor
- <a name="l04825"></a>04825 abserr = (abserr+abs(res24-res12))*factor
- <a name="l04826"></a>04826 go to 270
- <a name="l04827"></a>04827 <span class="comment">!</span>
- <a name="l04828"></a>04828 <span class="comment">! This part of the program is executed only if b = br.</span>
- <a name="l04829"></a>04829 <span class="comment">!</span>
- <a name="l04830"></a>04830 <span class="comment">! Compute the Chebyshev series expansion of the function</span>
- <a name="l04831"></a>04831 <span class="comment">! f2 = (0.5*(b+bl-a-a)+0.5*(b-bl)*x)**alfa*f(0.5*(b-bl)*x+0.5*(b+bl))</span>
- <a name="l04832"></a>04832 <span class="comment">!</span>
- <a name="l04833"></a>04833 140 continue
- <a name="l04834"></a>04834
- <a name="l04835"></a>04835 hlgth = 5.0e-01*(br-bl)
- <a name="l04836"></a>04836 centr = 5.0e-01*(br+bl)
- <a name="l04837"></a>04837 fix = centr-a
- <a name="l04838"></a>04838 fval(1) = 5.0e-01*f(hlgth+centr)*(fix+hlgth)**alfa
- <a name="l04839"></a>04839 fval(13) = f(centr)*(fix**alfa)
- <a name="l04840"></a>04840 fval(25) = 5.0e-01*f(centr-hlgth)*(fix-hlgth)**alfa
- <a name="l04841"></a>04841
- <a name="l04842"></a>04842 <span class="keyword">do</span> i = 2, 12
- <a name="l04843"></a>04843 u = hlgth*x(i-1)
- <a name="l04844"></a>04844 isym = 26-i
- <a name="l04845"></a>04845 fval(i) = f(u+centr)*(fix+u)**alfa
- <a name="l04846"></a>04846 fval(isym) = f(centr-u)*(fix-u)**alfa
- <a name="l04847"></a>04847 <span class="keyword">end do</span>
- <a name="l04848"></a>04848
- <a name="l04849"></a>04849 factor = hlgth**(beta+1.0e+00)
- <a name="l04850"></a>04850 result = 0.0e+00
- <a name="l04851"></a>04851 abserr = 0.0e+00
- <a name="l04852"></a>04852 res12 = 0.0e+00
- <a name="l04853"></a>04853 res24 = 0.0e+00
- <a name="l04854"></a>04854
- <a name="l04855"></a>04855 <span class="keyword">if</span> ( integr == 2 .or. integr == 4 ) <span class="keyword">then</span>
- <a name="l04856"></a>04856 go to 200
- <a name="l04857"></a>04857 <span class="keyword">end if</span>
- <a name="l04858"></a>04858 <span class="comment">!</span>
- <a name="l04859"></a>04859 <span class="comment">! integr = 1 (or 3)</span>
- <a name="l04860"></a>04860 <span class="comment">!</span>
- <a name="l04861"></a>04861 call <a class="code" href="quadpack_8f90.html#ad5beefcfdb335ea68ccf8397536c8c36">qcheb </a>( x, fval, cheb12, cheb24 )
- <a name="l04862"></a>04862
- <a name="l04863"></a>04863 <span class="keyword">do</span> i = 1, 13
- <a name="l04864"></a>04864 res12 = res12+cheb12(i)*rj(i)
- <a name="l04865"></a>04865 res24 = res24+cheb24(i)*rj(i)
- <a name="l04866"></a>04866 <span class="keyword">end do</span>
- <a name="l04867"></a>04867
- <a name="l04868"></a>04868 <span class="keyword">do</span> i = 14, 25
- <a name="l04869"></a>04869 res24 = res24+cheb24(i)*rj(i)
- <a name="l04870"></a>04870 <span class="keyword">end do</span>
- <a name="l04871"></a>04871
- <a name="l04872"></a>04872 <span class="keyword">if</span> ( integr == 1 ) go to 260
- <a name="l04873"></a>04873 <span class="comment">!</span>
- <a name="l04874"></a>04874 <span class="comment">! integr = 3</span>
- <a name="l04875"></a>04875 <span class="comment">!</span>
- <a name="l04876"></a>04876 dc = log ( br - bl )
- <a name="l04877"></a>04877 result = res24*dc
- <a name="l04878"></a>04878 abserr = abs((res24-res12)*dc)
- <a name="l04879"></a>04879 res12 = 0.0e+00
- <a name="l04880"></a>04880 res24 = 0.0e+00
- <a name="l04881"></a>04881
- <a name="l04882"></a>04882 <span class="keyword">do</span> i = 1, 13
- <a name="l04883"></a>04883 res12 = res12+cheb12(i)*rh(i)
- <a name="l04884"></a>04884 res24 = res24+cheb24(i)*rh(i)
- <a name="l04885"></a>04885 <span class="keyword">end do</span>
- <a name="l04886"></a>04886
- <a name="l04887"></a>04887 <span class="keyword">do</span> i = 14, 25
- <a name="l04888"></a>04888 res24 = res24+cheb24(i)*rh(i)
- <a name="l04889"></a>04889 <span class="keyword">end do</span>
- <a name="l04890"></a>04890
- <a name="l04891"></a>04891 go to 260
- <a name="l04892"></a>04892 <span class="comment">!</span>
- <a name="l04893"></a>04893 <span class="comment">! Compute the Chebyshev series expansion of the function</span>
- <a name="l04894"></a>04894 <span class="comment">! f3 = f2*log(0.5*(b-bl)*x+0.5*(b+bl-a-a))</span>
- <a name="l04895"></a>04895 <span class="comment">!</span>
- <a name="l04896"></a>04896 200 continue
- <a name="l04897"></a>04897
- <a name="l04898"></a>04898 fval(1) = fval(1) * log ( hlgth + fix )
- <a name="l04899"></a>04899 fval(13) = fval(13) * log ( fix )
- <a name="l04900"></a>04900 fval(25) = fval(25) * log ( fix - hlgth )
- <a name="l04901"></a>04901
- <a name="l04902"></a>04902 <span class="keyword">do</span> i = 2, 12
- <a name="l04903"></a>04903 u = hlgth*x(i-1)
- <a name="l04904"></a>04904 isym = 26-i
- <a name="l04905"></a>04905 fval(i) = fval(i) * log(u+fix)
- <a name="l04906"></a>04906 fval(isym) = fval(isym) * log(fix-u)
- <a name="l04907"></a>04907 <span class="keyword">end do</span>
- <a name="l04908"></a>04908
- <a name="l04909"></a>04909 call <a class="code" href="quadpack_8f90.html#ad5beefcfdb335ea68ccf8397536c8c36">qcheb </a>( x, fval, cheb12, cheb24 )
- <a name="l04910"></a>04910 <span class="comment">!</span>
- <a name="l04911"></a>04911 <span class="comment">! integr = 2 (or 4)</span>
- <a name="l04912"></a>04912 <span class="comment">!</span>
- <a name="l04913"></a>04913 <span class="keyword">do</span> i = 1, 13
- <a name="l04914"></a>04914 res12 = res12+cheb12(i)*rj(i)
- <a name="l04915"></a>04915 res24 = res24+cheb24(i)*rj(i)
- <a name="l04916"></a>04916 <span class="keyword">end do</span>
- <a name="l04917"></a>04917
- <a name="l04918"></a>04918 <span class="keyword">do</span> i = 14, 25
- <a name="l04919"></a>04919 res24 = res24+cheb24(i)*rj(i)
- <a name="l04920"></a>04920 <span class="keyword">end do</span>
- <a name="l04921"></a>04921
- <a name="l04922"></a>04922 <span class="keyword">if</span> ( integr == 2 ) go to 260
- <a name="l04923"></a>04923
- <a name="l04924"></a>04924 dc = log(br-bl)
- <a name="l04925"></a>04925 result = res24*dc
- <a name="l04926"></a>04926 abserr = abs((res24-res12)*dc)
- <a name="l04927"></a>04927 res12 = 0.0e+00
- <a name="l04928"></a>04928 res24 = 0.0e+00
- <a name="l04929"></a>04929 <span class="comment">!</span>
- <a name="l04930"></a>04930 <span class="comment">! integr = 4</span>
- <a name="l04931"></a>04931 <span class="comment">!</span>
- <a name="l04932"></a>04932 <span class="keyword">do</span> i = 1, 13
- <a name="l04933"></a>04933 res12 = res12+cheb12(i)*rh(i)
- <a name="l04934"></a>04934 res24 = res24+cheb24(i)*rh(i)
- <a name="l04935"></a>04935 <span class="keyword">end do</span>
- <a name="l04936"></a>04936
- <a name="l04937"></a>04937 <span class="keyword">do</span> i = 14, 25
- <a name="l04938"></a>04938 res24 = res24+cheb24(i)*rh(i)
- <a name="l04939"></a>04939 <span class="keyword">end do</span>
- <a name="l04940"></a>04940
- <a name="l04941"></a>04941 260 continue
- <a name="l04942"></a>04942
- <a name="l04943"></a>04943 result = (result+res24)*factor
- <a name="l04944"></a>04944 abserr = (abserr+abs(res24-res12))*factor
- <a name="l04945"></a>04945
- <a name="l04946"></a>04946 270 continue
- <a name="l04947"></a>04947
- <a name="l04948"></a>04948 return
- <a name="l04949"></a>04949 <span class="keyword">end</span>
- <a name="l04950"></a><a class="code" href="quadpack_8f90.html#ad5beefcfdb335ea68ccf8397536c8c36">04950</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#ad5beefcfdb335ea68ccf8397536c8c36">qcheb</a> ( x, fval, cheb12, cheb24 )
- <a name="l04951"></a>04951
- <a name="l04952"></a>04952 <span class="comment">!*****************************************************************************80</span>
- <a name="l04953"></a>04953 <span class="comment">!</span>
- <a name="l04954"></a>04954 <span class="comment">!! QCHEB computes the Chebyshev series expansion.</span>
- <a name="l04955"></a>04955 <span class="comment">!</span>
- <a name="l04956"></a>04956 <span class="comment">! Discussion:</span>
- <a name="l04957"></a>04957 <span class="comment">!</span>
- <a name="l04958"></a>04958 <span class="comment">! This routine computes the Chebyshev series expansion</span>
- <a name="l04959"></a>04959 <span class="comment">! of degrees 12 and 24 of a function using a fast Fourier transform method</span>
- <a name="l04960"></a>04960 <span class="comment">!</span>
- <a name="l04961"></a>04961 <span class="comment">! f(x) = sum(k=1, ...,13) (cheb12(k)*t(k-1,x)),</span>
- <a name="l04962"></a>04962 <span class="comment">! f(x) = sum(k=1, ...,25) (cheb24(k)*t(k-1,x)),</span>
- <a name="l04963"></a>04963 <span class="comment">!</span>
- <a name="l04964"></a>04964 <span class="comment">! where T(K,X) is the Chebyshev polynomial of degree K.</span>
- <a name="l04965"></a>04965 <span class="comment">!</span>
- <a name="l04966"></a>04966 <span class="comment">! Author:</span>
- <a name="l04967"></a>04967 <span class="comment">!</span>
- <a name="l04968"></a>04968 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l04969"></a>04969 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l04970"></a>04970 <span class="comment">!</span>
- <a name="l04971"></a>04971 <span class="comment">! Reference:</span>
- <a name="l04972"></a>04972 <span class="comment">!</span>
- <a name="l04973"></a>04973 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l04974"></a>04974 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l04975"></a>04975 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l04976"></a>04976 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l04977"></a>04977 <span class="comment">!</span>
- <a name="l04978"></a>04978 <span class="comment">! Parameters:</span>
- <a name="l04979"></a>04979 <span class="comment">!</span>
- <a name="l04980"></a>04980 <span class="comment">! Input, real X(11), contains the values of COS(K*PI/24), for K = 1 to 11.</span>
- <a name="l04981"></a>04981 <span class="comment">!</span>
- <a name="l04982"></a>04982 <span class="comment">! Input/output, real FVAL(25), the function values at the points</span>
- <a name="l04983"></a>04983 <span class="comment">! (b+a+(b-a)*cos(k*pi/24))/2, k = 0, ...,24, where (a,b) is the </span>
- <a name="l04984"></a>04984 <span class="comment">! approximation interval. FVAL(1) and FVAL(25) are divided by two</span>
- <a name="l04985"></a>04985 <span class="comment">! These values are destroyed at output.</span>
- <a name="l04986"></a>04986 <span class="comment">!</span>
- <a name="l04987"></a>04987 <span class="comment">! Output, real CHEB12(13), the Chebyshev coefficients for degree 12.</span>
- <a name="l04988"></a>04988 <span class="comment">!</span>
- <a name="l04989"></a>04989 <span class="comment">! Output, real CHEB24(25), the Chebyshev coefficients for degree 24.</span>
- <a name="l04990"></a>04990 <span class="comment">!</span>
- <a name="l04991"></a>04991 <span class="keyword">implicit none</span>
- <a name="l04992"></a>04992
- <a name="l04993"></a>04993 <span class="keywordtype">real</span> alam
- <a name="l04994"></a>04994 <span class="keywordtype">real</span> alam1
- <a name="l04995"></a>04995 <span class="keywordtype">real</span> alam2
- <a name="l04996"></a>04996 <span class="keywordtype">real</span> cheb12(13)
- <a name="l04997"></a>04997 <span class="keywordtype">real</span> cheb24(25)
- <a name="l04998"></a>04998 <span class="keywordtype">real</span> fval(25)
- <a name="l04999"></a>04999 <span class="keywordtype">integer</span> i
- <a name="l05000"></a>05000 <span class="keywordtype">integer</span> j
- <a name="l05001"></a>05001 <span class="keywordtype">real</span> part1
- <a name="l05002"></a>05002 <span class="keywordtype">real</span> part2
- <a name="l05003"></a>05003 <span class="keywordtype">real</span> part3
- <a name="l05004"></a>05004 <span class="keywordtype">real</span> v(12)
- <a name="l05005"></a>05005 <span class="keywordtype">real</span> x(11)
- <a name="l05006"></a>05006
- <a name="l05007"></a>05007 <span class="keyword">do</span> i = 1, 12
- <a name="l05008"></a>05008 j = 26-i
- <a name="l05009"></a>05009 v(i) = fval(i)-fval(j)
- <a name="l05010"></a>05010 fval(i) = fval(i)+fval(j)
- <a name="l05011"></a>05011 <span class="keyword">end do</span>
- <a name="l05012"></a>05012
- <a name="l05013"></a>05013 alam1 = v(1)-v(9)
- <a name="l05014"></a>05014 alam2 = x(6)*(v(3)-v(7)-v(11))
- <a name="l05015"></a>05015 cheb12(4) = alam1+alam2
- <a name="l05016"></a>05016 cheb12(10) = alam1-alam2
- <a name="l05017"></a>05017 alam1 = v(2)-v(8)-v(10)
- <a name="l05018"></a>05018 alam2 = v(4)-v(6)-v(12)
- <a name="l05019"></a>05019 alam = x(3)*alam1+x(9)*alam2
- <a name="l05020"></a>05020 cheb24(4) = cheb12(4)+alam
- <a name="l05021"></a>05021 cheb24(22) = cheb12(4)-alam
- <a name="l05022"></a>05022 alam = x(9)*alam1-x(3)*alam2
- <a name="l05023"></a>05023 cheb24(10) = cheb12(10)+alam
- <a name="l05024"></a>05024 cheb24(16) = cheb12(10)-alam
- <a name="l05025"></a>05025 part1 = x(4)*v(5)
- <a name="l05026"></a>05026 part2 = x(8)*v(9)
- <a name="l05027"></a>05027 part3 = x(6)*v(7)
- <a name="l05028"></a>05028 alam1 = v(1)+part1+part2
- <a name="l05029"></a>05029 alam2 = x(2)*v(3)+part3+x(10)*v(11)
- <a name="l05030"></a>05030 cheb12(2) = alam1+alam2
- <a name="l05031"></a>05031 cheb12(12) = alam1-alam2
- <a name="l05032"></a>05032 alam = x(1)*v(2)+x(3)*v(4)+x(5)*v(6)+x(7)*v(8) &
- <a name="l05033"></a>05033 +x(9)*v(10)+x(11)*v(12)
- <a name="l05034"></a>05034 cheb24(2) = cheb12(2)+alam
- <a name="l05035"></a>05035 cheb24(24) = cheb12(2)-alam
- <a name="l05036"></a>05036 alam = x(11)*v(2)-x(9)*v(4)+x(7)*v(6)-x(5)*v(8) &
- <a name="l05037"></a>05037 +x(3)*v(10)-x(1)*v(12)
- <a name="l05038"></a>05038 cheb24(12) = cheb12(12)+alam
- <a name="l05039"></a>05039 cheb24(14) = cheb12(12)-alam
- <a name="l05040"></a>05040 alam1 = v(1)-part1+part2
- <a name="l05041"></a>05041 alam2 = x(10)*v(3)-part3+x(2)*v(11)
- <a name="l05042"></a>05042 cheb12(6) = alam1+alam2
- <a name="l05043"></a>05043 cheb12(8) = alam1-alam2
- <a name="l05044"></a>05044 alam = x(5)*v(2)-x(9)*v(4)-x(1)*v(6) &
- <a name="l05045"></a>05045 -x(11)*v(8)+x(3)*v(10)+x(7)*v(12)
- <a name="l05046"></a>05046 cheb24(6) = cheb12(6)+alam
- <a name="l05047"></a>05047 cheb24(20) = cheb12(6)-alam
- <a name="l05048"></a>05048 alam = x(7)*v(2)-x(3)*v(4)-x(11)*v(6)+x(1)*v(8) &
- <a name="l05049"></a>05049 -x(9)*v(10)-x(5)*v(12)
- <a name="l05050"></a>05050 cheb24(8) = cheb12(8)+alam
- <a name="l05051"></a>05051 cheb24(18) = cheb12(8)-alam
- <a name="l05052"></a>05052
- <a name="l05053"></a>05053 <span class="keyword">do</span> i = 1, 6
- <a name="l05054"></a>05054 j = 14-i
- <a name="l05055"></a>05055 v(i) = fval(i)-fval(j)
- <a name="l05056"></a>05056 fval(i) = fval(i)+fval(j)
- <a name="l05057"></a>05057 <span class="keyword">end do</span>
- <a name="l05058"></a>05058
- <a name="l05059"></a>05059 alam1 = v(1)+x(8)*v(5)
- <a name="l05060"></a>05060 alam2 = x(4)*v(3)
- <a name="l05061"></a>05061 cheb12(3) = alam1+alam2
- <a name="l05062"></a>05062 cheb12(11) = alam1-alam2
- <a name="l05063"></a>05063 cheb12(7) = v(1)-v(5)
- <a name="l05064"></a>05064 alam = x(2)*v(2)+x(6)*v(4)+x(10)*v(6)
- <a name="l05065"></a>05065 cheb24(3) = cheb12(3)+alam
- <a name="l05066"></a>05066 cheb24(23) = cheb12(3)-alam
- <a name="l05067"></a>05067 alam = x(6)*(v(2)-v(4)-v(6))
- <a name="l05068"></a>05068 cheb24(7) = cheb12(7)+alam
- <a name="l05069"></a>05069 cheb24(19) = cheb12(7)-alam
- <a name="l05070"></a>05070 alam = x(10)*v(2)-x(6)*v(4)+x(2)*v(6)
- <a name="l05071"></a>05071 cheb24(11) = cheb12(11)+alam
- <a name="l05072"></a>05072 cheb24(15) = cheb12(11)-alam
- <a name="l05073"></a>05073
- <a name="l05074"></a>05074 <span class="keyword">do</span> i = 1, 3
- <a name="l05075"></a>05075 j = 8-i
- <a name="l05076"></a>05076 v(i) = fval(i)-fval(j)
- <a name="l05077"></a>05077 fval(i) = fval(i)+fval(j)
- <a name="l05078"></a>05078 <span class="keyword">end do</span>
- <a name="l05079"></a>05079
- <a name="l05080"></a>05080 cheb12(5) = v(1)+x(8)*v(3)
- <a name="l05081"></a>05081 cheb12(9) = fval(1)-x(8)*fval(3)
- <a name="l05082"></a>05082 alam = x(4)*v(2)
- <a name="l05083"></a>05083 cheb24(5) = cheb12(5)+alam
- <a name="l05084"></a>05084 cheb24(21) = cheb12(5)-alam
- <a name="l05085"></a>05085 alam = x(8)*fval(2)-fval(4)
- <a name="l05086"></a>05086 cheb24(9) = cheb12(9)+alam
- <a name="l05087"></a>05087 cheb24(17) = cheb12(9)-alam
- <a name="l05088"></a>05088 cheb12(1) = fval(1)+fval(3)
- <a name="l05089"></a>05089 alam = fval(2)+fval(4)
- <a name="l05090"></a>05090 cheb24(1) = cheb12(1)+alam
- <a name="l05091"></a>05091 cheb24(25) = cheb12(1)-alam
- <a name="l05092"></a>05092 cheb12(13) = v(1)-v(3)
- <a name="l05093"></a>05093 cheb24(13) = cheb12(13)
- <a name="l05094"></a>05094 alam = 1.0e+00/6.0e+00
- <a name="l05095"></a>05095
- <a name="l05096"></a>05096 <span class="keyword">do</span> i = 2, 12
- <a name="l05097"></a>05097 cheb12(i) = cheb12(i)*alam
- <a name="l05098"></a>05098 <span class="keyword">end do</span>
- <a name="l05099"></a>05099
- <a name="l05100"></a>05100 alam = 5.0e-01*alam
- <a name="l05101"></a>05101 cheb12(1) = cheb12(1)*alam
- <a name="l05102"></a>05102 cheb12(13) = cheb12(13)*alam
- <a name="l05103"></a>05103
- <a name="l05104"></a>05104 <span class="keyword">do</span> i = 2, 24
- <a name="l05105"></a>05105 cheb24(i) = cheb24(i)*alam
- <a name="l05106"></a>05106 <span class="keyword">end do</span>
- <a name="l05107"></a>05107
- <a name="l05108"></a>05108 cheb24(1) = 0.5E+00 * alam*cheb24(1)
- <a name="l05109"></a>05109 cheb24(25) = 0.5E+00 * alam*cheb24(25)
- <a name="l05110"></a>05110
- <a name="l05111"></a>05111 return
- <a name="l05112"></a>05112 <span class="keyword">end</span>
- <a name="l05113"></a><a class="code" href="quadpack_8f90.html#a5a75101d080f224c63adde98a0e64386">05113</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#a5a75101d080f224c63adde98a0e64386">qextr</a> ( n, epstab, result, abserr, res3la, nres )
- <a name="l05114"></a>05114
- <a name="l05115"></a>05115 <span class="comment">!*****************************************************************************80</span>
- <a name="l05116"></a>05116 <span class="comment">!</span>
- <a name="l05117"></a>05117 <span class="comment">!! QEXTR carries out the Epsilon extrapolation algorithm.</span>
- <a name="l05118"></a>05118 <span class="comment">!</span>
- <a name="l05119"></a>05119 <span class="comment">! Discussion:</span>
- <a name="l05120"></a>05120 <span class="comment">!</span>
- <a name="l05121"></a>05121 <span class="comment">! The routine determines the limit of a given sequence of approximations, </span>
- <a name="l05122"></a>05122 <span class="comment">! by means of the epsilon algorithm of P. Wynn. An estimate of the </span>
- <a name="l05123"></a>05123 <span class="comment">! absolute error is also given. The condensed epsilon table is computed.</span>
- <a name="l05124"></a>05124 <span class="comment">! Only those elements needed for the computation of the next diagonal</span>
- <a name="l05125"></a>05125 <span class="comment">! are preserved.</span>
- <a name="l05126"></a>05126 <span class="comment">!</span>
- <a name="l05127"></a>05127 <span class="comment">! Author:</span>
- <a name="l05128"></a>05128 <span class="comment">!</span>
- <a name="l05129"></a>05129 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l05130"></a>05130 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l05131"></a>05131 <span class="comment">!</span>
- <a name="l05132"></a>05132 <span class="comment">! Reference:</span>
- <a name="l05133"></a>05133 <span class="comment">!</span>
- <a name="l05134"></a>05134 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l05135"></a>05135 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l05136"></a>05136 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l05137"></a>05137 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l05138"></a>05138 <span class="comment">!</span>
- <a name="l05139"></a>05139 <span class="comment">! Parameters:</span>
- <a name="l05140"></a>05140 <span class="comment">!</span>
- <a name="l05141"></a>05141 <span class="comment">! Input, integer N, indicates the entry of EPSTAB which contains</span>
- <a name="l05142"></a>05142 <span class="comment">! the new element in the first column of the epsilon table.</span>
- <a name="l05143"></a>05143 <span class="comment">!</span>
- <a name="l05144"></a>05144 <span class="comment">! Input/output, real EPSTAB(52), the two lower diagonals of the triangular</span>
- <a name="l05145"></a>05145 <span class="comment">! epsilon table. The elements are numbered starting at the right-hand </span>
- <a name="l05146"></a>05146 <span class="comment">! corner of the triangle.</span>
- <a name="l05147"></a>05147 <span class="comment">!</span>
- <a name="l05148"></a>05148 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l05149"></a>05149 <span class="comment">!</span>
- <a name="l05150"></a>05150 <span class="comment">! Output, real ABSERR, estimate of the absolute error computed from</span>
- <a name="l05151"></a>05151 <span class="comment">! RESULT and the 3 previous results.</span>
- <a name="l05152"></a>05152 <span class="comment">!</span>
- <a name="l05153"></a>05153 <span class="comment">! ?, real RES3LA(3), the last 3 results.</span>
- <a name="l05154"></a>05154 <span class="comment">!</span>
- <a name="l05155"></a>05155 <span class="comment">! Input/output, integer NRES, the number of calls to the routine. This</span>
- <a name="l05156"></a>05156 <span class="comment">! should be zero on the first call, and is automatically updated</span>
- <a name="l05157"></a>05157 <span class="comment">! before return.</span>
- <a name="l05158"></a>05158 <span class="comment">!</span>
- <a name="l05159"></a>05159 <span class="comment">! Local Parameters:</span>
- <a name="l05160"></a>05160 <span class="comment">!</span>
- <a name="l05161"></a>05161 <span class="comment">! e0 - the 4 elements on which the</span>
- <a name="l05162"></a>05162 <span class="comment">! e1 computation of a new element in</span>
- <a name="l05163"></a>05163 <span class="comment">! e2 the epsilon table is based</span>
- <a name="l05164"></a>05164 <span class="comment">! e3 e0</span>
- <a name="l05165"></a>05165 <span class="comment">! e3 e1 new</span>
- <a name="l05166"></a>05166 <span class="comment">! e2</span>
- <a name="l05167"></a>05167 <span class="comment">! newelm - number of elements to be computed in the new</span>
- <a name="l05168"></a>05168 <span class="comment">! diagonal</span>
- <a name="l05169"></a>05169 <span class="comment">! error - error = abs(e1-e0)+abs(e2-e1)+abs(new-e2)</span>
- <a name="l05170"></a>05170 <span class="comment">! result - the element in the new diagonal with least value</span>
- <a name="l05171"></a>05171 <span class="comment">! of error</span>
- <a name="l05172"></a>05172 <span class="comment">! limexp is the maximum number of elements the epsilon table</span>
- <a name="l05173"></a>05173 <span class="comment">! can contain. if this number is reached, the upper diagonal</span>
- <a name="l05174"></a>05174 <span class="comment">! of the epsilon table is deleted.</span>
- <a name="l05175"></a>05175 <span class="comment">!</span>
- <a name="l05176"></a>05176 <span class="keyword">implicit none</span>
- <a name="l05177"></a>05177
- <a name="l05178"></a>05178 <span class="keywordtype">real</span> abserr
- <a name="l05179"></a>05179 <span class="keywordtype">real</span> delta1
- <a name="l05180"></a>05180 <span class="keywordtype">real</span> delta2
- <a name="l05181"></a>05181 <span class="keywordtype">real</span> delta3
- <a name="l05182"></a>05182 <span class="keywordtype">real</span> epsinf
- <a name="l05183"></a>05183 <span class="keywordtype">real</span> epstab(52)
- <a name="l05184"></a>05184 <span class="keywordtype">real</span> error
- <a name="l05185"></a>05185 <span class="keywordtype">real</span> err1
- <a name="l05186"></a>05186 <span class="keywordtype">real</span> err2
- <a name="l05187"></a>05187 <span class="keywordtype">real</span> err3
- <a name="l05188"></a>05188 <span class="keywordtype">real</span> e0
- <a name="l05189"></a>05189 <span class="keywordtype">real</span> e1
- <a name="l05190"></a>05190 <span class="keywordtype">real</span> e1abs
- <a name="l05191"></a>05191 <span class="keywordtype">real</span> e2
- <a name="l05192"></a>05192 <span class="keywordtype">real</span> e3
- <a name="l05193"></a>05193 <span class="keywordtype">integer</span> i
- <a name="l05194"></a>05194 <span class="keywordtype">integer</span> ib
- <a name="l05195"></a>05195 <span class="keywordtype">integer</span> ib2
- <a name="l05196"></a>05196 <span class="keywordtype">integer</span> ie
- <a name="l05197"></a>05197 <span class="keywordtype">integer</span> indx
- <a name="l05198"></a>05198 <span class="keywordtype">integer</span> k1
- <a name="l05199"></a>05199 <span class="keywordtype">integer</span> k2
- <a name="l05200"></a>05200 <span class="keywordtype">integer</span> k3
- <a name="l05201"></a>05201 <span class="keywordtype">integer</span> limexp
- <a name="l05202"></a>05202 <span class="keywordtype">integer</span> n
- <a name="l05203"></a>05203 <span class="keywordtype">integer</span> newelm
- <a name="l05204"></a>05204 <span class="keywordtype">integer</span> nres
- <a name="l05205"></a>05205 <span class="keywordtype">integer</span> num
- <a name="l05206"></a>05206 <span class="keywordtype">real</span> res
- <a name="l05207"></a>05207 <span class="keywordtype">real</span> result
- <a name="l05208"></a>05208 <span class="keywordtype">real</span> res3la(3)
- <a name="l05209"></a>05209 <span class="keywordtype">real</span> ss
- <a name="l05210"></a>05210 <span class="keywordtype">real</span> tol1
- <a name="l05211"></a>05211 <span class="keywordtype">real</span> tol2
- <a name="l05212"></a>05212 <span class="keywordtype">real</span> tol3
- <a name="l05213"></a>05213
- <a name="l05214"></a>05214 nres = nres+1
- <a name="l05215"></a>05215 abserr = huge ( abserr )
- <a name="l05216"></a>05216 result = epstab(n)
- <a name="l05217"></a>05217
- <a name="l05218"></a>05218 <span class="keyword">if</span> ( n < 3 ) <span class="keyword">then</span>
- <a name="l05219"></a>05219 abserr = max ( abserr,0.5e+00* epsilon ( result ) *abs(result))
- <a name="l05220"></a>05220 return
- <a name="l05221"></a>05221 <span class="keyword">end if</span>
- <a name="l05222"></a>05222
- <a name="l05223"></a>05223 limexp = 50
- <a name="l05224"></a>05224 epstab(n+2) = epstab(n)
- <a name="l05225"></a>05225 newelm = (n-1)/2
- <a name="l05226"></a>05226 epstab(n) = huge ( epstab(n) )
- <a name="l05227"></a>05227 num = n
- <a name="l05228"></a>05228 k1 = n
- <a name="l05229"></a>05229
- <a name="l05230"></a>05230 <span class="keyword">do</span> i = 1, newelm
- <a name="l05231"></a>05231
- <a name="l05232"></a>05232 k2 = k1-1
- <a name="l05233"></a>05233 k3 = k1-2
- <a name="l05234"></a>05234 res = epstab(k1+2)
- <a name="l05235"></a>05235 e0 = epstab(k3)
- <a name="l05236"></a>05236 e1 = epstab(k2)
- <a name="l05237"></a>05237 e2 = res
- <a name="l05238"></a>05238 e1abs = abs(e1)
- <a name="l05239"></a>05239 delta2 = e2-e1
- <a name="l05240"></a>05240 err2 = abs(delta2)
- <a name="l05241"></a>05241 tol2 = max ( abs(e2),e1abs)* epsilon ( e2 )
- <a name="l05242"></a>05242 delta3 = e1-e0
- <a name="l05243"></a>05243 err3 = abs(delta3)
- <a name="l05244"></a>05244 tol3 = max ( e1abs,abs(e0))* epsilon ( e0 )
- <a name="l05245"></a>05245 <span class="comment">!</span>
- <a name="l05246"></a>05246 <span class="comment">! If e0, e1 and e2 are equal to within machine accuracy, convergence </span>
- <a name="l05247"></a>05247 <span class="comment">! is assumed.</span>
- <a name="l05248"></a>05248 <span class="comment">!</span>
- <a name="l05249"></a>05249 <span class="keyword">if</span> ( err2 <= tol2 .and. err3 <= tol3 ) <span class="keyword">then</span>
- <a name="l05250"></a>05250 result = res
- <a name="l05251"></a>05251 abserr = err2+err3
- <a name="l05252"></a>05252 abserr = max ( abserr,0.5e+00* epsilon ( result ) *abs(result))
- <a name="l05253"></a>05253 return
- <a name="l05254"></a>05254 <span class="keyword">end if</span>
- <a name="l05255"></a>05255
- <a name="l05256"></a>05256 e3 = epstab(k1)
- <a name="l05257"></a>05257 epstab(k1) = e1
- <a name="l05258"></a>05258 delta1 = e1-e3
- <a name="l05259"></a>05259 err1 = abs(delta1)
- <a name="l05260"></a>05260 tol1 = max ( e1abs,abs(e3))* epsilon ( e3 )
- <a name="l05261"></a>05261 <span class="comment">!</span>
- <a name="l05262"></a>05262 <span class="comment">! If two elements are very close to each other, omit a part</span>
- <a name="l05263"></a>05263 <span class="comment">! of the table by adjusting the value of N.</span>
- <a name="l05264"></a>05264 <span class="comment">!</span>
- <a name="l05265"></a>05265 <span class="keyword">if</span> ( err1 <= tol1 .or. err2 <= tol2 .or. err3 <= tol3 ) go to 20
- <a name="l05266"></a>05266
- <a name="l05267"></a>05267 ss = 1.0e+00/delta1+1.0e+00/delta2-1.0e+00/delta3
- <a name="l05268"></a>05268 epsinf = abs ( ss*e1 )
- <a name="l05269"></a>05269 <span class="comment">!</span>
- <a name="l05270"></a>05270 <span class="comment">! Test to detect irregular behavior in the table, and</span>
- <a name="l05271"></a>05271 <span class="comment">! eventually omit a part of the table adjusting the value of N.</span>
- <a name="l05272"></a>05272 <span class="comment">!</span>
- <a name="l05273"></a>05273 <span class="keyword">if</span> ( epsinf > 1.0e-04 ) go to 30
- <a name="l05274"></a>05274
- <a name="l05275"></a>05275 20 continue
- <a name="l05276"></a>05276
- <a name="l05277"></a>05277 n = i+i-1
- <a name="l05278"></a>05278 exit
- <a name="l05279"></a>05279 <span class="comment">!</span>
- <a name="l05280"></a>05280 <span class="comment">! Compute a new element and eventually adjust the value of RESULT.</span>
- <a name="l05281"></a>05281 <span class="comment">!</span>
- <a name="l05282"></a>05282 30 continue
- <a name="l05283"></a>05283
- <a name="l05284"></a>05284 res = e1+1.0e+00/ss
- <a name="l05285"></a>05285 epstab(k1) = res
- <a name="l05286"></a>05286 k1 = k1-2
- <a name="l05287"></a>05287 error = err2+abs(res-e2)+err3
- <a name="l05288"></a>05288
- <a name="l05289"></a>05289 <span class="keyword">if</span> ( error <= abserr ) <span class="keyword">then</span>
- <a name="l05290"></a>05290 abserr = error
- <a name="l05291"></a>05291 result = res
- <a name="l05292"></a>05292 <span class="keyword">end if</span>
- <a name="l05293"></a>05293
- <a name="l05294"></a>05294 <span class="keyword">end do</span>
- <a name="l05295"></a>05295 <span class="comment">!</span>
- <a name="l05296"></a>05296 <span class="comment">! Shift the table.</span>
- <a name="l05297"></a>05297 <span class="comment">!</span>
- <a name="l05298"></a>05298 <span class="keyword">if</span> ( n == limexp ) <span class="keyword">then</span>
- <a name="l05299"></a>05299 n = 2*(limexp/2)-1
- <a name="l05300"></a>05300 <span class="keyword">end if</span>
- <a name="l05301"></a>05301
- <a name="l05302"></a>05302 <span class="keyword">if</span> ( (num/2)*2 == num ) <span class="keyword">then</span>
- <a name="l05303"></a>05303 ib = 2
- <a name="l05304"></a>05304 <span class="keyword">else</span>
- <a name="l05305"></a>05305 ib = 1
- <a name="l05306"></a>05306 <span class="keyword">end if</span>
- <a name="l05307"></a>05307
- <a name="l05308"></a>05308 ie = newelm+1
- <a name="l05309"></a>05309
- <a name="l05310"></a>05310 <span class="keyword">do</span> i = 1, ie
- <a name="l05311"></a>05311 ib2 = ib+2
- <a name="l05312"></a>05312 epstab(ib) = epstab(ib2)
- <a name="l05313"></a>05313 ib = ib2
- <a name="l05314"></a>05314 <span class="keyword">end do</span>
- <a name="l05315"></a>05315
- <a name="l05316"></a>05316 <span class="keyword">if</span> ( num /= n ) <span class="keyword">then</span>
- <a name="l05317"></a>05317
- <a name="l05318"></a>05318 indx = num-n+1
- <a name="l05319"></a>05319
- <a name="l05320"></a>05320 <span class="keyword">do</span> i = 1, n
- <a name="l05321"></a>05321 epstab(i)= epstab(indx)
- <a name="l05322"></a>05322 indx = indx+1
- <a name="l05323"></a>05323 <span class="keyword">end do</span>
- <a name="l05324"></a>05324
- <a name="l05325"></a>05325 <span class="keyword">end if</span>
- <a name="l05326"></a>05326
- <a name="l05327"></a>05327 <span class="keyword">if</span> ( nres < 4 ) <span class="keyword">then</span>
- <a name="l05328"></a>05328 res3la(nres) = result
- <a name="l05329"></a>05329 abserr = huge ( abserr )
- <a name="l05330"></a>05330 <span class="keyword">else</span>
- <a name="l05331"></a>05331 abserr = abs(result-res3la(3))+abs(result-res3la(2)) &
- <a name="l05332"></a>05332 +abs(result-res3la(1))
- <a name="l05333"></a>05333 res3la(1) = res3la(2)
- <a name="l05334"></a>05334 res3la(2) = res3la(3)
- <a name="l05335"></a>05335 res3la(3) = result
- <a name="l05336"></a>05336 <span class="keyword">end if</span>
- <a name="l05337"></a>05337
- <a name="l05338"></a>05338 abserr = max ( abserr,0.5e+00* epsilon ( result ) *abs(result))
- <a name="l05339"></a>05339
- <a name="l05340"></a>05340 return
- <a name="l05341"></a>05341 <span class="keyword">end</span>
- <a name="l05342"></a><a class="code" href="quadpack_8f90.html#abbba06307e0e8c4daa2651945570ba1c">05342</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#abbba06307e0e8c4daa2651945570ba1c">qfour</a> ( f, a, b, omega, integr, epsabs, epsrel, limit, icall, &
- <a name="l05343"></a>05343 maxp1, result, abserr, neval, ier, alist, blist, rlist, elist, iord, &
- <a name="l05344"></a>05344 nnlog, momcom, chebmo )
- <a name="l05345"></a>05345
- <a name="l05346"></a>05346 <span class="comment">!*****************************************************************************80</span>
- <a name="l05347"></a>05347 <span class="comment">!</span>
- <a name="l05348"></a>05348 <span class="comment">!! QFOUR estimates the integrals of oscillatory functions.</span>
- <a name="l05349"></a>05349 <span class="comment">!</span>
- <a name="l05350"></a>05350 <span class="comment">! Discussion:</span>
- <a name="l05351"></a>05351 <span class="comment">!</span>
- <a name="l05352"></a>05352 <span class="comment">! This routine calculates an approximation RESULT to a definite integral</span>
- <a name="l05353"></a>05353 <span class="comment">! I = integral of F(X) * COS(OMEGA*X) </span>
- <a name="l05354"></a>05354 <span class="comment">! or</span>
- <a name="l05355"></a>05355 <span class="comment">! I = integral of F(X) * SIN(OMEGA*X) </span>
- <a name="l05356"></a>05356 <span class="comment">! over (A,B), hopefully satisfying:</span>
- <a name="l05357"></a>05357 <span class="comment">! | I - RESULT | <= max ( epsabs, epsrel * |I| ) ).</span>
- <a name="l05358"></a>05358 <span class="comment">!</span>
- <a name="l05359"></a>05359 <span class="comment">! QFOUR is called by QAWO and QAWF. It can also be called directly in </span>
- <a name="l05360"></a>05360 <span class="comment">! a user-written program. In the latter case it is possible for the </span>
- <a name="l05361"></a>05361 <span class="comment">! user to determine the first dimension of array CHEBMO(MAXP1,25).</span>
- <a name="l05362"></a>05362 <span class="comment">! See also parameter description of MAXP1. Additionally see</span>
- <a name="l05363"></a>05363 <span class="comment">! parameter description of ICALL for eventually re-using</span>
- <a name="l05364"></a>05364 <span class="comment">! Chebyshev moments computed during former call on subinterval</span>
- <a name="l05365"></a>05365 <span class="comment">! of equal length abs(B-A).</span>
- <a name="l05366"></a>05366 <span class="comment">!</span>
- <a name="l05367"></a>05367 <span class="comment">! Author:</span>
- <a name="l05368"></a>05368 <span class="comment">!</span>
- <a name="l05369"></a>05369 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l05370"></a>05370 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l05371"></a>05371 <span class="comment">!</span>
- <a name="l05372"></a>05372 <span class="comment">! Reference:</span>
- <a name="l05373"></a>05373 <span class="comment">!</span>
- <a name="l05374"></a>05374 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l05375"></a>05375 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l05376"></a>05376 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l05377"></a>05377 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l05378"></a>05378 <span class="comment">!</span>
- <a name="l05379"></a>05379 <span class="comment">! Parameters:</span>
- <a name="l05380"></a>05380 <span class="comment">!</span>
- <a name="l05381"></a>05381 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l05382"></a>05382 <span class="comment">! function f ( x )</span>
- <a name="l05383"></a>05383 <span class="comment">! real f</span>
- <a name="l05384"></a>05384 <span class="comment">! real x</span>
- <a name="l05385"></a>05385 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l05386"></a>05386 <span class="comment">!</span>
- <a name="l05387"></a>05387 <span class="comment">! Input, real A, B, the limits of integration.</span>
- <a name="l05388"></a>05388 <span class="comment">!</span>
- <a name="l05389"></a>05389 <span class="comment">! Input, real OMEGA, the multiplier of X in the weight function.</span>
- <a name="l05390"></a>05390 <span class="comment">!</span>
- <a name="l05391"></a>05391 <span class="comment">! Input, integer INTEGR, indicates the weight functions to be used.</span>
- <a name="l05392"></a>05392 <span class="comment">! = 1, w(x) = cos(omega*x)</span>
- <a name="l05393"></a>05393 <span class="comment">! = 2, w(x) = sin(omega*x)</span>
- <a name="l05394"></a>05394 <span class="comment">!</span>
- <a name="l05395"></a>05395 <span class="comment">! Input, real EPSABS, EPSREL, the absolute and relative accuracy requested.</span>
- <a name="l05396"></a>05396 <span class="comment">!</span>
- <a name="l05397"></a>05397 <span class="comment">! Input, integer LIMIT, the maximum number of subintervals of [A,B]</span>
- <a name="l05398"></a>05398 <span class="comment">! that can be generated.</span>
- <a name="l05399"></a>05399 <span class="comment">!</span>
- <a name="l05400"></a>05400 <span class="comment">! icall - integer</span>
- <a name="l05401"></a>05401 <span class="comment">! if qfour is to be used only once, ICALL must</span>
- <a name="l05402"></a>05402 <span class="comment">! be set to 1. assume that during this call, the</span>
- <a name="l05403"></a>05403 <span class="comment">! Chebyshev moments (for clenshaw-curtis integration</span>
- <a name="l05404"></a>05404 <span class="comment">! of degree 24) have been computed for intervals of</span>
- <a name="l05405"></a>05405 <span class="comment">! lenghts (abs(b-a))*2**(-l), l=0,1,2,...momcom-1.</span>
- <a name="l05406"></a>05406 <span class="comment">! the Chebyshev moments already computed can be</span>
- <a name="l05407"></a>05407 <span class="comment">! re-used in subsequent calls, if qfour must be</span>
- <a name="l05408"></a>05408 <span class="comment">! called twice or more times on intervals of the</span>
- <a name="l05409"></a>05409 <span class="comment">! same length abs(b-a). from the second call on, one</span>
- <a name="l05410"></a>05410 <span class="comment">! has to put then ICALL > 1.</span>
- <a name="l05411"></a>05411 <span class="comment">! if ICALL < 1, the routine will end with ier = 6.</span>
- <a name="l05412"></a>05412 <span class="comment">!</span>
- <a name="l05413"></a>05413 <span class="comment">! maxp1 - integer</span>
- <a name="l05414"></a>05414 <span class="comment">! gives an upper bound on the number of</span>
- <a name="l05415"></a>05415 <span class="comment">! Chebyshev moments which can be stored, i.e.</span>
- <a name="l05416"></a>05416 <span class="comment">! for the intervals of lenghts abs(b-a)*2**(-l),</span>
- <a name="l05417"></a>05417 <span class="comment">! l=0,1, ..., maxp1-2, maxp1 >= 1.</span>
- <a name="l05418"></a>05418 <span class="comment">! if maxp1 < 1, the routine will end with ier = 6.</span>
- <a name="l05419"></a>05419 <span class="comment">! increasing (decreasing) the value of maxp1</span>
- <a name="l05420"></a>05420 <span class="comment">! decreases (increases) the computational time but</span>
- <a name="l05421"></a>05421 <span class="comment">! increases (decreases) the required memory space.</span>
- <a name="l05422"></a>05422 <span class="comment">!</span>
- <a name="l05423"></a>05423 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l05424"></a>05424 <span class="comment">!</span>
- <a name="l05425"></a>05425 <span class="comment">! Output, real ABSERR, an estimate of || I - RESULT ||.</span>
- <a name="l05426"></a>05426 <span class="comment">!</span>
- <a name="l05427"></a>05427 <span class="comment">! Output, integer NEVAL, the number of times the integral was evaluated.</span>
- <a name="l05428"></a>05428 <span class="comment">!</span>
- <a name="l05429"></a>05429 <span class="comment">! ier - integer</span>
- <a name="l05430"></a>05430 <span class="comment">! ier = 0 normal and reliable termination of the</span>
- <a name="l05431"></a>05431 <span class="comment">! routine. it is assumed that the</span>
- <a name="l05432"></a>05432 <span class="comment">! requested accuracy has been achieved.</span>
- <a name="l05433"></a>05433 <span class="comment">! - ier > 0 abnormal termination of the routine.</span>
- <a name="l05434"></a>05434 <span class="comment">! the estimates for integral and error are</span>
- <a name="l05435"></a>05435 <span class="comment">! less reliable. it is assumed that the</span>
- <a name="l05436"></a>05436 <span class="comment">! requested accuracy has not been achieved.</span>
- <a name="l05437"></a>05437 <span class="comment">! ier = 1 maximum number of subdivisions allowed</span>
- <a name="l05438"></a>05438 <span class="comment">! has been achieved. one can allow more</span>
- <a name="l05439"></a>05439 <span class="comment">! subdivisions by increasing the value of</span>
- <a name="l05440"></a>05440 <span class="comment">! limit (and taking according dimension</span>
- <a name="l05441"></a>05441 <span class="comment">! adjustments into account). however, if</span>
- <a name="l05442"></a>05442 <span class="comment">! this yields no improvement it is advised</span>
- <a name="l05443"></a>05443 <span class="comment">! to analyze the integrand, in order to</span>
- <a name="l05444"></a>05444 <span class="comment">! determine the integration difficulties.</span>
- <a name="l05445"></a>05445 <span class="comment">! if the position of a local difficulty can</span>
- <a name="l05446"></a>05446 <span class="comment">! be determined (e.g. singularity,</span>
- <a name="l05447"></a>05447 <span class="comment">! discontinuity within the interval) one</span>
- <a name="l05448"></a>05448 <span class="comment">! will probably gain from splitting up the</span>
- <a name="l05449"></a>05449 <span class="comment">! interval at this point and calling the</span>
- <a name="l05450"></a>05450 <span class="comment">! integrator on the subranges. if possible,</span>
- <a name="l05451"></a>05451 <span class="comment">! an appropriate special-purpose integrator</span>
- <a name="l05452"></a>05452 <span class="comment">! should be used which is designed for</span>
- <a name="l05453"></a>05453 <span class="comment">! handling the type of difficulty involved.</span>
- <a name="l05454"></a>05454 <span class="comment">! = 2 the occurrence of roundoff error is</span>
- <a name="l05455"></a>05455 <span class="comment">! detected, which prevents the requested</span>
- <a name="l05456"></a>05456 <span class="comment">! tolerance from being achieved.</span>
- <a name="l05457"></a>05457 <span class="comment">! the error may be under-estimated.</span>
- <a name="l05458"></a>05458 <span class="comment">! = 3 extremely bad integrand behavior occurs</span>
- <a name="l05459"></a>05459 <span class="comment">! at some points of the integration</span>
- <a name="l05460"></a>05460 <span class="comment">! interval.</span>
- <a name="l05461"></a>05461 <span class="comment">! = 4 the algorithm does not converge. roundoff</span>
- <a name="l05462"></a>05462 <span class="comment">! error is detected in the extrapolation</span>
- <a name="l05463"></a>05463 <span class="comment">! table. it is presumed that the requested</span>
- <a name="l05464"></a>05464 <span class="comment">! tolerance cannot be achieved due to</span>
- <a name="l05465"></a>05465 <span class="comment">! roundoff in the extrapolation table, and</span>
- <a name="l05466"></a>05466 <span class="comment">! that the returned result is the best which</span>
- <a name="l05467"></a>05467 <span class="comment">! can be obtained.</span>
- <a name="l05468"></a>05468 <span class="comment">! = 5 the integral is probably divergent, or</span>
- <a name="l05469"></a>05469 <span class="comment">! slowly convergent. it must be noted that</span>
- <a name="l05470"></a>05470 <span class="comment">! divergence can occur with any other value</span>
- <a name="l05471"></a>05471 <span class="comment">! of ier > 0.</span>
- <a name="l05472"></a>05472 <span class="comment">! = 6 the input is invalid, because</span>
- <a name="l05473"></a>05473 <span class="comment">! epsabs < 0 and epsrel < 0,</span>
- <a name="l05474"></a>05474 <span class="comment">! or (integr /= 1 and integr /= 2) or</span>
- <a name="l05475"></a>05475 <span class="comment">! ICALL < 1 or maxp1 < 1.</span>
- <a name="l05476"></a>05476 <span class="comment">! result, abserr, neval, last, rlist(1),</span>
- <a name="l05477"></a>05477 <span class="comment">! elist(1), iord(1) and nnlog(1) are set to</span>
- <a name="l05478"></a>05478 <span class="comment">! zero. alist(1) and blist(1) are set to a</span>
- <a name="l05479"></a>05479 <span class="comment">! and b respectively.</span>
- <a name="l05480"></a>05480 <span class="comment">!</span>
- <a name="l05481"></a>05481 <span class="comment">! Workspace, real ALIST(LIMIT), BLIST(LIMIT), contains in entries 1 </span>
- <a name="l05482"></a>05482 <span class="comment">! through LAST the left and right ends of the partition subintervals.</span>
- <a name="l05483"></a>05483 <span class="comment">!</span>
- <a name="l05484"></a>05484 <span class="comment">! Workspace, real RLIST(LIMIT), contains in entries 1 through LAST</span>
- <a name="l05485"></a>05485 <span class="comment">! the integral approximations on the subintervals.</span>
- <a name="l05486"></a>05486 <span class="comment">!</span>
- <a name="l05487"></a>05487 <span class="comment">! Workspace, real ELIST(LIMIT), contains in entries 1 through LAST</span>
- <a name="l05488"></a>05488 <span class="comment">! the absolute error estimates on the subintervals.</span>
- <a name="l05489"></a>05489 <span class="comment">!</span>
- <a name="l05490"></a>05490 <span class="comment">! iord - integer</span>
- <a name="l05491"></a>05491 <span class="comment">! vector of dimension at least limit, the first k</span>
- <a name="l05492"></a>05492 <span class="comment">! elements of which are pointers to the error</span>
- <a name="l05493"></a>05493 <span class="comment">! estimates over the subintervals, such that</span>
- <a name="l05494"></a>05494 <span class="comment">! elist(iord(1)), ..., elist(iord(k)), form</span>
- <a name="l05495"></a>05495 <span class="comment">! a decreasing sequence, with k = last</span>
- <a name="l05496"></a>05496 <span class="comment">! if last <= (limit/2+2), and</span>
- <a name="l05497"></a>05497 <span class="comment">! k = limit+1-last otherwise.</span>
- <a name="l05498"></a>05498 <span class="comment">!</span>
- <a name="l05499"></a>05499 <span class="comment">! nnlog - integer</span>
- <a name="l05500"></a>05500 <span class="comment">! vector of dimension at least limit, indicating the</span>
- <a name="l05501"></a>05501 <span class="comment">! subdivision levels of the subintervals, i.e.</span>
- <a name="l05502"></a>05502 <span class="comment">! iwork(i) = l means that the subinterval numbered</span>
- <a name="l05503"></a>05503 <span class="comment">! i is of length abs(b-a)*2**(1-l)</span>
- <a name="l05504"></a>05504 <span class="comment">!</span>
- <a name="l05505"></a>05505 <span class="comment">! on entry and return</span>
- <a name="l05506"></a>05506 <span class="comment">! momcom - integer</span>
- <a name="l05507"></a>05507 <span class="comment">! indicating that the Chebyshev moments have been</span>
- <a name="l05508"></a>05508 <span class="comment">! computed for intervals of lengths</span>
- <a name="l05509"></a>05509 <span class="comment">! (abs(b-a))*2**(-l), l=0,1,2, ..., momcom-1,</span>
- <a name="l05510"></a>05510 <span class="comment">! momcom < maxp1</span>
- <a name="l05511"></a>05511 <span class="comment">!</span>
- <a name="l05512"></a>05512 <span class="comment">! chebmo - real</span>
- <a name="l05513"></a>05513 <span class="comment">! array of dimension (maxp1,25) containing the</span>
- <a name="l05514"></a>05514 <span class="comment">! Chebyshev moments</span>
- <a name="l05515"></a>05515 <span class="comment">!</span>
- <a name="l05516"></a>05516 <span class="comment">! Local Parameters:</span>
- <a name="l05517"></a>05517 <span class="comment">!</span>
- <a name="l05518"></a>05518 <span class="comment">! alist - list of left end points of all subintervals</span>
- <a name="l05519"></a>05519 <span class="comment">! considered up to now</span>
- <a name="l05520"></a>05520 <span class="comment">! blist - list of right end points of all subintervals</span>
- <a name="l05521"></a>05521 <span class="comment">! considered up to now</span>
- <a name="l05522"></a>05522 <span class="comment">! rlist(i) - approximation to the integral over</span>
- <a name="l05523"></a>05523 <span class="comment">! (alist(i),blist(i))</span>
- <a name="l05524"></a>05524 <span class="comment">! rlist2 - array of dimension at least limexp+2 containing</span>
- <a name="l05525"></a>05525 <span class="comment">! the part of the epsilon table which is still</span>
- <a name="l05526"></a>05526 <span class="comment">! needed for further computations</span>
- <a name="l05527"></a>05527 <span class="comment">! elist(i) - error estimate applying to rlist(i)</span>
- <a name="l05528"></a>05528 <span class="comment">! maxerr - pointer to the interval with largest error</span>
- <a name="l05529"></a>05529 <span class="comment">! estimate</span>
- <a name="l05530"></a>05530 <span class="comment">! errmax - elist(maxerr)</span>
- <a name="l05531"></a>05531 <span class="comment">! erlast - error on the interval currently subdivided</span>
- <a name="l05532"></a>05532 <span class="comment">! area - sum of the integrals over the subintervals</span>
- <a name="l05533"></a>05533 <span class="comment">! errsum - sum of the errors over the subintervals</span>
- <a name="l05534"></a>05534 <span class="comment">! errbnd - requested accuracy max(epsabs,epsrel*</span>
- <a name="l05535"></a>05535 <span class="comment">! abs(result))</span>
- <a name="l05536"></a>05536 <span class="comment">! *****1 - variable for the left subinterval</span>
- <a name="l05537"></a>05537 <span class="comment">! *****2 - variable for the right subinterval</span>
- <a name="l05538"></a>05538 <span class="comment">! last - index for subdivision</span>
- <a name="l05539"></a>05539 <span class="comment">! nres - number of calls to the extrapolation routine</span>
- <a name="l05540"></a>05540 <span class="comment">! numrl2 - number of elements in rlist2. if an appropriate</span>
- <a name="l05541"></a>05541 <span class="comment">! approximation to the compounded integral has</span>
- <a name="l05542"></a>05542 <span class="comment">! been obtained it is put in rlist2(numrl2) after</span>
- <a name="l05543"></a>05543 <span class="comment">! numrl2 has been increased by one</span>
- <a name="l05544"></a>05544 <span class="comment">! small - length of the smallest interval considered</span>
- <a name="l05545"></a>05545 <span class="comment">! up to now, multiplied by 1.5</span>
- <a name="l05546"></a>05546 <span class="comment">! erlarg - sum of the errors over the intervals larger</span>
- <a name="l05547"></a>05547 <span class="comment">! than the smallest interval considered up to now</span>
- <a name="l05548"></a>05548 <span class="comment">! extrap - logical variable denoting that the routine is</span>
- <a name="l05549"></a>05549 <span class="comment">! attempting to perform extrapolation, i.e. before</span>
- <a name="l05550"></a>05550 <span class="comment">! subdividing the smallest interval we try to</span>
- <a name="l05551"></a>05551 <span class="comment">! decrease the value of erlarg</span>
- <a name="l05552"></a>05552 <span class="comment">! noext - logical variable denoting that extrapolation</span>
- <a name="l05553"></a>05553 <span class="comment">! is no longer allowed (true value)</span>
- <a name="l05554"></a>05554 <span class="comment">!</span>
- <a name="l05555"></a>05555 <span class="keyword">implicit none</span>
- <a name="l05556"></a>05556
- <a name="l05557"></a>05557 <span class="keywordtype">integer</span> limit
- <a name="l05558"></a>05558 <span class="keywordtype">integer</span> maxp1
- <a name="l05559"></a>05559
- <a name="l05560"></a>05560 <span class="keywordtype">real</span> a
- <a name="l05561"></a>05561 <span class="keywordtype">real</span> abseps
- <a name="l05562"></a>05562 <span class="keywordtype">real</span> abserr
- <a name="l05563"></a>05563 <span class="keywordtype">real</span> alist(limit)
- <a name="l05564"></a>05564 <span class="keywordtype">real</span> area
- <a name="l05565"></a>05565 <span class="keywordtype">real</span> area1
- <a name="l05566"></a>05566 <span class="keywordtype">real</span> area12
- <a name="l05567"></a>05567 <span class="keywordtype">real</span> area2
- <a name="l05568"></a>05568 <span class="keywordtype">real</span> a1
- <a name="l05569"></a>05569 <span class="keywordtype">real</span> a2
- <a name="l05570"></a>05570 <span class="keywordtype">real</span> b
- <a name="l05571"></a>05571 <span class="keywordtype">real</span> blist(limit)
- <a name="l05572"></a>05572 <span class="keywordtype">real</span> b1
- <a name="l05573"></a>05573 <span class="keywordtype">real</span> b2
- <a name="l05574"></a>05574 <span class="keywordtype">real</span> chebmo(maxp1,25)
- <a name="l05575"></a>05575 <span class="keywordtype">real</span> correc
- <a name="l05576"></a>05576 <span class="keywordtype">real</span> defab1
- <a name="l05577"></a>05577 <span class="keywordtype">real</span> defab2
- <a name="l05578"></a>05578 <span class="keywordtype">real</span> defabs
- <a name="l05579"></a>05579 <span class="keywordtype">real</span> domega
- <a name="l05580"></a>05580 <span class="keywordtype">real</span> dres
- <a name="l05581"></a>05581 <span class="keywordtype">real</span> elist(limit)
- <a name="l05582"></a>05582 <span class="keywordtype">real</span> epsabs
- <a name="l05583"></a>05583 <span class="keywordtype">real</span> epsrel
- <a name="l05584"></a>05584 <span class="keywordtype">real</span> erlarg
- <a name="l05585"></a>05585 <span class="keywordtype">real</span> erlast
- <a name="l05586"></a>05586 <span class="keywordtype">real</span> errbnd
- <a name="l05587"></a>05587 <span class="keywordtype">real</span> errmax
- <a name="l05588"></a>05588 <span class="keywordtype">real</span> error1
- <a name="l05589"></a>05589 <span class="keywordtype">real</span> erro12
- <a name="l05590"></a>05590 <span class="keywordtype">real</span> error2
- <a name="l05591"></a>05591 <span class="keywordtype">real</span> errsum
- <a name="l05592"></a>05592 <span class="keywordtype">real</span> ertest
- <a name="l05593"></a>05593 <span class="keywordtype">logical</span> extall
- <a name="l05594"></a>05594 <span class="keywordtype">logical</span> extrap
- <a name="l05595"></a>05595 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l05596"></a>05596 <span class="keywordtype">integer</span> icall
- <a name="l05597"></a>05597 <span class="keywordtype">integer</span> id
- <a name="l05598"></a>05598 <span class="keywordtype">integer</span> ier
- <a name="l05599"></a>05599 <span class="keywordtype">integer</span> ierro
- <a name="l05600"></a>05600 <span class="keywordtype">integer</span> integr
- <a name="l05601"></a>05601 <span class="keywordtype">integer</span> iord(limit)
- <a name="l05602"></a>05602 <span class="keywordtype">integer</span> iroff1
- <a name="l05603"></a>05603 <span class="keywordtype">integer</span> iroff2
- <a name="l05604"></a>05604 <span class="keywordtype">integer</span> iroff3
- <a name="l05605"></a>05605 <span class="keywordtype">integer</span> jupbnd
- <a name="l05606"></a>05606 <span class="keywordtype">integer</span> k
- <a name="l05607"></a>05607 <span class="keywordtype">integer</span> ksgn
- <a name="l05608"></a>05608 <span class="keywordtype">integer</span> ktmin
- <a name="l05609"></a>05609 <span class="keywordtype">integer</span> last
- <a name="l05610"></a>05610 <span class="keywordtype">integer</span> maxerr
- <a name="l05611"></a>05611 <span class="keywordtype">integer</span> momcom
- <a name="l05612"></a>05612 <span class="keywordtype">integer</span> nev
- <a name="l05613"></a>05613 <span class="keywordtype">integer</span> neval
- <a name="l05614"></a>05614 <span class="keywordtype">integer</span> nnlog(limit)
- <a name="l05615"></a>05615 <span class="keywordtype">logical</span> noext
- <a name="l05616"></a>05616 <span class="keywordtype">integer</span> nres
- <a name="l05617"></a>05617 <span class="keywordtype">integer</span> nrmax
- <a name="l05618"></a>05618 <span class="keywordtype">integer</span> nrmom
- <a name="l05619"></a>05619 <span class="keywordtype">integer</span> numrl2
- <a name="l05620"></a>05620 <span class="keywordtype">real</span> omega
- <a name="l05621"></a>05621 <span class="keywordtype">real</span> resabs
- <a name="l05622"></a>05622 <span class="keywordtype">real</span> reseps
- <a name="l05623"></a>05623 <span class="keywordtype">real</span> result
- <a name="l05624"></a>05624 <span class="keywordtype">real</span> res3la(3)
- <a name="l05625"></a>05625 <span class="keywordtype">real</span> rlist(limit)
- <a name="l05626"></a>05626 <span class="keywordtype">real</span> rlist2(52)
- <a name="l05627"></a>05627 <span class="keywordtype">real</span> small
- <a name="l05628"></a>05628 <span class="keywordtype">real</span> width
- <a name="l05629"></a>05629 <span class="comment">!</span>
- <a name="l05630"></a>05630 <span class="comment">! the dimension of rlist2 is determined by the value of</span>
- <a name="l05631"></a>05631 <span class="comment">! limexp in QEXTR (rlist2 should be of dimension</span>
- <a name="l05632"></a>05632 <span class="comment">! (limexp+2) at least).</span>
- <a name="l05633"></a>05633 <span class="comment">!</span>
- <a name="l05634"></a>05634 <span class="comment">! Test on validity of parameters.</span>
- <a name="l05635"></a>05635 <span class="comment">!</span>
- <a name="l05636"></a>05636 ier = 0
- <a name="l05637"></a>05637 neval = 0
- <a name="l05638"></a>05638 last = 0
- <a name="l05639"></a>05639 result = 0.0e+00
- <a name="l05640"></a>05640 abserr = 0.0e+00
- <a name="l05641"></a>05641 alist(1) = a
- <a name="l05642"></a>05642 blist(1) = b
- <a name="l05643"></a>05643 rlist(1) = 0.0e+00
- <a name="l05644"></a>05644 elist(1) = 0.0e+00
- <a name="l05645"></a>05645 iord(1) = 0
- <a name="l05646"></a>05646 nnlog(1) = 0
- <a name="l05647"></a>05647
- <a name="l05648"></a>05648 <span class="keyword">if</span> ( (integr /= 1.and.integr /= 2) .or. (epsabs < 0.0e+00.and. &
- <a name="l05649"></a>05649 epsrel < 0.0e+00) .or. icall < 1 .or. maxp1 < 1 ) <span class="keyword">then</span>
- <a name="l05650"></a>05650 ier = 6
- <a name="l05651"></a>05651 return
- <a name="l05652"></a>05652 <span class="keyword">end if</span>
- <a name="l05653"></a>05653 <span class="comment">!</span>
- <a name="l05654"></a>05654 <span class="comment">! First approximation to the integral.</span>
- <a name="l05655"></a>05655 <span class="comment">!</span>
- <a name="l05656"></a>05656 domega = abs ( omega )
- <a name="l05657"></a>05657 nrmom = 0
- <a name="l05658"></a>05658
- <a name="l05659"></a>05659 <span class="keyword">if</span> ( icall <= 1 ) <span class="keyword">then</span>
- <a name="l05660"></a>05660 momcom = 0
- <a name="l05661"></a>05661 <span class="keyword">end if</span>
- <a name="l05662"></a>05662
- <a name="l05663"></a>05663 call <a class="code" href="quadpack_8f90.html#ab0843f4831942d2c9bf3430cb71aca06">qc25o </a>( f, a, b, domega, integr, nrmom, maxp1, 0, result, abserr, &
- <a name="l05664"></a>05664 neval, defabs, resabs, momcom, chebmo )
- <a name="l05665"></a>05665 <span class="comment">!</span>
- <a name="l05666"></a>05666 <span class="comment">! Test on accuracy.</span>
- <a name="l05667"></a>05667 <span class="comment">!</span>
- <a name="l05668"></a>05668 dres = abs(result)
- <a name="l05669"></a>05669 errbnd = max ( epsabs,epsrel*dres)
- <a name="l05670"></a>05670 rlist(1) = result
- <a name="l05671"></a>05671 elist(1) = abserr
- <a name="l05672"></a>05672 iord(1) = 1
- <a name="l05673"></a>05673 <span class="keyword">if</span> ( abserr <= 1.0e+02* epsilon ( defabs ) *defabs .and. &
- <a name="l05674"></a>05674 abserr > errbnd ) ier = 2
- <a name="l05675"></a>05675
- <a name="l05676"></a>05676 <span class="keyword">if</span> ( limit == 1 ) <span class="keyword">then</span>
- <a name="l05677"></a>05677 ier = 1
- <a name="l05678"></a>05678 <span class="keyword">end if</span>
- <a name="l05679"></a>05679
- <a name="l05680"></a>05680 <span class="keyword">if</span> ( ier /= 0 .or. abserr <= errbnd ) <span class="keyword">then</span>
- <a name="l05681"></a>05681 go to 200
- <a name="l05682"></a>05682 <span class="keyword">end if</span>
- <a name="l05683"></a>05683 <span class="comment">!</span>
- <a name="l05684"></a>05684 <span class="comment">! Initializations</span>
- <a name="l05685"></a>05685 <span class="comment">!</span>
- <a name="l05686"></a>05686 errmax = abserr
- <a name="l05687"></a>05687 maxerr = 1
- <a name="l05688"></a>05688 area = result
- <a name="l05689"></a>05689 errsum = abserr
- <a name="l05690"></a>05690 abserr = huge ( abserr )
- <a name="l05691"></a>05691 nrmax = 1
- <a name="l05692"></a>05692 extrap = .false.
- <a name="l05693"></a>05693 noext = .false.
- <a name="l05694"></a>05694 ierro = 0
- <a name="l05695"></a>05695 iroff1 = 0
- <a name="l05696"></a>05696 iroff2 = 0
- <a name="l05697"></a>05697 iroff3 = 0
- <a name="l05698"></a>05698 ktmin = 0
- <a name="l05699"></a>05699 small = abs(b-a)*7.5e-01
- <a name="l05700"></a>05700 nres = 0
- <a name="l05701"></a>05701 numrl2 = 0
- <a name="l05702"></a>05702 extall = .false.
- <a name="l05703"></a>05703
- <a name="l05704"></a>05704 <span class="keyword">if</span> ( 5.0e-01*abs(b-a)*domega <= 2.0e+00) <span class="keyword">then</span>
- <a name="l05705"></a>05705 numrl2 = 1
- <a name="l05706"></a>05706 extall = .true.
- <a name="l05707"></a>05707 rlist2(1) = result
- <a name="l05708"></a>05708 <span class="keyword">end if</span>
- <a name="l05709"></a>05709
- <a name="l05710"></a>05710 <span class="keyword">if</span> ( 2.5e-01 * abs(b-a) * domega <= 2.0e+00 ) <span class="keyword">then</span>
- <a name="l05711"></a>05711 extall = .true.
- <a name="l05712"></a>05712 <span class="keyword">end if</span>
- <a name="l05713"></a>05713
- <a name="l05714"></a>05714 <span class="keyword">if</span> ( dres >= (1.0e+00-5.0e+01* epsilon ( defabs ) )*defabs ) <span class="keyword">then</span>
- <a name="l05715"></a>05715 ksgn = 1
- <a name="l05716"></a>05716 <span class="keyword">else</span>
- <a name="l05717"></a>05717 ksgn = -1
- <a name="l05718"></a>05718 <span class="keyword">end if</span>
- <a name="l05719"></a>05719 <span class="comment">!</span>
- <a name="l05720"></a>05720 <span class="comment">! main do-loop</span>
- <a name="l05721"></a>05721 <span class="comment">!</span>
- <a name="l05722"></a>05722 <span class="keyword">do</span> last = 2, limit
- <a name="l05723"></a>05723 <span class="comment">!</span>
- <a name="l05724"></a>05724 <span class="comment">! Bisect the subinterval with the nrmax-th largest error estimate.</span>
- <a name="l05725"></a>05725 <span class="comment">!</span>
- <a name="l05726"></a>05726 nrmom = nnlog(maxerr)+1
- <a name="l05727"></a>05727 a1 = alist(maxerr)
- <a name="l05728"></a>05728 b1 = 5.0e-01*(alist(maxerr)+blist(maxerr))
- <a name="l05729"></a>05729 a2 = b1
- <a name="l05730"></a>05730 b2 = blist(maxerr)
- <a name="l05731"></a>05731 erlast = errmax
- <a name="l05732"></a>05732
- <a name="l05733"></a>05733 call <a class="code" href="quadpack_8f90.html#ab0843f4831942d2c9bf3430cb71aca06">qc25o </a>( f, a1, b1, domega, integr, nrmom, maxp1, 0, area1, &
- <a name="l05734"></a>05734 error1, nev, resabs, defab1, momcom, chebmo )
- <a name="l05735"></a>05735
- <a name="l05736"></a>05736 neval = neval+nev
- <a name="l05737"></a>05737
- <a name="l05738"></a>05738 call <a class="code" href="quadpack_8f90.html#ab0843f4831942d2c9bf3430cb71aca06">qc25o </a>( f, a2, b2, domega, integr, nrmom, maxp1, 1, area2, &
- <a name="l05739"></a>05739 error2, nev, resabs, defab2, momcom, chebmo )
- <a name="l05740"></a>05740
- <a name="l05741"></a>05741 neval = neval+nev
- <a name="l05742"></a>05742 <span class="comment">!</span>
- <a name="l05743"></a>05743 <span class="comment">! Improve previous approximations to integral and error and</span>
- <a name="l05744"></a>05744 <span class="comment">! test for accuracy.</span>
- <a name="l05745"></a>05745 <span class="comment">!</span>
- <a name="l05746"></a>05746 area12 = area1+area2
- <a name="l05747"></a>05747 erro12 = error1+error2
- <a name="l05748"></a>05748 errsum = errsum+erro12-errmax
- <a name="l05749"></a>05749 area = area+area12-rlist(maxerr)
- <a name="l05750"></a>05750 <span class="keyword">if</span> ( defab1 == error1 .or. defab2 == error2 ) go to 25
- <a name="l05751"></a>05751 <span class="keyword">if</span> ( abs(rlist(maxerr)-area12) > 1.0e-05*abs(area12) &
- <a name="l05752"></a>05752 .or. erro12 < 9.9e-01*errmax ) go to 20
- <a name="l05753"></a>05753 <span class="keyword">if</span> ( extrap ) iroff2 = iroff2+1
- <a name="l05754"></a>05754
- <a name="l05755"></a>05755 <span class="keyword">if</span> ( .not.extrap ) <span class="keyword">then</span>
- <a name="l05756"></a>05756 iroff1 = iroff1+1
- <a name="l05757"></a>05757 <span class="keyword">end if</span>
- <a name="l05758"></a>05758
- <a name="l05759"></a>05759 20 continue
- <a name="l05760"></a>05760
- <a name="l05761"></a>05761 <span class="keyword">if</span> ( last > 10.and.erro12 > errmax ) iroff3 = iroff3+1
- <a name="l05762"></a>05762
- <a name="l05763"></a>05763 25 continue
- <a name="l05764"></a>05764
- <a name="l05765"></a>05765 rlist(maxerr) = area1
- <a name="l05766"></a>05766 rlist(last) = area2
- <a name="l05767"></a>05767 nnlog(maxerr) = nrmom
- <a name="l05768"></a>05768 nnlog(last) = nrmom
- <a name="l05769"></a>05769 errbnd = max ( epsabs,epsrel*abs(area))
- <a name="l05770"></a>05770 <span class="comment">!</span>
- <a name="l05771"></a>05771 <span class="comment">! Test for roundoff error and eventually set error flag</span>
- <a name="l05772"></a>05772 <span class="comment">!</span>
- <a name="l05773"></a>05773 <span class="keyword">if</span> ( iroff1+iroff2 >= 10 .or. iroff3 >= 20 ) ier = 2
- <a name="l05774"></a>05774
- <a name="l05775"></a>05775 <span class="keyword">if</span> ( iroff2 >= 5) ierro = 3
- <a name="l05776"></a>05776 <span class="comment">!</span>
- <a name="l05777"></a>05777 <span class="comment">! Set error flag in the case that the number of subintervals</span>
- <a name="l05778"></a>05778 <span class="comment">! equals limit.</span>
- <a name="l05779"></a>05779 <span class="comment">!</span>
- <a name="l05780"></a>05780 <span class="keyword">if</span> ( last == limit ) <span class="keyword">then</span>
- <a name="l05781"></a>05781 ier = 1
- <a name="l05782"></a>05782 <span class="keyword">end if</span>
- <a name="l05783"></a>05783 <span class="comment">!</span>
- <a name="l05784"></a>05784 <span class="comment">! Set error flag in the case of bad integrand behavior at</span>
- <a name="l05785"></a>05785 <span class="comment">! a point of the integration range.</span>
- <a name="l05786"></a>05786 <span class="comment">!</span>
- <a name="l05787"></a>05787 <span class="keyword">if</span> ( max ( abs(a1),abs(b2)) <= (1.0e+00+1.0e+03* epsilon ( a1 ) ) &
- <a name="l05788"></a>05788 *(abs(a2)+1.0e+03* tiny ( a2 ) )) <span class="keyword">then</span>
- <a name="l05789"></a>05789 ier = 4
- <a name="l05790"></a>05790 <span class="keyword">end if</span>
- <a name="l05791"></a>05791 <span class="comment">!</span>
- <a name="l05792"></a>05792 <span class="comment">! Append the newly-created intervals to the list.</span>
- <a name="l05793"></a>05793 <span class="comment">!</span>
- <a name="l05794"></a>05794 <span class="keyword">if</span> ( error2 <= error1 ) <span class="keyword">then</span>
- <a name="l05795"></a>05795 alist(last) = a2
- <a name="l05796"></a>05796 blist(maxerr) = b1
- <a name="l05797"></a>05797 blist(last) = b2
- <a name="l05798"></a>05798 elist(maxerr) = error1
- <a name="l05799"></a>05799 elist(last) = error2
- <a name="l05800"></a>05800 <span class="keyword">else</span>
- <a name="l05801"></a>05801 alist(maxerr) = a2
- <a name="l05802"></a>05802 alist(last) = a1
- <a name="l05803"></a>05803 blist(last) = b1
- <a name="l05804"></a>05804 rlist(maxerr) = area2
- <a name="l05805"></a>05805 rlist(last) = area1
- <a name="l05806"></a>05806 elist(maxerr) = error2
- <a name="l05807"></a>05807 elist(last) = error1
- <a name="l05808"></a>05808 <span class="keyword">end if</span>
- <a name="l05809"></a>05809 <span class="comment">!</span>
- <a name="l05810"></a>05810 <span class="comment">! Call QSORT to maintain the descending ordering</span>
- <a name="l05811"></a>05811 <span class="comment">! in the list of error estimates and select the subinterval</span>
- <a name="l05812"></a>05812 <span class="comment">! with nrmax-th largest error estimate (to be bisected next).</span>
- <a name="l05813"></a>05813 <span class="comment">!</span>
- <a name="l05814"></a>05814
- <a name="l05815"></a>05815 call <a class="code" href="quadpack_8f90.html#a55e08a684c5a6315fb37dd0fdc66d8e6">qsort </a>( limit, last, maxerr, errmax, elist, iord, nrmax )
- <a name="l05816"></a>05816
- <a name="l05817"></a>05817 <span class="keyword">if</span> ( errsum <= errbnd ) <span class="keyword">then</span>
- <a name="l05818"></a>05818 go to 170
- <a name="l05819"></a>05819 <span class="keyword">end if</span>
- <a name="l05820"></a>05820
- <a name="l05821"></a>05821 <span class="keyword">if</span> ( ier /= 0 ) <span class="keyword">then</span>
- <a name="l05822"></a>05822 exit
- <a name="l05823"></a>05823 <span class="keyword">end if</span>
- <a name="l05824"></a>05824
- <a name="l05825"></a>05825 <span class="keyword">if</span> ( last == 2 .and. extall ) go to 120
- <a name="l05826"></a>05826
- <a name="l05827"></a>05827 <span class="keyword">if</span> ( noext ) <span class="keyword">then</span>
- <a name="l05828"></a>05828 cycle
- <a name="l05829"></a>05829 <span class="keyword">end if</span>
- <a name="l05830"></a>05830
- <a name="l05831"></a>05831 <span class="keyword">if</span> ( .not. extall ) go to 50
- <a name="l05832"></a>05832 erlarg = erlarg-erlast
- <a name="l05833"></a>05833 <span class="keyword">if</span> ( abs(b1-a1) > small ) erlarg = erlarg+erro12
- <a name="l05834"></a>05834 <span class="keyword">if</span> ( extrap ) go to 70
- <a name="l05835"></a>05835 <span class="comment">!</span>
- <a name="l05836"></a>05836 <span class="comment">! Test whether the interval to be bisected next is the</span>
- <a name="l05837"></a>05837 <span class="comment">! smallest interval.</span>
- <a name="l05838"></a>05838 <span class="comment">!</span>
- <a name="l05839"></a>05839 50 continue
- <a name="l05840"></a>05840
- <a name="l05841"></a>05841 width = abs(blist(maxerr)-alist(maxerr))
- <a name="l05842"></a>05842
- <a name="l05843"></a>05843 <span class="keyword">if</span> ( width > small ) <span class="keyword">then</span>
- <a name="l05844"></a>05844 cycle
- <a name="l05845"></a>05845 <span class="keyword">end if</span>
- <a name="l05846"></a>05846
- <a name="l05847"></a>05847 <span class="keyword">if</span> ( extall ) go to 60
- <a name="l05848"></a>05848 <span class="comment">!</span>
- <a name="l05849"></a>05849 <span class="comment">! Test whether we can start with the extrapolation procedure</span>
- <a name="l05850"></a>05850 <span class="comment">! (we do this if we integrate over the next interval with</span>
- <a name="l05851"></a>05851 <span class="comment">! use of a Gauss-Kronrod rule - see QC25O).</span>
- <a name="l05852"></a>05852 <span class="comment">!</span>
- <a name="l05853"></a>05853 small = small*5.0e-01
- <a name="l05854"></a>05854
- <a name="l05855"></a>05855 <span class="keyword">if</span> ( 2.5e-01*width*domega > 2.0e+00 ) <span class="keyword">then</span>
- <a name="l05856"></a>05856 cycle
- <a name="l05857"></a>05857 <span class="keyword">end if</span>
- <a name="l05858"></a>05858
- <a name="l05859"></a>05859 extall = .true.
- <a name="l05860"></a>05860 go to 130
- <a name="l05861"></a>05861
- <a name="l05862"></a>05862 60 continue
- <a name="l05863"></a>05863
- <a name="l05864"></a>05864 extrap = .true.
- <a name="l05865"></a>05865 nrmax = 2
- <a name="l05866"></a>05866
- <a name="l05867"></a>05867 70 continue
- <a name="l05868"></a>05868
- <a name="l05869"></a>05869 <span class="keyword">if</span> ( ierro == 3 .or. erlarg <= ertest ) go to 90
- <a name="l05870"></a>05870 <span class="comment">!</span>
- <a name="l05871"></a>05871 <span class="comment">! The smallest interval has the largest error.</span>
- <a name="l05872"></a>05872 <span class="comment">! Before bisecting decrease the sum of the errors over the</span>
- <a name="l05873"></a>05873 <span class="comment">! larger intervals (ERLARG) and perform extrapolation.</span>
- <a name="l05874"></a>05874 <span class="comment">!</span>
- <a name="l05875"></a>05875 jupbnd = last
- <a name="l05876"></a>05876
- <a name="l05877"></a>05877 <span class="keyword">if</span> ( last > (limit/2+2) ) <span class="keyword">then</span>
- <a name="l05878"></a>05878 jupbnd = limit+3-last
- <a name="l05879"></a>05879 <span class="keyword">end if</span>
- <a name="l05880"></a>05880
- <a name="l05881"></a>05881 id = nrmax
- <a name="l05882"></a>05882
- <a name="l05883"></a>05883 <span class="keyword">do</span> k = id, jupbnd
- <a name="l05884"></a>05884 maxerr = iord(nrmax)
- <a name="l05885"></a>05885 errmax = elist(maxerr)
- <a name="l05886"></a>05886 <span class="keyword">if</span> ( abs(blist(maxerr)-alist(maxerr)) > small ) go to 140
- <a name="l05887"></a>05887 nrmax = nrmax+1
- <a name="l05888"></a>05888 <span class="keyword">end do</span>
- <a name="l05889"></a>05889 <span class="comment">!</span>
- <a name="l05890"></a>05890 <span class="comment">! Perform extrapolation.</span>
- <a name="l05891"></a>05891 <span class="comment">!</span>
- <a name="l05892"></a>05892 90 continue
- <a name="l05893"></a>05893
- <a name="l05894"></a>05894 numrl2 = numrl2+1
- <a name="l05895"></a>05895 rlist2(numrl2) = area
- <a name="l05896"></a>05896
- <a name="l05897"></a>05897 <span class="keyword">if</span> ( numrl2 < 3 ) go to 110
- <a name="l05898"></a>05898
- <a name="l05899"></a>05899 call <a class="code" href="quadpack_8f90.html#a5a75101d080f224c63adde98a0e64386">qextr </a>( numrl2, rlist2, reseps, abseps, res3la, nres )
- <a name="l05900"></a>05900 ktmin = ktmin+1
- <a name="l05901"></a>05901
- <a name="l05902"></a>05902 <span class="keyword">if</span> ( ktmin > 5.and.abserr < 1.0e-03*errsum ) <span class="keyword">then</span>
- <a name="l05903"></a>05903 ier = 5
- <a name="l05904"></a>05904 <span class="keyword">end if</span>
- <a name="l05905"></a>05905
- <a name="l05906"></a>05906 <span class="keyword">if</span> ( abseps >= abserr ) go to 100
- <a name="l05907"></a>05907
- <a name="l05908"></a>05908 ktmin = 0
- <a name="l05909"></a>05909 abserr = abseps
- <a name="l05910"></a>05910 result = reseps
- <a name="l05911"></a>05911 correc = erlarg
- <a name="l05912"></a>05912 ertest = max ( epsabs, epsrel*abs(reseps))
- <a name="l05913"></a>05913
- <a name="l05914"></a>05914 <span class="keyword">if</span> ( abserr <= ertest ) <span class="keyword">then</span>
- <a name="l05915"></a>05915 exit
- <a name="l05916"></a>05916 <span class="keyword">end if</span>
- <a name="l05917"></a>05917 <span class="comment">!</span>
- <a name="l05918"></a>05918 <span class="comment">! Prepare bisection of the smallest interval.</span>
- <a name="l05919"></a>05919 <span class="comment">!</span>
- <a name="l05920"></a>05920 100 continue
- <a name="l05921"></a>05921
- <a name="l05922"></a>05922 <span class="keyword">if</span> ( numrl2 == 1 ) <span class="keyword">then</span>
- <a name="l05923"></a>05923 noext = .true.
- <a name="l05924"></a>05924 <span class="keyword">end if</span>
- <a name="l05925"></a>05925
- <a name="l05926"></a>05926 <span class="keyword">if</span> ( ier == 5 ) <span class="keyword">then</span>
- <a name="l05927"></a>05927 exit
- <a name="l05928"></a>05928 <span class="keyword">end if</span>
- <a name="l05929"></a>05929
- <a name="l05930"></a>05930 110 continue
- <a name="l05931"></a>05931
- <a name="l05932"></a>05932 maxerr = iord(1)
- <a name="l05933"></a>05933 errmax = elist(maxerr)
- <a name="l05934"></a>05934 nrmax = 1
- <a name="l05935"></a>05935 extrap = .false.
- <a name="l05936"></a>05936 small = small*5.0e-01
- <a name="l05937"></a>05937 erlarg = errsum
- <a name="l05938"></a>05938 cycle
- <a name="l05939"></a>05939
- <a name="l05940"></a>05940 120 continue
- <a name="l05941"></a>05941
- <a name="l05942"></a>05942 small = small * 5.0e-01
- <a name="l05943"></a>05943 numrl2 = numrl2 + 1
- <a name="l05944"></a>05944 rlist2(numrl2) = area
- <a name="l05945"></a>05945
- <a name="l05946"></a>05946 130 continue
- <a name="l05947"></a>05947
- <a name="l05948"></a>05948 ertest = errbnd
- <a name="l05949"></a>05949 erlarg = errsum
- <a name="l05950"></a>05950
- <a name="l05951"></a>05951 140 continue
- <a name="l05952"></a>05952
- <a name="l05953"></a>05953 <span class="keyword">end do</span>
- <a name="l05954"></a>05954 <span class="comment">!</span>
- <a name="l05955"></a>05955 <span class="comment">! set the final result.</span>
- <a name="l05956"></a>05956 <span class="comment">!</span>
- <a name="l05957"></a>05957 <span class="keyword">if</span> ( abserr == huge ( abserr ) .or. nres == 0 ) <span class="keyword">then</span>
- <a name="l05958"></a>05958 go to 170
- <a name="l05959"></a>05959 <span class="keyword">end if</span>
- <a name="l05960"></a>05960
- <a name="l05961"></a>05961 <span class="keyword">if</span> ( ier+ierro == 0 ) go to 165
- <a name="l05962"></a>05962 <span class="keyword">if</span> ( ierro == 3 ) abserr = abserr+correc
- <a name="l05963"></a>05963 <span class="keyword">if</span> ( ier == 0 ) ier = 3
- <a name="l05964"></a>05964 <span class="keyword">if</span> ( result /= 0.0e+00.and.area /= 0.0e+00 ) go to 160
- <a name="l05965"></a>05965 <span class="keyword">if</span> ( abserr > errsum ) go to 170
- <a name="l05966"></a>05966 <span class="keyword">if</span> ( area == 0.0e+00 ) go to 190
- <a name="l05967"></a>05967 go to 165
- <a name="l05968"></a>05968
- <a name="l05969"></a>05969 160 continue
- <a name="l05970"></a>05970
- <a name="l05971"></a>05971 <span class="keyword">if</span> ( abserr/abs(result) > errsum/abs(area) ) go to 170
- <a name="l05972"></a>05972 <span class="comment">!</span>
- <a name="l05973"></a>05973 <span class="comment">! Test on divergence.</span>
- <a name="l05974"></a>05974 <span class="comment">!</span>
- <a name="l05975"></a>05975 165 continue
- <a name="l05976"></a>05976
- <a name="l05977"></a>05977 <span class="keyword">if</span> ( ksgn == (-1) .and. max ( abs(result),abs(area)) <= &
- <a name="l05978"></a>05978 defabs*1.0e-02 ) go to 190
- <a name="l05979"></a>05979
- <a name="l05980"></a>05980 <span class="keyword">if</span> ( 1.0e-02 > (result/area) .or. (result/area) > 1.0e+02 &
- <a name="l05981"></a>05981 .or. errsum >= abs(area) ) ier = 6
- <a name="l05982"></a>05982
- <a name="l05983"></a>05983 go to 190
- <a name="l05984"></a>05984 <span class="comment">!</span>
- <a name="l05985"></a>05985 <span class="comment">! Compute global integral sum.</span>
- <a name="l05986"></a>05986 <span class="comment">!</span>
- <a name="l05987"></a>05987 170 continue
- <a name="l05988"></a>05988
- <a name="l05989"></a>05989 result = sum ( rlist(1:last) )
- <a name="l05990"></a>05990
- <a name="l05991"></a>05991 abserr = errsum
- <a name="l05992"></a>05992
- <a name="l05993"></a>05993 190 continue
- <a name="l05994"></a>05994
- <a name="l05995"></a>05995 <span class="keyword">if</span> (ier > 2) ier=ier-1
- <a name="l05996"></a>05996
- <a name="l05997"></a>05997 200 continue
- <a name="l05998"></a>05998
- <a name="l05999"></a>05999 <span class="keyword">if</span> ( integr == 2 .and. omega < 0.0e+00 ) <span class="keyword">then</span>
- <a name="l06000"></a>06000 result = -result
- <a name="l06001"></a>06001 <span class="keyword">end if</span>
- <a name="l06002"></a>06002
- <a name="l06003"></a>06003 return
- <a name="l06004"></a>06004 <span class="keyword">end</span>
- <a name="l06005"></a><a class="code" href="quadpack_8f90.html#a1722ad5ba07cec52d38c9ebf9df80a2d">06005</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#a1722ad5ba07cec52d38c9ebf9df80a2d">qk15</a> ( f, a, b, result, abserr, resabs, resasc )
- <a name="l06006"></a>06006
- <a name="l06007"></a>06007 <span class="comment">!*****************************************************************************80</span>
- <a name="l06008"></a>06008 <span class="comment">!</span>
- <a name="l06009"></a>06009 <span class="comment">!! QK15 carries out a 15 point Gauss-Kronrod quadrature rule.</span>
- <a name="l06010"></a>06010 <span class="comment">!</span>
- <a name="l06011"></a>06011 <span class="comment">! Discussion:</span>
- <a name="l06012"></a>06012 <span class="comment">!</span>
- <a name="l06013"></a>06013 <span class="comment">! This routine approximates</span>
- <a name="l06014"></a>06014 <span class="comment">! I = integral ( A <= X <= B ) F(X) dx</span>
- <a name="l06015"></a>06015 <span class="comment">! with an error estimate, and</span>
- <a name="l06016"></a>06016 <span class="comment">! J = integral ( A <= X <= B ) | F(X) | dx</span>
- <a name="l06017"></a>06017 <span class="comment">!</span>
- <a name="l06018"></a>06018 <span class="comment">! Author:</span>
- <a name="l06019"></a>06019 <span class="comment">!</span>
- <a name="l06020"></a>06020 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l06021"></a>06021 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l06022"></a>06022 <span class="comment">!</span>
- <a name="l06023"></a>06023 <span class="comment">! Reference:</span>
- <a name="l06024"></a>06024 <span class="comment">!</span>
- <a name="l06025"></a>06025 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l06026"></a>06026 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l06027"></a>06027 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l06028"></a>06028 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l06029"></a>06029 <span class="comment">!</span>
- <a name="l06030"></a>06030 <span class="comment">! Parameters:</span>
- <a name="l06031"></a>06031 <span class="comment">!</span>
- <a name="l06032"></a>06032 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l06033"></a>06033 <span class="comment">! function f ( x )</span>
- <a name="l06034"></a>06034 <span class="comment">! real f</span>
- <a name="l06035"></a>06035 <span class="comment">! real x</span>
- <a name="l06036"></a>06036 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l06037"></a>06037 <span class="comment">!</span>
- <a name="l06038"></a>06038 <span class="comment">! Input, real A, B, the limits of integration.</span>
- <a name="l06039"></a>06039 <span class="comment">!</span>
- <a name="l06040"></a>06040 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l06041"></a>06041 <span class="comment">! RESULT is computed by applying the 15-point Kronrod rule (RESK) </span>
- <a name="l06042"></a>06042 <span class="comment">! obtained by optimal addition of abscissae to the 7-point Gauss rule </span>
- <a name="l06043"></a>06043 <span class="comment">! (RESG).</span>
- <a name="l06044"></a>06044 <span class="comment">!</span>
- <a name="l06045"></a>06045 <span class="comment">! Output, real ABSERR, an estimate of | I - RESULT |.</span>
- <a name="l06046"></a>06046 <span class="comment">!</span>
- <a name="l06047"></a>06047 <span class="comment">! Output, real RESABS, approximation to the integral of the absolute</span>
- <a name="l06048"></a>06048 <span class="comment">! value of F.</span>
- <a name="l06049"></a>06049 <span class="comment">!</span>
- <a name="l06050"></a>06050 <span class="comment">! Output, real RESASC, approximation to the integral | F-I/(B-A) | </span>
- <a name="l06051"></a>06051 <span class="comment">! over [A,B].</span>
- <a name="l06052"></a>06052 <span class="comment">!</span>
- <a name="l06053"></a>06053 <span class="comment">! Local Parameters:</span>
- <a name="l06054"></a>06054 <span class="comment">!</span>
- <a name="l06055"></a>06055 <span class="comment">! the abscissae and weights are given for the interval (-1,1).</span>
- <a name="l06056"></a>06056 <span class="comment">! because of symmetry only the positive abscissae and their</span>
- <a name="l06057"></a>06057 <span class="comment">! corresponding weights are given.</span>
- <a name="l06058"></a>06058 <span class="comment">!</span>
- <a name="l06059"></a>06059 <span class="comment">! xgk - abscissae of the 15-point Kronrod rule</span>
- <a name="l06060"></a>06060 <span class="comment">! xgk(2), xgk(4), ... abscissae of the 7-point</span>
- <a name="l06061"></a>06061 <span class="comment">! Gauss rule</span>
- <a name="l06062"></a>06062 <span class="comment">! xgk(1), xgk(3), ... abscissae which are optimally</span>
- <a name="l06063"></a>06063 <span class="comment">! added to the 7-point Gauss rule</span>
- <a name="l06064"></a>06064 <span class="comment">!</span>
- <a name="l06065"></a>06065 <span class="comment">! wgk - weights of the 15-point Kronrod rule</span>
- <a name="l06066"></a>06066 <span class="comment">!</span>
- <a name="l06067"></a>06067 <span class="comment">! wg - weights of the 7-point Gauss rule</span>
- <a name="l06068"></a>06068 <span class="comment">!</span>
- <a name="l06069"></a>06069 <span class="comment">! centr - mid point of the interval</span>
- <a name="l06070"></a>06070 <span class="comment">! hlgth - half-length of the interval</span>
- <a name="l06071"></a>06071 <span class="comment">! absc - abscissa</span>
- <a name="l06072"></a>06072 <span class="comment">! fval* - function value</span>
- <a name="l06073"></a>06073 <span class="comment">! resg - result of the 7-point Gauss formula</span>
- <a name="l06074"></a>06074 <span class="comment">! resk - result of the 15-point Kronrod formula</span>
- <a name="l06075"></a>06075 <span class="comment">! reskh - approximation to the mean value of f over (a,b),</span>
- <a name="l06076"></a>06076 <span class="comment">! i.e. to i/(b-a)</span>
- <a name="l06077"></a>06077 <span class="comment">!</span>
- <a name="l06078"></a>06078 <span class="keyword">implicit none</span>
- <a name="l06079"></a>06079
- <a name="l06080"></a>06080 <span class="keywordtype">real</span> a
- <a name="l06081"></a>06081 <span class="keywordtype">real</span> absc
- <a name="l06082"></a>06082 <span class="keywordtype">real</span> abserr
- <a name="l06083"></a>06083 <span class="keywordtype">real</span> b
- <a name="l06084"></a>06084 <span class="keywordtype">real</span> centr
- <a name="l06085"></a>06085 <span class="keywordtype">real</span> dhlgth
- <a name="l06086"></a>06086 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l06087"></a>06087 <span class="keywordtype">real</span> fc
- <a name="l06088"></a>06088 <span class="keywordtype">real</span> fsum
- <a name="l06089"></a>06089 <span class="keywordtype">real</span> fval1
- <a name="l06090"></a>06090 <span class="keywordtype">real</span> fval2
- <a name="l06091"></a>06091 <span class="keywordtype">real</span> fv1(7)
- <a name="l06092"></a>06092 <span class="keywordtype">real</span> fv2(7)
- <a name="l06093"></a>06093 <span class="keywordtype">real</span> hlgth
- <a name="l06094"></a>06094 <span class="keywordtype">integer</span> j
- <a name="l06095"></a>06095 <span class="keywordtype">integer</span> jtw
- <a name="l06096"></a>06096 <span class="keywordtype">integer</span> jtwm1
- <a name="l06097"></a>06097 <span class="keywordtype">real</span> resabs
- <a name="l06098"></a>06098 <span class="keywordtype">real</span> resasc
- <a name="l06099"></a>06099 <span class="keywordtype">real</span> resg
- <a name="l06100"></a>06100 <span class="keywordtype">real</span> resk
- <a name="l06101"></a>06101 <span class="keywordtype">real</span> reskh
- <a name="l06102"></a>06102 <span class="keywordtype">real</span> result
- <a name="l06103"></a>06103 <span class="keywordtype">real</span> wg(4)
- <a name="l06104"></a>06104 <span class="keywordtype">real</span> wgk(8)
- <a name="l06105"></a>06105 <span class="keywordtype">real</span> xgk(8)
- <a name="l06106"></a>06106
- <a name="l06107"></a>06107 <span class="keyword">data</span> xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7),xgk(8)/ &
- <a name="l06108"></a>06108 9.914553711208126e-01, 9.491079123427585e-01, &
- <a name="l06109"></a>06109 8.648644233597691e-01, 7.415311855993944e-01, &
- <a name="l06110"></a>06110 5.860872354676911e-01, 4.058451513773972e-01, &
- <a name="l06111"></a>06111 2.077849550078985e-01, 0.0e+00 /
- <a name="l06112"></a>06112 <span class="keyword">data</span> wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7),wgk(8)/ &
- <a name="l06113"></a>06113 2.293532201052922e-02, 6.309209262997855e-02, &
- <a name="l06114"></a>06114 1.047900103222502e-01, 1.406532597155259e-01, &
- <a name="l06115"></a>06115 1.690047266392679e-01, 1.903505780647854e-01, &
- <a name="l06116"></a>06116 2.044329400752989e-01, 2.094821410847278e-01/
- <a name="l06117"></a>06117 <span class="keyword">data</span> wg(1),wg(2),wg(3),wg(4)/ &
- <a name="l06118"></a>06118 1.294849661688697e-01, 2.797053914892767e-01, &
- <a name="l06119"></a>06119 3.818300505051189e-01, 4.179591836734694e-01/
- <a name="l06120"></a>06120 <span class="comment">!</span>
- <a name="l06121"></a>06121 centr = 5.0e-01*(a+b)
- <a name="l06122"></a>06122 hlgth = 5.0e-01*(b-a)
- <a name="l06123"></a>06123 dhlgth = abs(hlgth)
- <a name="l06124"></a>06124 <span class="comment">!</span>
- <a name="l06125"></a>06125 <span class="comment">! Compute the 15-point Kronrod approximation to the integral,</span>
- <a name="l06126"></a>06126 <span class="comment">! and estimate the absolute error.</span>
- <a name="l06127"></a>06127 <span class="comment">!</span>
- <a name="l06128"></a>06128 fc = f(centr)
- <a name="l06129"></a>06129 resg = fc*wg(4)
- <a name="l06130"></a>06130 resk = fc*wgk(8)
- <a name="l06131"></a>06131 resabs = abs(resk)
- <a name="l06132"></a>06132
- <a name="l06133"></a>06133 <span class="keyword">do</span> j = 1, 3
- <a name="l06134"></a>06134 jtw = j*2
- <a name="l06135"></a>06135 absc = hlgth*xgk(jtw)
- <a name="l06136"></a>06136 fval1 = f(centr-absc)
- <a name="l06137"></a>06137 fval2 = f(centr+absc)
- <a name="l06138"></a>06138 fv1(jtw) = fval1
- <a name="l06139"></a>06139 fv2(jtw) = fval2
- <a name="l06140"></a>06140 fsum = fval1+fval2
- <a name="l06141"></a>06141 resg = resg+wg(j)*fsum
- <a name="l06142"></a>06142 resk = resk+wgk(jtw)*fsum
- <a name="l06143"></a>06143 resabs = resabs+wgk(jtw)*(abs(fval1)+abs(fval2))
- <a name="l06144"></a>06144 <span class="keyword">end do</span>
- <a name="l06145"></a>06145
- <a name="l06146"></a>06146 <span class="keyword">do</span> j = 1, 4
- <a name="l06147"></a>06147 jtwm1 = j*2-1
- <a name="l06148"></a>06148 absc = hlgth*xgk(jtwm1)
- <a name="l06149"></a>06149 fval1 = f(centr-absc)
- <a name="l06150"></a>06150 fval2 = f(centr+absc)
- <a name="l06151"></a>06151 fv1(jtwm1) = fval1
- <a name="l06152"></a>06152 fv2(jtwm1) = fval2
- <a name="l06153"></a>06153 fsum = fval1+fval2
- <a name="l06154"></a>06154 resk = resk+wgk(jtwm1)*fsum
- <a name="l06155"></a>06155 resabs = resabs+wgk(jtwm1)*(abs(fval1)+abs(fval2))
- <a name="l06156"></a>06156 <span class="keyword">end do</span>
- <a name="l06157"></a>06157
- <a name="l06158"></a>06158 reskh = resk * 5.0e-01
- <a name="l06159"></a>06159 resasc = wgk(8)*abs(fc-reskh)
- <a name="l06160"></a>06160
- <a name="l06161"></a>06161 <span class="keyword">do</span> j = 1, 7
- <a name="l06162"></a>06162 resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh))
- <a name="l06163"></a>06163 <span class="keyword">end do</span>
- <a name="l06164"></a>06164
- <a name="l06165"></a>06165 result = resk*hlgth
- <a name="l06166"></a>06166 resabs = resabs*dhlgth
- <a name="l06167"></a>06167 resasc = resasc*dhlgth
- <a name="l06168"></a>06168 abserr = abs((resk-resg)*hlgth)
- <a name="l06169"></a>06169
- <a name="l06170"></a>06170 <span class="keyword">if</span> ( resasc /= 0.0e+00.and.abserr /= 0.0e+00 ) <span class="keyword">then</span>
- <a name="l06171"></a>06171 abserr = resasc*min ( 1.0e+00,(2.0e+02*abserr/resasc)**1.5e+00)
- <a name="l06172"></a>06172 <span class="keyword">end if</span>
- <a name="l06173"></a>06173
- <a name="l06174"></a>06174 <span class="keyword">if</span> ( resabs > tiny ( resabs ) / (5.0e+01* epsilon ( resabs ) ) ) <span class="keyword">then</span>
- <a name="l06175"></a>06175 abserr = max (( epsilon ( resabs ) *5.0e+01)*resabs,abserr)
- <a name="l06176"></a>06176 <span class="keyword">end if</span>
- <a name="l06177"></a>06177
- <a name="l06178"></a>06178 return
- <a name="l06179"></a>06179 <span class="keyword">end</span>
- <a name="l06180"></a><a class="code" href="quadpack_8f90.html#a59164415fc33f2f3bf4ebc4ee2220f7e">06180</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#a59164415fc33f2f3bf4ebc4ee2220f7e">qk15i</a> ( f, boun, inf, a, b, result, abserr, resabs, resasc )
- <a name="l06181"></a>06181
- <a name="l06182"></a>06182 <span class="comment">!*****************************************************************************80</span>
- <a name="l06183"></a>06183 <span class="comment">!</span>
- <a name="l06184"></a>06184 <span class="comment">!! QK15I applies a 15 point Gauss-Kronrod quadrature on an infinite interval.</span>
- <a name="l06185"></a>06185 <span class="comment">!</span>
- <a name="l06186"></a>06186 <span class="comment">! Discussion:</span>
- <a name="l06187"></a>06187 <span class="comment">!</span>
- <a name="l06188"></a>06188 <span class="comment">! The original infinite integration range is mapped onto the interval </span>
- <a name="l06189"></a>06189 <span class="comment">! (0,1) and (a,b) is a part of (0,1). The routine then computes:</span>
- <a name="l06190"></a>06190 <span class="comment">!</span>
- <a name="l06191"></a>06191 <span class="comment">! i = integral of transformed integrand over (a,b),</span>
- <a name="l06192"></a>06192 <span class="comment">! j = integral of abs(transformed integrand) over (a,b).</span>
- <a name="l06193"></a>06193 <span class="comment">!</span>
- <a name="l06194"></a>06194 <span class="comment">! Author:</span>
- <a name="l06195"></a>06195 <span class="comment">!</span>
- <a name="l06196"></a>06196 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l06197"></a>06197 <span class="comment">! Christian Ueberhuber, David Kahaner</span>
- <a name="l06198"></a>06198 <span class="comment">!</span>
- <a name="l06199"></a>06199 <span class="comment">! Reference:</span>
- <a name="l06200"></a>06200 <span class="comment">!</span>
- <a name="l06201"></a>06201 <span class="comment">! Robert Piessens, Elise de Doncker-Kapenger, </span>
- <a name="l06202"></a>06202 <span class="comment">! Christian Ueberhuber, David Kahaner,</span>
- <a name="l06203"></a>06203 <span class="comment">! QUADPACK, a Subroutine Package for Automatic Integration,</span>
- <a name="l06204"></a>06204 <span class="comment">! Springer Verlag, 1983</span>
- <a name="l06205"></a>06205 <span class="comment">!</span>
- <a name="l06206"></a>06206 <span class="comment">! Parameters:</span>
- <a name="l06207"></a>06207 <span class="comment">!</span>
- <a name="l06208"></a>06208 <span class="comment">! Input, external real F, the name of the function routine, of the form</span>
- <a name="l06209"></a>06209 <span class="comment">! function f ( x )</span>
- <a name="l06210"></a>06210 <span class="comment">! real f</span>
- <a name="l06211"></a>06211 <span class="comment">! real x</span>
- <a name="l06212"></a>06212 <span class="comment">! which evaluates the integrand function.</span>
- <a name="l06213"></a>06213 <span class="comment">!</span>
- <a name="l06214"></a>06214 <span class="comment">! Input, real BOUN, the finite bound of the original integration range,</span>
- <a name="l06215"></a>06215 <span class="comment">! or zero if INF is 2.</span>
- <a name="l06216"></a>06216 <span class="comment">!</span>
- <a name="l06217"></a>06217 <span class="comment">! Input, integer INF, indicates the type of the interval.</span>
- <a name="l06218"></a>06218 <span class="comment">! -1: the original interval is (-infinity,BOUN),</span>
- <a name="l06219"></a>06219 <span class="comment">! +1, the original interval is (BOUN,+infinity),</span>
- <a name="l06220"></a>06220 <span class="comment">! +2, the original interval is (-infinity,+infinity) and</span>
- <a name="l06221"></a>06221 <span class="comment">! the integral is computed as the sum of two integrals, one </span>
- <a name="l06222"></a>06222 <span class="comment">! over (-infinity,0) and one over (0,+infinity).</span>
- <a name="l06223"></a>06223 <span class="comment">!</span>
- <a name="l06224"></a>06224 <span class="comment">! Input, real A, B, the limits of integration, over a subrange of [0,1].</span>
- <a name="l06225"></a>06225 <span class="comment">!</span>
- <a name="l06226"></a>06226 <span class="comment">! Output, real RESULT, the estimated value of the integral.</span>
- <a name="l06227"></a>06227 <span class="comment">! RESULT is computed by applying the 15-point Kronrod rule (RESK) obtained </span>
- <a name="l06228"></a>06228 <span class="comment">! by optimal addition of abscissae to the 7-point Gauss rule (RESG).</span>
- <a name="l06229"></a>06229 <span class="comment">!</span>
- <a name="l06230"></a>06230 <span class="comment">! Output, real ABSERR, an estimate of | I - RESULT |.</span>
- <a name="l06231"></a>06231 <span class="comment">!</span>
- <a name="l06232"></a>06232 <span class="comment">! Output, real RESABS, approximation to the integral of the absolute</span>
- <a name="l06233"></a>06233 <span class="comment">! value of F.</span>
- <a name="l06234"></a>06234 <span class="comment">!</span>
- <a name="l06235"></a>06235 <span class="comment">! Output, real RESASC, approximation to the integral of the</span>
- <a name="l06236"></a>06236 <span class="comment">! transformated integrand | F-I/(B-A) | over [A,B].</span>
- <a name="l06237"></a>06237 <span class="comment">!</span>
- <a name="l06238"></a>06238 <span class="comment">! Local Parameters:</span>
- <a name="l06239"></a>06239 <span class="comment">!</span>
- <a name="l06240"></a>06240 <span class="comment">! centr - mid point of the interval</span>
- <a name="l06241"></a>06241 <span class="comment">! hlgth - half-length of the interval</span>
- <a name="l06242"></a>06242 <span class="comment">! absc* - abscissa</span>
- <a name="l06243"></a>06243 <span class="comment">! tabsc* - transformed abscissa</span>
- <a name="l06244"></a>06244 <span class="comment">! fval* - function value</span>
- <a name="l06245"></a>06245 <span class="comment">! resg - result of the 7-point Gauss formula</span>
- <a name="l06246"></a>06246 <span class="comment">! resk - result of the 15-point Kronrod formula</span>
- <a name="l06247"></a>06247 <span class="comment">! reskh - approximation to the mean value of the transformed</span>
- <a name="l06248"></a>06248 <span class="comment">! integrand over (a,b), i.e. to i/(b-a)</span>
- <a name="l06249"></a>06249 <span class="comment">!</span>
- <a name="l06250"></a>06250 <span class="keyword">implicit none</span>
- <a name="l06251"></a>06251
- <a name="l06252"></a>06252 <span class="keywordtype">real</span> a
- <a name="l06253"></a>06253 <span class="keywordtype">real</span> absc
- <a name="l06254"></a>06254 <span class="keywordtype">real</span> absc1
- <a name="l06255"></a>06255 <span class="keywordtype">real</span> absc2
- <a name="l06256"></a>06256 <span class="keywordtype">real</span> abserr
- <a name="l06257"></a>06257 <span class="keywordtype">real</span> b
- <a name="l06258"></a>06258 <span class="keywordtype">real</span> boun
- <a name="l06259"></a>06259 <span class="keywordtype">real</span> centr
- <a name="l06260"></a>06260 <span class="keywordtype">real</span> dinf
- <a name="l06261"></a>06261 <span class="keywordtype">real</span>, <span class="keywordtype">external</span> :: f
- <a name="l06262"></a>06262 <span class="keywordtype">real</span> fc
- <a name="l06263"></a>06263 <span class="keywordtype">real</span> fsum
- <a name="l06264"></a>06264 <span class="keywordtype">real</span> fval1
- <a name="l06265"></a>06265 <span class="keywordtype">real</span> fval2
- <a name="l06266"></a>06266 <span class="keywordtype">real</span> fv1(7)
- <a name="l06267"></a>06267 <span class="keywordtype">real</span> fv2(7)
- <a name="l06268"></a>06268 <span class="keywordtype">real</span> hlgth
- <a name="l06269"></a>06269 <span class="keywordtype">integer</span> inf
- <a name="l06270"></a>06270 <span class="keywordtype">integer</span> j
- <a name="l06271"></a>06271 <span class="keywordtype">real</span> resabs
- <a name="l06272"></a>06272 <span class="keywordtype">real</span> resasc
- <a name="l06273"></a>06273 <span class="keywordtype">real</span> resg
- <a name="l06274"></a>06274 <span class="keywordtype">real</span> resk
- <a name="l06275"></a>06275 <span class="keywordtype">real</span> reskh
- <a name="l06276"></a>06276 <span class="keywordtype">real</span> result
- <a name="l06277"></a>06277 <span class="keywordtype">real</span> tabsc1
- <a name="l06278"></a>06278 <span class="keywordtype">real</span> tabsc2
- <a name="l06279"></a>06279 <span class="keywordtype">real</span> wg(8)
- <a name="l06280"></a>06280 <span class="keywordtype">real</span> wgk(8)
- <a name="l06281"></a>06281 <span class="keywordtype">real</span> xgk(8)
- <a name="l06282"></a>06282 <span class="comment">!</span>
- <a name="l06283"></a>06283 <span class="comment">! the abscissae and weights are supplied for the interval</span>
- <a name="l06284"></a>06284 <span class="comment">! (-1,1). because of symmetry only the positive abscissae and</span>
- <a name="l06285"></a>06285 <span class="comment">! their corresponding weights are given.</span>
- <a name="l06286"></a>06286 <span class="comment">!</span>
- <a name="l06287"></a>06287 <span class="comment">! xgk - abscissae of the 15-point Kronrod rule</span>
- <a name="l06288"></a>06288 <span class="comment">! xgk(2), xgk(4), ... abscissae of the 7-point Gauss</span>
- <a name="l06289"></a>06289 <span class="comment">! rule</span>
- <a name="l06290"></a>06290 <span class="comment">! xgk(1), xgk(3), ... abscissae which are optimally</span>
- <a name="l06291"></a>06291 <span class="comment">! added to the 7-point Gauss rule</span>
- <a name="l06292"></a>06292 <span class="comment">!</span>
- <a name="l06293"></a>06293 <span class="comment">! wgk - weights of the 15-point Kronrod rule</span>
- <a name="l06294"></a>06294 <span class="comment">!</span>
- <a name="l06295"></a>06295 <span class="comment">! wg - weights of the 7-point Gauss rule, corresponding</span>
- <a name="l06296"></a>06296 <span class="comment">! to the abscissae xgk(2), xgk(4), ...</span>
- <a name="l06297"></a>06297 <span class="comment">! wg(1), wg(3), ... are set to zero.</span>
- <a name="l06298"></a>06298 <span class="comment">!</span>
- <a name="l06299"></a>06299 <span class="keyword">data</span> xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7),xgk(8)/ &
- <a name="l06300"></a>06300 9.914553711208126e-01, 9.491079123427585e-01, &
- <a name="l06301"></a>06301 8.648644233597691e-01, 7.415311855993944e-01, &
- <a name="l06302"></a>06302 5.860872354676911e-01, 4.058451513773972e-01, &
- <a name="l06303"></a>06303 2.077849550078985e-01, 0.0000000000000000e+00/
- <a name="l06304"></a>06304
- <a name="l06305"></a>06305 <span class="keyword">data</span> wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7),wgk(8)/ &
- <a name="l06306"></a>06306 2.293532201052922e-02, 6.309209262997855e-02, &
- <a name="l06307"></a>06307 1.047900103222502e-01, 1.406532597155259e-01, &
- <a name="l06308"></a>06308 1.690047266392679e-01, 1.903505780647854e-01, &
- <a name="l06309"></a>06309 2.044329400752989e-01, 2.094821410847278e-01/
- <a name="l06310"></a>06310
- <a name="l06311"></a>06311 <span class="keyword">data</span> wg(1),wg(2),wg(3),wg(4),wg(5),wg(6),wg(7),wg(8)/ &
- <a name="l06312"></a>06312 0.0000000000000000e+00, 1.294849661688697e-01, &
- <a name="l06313"></a>06313 0.0000000000000000e+00, 2.797053914892767e-01, &
- <a name="l06314"></a>06314 0.0000000000000000e+00, 3.818300505051189e-01, &
- <a name="l06315"></a>06315 0.0000000000000000e+00, 4.179591836734694e-01/
- <a name="l06316"></a>06316
- <a name="l06317"></a>06317 dinf = min ( 1, inf )
- <a name="l06318"></a>06318
- <a name="l06319"></a>06319 centr = 5.0e-01*(a+b)
- <a name="l06320"></a>06320 hlgth = 5.0e-01*(b-a)
- <a name="l06321"></a>06321 tabsc1 = boun+dinf*(1.0e+00-centr)/centr
- <a name="l06322"></a>06322 fval1 = f(tabsc1)
- <a name="l06323"></a>06323 <span class="keyword">if</span> ( inf == 2 ) fval1 = fval1+f(-tabsc1)
- <a name="l06324"></a>06324 fc = (fval1/centr)/centr
- <a name="l06325"></a>06325 <span class="comment">!</span>
- <a name="l06326"></a>06326 <span class="comment">! Compute the 15-point Kronrod approximation to the integral,</span>
- <a name="l06327"></a>06327 <span class="comment">! and estimate the error.</span>
- <a name="l06328"></a>06328 <span class="comment">!</span>
- <a name="l06329"></a>06329 resg = wg(8)*fc
- <a name="l06330"></a>06330 resk = wgk(8)*fc
- <a name="l06331"></a>06331 resabs = abs(resk)
- <a name="l06332"></a>06332
- <a name="l06333"></a>06333 <span class="keyword">do</span> j = 1, 7
- <a name="l06334"></a>06334
- <a name="l06335"></a>06335 absc = hlgth*xgk(j)
- <a name="l06336"></a>06336 absc1 = centr-absc
- <a name="l06337"></a>06337 absc2 = centr+absc
- <a name="l06338"></a>06338 tabsc1 = boun+dinf*(1.0e+00-absc1)/absc1
- <a name="l06339"></a>06339 tabsc2 = boun+dinf*(1.0e+00-absc2)/absc2
- <a name="l06340"></a>06340 fval1 = f(tabsc1)
- <a name="l06341"></a>06341 fval2 = f(tabsc2)
- <a name="l06342"></a>06342
- <a name="l06343"></a>06343 <span class="keyword">if</span> ( inf == 2 ) <span class="keyword">then</span>
- <a name="l06344"></a>06344 fval1 = fval1+f(-tabsc1)
- <a name="l06345"></a>06345 fval2 = fval2+f(-tabsc2)
- <a name="l06346"></a>06346 <span class="keyword">end if</span>
- <a name="l06347"></a>06347
- <a name="l06348"></a>06348 fval1 = (fval1/absc1)/absc1
- <a name="l06349"></a>06349 fval2 = (fval2/absc2)/absc2
- <a name="l06350"></a>06350 fv1(j) = fval1
- <a name="l06351"></a>06351 fv2(j) = fval2
- <a name="l06352"></a>06352 fsum = fval1+fval2
- <a name="l06353"></a>06353 resg = resg+wg(j)*fsum
- <a name="l06354"></a>06354 resk = resk+wgk(j)*fsum
- <a name="l06355"></a>06355 resabs = resabs+wgk(j)*(abs(fval1)+abs(fval2))
- <a name="l06356"></a>06356 <span class="keyword">end do</span>
- <a name="l06357"></a>06357
- <a name="l06358"></a>06358 reskh = resk * 5.0e-01
- <a name="l06359"></a>06359 resasc = wgk(8) * abs(fc-reskh)
- <a name="l06360"></a>06360
- <a name="l06361"></a>06361 <span class="keyword">do</span> j = 1, 7
- <a name="l06362"></a>06362 resasc = resasc + wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh))
- <a name="l06363"></a>06363 <span class="keyword">end do</span>
- <a name="l06364"></a>06364
- <a name="l06365"></a>06365 result = resk * hlgth
- <a name="l06366"></a>06366 resasc = resasc * hlgth
- <a name="l06367"></a>06367 resabs = resabs * hlgth
- <a name="l06368"></a>06368 abserr = abs ( ( resk - resg ) * hlgth )
- <a name="l06369"></a>06369
- <a name="l06370"></a>06370 <span class="keyword">if</span> ( resasc /= 0.0e+00.and.abserr /= 0.0e+00) <span class="keyword">then</span>
- <a name="l06371"></a>06371 abserr = resasc* min ( 1.0e+00,(2.0e+02*abserr/resasc)**1.5e+00)
- <a name="l06372"></a>06372 <span class="keyword">end if</span>
- <a name="l06373"></a>06373
- <a name="l06374"></a>06374 <span class="keyword">if</span> ( resabs > tiny ( resabs ) / ( 5.0e+01 * epsilon ( resabs ) ) ) <span class="keyword">then</span>
- <a name="l06375"></a>06375 abserr = max (( epsilon ( resabs ) *5.0e+01)*resabs,abserr)
- <a name="l06376"></a>06376 <span class="keyword">end if</span>
- <a name="l06377"></a>06377
- <a name="l06378"></a>06378 return
- <a name="l06379"></a>06379 <span class="keyword">end</span>
- <a name="l06380"></a><a class="code" href="quadpack_8f90.html#a0c083838940925726abd5bc85fa29587">06380</a> <span class="keyword">subroutine </span><a class="code" href="quadpack_8f90.html#a0c083838940925726abd5bc85fa29587">qk15w</a> ( f, w, p1, p2, p3, p4, kp, a, b, result, abserr, resabs, &
- <a name="l06381"></a>06381 resasc )
- <a name="l06382"></a>06382
- <a name="l06383"></a>06383 <span class="comment">!*****************************************************************************80</span>
- <a name="l06384"></