gsl_inte_qag_b.h

00001 /*
00002   -------------------------------------------------------------------
00003 
00004   Copyright (C) 2006, 2007, Andrew W. Steiner
00005 
00006   This file is part of O2scl.
00007 
00008   O2scl is free software; you can redistribute it and/or modify
00009   it under the terms of the GNU General Public License as published by
00010   the Free Software Foundation; either version 3 of the License, or
00011   (at your option) any later version.
00012 
00013   O2scl is distributed in the hope that it will be useful,
00014   but WITHOUT ANY WARRANTY; without even the implied warranty of
00015   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00016   GNU General Public License for more details.
00017 
00018   You should have received a copy of the GNU General Public License
00019   along with O2scl. If not, see <http://www.gnu.org/licenses/>.
00020 
00021   -------------------------------------------------------------------
00022 */
00023 #ifndef O2SCL_GSL_INTE_QAG_B_H
00024 #define O2SCL_GSL_INTE_QAG_B_H
00025 
00026 #include <cmath>
00027 #include <gsl/gsl_integration.h>
00028 #include <o2scl/inte.h>
00029 #include <o2scl/gsl_inte.h>
00030 
00031 /** 
00032     \brief A namespace for the GSL adaptive integration coefficients
00033 
00034     <b>Documentation from GSL</b>: \n    
00035     Gauss quadrature weights and kronrod quadrature abscissae and
00036     weights as evaluated with 80 decimal digit arithmetic by
00037     L. W. Fullerton, Bell Labs, Nov. 1981.
00038 */
00039 namespace o2scl_inte_qag_coeffs {
00040   
00041   /** abscissae of the 15-point kronrod rule */
00042   static const double qk15_xgk[8] =    
00043     {
00044       0.991455371120812639206854697526329,
00045       0.949107912342758524526189684047851,
00046       0.864864423359769072789712788640926,
00047       0.741531185599394439863864773280788,
00048       0.586087235467691130294144838258730,
00049       0.405845151377397166906606412076961,
00050       0.207784955007898467600689403773245,
00051       0.000000000000000000000000000000000
00052     };
00053 
00054   /* xgk[1], xgk[3], ... abscissae of the 7-point gauss rule. 
00055      xgk[0], xgk[2], ... abscissae to optimally extend the 7-point 
00056      gauss rule */
00057 
00058   /** weights of the 7-point gauss rule */
00059   static const double qk15_wg[4] =     
00060     {
00061       0.129484966168869693270611432679082,
00062       0.279705391489276667901467771423780,
00063       0.381830050505118944950369775488975,
00064       0.417959183673469387755102040816327
00065     };
00066 
00067   /** weights of the 15-point kronrod rule */
00068   static const double qk15_wgk[8] =    
00069     {
00070       0.022935322010529224963732008058970,
00071       0.063092092629978553290700663189204,
00072       0.104790010322250183839876322541518,
00073       0.140653259715525918745189590510238,
00074       0.169004726639267902826583426598550,
00075       0.190350578064785409913256402421014,
00076       0.204432940075298892414161999234649,
00077       0.209482141084727828012999174891714
00078     };
00079 
00080   /** abscissae of the 21-point kronrod rule */
00081   static const double qk21_xgk[11] =   
00082     {
00083       0.995657163025808080735527280689003,
00084       0.973906528517171720077964012084452,
00085       0.930157491355708226001207180059508,
00086       0.865063366688984510732096688423493,
00087       0.780817726586416897063717578345042,
00088       0.679409568299024406234327365114874,
00089       0.562757134668604683339000099272694,
00090       0.433395394129247190799265943165784,
00091       0.294392862701460198131126603103866,
00092       0.148874338981631210884826001129720,
00093       0.000000000000000000000000000000000
00094     };
00095 
00096   /* xgk[1], xgk[3], ...abscissae of the 10-point gauss rule. 
00097      xgk[0], xgk[2], ...abscissae to optimally extend the 10-point 
00098      gauss rule */
00099 
00100   /** weights of the 10-point gauss rule */
00101   static const double qk21_wg[5] =     
00102     {
00103       0.066671344308688137593568809893332,
00104       0.149451349150580593145776339657697,
00105       0.219086362515982043995534934228163,
00106       0.269266719309996355091226921569469,
00107       0.295524224714752870173892994651338
00108     };
00109 
00110   /** weights of the 21-point kronrod rule */
00111   static const double qk21_wgk[11] =   
00112     {
00113       0.011694638867371874278064396062192,
00114       0.032558162307964727478818972459390,
00115       0.054755896574351996031381300244580,
00116       0.075039674810919952767043140916190,
00117       0.093125454583697605535065465083366,
00118       0.109387158802297641899210590325805,
00119       0.123491976262065851077958109831074,
00120       0.134709217311473325928054001771707,
00121       0.142775938577060080797094273138717,
00122       0.147739104901338491374841515972068,
00123       0.149445554002916905664936468389821
00124     };
00125 
00126   /** abscissae of the 31-point kronrod rule */
00127   static const double qk31_xgk[16] =   
00128     {
00129       0.998002298693397060285172840152271,
00130       0.987992518020485428489565718586613,
00131       0.967739075679139134257347978784337,
00132       0.937273392400705904307758947710209,
00133       0.897264532344081900882509656454496,
00134       0.848206583410427216200648320774217,
00135       0.790418501442465932967649294817947,
00136       0.724417731360170047416186054613938,
00137       0.650996741297416970533735895313275,
00138       0.570972172608538847537226737253911,
00139       0.485081863640239680693655740232351,
00140       0.394151347077563369897207370981045,
00141       0.299180007153168812166780024266389,
00142       0.201194093997434522300628303394596,
00143       0.101142066918717499027074231447392,
00144       0.000000000000000000000000000000000
00145     };
00146 
00147   /* xgk[1], xgk[3], ...abscissae of the 15-point gauss rule. 
00148      xgk[0], xgk[2], ...abscissae to optimally extend the 15-point 
00149      gauss rule */
00150 
00151   /** weights of the 15-point gauss rule */
00152   static const double qk31_wg[8] =     
00153     {
00154       0.030753241996117268354628393577204,
00155       0.070366047488108124709267416450667,
00156       0.107159220467171935011869546685869,
00157       0.139570677926154314447804794511028,
00158       0.166269205816993933553200860481209,
00159       0.186161000015562211026800561866423,
00160       0.198431485327111576456118326443839,
00161       0.202578241925561272880620199967519
00162     };
00163 
00164   /** weights of the 31-point kronrod rule */
00165   static const double qk31_wgk[16] =   
00166     {
00167       0.005377479872923348987792051430128,
00168       0.015007947329316122538374763075807,
00169       0.025460847326715320186874001019653,
00170       0.035346360791375846222037948478360,
00171       0.044589751324764876608227299373280,
00172       0.053481524690928087265343147239430,
00173       0.062009567800670640285139230960803,
00174       0.069854121318728258709520077099147,
00175       0.076849680757720378894432777482659,
00176       0.083080502823133021038289247286104,
00177       0.088564443056211770647275443693774,
00178       0.093126598170825321225486872747346,
00179       0.096642726983623678505179907627589,
00180       0.099173598721791959332393173484603,
00181       0.100769845523875595044946662617570,
00182       0.101330007014791549017374792767493
00183     };
00184 
00185   /** abscissae of the 41-point kronrod rule */
00186   static const double qk41_xgk[21] =   
00187     {
00188       0.998859031588277663838315576545863,
00189       0.993128599185094924786122388471320,
00190       0.981507877450250259193342994720217,
00191       0.963971927277913791267666131197277,
00192       0.940822633831754753519982722212443,
00193       0.912234428251325905867752441203298,
00194       0.878276811252281976077442995113078,
00195       0.839116971822218823394529061701521,
00196       0.795041428837551198350638833272788,
00197       0.746331906460150792614305070355642,
00198       0.693237656334751384805490711845932,
00199       0.636053680726515025452836696226286,
00200       0.575140446819710315342946036586425,
00201       0.510867001950827098004364050955251,
00202       0.443593175238725103199992213492640,
00203       0.373706088715419560672548177024927,
00204       0.301627868114913004320555356858592,
00205       0.227785851141645078080496195368575,
00206       0.152605465240922675505220241022678,
00207       0.076526521133497333754640409398838,
00208       0.000000000000000000000000000000000
00209     };
00210 
00211   /* xgk[1], xgk[3], ...abscissae of the 20-point gauss rule. 
00212      xgk[0], xgk[2], ...abscissae to optimally extend the 20-point 
00213      gauss rule */
00214 
00215   /** weights of the 20-point gauss rule */
00216   static const double qk41_wg[11] =    
00217     {
00218       0.017614007139152118311861962351853,
00219       0.040601429800386941331039952274932,
00220       0.062672048334109063569506535187042,
00221       0.083276741576704748724758143222046,
00222       0.101930119817240435036750135480350,
00223       0.118194531961518417312377377711382,
00224       0.131688638449176626898494499748163,
00225       0.142096109318382051329298325067165,
00226       0.149172986472603746787828737001969,
00227       0.152753387130725850698084331955098
00228     };
00229 
00230   /** weights of the 41-point kronrod rule */
00231   static const double qk41_wgk[21] =   
00232     {
00233       0.003073583718520531501218293246031,
00234       0.008600269855642942198661787950102,
00235       0.014626169256971252983787960308868,
00236       0.020388373461266523598010231432755,
00237       0.025882133604951158834505067096153,
00238       0.031287306777032798958543119323801,
00239       0.036600169758200798030557240707211,
00240       0.041668873327973686263788305936895,
00241       0.046434821867497674720231880926108,
00242       0.050944573923728691932707670050345,
00243       0.055195105348285994744832372419777,
00244       0.059111400880639572374967220648594,
00245       0.062653237554781168025870122174255,
00246       0.065834597133618422111563556969398,
00247       0.068648672928521619345623411885368,
00248       0.071054423553444068305790361723210,
00249       0.073030690332786667495189417658913,
00250       0.074582875400499188986581418362488,
00251       0.075704497684556674659542775376617,
00252       0.076377867672080736705502835038061,
00253       0.076600711917999656445049901530102
00254     };
00255 
00256   /** abscissae of the 51-point kronrod rule */
00257   static const double qk51_xgk[26] =   
00258     {
00259       0.999262104992609834193457486540341,
00260       0.995556969790498097908784946893902,
00261       0.988035794534077247637331014577406,
00262       0.976663921459517511498315386479594,
00263       0.961614986425842512418130033660167,
00264       0.942974571228974339414011169658471,
00265       0.920747115281701561746346084546331,
00266       0.894991997878275368851042006782805,
00267       0.865847065293275595448996969588340,
00268       0.833442628760834001421021108693570,
00269       0.797873797998500059410410904994307,
00270       0.759259263037357630577282865204361,
00271       0.717766406813084388186654079773298,
00272       0.673566368473468364485120633247622,
00273       0.626810099010317412788122681624518,
00274       0.577662930241222967723689841612654,
00275       0.526325284334719182599623778158010,
00276       0.473002731445714960522182115009192,
00277       0.417885382193037748851814394594572,
00278       0.361172305809387837735821730127641,
00279       0.303089538931107830167478909980339,
00280       0.243866883720988432045190362797452,
00281       0.183718939421048892015969888759528,
00282       0.122864692610710396387359818808037,
00283       0.061544483005685078886546392366797,
00284       0.000000000000000000000000000000000
00285     };
00286 
00287   /* xgk[1], xgk[3], ...abscissae of the 25-point gauss rule. 
00288      xgk[0], xgk[2], ...abscissae to optimally extend the 25-point 
00289      gauss rule */
00290 
00291   /** weights of the 25-point gauss rule */
00292   static const double qk51_wg[13] =    
00293     {
00294       0.011393798501026287947902964113235,
00295       0.026354986615032137261901815295299,
00296       0.040939156701306312655623487711646,
00297       0.054904695975835191925936891540473,
00298       0.068038333812356917207187185656708,
00299       0.080140700335001018013234959669111,
00300       0.091028261982963649811497220702892,
00301       0.100535949067050644202206890392686,
00302       0.108519624474263653116093957050117,
00303       0.114858259145711648339325545869556,
00304       0.119455763535784772228178126512901,
00305       0.122242442990310041688959518945852,
00306       0.123176053726715451203902873079050
00307     };
00308 
00309   /** weights of the 51-point kronrod rule */
00310   static const double qk51_wgk[26] =   
00311     {
00312       0.001987383892330315926507851882843,
00313       0.005561932135356713758040236901066,
00314       0.009473973386174151607207710523655,
00315       0.013236229195571674813656405846976,
00316       0.016847817709128298231516667536336,
00317       0.020435371145882835456568292235939,
00318       0.024009945606953216220092489164881,
00319       0.027475317587851737802948455517811,
00320       0.030792300167387488891109020215229,
00321       0.034002130274329337836748795229551,
00322       0.037116271483415543560330625367620,
00323       0.040083825504032382074839284467076,
00324       0.042872845020170049476895792439495,
00325       0.045502913049921788909870584752660,
00326       0.047982537138836713906392255756915,
00327       0.050277679080715671963325259433440,
00328       0.052362885806407475864366712137873,
00329       0.054251129888545490144543370459876,
00330       0.055950811220412317308240686382747,
00331       0.057437116361567832853582693939506,
00332       0.058689680022394207961974175856788,
00333       0.059720340324174059979099291932562,
00334       0.060539455376045862945360267517565,
00335       0.061128509717053048305859030416293,
00336       0.061471189871425316661544131965264,
00337       0.061580818067832935078759824240066
00338     };
00339 
00340   /* wgk[25] was calculated from the values of wgk[0..24] */
00341 
00342   /** abscissae of the 61-point kronrod rule */
00343   static const double qk61_xgk[31] =   
00344     {
00345       0.999484410050490637571325895705811,
00346       0.996893484074649540271630050918695,
00347       0.991630996870404594858628366109486,
00348       0.983668123279747209970032581605663,
00349       0.973116322501126268374693868423707,
00350       0.960021864968307512216871025581798,
00351       0.944374444748559979415831324037439,
00352       0.926200047429274325879324277080474,
00353       0.905573307699907798546522558925958,
00354       0.882560535792052681543116462530226,
00355       0.857205233546061098958658510658944,
00356       0.829565762382768397442898119732502,
00357       0.799727835821839083013668942322683,
00358       0.767777432104826194917977340974503,
00359       0.733790062453226804726171131369528,
00360       0.697850494793315796932292388026640,
00361       0.660061064126626961370053668149271,
00362       0.620526182989242861140477556431189,
00363       0.579345235826361691756024932172540,
00364       0.536624148142019899264169793311073,
00365       0.492480467861778574993693061207709,
00366       0.447033769538089176780609900322854,
00367       0.400401254830394392535476211542661,
00368       0.352704725530878113471037207089374,
00369       0.304073202273625077372677107199257,
00370       0.254636926167889846439805129817805,
00371       0.204525116682309891438957671002025,
00372       0.153869913608583546963794672743256,
00373       0.102806937966737030147096751318001,
00374       0.051471842555317695833025213166723,
00375       0.000000000000000000000000000000000
00376     };
00377 
00378   /* xgk[1], xgk[3], ... abscissae of the 30-point gauss rule. 
00379      xgk[0], xgk[2], ... abscissae to optimally extend the 30-point 
00380      gauss rule */
00381 
00382   /** weights of the 30-point gauss rule */
00383   static const double qk61_wg[15] =    
00384     {
00385       0.007968192496166605615465883474674,
00386       0.018466468311090959142302131912047,
00387       0.028784707883323369349719179611292,
00388       0.038799192569627049596801936446348,
00389       0.048402672830594052902938140422808,
00390       0.057493156217619066481721689402056,
00391       0.065974229882180495128128515115962,
00392       0.073755974737705206268243850022191,
00393       0.080755895229420215354694938460530,
00394       0.086899787201082979802387530715126,
00395       0.092122522237786128717632707087619,
00396       0.096368737174644259639468626351810,
00397       0.099593420586795267062780282103569,
00398       0.101762389748405504596428952168554,
00399       0.102852652893558840341285636705415
00400     };
00401 
00402   /** weights of the 61-point kronrod rule */
00403   static const double qk61_wgk[31] =   
00404     {
00405       0.001389013698677007624551591226760,
00406       0.003890461127099884051267201844516,
00407       0.006630703915931292173319826369750,
00408       0.009273279659517763428441146892024,
00409       0.011823015253496341742232898853251,
00410       0.014369729507045804812451432443580,
00411       0.016920889189053272627572289420322,
00412       0.019414141193942381173408951050128,
00413       0.021828035821609192297167485738339,
00414       0.024191162078080601365686370725232,
00415       0.026509954882333101610601709335075,
00416       0.028754048765041292843978785354334,
00417       0.030907257562387762472884252943092,
00418       0.032981447057483726031814191016854,
00419       0.034979338028060024137499670731468,
00420       0.036882364651821229223911065617136,
00421       0.038678945624727592950348651532281,
00422       0.040374538951535959111995279752468,
00423       0.041969810215164246147147541285970,
00424       0.043452539701356069316831728117073,
00425       0.044814800133162663192355551616723,
00426       0.046059238271006988116271735559374,
00427       0.047185546569299153945261478181099,
00428       0.048185861757087129140779492298305,
00429       0.049055434555029778887528165367238,
00430       0.049795683427074206357811569379942,
00431       0.050405921402782346840893085653585,
00432       0.050881795898749606492297473049805,
00433       0.051221547849258772170656282604944,
00434       0.051426128537459025933862879215781,
00435       0.051494729429451567558340433647099
00436     };
00437   
00438 }
00439 
00440 #ifndef DOXYGENP
00441 namespace o2scl {
00442 #endif
00443 
00444 #ifdef NEVER_DEFINED  
00445 
00446   class gsl_inte_workspace : public gsl_integration_workspace {
00447 
00448   public:
00449 
00450     int set_size(int sz);
00451     
00452     int size();
00453 
00454     int resize(int sz)
00455 
00456     int initialise(double a, double b);
00457 
00458     int set_initial_result(double result, double error);
00459 
00460     int retrieve(double *a, double *b, double *r, double *e) const;
00461 
00462     int qpsrt();
00463 
00464     int update(double a1, double b1, double area1, double error1,
00465                double a2, double b2, double area2, double error2);
00466 
00467     double sum_results();
00468 
00469     int subinterval_too_small(double a1, double a2, double b2);
00470 
00471     int append_interval(double a1, double b1, double area1, double error1);
00472 
00473   };
00474 #endif
00475 
00476   /** 
00477       \brief Base routines for the GSL adaptive integration routines
00478 
00479       \todo Move gsl_integration_workspace to a separate class
00480       and remove this class, making all children direct descendants 
00481       of gsl_inte instead. We'll have to figure out what to
00482       do with the data member \c wkspace though.
00483 
00484   */
00485   class gsl_inte_table : public gsl_inte {
00486     
00487   public:
00488     
00489     /// The integration workspace
00490     gsl_integration_workspace *w;
00491 
00492     /// The size of the integration workspace
00493     int wkspace;
00494     
00495     gsl_inte_table();
00496     
00497     ~gsl_inte_table();
00498     
00499     /// Set the integration workspace size
00500     int set_wkspace(size_t size);
00501     
00502     /** 
00503         \brief Initialize the workspace for an integration with limits
00504         \c a and \c b.
00505      */
00506     void initialise(gsl_integration_workspace *workspace, 
00507                     double a, double b);
00508     
00509     /// Set the result at position zero
00510     void set_initial_result(gsl_integration_workspace *workspace,
00511                             double result, double error);
00512     
00513     /** 
00514         \brief Retrieve the ith result from the workspace
00515 
00516         The workspace variable \c i is used to specify which 
00517         interval is requested.
00518      */
00519     void retrieve(const gsl_integration_workspace *workspace,
00520                   double *a, double *b, double *r, double *e);
00521     
00522     /// Sort the workspace
00523     void qpsrt(gsl_integration_workspace *workspace);
00524     
00525     /// Update workspace with new results and resort
00526     void update(gsl_integration_workspace *workspace,
00527                 double a1, double b1, double area1, double error1,
00528                 double a2, double b2, double area2, double error2);
00529     
00530     /// Add up all of the contributions to construct the final result
00531     double sum_results(const gsl_integration_workspace *workspace);
00532     
00533     /// Find out if the present subinterval is too small
00534     int subinterval_too_small(double a1, double a2, double b2);
00535 
00536     /// Append new results to workspace
00537     void append_interval(gsl_integration_workspace *workspace,
00538                          double a1, double b1, double area1, double error1);
00539     
00540   };
00541   
00542   /// Desc
00543   template<class param_t, class func_t> 
00544     class gsl_inte_kronrod : public gsl_inte_table, 
00545     public inte<param_t,func_t> {
00546     
00547   public:
00548     
00549     /// The basic GSL Gauss-Kronrod integration function
00550     virtual void gsl_integration_qk_o2scl
00551       (func_t &func, const int n, const double xgk[], const double wg[], 
00552        const double wgk[], double fv1[], double fv2[], double a, double b,
00553        double *result, double *abserr, double *resabs, double *resasc, 
00554        param_t &pa) {
00555       
00556       const double center = 0.5 * (a + b);
00557       const double o2sclf_length = 0.5 * (b - a);
00558       const double abs_o2sclf_length = fabs (o2sclf_length);
00559           
00560       double f_center;
00561       func(center,f_center,pa);
00562           
00563       double result_gauss = 0;
00564       double result_kronrod = f_center * wgk[n - 1];
00565  
00566       double result_abs = fabs (result_kronrod);
00567       double result_asc = 0;
00568       double mean = 0, err = 0;
00569       
00570       int j;
00571       
00572       if (n % 2 == 0)
00573         {
00574           result_gauss = f_center * wg[n / 2 - 1];
00575         }
00576       
00577       for (j = 0; j < (n - 1) / 2; j++)
00578         {
00579           const int jtw = j * 2 + 1;        /* j=1,2,3 jtw=2,4,6 */
00580           const double abscissa = o2sclf_length * xgk[jtw];
00581               
00582           double fval1, fval2;
00583           func(center-abscissa,fval1,pa);
00584           func(center+abscissa,fval2,pa);
00585               
00586           const double fsum = fval1 + fval2;
00587           fv1[jtw] = fval1;
00588           fv2[jtw] = fval2;
00589           result_gauss += wg[j] * fsum;
00590           result_kronrod += wgk[jtw] * fsum;
00591           result_abs += wgk[jtw] * (fabs (fval1) + fabs (fval2));
00592         }
00593       
00594       for (j = 0; j < n / 2; j++)
00595         {
00596           int jtwm1 = j * 2;
00597           const double abscissa = o2sclf_length * xgk[jtwm1];
00598 
00599           double fval1, fval2;
00600           func(center-abscissa,fval1,pa);
00601           func(center+abscissa,fval2,pa);
00602 
00603           fv1[jtwm1] = fval1;
00604           fv2[jtwm1] = fval2;
00605           result_kronrod += wgk[jtwm1] * (fval1 + fval2);
00606           result_abs += wgk[jtwm1] * (fabs (fval1) + fabs (fval2));
00607         };
00608       
00609       mean = result_kronrod * 0.5;
00610       
00611       result_asc = wgk[n - 1] * fabs (f_center - mean);
00612       
00613       for (j = 0; j < n - 1; j++)
00614         {
00615           result_asc += wgk[j] * (fabs (fv1[j] - mean) + 
00616                                   fabs (fv2[j] - mean));
00617         }
00618       
00619       /* scale by the width of the integration region */
00620       
00621       err = (result_kronrod - result_gauss) * o2sclf_length;
00622       
00623       result_kronrod *= o2sclf_length;
00624       result_abs *= abs_o2sclf_length;
00625       result_asc *= abs_o2sclf_length;
00626       
00627       *result = result_kronrod;
00628       *resabs = result_abs;
00629       *resasc = result_asc;
00630       *abserr = rescale_error (err, result_abs, result_asc);
00631       
00632     }
00633     
00634   };
00635 
00636   /** \brief Integrate a function with a singularity (GSL)
00637    */
00638   template<class param_t, class func_t> class gsl_inte_singular : 
00639   public gsl_inte_kronrod<param_t,func_t> {
00640 
00641   protected:
00642       
00643     /** 
00644         \brief A structure for extrapolation for \ref gsl_inte_qags
00645 
00646         \todo Move this to a new class, with qelg() as a method
00647     */
00648     struct extrapolation_table
00649     {
00650       size_t n;
00651       double rlist2[52];
00652       size_t nres;
00653       double res3la[3];
00654     };
00655 
00656     /// Desc
00657     void initialise_table(struct extrapolation_table *table) {
00658       table->n = 0;
00659       table->nres = 0;
00660     }
00661       
00662     /// Desc
00663     void append_table(struct extrapolation_table *table, double y) {
00664       size_t n;
00665       n = table->n;
00666       table->rlist2[n] = y;
00667       table->n++;
00668     }
00669 
00670     /// Desc
00671     inline int test_positivity(double result, double resabs) {
00672       int status = (fabs (result) >= (1 - 50 * GSL_DBL_EPSILON) * resabs);
00673         
00674       return status;
00675     }
00676       
00677     /// Desc
00678     void qelg(struct extrapolation_table *table, double *result,
00679               double *abserr) {
00680       
00681       double *epstab = table->rlist2;
00682       double *res3la = table->res3la;
00683       const size_t n = table->n - 1;
00684         
00685       const double current = epstab[n];
00686         
00687       double absolute = GSL_DBL_MAX;
00688       double relative = 5 * GSL_DBL_EPSILON * fabs (current);
00689         
00690       const size_t newelm = n / 2;
00691       const size_t n_orig = n;
00692       size_t n_final = n;
00693       size_t i;
00694         
00695       const size_t nres_orig = table->nres;
00696         
00697       *result = current;
00698       *abserr = GSL_DBL_MAX;
00699         
00700       if (n < 2)
00701         {
00702           *result = current;
00703           *abserr = GSL_MAX_DBL (absolute, relative);
00704           return;
00705         }
00706         
00707       epstab[n + 2] = epstab[n];
00708       epstab[n] = GSL_DBL_MAX;
00709         
00710       for (i = 0; i < newelm; i++)
00711         {
00712           double res = epstab[n - 2 * i + 2];
00713           double e0 = epstab[n - 2 * i - 2];
00714           double e1 = epstab[n - 2 * i - 1];
00715           double e2 = res;
00716             
00717           double e1abs = fabs (e1);
00718           double delta2 = e2 - e1;
00719           double err2 = fabs (delta2);
00720           double tol2 = GSL_MAX_DBL (fabs (e2), e1abs) * GSL_DBL_EPSILON;
00721           double delta3 = e1 - e0;
00722           double err3 = fabs (delta3);
00723           double tol3 = GSL_MAX_DBL (e1abs, fabs (e0)) * GSL_DBL_EPSILON;
00724             
00725           double e3, delta1, err1, tol1, ss;
00726             
00727           if (err2 <= tol2 && err3 <= tol3)
00728             {
00729               /* If e0, e1 and e2 are equal to within machine accuracy,
00730                  convergence is assumed.  */
00731                 
00732               *result = res;
00733               absolute = err2 + err3;
00734               relative = 5 * GSL_DBL_EPSILON * fabs (res);
00735               *abserr = GSL_MAX_DBL (absolute, relative);
00736               return;
00737             }
00738             
00739           e3 = epstab[n - 2 * i];
00740           epstab[n - 2 * i] = e1;
00741           delta1 = e1 - e3;
00742           err1 = fabs (delta1);
00743           tol1 = GSL_MAX_DBL (e1abs, fabs (e3)) * GSL_DBL_EPSILON;
00744             
00745           /* If two elements are very close to each other, omit a part of
00746              the table by adjusting the value of n */
00747             
00748           if (err1 <= tol1 || err2 <= tol2 || err3 <= tol3)
00749             {
00750               n_final = 2 * i;
00751               break;
00752             }
00753             
00754           ss = (1 / delta1 + 1 / delta2) - 1 / delta3;
00755             
00756           /* Test to detect irregular behaviour in the table, and
00757              eventually omit a part of the table by adjusting the value of
00758              n. */
00759           if (fabs (ss * e1) <= 0.0001)
00760             {
00761               n_final = 2 * i;
00762               break;
00763             }
00764           /* Compute a new element and eventually adjust the value of
00765              result. */
00766             
00767           res = e1 + 1 / ss;
00768           epstab[n - 2 * i] = res;
00769             
00770           {
00771             const double error = err2 + fabs (res - e2) + err3;
00772               
00773             if (error <= *abserr)
00774               {
00775                 *abserr = error;
00776                 *result = res;
00777               }
00778           }
00779         }
00780         
00781       /* Shift the table */
00782         
00783       {
00784         const size_t limexp = 50 - 1;
00785           
00786         if (n_final == limexp)
00787           {
00788             n_final = 2 * (limexp / 2);
00789           }
00790       }
00791         
00792       if (n_orig % 2 == 1)
00793         {
00794           for (i = 0; i <= newelm; i++)
00795             {
00796               epstab[1 + i * 2] = epstab[i * 2 + 3];
00797             }
00798         }
00799       else
00800         {
00801           for (i = 0; i <= newelm; i++)
00802             {
00803               epstab[i * 2] = epstab[i * 2 + 2];
00804             }
00805         }
00806       if (n_orig != n_final)
00807         {
00808           for (i = 0; i <= n_final; i++)
00809             {
00810               epstab[i] = epstab[n_orig - n_final + i];
00811             }
00812         }
00813         
00814       table->n = n_final + 1;
00815         
00816       if (nres_orig < 3)
00817         {
00818           res3la[nres_orig] = *result;
00819           *abserr = GSL_DBL_MAX;
00820         }
00821       else
00822         {                           /* Compute error estimate */
00823           *abserr = (fabs (*result - res3la[2]) + fabs (*result - res3la[1])
00824                      + fabs (*result - res3la[0]));
00825             
00826           res3la[0] = res3la[1];
00827           res3la[1] = res3la[2];
00828           res3la[2] = *result;
00829         }
00830         
00831       /* In QUADPACK the variable table->nres is incremented at the top of
00832          qelg, so it increases on every call. This leads to the array
00833          res3la being accessed when its elements are still undefined, so I
00834          have moved the update to this point so that its value more
00835          useful. */
00836         
00837       table->nres = nres_orig + 1;
00838         
00839       *abserr = GSL_MAX_DBL (*abserr, 5 * GSL_DBL_EPSILON * fabs (*result));
00840         
00841       return;
00842     }
00843       
00844     /// Desc
00845     int large_interval (gsl_integration_workspace * workspace) {
00846       size_t i = workspace->i ;
00847       const size_t * level = workspace->level;
00848         
00849       if (level[i] < workspace->maximum_level)
00850         {
00851           return 1 ;
00852         }
00853       else
00854         {
00855           return 0 ;
00856         }
00857     }
00858       
00859     /// Desc
00860     inline void reset_nrmax (gsl_integration_workspace * workspace) {
00861       workspace->nrmax = 0;
00862       workspace->i = workspace->order[0] ;
00863     }
00864       
00865     /// Desc
00866     int increase_nrmax (gsl_integration_workspace * workspace) {
00867       int k;
00868       int id = workspace->nrmax;
00869       int jupbnd;
00870         
00871       const size_t * level = workspace->level;
00872       const size_t * order = workspace->order;
00873         
00874       size_t limit = workspace->limit ;
00875       size_t last = workspace->size - 1 ;
00876         
00877       if (last > (1 + limit / 2))
00878         {
00879           jupbnd = limit + 1 - last;
00880         }
00881       else
00882         {
00883           jupbnd = last;
00884         }
00885         
00886       for (k = id; k <= jupbnd; k++)
00887         {
00888           size_t i_max = order[workspace->nrmax];
00889             
00890           workspace->i = i_max ;
00891             
00892           if (level[i_max] < workspace->maximum_level)
00893             {
00894               return 1;
00895             }
00896             
00897           workspace->nrmax++;
00898             
00899         }
00900       return 0;
00901     }
00902 
00903     /// Desc
00904     int qags(func_t &func,
00905              const int qn, const double xgk[], const double wg[],
00906              const double wgk[], double fv1[], double fv2[],
00907              const double a, const double b,
00908              const double l_epsabs, const double l_epsrel,
00909              const size_t limit,
00910              double *result, double *abserr, param_t &pa) 
00911     {
00912 
00913       double area, errsum;
00914       double res_ext, err_ext;
00915       double result0, abserr0, resabs0, resasc0;
00916       double tolerance;
00917           
00918       double ertest = 0;
00919       double error_over_large_intervals = 0;
00920       double reseps = 0, abseps = 0, correc = 0;
00921       size_t ktmin = 0;
00922       int roundoff_type1 = 0, roundoff_type2 = 0, roundoff_type3 = 0;
00923       int error_type = 0, error_type2 = 0;
00924           
00925       size_t iteration = 0;
00926           
00927       int positive_integrand = 0;
00928       int extrapolate = 0;
00929       int disallow_extrapolation = 0;
00930           
00931       struct extrapolation_table table;
00932           
00933       /* Initialize results */
00934           
00935       initialise (this->w, a, b);
00936           
00937       *result = 0;
00938       *abserr = 0;
00939           
00940       if (limit > this->w->limit) {
00941         GSL_ERROR ("iteration limit exceeds available w", 
00942                    GSL_EINVAL) ;
00943       }
00944           
00945       /* Test on accuracy */
00946       if (this->tolx <= 0 && (this->tolf < 50 * GSL_DBL_EPSILON || 
00947                               this->tolf < 0.5e-28)) {
00948         GSL_ERROR
00949           ("tolerance cannot be acheived with given epsabs and epsrel",
00950            GSL_EBADTOL);
00951       }
00952           
00953       /* Perform the first integration */
00954         
00955       gsl_integration_qk_o2scl(func,qn,xgk,wg,wgk,fv1,fv2,a,b,
00956                              &result0,&abserr0,&resabs0,&resasc0,pa);
00957         
00958       set_initial_result (this->w, result0, abserr0);
00959           
00960       tolerance = GSL_MAX_DBL (this->tolx, this->tolf * fabs (result0));
00961           
00962       if (abserr0 <= 100 * GSL_DBL_EPSILON * resabs0 && 
00963           abserr0 > tolerance) {
00964         *result = result0;
00965         *abserr = abserr0;
00966             
00967         GSL_ERROR ("cannot reach tolerance because of roundoff error"
00968                    "on first attempt", GSL_EROUND);
00969       } else if ((abserr0 <= tolerance && 
00970                   abserr0 != resasc0) || abserr0 == 0.0) {
00971         *result = result0;
00972         *abserr = abserr0;
00973             
00974         return gsl_success;
00975       } else if (limit == 1) {
00976         *result = result0;
00977         *abserr = abserr0;
00978             
00979         GSL_ERROR
00980           ("a maximum of one iteration was insufficient",
00981            GSL_EMAXITER);
00982       }
00983           
00984       /* Initialization */
00985           
00986       initialise_table (&table);
00987       append_table (&table, result0);
00988           
00989       area = result0;
00990       errsum = abserr0;
00991           
00992       res_ext = result0;
00993       err_ext = GSL_DBL_MAX;
00994           
00995       positive_integrand = this->test_positivity (result0, resabs0);
00996           
00997       iteration = 1;
00998           
00999       do {
01000         size_t current_level;
01001         double a1, b1, a2, b2;
01002         double a_i, b_i, r_i, e_i;
01003         double area1 = 0, area2 = 0, area12 = 0;
01004         double error1 = 0, error2 = 0, error12 = 0;
01005         double resasc1, resasc2;
01006         double resabs1, resabs2;
01007         double last_e_i;
01008             
01009         /* Bisect the subinterval with the largest error estimate */
01010             
01011         retrieve (this->w, &a_i, &b_i, &r_i, &e_i);
01012             
01013         current_level = this->w->level[this->w->i] + 1;
01014             
01015         a1 = a_i;
01016         b1 = 0.5 * (a_i + b_i);
01017         a2 = b1;
01018         b2 = b_i;
01019             
01020         iteration++;
01021             
01022         gsl_integration_qk_o2scl(func,qn,xgk,wg,wgk,fv1,fv2,a1,b1,
01023                                &area1,&error1,&resabs1,&resasc1,pa);
01024         gsl_integration_qk_o2scl(func,qn,xgk,wg,wgk,fv1,fv2,a2,b2,
01025                                &area2,&error2,&resabs2,&resasc2,pa);
01026             
01027         area12 = area1 + area2;
01028         error12 = error1 + error2;
01029         last_e_i = e_i;
01030             
01031         /* Improve previous approximations to the integral and test for
01032            accuracy.
01033                
01034            We write these expressions in the same way as the original
01035            QUADPACK code so that the rounding errors are the same, which
01036            makes testing easier. */
01037             
01038         errsum = errsum + error12 - e_i;
01039         area = area + area12 - r_i;
01040             
01041         tolerance = GSL_MAX_DBL (this->tolx, this->tolf * fabs (area));
01042         if (resasc1 != error1 && resasc2 != error2)
01043           {
01044             double delta = r_i - area12;
01045                 
01046             if (fabs (delta) <= 1.0e-5 * fabs (area12) && 
01047                 error12 >= 0.99 * e_i)
01048               {
01049                 if (!extrapolate)
01050                   {
01051                     roundoff_type1++;
01052                   }
01053                 else
01054                   {
01055                     roundoff_type2++;
01056                   }
01057               }
01058             if (iteration > 10 && error12 > e_i)
01059               {
01060                 roundoff_type3++;
01061               }
01062           }
01063             
01064         /* Test for roundoff and eventually set error flag */
01065             
01066         if (roundoff_type1 + roundoff_type2 >= 10 || 
01067             roundoff_type3 >= 20)
01068           {
01069             error_type = 2;       /* round off error */
01070           }
01071             
01072         if (roundoff_type2 >= 5)
01073           {
01074             error_type2 = 1;
01075           }
01076             
01077         /* set error flag in the case of bad integrand behaviour at
01078            a point of the integration range */
01079             
01080         if (this->subinterval_too_small (a1, a2, b2))
01081           {
01082             error_type = 4;
01083           }
01084             
01085         /* append the newly-created intervals to the list */
01086             
01087         update (this->w, a1, b1, area1, error1, a2, b2, area2, error2);
01088             
01089         if (errsum <= tolerance)
01090           {
01091             goto compute_result;
01092           }
01093             
01094         if (error_type)
01095           {
01096             break;
01097           }
01098             
01099         if (iteration >= limit - 1)
01100           {
01101             error_type = 1;
01102             break;
01103           }
01104             
01105         if (iteration == 2) {
01106           error_over_large_intervals = errsum;
01107           ertest = tolerance;
01108           append_table (&table, area);
01109           continue;
01110         }
01111             
01112         if (disallow_extrapolation) {
01113           continue;
01114         }
01115             
01116         error_over_large_intervals += -last_e_i;
01117             
01118         if (current_level < this->w->maximum_level)
01119           {
01120             error_over_large_intervals += error12;
01121           }
01122             
01123         if (!extrapolate)
01124           {
01125             /* test whether the interval to be bisected next is the
01126                smallest interval. */
01127                 
01128             if (large_interval (this->w))
01129               continue;
01130                 
01131             extrapolate = 1;
01132             this->w->nrmax = 1;
01133           }
01134         if (!error_type2 && error_over_large_intervals > ertest)
01135           {
01136             if (increase_nrmax (this->w))
01137               continue;
01138           }
01139             
01140         /* Perform extrapolation */
01141             
01142         append_table (&table, area);
01143             
01144         qelg (&table, &reseps, &abseps);
01145             
01146         ktmin++;
01147             
01148         if (ktmin > 5 && err_ext < 0.001 * errsum)
01149           {
01150             error_type = 5;
01151           }
01152             
01153         if (abseps < err_ext)
01154           {
01155             ktmin = 0;
01156             err_ext = abseps;
01157             res_ext = reseps;
01158             correc = error_over_large_intervals;
01159             ertest = GSL_MAX_DBL (this->tolx, 
01160                                   this->tolf * fabs (reseps));
01161             if (err_ext <= ertest)
01162               break;
01163           }
01164             
01165         /* Prepare bisection of the smallest interval. */
01166             
01167         if (table.n == 1)
01168           {
01169             disallow_extrapolation = 1;
01170           }
01171             
01172         if (error_type == 5)
01173           {
01174             break;
01175           }
01176             
01177         /* work on interval with largest error */
01178             
01179         reset_nrmax (this->w);
01180         extrapolate = 0;
01181         error_over_large_intervals = errsum;
01182             
01183       }
01184       while (iteration < limit);
01185           
01186           
01187       *result = res_ext;
01188       *abserr = err_ext;
01189           
01190       if (err_ext == GSL_DBL_MAX)
01191         goto compute_result;
01192           
01193       if (error_type || error_type2)
01194         {
01195           if (error_type2)
01196             {
01197               err_ext += correc;
01198             }
01199               
01200           if (error_type == 0)
01201             error_type = 3;
01202               
01203           if (res_ext != 0.0 && area != 0.0)
01204             {
01205               if (err_ext / fabs (res_ext) > errsum / fabs (area))
01206                 goto compute_result;
01207             }
01208           else if (err_ext > errsum)
01209             {
01210               goto compute_result;
01211             }
01212           else if (area == 0.0)
01213             {
01214               goto return_error;
01215             }
01216         }
01217           
01218       /*  Test on divergence. */
01219           
01220       {
01221         double max_area = GSL_MAX_DBL (fabs (res_ext), fabs (area));
01222             
01223         if (!positive_integrand && max_area < 0.01 * resabs0)
01224           goto return_error;
01225       }
01226           
01227       {
01228         double ratio = res_ext / area;
01229             
01230         if (ratio < 0.01 || ratio > 100.0 || errsum > fabs (area))
01231           error_type = 6;
01232       }
01233           
01234       goto return_error;
01235           
01236     compute_result:
01237           
01238       *result = sum_results (this->w);
01239       *abserr = errsum;
01240           
01241     return_error:
01242           
01243       if (error_type > 2)
01244         error_type--;
01245           
01246           
01247           
01248       if (error_type == 0) {
01249         return gsl_success;
01250       } else if (error_type == 1) {
01251         GSL_ERROR("number of iterations was insufficient", GSL_EMAXITER);
01252       } else if (error_type == 2) {
01253         GSL_ERROR("cannot reach tolerance because of roundoff error",
01254                   GSL_EROUND);
01255       } else if (error_type == 3) {
01256         GSL_ERROR("bad integrand behavior found in integration interval",
01257                   GSL_ESING);
01258       } else if (error_type == 4) {
01259         GSL_ERROR("roundoff error detected in the extrapolation table",
01260                   GSL_EROUND);
01261       } else if (error_type == 5) {
01262         GSL_ERROR("integral is divergent, or slowly convergent",
01263                   GSL_EDIVERGE);
01264       } else {
01265         GSL_ERROR("could not integrate function", GSL_EFAILED);
01266       }
01267           
01268     }                                               
01269 
01270   };
01271 
01272   /** \brief Integrate a function with a singularity (GSL)
01273    */
01274   template<class param_t, class func_t> class gsl_inte_transform : 
01275   public gsl_inte_singular<param_t,func_t> {
01276     
01277   public:
01278     
01279     virtual double transform(func_t &func, double t, param_t &pa) {
01280       return 0.0;
01281     }
01282     
01283     /** 
01284         \brief The basic Gauss-Kronrod integration function
01285         
01286         This is basically just a copy of
01287         gsl_inte_qag::gsl_integration_qk_o2scl() which is rewritten to
01288         call the internal transformed function rather than directly
01289         calling the user-specified function.
01290     */
01291     virtual void gsl_integration_qk_o2scl
01292       (func_t &func, const int n, const double xgk[], const double wg[], 
01293        const double wgk[], double fv1[], double fv2[], double a, double b, 
01294        double *result, double *abserr, double *resabs, double *resasc, 
01295        param_t &pa) {
01296       
01297       const double center = 0.5 * (a + b);
01298       const double o2sclf_length = 0.5 * (b - a);
01299       const double abs_o2sclf_length = fabs (o2sclf_length);
01300       
01301       const double f_center=transform(func,center,pa);
01302           
01303       double result_gauss = 0;
01304       double result_kronrod = f_center * wgk[n - 1];
01305  
01306       double result_abs = fabs (result_kronrod);
01307       double result_asc = 0;
01308       double mean = 0, err = 0;
01309       
01310       int j;
01311       
01312       if (n % 2 == 0)
01313         {
01314           result_gauss = f_center * wg[n / 2 - 1];
01315         }
01316       
01317       for (j = 0; j < (n - 1) / 2; j++)
01318         {
01319           const int jtw = j * 2 + 1;        /* j=1,2,3 jtw=2,4,6 */
01320           const double abscissa = o2sclf_length * xgk[jtw];
01321               
01322           const double fval1=transform(func,center-abscissa,pa);
01323           const double fval2=transform(func,center+abscissa,pa);
01324           const double fsum = fval1 + fval2;
01325 
01326           fv1[jtw] = fval1;
01327           fv2[jtw] = fval2;
01328           result_gauss += wg[j] * fsum;
01329           result_kronrod += wgk[jtw] * fsum;
01330           result_abs += wgk[jtw] * (fabs (fval1) + fabs (fval2));
01331         }
01332       
01333       for (j = 0; j < n / 2; j++)
01334         {
01335           int jtwm1 = j * 2;
01336           const double abscissa = o2sclf_length * xgk[jtwm1];
01337               
01338           const double fval1=transform(func,center-abscissa,pa);
01339           const double fval2=transform(func,center+abscissa,pa);
01340               
01341           fv1[jtwm1] = fval1;
01342           fv2[jtwm1] = fval2;
01343           result_kronrod += wgk[jtwm1] * (fval1 + fval2);
01344           result_abs += wgk[jtwm1] * (fabs (fval1) + fabs (fval2));
01345         };
01346       
01347       mean = result_kronrod * 0.5;
01348       
01349       result_asc = wgk[n - 1] * fabs (f_center - mean);
01350       
01351       for (j = 0; j < n - 1; j++)
01352         {
01353           result_asc += wgk[j] * (fabs (fv1[j] - mean) + 
01354                                   fabs (fv2[j] - mean));
01355         }
01356       
01357       /* scale by the width of the integration region */
01358       
01359       err = (result_kronrod - result_gauss) * o2sclf_length;
01360       
01361       result_kronrod *= o2sclf_length;
01362       result_abs *= abs_o2sclf_length;
01363       result_asc *= abs_o2sclf_length;
01364       
01365       *result = result_kronrod;
01366       *resabs = result_abs;
01367       *resasc = result_asc;
01368       *abserr = this->rescale_error (err, result_abs, result_asc);
01369       
01370     }
01371 
01372   };
01373 
01374 #ifndef DOXYGENP
01375 }
01376 #endif
01377 
01378 #endif

Documentation generated with Doxygen and provided under the GNU Free Documentation License. See License Information for details.