    MODULE quadpack2003
      USE set_precision, ONLY : wp
      IMPLICIT NONE

      PRIVATE ! Key exported symbols are declared PUBLIC

! The components of this derived type define a number of parameters that
! comntrol the approximation process. Extending this defined type allows
! for example, parameters to be passed to the function evaluation routine,
! the use of recursion to evaluate multiple integrals, etc.

! Input: INTEGER :: key
!        defines the order of the local Gauss-Kronrod integration rule to be
!        used on each subinterval.
!         <=1: 7 Gauss points, 15 Gauss-Kronrod points,
!           2: 10 Gauss points, 21 Gauss-Kronrod points,
!           3: 15 Gauss points, 31 Gauss-Kronrod points,
!           4: 20 Gauss points, 41 Gauss-Kronrod points,
!           5: 25 Gauss points, 51 Gauss-Kronrod points,
!         >=6: 30 Gauss points, 61 Gauss-Kronrod points.
!        Default value: 6

! Input: INTEGER :: limit
!        defines the maximum number of subdivisions allowed in the subdivision
!        process. If this value is exceeded the routine will return with an
!        error code (quadpackBase%ier) of 1.
!        Default value: 50

! Input: REAL(wp) :: epsabs, epsrel
!        define the absolute and relative error tolerances required. The routine
!        will attempt to return an approximation satisfying
!             ||I - intApprox|| <= max(epsabs, epsrel*||I||)
!        where I is the exact value of the integral.
!        Default values: epsabs = 0.0_wp, epsrel = sqrt(machine precision)

! Output: INTEGER :: nfunction_evaluations
!        provides the total number of function evaluations performed.

! Output: INTEGER :: nvector_evaluations
!        provides the total number of subintervals used in the evaluation.

! Output: REAL(wp) :: abserr
!        provides an estimate of the modulus of the absolute error which should
!        equal or exceed abs(I-intApprox)

! Output: INTEGER :: ier
!        returns the error status. 0 signifies a successful calculation. The
!        following non-zero values all signify a problem with the computation.
!           1: maximum number of subdivisions allowed has been achieved.  One can
!              allow more subdivisions by increasing the value of LIMIT in QAG.
!              However, if this yields no improvement it is advised to analyze
!              the integrand to determine the integration difficulties.
!              If the position of a local difficulty can be determined, such
!              as a singularity or discontinuity within the interval) one will
!              probably gain from splitting up the interval at this point
!              and calling the integrator on the subranges.  If possible,
!              an appropriate special-purpose integrator should be used
!              which is designed for handling the type of difficulty involved.
!           2: the occurrence of roundoff error is detected, which prevents
!              the requested tolerance from being achieved.
!           3: extremely bad integrand behavior occurs at some points of the
!              integration interval.
!           4: roundoff error on extrapolation.
!           5: divergent integral (or slowly convergent integral).
!           6: the input is invalid, because EPSABS < 0 and EPSREL < 0.
!           7: limiting number of cycles attained (QAWF only).

! Input/Output: INTEGER ::ncomponents
!         signifies the number of components in the vector integral. This is
!         used to define the abstract interface for vector integration.
!         It is unused for scalar function integration.

! PROCEDURE(ERRNORM), POINTER :: enorm
!         points to a user-supplied function of the form

!            FUNCTION errnorm(e,extend) RESULT(norm)
!              IMPORT wp, quadpackbase
!              REAL(wp), INTENT(IN) :: e(:)
!              CLASS(quadpackbase), INTENT(INOUT) :: extend
!              REAL(wp) :: norm
!            END FUNCTION

!         which is then used to perform norm calculations on the vector of
!         integrands. It is unused for scalar function integration.
!         If the pointer is not associated then the packaged routine MAXNORM is
!         called. This uses MAXVAL(ABS(e)).
!         Default: enorm => NULL()
! A fuller description of all the components is included in the
! comments immediately preceding this type definition.
      TYPE, PUBLIC :: quadpackbase
  ! Define Gauss rule to be used on each subinterval
        INTEGER :: key = 6
  ! Maximum number of subdivisions allowed
        INTEGER :: limit = 50
  ! Absolute and relative error tolerances required
        REAL (wp) :: epsabs = 0.0E0_wp
        REAL (wp) :: epsrel = sqrt(epsilon(1.0E0_wp))
  ! Total number of function evaluations and subintervals used
        INTEGER :: nfunction_evaluations
        INTEGER :: nvector_evaluations
  ! Estimate of absolute error in result
        REAL (wp) :: abserr
  ! Error status flag
        INTEGER :: ier
  ! Number of components in vector integration
        INTEGER :: ncomponents
  ! Pointer to user-supplied function for norm calculations
        PROCEDURE(errnorm), POINTER, NOPASS :: enorm=>NULL()
      END TYPE quadpackbase

      ABSTRACT INTERFACE
        RECURSIVE FUNCTION fs(xval,extend) RESULT (yval)
          IMPORT wp, quadpackbase
          REAL (wp), INTENT (IN) :: xval(:)
          CLASS (quadpackbase), INTENT (INOUT) :: extend
          REAL (wp) :: yval(size(xval))
        END FUNCTION fs

        RECURSIVE FUNCTION fv(xval,extend) RESULT (yval)
          IMPORT wp, quadpackbase
          REAL (wp), INTENT (IN) :: xval(:)
          CLASS (quadpackbase), INTENT (INOUT) :: extend
          REAL (wp) :: yval(size(xval),extend%ncomponents)
        END FUNCTION fv

        FUNCTION errnorm(e,extend) RESULT (norm)
          IMPORT wp, quadpackbase
          REAL (wp), INTENT (IN) :: e(:)
          CLASS (quadpackbase), INTENT (INOUT) :: extend
          REAL (wp) :: norm
        END FUNCTION errnorm
    END INTERFACE

! This is a generic interface definition.  Either scalar or vector
! integration can use the same routine name, QAG2003.  The routine called
! is either QAG2003S or QAG2003V.  This choice depends on the type and
! rank of intApprox. If intApprox is scalar, QAG2003S is called.
! If intApprox(:) is rank 1, QAG2003V is called.

      INTERFACE qag2003
        MODULE PROCEDURE qag2003s, qag2003v
      END INTERFACE

      PUBLIC qag2003, qag2003s, qag2003v, fs, fv, errnorm, wp

! Named constants
      REAL (wp), PARAMETER, PUBLIC :: half = 0.5E0_wp, zero = 0.0E0_wp, &
        one = 1.0E0_wp, two = 2.0E0_wp, onept5 = 1.5_wp, twohun = 200.0_wp, &
        fifty = 50.0E0_wp, cc = 200.0E0_wp, p99 = 0.99_wp, tenm5 = 0.00001_wp, &
        ten4 = 10000.0E0_wp, ten3 = 1000.0E0_wp

! Named constants for linking key values with rules
      INTEGER, PARAMETER :: gk15rule = 1, gk21rule = 2, gk31rule = 3, &
        gk41rule = 4, gk51rule = 5, gk61rule = 6, maxrules = 6

! Array defining number of points associated with each rule
      INTEGER, PARAMETER :: xrule(1:maxrules) = (/ 15, 21, 31, 41, 51, 61 /)

! Indexes for pointers into the one dimension arrays
! to extract each rule
      INTEGER, PARAMETER :: gkindex(1:maxrules+1) = (/ 1, 9, 20, 36, 57, 83, &
        114 /)
      INTEGER, PARAMETER :: gaussindex(1:maxrules+1) = (/ 1, 5, 10, 18, 28, &
        41, 56 /)

! Data for 15-point Gauss-Kronrod rule
      REAL (wp), PARAMETER :: xwg15(1:4) = (/ &
        0.129484966168869693270611432679082E0_wp, &
        0.279705391489276667901467771423780E0_wp, &
        0.381830050505118944950369775488975E0_wp, &
        0.417959183673469387755102040816327E0_wp/)

      REAL (wp), PARAMETER :: xxgk15(1:8) = (/ &
        0.949107912342758524526189684047851E0_wp, &
        0.741531185599394439863864773280788E0_wp, &
        0.405845151377397166906606412076961E0_wp, &
        0.991455371120812639206854697526329E0_wp, &
        0.864864423359769072789712788640926E0_wp, &
        0.586087235467691130294144838258730E0_wp, &
        0.207784955007898467600689403773245E0_wp, &
        0.000000000000000000000000000000000E0_wp/)

      REAL (wp), PARAMETER :: xwgk15(1:8) = (/ &
        0.063092092629978553290700663189204E0_wp, &
        0.140653259715525918745189590510238E0_wp, &
        0.190350578064785409913256402421014E0_wp, &
        0.022935322010529224963732008058970E0_wp, &
        0.104790010322250183839876322541518E0_wp, &
        0.169004726639267902826583426598550E0_wp, &
        0.204432940075298892414161999234649E0_wp, &
        0.209482141084727828012999174891714E0_wp/)

! Data for 21-point Gauss-Kronrod rule
      REAL (wp), PARAMETER :: xwg21(1:5) = (/ &
        0.066671344308688137593568809893332E0_wp, &
        0.149451349150580593145776339657697E0_wp, &
        0.219086362515982043995534934228163E0_wp, &
        0.269266719309996355091226921569469E0_wp, &
        0.295524224714752870173892994651338E0_wp/)

      REAL (wp), PARAMETER :: xxgk21(1:11) = (/ &
        0.973906528517171720077964012084452E0_wp, &
        0.865063366688984510732096688423493E0_wp, &
        0.679409568299024406234327365114874E0_wp, &
        0.433395394129247190799265943165784E0_wp, &
        0.148874338981631210884826001129720E0_wp, &
        0.995657163025808080735527280689003E0_wp, &
        0.930157491355708226001207180059508E0_wp, &
        0.780817726586416897063717578345042E0_wp, &
        0.562757134668604683339000099272694E0_wp, &
        0.294392862701460198131126603103866E0_wp, &
        0.000000000000000000000000000000000E0_wp/)

      REAL (wp), PARAMETER :: xwgk21(1:11) = (/ &
        0.032558162307964727478818972459390E0_wp, &
        0.075039674810919952767043140916190E0_wp, &
        0.109387158802297641899210590325805E0_wp, &
        0.134709217311473325928054001771707E0_wp, &
        0.147739104901338491374841515972068E0_wp, &
        0.011694638867371874278064396062192E0_wp, &
        0.054755896574351996031381300244580E0_wp, &
        0.093125454583697605535065465083366E0_wp, &
        0.123491976262065851077958109831074E0_wp, &
        0.142775938577060080797094273138717E0_wp, &
        0.149445554002916905664936468389821E0_wp/)

! Data for 31-point Gauss-Kronrod rule
      REAL (wp), PARAMETER :: xwg31(1:8) = (/ &
        0.030753241996117268354628393577204E0_wp, &
        0.070366047488108124709267416450667E0_wp, &
        0.107159220467171935011869546685869E0_wp, &
        0.139570677926154314447804794511028E0_wp, &
        0.166269205816993933553200860481209E0_wp, &
        0.186161000015562211026800561866423E0_wp, &
        0.198431485327111576456118326443839E0_wp, &
        0.202578241925561272880620199967519E0_wp/)

      REAL (wp), PARAMETER :: xxgk31(1:16) = (/ &
        0.987992518020485428489565718586613E0_wp, &
        0.937273392400705904307758947710209E0_wp, &
        0.848206583410427216200648320774217E0_wp, &
        0.724417731360170047416186054613938E0_wp, &
        0.570972172608538847537226737253911E0_wp, &
        0.394151347077563369897207370981045E0_wp, &
        0.201194093997434522300628303394596E0_wp, &
        0.998002298693397060285172840152271E0_wp, &
        0.967739075679139134257347978784337E0_wp, &
        0.897264532344081900882509656454496E0_wp, &
        0.790418501442465932967649294817947E0_wp, &
        0.650996741297416970533735895313275E0_wp, &
        0.485081863640239680693655740232351E0_wp, &
        0.299180007153168812166780024266389E0_wp, &
        0.101142066918717499027074231447392E0_wp, &
        0.000000000000000000000000000000000E0_wp/)

      REAL (wp), PARAMETER :: xwgk31(1:16) = (/ &
        0.015007947329316122538374763075807E0_wp, &
        0.035346360791375846222037948478360E0_wp, &
        0.053481524690928087265343147239430E0_wp, &
        0.069854121318728258709520077099147E0_wp, &
        0.083080502823133021038289247286104E0_wp, &
        0.093126598170825321225486872747346E0_wp, &
        0.099173598721791959332393173484603E0_wp, &
        0.005377479872923348987792051430128E0_wp, &
        0.025460847326715320186874001019653E0_wp, &
        0.044589751324764876608227299373280E0_wp, &
        0.062009567800670640285139230960803E0_wp, &
        0.076849680757720378894432777482659E0_wp, &
        0.088564443056211770647275443693774E0_wp, &
        0.096642726983623678505179907627589E0_wp, &
        0.100769845523875595044946662617570E0_wp, &
        0.101330007014791549017374792767493E0_wp/)

