878 lines
37 KiB
Fortran
878 lines
37 KiB
Fortran
|
!
|
||
|
|
!=======================================================================
|
||
|
|
!
|
||
|
|
MODULE INTEGRATION2
|
||
|
|
!
|
||
|
|
! This module contains integration routines in order to integrate
|
||
|
|
! a function F over the interval [0,+INF].
|
||
|
|
!
|
||
|
|
! These routines are:
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! * Lagrange : INTEGR_L_0_INF(F,X1,NSIZE,NMAX1,ID,F_INF,HOP,A)
|
||
|
|
!
|
||
|
|
! * double exponential transformation : INTDEI(F,A,EPS,I,ERR) <-- standard version
|
||
|
|
! INTDEI_1(F,A,X,EPS,I,ERR) <-- 1-parameter version (X)
|
||
|
|
! INTDEI_2(F,A,X,Y,EPS,I,ERR) <-- 2-parameter version (X,Y)
|
||
|
|
! INTDEI_F(F,A,AW,I,ERR) <-- fast version
|
||
|
|
!
|
||
|
|
USE ACCURACY_REAL
|
||
|
|
!
|
||
|
|
CONTAINS
|
||
|
|
!
|
||
|
|
!=======================================================================
|
||
|
|
!
|
||
|
|
SUBROUTINE INTEGR_L_0_INF(F,X1,N_SIZE,NMAX1,ID,F_INF,HOP,A)
|
||
|
|
!
|
||
|
|
! This subroutine integrates from 0 to infinity a function f(x)
|
||
|
|
! defined by the arrays X and F up to NMAX and for which
|
||
|
|
! the asymptotic value at infinity F_INF is known.
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Input parameters:
|
||
|
|
!
|
||
|
|
! * F : function array
|
||
|
|
! * X1 : mesh array (constant step)
|
||
|
|
! * N_SIZE : dimensioning of the arrays
|
||
|
|
! * NMAX1 : index of upper limit of integration on the mesh
|
||
|
|
! * ID : integer parameter
|
||
|
|
! ID = 1 --> F0 = 0 at the origin
|
||
|
|
! ID > 1 --> F0 not 0 at the origin
|
||
|
|
! * F_INF : limit of f(x) for x --> infinity
|
||
|
|
! * HOP : hopping parameter defining the mesh X(NMAX) --> infinity
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Output parameters:
|
||
|
|
!
|
||
|
|
! * A : integral result
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Method: The integral is separated as
|
||
|
|
!
|
||
|
|
! / X1(NMAX) / + INF = X1(NMAX+NMAX/HOP)
|
||
|
|
! | |
|
||
|
|
! | f(x) dx + | f(x) dx
|
||
|
|
! | |
|
||
|
|
! / 0 / X1(NMAX)
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! * The first integral is computed using Lagrange integration.
|
||
|
|
! * For the second integral, a new mesh containing NMAX/HOP points
|
||
|
|
! is constructed. This is done by a 5-point Lagrange interpolation
|
||
|
|
! from X1(NMAX-3*HOP), X1(NMAX-2*HOP), X1(NMAX-HOP), X1(NMAX)
|
||
|
|
! and X1(NMAX+NMAX/HOP) whose F value is taken as F_INF
|
||
|
|
! * Once the new F and X1 arrays are constructed, the second integral
|
||
|
|
! is also computed using a Lagrange integration.
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! --> Real function F case <--
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Author : D. Sébilleau
|
||
|
|
!
|
||
|
|
! Last modified : 5 Aug 2020
|
||
|
|
!
|
||
|
|
!
|
||
|
|
USE DIMENSION_CODE, ONLY : NSIZE
|
||
|
|
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE
|
||
|
|
USE INTEGRATION, ONLY : INTEGR_L
|
||
|
|
USE INTERPOLATION, ONLY : LAG_5P_INTERP
|
||
|
|
!
|
||
|
|
IMPLICIT NONE
|
||
|
|
!
|
||
|
|
REAL (WP) :: X1(N_SIZE),F(N_SIZE) ! 1st integral
|
||
|
|
REAL (WP) :: X2(NSIZE),G(NSIZE) ! 2nd integral
|
||
|
|
REAL (WP) :: XX(5),AA(5) ! interpolation points
|
||
|
|
REAL (WP) :: F_INF
|
||
|
|
REAL (WP) :: H1,H2
|
||
|
|
REAL (WP) :: A1,A2,A
|
||
|
|
!
|
||
|
|
REAL (WP) :: DFLOAT
|
||
|
|
!
|
||
|
|
INTEGER :: N_SIZE,NMAX1,ID,HOP
|
||
|
|
INTEGER :: NMAX2,IP
|
||
|
|
!
|
||
|
|
H1=X1(2)-X1(1) ! step for 1st integral
|
||
|
|
!
|
||
|
|
! Computing the first integral
|
||
|
|
!
|
||
|
|
CALL INTEGR_L(F,H1,N_SIZE,NMAX1,A1,ID) !
|
||
|
|
!
|
||
|
|
NMAX2=NMAX1/HOP ! nb of points of mesh X2
|
||
|
|
H2=H1*HOP ! step for mesh X2
|
||
|
|
!
|
||
|
|
! Defining the [ X(NMAX, + INF ] mesh
|
||
|
|
!
|
||
|
|
DO IP=1,NMAX2 !
|
||
|
|
X2(IP)=X1(NMAX1)+DFLOAT(IP-1)*H2 !
|
||
|
|
END DO !
|
||
|
|
!
|
||
|
|
! Constructing the Lagrange interpolation points
|
||
|
|
!
|
||
|
|
XX(1)=X1(NMAX1-3*HOP) !
|
||
|
|
XX(2)=X1(NMAX1-2*HOP) !
|
||
|
|
XX(3)=X1(NMAX1-HOP) !
|
||
|
|
XX(4)=X1(NMAX1) !
|
||
|
|
XX(5)=X2(NMAX2) !
|
||
|
|
!
|
||
|
|
AA(1)=F(NMAX1-3*HOP) !
|
||
|
|
AA(2)=F(NMAX1-2*HOP) !
|
||
|
|
AA(3)=F(NMAX1-HOP) !
|
||
|
|
AA(4)=F(NMAX1) !
|
||
|
|
AA(5)=F_INF !
|
||
|
|
!
|
||
|
|
! Evaluating f(x) = G over the X2 mesh
|
||
|
|
!
|
||
|
|
DO IP=1,NMAX2 !
|
||
|
|
G(IP)=LAG_5P_INTERP(XX,AA,X2(IP)) !
|
||
|
|
END DO !
|
||
|
|
!
|
||
|
|
! Computing the second integral
|
||
|
|
!
|
||
|
|
CALL INTEGR_L(G,H2,NSIZE,NMAX2,A2,1) !
|
||
|
|
!
|
||
|
|
A=A1+A2 !
|
||
|
|
!
|
||
|
|
END SUBROUTINE INTEGR_L_0_INF
|
||
|
|
!
|
||
|
|
!=======================================================================
|
||
|
|
!
|
||
|
|
SUBROUTINE INTDEI(F,A,EPS,I,ERR)
|
||
|
|
!
|
||
|
|
! This subroutine is the integrator of f(x) over (a,infinity)
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Input parameters:
|
||
|
|
!
|
||
|
|
! * F : integrand f(x)
|
||
|
|
! * A : lower 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,infinity).
|
||
|
|
! relative error
|
||
|
|
! EPS is relative error requested excluding
|
||
|
|
! cancellation of significant digits.
|
||
|
|
! i.e. EPS means : (absolute error) /
|
||
|
|
! (integral_a^infinity |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,infinity).
|
||
|
|
! you must divide the interval
|
||
|
|
! (a,infinity) at this points.
|
||
|
|
! 2. relative error of f(x) is
|
||
|
|
! greater than EPS.
|
||
|
|
! 3. f(x) has oscillatory factor
|
||
|
|
! and decay of f(x) is very slow
|
||
|
|
! as x -> infinity.
|
||
|
|
! 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 Aug 2020
|
||
|
|
!
|
||
|
|
!
|
||
|
|
!
|
||
|
|
USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF
|
||
|
|
!
|
||
|
|
IMPLICIT NONE
|
||
|
|
!
|
||
|
|
REAL (WP) :: A,EPS,I,ERR
|
||
|
|
REAL (WP) :: EFS,HOFF
|
||
|
|
REAL (WP) :: PI4,EPSLN,EPSH,H0,EHP,EHM,EPST,IR,H,IBACK
|
||
|
|
REAL (WP) :: IRBACK,T,EP,EM,XP,XM,FP,FM,ERRT,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 = 11.0E0_WP !
|
||
|
|
!
|
||
|
|
! ------------------------------
|
||
|
|
!
|
||
|
|
PI4 = DATAN(ONE) !
|
||
|
|
EPSLN = ONE - DLOG(EFS*EPS) !
|
||
|
|
EPSH = DSQRT(EFS*EPS) !
|
||
|
|
H0 = HOFF /EPSLN !
|
||
|
|
EHP = DEXP(H0) !
|
||
|
|
EHM = ONE/EHP !
|
||
|
|
EPST = DEXP(-EHM*EPSLN) !
|
||
|
|
IR = F(A+1) !
|
||
|
|
I = IR*(TWO*PI4) !
|
||
|
|
ERR = DABS(I)*EPST !
|
||
|
|
H = TWO*H0 !
|
||
|
|
M = 1 !
|
||
|
|
!
|
||
|
|
10 CONTINUE !
|
||
|
|
!
|
||
|
|
IBACK = I !
|
||
|
|
IRBACK = IR !
|
||
|
|
T = H * HALF !
|
||
|
|
!
|
||
|
|
20 CONTINUE !
|
||
|
|
!
|
||
|
|
EM = DEXP(T) !
|
||
|
|
EP = PI4 * EM !
|
||
|
|
EM = PI4 / EM !
|
||
|
|
!
|
||
|
|
30 CONTINUE !
|
||
|
|
!
|
||
|
|
XP = DEXP(EP-EM) !
|
||
|
|
XM = ONE/XP !
|
||
|
|
FP = F(A+XP)*XP !
|
||
|
|
FM = F(A+XM)*XM !
|
||
|
|
IR = IR+(FP+FM) !
|
||
|
|
I = I+(FP+FM)*(EP+EM) !
|
||
|
|
ERRT = (DABS(FP)+DABS(FM))*(EP+EM) !
|
||
|
|
!
|
||
|
|
IF(M == 1) ERR = ERR+ERRT*EPST !
|
||
|
|
!
|
||
|
|
EP = EP*EHP !
|
||
|
|
EM = EM*EHM !
|
||
|
|
!
|
||
|
|
IF(ERRT > ERR .OR. XM > 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 INTDEI
|
||
|
|
!
|
||
|
|
!=======================================================================
|
||
|
|
!
|
||
|
|
SUBROUTINE INTDEI_1(F,A,X,EPS,I,ERR)
|
||
|
|
!
|
||
|
|
! This subroutine is the integrator of f(x) over (a,infinity)
|
||
|
|
! with ONE extra parameter in the definition of the integrand
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Input parameters:
|
||
|
|
!
|
||
|
|
! * F : integrand f(x)
|
||
|
|
! * A : lower limit of integration
|
||
|
|
! * X : extra parameter of F
|
||
|
|
! * 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,infinity).
|
||
|
|
! relative error
|
||
|
|
! EPS is relative error requested excluding
|
||
|
|
! cancellation of significant digits.
|
||
|
|
! i.e. EPS means : (absolute error) /
|
||
|
|
! (integral_a^infinity |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,infinity).
|
||
|
|
! you must divide the interval
|
||
|
|
! (a,infinity) at this points.
|
||
|
|
! 2. relative error of f(x) is
|
||
|
|
! greater than EPS.
|
||
|
|
! 3. f(x) has oscillatory factor
|
||
|
|
! and decay of f(x) is very slow
|
||
|
|
! as x -> infinity.
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Last modified: D. Sébilleau 4 Aug 2020
|
||
|
|
!
|
||
|
|
!
|
||
|
|
USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF
|
||
|
|
!
|
||
|
|
IMPLICIT NONE
|
||
|
|
!
|
||
|
|
REAL (WP) :: A,X,EPS,I,ERR
|
||
|
|
REAL (WP) :: EFS,HOFF
|
||
|
|
REAL (WP) :: PI4,EPSLN,EPSH,H0,EHP,EHM,EPST,IR,H,IBACK
|
||
|
|
REAL (WP) :: IRBACK,T,EP,EM,XP,XM,FP,FM,ERRT,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 = 11.0E0_WP !
|
||
|
|
!
|
||
|
|
! ------------------------------
|
||
|
|
!
|
||
|
|
PI4 = DATAN(ONE) !
|
||
|
|
EPSLN = ONE - DLOG(EFS*EPS) !
|
||
|
|
EPSH = DSQRT(EFS*EPS) !
|
||
|
|
H0 = HOFF /EPSLN !
|
||
|
|
EHP = DEXP(H0) !
|
||
|
|
EHM = ONE/EHP !
|
||
|
|
EPST = DEXP(-EHM*EPSLN) !
|
||
|
|
IR = F(A+1,X) !
|
||
|
|
I = IR*(TWO*PI4) !
|
||
|
|
ERR = DABS(I)*EPST !
|
||
|
|
H = TWO*H0 !
|
||
|
|
M = 1 !
|
||
|
|
!
|
||
|
|
10 CONTINUE !
|
||
|
|
!
|
||
|
|
IBACK = I !
|
||
|
|
IRBACK = IR !
|
||
|
|
T = H * HALF !
|
||
|
|
!
|
||
|
|
20 CONTINUE !
|
||
|
|
!
|
||
|
|
EM = DEXP(T) !
|
||
|
|
EP = PI4 * EM !
|
||
|
|
EM = PI4 / EM !
|
||
|
|
!
|
||
|
|
30 CONTINUE !
|
||
|
|
!
|
||
|
|
XP = DEXP(EP-EM) !
|
||
|
|
XM = ONE/XP !
|
||
|
|
FP = F(A+XP,X)*XP !
|
||
|
|
FM = F(A+XM,X)*XM !
|
||
|
|
IR = IR+(FP+FM) !
|
||
|
|
I = I+(FP+FM)*(EP+EM) !
|
||
|
|
ERRT = (DABS(FP)+DABS(FM))*(EP+EM) !
|
||
|
|
!
|
||
|
|
IF(M == 1) ERR = ERR+ERRT*EPST !
|
||
|
|
!
|
||
|
|
EP = EP*EHP !
|
||
|
|
EM = EM*EHM !
|
||
|
|
!
|
||
|
|
IF(ERRT > ERR .OR. XM > 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 INTDEI_1
|
||
|
|
!
|
||
|
|
!=======================================================================
|
||
|
|
!
|
||
|
|
SUBROUTINE INTDEI_2(F,A,X,Y,EPS,I,ERR)
|
||
|
|
!
|
||
|
|
! This subroutine is the integrator of f(x) over (a,infinity)
|
||
|
|
! with TWO extra parameters in the definition of the integrand
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Input parameters:
|
||
|
|
!
|
||
|
|
! * F : integrand f(x)
|
||
|
|
! * A : lower limit of integration
|
||
|
|
! * X : first extra parameter of F
|
||
|
|
! * Y : second extra parameter of F
|
||
|
|
! * 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,infinity).
|
||
|
|
! relative error
|
||
|
|
! EPS is relative error requested excluding
|
||
|
|
! cancellation of significant digits.
|
||
|
|
! i.e. EPS means : (absolute error) /
|
||
|
|
! (integral_a^infinity |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,infinity).
|
||
|
|
! you must divide the interval
|
||
|
|
! (a,infinity) at this points.
|
||
|
|
! 2. relative error of f(x) is
|
||
|
|
! greater than EPS.
|
||
|
|
! 3. f(x) has oscillatory factor
|
||
|
|
! and decay of f(x) is very slow
|
||
|
|
! as x -> infinity.
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Last modified: D. Sébilleau 4 Aug 2020
|
||
|
|
!
|
||
|
|
!
|
||
|
|
USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF
|
||
|
|
!
|
||
|
|
IMPLICIT NONE
|
||
|
|
!
|
||
|
|
REAL (WP) :: A,X,Y,EPS,I,ERR
|
||
|
|
REAL (WP) :: EFS,HOFF
|
||
|
|
REAL (WP) :: PI4,EPSLN,EPSH,H0,EHP,EHM,EPST,IR,H,IBACK
|
||
|
|
REAL (WP) :: IRBACK,T,EP,EM,XP,XM,FP,FM,ERRT,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 = 11.0E0_WP !
|
||
|
|
!
|
||
|
|
! ------------------------------
|
||
|
|
!
|
||
|
|
PI4 = DATAN(ONE) !
|
||
|
|
EPSLN = ONE - DLOG(EFS*EPS) !
|
||
|
|
EPSH = DSQRT(EFS*EPS) !
|
||
|
|
H0 = HOFF /EPSLN !
|
||
|
|
EHP = DEXP(H0) !
|
||
|
|
EHM = ONE/EHP !
|
||
|
|
EPST = DEXP(-EHM*EPSLN) !
|
||
|
|
IR = F(A+1,X,Y) !
|
||
|
|
I = IR*(TWO*PI4) !
|
||
|
|
ERR = DABS(I)*EPST !
|
||
|
|
H = TWO*H0 !
|
||
|
|
M = 1 !
|
||
|
|
!
|
||
|
|
10 CONTINUE !
|
||
|
|
!
|
||
|
|
IBACK = I !
|
||
|
|
IRBACK = IR !
|
||
|
|
T = H * HALF !
|
||
|
|
!
|
||
|
|
20 CONTINUE !
|
||
|
|
!
|
||
|
|
EM = DEXP(T) !
|
||
|
|
EP = PI4 * EM !
|
||
|
|
EM = PI4 / EM !
|
||
|
|
!
|
||
|
|
30 CONTINUE !
|
||
|
|
!
|
||
|
|
XP = DEXP(EP-EM) !
|
||
|
|
XM = ONE/XP !
|
||
|
|
FP = F(A+XP,X,Y)*XP !
|
||
|
|
FM = F(A+XM,X,Y)*XM !
|
||
|
|
IR = IR+(FP+FM) !
|
||
|
|
I = I+(FP+FM)*(EP+EM) !
|
||
|
|
ERRT = (DABS(FP)+DABS(FM))*(EP+EM) !
|
||
|
|
!
|
||
|
|
IF(M == 1) ERR = ERR+ERRT*EPST !
|
||
|
|
!
|
||
|
|
EP = EP*EHP !
|
||
|
|
EM = EM*EHM !
|
||
|
|
!
|
||
|
|
IF(ERRT > ERR .OR. XM > 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 INTDEI_2
|
||
|
|
!
|
||
|
|
!=======================================================================
|
||
|
|
!
|
||
|
|
SUBROUTINE INTDEI_F(F,A,AW,I,ERR)
|
||
|
|
!
|
||
|
|
! This subroutine is the integrator of f(x) over (a,infinity)
|
||
|
|
!
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! --> <--
|
||
|
|
! --> This is the fast version <--
|
||
|
|
! --> <--
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Usage:
|
||
|
|
!
|
||
|
|
! CALL INTDEIINI(LENAW,TINY,EPS,AW) ! initialization of AW
|
||
|
|
! ...
|
||
|
|
! CALL INTDEI_F(F,A,AW,I,ERR)
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Input parameters:
|
||
|
|
!
|
||
|
|
! * F : integrand f(x)
|
||
|
|
! * A : lower 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,infinity).
|
||
|
|
! relative error
|
||
|
|
! EPS is relative error requested excluding
|
||
|
|
! cancellation of significant digits.
|
||
|
|
! i.e. EPS means : (absolute error) /
|
||
|
|
! (integral_a^infinity |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,infinity).
|
||
|
|
! you must divide the interval
|
||
|
|
! (a,infinity) at this points.
|
||
|
|
! 2. relative error of f(x) is
|
||
|
|
! greater than EPS.
|
||
|
|
! 3. f(x) has oscillatory factor
|
||
|
|
! and decay of f(x) is very slow
|
||
|
|
! as x -> infinity.
|
||
|
|
! 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 Aug 2020
|
||
|
|
!
|
||
|
|
!
|
||
|
|
USE REAL_NUMBERS, ONLY : ONE,TWO,HALF
|
||
|
|
!
|
||
|
|
IMPLICIT NONE
|
||
|
|
!
|
||
|
|
REAL (WP) :: A,AW(0 : *),I,ERR
|
||
|
|
REAL (WP) :: EPSH,IR,FP,FM,ERRT,ERRH,ERRD
|
||
|
|
REAL (WP) :: H,IBACK,IRBACK
|
||
|
|
!
|
||
|
|
REAL (WP), EXTERNAL :: F
|
||
|
|
!
|
||
|
|
REAL (WP) :: DABS
|
||
|
|
!
|
||
|
|
INTEGER :: NOFF,LENAWM,NK,K,J,JTMP,JM,M,KL,KLIM
|
||
|
|
!
|
||
|
|
INTEGER :: INT
|
||
|
|
!
|
||
|
|
NOFF = 5 !
|
||
|
|
LENAWM = INT(AW(0) + HALF) !
|
||
|
|
NK = INT(AW(1) + HALF) !
|
||
|
|
EPSH = AW(4) !
|
||
|
|
I = F(A + AW(NOFF)) !
|
||
|
|
IR = I * AW(NOFF+1) !
|
||
|
|
I = I * AW(NOFF+2) !
|
||
|
|
ERR = DABS(I) !
|
||
|
|
K = NK + NOFF !
|
||
|
|
J = NOFF !
|
||
|
|
!
|
||
|
|
10 CONTINUE !
|
||
|
|
!
|
||
|
|
J = J + 6 !
|
||
|
|
FM = F(A + AW(J)) !
|
||
|
|
FP = F(A + AW(J+1)) !
|
||
|
|
IR = IR + (FM*AW(J+2) + FP*AW(J+3)) !
|
||
|
|
FM = FM * AW(J+4) !
|
||
|
|
FP = FP * AW(J+5) !
|
||
|
|
I = I + (FM+FP) !
|
||
|
|
ERR = ERR + (DABS(FM)+DABS(FP)) !
|
||
|
|
!
|
||
|
|
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(FM) > ERRT .AND. J < K) !
|
||
|
|
J = J + 6 !
|
||
|
|
FM = F(A + AW(J)) !
|
||
|
|
IR = IR + FM*AW(J+2) !
|
||
|
|
FM = FM * AW(J+4) !
|
||
|
|
I = I + FM !
|
||
|
|
END DO !
|
||
|
|
!
|
||
|
|
JM = J !
|
||
|
|
J = JTMP !
|
||
|
|
!
|
||
|
|
DO WHILE (DABS(FP) > ERRT .AND. J < K) !
|
||
|
|
J = J + 6 !
|
||
|
|
FP = F(A + AW(J+1)) !
|
||
|
|
IR = IR + FP*AW(J+3) !
|
||
|
|
FP = FP * AW(J+5) !
|
||
|
|
I = I + FP !
|
||
|
|
END DO !
|
||
|
|
!
|
||
|
|
IF(J < JM) JM = J !
|
||
|
|
!
|
||
|
|
JM = JM - (NOFF+6) !
|
||
|
|
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+6,JTMP,6 !
|
||
|
|
FM = F(A + AW(J)) !
|
||
|
|
FP = F(A + AW(J+1)) !
|
||
|
|
IR = IR + (FM*AW(J+2) + FP*AW(J+3)) !
|
||
|
|
I = I + (FM*AW( +4) + FP*AW(J+5)) !
|
||
|
|
END DO !
|
||
|
|
!
|
||
|
|
K = K + NK !
|
||
|
|
J = JTMP !
|
||
|
|
!
|
||
|
|
30 CONTINUE !
|
||
|
|
!
|
||
|
|
J = J + 6 !
|
||
|
|
FM = F(A + AW(J)) !
|
||
|
|
IR = IR + FM*AW(J+2) !
|
||
|
|
FM = FM * AW(J+4) !
|
||
|
|
I = I + FM !
|
||
|
|
!
|
||
|
|
IF(DABS(FM) > ERRT .AND. J < K) GO TO 30 !
|
||
|
|
!
|
||
|
|
J = JTMP !
|
||
|
|
!
|
||
|
|
40 CONTINUE !
|
||
|
|
!
|
||
|
|
J = J + 6 !
|
||
|
|
FP = F(A + AW(J+1)) !
|
||
|
|
IR = IR + FP*AW(J+3) !
|
||
|
|
FP = FP * AW(J+5) !
|
||
|
|
I = I + FP !
|
||
|
|
!
|
||
|
|
IF(DABS(FP) > 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 !
|
||
|
|
!
|
||
|
|
IF(ERRD > ERRH) THEN !
|
||
|
|
ERR = -ERRD * M !
|
||
|
|
ELSE !
|
||
|
|
ERR = ERR * (AW(2)*M) !
|
||
|
|
END IF !
|
||
|
|
!
|
||
|
|
END SUBROUTINE INTDEI_F
|
||
|
|
!
|
||
|
|
!=======================================================================
|
||
|
|
!
|
||
|
|
SUBROUTINE INTDEIINI_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 5 Aug 2020
|
||
|
|
!
|
||
|
|
!
|
||
|
|
USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF
|
||
|
|
!
|
||
|
|
IMPLICIT NONE
|
||
|
|
!
|
||
|
|
REAL (WP) :: TINY,EPS,AW(0 : LENAW - 1)
|
||
|
|
REAL (WP) :: EFS,HOFF
|
||
|
|
REAL (WP) :: PI4,TINYLN,EPSLN,H0,EHP,EHM
|
||
|
|
REAL (WP) :: H,T,EP,EM,XP,XM,WWP,WWM
|
||
|
|
!
|
||
|
|
REAL (WP) :: DATAN,DLOG,DSQRT,DEXP,DFLOAT
|
||
|
|
!
|
||
|
|
INTEGER :: LENAW
|
||
|
|
INTEGER :: NOFF,NK,K,J
|
||
|
|
!
|
||
|
|
! ---- adjustable parameter ----
|
||
|
|
!
|
||
|
|
EFS = 0.1E0_WP !
|
||
|
|
HOFF = 11.0E0_WP !
|
||
|
|
!
|
||
|
|
! ------------------------------
|
||
|
|
!
|
||
|
|
PI4 = DATAN(ONE) !
|
||
|
|
TINYLN = -DLOG(TINY) !
|
||
|
|
EPSLN = ONE - 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) = ONE !
|
||
|
|
AW(NOFF+1) = FOUR * H0 !
|
||
|
|
AW(NOFF+2) = TWO * PI4 * H0 !
|
||
|
|
H = TWO !
|
||
|
|
NK = 0 !
|
||
|
|
K = NOFF + 6 !
|
||
|
|
!
|
||
|
|
10 CONTINUE !
|
||
|
|
!
|
||
|
|
T = H * HALF !
|
||
|
|
!
|
||
|
|
20 CONTINUE !
|
||
|
|
!
|
||
|
|
EM = DEXP(H0*T) !
|
||
|
|
EP = PI4 * EM !
|
||
|
|
EM = PI4 / EM !
|
||
|
|
J = K !
|
||
|
|
!
|
||
|
|
30 CONTINUE !
|
||
|
|
!
|
||
|
|
XP = DEXP(EP-EM) !
|
||
|
|
XM = ONE / XP !
|
||
|
|
WWP= XP * ((EP+EM)*H0) !
|
||
|
|
WWM= XM * ((EP+EM)*H0) !
|
||
|
|
AW(J) = XM !
|
||
|
|
AW(J+1) = XP !
|
||
|
|
AW(J+2) = XM * (FOUR*H0) !
|
||
|
|
AW(J+3) = XP * (FOUR*H0) !
|
||
|
|
AW(J+4) = WWM !
|
||
|
|
AW(J+5) = WWP !
|
||
|
|
EP = EP * EHP !
|
||
|
|
EM = EM * EHM !
|
||
|
|
J = J + 6 !
|
||
|
|
!
|
||
|
|
IF(EP < TINYLN .AND. J <= (LENAW-6)) 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-12)) J = J - 6 !
|
||
|
|
NK = J - NOFF !
|
||
|
|
K = K + NK !
|
||
|
|
AW(1) = NK !
|
||
|
|
END IF !
|
||
|
|
!
|
||
|
|
IF((2*K - NOFF - 6) <= LENAW) GO TO 10 !
|
||
|
|
!
|
||
|
|
AW(0) = DFLOAT(K-6) !
|
||
|
|
!
|
||
|
|
END SUBROUTINE INTDEIINI_F
|
||
|
|
!
|
||
|
|
END MODULE INTEGRATION2
|