!
!=======================================================================
!
MODULE INTEGRATION
!
!  This module contains integration routines in order to integrate
!    a function F over the interval [A,B].
!
!  These routines are:
!
!
!   * Lagrange                              :  INTEGR_L(F,DR,NSIZE,NMAX,A,ID)
!
!   * N-point Gauss-Legendre                :  GAUSS_LEG(FCT,A,B,NGL,RES)
!
!   * CERNLIB adaptive Gauss quadrature     :  DGAUSS1(OM,KK,A,B,EPS)
!
!   * double exponential transformation     :  INTDE(F,A,B,EPS,I,ERR)
!
!   * fast double exponential transformation:  INTDE_F(F,A,B,AW,I,ERR)
!
!   * Romberg                               :  RBI1(FCT,A,B,PREC,OBTPREC,NITER,ITERMIN,ITERMAX)
!
!   * Simpson                               :  SIMPSON(FCT,A,B,N,RES)
!
!   *                                       :  QANC8(FCT,A,B,AERR,RERR,RES,ERR,NBF,FLG)
!
!
      USE ACCURACY_REAL
!
CONTAINS
!
!=======================================================================
!
      SUBROUTINE INTEGR_L(F,DR,NSIZE,NMAX,A,ID)
!
!.....Based on Lagrange integration formula 25.4.12
!
!     (See Table 25.3 for numerical coefficients) - Chapter 25 of
!     Abramowitz & Stegun, "Handbook of mathematical functions",
!     page 886 (Dover)
!
!
!  Input parameters:
!
!       * F        : function to be integrated
!       * DR       : constant grid step
!       * NSIZE    : dimensioning of the arrays
!       * NMAX     : index of upper limit of integration on the r mesh
!       * ID       : integer parameter
!                       ID  = 1  --> F0 = 0 at the origin
!                       ID  > 1  --> F0 not 0 at the origin
!
!
!  Output parameters:
!
!       * A        : integral result
!
!
!                      --> Real function F case <--
!
!   Author :  C. R. Natoli
!
!                                    Last modified (DS) :  2 Nov 2020
!
!
      USE REAL_NUMBERS,     ONLY : ZERO,FIVE,NINE
!
      IMPLICIT NONE
!
      REAL (WP), INTENT(IN)  ::  F(NSIZE),DR
      REAL (WP), INTENT(OUT) ::  A
!
      REAL (WP)              ::  H,A0,F0
      REAL (WP)              ::  S720,S251,S646,S264
      REAL (WP)              ::  S106,S19,S346,S456,S74,S11
!
      INTEGER, INTENT(IN)    ::  NSIZE,NMAX,ID
!
      INTEGER                ::  K0,KX,K
!
!  Coefficients given by table 25.3 p. 915:
!
      S720 = 720.0E0_WP                                             !
      S251 = 251.0E0_WP                                             !
      S646 = 646.0E0_WP                                             !
      S264 = 264.0E0_WP                                             !
      S106 = 106.0E0_WP                                             !
      S19  =  19.0E0_WP                                             !
      S346 = 346.0E0_WP                                             !
      S456 = 456.0E0_WP                                             !
      S74  =  74.0E0_WP                                             !
      S11  =  11.0E0_WP                                             !
!
      H  = DR                                                       !
      A0 = ZERO                                                     !
!
      IF(ID == 1) THEN                                              !
        F0 = ZERO                                                   !
        K0 = 0                                                      !
      ELSE                                                          !
        F0 = F(1)                                                   !
        K0 = 1                                                      !
      END IF                                                        !
!
      KX = NMAX                                                     !
!
      A = A0 + H * ( S251 * F0      + S646 * F(K0+1) -            & !
                     S264 * F(K0+2) + S106 * F(K0+3) -            & !
                     S19  * F(K0+4)                               & !
                   ) / S720                                         !
      A = A  + H * ( -S19 * F0      + S346 * F(K0+1) +            & !
                     S456 * F(K0+2) - S74  * F(K0+3) +            & !
                     S11  * F(K0+4)                               & !
                    ) / S720                                        !
      A = A  + H * ( S11  * F0      - S74  * F(K0+1) +            & !
                     S456 * F(K0+2) + S346 * F(K0+3) -            & !
                     S19  * F(K0+4)                               & !
                   ) / S720                                         !
!
      K0 = K0 + 4                                                   !
!
      DO K = K0, KX                                                 !
        A = A + H * ( NINE * F(K)   + 19.0E0_WP * F(K-1) -        & !
                      FIVE * F(K-2) +  F(K-3)                     & !
                    ) / 24.0E0_WP                                   !
      END DO                                                        !
!
      END SUBROUTINE INTEGR_L
!
!=======================================================================
!
      SUBROUTINE GAUSS_LEG(FCT,A,B,NGL,RES)
!
!  This subroutine performs a Gauss-Legendre integration of
!    the external function FCT
!
!
!
!   Author :  D. Sébilleau
!
!                                           Last modified :  5 Jun 2020
!
!
      USE REAL_NUMBERS,     ONLY : ZERO
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN)    :: NGL
!
      INTEGER                :: J