! Data for 41-point Gauss-Kronrod rule
      REAL (wp), PARAMETER :: xwg41(1:10) = (/ &
        0.017614007139152118311861962351853E0_wp, &
        0.040601429800386941331039952274932E0_wp, &
        0.062672048334109063569506535187042E0_wp, &
        0.083276741576704748724758143222046E0_wp, &
        0.101930119817240435036750135480350E0_wp, &
        0.118194531961518417312377377711382E0_wp, &
        0.131688638449176626898494499748163E0_wp, &
        0.142096109318382051329298325067165E0_wp, &
        0.149172986472603746787828737001969E0_wp, &
        0.152753387130725850698084331955098E0_wp/)

      REAL (wp), PARAMETER :: xxgk41(1:21) = (/ &
        0.993128599185094924786122388471320E0_wp, &
        0.963971927277913791267666131197277E0_wp, &
        0.912234428251325905867752441203298E0_wp, &
        0.839116971822218823394529061701521E0_wp, &
        0.746331906460150792614305070355642E0_wp, &
        0.636053680726515025452836696226286E0_wp, &
        0.510867001950827098004364050955251E0_wp, &
        0.373706088715419560672548177024927E0_wp, &
        0.227785851141645078080496195368575E0_wp, &
        0.076526521133497333754640409398838E0_wp, &
        0.998859031588277663838315576545863E0_wp, &
        0.981507877450250259193342994720217E0_wp, &
        0.940822633831754753519982722212443E0_wp, &
        0.878276811252281976077442995113078E0_wp, &
        0.795041428837551198350638833272788E0_wp, &
        0.693237656334751384805490711845932E0_wp, &
        0.575140446819710315342946036586425E0_wp, &
        0.443593175238725103199992213492640E0_wp, &
        0.301627868114913004320555356858592E0_wp, &
        0.152605465240922675505220241022678E0_wp, &
        0.000000000000000000000000000000000E0_wp/)

      REAL (wp), PARAMETER :: xwgk41(1:21) = (/ &
        0.008600269855642942198661787950102E0_wp, &
        0.020388373461266523598010231432755E0_wp, &
        0.031287306777032798958543119323801E0_wp, &
        0.041668873327973686263788305936895E0_wp, &
        0.050944573923728691932707670050345E0_wp, &
        0.059111400880639572374967220648594E0_wp, &
        0.065834597133618422111563556969398E0_wp, &
        0.071054423553444068305790361723210E0_wp, &
        0.074582875400499188986581418362488E0_wp, &
        0.076377867672080736705502835038061E0_wp, &
        0.003073583718520531501218293246031E0_wp, &
        0.014626169256971252983787960308868E0_wp, &
        0.025882133604951158834505067096153E0_wp, &
        0.036600169758200798030557240707211E0_wp, &
        0.046434821867497674720231880926108E0_wp, &
        0.055195105348285994744832372419777E0_wp, &
        0.062653237554781168025870122174255E0_wp, &
        0.068648672928521619345623411885368E0_wp, &
        0.073030690332786667495189417658913E0_wp, &
        0.075704497684556674659542775376617E0_wp, &
        0.076600711917999656445049901530102E0_wp/)

! Data for 51-point Gauss-Kronrod rule
      REAL (wp), PARAMETER :: xwg51(1:13) = (/ &
        0.011393798501026287947902964113235E0_wp, &
        0.026354986615032137261901815295299E0_wp, &
        0.040939156701306312655623487711646E0_wp, &
        0.054904695975835191925936891540473E0_wp, &
        0.068038333812356917207187185656708E0_wp, &
        0.080140700335001018013234959669111E0_wp, &
        0.091028261982963649811497220702892E0_wp, &
        0.100535949067050644202206890392686E0_wp, &
        0.108519624474263653116093957050117E0_wp, &
        0.114858259145711648339325545869556E0_wp, &
        0.119455763535784772228178126512901E0_wp, &
        0.122242442990310041688959518945852E0_wp, &
        0.123176053726715451203902873079050E0_wp/)

      REAL (wp), PARAMETER :: xxgk51(1:26) = (/ &
        0.995556969790498097908784946893902E0_wp, &
        0.976663921459517511498315386479594E0_wp, &
        0.942974571228974339414011169658471E0_wp, &
        0.894991997878275368851042006782805E0_wp, &
        0.833442628760834001421021108693570E0_wp, &
        0.759259263037357630577282865204361E0_wp, &
        0.673566368473468364485120633247622E0_wp, &
        0.577662930241222967723689841612654E0_wp, &
        0.473002731445714960522182115009192E0_wp, &
        0.361172305809387837735821730127641E0_wp, &
        0.243866883720988432045190362797452E0_wp, &
        0.122864692610710396387359818808037E0_wp, &
        0.999262104992609834193457486540341E0_wp, &
        0.988035794534077247637331014577406E0_wp, &
        0.961614986425842512418130033660167E0_wp, &
        0.920747115281701561746346084546331E0_wp, &
        0.865847065293275595448996969588340E0_wp, &
        0.797873797998500059410410904994307E0_wp, &
        0.717766406813084388186654079773298E0_wp, &
        0.626810099010317412788122681624518E0_wp, &
        0.526325284334719182599623778158010E0_wp, &
        0.417885382193037748851814394594572E0_wp, &
        0.303089538931107830167478909980339E0_wp, &
        0.183718939421048892015969888759528E0_wp, &
        0.061544483005685078886546392366797E0_wp, &
        0.000000000000000000000000000000000E0_wp/)

      REAL (wp), PARAMETER :: xwgk51(1:26) = (/ &
        0.005561932135356713758040236901066E0_wp, &
        0.013236229195571674813656405846976E0_wp, &
        0.020435371145882835456568292235939E0_wp, &
        0.027475317587851737802948455517811E0_wp, &
        0.034002130274329337836748795229551E0_wp, &
        0.040083825504032382074839284467076E0_wp, &
        0.045502913049921788909870584752660E0_wp, &
        0.050277679080715671963325259433440E0_wp, &
        0.054251129888545490144543370459876E0_wp, &
        0.057437116361567832853582693939506E0_wp, &
        0.059720340324174059979099291932562E0_wp, &
        0.061128509717053048305859030416293E0_wp, &
        0.001987383892330315926507851882843E0_wp, &
        0.009473973386174151607207710523655E0_wp, &
        0.016847817709128298231516667536336E0_wp, &
        0.024009945606953216220092489164881E0_wp, &
        0.030792300167387488891109020215229E0_wp, &
        0.037116271483415543560330625367620E0_wp, &
        0.042872845020170049476895792439495E0_wp, &
        0.047982537138836713906392255756915E0_wp, &
        0.052362885806407475864366712137873E0_wp, &
        0.055950811220412317308240686382747E0_wp, &
        0.058689680022394207961974175856788E0_wp, &
        0.060539455376045862945360267517565E0_wp, &
        0.061471189871425316661544131965264E0_wp, &
        0.061580818067832935078759824240066E0_wp/)

! Data for 61-point Gauss-Kronrod rule
      REAL (wp), PARAMETER :: xwg61(1:15) = (/ &
        0.007968192496166605615465883474674E0_wp, &
        0.018466468311090959142302131912047E0_wp, &
        0.028784707883323369349719179611292E0_wp, &
        0.038799192569627049596801936446348E0_wp, &
        0.048402672830594052902938140422808E0_wp, &
        0.057493156217619066481721689402056E0_wp, &
        0.065974229882180495128128515115962E0_wp, &
        0.073755974737705206268243850022191E0_wp, &
        0.080755895229420215354694938460530E0_wp, &
        0.086899787201082979802387530715126E0_wp, &
        0.092122522237786128717632707087619E0_wp, &
        0.096368737174644259639468626351810E0_wp, &
        0.099593420586795267062780282103569E0_wp, &
        0.101762389748405504596428952168554E0_wp, &
        0.102852652893558840341285636705415E0_wp/)

      REAL (wp), PARAMETER :: xxgk61(1:31) = (/ &
        0.996893484074649540271630050918695E0_wp, &
        0.983668123279747209970032581605663E0_wp, &
        0.960021864968307512216871025581798E0_wp, &
        0.926200047429274325879324277080474E0_wp, &
        0.882560535792052681543116462530226E0_wp, &
        0.829565762382768397442898119732502E0_wp, &
        0.767777432104826194917977340974503E0_wp, &
        0.697850494793315796932292388026640E0_wp, &
        0.620526182989242861140477556431189E0_wp, &
        0.536624148142019899264169793311073E0_wp, &
        0.447033769538089176780609900322854E0_wp, &
        0.352704725530878113471037207089374E0_wp, &
        0.254636926167889846439805129817805E0_wp, &
        0.153869913608583546963794672743256E0_wp, &
        0.051471842555317695833025213166723E0_wp, &
        0.999484410050490637571325895705811E0_wp, &
        0.991630996870404594858628366109486E0_wp, &
        0.973116322501126268374693868423707E0_wp, &
        0.944374444748559979415831324037439E0_wp, &
        0.905573307699907798546522558925958E0_wp, &
        0.857205233546061098958658510658944E0_wp, &
        0.799727835821839083013668942322683E0_wp, &
        0.733790062453226804726171131369528E0_wp, &
        0.660061064126626961370053668149271E0_wp, &
        0.579345235826361691756024932172540E0_wp, &
        0.492480467861778574993693061207709E0_wp, &
        0.400401254830394392535476211542661E0_wp, &
        0.304073202273625077372677107199257E0_wp, &
        0.204525116682309891438957671002025E0_wp, &
        0.102806937966737030147096751318001E0_wp, &
        0.000000000000000000000000000000000E0_wp/)

      REAL (wp), PARAMETER :: xwgk61(1:31) = (/ &
        0.003890461127099884051267201844516E0_wp, &
        0.009273279659517763428441146892024E0_wp, &
        0.014369729507045804812451432443580E0_wp, &
        0.019414141193942381173408951050128E0_wp, &
        0.024191162078080601365686370725232E0_wp, &
        0.028754048765041292843978785354334E0_wp, &
        0.032981447057483726031814191016854E0_wp, &
        0.036882364651821229223911065617136E0_wp, &
        0.040374538951535959111995279752468E0_wp, &
        0.043452539701356069316831728117073E0_wp, &
        0.046059238271006988116271735559374E0_wp, &
        0.048185861757087129140779492298305E0_wp, &
        0.049795683427074206357811569379942E0_wp, &
        0.050881795898749606492297473049805E0_wp, &
        0.051426128537459025933862879215781E0_wp, &
        0.001389013698677007624551591226760E0_wp, &
        0.006630703915931292173319826369750E0_wp, &
        0.011823015253496341742232898853251E0_wp, &
        0.016920889189053272627572289420322E0_wp, &
        0.021828035821609192297167485738339E0_wp, &
        0.026509954882333101610601709335075E0_wp, &
        0.030907257562387762472884252943092E0_wp, &
        0.034979338028060024137499670731468E0_wp, &
        0.038678945624727592950348651532281E0_wp, &
        0.041969810215164246147147541285970E0_wp, &
        0.044814800133162663192355551616723E0_wp, &
        0.047185546569299153945261478181099E0_wp, &
        0.049055434555029778887528165367238E0_wp, &
        0.050405921402782346840893085653585E0_wp, &
        0.051221547849258772170656282604944E0_wp, &
        0.051494729429451567558340433647099E0_wp/)

      REAL (wp), TARGET :: xwg(1:gaussindex(maxrules+1)-1) = (/ xwg15, xwg21, &
        xwg31, xwg41, xwg51, xwg61/)
      REAL (wp), TARGET :: xwgk(1:gkindex(maxrules+1)-1) = (/ xwgk15, xwgk21, &
        xwgk31, xwgk41, xwgk51, xwgk61/)
      REAL (wp), TARGET :: xxgk(1:gkindex(maxrules+1)-1) = (/ xxgk15, xxgk21, &
        xxgk31, xxgk41, xxgk51, xxgk61/)

    CONTAINS

      RECURSIVE SUBROUTINE qag2003v(f,extype,a,b,intapprox)

!*****************************************************************************80

!! QAG2003V approximates a vector integral over a finite interval.

!  Discussion:

!    The routine calculates an approximation intApprox to a definite integral
!      I = integral of F over (A,B),
!    hopefully satisfying
!      || I - intApprox || <= max ( EPSABS, EPSREL * ||I|| ).

!    QAG2003 is a simple globally adaptive integrator using the strategy of
!    Aind (Piessens, 1973).  It is possible to choose between 6 pairs of
!    Gauss-Kronrod quadrature formulae for the rule evaluation component.
!    The pairs of high degree of precision are suitable for handling
!    integration difficulties due to a strongly oscillating integrand.

!  Authors:

!    Fortran 77 version:
!      Robert Piessens, Elise de Doncker-Kapenger,
!      Christian Ueberhuber, David Kahaner
!    Fortran 2003 version:
!      Richard Hanson, Tim Hopkins

!  Reference:

!    Robert Piessens, Elise de Doncker-Kapenger,
!    Christian Ueberhuber, David Kahaner,
!    QUADPACK, a Subroutine Package for Automatic Integration,
!    Springer Verlag, 1983

!  Parameters:

!   External REAL(wp), FUNCTION f
!     User provided function, of the form

!          [RECURSIVE] FUNCTION f ( x, extype) RESULT(funVals)
!          REAL, INTENT(IN) :: x(:), f(size(x))
!          CLASS(quadpackBase) :: extype
!          REAL(wp) :: funVals(SIZE(x))

!    which evaluates the integrand function at the vector of points given by x.

!    Input/Output: CLASS(quadpackBase) :: extype
!      Used to set the required accuracy tolerances, order of rule to be used,
!      limit on the number of subdivisions, etc.
!      See description of components in definition of type quadpackBase at the
!      head of this file.

!    Input: REAL(wp) :: a, b,
!      define the lower and upper limits of the integration respectively.

!    Output: REAL(wp) :: intApprox
!      returns the computed approximations to the vector of integrals.

! Type and define dummy function values -
  PROCEDURE(fv) :: f

        CLASS (quadpackbase), INTENT (INOUT) :: extype
        REAL (wp), INTENT (IN) :: a, b
        REAL (wp), INTENT (OUT) :: intapprox(:)
        INTEGER last

  PROCEDURE(errnorm), POINTER  :: norm

! Used only with vector integrals.  If the pointer is not
! associated - i.e. still points to NULL() - then a packaged
! routine MAXNORM(E(:),EXTEND) is called.  Otherwise
! a user can write another norm with these same arguments.
! They would then point to this new norm in this component.
        IF ( .NOT. associated(extype%enorm)) THEN
! For vector integrals use the max abs norm.
          norm => maxnorm
        ELSE
! Otherwise the calling program has defined a norm.
          norm => extype%enorm
        END IF

! Needed to define assumed size dimension of user-written
! evaluation code.
        extype%ncomponents = size(intapprox)
        CALL qage2003v(f,extype,a,b,intapprox,last,norm)
      END SUBROUTINE qag2003v

      RECURSIVE SUBROUTINE qage2003v(f,extype,a,b,intapprox,last,norm)
        IMPLICIT NONE
!*****************************************************************************80

!! QAGE2003V estimates a vector-valued definite integral.

!  Discussion:

!    The routine calculates an approximation intApprox to a definite integral
!      I = integral of F over (A,B),
!    hopefully satisfying
!      || I - intApprox || <= max ( EPSABS, EPSREL * ||I|| ).

!  Author:

!    Robert Piessens, Elise de Doncker-Kapenger,
!    Christian Ueberhuber, David Kahaner

!  Reference:

!    Robert Piessens, Elise de Doncker-Kapenger,
!    Christian Ueberhuber, David Kahaner,
!    QUADPACK, a Subroutine Package for Automatic Integration,
!    Springer Verlag, 1983

!  Parameters:

!    Input, external real F, the name of the function routine, of the form
!      [recursive] function f ( x, EXTYPE)
!      real x(:), f(size(x))
!    which evaluates the integrand function.

!    Input, real A, B, the limits of integration.

!    Input, real EPSABS, EPSREL, the absolute and relative accuracy requested.

!    Input, integer KEY, chooses the order of the local integration rule:
!    1,  7 Gauss points, 15 Gauss-Kronrod points,
!    2, 10 Gauss points, 21 Gauss-Kronrod points,
!    3, 15 Gauss points, 31 Gauss-Kronrod points,
!    4, 20 Gauss points, 41 Gauss-Kronrod points,
!    5, 25 Gauss points, 51 Gauss-Kronrod points,
!    6, 30 Gauss points, 61 Gauss-Kronrod points.

!    Input, integer LIMIT, the maximum number of subintervals that
!    can be used.

!    Output, real intApprox, the estimated value of the integral.

!    Output, real ABSERR, an estimate of || I - intApprox ||.

!    Output, integer IER, return code.
!    0, normal and reliable termination of the routine.  It is assumed that the
!      requested accuracy has been achieved.
!    1, maximum number of subdivisions allowed has been achieved.  One can
!      allow more subdivisions by increasing the value of LIMIT in QAG.
!      However, if this yields no improvement it is advised to analyze the
!      integrand to determine the integration difficulties.  If the position
!      of a local difficulty can be determined, such as a singularity or
!      discontinuity within the interval) one will probably gain from
!      splitting up the interval at this point and calling the integrator
!      on the subranges.  If possible, an appropriate special-purpose
!      integrator should be used which is designed for handling the type
!      of difficulty involved.
!    2, the occurrence of roundoff error is detected, which prevents the
!      requested tolerance from being achieved.
!    3, extremely bad integrand behavior occurs at some points of the
!      integration interval.
!    6, the input is invalid, because EPSABS < 0 and EPSREL < 0.

!    Workspace, real ALIST(LIMIT), BLIST(LIMIT), contains in entries 1
!    through LAST the left and right ends of the partition subintervals.

!    Workspace, real RLIST(LIMIT), contains in entries 1 through LAST
!    the integral approximations on the subintervals.

!    Workspace, real ELIST(LIMIT), contains in entries 1 through LAST
!    the absolute error estimates on the subintervals.

!    Output, integer IORD(LIMIT), the first K elements of which are pointers
!    to the error estimates over the subintervals, such that
!    elist(iord(1)), ..., elist(iord(k)) form a decreasing sequence, with
!    k = last if last <= (limit/2+2), and k = limit+1-last otherwise.

!    Output, integer LAST, the number of subintervals actually produced
!    in the subdivision process.

!  Local parameters:

!    alist     - list of left end points of all subintervals
!                       considered up to now
!    blist     - list of right end points of all subintervals
!                       considered up to now
!    elist(i)  - error estimate applying to rlist(i)
!    maxerr    - pointer to the interval with largest error estimate
!    errmax    - elist(maxerr)
!    area      - sum of the integrals over the subintervals
!    errsum    - sum of the errors over the subintervals
!    errbnd    - requested accuracy max(epsabs,epsrel*abs(intApprox))
!    defab1    - variable for the left subinterval
!    defab2    - variable for the right subinterval
!    last      - index for subdivision

! Type and define dummy function values -
  PROCEDURE(fv) :: f
        CLASS (quadpackbase), INTENT (INOUT) :: extype
        REAL (wp), INTENT (IN) :: a, b
        REAL (wp), INTENT (INOUT) :: intapprox(:)
        INTEGER, INTENT (INOUT) :: last
  PROCEDURE(errnorm), POINTER :: norm

        REAL (wp) a12, rl
        REAL (wp) a1, a2, b1, b2, c
        REAL (wp) errbnd, errmax, errsum
        REAL (wp) error1, error2, erro12
        REAL (wp), ALLOCATABLE :: alist(:), blist(:), area(:), area1(:), &
          area2(:), area12(:), resabs(:), elist(:), rlist(:,:), defabs(:), &
          defab1(:), defab2(:)
        INTEGER iroff1, iroff2, keyf, maxerr
        INTEGER nrmax, i
        INTEGER, ALLOCATABLE :: iord(:)

        ASSOCIATE (limit => extype%limit,&
                   epsabs=> extype%epsabs,&
                   epsrel=> extype%epsrel,&
                   abserr=> extype%abserr,&
                   key   => extype%key,&
                   ier   => extype%ier,&
                   nvec  => extype%nvector_evaluations, &
                   neval => extype%nfunction_evaluations, &
                     M   => size(intApprox))
! Allocate space for lists -- use limit to set sizes
        ALLOCATE (alist(limit),blist(limit),elist(limit),rlist(limit,m), &
          area(m),area12(m),area1(m),area2(m),resabs(m),defabs(m),defab1(m), &
          defab2(m),iord(limit))

!  Test on validity of parameters.

        ier = 0
        last = 0
        intapprox = zero
        abserr = zero
        alist(1) = a
        blist(1) = b
        rlist(1,:) = zero
        elist(1) = zero
        iord(1) = 0
        nvec = 0
        neval = 0

        IF (epsabs<zero .AND. epsrel<zero) THEN
          ier = 6
          RETURN
        END IF

!  First approximation to the integral.

        keyf = min(max(key,1),6)
        c = keyf

        CALL qkgenv(f,extype,a,b,intapprox,defabs,resabs,norm)
        nvec = nvec + 1
        last = 1
        rlist(1,:) = intapprox
        elist(1) = abserr
        iord(1) = 1

!  Test on accuracy.

        errbnd = max(epsabs,epsrel*norm(abs(intapprox),extype))

        IF (abserr<=half*epsilon(abserr)*norm(defabs,extype) .AND. &
            errbnd<abserr) THEN
          ier = 2
        END IF

        IF (limit==1) THEN
          ier = 1
        END IF

        IF (ier/=0 .OR. (abserr<=errbnd .AND. abserr/=norm(resabs, &
            extype)) .OR. abserr==zero) THEN

          neval = nvec*xrule(keyf)
          RETURN

        END IF

!  Initialization.

        errmax = abserr
        maxerr = 1
        area = intapprox
        errsum = abserr
        nrmax = 1
        iroff1 = 0
        iroff2 = 0

        DO last = 2, limit

!  Bisect the subinterval with the largest error estimate.

          a1 = alist(maxerr)
          b1 = half*(alist(maxerr)+blist(maxerr))
          a2 = b1
          b2 = blist(maxerr)

          CALL qkgenv(f,extype,a1,b1,area1,resabs,defab1,norm)
          error1 = abserr
          CALL qkgenv(f,extype,a2,b2,area2,resabs,defab2,norm)
          error2 = abserr
          nvec = nvec + 2

!  Improve previous approximations to integral and error and
!  test for accuracy.

          area12 = area1 + area2
          erro12 = error1 + error2
          errsum = errsum + erro12 - errmax
          area = area + area12 - rlist(maxerr,:)

          IF (norm(defab1,extype)/=error1 .AND. norm(defab2,extype)/=error2) &
              THEN
            a12 = norm(abs(area12),extype)
            rl = norm(abs(rlist(maxerr,:)-area12),extype)
            IF (rl<=tenm5*a12 .AND. p99*errmax<=erro12) THEN
              iroff1 = iroff1 + 1
            END IF

            IF (10<last .AND. errmax<erro12) THEN
              iroff2 = iroff2 + 1
            END IF

          END IF

          rlist(maxerr,:) = area1
          rlist(last,:) = area2
          errbnd = max(epsabs,epsrel*norm(abs(area),extype))

!  Test for roundoff error and eventually set error flag.

          IF (errbnd<errsum) THEN

            IF (6<=iroff1 .OR. 20<=iroff2) THEN
              ier = 2
            END IF

!  Set error flag in the case that the number of subintervals
!  equals limit.

            IF (last==limit) THEN
              ier = 1
            END IF

!  Set error flag in the case of bad integrand behavior
!  at a point of the integration range.

            IF (max(abs(a1),abs(b2))<=(one+c*ten3*epsilon(a1))*(abs( &
                a2)+ten4*tiny(a2))) THEN
              ier = 3
            END IF

          END IF

!  Append the newly-created intervals to the list.

          IF (error2<=error1) THEN
            alist(last) = a2
            blist(maxerr) = b1
            blist(last) = b2
            elist(maxerr) = error1
            elist(last) = error2
          ELSE
            alist(maxerr) = a2
            alist(last) = a1
            blist(last) = b1
            rlist(maxerr,:) = area2
            rlist(last,:) = area1
            elist(maxerr) = error2
            elist(last) = error1
          END IF

!  Call QSORT to maintain the descending ordering
!  in the list of error estimates and select the subinterval
!  with the largest error estimate (to be bisected next).

          CALL qsort_2003(limit,last,maxerr,errmax,elist,iord,nrmax)
          IF (ier/=0 .OR. errsum<=errbnd) THEN
            EXIT
          END IF

        END DO

!  Compute final result.

        intapprox = zero
        DO i = 1, last
          intapprox = intapprox + rlist(i,:)
        END DO
        abserr = errsum
        neval = nvec*xrule(keyf)

END ASSOCIATE

      END SUBROUTINE qage2003v

      RECURSIVE SUBROUTINE qag2003s(f,extype,a,b,intapprox)

!*****************************************************************************80

!! QAG2003S approximates a scalar integral over a finite interval.

!  Discussion:

!    The routine calculates an approximation intApprox to a definite integral
!      I = integral of F over (A,B),
!    hopefully satisfying
!      || I - intApprox || <= max ( EPSABS, EPSREL * ||I|| ).

!    QAG2003 is a simple globally adaptive integrator using the strategy of
!    Aind (Piessens, 1973).  It is possible to choose between 6 pairs of
!    Gauss-Kronrod quadrature formulae for the rule evaluation component.
!    The pairs of high degree of precision are suitable for handling
!    integration difficulties due to a strongly oscillating integrand.

!  Author:

!    Robert Piessens, Elise de Doncker-Kapenger,
!    Christian Ueberhuber, David Kahaner

!  Reference:

!    Robert Piessens, Elise de Doncker-Kapenger,
!    Christian Ueberhuber, David Kahaner,
!    QUADPACK, a Subroutine Package for Automatic Integration,
!    Springer Verlag, 1983
!    Modification using Fortran 2003 by R. J. Hanson
!  Parameters:

!    Input, external F, the name of the function routine, of the form
!      [recursive] function f ( x, EXTYPE)
!      real x(:), f(size(x))
!    which evaluates the integrand function.

!    Input, real A, B, the limits of integration.

!    Input, real EPSABS, EPSREL, the absolute and relative accuracy requested.

!    Input, integer KEY, chooses the order of the local integration rule:
!    1,  7 Gauss points, 15 Gauss-Kronrod points,
!    2, 10 Gauss points, 21 Gauss-Kronrod points,
!    3, 15 Gauss points, 31 Gauss-Kronrod points,
!    4, 20 Gauss points, 41 Gauss-Kronrod points,
!    5, 25 Gauss points, 51 Gauss-Kronrod points,
!    6, 30 Gauss points, 61 Gauss-Kronrod points.

!    Output, real intApprox, the estimated value of the integral.

!    Output, real ABSERR, an estimate of || I - intApprox ||.

!    Output, integer IER, return code.
!    0, normal and reliable termination of the routine.  It is assumed that the
!      requested accuracy has been achieved.
!    1, maximum number of subdivisions allowed has been achieved.  One can
!      allow more subdivisions by increasing the value of LIMIT in QAG.
!      However, if this yields no improvement it is advised to analyze the
!      integrand to determine the integration difficulties.  If the position
!      of a local difficulty can be determined, such as a singularity or
!      discontinuity within the interval) one will probably gain from
!      splitting up the interval at this point and calling the integrator
!      on the subranges.  If possible, an appropriate special-purpose
!      integrator should be used which is designed for handling the type
!      of difficulty involved.
!    2, the occurrence of roundoff error is detected, which prevents the
!      requested tolerance from being achieved.
!    3, extremely bad integrand behavior occurs at some points of the
!      integration interval.
!    6, the input is invalid, because EPSABS < 0 and EPSREL < 0.

!  Local parameters:

!    LIMIT is the maximum number of subintervals allowed in
!    the subdivision process of QAGE.

! Type and define dummy function values -
  PROCEDURE(fs) :: f

        CLASS (quadpackbase), INTENT (INOUT) :: extype
        REAL (wp), INTENT (IN) :: a, b
        REAL (wp), INTENT (OUT) :: intapprox

        INTEGER :: last

        CALL qage2003s(f,extype,a,b,intapprox,last)

      END SUBROUTINE qag2003s

      RECURSIVE SUBROUTINE qage2003s(f,extype,a,b,intapprox,last)

!*****************************************************************************80

!! QAGE2003 estimates a definite integral.

!  Discussion:

!    The routine calculates an approximation intApprox to a definite integral
!      I = integral of F over (A,B),
!    hopefully satisfying
!      || I - intApprox || <= max ( EPSABS, EPSREL * ||I|| ).

!  Author:

!    Robert Piessens, Elise de Doncker-Kapenger,
!    Christian Ueberhuber, David Kahaner

!  Reference:

!    Robert Piessens, Elise de Doncker-Kapenger,
!    Christian Ueberhuber, David Kahaner,
!    QUADPACK, a Subroutine Package for Automatic Integration,
!    Springer Verlag, 1983

!  Parameters:

!    Input, external real F, the name of the function routine, of the form
!      [recursive] function f ( x, EXTYPE)
!      real x(:), f(size(x))
!    which evaluates the integrand function.

!    Input, real A, B, the limits of integration.

!    Input, real EPSABS, EPSREL, the absolute and relative accuracy requested.

!    Input, integer KEY, chooses the order of the local integration rule:
!    1,  7 Gauss points, 15 Gauss-Kronrod points,
!    2, 10 Gauss points, 21 Gauss-Kronrod points,
!    3, 15 Gauss points, 31 Gauss-Kronrod points,
!    4, 20 Gauss points, 41 Gauss-Kronrod points,
!    5, 25 Gauss points, 51 Gauss-Kronrod points,
!    6, 30 Gauss points, 61 Gauss-Kronrod points.

!    Input, integer LIMIT, the maximum number of subintervals that
!    can be used.

!    Output, real intApprox, the estimated value of the integral.

!    Output, real ABSERR, an estimate of || I - intApprox ||.

!    Output, integer IER, return code.
!    0, normal and reliable termination of the routine.  It is assumed that the
!      requested accuracy has been achieved.
!    1, maximum number of subdivisions allowed has been achieved.  One can
!      allow more subdivisions by increasing the value of LIMIT in QAG.
!      However, if this yields no improvement it is advised to analyze the
!      integrand to determine the integration difficulties.  If the position
!      of a local difficulty can be determined, such as a singularity or
!      discontinuity within the interval) one will probably gain from
!      splitting up the interval at this point and calling the integrator
!      on the subranges.  If possible, an appropriate special-purpose
!      integrator should be used which is designed for handling the type
!      of difficulty involved.
!    2, the occurrence of roundoff error is detected, which prevents the
!      requested tolerance from being achieved.
!    3, extremely bad integrand behavior occurs at some points of the
!      integration interval.
!    6, the input is invalid, because EPSABS < 0 and EPSREL < 0.

!    Workspace, real ALIST(LIMIT), BLIST(LIMIT), contains in entries 1
!    through LAST the left and right ends of the partition subintervals.

!    Workspace, real RLIST(LIMIT), contains in entries 1 through LAST
!    the integral approximations on the subintervals.

!    Workspace, real ELIST(LIMIT), contains in entries 1 through LAST
!    the absolute error estimates on the subintervals.

!    Output, integer IORD(LIMIT), the first K elements of which are pointers
!    to the error estimates over the subintervals, such that
!    elist(iord(1)), ..., elist(iord(k)) form a decreasing sequence, with
!    k = last if last <= (limit/2+2), and k = limit+1-last otherwise.

!    Output, integer LAST, the number of subintervals actually produced
!    in the subdivision process.

!  Local parameters:

!    alist     - list of left end points of all subintervals
!                       considered up to now
!    blist     - list of right end points of all subintervals
!                       considered up to now
!    elist(i)  - error estimate applying to rlist(i)
!    maxerr    - pointer to the interval with largest error estimate
!    errmax    - elist(maxerr)
!    area      - sum of the integrals over the subintervals
!    errsum    - sum of the errors over the subintervals
!    errbnd    - requested accuracy max(epsabs,epsrel*abs(intApprox))
!    defab1    - variable for the left subinterval
!    defab2    - variable for the right subinterval
!    last      - index for subdivision

! Type and define dummy function values -
  PROCEDURE(FS) :: F
        CLASS (quadpackbase), INTENT (INOUT) :: extype
        REAL (wp), INTENT (IN) :: a, b
        REAL (wp), INTENT (OUT) :: intapprox
        INTEGER, INTENT (OUT) :: last

        REAL (wp) area, area1, area12, area2
        REAL (wp) a1, a2, b1, b2, c, defabs, defab1, defab2
        REAL (wp) errbnd, errmax, error1
        REAL (wp) error2, erro12, errsum, resabs
        REAL (wp), ALLOCATABLE :: alist(:), blist(:), elist(:), rlist(:)
        INTEGER iroff1, iroff2, keyf, maxerr
        INTEGER nrmax
        INTEGER, ALLOCATABLE :: iord(:)

        ASSOCIATE (limit => extype%limit,&
                   epsabs=> extype%epsabs,&
                   epsrel=> extype%epsrel,&
                   abserr=> extype%abserr,&
                   key   => extype%key,&
                   nvec  => extype%nvector_evaluations, &
                   neval => extype%nfunction_evaluations, &
                   ier   => extype%ier)

! Allocate space for lists -- use limit to set sizes
        ALLOCATE (alist(limit),blist(limit),elist(limit),rlist(limit), &
          iord(limit))

!  Test on validity of parameters.

        ier = 0
        last = 0
        intapprox = zero
        abserr = zero
        alist(1) = a
        blist(1) = b
        rlist(1) = zero
        elist(1) = zero
        iord(1) = 0
        nvec = 0
        neval = 0

        IF (epsabs<zero .AND. epsrel<zero) THEN
          ier = 6
          RETURN
        END IF

!  First approximation to the integral.

!!!!!! NEED TO DO SOMETHING WITH KEYF HERE !!!!!
        keyf = min(max(key,1),6)
        c = keyf

        CALL qkgens(f,extype,a,b,intapprox,defabs,resabs)
        nvec = 1
        last = 1
        rlist(1) = intapprox
        elist(1) = abserr
        iord(1) = 1

!  Test on accuracy.

        errbnd = max(epsabs,epsrel*abs(intapprox))

        IF (abserr<=half*epsilon(defabs)*defabs .AND. errbnd<abserr) THEN
          ier = 2
        END IF

        IF (limit==1) THEN
          ier = 1
        END IF

        IF (ier/=0 .OR. (abserr<=errbnd .AND. abserr/=resabs) .OR. &
            abserr==zero) THEN

          neval = nvec*xrule(keyf)
          RETURN

        END IF

!  Initialization.

        errmax = abserr
        maxerr = 1
        area = intapprox
        errsum = abserr
        nrmax = 1
        iroff1 = 0
        iroff2 = 0

        DO last = 2, limit

!  Bisect the subinterval with the largest error estimate.

          a1 = alist(maxerr)
          b1 = half*(alist(maxerr)+blist(maxerr))
          a2 = b1
          b2 = blist(maxerr)

          CALL qkgens(f,extype,a1,b1,area1,resabs,defab1)
          error1 = abserr
          CALL qkgens(f,extype,a2,b2,area2,resabs,defab2)
          error2 = abserr
          nvec = nvec + 2

!  Improve previous approximations to integral and error and
!  test for accuracy.

          area12 = area1 + area2
          erro12 = error1 + error2
          errsum = errsum + erro12 - errmax
          area = area + area12 - rlist(maxerr)

          IF (defab1/=error1 .AND. defab2/=error2) THEN

            IF (abs(rlist(maxerr)-area12)<=tenm5*abs(area12) .AND. p99*errmax &
                <=erro12) THEN
              iroff1 = iroff1 + 1
            END IF

            IF (10<last .AND. errmax<erro12) THEN
              iroff2 = iroff2 + 1
            END IF

          END IF

          rlist(maxerr) = area1
          rlist(last) = area2
          errbnd = max(epsabs,epsrel*abs(area))

!  Test for roundoff error and eventually set error flag.

          IF (errbnd<errsum) THEN

            IF (6<=iroff1 .OR. 20<=iroff2) THEN
              ier = 2
            END IF

!  Set error flag in the case that the number of subintervals
!  equals limit.

            IF (last==limit) THEN
              ier = 1
            END IF

!  Set error flag in the case of bad integrand behavior
!  at a point of the integration range.

            IF (max(abs(a1),abs(b2))<=(one+c*ten3*epsilon(a1))*(abs( &
                a2)+ten4*tiny(a2))) THEN
              ier = 3
            END IF

          END IF

!  Append the newly-created intervals to the list.

          IF (error2<=error1) THEN
            alist(last) = a2
            blist(maxerr) = b1
            blist(last) = b2
            elist(maxerr) = error1
            elist(last) = error2
          ELSE
            alist(maxerr) = a2
            alist(last) = a1
            blist(last) = b1
            rlist(maxerr) = area2
            rlist(last) = area1
            elist(maxerr) = error2
            elist(last) = error1
          END IF

!  Call QSORT to maintain the descending ordering
!  in the list of error estimates and select the subinterval
!  with the largest error estimate (to be bisected next).

          CALL qsort_2003(limit,last,maxerr,errmax,elist,iord,nrmax)
          IF (ier/=0 .OR. errsum<=errbnd) THEN
            EXIT
          END IF

        END DO

!  Compute final result.

        intapprox = sum(rlist(1:min(last,limit)))

        abserr = errsum
        neval = nvec*xrule(keyf)

END ASSOCIATE
      END SUBROUTINE qage2003s

      RECURSIVE SUBROUTINE qkgens(f,extype,a,b,intapprox,resabs,resasc)

        REAL (wp), INTENT (IN) :: a, b
        REAL (wp), INTENT (INOUT) :: intapprox, resabs, resasc
      PROCEDURE(fs) :: f
        CLASS (quadpackbase), INTENT (INOUT) :: extype

!            To compute I = Integral of F over (A,B), with error
!                           estimate
!                       J = Integral of ABS(F) over (A,B)
!           Piessens, Robert
!             Applied Mathematics and Programming Division
!             K. U. Leuven
!           de Doncker, Elise
!             Applied Mathematics and Programming Division
!             K. U. Leuven

!           PARAMETERS
!            ON ENTRY
!              F      - Real
!                       Function subprogram defining the scalar integrand
!                       FUNCTION F(X,EXTYPE). The actual name for F needs to be
!                       Declared E X T E R N A L in the driver program or an
!                       equivalent via use association.  Note that the argument
!                       X(:) is an array so the result is an array of the same
!                       size.

