! !======================================================================= ! 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