!
      REAL (WP), INTENT(IN)  ::  A,B
      REAL (WP), INTENT(OUT) ::  RES
!
      REAL (WP)              ::  XGL(NGL),WGT(NGL)
!
      REAL (WP), EXTERNAL   ::  FCT
!
!  Construct Gauss-Legendre points from Numerical Recipes subroutine
!
      CALL GAULEG(A,B,XGL,WGT,NGL)                                  !
!
!  Performing the integral
!
      RES = ZERO                                                    !
      DO J = 1, NGL                                                 !
        RES = RES + WGT(J) * FCT(XGL(J))                            !
      END DO                                                        !
!
      END SUBROUTINE GAUSS_LEG
!
!=======================================================================
!
      SUBROUTINE GAULEG(X1,X2,X,W,N)
!
!  Given the lower and upper limits of integration X1 and X2,
!    and given N, this routine returns arrays X[1..N] and W[1..N]
!    of length N, containing the abscissas and weights
!    of the Gauss-Legendre N-point quadrature formula
!
!            This subroutine is taken from the book :
!
!          "Numerical Recipes : The Art of Scientific
!           Computing" par W.H. Press, B.P. Flannery,
!               S.A. Teukolsky et W.T. Vetterling
!               (Cambridge University Press 1992)
!
!                       p. 145
!
!  Input parameters:
!
!       X1       :  lower limit of integration
!       X2       :  upper limit of integration
!       N        :  order of the Gauss-Legendre quadrature formula
!
!
!  Output parameters:
!
!       X        :  abscissas for Gauss-Legendre N-point quadrature formula
!       W        :  weights for Gauss-Legendre N-point quadrature formula
!
!
!
      USE REAL_NUMBERS,     ONLY : ZERO,ONE,TWO,HALF,FOURTH
      USE PI_ETC,           ONLY : PI
!
      IMPLICIT NONE
!
      REAL (WP)             ::  X1,X2,X(N),W(N)
      REAL (WP)             ::  EPS
      REAL (WP)             ::  XM,XL,Z,Z1,P1,P2,P3,PP
!
      REAL (WP)             ::  DCOS,DFLOAT,DABS
!
      INTEGER N,M,I,J
!
      EPS=3.0E-14_WP                                                !
!
      M=(N+1)/2                                                     ! the roots are symmetric
      XM=HALF*(X2+X1)                                               ! in the interval, so we only
      XL=HALF*(X2-X1)                                               ! have to find half of them
!
!  Loop over the desired roots
!
      DO I=1,M                                                      !
!
!  Starting with the approximation to the ith root,
!    we enter the main loop of refinement by Newton’s method
!
        Z=DCOS(PI*(DFLOAT(I)-FOURTH)/(DFLOAT(N)+HALF))              ! approx for ith root
!
   1    CONTINUE                                                    !
!
        P1=ONE                                                      !
        P2=ZERO                                                     !
!
!  Loop up the recurrence relation to get the
!    Legendre polynomial evaluated at Z
!
        DO J=1,N                                                    !
          P3=P2                                                     !
          P2=P1                                                     !
          P1=((TWO*DFLOAT(J)-ONE)*Z*P2-(DFLOAT(J)-ONE)*P3)    &     !
               /DFLOAT(J)                                           !
        END DO                                                      !
!
!  P1 is now the desired Legendre polynomial. We next compute PP,
!    its derivative,by a standard relation involving also P2,
!    the polynomial of one lower order
!
        PP=DFLOAT(N)*(Z*P1-P2)/(Z*Z-ONE)                            !
        Z1=Z                                                        !
        Z=Z1-P1/PP                                                  ! Newton’s method
!
        IF(DABS(Z-Z1) > EPS) GO TO 1                                !
!
!  Scale the root to the desired interval and put in
!    its symmetric counterpart
!
        X(I)=XM-XL*Z                                                !
        X(N+1-I)=XM+XL*Z                                            !
!
!  Compute the weight and its symmetric counterpart
!
        W(I)=TWO*XL/((ONE-Z*Z)*PP*PP)                               !
        W(N+1-I)=W(I)                                               !
!
      END DO                                                        !
!
      END SUBROUTINE GAULEG
!
!=======================================================================
!
      FUNCTION DGAUSS1(FCT,OM,KK,A,B,EPS)
!
!     ******************************************************************
!
!     ADAPTIVE GAUSSIAN QUADRATURE.
!
!     GAUSS IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF
!     THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER
!     EPS.
!
!     ******************************************************************
!
!  Originally written by K.S. Kölbig for CERNLIB
!
!                                          First version: 12 May 1966
!                                          Revised      : 15 Mar 1993
!
! $Id: imp64.inc,v 1.1.1.1 1996/04/01 15:02:59 mclareni Exp $
!
! $Log: imp64.inc,v $
! Revision 1.1.1.1  1996/04/01 15:02:59  mclareni
! Mathlib gen
!
!
! imp64.inc
!
!
      USE REAL_NUMBERS,     ONLY : ZERO,ONE,TWO,FIVE
!
      IMPLICIT NONE