!              EXTYPE   The extended or base data type of class
!                       QUADPACKBASE.  This allows a user program
!                       to pass data to the evaluation function, F.

!              A      - Real
!                       Lower limit of integration

!              B      - Real
!                       Upper limit of integration

!            ON RETURN
!              intApprox - Real
!                       Approximation to the integral I
!                       intApprox is computed by applying a
!                       KRONROD RULE (RESK) obtained by optimal addition
!                       of abscissae to a GAUSS RULE (RESG).

!              ABSERR - Real
!                       Estimate of the modulus of the absolute error,
!                       which should not exceed ABS(I-intApprox)

!              RESABS - Real
!                       Approximation to the integral J

!              RESASC - Real
!                       Approximation to the integral of ABS(F-I/(B-A))
!                       over (A,B)

!           THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1).
!           BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR
!           CORRESPONDING WEIGHTS ARE GIVEN.

!           XGK    - ABSCISSAE OF THE KRONROD RULE
!                    XGK(2), XGK(4), ...  ABSCISSAE OF THE
!                    GAUSS RULE
!                    XGK(1), XGK(3), ...  ABSCISSAE WHICH ARE OPTIMALLY
!                    ADDED TO THE  GAUSS RULE

!           WGK    - WEIGHTS OF THE KRONROD RULE

!           WG     - WEIGHTS OF THE GAUSS RULE

!           LIST OF MAJOR VARIABLES
!           -----------------------

!           CENTR  - MID POINT OF THE INTERVAL
!           HLGTH  - HALF-LENGTH OF THE INTERVAL
!           ABSC   - ABSCISSA
!           FVALUE - FUNCTION VALUE
!           RESG   - RESULT OF THE GAUSS FORMULA
!           RESK   - RESULT OF THE KRONROD FORMULA
!           RESKH  - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B),
!                    I.E. TO I/(B-A)
!     Note: xrule(:) is an array of integers in the module
!     set_gk_data.  Its value, via the call, is used to
!     set the size of the automatic arrays XVALUE, FVALUE.

        REAL (wp) centr, hlgth, resg, resk, reskh
        INTEGER ng, nk, nt
        REAL (wp), POINTER :: fk1(:), fk2(:), fg1(:), fg2(:)
        REAL (wp), TARGET, DIMENSION (xrule(extype%key)) :: xvalue, fvalue

      ASSOCIATE(key => extype%key, abserr => extype%abserr)

      ASSOCIATE(WG =>  XWG(gaussIndex(key):gaussIndex(key+1)-1),&
                WGK => XWGK(gkIndex(key):gkIndex(key+1)-1),&
                XGK => XXGK(gkIndex(key):gkIndex(key+1)-1),&
                RULE => XRULE(key))

        nt = rule
        nk = nt/2
        ng = nk/2

        centr = half*(a+b)
        hlgth = half*(b-a)

! Compute all the x-values and then call the user-supplied function
! to compute all the f values in a single call
        xvalue = (/ centr, centr - hlgth*xgk(1:nk), centr + hlgth*xgk(1:nk) /)

        fvalue = f(xvalue,extype)

        fk1 => fvalue(2:nk+1)
        fk2 => fvalue(nk+2:nt)
        fg1 => fvalue(2:ng+1)
        fg2 => fvalue(nk+2:nk+ng+1)

!           COMPUTE THE KRONROD APPROXIMATION TO
!           THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR.

        IF (mod(nt/2,2)==1) THEN
          resg = fvalue(1)*wg(ng+1)
        ELSE
          resg = zero
        END IF

        resg = resg + dot_product(wg(1:ng),fg1+fg2)

        resk = dot_product(wgk(1:nk),fk1+fk2) + fvalue(1)*wgk(nk+1)

        resabs = dot_product(wgk(1:nk),abs(fk1)+abs(fk2)) + &
          abs(fvalue(1))*wgk(nk+1)
        reskh = resk*half
        resasc = dot_product(wgk(1:nk),abs(fk1-reskh)+abs(fk2-reskh)) + &
          abs(fvalue(1)-reskh)*wgk(nk+1)
      END ASSOCIATE
        intapprox = resk*hlgth
        resabs = resabs*abs(hlgth)
        resasc = resasc*abs(hlgth)
        abserr = abs((resk-resg)*hlgth)
        IF (resasc/=zero .AND. abserr/=zero) THEN
          abserr = resasc*min(one,(twohun*abserr/resasc)**onept5)
        END IF
        IF (resabs*fifty*epsilon(one)>tiny(one)) THEN
          abserr = max((epsilon(one)*fifty)*resabs,abserr)
        END IF
      END ASSOCIATE
      END SUBROUTINE qkgens

      RECURSIVE SUBROUTINE qkgenv(f,extype,a,b,intapprox,resabs,resasc,norm)

        REAL (wp), INTENT (IN) :: a, b
        REAL (wp), INTENT (INOUT), DIMENSION (:) :: intapprox, resabs, resasc
      PROCEDURE(fv) :: f
        CLASS (quadpackbase), INTENT (INOUT) :: extype
      PROCEDURE(errnorm),POINTER :: norm

!            To compute I = Integral of F over (A,B), with error
!                           estimate
!                       J = Integral of ABS(F) over (A,B)
!           Piessens, Robert
!             Applied Mathematics and Programming Division
!             K. U. Leuven
!           de Doncker, Elise
!             Applied Mathematics and Programming Division
!             K. U. Leuven

!           PARAMETERS
!            ON ENTRY
!              F      - Real
!                       Function subprogram defining the scalar integrand
!                       FUNCTION F(X,EXTYPE). The actual name for F needs to be
!                       Declared E X T E R N A L in the driver program or an
!                       equivalent via use association.  Note that the argument
!                       X(:) is an array so the result is an array of
!                       size (SIZE(X), EXTYPE%NCOMPONENTS).

!              EXTYPE   The extended or base data type of class
!                       QUADPACKBASE.  This allows a user program
!                       to pass data to the evaluation function, F.

!              A      - Real
!                       Lower limit of integration

!              B      - Real
!                       Upper limit of integration

!            ON RETURN
!              intApprox - Real
!                       Approximation to the integral I
!                       intApprox is computed by applying a
!                       KRONROD RULE (RESK) obtained by optimal addition
!                       of abscissae to a GAUSS RULE (RESG).

!              ABSERR - Real
!                       Estimate of the modulus of the absolute error,
!                       which should not exceed ABS(I-intApprox)

!              RESABS - Real
!                       Approximation to the integral J

!              RESASC - Real
!                       Approximation to the integral of ABS(F-I/(B-A))
!                       over (A,B)

        REAL (wp) centr, hlgth, resg(size(intapprox)), resk(size(intapprox)), &
          reskh(size(intapprox))
        INTEGER ng, nk, nt, i
        REAL (wp), POINTER :: fk1(:,:), fk2(:,:), fg1(:,:), fg2(:,:)

!           THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1).
!           BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR
!           CORRESPONDING WEIGHTS ARE GIVEN.

!           XGK    - ABSCISSAE OF THE 21-POINT KRONROD RULE
!                    XGK(2), XGK(4), ...  ABSCISSAE OF THE 10-POINT
!                    GAUSS RULE
!                    XGK(1), XGK(3), ...  ABSCISSAE WHICH ARE OPTIMALLY
!                    ADDED TO THE 10-POINT GAUSS RULE

!           WGK    - WEIGHTS OF THE KRONROD RULE

!           WG     - WEIGHTS OF THE GAUSS RULE

!           LIST OF MAJOR VARIABLES
!           -----------------------

!           CENTR  - MID POINT OF THE INTERVAL
!           HLGTH  - HALF-LENGTH OF THE INTERVAL
!           ABSC   - ABSCISSA
!           FVALUE - FUNCTION VALUE
!           RESG   - RESULT OF THE GAUSS FORMULA
!           RESK   - RESULT OF THE KRONROD FORMULA
!           RESKH  - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B),
!                    I.E. TO I/(B-A)
!     Note: xrule(:) is an array of integers in the module
!     set_gk_data.  Its value, via the call, is used to
!     set the size of the automatic arrays XVALUE, FVALUE.

        REAL (wp), TARGET, DIMENSION (xrule(extype%key),size(intapprox)) :: &
          xvalue(xrule(extype%key)), fvalue

! It would be cleaner to amalgamate the two ASSOCIATE statements but the NAG
! compiler does not like this
      ASSOCIATE(key => extype%key, abserr => extype%abserr)

      ASSOCIATE(WG =>  XWG(gaussIndex(key):gaussIndex(key+1)-1),&
                WGK => XWGK(gkIndex(key):gkIndex(key+1)-1),&
                XGK => XXGK(gkIndex(key):gkIndex(key+1)-1),&
                RULE => XRULE(key))

        nt = rule
        nk = nt/2
        ng = nk/2

        centr = half*(a+b)
        hlgth = half*(b-a)

! Compute all the x-values and then call the user supplied function
! to compute all the f values in a single call
        xvalue = (/ centr, centr - hlgth*xgk(1:nk), centr + hlgth*xgk(1:nk) /)

        fvalue = f(xvalue,extype)

        fk1 => fvalue(2:nk+1,:)
        fk2 => fvalue(nk+2:nt,:)
        fg1 => fvalue(2:ng+1,:)
        fg2 => fvalue(nk+2:nk+ng+1,:)

! Compute the Kronrod approximation to the integral, and
! estimate the absolute error.

        IF (mod(nt/2,2)==1) THEN
          resg = fvalue(1,:)*wg(ng+1)
        ELSE
          resg = zero
        END IF

        resg = resg + matmul(wg(1:ng),(fg1+fg2))
        resk = matmul(wgk(1:nk),(fk1+fk2)) + fvalue(1,:)*wgk(nk+1)
        resabs = matmul(wgk(1:nk),(abs(fk1)+abs(fk2))) + &
          abs(fvalue(1,:))*wgk(nk+1)
        reskh = resk*half

        DO i = 1, nk
          fk1(i,:) = fk1(i,:) - reskh
          fk2(i,:) = fk2(i,:) - reskh
        END DO

        resasc = matmul(wgk(1:nk),abs(fk1)+abs(fk2)) + &
          abs(fvalue(1,:)-reskh)*wgk(nk+1)
      END ASSOCIATE
        intapprox = resk*hlgth
        resabs = resabs*abs(hlgth)
        resasc = resasc*abs(hlgth)
        abserr = norm(abs((resk-resg)*hlgth),extype)

        IF (all(resasc/=zero) .AND. abserr/=zero) THEN
          abserr = norm(resasc*min(one,(twohun*abserr/ &
            maxval(resasc))**onept5),extype)
        END IF
        IF (norm(resabs,extype)*fifty*epsilon(one)>tiny(one)) THEN
          abserr = max((epsilon(one)*fifty)*norm(resabs,extype),abserr)
        END IF
      END ASSOCIATE
      END SUBROUTINE qkgenv

      SUBROUTINE qsort_2003(limit,last,maxerr,ermax,elist,iord,nrmax)

!*****************************************************************************80

!! QSORT_2003 maintains the order of a list of local error estimates.

!  Discussion:

!    This routine maintains the descending ordering in the list of the
!    local error estimates resulting from the interval subdivision process.
!    At each call two error estimates are inserted using the sequential
!    search top-down for the largest error estimate and bottom-up for the
!    smallest error estimate.

!  Author:

!    Robert Piessens, Elise de Doncker-Kapenger,
!    Christian Ueberhuber, David Kahaner

!  Reference:

!    Robert Piessens, Elise de Doncker-Kapenger,
!    Christian Ueberhuber, David Kahaner,
!    QUADPACK, a Subroutine Package for Automatic Integration,
!    Springer Verlag, 1983

!  Parameters:

!    Input, integer LIMIT, the maximum number of error estimates the list can
!    contain.

!    Input, integer LAST, the current number of error estimates.

!    Input/output, integer MAXERR, the index in the list of the NRMAX-th
!    largest error.

!    Output, real ERMAX, the NRMAX-th largest error = ELIST(MAXERR).

!    Input, real ELIST(LIMIT), contains the error estimates.

!    Input/output, integer IORD(LAST).  The first K elements contain
!    pointers to the error estimates such that ELIST(IORD(1)) through
!    ELIST(IORD(K)) form a decreasing sequence, with
!      K = LAST
!    if
!      LAST <= (LIMIT/2+2),
!    and otherwise
!      K = LIMIT+1-LAST.

!    Input/output, integer NRMAX.

        INTEGER, INTENT (IN) :: limit, last
        INTEGER, INTENT (INOUT) :: iord(last), maxerr, nrmax
        REAL (wp), INTENT (INOUT) :: elist(last)
        REAL (wp), INTENT (OUT) :: ermax

        INTEGER i, ibeg, isucc, j, jbnd
        INTEGER jupbn, k, istate
        REAL (wp) errmax, errmin

!  Check whether the list contains more than two error estimates.

        istate = 1
        DO
          SELECT CASE (istate)
          CASE (1)
            IF (last<=2) THEN
              iord(1) = 1
              iord(2) = 2
              istate = 90
              CYCLE
            END IF

