1133 lines
48 KiB
Fortran
1133 lines
48 KiB
Fortran
!
|
||
!=======================================================================
|
||
!
|
||
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
|