!
      REAL (WP)             ::  W(12),X(12)
      REAL (WP)             ::  CONST,AA,BB,U,S8,S16,C1,C2,H
      REAL (WP)             ::  Z1,HF,CST
      REAL (WP)             ::  A,B,EPS
      REAL (WP)             ::  DGAUSS1
      REAL (WP)             ::  OM
!
      REAL (WP)             ::  FCT
!
      REAL (WP)             ::  DABS
!
      INTEGER               ::  I,KK
      INTEGER               ::  LOGF
!
      PARAMETER (Z1 = ONE, HF = Z1/TWO, CST = FIVE*Z1/1000.0E0_WP)  !
!
      DATA X( 1) /9.6028985649753623E-01_WP/                        !
      DATA X( 2) /7.9666647741362674E-01_WP/                        !
      DATA X( 3) /5.2553240991632899E-01_WP/                        !
      DATA X( 4) /1.8343464249564980E-01_WP/                        !
      DATA X( 5) /9.8940093499164993E-01_WP/                        !
      DATA X( 6) /9.4457502307323258E-01_WP/                        !
      DATA X( 7) /8.6563120238783174E-01_WP/                        !
      DATA X( 8) /7.5540440835500303E-01_WP/                        !
      DATA X( 9) /6.1787624440264375E-01_WP/                        !
      DATA X(10) /4.5801677765722739E-01_WP/                        !
      DATA X(11) /2.8160355077925891E-01_WP/                        !
      DATA X(12) /9.5012509837637440E-02_WP/                        !
!
      DATA W( 1) /1.0122853629037626E-01_WP/                        !
      DATA W( 2) /2.2238103445337447E-01_WP/                        !
      DATA W( 3) /3.1370664587788729E-01_WP/                        !
      DATA W( 4) /3.6268378337836198E-01_WP/                        !
      DATA W( 5) /2.7152459411754095E-02_WP/                        !
      DATA W( 6) /6.2253523938647893E-02_WP/                        !
      DATA W( 7) /9.5158511682492785E-02_WP/                        !
      DATA W( 8) /1.2462897125553387E-01_WP/                        !
      DATA W( 9) /1.4959598881657673E-01_WP/                        !
      DATA W(10) /1.6915651939500254E-01_WP/                        !
      DATA W(11) /1.8260341504492359E-01_WP/                        !
      DATA W(12) /1.8945061045506850E-01_WP/                        !
!
      H=ZERO                                                        !
!
      LOGF=6                                                        !
!
      IF(B == A) GO TO 99                                           !
!
      CONST=CST/DABS(B-A)                                           !
      BB=A                                                          !
!
    1 AA=BB                                                         !
      BB=B                                                          !
!
    2 C1=HF*(BB+AA)                                                 !
      C2=HF*(BB-AA)                                                 !
!
      S8=ZERO                                                       !
      DO I = 1,4                                                    !
        U=C2*X(I)                                                   !
        S8=S8+W(I)*(FCT(C1+U,OM,KK)+FCT(C1-U,OM,KK))                !
      END DO                                                        !
!
      S16=ZERO                                                      !
      DO I = 5,12                                                   !
        U=C2*X(I)                                                   !
        S16=S16+W(I)*(FCT(C1+U,OM,KK)+FCT(C1-U,OM,KK))              !
      END DO                                                        !
      S16=C2*S16                                                    !
!
      IF(DABS(S16-C2*S8) <= EPS*(ONE+DABS(S16))) THEN               !
        H=H+S16                                                     !
        IF(BB /= B) GO TO 1                                         !
      ELSE                                                          !
        BB=C1                                                       !
        IF(ONE+CONST*DABS(C2) /= ONE) GO TO 2                       !
        H=ZERO                                                      !
!
        WRITE(LOGF,*)' DGAUSS: D103.1, too high accuracy required'  !
        STOP                                                        !
!
      END IF                                                        !
!
   99 DGAUSS1=H                                                     !
!
      END FUNCTION DGAUSS1
!
!=======================================================================
!
      SUBROUTINE INTDE(F,A,B,EPS,I,ERR)
!
!  This subroutine is the integrator of f(x) over (a,b)
!
!
!  Input parameters:
!
!       * F        : integrand f(x)
!       * A        : lower limit of integration
!       * B        : upper limit of integration
!       * EPS      : relative error requested
!
!
!  Output variables:
!
!       * I        : approximation to the integral
!       * ERR      : estimate of the absolute error
!
!
!  Remarks:
!
!         function
!             f(x) needs to be analytic over (a,b).
!         relative error
!             EPS is relative error requested excluding
!             cancellation of significant digits.
!             i.e. EPS means : (absolute error) /
!                              (integral_a^b |f(x)| dx).
!             EPS does not mean : (absolute error) / I.
!         error message
!             ERR >= 0 : normal termination.
!             ERR < 0  : abnormal termination (M >= MMAX).
!                        i.e. convergent error is detected :
!                            1. f(x) or (d/dx)^n f(x) has
!                               discontinuous points or sharp
!                               peaks over (a,b).
!                               you must divide the interval
!                               (a,b) at this points.
!                            2. relative error of f(x) is
!                               greater than eps.
!                            3. f(x) has oscillatory factor
!                               and frequency of the oscillation
!                               is very high.
!
!    Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp).
!    You may use, copy, modify this code for any purpose and
!    without fee. You may distribute this ORIGINAL package.
!
!
!   Modified: D. Sébilleau   4 Jun 2020
!
!
      USE REAL_NUMBERS,     ONLY : ONE,TWO,FOUR,HALF,FOURTH