!  This part of the routine is only executed if, due to a
!  difficult integrand, subdivision increased the error
!  estimate. In the normal case the insert procedure should
!  start after the nrmax-th largest error estimate.

            errmax = elist(maxerr)

            DO i = 1, nrmax - 1

              isucc = iord(nrmax-1)

              IF (errmax<=elist(isucc)) THEN
                EXIT
              END IF

              iord(nrmax) = isucc
              nrmax = nrmax - 1

            END DO

!  Compute the number of elements in the list to be maintained
!  in descending order.  This number depends on the number of
!  subdivisions still allowed.

            jupbn = last

            IF ((limit/2+2)<last) THEN
              jupbn = limit + 3 - last
            END IF

            errmin = elist(last)

!  Insert errmax by traversing the list top-down, starting
!  comparison from the element elist(iord(nrmax+1)).

            jbnd = jupbn - 1
            ibeg = nrmax + 1

            DO i = ibeg, jbnd
              isucc = iord(i)
              IF (elist(isucc)<=errmax) THEN
                istate = 60
                CYCLE
              END IF
              iord(i-1) = isucc
            END DO

            iord(jbnd) = maxerr
            iord(jupbn) = last
            istate = 90
            CYCLE

!  Insert errmin by traversing the list bottom-up.

          CASE (60)

            iord(i-1) = maxerr
            k = jbnd

            DO j = i, jbnd
              isucc = iord(k)
              IF (errmin<elist(isucc)) THEN
                istate = 80
              END IF
              iord(k+1) = isucc
              k = k - 1
            END DO

            iord(i) = last
            istate = 90
            CYCLE

          CASE (80)

            iord(k+1) = last

!  Set maxerr and ermax.

            istate = 90
            CYCLE

          CASE (90)

            maxerr = iord(nrmax)
            ermax = elist(maxerr)
            EXIT
          END SELECT
        END DO
      END SUBROUTINE qsort_2003

      FUNCTION maxnorm(e,extend) RESULT (norm)
! This is the default norm used for vector integration.
! It is the max abs norm.
        REAL (wp), INTENT (IN) :: e(:)

        CLASS (quadpackbase), INTENT (INOUT) :: extend
        REAL (wp) norm

        norm = maxval(abs(e))
      END FUNCTION maxnorm

    END MODULE quadpack2003


      real function nfwdens(rad)

      include 'commonblocks'

      s = rad/a
      nfwdens = haloconst/(s**cusp)/((1.+s)**(outerhaloslope-cusp))
      return
      end

      real function nfwdensprime(rad)

      include 'commonblocks'
      real nfwdens

      s = rad/a
      nfwdensprime = -nfwdens(rad)/a*(outerhaloslope*s+cusp)/s/(1.+s)
      return
      end

      real function nfwdens2prime(rad)

      include 'commonblocks'
      real nfwdens

      s = rad/a
      nfwdens2prime = nfwdens(rad)/a/a*
     *     (cusp*(cusp+1.)+2.*(1.+outerhaloslope)*cusp*s+
     +     outerhaloslope*(1.+outerhaloslope)*s*s)/s/s/(1.+s)/(1.+s)
      return
      end


      SUBROUTINE MB01RY( SIDE, UPLO, TRANS, M, ALPHA, BETA, R, LDR, H,
     $                   LDH, B, LDB, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute either the upper or lower triangular part of one of the
C     matrix formulas
C        _
C        R = alpha*R + beta*op( H )*B,                               (1)
C        _
C        R = alpha*R + beta*B*op( H ),                               (2)
C                                                    _
C     where alpha and beta are scalars, H, B, R, and R are m-by-m
C     matrices, H is an upper Hessenberg matrix, and op( H ) is one of
C
C        op( H ) = H   or   op( H ) = H',  the transpose of H.
C
C     The result is overwritten on R.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SIDE    CHARACTER*1
C             Specifies whether the Hessenberg matrix H appears on the
C             left or right in the matrix product as follows:
C                     _
C             = 'L':  R = alpha*R + beta*op( H )*B;
C                     _
C             = 'R':  R = alpha*R + beta*B*op( H ).
C
C     UPLO    CHARACTER*1                               _
C             Specifies which triangles of the matrices R and R are
C             computed and given, respectively, as follows:
C             = 'U':  the upper triangular part;
C             = 'L':  the lower triangular part.
C
C     TRANS   CHARACTER*1
C             Specifies the form of op( H ) to be used in the matrix
C             multiplication as follows:
C             = 'N':  op( H ) = H;
C             = 'T':  op( H ) = H';
C             = 'C':  op( H ) = H'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER           _
C             The order of the matrices R, R, H and B.  M >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then R need not be
C             set before entry.
C
C     BETA    (input) DOUBLE PRECISION
C             The scalar beta. When beta is zero then H and B are not
C             referenced.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
C             On entry with UPLO = 'U', the leading M-by-M upper
C             triangular part of this array must contain the upper
C             triangular part of the matrix R; the strictly lower
C             triangular part of the array is not referenced.
C             On entry with UPLO = 'L', the leading M-by-M lower
C             triangular part of this array must contain the lower
C             triangular part of the matrix R; the strictly upper
C             triangular part of the array is not referenced.
C             On exit, the leading M-by-M upper triangular part (if
C             UPLO = 'U'), or lower triangular part (if UPLO = 'L') of
C             this array contains the corresponding triangular part of
C                                 _
C             the computed matrix R.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,M).
C
C     H       (input) DOUBLE PRECISION array, dimension (LDH,M)
C             On entry, the leading M-by-M upper Hessenberg part of
C             this array must contain the upper Hessenberg part of the
C             matrix H.
C             The elements below the subdiagonal are not referenced,
C             except possibly for those in the first column, which
C             could be overwritten, but are restored on exit.
C
C     LDH     INTEGER
C             The leading dimension of array H.  LDH >= MAX(1,M).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading M-by-M part of this array must
C             contain the matrix B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,M).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             LDWORK >= M, if  beta <> 0 and SIDE = 'L';
C             LDWORK >= 0, if  beta =  0 or  SIDE = 'R'.
C             This array is not referenced when beta = 0 or SIDE = 'R'.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix expression is efficiently evaluated taking the
C     Hessenberg/triangular structure into account. BLAS 2 operations
C     are used. A block algorithm can be constructed; it can use BLAS 3
C     GEMM operations for most computations, and calls of this BLAS 2
C     algorithm for computing the triangles.
C
C     FURTHER COMMENTS
C
C     The main application of this routine is when the result should
C     be a symmetric matrix, e.g., when B = X*op( H )', for (1), or
C     B = op( H )'*X, for (2), where B is already available and X = X'.
C
C     CONTRIBUTORS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix algebra, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         SIDE, TRANS, UPLO
      INTEGER           INFO, LDB, LDH, LDR, M
      DOUBLE PRECISION  ALPHA, BETA
C     .. Array Arguments ..
      DOUBLE PRECISION  B(LDB,*), DWORK(*), H(LDH,*), R(LDR,*)
C     .. Local Scalars ..
      LOGICAL           LSIDE, LTRANS, LUPLO
      INTEGER           I, J
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DDOT
      EXTERNAL          DDOT, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMV, DLASCL, DLASET, DSCAL, DSWAP,
     $                  DTRMV, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO   = 0
      LSIDE  = LSAME( SIDE,  'L' )
      LUPLO  = LSAME( UPLO,  'U' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      IF(      ( .NOT.LSIDE  ).AND.( .NOT.LSAME( SIDE,  'R' ) ) )THEN
         INFO = -1
      ELSE IF( ( .NOT.LUPLO  ).AND.( .NOT.LSAME( UPLO,  'L' ) ) )THEN
         INFO = -2
      ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDR.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF( LDH.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
         INFO = -12
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01RY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( M.EQ.0 )
     $   RETURN
C
      IF ( BETA.EQ.ZERO ) THEN
         IF ( ALPHA.EQ.ZERO ) THEN
C
C           Special case when both alpha = 0 and beta = 0.
C
            CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR )
         ELSE
C
C           Special case beta = 0.
C
            IF ( ALPHA.NE.ONE )
     $         CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO )
         END IF
         RETURN
      END IF
C
C     General case: beta <> 0.
C     Compute the required triangle of (1) or (2) using BLAS 2
C     operations.
C
      IF( LSIDE ) THEN
C
C        To avoid repeated references to the subdiagonal elements of H,
C        these are swapped with the corresponding elements of H in the
C        first column, and are finally restored.
C
         IF( M.GT.2 )
     $      CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
C
         IF( LUPLO ) THEN
            IF ( LTRANS ) THEN
C
               DO 20 J = 1, M
C
C                 Multiply the transposed upper triangle of the leading
C                 j-by-j submatrix of H by the leading part of the j-th
C                 column of B.
C
                  CALL DCOPY( J, B( 1, J ), 1, DWORK, 1 )
                  CALL DTRMV( 'Upper', TRANS, 'Non-unit', J, H, LDH,
     $                        DWORK, 1 )
C
C                 Add the contribution of the subdiagonal of H to
C                 the j-th column of the product.
C
                  DO 10 I = 1, MIN( J, M - 1 )
                     R( I, J ) = ALPHA*R( I, J ) + BETA*( DWORK( I ) +
     $                           H( I+1, 1 )*B( I+1, J ) )
   10             CONTINUE
C
   20          CONTINUE
C
               R( M, M ) = ALPHA*R( M, M ) + BETA*DWORK( M )
C
            ELSE
C
               DO 40 J = 1, M
C
C                 Multiply the upper triangle of the leading j-by-j
C                 submatrix of H by the leading part of the j-th column
C                 of B.
C
                  CALL DCOPY( J, B( 1, J ), 1, DWORK, 1 )
                  CALL DTRMV( 'Upper', TRANS, 'Non-unit', J, H, LDH,
     $                        DWORK, 1 )
                  IF( J.LT.M ) THEN
C
C                    Multiply the remaining right part of the leading
C                    j-by-M submatrix of H by the trailing part of the
C                    j-th column of B.
C
                     CALL DGEMV( TRANS, J, M-J, BETA, H( 1, J+1 ), LDH,
     $                           B( J+1, J ), 1, ALPHA, R( 1, J ), 1 )
                  ELSE
                     CALL DSCAL( M, ALPHA, R( 1, M ), 1 )
                  END IF
C
C                 Add the contribution of the subdiagonal of H to
C                 the j-th column of the product.
C
                  R( 1, J ) = R( 1, J ) + BETA*DWORK( 1 )
C
                  DO 30 I = 2, J
                     R( I, J ) = R( I, J ) + BETA*( DWORK( I ) +
     $                           H( I, 1 )*B( I-1, J ) )
   30             CONTINUE
C
   40          CONTINUE
C
            END IF
C
         ELSE
C
            IF ( LTRANS ) THEN
C
               DO 60 J = M, 1, -1
C
C                 Multiply the transposed upper triangle of the trailing
C                 (M-j+1)-by-(M-j+1) submatrix of H by the trailing part
C                 of the j-th column of B.
C
                  CALL DCOPY( M-J+1, B( J, J ), 1, DWORK( J ), 1 )
                  CALL DTRMV( 'Upper', TRANS, 'Non-unit', M-J+1,
     $                        H( J, J ), LDH, DWORK( J ), 1 )
                  IF( J.GT.1 ) THEN
C
C                    Multiply the remaining left part of the trailing
C                    (M-j+1)-by-(j-1) submatrix of H' by the leading
C                    part of the j-th column of B.
C
                     CALL DGEMV( TRANS, J-1, M-J+1, BETA, H( 1, J ),
     $                           LDH, B( 1, J ), 1, ALPHA, R( J, J ),
     $                           1 )
                  ELSE
                     CALL DSCAL( M, ALPHA, R( 1, 1 ), 1 )
                  END IF
C
C                 Add the contribution of the subdiagonal of H to
C                 the j-th column of the product.
C
                  DO 50 I = J, M - 1
                     R( I, J ) = R( I, J ) + BETA*( DWORK( I ) +
     $                           H( I+1, 1 )*B( I+1, J ) )
   50             CONTINUE
C
                  R( M, J ) = R( M, J ) + BETA*DWORK( M )
   60          CONTINUE
C
            ELSE
C
               DO 80 J = M, 1, -1
C
C                 Multiply the upper triangle of the trailing
C                 (M-j+1)-by-(M-j+1) submatrix of H by the trailing
C                 part of the j-th column of B.
C
                  CALL DCOPY( M-J+1, B( J, J ), 1, DWORK( J ), 1 )
                  CALL DTRMV( 'Upper', TRANS, 'Non-unit', M-J+1,
     $                        H( J, J ), LDH, DWORK( J ), 1 )
C
C                 Add the contribution of the subdiagonal of H to
C                 the j-th column of the product.
C
                  DO 70 I = MAX( J, 2 ), M
                     R( I, J ) = ALPHA*R( I, J ) + BETA*( DWORK( I )
     $                               + H( I, 1 )*B( I-1, J ) )
   70             CONTINUE