!
      IMPLICIT NONE
!
      REAL (WP)             ::  A,B,EPS,I,ERR
      REAL (WP)             ::  EFS,HOFF
      REAL (WP)             ::  PI2,EPSLN,EPSH,H0,EHP,EHM,EPST,BA,IR,H
      REAL (WP)             ::  IBACK,IRBACK,T,EP,EM,XW,XA,WG,FA,FB,ERRT
      REAL (WP)             ::  ERRH,ERRD
!
      REAL (WP), EXTERNAL   ::  F
!
      REAL (WP)             ::  DATAN,DLOG,DSQRT,DEXP,DABS
!
      INTEGER               ::  MMAX
      INTEGER               ::  M
!
! ---- adjustable parameter ----
!
      MMAX = 256                                                    !
      EFS  = 0.1E0_WP                                               !
      HOFF = 8.5E0_WP                                               !
!
! ------------------------------
!
      PI2   = TWO*DATAN(ONE)                                        !
      EPSLN = ONE-DLOG(EFS*EPS)                                     !
      EPSH  = DSQRT(EFS*EPS)                                        !
      H0    = HOFF/EPSLN                                            !
      EHP   = DEXP(H0)                                              !
      EHM   = ONE/EHP                                               !
      EPST  = DEXP(-EHM*EPSLN)                                      !
      BA    = B-A                                                   !
      IR    = F((A+B)*HALF)*(BA*FOURTH)                             !
      I     = IR*(TWO*PI2)                                          !
      ERR   = DABS(I)*EPST                                          !
      H     = TWO  *H0                                              !
      M     = 1                                                     !
!
   10 CONTINUE                                                      !
!
      IBACK  = I                                                    !
      IRBACK = IR                                                   !
      T      = H*HALF                                               !
!
   20 CONTINUE                                                      !
!
      EM = DEXP(T)                                                  !
      EP = PI2*EM                                                   !
      EM = PI2/EM                                                   !
!
   30 CONTINUE                                                      !
!
      XW   = ONE/(ONE+DEXP(EP-EM))                                  !
      XA   = BA*XW                                                  !
      WG   = XA*(ONE-XW)                                            !
      FA   = F(A+XA)*WG                                             !
      FB   = F(B-XA)*WG                                             !
      IR   = IR+(FA+FB)                                             !
      I    = I+(FA+FB)*(EP+EM)                                      !
      ERRT = (DABS(FA)+DABS(FB))*(EP+EM)                            !
!
      IF(M == 1) ERR = ERR+ERRT*EPST                                !
!
      EP = EP*EHP                                                   !
      EM = EM*EHM                                                   !
!
      IF(ERRT > ERR .OR. XW > EPSH) GO TO 30                        !
!
      T = T+H                                                       !
!
      IF(T < H0) GO TO 20                                           !
!
      IF(M == 1) THEN                                               !
        ERRH = (ERR/EPST)*EPSH*H0                                   !
        ERRD = ONE + TWO*ERRH                                       !
      ELSE                                                          !
        ERRD = H*(DABS(I-TWO*IBACK) + FOUR*DABS(IR-TWO*IRBACK))     !
      END IF                                                        !
!
      H = H*HALF                                                    !
      M = M*2                                                       !
!
      IF(ERRD > ERRH .AND. M < MMAX) GO TO 10                       !
!
      I = I*H                                                       !
!
      IF(ERRD > ERRH) THEN                                          !
        ERR = -ERRD*M                                               !
      ELSE                                                          !
        ERR = ERRH*EPSH*M / (TWO*EFS)                               !
      END IF                                                        !
!
      END SUBROUTINE INTDE
!
!=======================================================================
!
      SUBROUTINE INTDE_F(F,A,B,AW,I,ERR)
!
!  This subroutine is the integrator of f(x) over (a,b)
!
!
!              -->                           <--
!              --> This is the fast version  <--
!              -->                           <--
!
!
!  Usage:
!
!         CALL INTDEINI(LENAW,TINY,EPS,AW)        ! initialization of AW
!         ...
!         CALL INTDE_F(F,A,B,AW,I,ERR)
!
!
!  Input parameters:
!
!       * F        : integrand f(x)
!       * A        : lower limit of integration
!       * B        : upper limit of integration
!       * AW       : points and weights of the quadrature
!                      formula, AW(0...LENAW-1)
!
!
!  Output variables:
!
!       * I        : approximation to the integral
!       * ERR      : estimate of the absolute error
!
!
!  Remarks:
!
!         initial parameters
!             LENAW > 1000,
!             IEEE double :
!                 LENAW = 8000
!                 TINY  = 1.0D-307
!         function
!             f(x) needs to be analytic over (a,b).
!         relative error
!             EPS is relative error requested excluding
!             cancellation of significant digits.
!             i.e. EPS means : (absolute error) /
!                              (integral_a^b |f(x)| dx).
!             EPS does not mean : (absolute error) / I.
!         error message
!             ERR >= 0 : normal termination.
!             ERR < 0  : abnormal termination (M >= MMAX).
!                        i.e. convergent error is detected :
!                            1. f(x) or (d/dx)^n f(x) has
!                               discontinuous points or sharp
!                               peaks over (a,b).
!                               you must divide the interval
!                               (a,b) at this points.
!                            2. relative error of f(x) is
!                               greater than eps.
!                            3. f(x) has oscillatory factor
!                               and frequency of the oscillation
!                               is very high.
!
!    Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp).
!    You may use, copy, modify this code for any purpose and
!    without fee. You may distribute this ORIGINAL package.
!
!
!   Modified: D. Sébilleau   4 Jun 2020
!
!
      USE REAL_NUMBERS,     ONLY : ONE,TWO,HALF
!
      IMPLICIT NONE
!
      REAL (WP)             ::  A,B,AW(0 : *),I,ERR
      REAL (WP)             ::  EPSH,BA,IR,XA,FA,FB,ERRT,ERRH,ERRD,H,IBACK,IRBACK
!
      REAL (WP), EXTERNAL   ::  F
!
      REAL (WP)             ::  DABS
!
      INTEGER               ::  NOFF,LENAWM,NK,K,J,JTMP,JM,M,KLIM
!
      INTEGER               ::  INT
!
      NOFF   = 5                                                    !
      LENAWM = INT(AW(0)+HALF)                                      !
      NK     = INT(AW(1)+HALF)                                      !
      EPSH   = AW(4)                                                !
      BA     = B - A                                                !
      I      = F((A+B) * AW(NOFF))                                  !
      IR     = I * AW(NOFF+1)                                       !
      I      = I * AW(NOFF+2)                                       !
      ERR    = DABS(I)                                              !
      K      = NK + NOFF                                            !
      J      = NOFF                                                 !
!
   10 CONTINUE                                                      !
!
      J   = J + 3                                                   !
      XA  = BA * AW(J)                                              !
      FA  = F(A+XA)                                                 !
      FB  = F(B-XA)                                                 !
      IR  = IR + (FA+FB) * AW(J+1)                                  !
      FA  = FA * AW(J+2)                                            !
      FB  = FB * AW(J+2)                                            !
      I   = I + (FA+FB)                                             !
      ERR = ERR + (DABS(FA)+DABS(FB))                               !
!
      IF (AW(J) > EPSH .AND. J < K) GO TO 10                        !
!
      ERRT = ERR * AW(3)                                            !
      ERRH = ERR * EPSH                                             !
      ERRD = ONE + TWO*ERRH                                         !
      JTMP = J                                                      !
!
      DO WHILE (DABS(FA) > ERRT .AND. J < K)                        !
        J  = J + 3                                                  !
        FA = F(A + BA*AW(J))                                        !
        IR = IR + FA*AW(J+1)                                        !
        FA = FA * AW(J+2)                                           !
        I  = I + FA                                                 !
      END DO                                                        !
!
      JM = J                                                        !
      J  = JTMP                                                     !
!
      DO WHILE (DABS(FB) > ERRT .AND. J < K)                        !
        J  = J + 3                                                  !
        FB = F(B - BA*AW(J))                                        !
        IR = IR + FB*AW(J+1)                                        !
        FB = FB * AW(J+2)                                           !
        I  = I + FB                                                 !
      END DO                                                        !
!
      IF(J < JM) JM = J                                             !
!
      JM   = JM - (NOFF+3)                                          !
      H    = ONE                                                    !
      M    = 1                                                      !
      KLIM = K + NK                                                 !
!
      DO WHILE (ERRD > ERRH .AND. KLIM <= LENAWM)                   !
        IBACK  = I                                                  !
        IRBACK = IR                                                 !
!
   20   CONTINUE                                                    !
!
        JTMP = K + JM                                               !
        DO J = K + 3, JTMP, 3                                       !
          XA = BA*AW(J)                                             !
          FA = F(A + XA)                                            !
          FB = F(B - XA)                                            !
          IR = IR + (FA + FB)*AW(J+1)                               !
          I  = I + (FA + FB)*AW(J+2)                                !
        END DO                                                      !
!
        K = K + NK                                                  !
        J = JTMP                                                    !
!
   30   CONTINUE                                                    !
!
        J  = J + 3                                                  !
        FA = F(A + BA*AW(J))                                        !
        IR = IR + FA*AW(J+1)                                        !
        FA = FA * AW(J+2)                                           !
        I  = I + FA                                                 !
!
        IF(DABS(FA) > ERRT .AND. J < K) GO TO 30                    !
!
        J  = JTMP                                                   !
!
   40   CONTINUE                                                    !
!
        J  = J + 3                                                  !
        FB = F(B - BA*AW(J))                                        !
        IR = IR + FB*AW(J+1)                                        !
        FB = FB * AW(J+2)                                           !
        I  = I + FB                                                 !
!
        IF(DABS(FB) > ERRT .AND. J < K) GO TO 40                    !