C
   80          CONTINUE
C
               R( 1, 1 ) = ALPHA*R( 1, 1 ) + BETA*DWORK( 1 )
C
            END IF
         END IF
C
         IF( M.GT.2 )
     $      CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 )
C
      ELSE
C
C        Row-wise calculations are used for H, if SIDE = 'R' and
C        TRANS = 'T'.
C
         IF( LUPLO ) THEN
            IF( LTRANS ) THEN
               R( 1, 1 ) = ALPHA*R( 1, 1 ) +
     $                     BETA*DDOT( M, B, LDB, H, LDH )
C
               DO 90 J = 2, M
                  CALL DGEMV( 'NoTranspose', J, M-J+2, BETA,
     $                        B( 1, J-1 ), LDB, H( J, J-1 ), LDH,
     $                        ALPHA, R( 1, J ), 1 )
   90          CONTINUE
C
            ELSE
C
               DO 100 J = 1, M - 1
                  CALL DGEMV( 'NoTranspose', J, J+1, BETA, B, LDB,
     $                        H( 1, J ), 1, ALPHA, R( 1, J ), 1 )
  100          CONTINUE
C
               CALL DGEMV( 'NoTranspose', M, M, BETA, B, LDB,
     $                     H( 1, M ), 1, ALPHA, R( 1, M ), 1 )
C
            END IF
C
         ELSE
C
            IF( LTRANS ) THEN
C
               CALL DGEMV( 'NoTranspose', M, M, BETA, B, LDB, H, LDH,
     $                     ALPHA, R( 1, 1 ), 1 )
C
               DO 110 J = 2, M
                  CALL DGEMV( 'NoTranspose', M-J+1, M-J+2, BETA,
     $                        B( J, J-1 ), LDB, H( J, J-1 ), LDH, ALPHA,
     $                        R( J, J ), 1 )
  110          CONTINUE
C
            ELSE
C
               DO 120 J = 1, M - 1
                  CALL DGEMV( 'NoTranspose', M-J+1, J+1, BETA,
     $                        B( J, 1 ), LDB, H( 1, J ), 1, ALPHA,
     $                        R( J, J ), 1 )
  120          CONTINUE
C
               R( M, M ) = ALPHA*R( M, M ) +
     $                     BETA*DDOT( M, B( M, 1 ), LDB, H( 1, M ), 1 )
C
            END IF
         END IF
      END IF
C
      RETURN
C *** Last line of MB01RY ***
      END


      INTEGER            LWORK, MAXN
      DOUBLE PRECISION   ZERO
      PARAMETER          ( LWORK = 264, MAXN = 100, ZERO = 0.0D+0 )
      INTEGER            LDA
      DOUBLE PRECISION   MONE
      INTEGER            MAXPROCS
      PARAMETER          ( LDA = MAXN, MONE = -1.0D+0, MAXPROCS = 512 )
*     ..
*     .. Local Scalars ..
      INTEGER            CONTEXT, I, IAM, INFO, MYCOL, MYROW, N, NB,
     $                   NPCOL, NPROCS, NPROW
*     ..
*     .. Local Arrays ..
      INTEGER            DESCA( 50 ), DESCZ( 50 )
      DOUBLE PRECISION   A( LDA, LDA ), W( MAXN ),
     $                   WORK( LWORK ), Z( LDA, LDA )

      n = 4

      do j = 1, n
         do i = 1, n
            a(i,j)= n - max(i,j) + 1
         enddo
      enddo

      call dsyev('v','u', n, a, lda, w, work, n*n, info)

      write(*,'(" Eigenvalues:",4f10.5)') w(1:n)

      write(*,'(" Eigenvectors:")')
      write(*,'(f10.5)') a(1:n,1:n)

      end


MODULE EulerEquationsUtilitiesModule_GR

  USE, INTRINSIC :: ieee_arithmetic, ONLY: &
    IEEE_IS_NAN

  USE KindModule, ONLY: &
    DP, SqrtTiny
  USE GeometryFieldsModule, ONLY: &
    iGF_Gm_dd_11, iGF_Gm_dd_22, iGF_Gm_dd_33
  USE FluidFieldsModule, ONLY: &
    iCF_D, iCF_S1, iCF_S2, iCF_S3, iCF_E, iCF_Ne, nCF, &
    iPF_D, iPF_V1, iPF_V2, iPF_V3, iPF_E, iPF_Ne, &
    iAF_P
  USE EquationOfStateModule, ONLY: &
    ComputePressureFromSpecificInternalEnergy

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: ComputeConserved
  PUBLIC :: ComputePrimitive
  PUBLIC :: Eigenvalues
  PUBLIC :: ComputeSoundSpeed
  PUBLIC :: Flux_X1
  PUBLIC :: AlphaC

CONTAINS

  SUBROUTINE ComputeConserved( uPF, uAF, uGF, uCF )

    REAL(DP), DIMENSION(:,:), INTENT(in)  :: uPF
    REAL(DP), DIMENSION(:,:), INTENT(in)  :: uAF
    REAL(DP), DIMENSION(:,:), INTENT(in)  :: uGF
    REAL(DP), DIMENSION(:,:), INTENT(out) :: uCF

    INTEGER  :: i
    REAL(DP) :: Gm11, Gm22, Gm33, vSq, W, h

    DO i = 1, SIZE( uCF, DIM = 1 )

      Gm11 = uGF(i,iGF_Gm_dd_11)
      Gm22 = uGF(i,iGF_Gm_dd_22)
      Gm33 = uGF(i,iGF_Gm_dd_33)

      vSq = Gm11 * uPF(i,iPF_V1)**2 &
            + Gm22 * uPF(i,iPF_V2)**2 &
            + Gm33 * uPF(i,iPF_V3)**2

      W = 1.0_DP / SQRT( 1.0_DP - vSq )
      h = 1.0_DP + ( uPF(i,iPF_E) + uAF(i,iAF_P) ) / uPF(i,iPF_D)

      uCF(i,iCF_D)  = W * uPF(i,iPF_D)
      uCF(i,iCF_S1) = h * W**2 * uPF(i,iPF_D) * Gm11 * uPF(i,iPF_V1)
      uCF(i,iCF_S2) = h * W**2 * uPF(i,iPF_D) * Gm22 * uPF(i,iPF_V2)
      uCF(i,iCF_S3) = h * W**2 * uPF(i,iPF_D) * Gm33 * uPF(i,iPF_V3)
      uCF(i,iCF_E)  = h * W**2 * uPF(i,iPF_D) - uAF(i,iAF_P) &
                        - W * uPF(i,iPF_D)
      uCF(i,iCF_Ne) = W * uPF(i,iPF_Ne)

    END DO

  END SUBROUTINE ComputeConserved

  SUBROUTINE ComputePrimitive( uCF, uGF, uPF, uAF )

    REAL(DP), DIMENSION(:,:), INTENT(in)  :: uCF
    REAL(DP), DIMENSION(:,:), INTENT(in)  :: uGF
    REAL(DP), DIMENSION(:,:), INTENT(out) :: uPF
    REAL(DP), DIMENSION(:,:), INTENT(out) :: uAF

    LOGICAL  :: Converged
    INTEGER  :: i, nIter
    REAL(DP) :: Gm11, Gm22, Gm33, SSq, vSq, W, h
    REAL(DP) :: Pold, Pnew, FunP, JacP
    REAL(DP), PARAMETER :: TolP = 1.0d-10

    DO i = 1, SIZE( uPF, DIM = 1 )

      Gm11 = uGF(i,iGF_Gm_dd_11)
      Gm22 = uGF(i,iGF_Gm_dd_22)
      Gm33 = uGF(i,iGF_Gm_dd_33)

      SSq =  uCF(i,iCF_S1)**2 / Gm11 &
           + uCF(i,iCF_S2)**2 / Gm22 &
           + uCF(i,iCF_S3)**2 / Gm33

      ! --- Find Pressure with Newton's Method ---

      ! --- Approximation for pressure assuming h^2=1
      Pold = SQRT( SSq + uCF(i,iCF_D)**2 ) - uCF(i,iCF_D) - uCF(i,iCF_E)
      ! --- Converges ~4 iterations

      !Pold = uAF(i,iAF_P) ! --- Initial Guess ! 1-3 iterations

      Converged = .FALSE.
      nIter     = 0

      DO WHILE ( .NOT. Converged )

         nIter = nIter + 1

       CALL ComputeFunJacP &
            ( uCF(i,iCF_D), SSq, uCF(i,iCF_E), Pold, FunP, JacP )

       Pnew = Pold - FunP / JacP

        IF( ABS( Pnew / Pold - 1.0_DP ) <= TolP ) Converged = .TRUE.

        IF( 1 == 1 )THEN
          IF( nIter .GT. 10 )THEN
          WRITE(*,'(A6,1x,I2,3x,A10,E27.20)') 'nIter:', &
                nIter,'|ERROR| =',ABS( Pnew / Pold - 1.0_DP )
          END IF
        END IF

        IF( nIter == 100)THEN
          WRITE(*,*) 'No convergence, |ERROR|:', ABS( Pnew / Pold - 1.0_DP )
          WRITE(*,*) 'Pold:                   ', Pold
          WRITE(*,*) 'Pnew:                   ', Pnew
          STOP
        END IF

        IF( IEEE_IS_NAN( Pnew ) )THEN
          WRITE(*,'(A6,1x,I2)') 'nIter:' , nIter
          WRITE(*,'(A6,1x,E9.2)') 'Pold:', Pold
          WRITE(*,'(A6,1x,E9.2)') 'Pnew:', Pnew
          WRITE(*,'(A6,1x,E9.2)') 'D:'   , uCF(i,iCF_D)
          STOP
        END IF

        Pold = Pnew

      END DO

      WRITE(*,'(A18,1x,I2,1x,A10)') 'Convergence after:' , nIter , 'iterations'

      uAF(i,iAF_P) = Pnew

      vSq = SSq / ( uCF(i,iCF_E) + Pnew + uCF(i,iCF_D) )**2

      W = 1.0_DP / SQRT( 1.0_DP - vSq )

      h = ( uCF(i,iCF_E) + Pnew + uCF(i,iCF_D) ) / ( W * uCF(i,iCF_D) )

      ! --- Recover Primitive Variables ---

      uPF(i,iPF_D)  = uCF(i,iCF_D) / W

      uPF(i,iPF_V1) = uCF(i,iCF_S1) / ( uCF(i,iCF_D) * h * W * Gm11 )

      uPF(i,iPF_V2) = uCF(i,iCF_S2) / ( uCF(i,iCF_D) * h * W * Gm22 )

      uPF(i,iPF_V3) = uCF(i,iCF_S3) / ( uCF(i,iCF_D) * h * W * Gm33 )

      uPF(i,iPF_E)  = uCF(i,iCF_D) * ( h - 1.0_DP ) / W - Pnew

      uPF(i,iPF_Ne) = uCF(i,iCF_Ne) / W

    END DO

  END SUBROUTINE ComputePrimitive

  PURE FUNCTION Eigenvalues( V1, V2, V3, Gm_dd_11, Gm_dd_22, Gm_dd_33, &
                              Alpha, Beta1, Cs )

    ! Alpha is the lapse function
    ! Vi is the contravariant component V^i
    ! Beta1 is the contravariant component Beta^1

    REAL(DP), INTENT(in) :: V1, V2, V3, Gm_dd_11, Gm_dd_22, Gm_dd_33, &
                              Alpha, Beta1, Cs
    REAL(DP) :: VSq
    REAL(DP), DIMENSION(1:5) :: Eigenvalues

    Vsq = Gm_dd_11 * V1**2 + Gm_dd_22 * V2**2 + Gm_dd_33 * V3**2

    Eigenvalues(1:5) = &
      [ Alpha / ( 1.0_DP - VSq * Cs**2 ) * ( V1 * ( 1.0_DP - Cs**2 ) - Cs &
        * SQRT( ( 1.0_DP - VSq ) * ( 1.0_DP / Gm_dd_11 &
        * ( 1.0_DP - VSq * Cs**2 ) - V1**2 * ( 1.0_DP - Cs**2 )))) - Beta1, &

        Alpha * V1 - Beta1, &

        Alpha / ( 1.0_DP - VSq * Cs**2 ) * ( V1 * ( 1.0_DP - Cs**2 ) + Cs &
        * SQRT( ( 1.0_DP - VSq ) * ( 1.0_DP / Gm_dd_11 &
        * ( 1.0_DP - VSq * Cs**2 ) - V1**2 * ( 1.0_DP - Cs**2 )))) - Beta1, &

        Alpha * V1 - Beta1, &

        Alpha * V1 - Beta1 ]

    RETURN
  END FUNCTION Eigenvalues

  PURE FUNCTION ComputeSoundSpeed( p, e, rho, Gamma ) RESULT( Cs )

    REAL(DP), INTENT(in) :: p, e, rho, Gamma
    REAL(DP) :: Cs

    Cs = SQRT ( Gamma * p / ( rho + e + p ) )

  END FUNCTION ComputeSoundSpeed

  FUNCTION Flux_X1 &
    ( D, V1, V2, V3, E, P, Ne, Alpha, Beta1, Gm11, Gm22, Gm33 )

    REAL(DP), INTENT(in)       :: D, V1, V2, V3, E, P, Ne
    REAL(DP), INTENT(in)       :: Alpha, Beta1, Gm11, Gm22, Gm33
    REAL(DP), DIMENSION(1:nCF) :: Flux_X1

    REAL(DP) :: vSq, W, h

    vSq = Gm11 * V1**2 + Gm22 * V2**2 + Gm33 * V3**2

    W   = 1.0_DP / SQRT( 1.0_DP - vSq )

    h   = 1.0_DP + ( E + P ) / D

    Flux_X1(iCF_D)  &
      = W * D * ( Alpha * V1 - Beta1 )

    Flux_X1(iCF_S1) &
      = D * h * W**2 * Gm11 * V1 * ( Alpha * V1 - Beta1 ) + Alpha * P

    Flux_X1(iCF_S2) &
      = D * h * W**2 * Gm22 * V2 * ( Alpha * V1 - Beta1 )

    Flux_X1(iCF_S3) &
      = D * h * W**2 * Gm33 * V3 * ( Alpha * V1 - Beta1 )

    Flux_X1(iCF_E)  &
      = ( D * h * W**2 - D * W ) * ( Alpha * V1 - Beta1 ) + Beta1 * P

    Flux_X1(iCF_Ne) &
      = W * Ne * ( Alpha * V1 - Beta1 )

    RETURN
  END FUNCTION Flux_X1

  SUBROUTINE ComputeFunJacP( D, SSq, E, P, FunP, JacP )

    REAL(DP), INTENT(in)  :: D, SSq, E, P
    REAL(DP), INTENT(out) :: FunP, JacP

    REAL(DP) :: HSq, RHO, EPS, dRHO, dEPS
    REAL(DP), DIMENSION(1) :: Pbar

    HSq = ( E + P + D )**2

    RHO = D * SQRT( HSq - SSq ) / SQRT( HSq )

    EPS = ( SQRT( HSq - SSq ) &
            - P * SQRT( HSq ) / SQRT( HSq - SSq ) - D ) / D

    CALL ComputePressureFromSpecificInternalEnergy &
           ( [ RHO ], [ EPS ], [ 0.0_DP ], Pbar )

    FunP = P - Pbar(1)

    dRHO = D * SSq / ( SQRT( HSq - SSq ) * HSq )
    dEPS = P * SSq / ( ( HSq - SSq ) * SQRT( HSq ) * RHO )

    JacP = 1.0_DP - Pbar(1) * ( dRHO / RHO + dEPS / EPS )

  END SUBROUTINE ComputeFunJacP

  REAL(DP) FUNCTION AlphaC( U_L, U_R, F_L, F_R, aP, aM, Gm_dd_11, Beta_u_1 )

    ! --- Middle Wavespeed as Suggested by Mignone and Bodo (2005) ---

    REAL(DP), INTENT(in) :: U_L(nCF), U_R(nCF), F_L(nCF), F_R(nCF), aP, aM, Gm_dd_11, Beta_u_1
    REAL(DP)             :: U_S1, U_E, F_S1, F_E, A, B, C, eps

    eps = SqrtTiny

    ! --- Note the sign change on aM which is due
    ! --- to it being read in as positive but the formulae assuming
    ! --- it is negative
    ! --- Also note that we use tau instead of E

    U_S1 = aP * U_R(iCF_S1) + aM * U_L(iCF_S1) + F_L(iCF_S1) - F_R(iCF_S1)

    U_E  = aP * ( U_R(iCF_E) + U_R(iCF_D) ) + aM * ( U_L(iCF_E) + U_L(iCF_D) ) &
          + ( F_L(iCF_E) + F_L(iCF_D) + Beta_u_1 * U_L(iCF_E) ) &
          - ( F_R(iCF_E) + F_R(iCF_D) + Beta_u_1 * U_R(iCF_E) )

    F_S1 =  aP * F_L(iCF_S1) + aM * F_R(iCF_S1) &
          - aP * aM * ( U_R(iCF_S1) - U_L(iCF_S1 ) )

    F_E  =  aP * ( F_L(iCF_E) + F_L(iCF_D) + Beta_u_1 * U_L(iCF_E) ) &
          + aM * ( F_R(iCF_E) + F_R(iCF_D) + Beta_u_1 * U_R(iCF_E) ) &
          - aP * aM * ( ( U_R(iCF_E) + U_R(iCF_D) ) &
          - ( U_L(iCF_E) + U_L(iCF_D) ) )

    ! --- A, B, and C from quadratic equation
    A = Gm_dd_11**2 * ( F_E + Beta_u_1 * U_E )
    B = -Gm_dd_11 * ( U_E + F_S1 + Beta_u_1 * U_S1 )
    C = U_S1

    ! --- Accounting for special cases of the solution to a
    ! --- quadratic equation when A = 0

    IF     ( ( ABS( A ) .LT. eps ) .AND. ( ABS( B ) .LT. eps ) &
            .AND. ( ABS( C ) .LT. eps ) )THEN
      WRITE(*,*) 'AlphaC is undefined'
      AlphaC = 0.0_DP
    ELSE IF( ( ABS( A ) .LT. eps ) .AND. ( ABS( B ) .LT. eps ) )THEN
      WRITE(*,*) 'AlphaC is undefined'
      WRITE(*,*) 'C:', C
      AlphaC = 0.0_DP
    ELSE IF( ( ABS( A ) .LT. eps ) .AND. ( ABS( C ) .LT. eps ) )THEN
      AlphaC = 0.0_DP
    ELSE IF( ABS( A ) .LT. eps )THEN
      AlphaC = -C / B
    ELSE
      AlphaC = ( -B - SQRT( B**2 - 4.0_DP * A * C ) ) / ( 2.0_DP * A )
    END IF

    RETURN

  END FUNCTION AlphaC

END MODULE EulerEquationsUtilitiesModule_GR


c
c
c
c     =================================================
      function fdisc(x,y)
c     =================================================
      implicit double precision (a-h,o-z)
      common/cdisc/ x0,y0,alf,beta,r0,idisc
c
c     # for computing cell averages for initial data that has a
c     # discontinuity along some curve.  fdisc should be negative to the
c     # left of the curve and positive to the right
c     # idisc specifies the nature of the discontinuity for two
c     # particular cases (a straight line and circle) but this routine
c     # can be modified for any other curve.
c
      go to (10,20) idisc
c
   10 continue
c     # straight line through (x0,y0) with normal (alf,beta) pointing
c     # into right state
c
      fdisc = (x-x0)*alf + (y-y0)*beta
      return
c
   20 continue
c     # circle of radius r0:
      fdisc = (x-x0)**2 + (y-y0)**2 - r0**2
c
      return
      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> The driver program for the spec benchmark.
!! This program computes the inverse of a matrix using hotelling's method.
PROGRAM PremadeMatrixProgram
  USE DataTypesModule, ONLY : NTREAL
  USE InverseSolversModule, ONLY : Invert
  USE LoggingModule, ONLY : EnterSubLog, ExitSubLog, WriteElement, WriteHeader
  USE PermutationModule, ONLY : Permutation_t, ConstructRandomPermutation
  USE ProcessGridModule, ONLY : ConstructProcessGrid, IsRoot, &
       & DestructProcessGrid
  USE PSMatrixModule, ONLY : Matrix_ps, ConstructMatrixFromMatrixMarket, &
       & DestructMatrix, ConstructEmptyMatrix, FillMatrixIdentity
  USE PSMatrixAlgebraModule, ONLY : MatrixMultiply, MatrixNorm, IncrementMatrix
  USE SolverParametersModule, ONLY : SolverParameters_t
  USE SquareRootSolversModule, ONLY : InverseSquareRoot
  USE MPI
  IMPLICIT NONE
  REAL(NTREAL), PARAMETER :: checkval = 5e-2_NTREAL
  REAL(NTREAL), PARAMETER :: converge = 1e-5_NTREAL
  !! Variables for handling input parameters.
  CHARACTER(len=80) :: input_file
  REAL(NTREAL) :: threshold
  TYPE(SolverParameters_t) :: solver_parameters
  TYPE(Permutation_t) :: permutation
  !! Matrices
  TYPE(Matrix_ps) :: Input
  TYPE(Matrix_ps) :: Identity
  TYPE(Matrix_ps) :: Result
  TYPE(Matrix_ps) :: Reference
  TYPE(Matrix_ps) :: Temp
  !! Temporary Variables
  CHARACTER(len=80) :: argument
  CHARACTER(len=80) :: argument_value
  INTEGER :: counter
  INTEGER :: provided, ierr
  INTEGER :: rank
  INTEGER :: II, loop_times
  REAL(NTREAL) :: error

  !! Setup MPI
  CALL MPI_Init_thread(MPI_THREAD_SERIALIZED, provided, ierr)
  CALL MPI_Comm_rank(MPI_COMM_WORLD,rank, ierr)

  !! Process the input parameters.
  DO counter=1,command_argument_count(),2
     CALL get_command_argument(counter,argument)
     CALL get_command_argument(counter+1,argument_value)
     SELECT CASE(argument)
     CASE('--input')
        input_file = argument_value
     CASE('--threshold')
        READ(argument_value,*) threshold
     CASE('--loop_times')
        READ(argument_value,*) loop_times
     END SELECT
  END DO

  !! Setup the process grid.
  CALL ConstructProcessGrid(MPI_COMM_WORLD)

  CALL WriteHeader("Command Line Parameters")
  CALL EnterSubLog
  CALL WriteElement(key="input", value=input_file)
  CALL WriteElement(key="threshold", value=threshold)
  CALL WriteElement(key="loop_times", value=loop_times)
  CALL ExitSubLog

  !! Read in the matrices from file.
  CALL ConstructMatrixFromMatrixMarket(Input, input_file)
  CALL ConstructEmptyMatrix(Identity, Input)
  CALL FillMatrixIdentity(Identity)

  !! Set Up The Solver Parameters.
  CALL ConstructRandomPermutation(permutation, Input%logical_matrix_dimension)
  solver_parameters = SolverParameters_t(&
       & converge_diff_in=converge, threshold_in=threshold, &
       & BalancePermutation_in=permutation, be_verbose_in=.TRUE.)

  !! Call the solver routine.
  !! Time this part.
  DO II = 1, loop_times
     CALL InverseSquareRoot(Input, Result, solver_parameters)
  END DO

  !! Check The Answer
  CALL MatrixMultiply(Input, Result, Temp, threshold_in=threshold)
  CALL MatrixMultiply(Result, Temp, Reference, threshold_in=threshold)
  CALL IncrementMatrix(Identity, Reference, alpha_in=-1.0_NTREAL)
  error = MatrixNorm(Reference)
  CALL WriteElement(key="error", value=error)
  IF (error .GT. checkval) THEN
     CALL MPI_Abort(MPI_COMM_WORLD, 1, ierr)
  END IF

  !! Cleanup
  CALL DestructMatrix(Input)
  CALL DestructMatrix(Reference)
  CALL DestructMatrix(Result)
  CALL DestructProcessGrid
  CALL MPI_Finalize(ierr)
END PROGRAM PremadeMatrixProgram


c     ============================================
      subroutine setaux(maxmx,mbc,mx,xlower,dx,maux,aux)
c     ============================================
c
c     # set auxiliary arrays
c
      implicit none
      double precision aux(1-mbc:maxmx+mbc, *)

      integer maxmx,mbc,mx,maux
      double precision xlower,dx

      integer m,i
      double precision xcell,theta_init,theta_init_flume,topo_init
      double precision phi_init

      include "digparamsdec.i"
      include "digparamscommon.i"

      do i=1-mbc,mx+mbc
         do m=1,maux
            aux(i,m)=0.d0
         enddo
         xcell = xlower + (i-0.5d0)*dx

         if (init_htype.eq.0) then
             aux(i,i_theta) = theta_init_flume(xcell)
             aux(i,i_topo) = 0.d0
             aux(i,i_phi) =  phi_bed
         else
             aux(i,i_theta) = theta_init(xcell)
             aux(i,i_topo) = topo_init(xcell)
             aux(i,i_phi) = phi_init(xcell,phi_bed,phi_int)
         endif
      enddo

      return
      end

c=======================================================================
      function theta_init_flume(xcell)
c
c     function to return the flume geometry, given x, for the flume hopper
c     uses parameters set in digparams
c=======================================================================
      implicit none

      double precision theta_init_flume
      double precision D2,theta,xcell

      include "digparamsdec.i"
      include "digparamscommon.i"

      D2 = flumelen + flumerad*(theta1-theta2)

      if (xcell.lt.flumelen) then
          theta=theta1
      elseif (xcell.gt.D2) then
          theta=theta2
      else
          theta=theta1-(xcell-flumelen)/flumerad
      endif
      theta_init_flume = theta
      return
      end