!
        IF(K < KLIM) GO TO 20                                       !
!
        ERRD = H * (DABS(I-2*IBACK) + DABS(IR-2*IRBACK))            !
        H    = H * HALF                                             !
        M    = M * 2                                                !
        KLIM = 2*KLIM - NOFF                                        !
      END DO                                                        !
!
      I = I * (H*BA)                                                !
      IF(ERRD > ERRH) THEN                                          !
          ERR = -ERRD * (M * DABS(BA))                              !
      ELSE                                                          !
          ERR = ERR * AW(2)*(M * DABS(BA))                          !
      END IF                                                        !
!
      END SUBROUTINE INTDE_F
!
!=======================================================================
!
      SUBROUTINE INTDEINI_F(LENAW,TINY,EPS,AW)
!
!  This subroutine calculates the points and weights of the quadrature
!                      formula
!
!    Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp).
!    You may use, copy, modify this code for any purpose and
!    without fee. You may distribute this ORIGINAL package.
!
!
!   Modified: D. Sébilleau   4 Jun 2020
!
!
      USE REAL_NUMBERS,     ONLY : ZERO,ONE,TWO,FOUR,HALF
!
      IMPLICIT NONE
!
      REAL (WP)             ::  TINY,EPS,AW(0 : LENAW - 1)
      REAL (WP)             ::  EFS,HOFF
      REAL (WP)             ::  PI2,TINYLN,EPSLN,H0,EHP,EHM,H,T,EP,EM,XW,WG
!
      REAL (WP)             ::  DATAN,DLOG,DEXP,DSQRT
!
      INTEGER               ::  LENAW
      INTEGER               ::  NOFF,NK,K,J
!
! ---- adjustable parameter ----
!
      EFS  = 0.1E0_WP                                               !
      HOFF = 8.5E0_WP                                               !
!
! ------------------------------
!
      PI2    = TWO * DATAN(ONE)                                     !
      TINYLN = -DLOG(TINY)                                          !
      EPSLN  = ZERO - DLOG(EFS*EPS)                                 !
      H0     = HOFF / EPSLN                                         !
      EHP    = DEXP(H0)                                             !
      EHM    = ONE / EHP                                            !
      AW(2)  = EPS                                                  !
      AW(3)  = DEXP(-EHM*EPSLN)                                     !
      AW(4)  = DSQRT(EFS*EPS)                                       !
      NOFF   = 5                                                    !
      AW(NOFF)   = HALF                                             !
      AW(NOFF+1) = H0                                               !
      AW(NOFF+2) = PI2 * H0 * HALF                                  !
      H  = TWO                                                      !
      NK = 0                                                        !
      K  = NOFF + 3                                                 !
!
   10 CONTINUE                                                      !
!
      T = H * HALF                                                  !
!
   20 CONTINUE                                                      !
!
      EM = DEXP(H0*T)                                               !
      EP = PI2 * EM                                                 !
      EM = PI2 / EM                                                 !
      J  = K                                                        !
!
   30 CONTINUE                                                      !
!
      XW      = ONE / (ONE + DEXP(EP-EM))                           !
      WG      = XW * (ONE-XW) * H0                                  !
      AW(J)   = XW                                                  !
      AW(J+1) = WG * FOUR                                           !
      AW(J+2) = WG * (EP+EM)                                        !
      EP      = EP * EHP                                            !
      EM      = EM * EHM                                            !
      J       = J + 3                                               !
!
      IF (EP < TINYLN .AND. J <= (LENAW-3)) GO TO 30                !
!
      T = T + H                                                     !
      K = K + NK                                                    !
!
      IF(T < ONE) GO TO 20                                          !
!
      H = H * HALF                                                  !
!
      IF(NK == 0) THEN                                              !
        IF(J > (LENAW-6)) J = J - 3                                 !
        NK    = J - NOFF                                            !
        K     = K + NK                                              !
        AW(1) = NK                                                  !
      END IF                                                        !
!
      IF((2*K - NOFF - 3) <= LENAW) GO TO 10                        !
!
      AW(0) = DFLOAT(K-3)                                           !
!
      END SUBROUTINE INTDEINI_F
!
!=======================================================================
!
      FUNCTION RBI1(FCT,A,B,PREC,OBTPREC,NITER,ITERMIN,ITERMAX)
!
!*******************************************************
!* Integral of a function FCT(X) by Romberg's method   *
!* --------------------------------------------------- *
!* INPUTS:                                             *
!*          A      begin value of x variable           *
!*          B      end value of x variable             *
!*       PREC      desired precision                   *
!*    ITERMIN      minimum number of iterations        *
!*    ITERMAX      maximum number of iterations        *
!*                                                     *
!* OUTPUTS:                                            *
!*    OBTPREC      obtained precision for integral     *
!*      NITER      number of iterations done           *
!*   INTEGRAL      the integral of FCT(X) from a to b  *
!*                                                     *
!*******************************************************
!
!   Last modified: D. Sébilleau   5 June 2020
!
!
      USE DIMENSION_CODE,   ONLY : MAXITER
      USE REAL_NUMBERS,     ONLY : ONE,TWO,FOUR
!
!
      IMPLICIT NONE
!
      REAL (WP)             ::  RBI1
      REAL (WP)             ::  A,B,PREC,OBTPREC
      REAL (WP)             ::  T(0:MAXITER,0:MAXITER)
      REAL (WP)             ::  PAS,R,S,TA
!
      REAL (WP), EXTERNAL   ::  FCT
!
      REAL (WP)             ::  DABS
!
      INTEGER               ::  NITER,ITERMIN,ITERMAX,I,J
!
      IF (ITERMAX > MAXITER)  ITERMAX=MAXITER                       !
!
      R = FCT(A)                                                    !
      TA = (R + FCT(B) ) / TWO                                      !
      NITER=0                                                       !
      PAS=B-A                                                       !
      T(0,0)=TA*PAS                                                 !
 100  NITER=NITER+1                                                 !
      PAS=PAS/TWO                                                   !
      S=TA                                                          !
!
      DO I=1, 2**NITER-1                                            !
        S = S + FCT(A+PAS*I)                                        !
      END DO                                                        !
!
      T(0,NITER)=S*PAS                                              !
      R=ONE                                                         !
      DO I=1, NITER                                                 !
        R=R*FOUR                                                    !
        J=NITER-I                                                   !
        T(I,J)=(R*T(I-1,J+1) - T(I-1,J))/(R-ONE)                    !
      END DO                                                        !
!
      OBTPREC = DABS(T(NITER,0) - T(NITER-1,0))                     !
!
      IF (NITER   > ITERMAX)  GO TO 200                             !
      IF (NITER   < ITERMIN)  GO TO 100                             !
      IF (OBTPREC > PREC)     GO TO 100                             !
!
 200  RBI1 = T(NITER,0)                                             !
!
      END FUNCTION RBI1
!
!=======================================================================
!
      SUBROUTINE SIMPSON(FCT,A,B,N,RES)
!
!*******************************************************
!* Integral of a function FCT(X) by Simpson's method   *
!* --------------------------------------------------- *
!* INPUTS:                                             *
!*          A      begin value of x variable           *
!*          B      end value of x variable             *
!*          N      number of integration steps         *
!*                                                     *
!* OUTPUT:                                             *
!*          RES    the integral of FCT(X) from a to b  *
!*                                                     *
!*******************************************************
!
      USE REAL_NUMBERS,     ONLY : TWO,THREE
!
      IMPLICIT NONE
!
      REAL (WP)             ::  A,B,RES
      REAL (WP)             ::  STEP,R
!
      REAL (WP), EXTERNAL   ::  FCT
!
      INTEGER               ::   N,I
!
      STEP = (B-A)/TWO/N                                            !
      R = FCT(A)                                                    !
      RES = (R+FCT(B))/TWO                                          !
!
      DO I=1, 2*N-1                                                 !
        R = FCT(A+I*STEP)                                           !
        IF(MOD(I,2) /= 0) THEN                                      !
          RES = RES + R + R                                         !
        ELSE                                                        !
          RES = RES + R                                             !
        END IF                                                      !
      END DO                                                        !
!
      RES = RES * STEP*TWO/THREE                                    !
!
      END SUBROUTINE SIMPSON
!
!=======================================================================
!
      SUBROUTINE QANC8 (FCT,A,B,AERR,RERR,RES,ERR,NBF,FLG)
!
!     Integrate a real function FCT(X) from X = A to X = B,
!     with given absolute and relative precisions, AERR, RERR.
!
!     Inputs:
!
!     FCT       :  external user-defined function for any X value
!                  in interval [A,B]
!     A,B       :  limits of interval
!     AERR,RERR :  respectively absolute error and relative error
!                  required by user
!
!     Outputs:
!
!     RES       :  value of integral
!     ERR       :  estimated error
!     NBF       :  number of necessary FCT(X) evaluations
!     FLG       :  indicator
!                    = 0.0       correct result
!                    = NNN.RRR   no convergence du to a singularity
!                      the singular point abcissa is given by formula:
!                                 XS = B-.RRR*(B-A)

!     Reference :
!
!     G.E. Forsythe, Computer Methods for Mathematical
!                    Computations, Prentice-Hall, Inc. (1977)
!
! -----------------------------------------------------------------------
!
      USE REAL_NUMBERS,     ONLY : ZERO,ONE,TWO,HALF
!
      IMPLICIT NONE
!
      REAL (WP), INTENT(IN)   ::    A,B,AERR,RERR
      REAL (WP), INTENT(OUT)  ::    RES,FLG
      REAL (WP)               ::    ERR
      REAL (WP)               ::    QR(31),F(16),X(16),FS(8,30),XS(8,30)
      REAL (WP)               ::    W0,W1,W2,W3,W4
      REAL (WP)               ::    COR,SUM
      REAL (WP)               ::    X0,QP,PAS1,PAS,QL,QN,QD,ERR1,TOL1
      REAL (WP)               ::    F0,TEMP
      REAL (WP)               ::    DABS,MAX
!
      REAL (WP), EXTERNAL     ::    FCT
!
      INTEGER, INTENT(OUT)    ::    NBF
      INTEGER                 ::    LMIN,LMAX,LOUT,NMAX,NFIN
      INTEGER                 ::    L,NIM,J,I
!
      LMIN = 1                                                      !
      LMAX = 30                                                     !
      LOUT = 6                                                      !
      NMAX = 5000                                                   !
      NFIN = NMAX-8*(LMAX-LOUT+2**(LOUT+1))                         !
      W0   =   3956.E0_WP/14175.E0_WP                               !
      W1   =  23552.E0_WP/14175.E0_WP                               !
      W2   =  -3712.E0_WP/14175.E0_WP                               !
      W3   =  41984.E0_WP/14175.E0_WP                               !
      W4   = -18160.E0_WP/14175.E0_WP                               !
      FLG  = ZERO                                                   !
      RES  = ZERO                                                   !
      COR  = ZERO                                                   !
      ERR  = ZERO                                                   !
      SUM  = ZERO                                                   !
      NBF  = 0                                                      !
!
      IF (A == B) RETURN                                            !
!
      L     = 0                                                     !
      NIM   = 1                                                     !
      X0    = A                                                     !
      X(16) = B                                                     !
      QP    = ZERO                                                  !
      F0    = FCT(X0)                                               !
      PAS1  = (B-A)/16.E0_WP                                        !
      X(8)  = (X0+X(16))*HALF                                       !
      X(4)  = (X0+X(8))*HALF                                        !
      X(12) = (X(8)+X(16))*HALF                                     !
      X(2)  = (X0+X(4))*HALF                                        !
      X(6)  = (X(4)+X(8))*HALF                                      !
      X(10) = (X(8)+X(12))*HALF                                     !
      X(14) = (X(12)+X(16))*HALF                                    !
!
      DO J = 2,16,2                                                 !
        F(J) = FCT(X(J))                                            !
      END DO                                                        !
!
      NBF  = 9                                                      !
   30 X(1) = (X0+X(2))*HALF                                         !
      F(1) = FCT(X(1))                                              !
!
      DO J = 3,15,2                                                 !
        X(J) = (X(J-1)+X(J+1))*HALF                                 !
        F(J) = FCT(X(J))                                            !
      END DO
!
      NBF  = NBF+8                                                  !
      PAS  = (X(16)-X0)/16.E0_WP                                    !
      QL   = (W0*(F0+F(8))+W1*(F(1)+F(7))+W2*(F(2)+F(6))        &   !
                                 +W3*(F(3)+F(5))+W4*F(4))*PAS       !
      QR(L+1) = (W0*(F(8)+F(16))+W1*(F(9)+F(15))                &   !
             +W2*(F(10)+F(14))+W3*(F(11)+F(13))+W4*F(12))*PAS       !
      QN   = QL + QR(L+1)                                           !
      QD   = QN - QP                                                !
      SUM  = SUM + QD                                               !
      ERR1 = DABS(QD)/1023.E0_WP                                    !
      TOL1 = MAX(AERR,RERR*DABS(SUM))*(PAS/PAS1)                    !
!
      IF (L    <   LMIN)    GO TO 50                                !
      IF (L    >=  LMAX)    GO TO 62                                !
      IF (NBF  >   NFIN)    GO TO 60                                !
      IF (ERR1 <=  TOL1)    GO TO 70                                !
!
   50 NIM = 2*NIM                                                   !
      L   = L+1                                                     !
!
      DO I = 1,8                                                    !
        FS(I,L) = F(I+8)                                            !
        XS(I,L) = X(I+8)                                            !
      END DO                                                        !
!
      QP = QL                                                       !
!
      DO I = 1,8                                                    !
        F(18-2*I) = F(9-I)                                          !
        X(18-2*I) = X(9-I)                                          !
      END DO                                                        !
!
      GO TO 30                                                      !
!
   60 NFIN = 2*NFIN                                                 !
      LMAX = LOUT                                                   !
      FLG  = FLG + (B-X0)/(B-A)                                     !
!
      GO TO 70                                                      !
!
   62 FLG = FLG + ONE                                               !
   70 RES = RES + QN                                                !
      ERR = ERR + ERR1                                              !
      COR = COR + QD/1023.E0_WP                                     !
!
   72 IF (NIM == 2*(NIM/2)) GO TO 75                                !
      NIM = NIM/2                                                   !
      L   = L-1                                                     !
!
      GO TO 72                                                      !
!
   75 NIM = NIM+1                                                   !
      IF (L <= 0) GO TO 80                                          !
      QP  = QR(L)                                                   !
      X0  = X(16)                                                   !
      F0  = F(16)                                                   !
!
      DO I = 1,8                                                    !
        F(2*I) = FS(I,L)                                            !
        X(2*I) = XS(I,L)                                            !
      END DO                                                        !
!
      GO TO 30                                                      !
!
   80 RES = RES + COR                                               !
      IF (ERR == ZERO)   RETURN                                     !
   82 TEMP = DABS(RES) + ERR                                        !
      IF (TEMP /= DABS(RES)) RETURN                                 !
      ERR = TWO*ERR                                                 !
!
      GO TO 82                                                      !
!
      END SUBROUTINE QANC8
!
END MODULE INTEGRATION
