epsi
/
MsSpec-DFM
3
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
MsSpec-DFM/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/external_functions.f90

5420 lines
251 KiB
Fortran
Raw Normal View History

initial commit
2022-02-02 16:19:10 +01:00
!
!=======================================================================
!
MODULE EXT_FUNCTIONS
!
! This module provides external functions
!
! List of external functions provided:
!
! 1) Plasma dispersion function Z(x):
! SUBROUTINE PDF(X)
!
! 2) Vlasov function W(x):
! FUNCTION W(X)
!
! 3) Dawson function D(x):
! FUNCTION DAWSON(X)
!
! 4) Faddeeva function W(z):
! SUBROUTINE WOFZ(XI,YI,U,V,FLAG)
!
! 5) Mittag-Leffler function E_{alpha,beta}(z):
! FUNCTION MLFV(ALPHA,BETA,Z,FI)
!
! 6) Confluent hypergeometric function 1F1(a,b;z) = M(a,b;z):
! FUNCTION CONHYP(A,B,Z,LNCHF,IP)
!
! 7) Fermi-Dirac integral functions:
! FUNCTION FDM0P5(XVALUE) D_{-1/2}(x)
! FUNCTION FDP0P5(XVALUE) D_{+1/2}(x)
! FUNCTION FDP1P5(XVALUE) D_{+3/2}(x)
! FUNCTION FDP2P5(XVALUE) D_{+5/2}(x)
!
! 8) Logarithm of Gamma function real argument
! FUNCTION DLGAMA(X)
!
! 9) Incomplete gamma functions:
! FUNCTION GAMMP(A,X) gamma(a,x) / Gamma(a)
! FUNCTION GAMMQ(A,X) Gamma(a,x) / Gamma(a)
!
! 10) Polygamma function Psi^(k)(x)
! FUNCTION DPSIPG(X,K)
!
! 11) Carlson's elliptic integrals:
! FUNCTION RF(X,Y,Z) first kind
! FUNCTION RJ(X,Y,Z,P) second kind
! FUNCTION RD(X,Y,Z) third kind
! FUNCTION RC(X,Y) degenerate
!
! 12) Exponential integral:
! FUNCTION DEI(X) real argument
! SUBROUTINE E1Z(Z,CE1) complex argument
!
! 13) Error functions:
! FUNCTION ERF(X) error function
! FUNCTION ERFC(X) complementary error function
!
! 14) Bessel functions:
! FUNCTION DBESJ0(X) J_0(x)
! FUNCTION DBESJ1(X) J_1(x)
!
! 15) Hermite polynomials H_n(x)
! SUBROUTINE H_POLYNOMIAL_VALUE(M,N,X,P)
!
!
USE ACCURACY_REAL
!
CONTAINS
!
!=======================================================================
!
! 1) Plasma dispersion function Z(x):
!
!=======================================================================
!
FUNCTION PDF(X)
!
! This is the so-called plasma dispersion function:
!
! Z(x) = 1/sqrt(pi) * int_{- inf}^{+ inf} e^{-t^2} / (x - t) dt
!
! Alternatively, it can be expressed in terms of the Faddeeva function
!
! W(x) = e^{-x^2} * [ 1 + 2i/sqrt(pi) * int_0^x e^{t^2} dt ]
!
! or in terms of the Dawson function
!
! D(x) = e^{-x^2} * int_0^x e^{t^2} dt
!
! as
!
!
! Z(x) = - i * sqrt(pi) * W(x)
!
! = 2 * D(x) - i * sqrt(pi) * e^{-x^2}
!
!
! Author : D. Sébilleau
!
! Last modified : 12 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : TWO
USE COMPLEX_NUMBERS, ONLY : IC
USE PI_ETC, ONLY : SQR_PI
!
IMPLICIT NONE
!
REAL (WP), INTENT(IN) :: X
!
REAL (WP) :: EXP
!
COMPLEX (WP) :: PDF
!
PDF = TWO * DAWSON(X) - IC * SQR_PI * EXP(- X * X) !
!
END FUNCTION PDF
!
!=======================================================================
!
! 2) Vlasov function W(x):
!
!=======================================================================
!
FUNCTION W(X)
!
! This function computes the Vlasov function W(x) as given
! by Hong and Kim or Ichimaru for the calculation of their dynamical
! 3D local-field corrections
!
! We express it in terms of the Dawson integral D(x):
!
! W(x) = 1 - 2 * (x /sqrt(2)) * D(x/sqrt(2)) +
!
! i * (x /sqrt(2) * sqrt(pi) * exp(-x^2/2)
!
! References: (1) J. Hong and C. Kim, Phys. Rev. A 43, 1965-1971 (1991)
! (2) S. Ichimaru, Rev. Mod. Phys. 54, 1017-1059 (1982)
!
!
! Author : D. Sébilleau
!
! Last modified : 12 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ONE,TWO
USE COMPLEX_NUMBERS, ONLY : IC
USE PI_ETC, ONLY : SQR_PI
USE SQUARE_ROOTS, ONLY : SQR2
!
IMPLICIT NONE
!
REAL (WP), INTENT(IN) :: X
REAL (WP) :: Y
!
REAL (WP) :: EXP
!
COMPLEX (WP) :: W
!
Y = X / SQR2 !
!
W = ONE - TWO * Y * DAWSON(Y) + IC * SQR_PI * Y * EXP(- Y * Y)!
!
END FUNCTION W
!
!=======================================================================
!
! 3) Dawson function D(x):
!
!=======================================================================
!
FUNCTION DAWSON(X)
!
! This function returns Dawson integral. It is a rewriting
! of Numerical Recipes' version
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,HALF
!
IMPLICIT NONE
!
INTEGER :: I,INIT,N0
!
INTEGER, PARAMETER :: NMAX = 6
!
REAL (WP), INTENT(IN) :: X
REAL (WP) :: DAWSON
!
REAL (WP) :: D1,D2,E1,E2
REAL (WP) :: SUM,X2,XP,XX
REAL (WP) :: C(NMAX)
!
REAL (WP), PARAMETER :: H = 0.4E0_WP
REAL (WP), PARAMETER :: A1 = TWO / THREE
REAL (WP), PARAMETER :: A2 = 0.4E0_WP
REAL (WP), PARAMETER :: A3 = TWO /7.E0_WP
!
REAL (WP) :: EXP,FLOAT,ABS
!
SAVE INIT,C !
DATA INIT /0/ !
!
IF(INIT == 0)THEN !
INIT = 1 !
DO I = 1, NMAX !
C(I) = EXP(- ((TWO * FLOAT(I) - ONE) * H)**2) !
END DO !
END IF !
!
IF(ABS(X) < 0.2E0_WP) THEN !
!
X2 = X * X !
!
DAWSON = X * ( ONE - A1 * X2 * (ONE - A2 * X2 * & !
(ONE - A3 * X2)) & !
) !
!
ELSE !
!
XX = ABS(X) !
N0 = 2 * NINT(HALF * XX / H) !
XP = XX - FLOAT(N0) * H !
E1 = EXP(TWO * XP * H) !
E2 = E1 * E1 !
D1 = FLOAT(N0 + 1) !
D2 = D1 - TWO !
!
SUM = ZERO !
DO I = 1,NMAX !
SUM = SUM + C(I) * (E1 / D1 + ONE / (D2 * E1)) !
D1 = D1 + TWO !
D2 = D2 - TWO !
E1 = E2 * E1 !
END DO !
!
DAWSON = 0.56418958350E0_WP * SIGN(EXP(- XP**2),X) * SUM !
!
END IF !
!
END FUNCTION DAWSON
!
!=======================================================================
!
! 4) Faddeeva function W(z):
!
!=======================================================================
!
SUBROUTINE WOFZ (XI, YI, U, V, FLAG)
!
! Given a complex number Z = (XI,YI), this subroutine computes
! the value of the Faddeeva-function W(Z) = EXP(-Z**2)*ERFC(-I*Z),
! where ERFC is the complex complementary error-function and I
! means SQRT(-1).
! The accuracy of the algorithm for Z in the 1st and 2nd quadrant
! is 14 significant digits; In the 3rd and 4th it is 13 significant
! digits outside a circular region with radius 0.126 around a zero
! of the function.
!
! All real variables in the program are REAL*8.
!
! Algorithm 680, Collected algorithms from ACM.
! This work published in Transactions on Mathematical Software,
! Vol. 16, No. 1, pp. 47.
!
! The code contains a few compiler-dependent parameters :
! RMAXREAL = the maximum value of RMAXREAL equals the root of
! RMAX = the largest number which can still be
! implemented on the computer in REAL*8
! floating-point arithmetic
! RMAXEXP = LN(RMAX) - LN(2)
! RMAXGONI = the largest possible argument of a REAL*8
! goniometric function (DCOS, DSIN, ...)
! The reason why these parameters are needed as they are defined will
! be explained in the code by means of comments
!
!
! Parameter list:
!
! XI : real part of Z
! YI : imaginary part of Z
! U : real part of W(Z)
! V : imaginary part of W(Z)
! FLAG : an error flag indicating whether overflow will
! occur or not; type LOGICAL;
! the values of this variable have the following
! meaning :
! FLAG=.FALSE. : no error condition
! FLAG=.TRUE. : overflow will occur, the routine
! becomes inactive
!
! XI, YI are the input-parameters
! U, V, FLAG are the output-parameters
!
! Furthermore the parameter factor equals 2/SQRT(PI)
!
! The routine is not underflow-protected but any variable can be
! put to 0 upon underflow;
!
! Reference : GPM Poppe, CMJ Wijers; "More Efficient Computation of
! the Complex Error-Function, ACM Trans. Math. Software.
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,SIX,SEVEN,HALF
!
IMPLICIT REAL*8 (A-H, O-Z)
!
LOGICAL A, B, FLAG
PARAMETER (FACTOR = 1.12837916709551257388E0_WP, & !
RMAXREAL = 0.5E+154_WP, & !
RMAXEXP = 708.503061461606E0_WP, & !
RMAXGONI = 3.53711887601422E+15_WP) !
!
FLAG = .FALSE. !
!
XABS = DABS(XI) !
YABS = DABS(YI) !
X = XABS/6.3E0_WP !
Y = YABS/4.4E0_WP !
!
! The following IF-Statement protects
! QRHO = (X**2 + Y**2) against overflow
!
IF ((XABS > RMAXREAL) .OR. (YABS > RMAXREAL)) GO TO 100 !
!
QRHO = X**2 + Y**2 !
!
XABSQ = XABS**2 !
XQUAD = XABSQ - YABS**2 !
YQUAD = 2*XABS*YABS !
!
A = QRHO.LT.0.085264E0_WP !
!
IF (A) THEN !
!
! If (QRHO.LT.0.085264E0_WP) then the Faddeeva-function is evaluated
! using a power-series (Abramowitz/Stegun, equation (7.1.5), P.297)
!
! N is the minimum number of terms needed to obtain the required
! accuracy
!
QRHO = (ONE-0.85E0_WP*Y)*DSQRT(QRHO) !
N = IDNINT(SIX + 72.0E0_WP*QRHO) !
J = 2*N+1 !
XSUM = ONE/J !
YSUM = ZERO !
!
DO I=N, 1, -1 !
J = J - 2 !
XAUX = (XSUM*XQUAD - YSUM*YQUAD)/I !
YSUM = (XSUM*YQUAD + YSUM*XQUAD)/I !
XSUM = XAUX + ONE/J !
END DO !
!
U1 = -FACTOR*(XSUM*YABS + YSUM*XABS) + ONE !
V1 = FACTOR*(XSUM*XABS - YSUM*YABS) !
DAUX = DEXP(-XQUAD) !
U2 = DAUX*DCOS(YQUAD) !
V2 = -DAUX*DSIN(YQUAD) !
!
U = U1*U2 - V1*V2 !
V = U1*V2 + V1*U2 !
!
ELSE
!
! If (QRHO.GT.1.O) then W(Z) is evaluated using the Laplace
! continued fraction
! NU is the minimum number of terms needed to obtain the required
! accuracy
!
! If ((QRHO.GT.0.085264E0_WP).AND.(QRHO.LT.1.0)) then W(Z) is evaluated
! by a truncated taylor expansion, where the Laplace continued fraction
! is used to calculate the derivatives of W(Z)
!
! KAPN is the minimum number of terms in the taylor expansion needed
! to obtain the required accuracy
!
! NU is the minimum number of terms of the continued fraction needed
! to calculate the derivatives with the required accuracy
!
IF (QRHO > ONE) THEN !
H = ZERO !
KAPN = 0 !
QRHO = DSQRT(QRHO) !
NU = IDINT(THREE + (1442.0E0_WP / & !
(26.0E0_WP*QRHO+77.0E0_WP))) !
ELSE !
QRHO = (ONE-Y)*DSQRT(ONE-QRHO) !
H = 1.88E0_WP*QRHO !
H2 = TWO*H !
KAPN = IDNINT( SEVEN + 34.0E0_WP*QRHO) !
NU = IDNINT(16.0E0_WP + 26.0E0_WP*QRHO) !
END IF !
!
B = (H > ZERO) !
!
IF (B) QLAMBDA = H2**KAPN !
!
RX = ZERO !
RY = ZERO !
SX = ZERO !
SY = ZERO !
!
DO N=NU, 0, -1 !
NP1 = N + 1 !
TX = YABS + H + NP1*RX !
TY = XABS - NP1*RY !
C = HALF/(TX**2 + TY**2) !
RX = C*TX !
RY = C*TY !
IF ((B) .AND. (N.LE.KAPN)) THEN !
TX = QLAMBDA + SX !
SX = RX*TX - RY*SY !
SY = RY*TX + RX*SY !
QLAMBDA = QLAMBDA/H2 !
END IF !
END DO !
!
IF (H == ZERO) THEN !
U = FACTOR*RX !
V = FACTOR*RY !
ELSE !
U = FACTOR*SX !
V = FACTOR*SY !
END IF !
!
IF (YABS == ZERO) U = DEXP(-XABS**2) !
!
END IF !
!
! Evaluation of W(Z) in the other quadrants
!
IF (YI < ZERO) THEN !
!
IF (A) THEN
U2 = 2*U2 !
V2 = 2*V2 !
ELSE !
XQUAD = -XQUAD !
!
! The following if-statement protects 2*EXP(-Z**2)
! against overflow
!
IF ((YQUAD > RMAXGONI) .OR. & !
(XQUAD > RMAXEXP)) GO TO 100 !
!
W1 = TWO*DEXP(XQUAD) !
U2 = W1*DCOS(YQUAD) !
V2 = -W1*DSIN(YQUAD) !
END IF
!
U = U2 - U !
V = V2 - V !
IF (XI > ZERO) V = -V !
ELSE !
IF (XI < ZERO) V = -V !
END IF !
!
RETURN
!
100 FLAG = .TRUE. !
!
END SUBROUTINE WOFZ
!
!=======================================================================
!
! 5) Mittag-Leffler function E_{alpha,beta}(z):
!
!=======================================================================
!
RECURSIVE FUNCTION MLFV(ALPHA,BETA,Z,FI) RESULT(RES)
!
!.......................................................................
!
! MLFV -- Mittag-Leffler function.
!
! MLFV(ALPHA,BETA,Z,P) is the Mittag-Leffler function
! E_{alpha,beta}(z)
!
! evaluated with accuracy 10^(-P) for Z
!
! ALPHA and BETA are real scalars, P is integer, Z is complex.
!
! Created by Davide Verotta on 3/11/10.
! After MatLAB code C (C) 2001-2009 Igor Podlubny, Martin Kacenak
! Copyright 2010 UCSF. All rights reserved.
!
! Modified by Eduardo Mendes (with the permission of Davide Verotta) on 5/14/15.
!
! The function is update following the newest matlab code version and
! nows deals with complex numbers.
!
! The function has been tested with gfortran under Yosemite.
!
!.......................................................................
!
! Last modified (DS) : 23 Feb 2021
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FIVE,SIX,TEN,HALF
USE COMPLEX_NUMBERS, ONLY : ZEROC,IC
USE PI_ETC, ONLY : PI
!
IMPLICIT NONE
!
CHARACTER (LEN = 1) :: PN,KN
!
INTEGER, INTENT(IN) :: FI
!
INTEGER :: K,M,H
INTEGER :: LOGF
!
REAL (WP), INTENT(IN) :: ALPHA,BETA
!
REAL (WP) :: R0,RC,ANGZ
REAL (WP) :: EPS,AAZ
!
REAL (WP) :: LOG,ABS,DIMAG,DBLE,ATAN2
REAL (WP) :: EXP,LOG10,SQRT,FLOAT
REAL (WP) :: FLOOR,CEILING
!
COMPLEX (WP), INTENT(IN) :: Z
!
COMPLEX (WP) :: RES
!
COMPLEX (WP) :: NEWSUM,TERM,AUX,A1,A2,OLDSUM
COMPLEX (WP) :: ZN
!
LOGICAL :: L1,L2,L3,L4
!
LOGF = 6 ! log file
!
! Initilization of some variables
!
A1 = ZERO !
A2 = ZERO !
NEWSUM = ZERO !
OLDSUM = ZERO !
RES = ZERO !
!
! Checking the values of ALPHA and BETA
!
IF(ALPHA < ZERO)THEN !
WRITE(LOGF,10) !
STOP !
ELSE IF(BETA > FIVE) THEN !
WRITE(LOGF,20) !
STOP !
ELSE IF(ALPHA > FIVE) THEN !
WRITE(LOGF,30) !
STOP !
END IF !
!
PN = 'P' !
KN = 'K' !
!
IF(BETA < ZERO) THEN !
RC = LOG( TEN**(-FI) * PI / ( & !
SIX * (-BETA + TWO) * (- BETA * TWO)**(- BETA) & !
) & !
) !
RC = (- TWO * RC)**ALPHA
ELSE !
RC = (- TWO * LOG( TEN**(-FI) * PI / SIX ) )**ALPHA !
END IF !
!
R0 = MAX(ONE,TWO * ABS(Z),RC) !
ANGZ = ATAN2(DIMAG(Z),DBLE(Z)) !
AAZ = ABS(ANGZ) !
!
IF(ALPHA == ONE .AND. BETA == ONE) THEN !
RES = EXP(Z) !
RETURN !
END IF !
!
! Logical functions
!
L1 = ( (ALPHA < ONE .AND. ABS(Z) <= ONE) ) !
L2 = ( ONE <= ALPHA .AND. ALPHA < TWO ) !
L3 = ( ABS(Z) <= FLOOR( 20.0E0_WP / & !
(2.1E0_WP - ALPHA)**(5.5E0_WP - TWO *ALPHA) & !
) ) !
L4 = ( ALPHA >= TWO) .AND. (ABS(Z) <= 50.0E0_WP) !
!
IF(L1 .OR. L2 .AND. L3 .OR. L4) THEN !
OLDSUM = ZEROC !
K = 0 !
DO WHILE((ALPHA * K + BETA) <= ZERO) !
K = K + 1 !
END DO !
NEWSUM = Z**K / GAMMA(ALPHA * K + BETA) !
!
! Double summation because z can be negative
!
DO WHILE(NEWSUM /= OLDSUM) !
OLDSUM = NEWSUM !
K = K + 1 !
TERM = Z**K / GAMMA(ALPHA * K + BETA) !
NEWSUM = NEWSUM + TERM !
K = K + 1 !
TERM = Z**K / GAMMA(ALPHA * K + BETA) !
NEWSUM = NEWSUM + TERM !
END DO !
RES = NEWSUM !
RETURN !
END IF !
!
! The matlab function fix rounds toward zero,
! can use floor since alpha is positive
!
IF(ALPHA <= ONE .AND. ABS(Z) <= & !
FLOOR(FIVE * ALPHA + TEN)) THEN !
IF((AAZ > PI * ALPHA) .AND. & !
(ABS(AAZ - (PI * ALPHA)) > TEN*(-FI))) THEN !
IF(BETA <= ONE) THEN !
RES = ROMBINT(KN,ZERO,R0,FI,ALPHA,BETA,Z,ZERO) !
ELSE !
EPS = ONE !
AUX = ROMBINT(PN,-PI*ALPHA,PI*ALPHA,FI,ALPHA,BETA,Z,EPS)!
RES = ROMBINT(KN,EPS,R0,FI,ALPHA,BETA,Z,ZERO) + AUX !
END IF !
ELSE IF(AAZ < PI * ALPHA .AND. & !
ABS(AAZ - (PI * ALPHA)) > TEN**(-FI)) THEN !
IF(BETA <= ONE) THEN !
AUX = (Z**((ONE - BETA) / ALPHA)) * & !
(EXP(Z**(ONE / ALPHA)) / ALPHA) !
RES = ROMBINT(KN,ZERO,R0,FI,ALPHA,BETA,Z,ZERO) + AUX !
ELSE !
EPS = ABS(Z) / TWO !
AUX = ROMBINT(KN,EPS,R0,FI,ALPHA,BETA,Z,ZERO) !
AUX = AUX + & !
ROMBINT(PN,-PI*ALPHA,PI*ALPHA,FI,ALPHA,BETA,Z,EPS)!
RES = AUX + & !
(Z**((ONE - BETA) / ALPHA)) * & !
(EXP(Z**(ONE / ALPHA)) / ALPHA) !
END IF !
ELSE !
EPS = ABS(Z) + HALF !
AUX = ROMBINT(PN,-PI*ALPHA,PI*ALPHA,FI,ALPHA,BETA,Z,EPS) !
RES = ROMBINT(KN,EPS,R0,FI,ALPHA,BETA,Z,ZERO) + AUX !
END IF !
RETURN !
END IF !
!
IF(ALPHA <= ONE) THEN !
IF(AAZ < (PI * ALPHA * HALF + MIN(PI,PI*ALPHA)) * HALF) THEN!
NEWSUM = ( Z**((ONE - BETA) / ALPHA) ) * & !
EXP(Z**(ONE / ALPHA)) / ALPHA !
DO K = 1, FLOOR(FI / LOG10(ABS(Z))) !
!
! There is a need to avoid gamma of negative numbers. NaN
!
IF(CEILING(BETA-ALPHA*K) /= FLOOR(BETA-ALPHA*K)) THEN !
NEWSUM = NEWSUM - ((Z**(-K)) / GAMMA(BETA-ALPHA*K)) !
END IF !
END DO !
RES = NEWSUM !
ELSE !
NEWSUM = ZERO !
DO K = 1, FLOOR(FI / LOG10(ABS(Z))) !
!
! There is a need to avoid gamma of negative numbers.
!
IF(CEILING(BETA-ALPHA*K) /= FLOOR(BETA-ALPHA*K)) THEN !
NEWSUM = NEWSUM - ((Z**(-K)) / GAMMA(BETA-ALPHA*K)) !
END IF !
END DO !
RES = NEWSUM !
END IF !
ELSE !
IF(ALPHA >= TWO) THEN !
M = FLOOR(ALPHA * HALF) !
AUX = ZERO !
!
! Recursive call
!
DO H = 0, M !
ZN = ( Z**(ONE / FLOAT(M+1)) ) * & !
EXP( (TWO * PI * IC * FLOAT(H)) / FLOAT(M+1) ) !
AUX = AUX + MLFV(ALPHA / FLOAT(M+1),BETA,ZN,FI) !
END DO !
RES = (ONE / FLOAT(M+1)) * AUX !
ELSE !
!
! Recursive call
!
! I had to use sqrt instead of **(1/2) since Fortran returns real values
! the latter.
!
A1 = MLFV(ALPHA * HALF,BETA, SQRT(Z),FI) !
A2 = MLFV(ALPHA * HALF,BETA,-SQRT(Z),FI) !
RES = (A1 + A2) * HALF !
END IF !
END IF !
!
! Formats
!
10 FORMAT(//,5X,"<<<<< ALPHA must be greater than 0 >>>>>",//)
20 FORMAT(//,5X,"<<<<< BETA must be smaller than 5 >>>>>",//)
30 FORMAT(//,5X,"<<<<< ALPHA must be smaller than 5 >>>>>",//)
!
CONTAINS
!
!-----------------------------------------------------------------------
!
FUNCTION ROMBINT(FUNFCN,A,B,ORDER,V1,V2,V3,V4)
!
!.......................................................................
!
! Romber integration for auxillary functions
!
!.......................................................................
!
!
! Last modified (DS) : 27 Jan 2021
!
!
USE REAL_NUMBERS, ONLY : ONE,FOUR,HALF
USE COMPLEX_NUMBERS, ONLY : ZEROC
!
IMPLICIT NONE
!
CHARACTER (LEN = 1) :: FUNFCN
!
INTEGER, INTENT(IN) :: ORDER
!
INTEGER :: LOGF
INTEGER :: IORDER,IPOWER
INTEGER :: I,J,K
!
REAL (WP), INTENT(IN) :: A,B,V1,V2,V4
!
REAL (WP) :: HH
!
REAL (WP) :: FLOAT
!
COMPLEX (WP), INTENT(IN) :: V3
COMPLEX (WP) :: ROMBINT
!
COMPLEX (WP) :: A1,A2,AUXSUM
COMPLEX (WP) :: ROM(2,8)
!
LOGF = 6 ! log file
!
IORDER = ORDER !
!
IF(FUNFCN == "K") IORDER = 6 !
IF(ORDER > 8) THEN !
WRITE(LOGF,10) IORDER !
STOP !
END IF !
!
! Initialization of ROM array
!
DO I = 1, 2 !
DO J = 1, IORDER !
ROM(I,J) = ZEROC !
END DO !
END DO !
!
HH = B - A !
!
IF(FUNFCN == 'K')THEN !
A1 = KK(A,V1,V2,V3) !
A2 = KK(B,V1,V2,V3) !
ELSE !
A1 = PP(A,V1,V2,V3,V4) !
A2 = PP(B,V1,V2,V3,V4) !
END IF !
!
ROM(1,1) = HH * (A1 + A2) * HALF !
!
IPOWER = 1 !
!
DO I = 2, IORDER !
AUXSUM = ZEROC !
DO J = 1, IPOWER !
IF(FUNFCN == 'K') THEN !
A1 = KK((A+HH*(FLOAT(J)-HALF)),V1,V2,V3) !
ELSE !
A1 = PP((A+HH*(FLOAT(J)-HALF)),V1,V2,V3,V4) !
END IF !
AUXSUM = AUXSUM + A1 !
END DO !
ROM(2,1) = (ROM(1,1) + HH * AUXSUM) * HALF !
DO K = 1, I-1 !
ROM(2,K+1) = ( (FOUR**K) * ROM(2,K) - ROM(1,K) ) / & !
( (FOUR**K) - ONE ) !
END DO !
DO J = 0, I-1 !
ROM(1,J+1) = ROM(2,J+1) !
END DO !
IPOWER = IPOWER * 2 !
HH = HH * HALF !
END DO
!
ROMBINT = ROM(1,IORDER) !
!
! Formats
!
10 FORMAT(//,5X,"<<<<< Increase size of matrix R which is 8, order is >>>>>",I2,//)
!
END FUNCTION ROMBINT
!
!-----------------------------------------------------------------------
!
FUNCTION KK(R,ALFA,BETA,Z)
!
USE REAL_NUMBERS, ONLY : ONE,TWO
USE PI_ETC, ONLY : PI
!
!
IMPLICIT NONE
!
REAL (WP), INTENT(IN) :: R,ALFA,BETA
!
REAL (WP) :: EXP,SIN,COS
!
COMPLEX (WP), INTENT(IN) :: Z
COMPLEX (WP) :: KK
!
COMPLEX (WP) :: W
!
! This part has been modified and updated following the Matlab newest package code.
!
W = R**((ONE - BETA) / ALFA) * EXP(- R**(ONE / ALFA)) * & !
( R * SIN(PI*(ONE - BETA)) - & !
Z * SIN(PI*(ONE - BETA + ALFA)) ) / & !
(PI * ALFA * (R**2 - TWO * R * Z* COS(PI * ALFA) + Z**2)) !
!
KK = W
!
END FUNCTION KK
!
!-----------------------------------------------------------------------
!
FUNCTION PP(R,ALPHA,BETA,Z,EPSN)
!
USE REAL_NUMBERS, ONLY : ONE,TWO
USE COMPLEX_NUMBERS, ONLY : IC
USE PI_ETC, ONLY : PI
!
IMPLICIT NONE
!
REAL (WP), INTENT(IN) :: R,ALPHA,BETA,EPSN
!
REAL (WP) :: EXP,SIN,COS
!
COMPLEX (WP), INTENT(IN) :: Z
COMPLEX (WP) :: PP
!
COMPLEX (WP) :: W
!
W = (EPSN**(ONE / ALPHA)) * SIN(R / ALPHA) + & !
R * (ONE + (ONE - BETA) / ALPHA) !
!
PP = ( (EPSN**(ONE + (ONE - BETA) / ALPHA) ) / & !
(TWO * PI * ALPHA)) * ( & !
( EXP((EPSN**(ONE / ALPHA)) * COS(R / ALPHA)) *& !
(COS(W) + IC * SIN(W)) & !
) & !
) / & !
(EPSN * EXP(IC * R) - Z ) !
!
END FUNCTION PP
!
END FUNCTION MLFV
!
!-----------------------------------------------------------------------
!
FUNCTION MLFVDERIV(ALPHA,BETA,Z,FI)
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,SIX, &
HALF,SMALL
USE COMPLEX_NUMBERS, ONLY : ZEROC
!
IMPLICIT NONE
!
INTEGER, INTENT(IN) :: FI
!
INTEGER :: K,K0
!
REAL (WP), INTENT(IN) :: ALPHA,BETA
!
REAL (WP) :: D,W,AUX,K1
!
REAL (WP) :: ABS,LOG,MAX,SQRT,FLOAT
!
COMPLEX (WP), INTENT(IN) :: Z
COMPLEX (WP) :: MLFVDERIV
!
COMPLEX (WP) :: NEWSUM
!
NEWSUM = ZEROC !
W = ALPHA + BETA - THREE * HALF !
D = ALPHA * ALPHA - FOUR * ALPHA * BETA + & !
SIX * ALPHA + ONE !
!
! I had to add the following conditional statement to avoid log(1)
!
IF(ABS(LOG(ABS(Z))) < SMALL) THEN !
AUX = 100000.0E0_WP !
ELSE !
AUX = ABS( LOG(FI * (ONE - ABS(Z))) / LOG(ABS(Z)) ) !
END IF !
!
IF(ABS(Z) > ZERO .AND. ABS(Z) < ONE) THEN !
IF(ALPHA > ONE) THEN !
K1 = ABS((TWO - ALPHA - BETA) / (ALPHA -ONE )) + ONE !
ELSE
IF(ALPHA > ZERO .AND. ALPHA <= ONE .AND. D <= ZERO) THEN !
K1 = ABS((THREE - ALPHA - BETA) / ALPHA) + ONE !
ELSE
K1 = MAX(ABS((THREE - ALPHA - BETA) / ALPHA) + ONE, & !
ABS((ONE - TWO * W * ALPHA + SQRT(D)) / & !
(TWO * ALPHA * ALPHA)) + ONE) !
END IF !
END IF !
!
K0 = CEILING(MAX(K1,AUX)) !
!
DO K = 0, K0 !
NEWSUM = NEWSUM + ( FLOAT(K+1) * Z**K) / & !
GAMMA(ALPHA + BETA + ALPHA * K) !
END DO
ELSE IF(ABS(Z) == ZERO) THEN !
AUX = - TWO !
NEWSUM = GAMMA(AUX) !
ELSE
NEWSUM = ( MLFV(ALPHA,BETA-ONE,Z,FI) - (BETA - ONE) * & !
MLFV(ALPHA,BETA,Z,FI) ) / (ALPHA*Z) !
END IF !
!
MLFVDERIV = NEWSUM !
!
END FUNCTION MLFVDERIV
!
!=======================================================================
!
! 6) Confluent hypergeometric function 1F1(a,b;z) = M(a,b;z):
!
!=======================================================================
!
FUNCTION CONHYP(A,B,Z,LNCHF,IP)
!
! This function computes the confluent hypergeometric function
!
! 1F1(a,b;z) = M(a,b;z)
!
! solution of the differential equation
!
! z M"(a;b;z) + (b-z) M'(a;b;z) - a M(a;b;z) = 0
!
! Algorithm 707, collected algorithms from ACM.
! This work published in Transactions on Mathematical Software,
! Vol. 18, No. 3, September, 1992, pp. 345-349.
!
! Input parameters:
!
! * A : first parameter of 1F1(a,b;z)
! * A : second parameter of 1F1(a,b;z)
! * Z : argument of 1F1(a,b;z)
! * LNCHF : switch
! LNCHF = 0 --> return 1F1(a,b;z)
! LNCHF = 1 --> return LOG(1F1(a,b;z))
! * IP : number of array positions to be used
! IP = 0 --> program estimates it
! IP = 10 --> reasonable value
!
!
! Authors : M. Nardin, W. F. Perger and A. Bhalla
!
!
!
USE REAL_NUMBERS, ONLY : ZERO,HALF,ONE,TWO,TEN
USE PI_ETC, ONLY : PI
!
IMPLICIT NONE
!
INTEGER :: LNCHF,I,IP
COMPLEX (WP) :: A,B,Z,CONHYP
!
REAL (WP) :: NTERM,FX,TERM1,MAX,TERM2,ANG
!
IF (CDABS(Z) /= ZERO) THEN !
ANG=DATAN2(DIMAG(Z),DBLE(Z)) !
ELSE !
ANG=ONE !
END IF !
IF (DABS(ANG) < (PI*HALF)) THEN !
ANG=ONE !
ELSE !
ANG=DSIN(DABS(ANG)-(PI*HALF))+ONE !
END IF !
!
MAX=ZERO !
NTERM=ZERO !
FX=ZERO !
TERM1=ZERO !
!
10 NTERM=NTERM+ONE !
TERM2=CDABS((A+NTERM-1)*Z/((B+NTERM-1)*NTERM)) !
!
IF (TERM2 == ZERO) GO TO 20 !
IF (TERM2 < ONE) THEN !
IF ((DBLE(A)+NTERM-1) > ONE) THEN !
IF ((DBLE(B)+NTERM-1) > ONE) THEN !
IF ((TERM2-TERM1) < ZERO) THEN !
GO TO 20 !
END IF !
END IF !
END IF !
END IF !
!
FX=FX+DLOG(TERM2) !
IF (FX .GT. MAX) MAX=FX !
TERM1=TERM2 !
GO TO 10 !
!
20 MAX=MAX*2/(BITS()*6.93147181E-1_WP) !
I=INT(MAX*ANG)+7 !
IF ( I < 5) I=5 !
IF (IP > I) I=IP !
!
CONHYP=CHGF(A,B,Z,I,LNCHF) !
!
END FUNCTION CONHYP
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * FUNCTION BITS *
! * *
! * *
! * Description : Determines the number of significant figures *
! * of machine precision to arrive at the size of the array *
! * the numbers must must be stored in to get the accuracy *
! * of the solution. *
! * *
! * Subprograms called: none *
! * *
! ****************************************************************
!
FUNCTION BITS()
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO
!
IMPLICIT NONE
!
REAL (WP) :: BIT,BIT2
!
INTEGER :: BITS,COUNT
!
BIT=ONE !
COUNT=0 !
!
10 COUNT=COUNT+1 !
!
BIT2=BIT*TWO !
BIT=BIT2+ONE !
IF ((BIT-BIT2) /= ZERO) GO TO 10 !
!
BITS=COUNT-1 !
!
END FUNCTION BITS
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * FUNCTION CHGF *
! * *
! * *
! * Description : Function that sums the Kummer series and *
! * returns the solution of the confluent hypergeometric *
! * function. *
! * *
! * Subprograms called: ARMULT, ARYDIV, BITS, CMPADD, CMPMUL *
! * *
! ****************************************************************
!
FUNCTION CHGF (A,B,Z,L,LNCHF)
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF,TEN
!
IMPLICIT NONE
!
INTEGER :: LENGTH
PARAMETER (LENGTH=777) !
!
INTEGER :: L,I,BIT,LNCHF,NMACH,ICOUNT,IXCNT
INTEGER :: LOGF
!
REAL (WP) :: AR,AI,CR,CI,XR,XI
REAL (WP) :: CNT,SIGFIG,MX1,MX2,RMAX
REAL (WP) :: R1,AR2,AI2,CR2,CI2,XR2,XI2
REAL (WP) :: SUMR(-1:LENGTH),SUMI(-1:LENGTH)
REAL (WP) :: NUMR(-1:LENGTH),NUMI(-1:LENGTH)
REAL (WP) :: DENOMR(-1:LENGTH),DENOMI(-1:LENGTH)
REAL (WP) :: QR1(-1:LENGTH),QR2(-1:LENGTH)
REAL (WP) :: QI1(-1:LENGTH),QI2(-1:LENGTH)
!
COMPLEX (WP) :: A,B,Z,FINAL,CHGF
!
LOGF=6 !
!
BIT=BITS() !
RMAX=TWO**(BIT/2) !
SIGFIG=TWO**(BIT/4) !
!
! Set to zero any arguments which are below the precision of the
! algorithm.
!
AR2=DBLE(A)*SIGFIG !
AR =DINT(AR2) !
AR2=DNINT((AR2-AR)*RMAX) !
AI2=DIMAG(A)*SIGFIG !
AI =DINT(AI2) !
AI2=DNINT((AI2-AI)*RMAX) !
CR2=DBLE(B)*SIGFIG !
CR =DINT(CR2) !
CR2=DNINT((CR2-CR)*RMAX) !
CI2=DIMAG(B)*SIGFIG !
CI =DINT(CI2) !
CI2=DNINT((CI2-CI)*RMAX) !
XR2=DBLE(Z)*SIGFIG !
XR =DINT(XR2) !
XR2=DNINT((XR2-XR)*RMAX) !
XI2=DIMAG(Z)*SIGFIG !
XI =DINT(XI2) !
XI2=DNINT((XI2-XI)*RMAX) !
!
! Warn the user that the input value was so close to zero that it
! was set equal to zero.
!
IF ((DBLE(A)/= ZERO) .AND. (AR == ZERO) .AND. (AR2 == ZERO)) &!
WRITE(LOGF,*) ' WARNING - REAL PART OF A WAS SET TO ZERO' !
IF ((DIMAG(A)/= ZERO) .AND. (AI == ZERO) .AND. (AI2 == ZERO))&!
WRITE(LOGF,*) ' WARNING - IMAG PART OF A WAS SET TO ZERO' !
IF ((DBLE(B)/= ZERO) .AND. (CR == ZERO) .AND. (CR2 == ZERO)) &!
WRITE(LOGF,*) ' WARNING - REAL PART OF B WAS SET TO ZERO' !
IF ((DIMAG(B)/= ZERO) .AND. (CI == ZERO) .AND. (CI2 == ZERO))&!
WRITE(LOGF,*) ' WARNING - IMAG PART OF B WAS SET TO ZERO' !
IF ((DBLE(Z)/= ZERO) .AND. (XR == ZERO) .AND. (XR2 == ZERO)) &!
WRITE(LOGF,*) ' WARNING - REAL PART OF Z WAS SET TO ZERO' !
IF ((DIMAG(Z)/= ZERO) .AND. (XI == ZERO) .AND. (XI2 == ZERO))&!
WRITE(LOGF,*) ' WARNING - IMAG PART OF Z WAS SET TO ZERO' !
!
! Screening of the case when b is zero or a negative integer.
!
IF ((CR == ZERO) .AND. (CR2 == ZERO) .AND. &!
(CI == ZERO) .AND. (CI2 == ZERO)) THEN !
WRITE (LOGF,*) ' ERROR-- ARGUMENT B WAS EQUAL TO ZERO' !
STOP !
END IF !
!
NMACH=INT(LOG10(TWO**INT(BITS()))) !
IF ((CI == ZERO) .AND. (CI2 ==ZERO) .AND. &!
(DBLE(B) < ZERO)) THEN !
IF (ABS(DBLE(B)-DBLE(NINT(DBLE(B)))) < TEN**(-NMACH)) THEN !
WRITE (LOGF,*) ' ERROR-- ARGUMENT B WAS A NEGATIVE INTEGER'!
STOP !
END IF !
END IF !
!
SUMR(-1) =ONE !
SUMI(-1) =ONE !
NUMR(-1) =ONE !
NUMI(-1) =ONE !
DENOMR(-1)=ONE !
DENOMI(-1)=ONE !
!
DO I=0,L+1 !
SUMR(I) =ZERO !
SUMI(I) =ZERO !
NUMR(I) =ZERO !
NUMI(I) =ZERO !
DENOMR(I)=ZERO !
DENOMI(I)=ZERO !
END DO
!
SUMR(1) =ONE !
NUMR(1) =ONE !
DENOMR(1)=ONE !
CNT =SIGFIG !
ICOUNT =-1 !
!
IF ((AI == ZERO) .AND. (AI2 == ZERO) .AND. &!
(DBLE(A) < ZERO)) THEN !
IF (ABS(DBLE(A)-DBLE(NINT(DBLE(A)))) < TEN**(-NMACH)) &!
ICOUNT=-NINT(DBLE(A)) !
END IF !
!
IXCNT=0 !
!
110 IF (SUMR(1) < HALF) THEN !
MX1=SUMI(L+1) !
ELSE IF (SUMI(1) < HALF) THEN !
MX1=SUMR(L+1) !
ELSE !
MX1=DMAX1(SUMR(L+1),SUMI(L+1)) !
END IF !
IF (NUMR(1) < HALF) THEN !
MX2=NUMI(L+1) !
ELSE IF (NUMI(1) < HALF) THEN !
MX2=NUMR(L+1) !
ELSE !
MX2=DMAX1(NUMR(L+1),NUMI(L+1)) !
END IF !
IF (MX1-MX2 > TWO) THEN !
IF (CR > ZERO) THEN !
IF (CDABS(DCMPLX(AR,AI)*DCMPLX(XR,XI)/(DCMPLX(CR,CI)*CNT))&!
< ONE) GO TO 190 !
END IF !
END IF !
!
IF (IXCNT == ICOUNT) GO TO 190 !
!
IXCNT=IXCNT+1 !
CALL CMPMUL(SUMR,SUMI,CR,CI,QR1,QI1,L,RMAX) !
CALL CMPMUL(SUMR,SUMI,CR2,CI2,QR2,QI2,L,RMAX) !
QR2(L+1)=QR2(L+1)-1 !
QI2(L+1)=QI2(L+1)-1 !
CALL CMPADD(QR1,QI1,QR2,QI2,SUMR,SUMI,L,RMAX) !
!
CALL ARMULT(SUMR,CNT,SUMR,L,RMAX) !
CALL ARMULT(SUMI,CNT,SUMI,L,RMAX) !
CALL CMPMUL(DENOMR,DENOMI,CR,CI,QR1,QI1,L,RMAX) !
CALL CMPMUL(DENOMR,DENOMI,CR2,CI2,QR2,QI2,L,RMAX) !
QR2(L+1)=QR2(L+1)-1 !
QI2(L+1)=QI2(L+1)-1 !
CALL CMPADD(QR1,QI1,QR2,QI2,DENOMR,DENOMI,L,RMAX) !
!
CALL ARMULT(DENOMR,CNT,DENOMR,L,RMAX) !
CALL ARMULT(DENOMI,CNT,DENOMI,L,RMAX) !
CALL CMPMUL(NUMR,NUMI,AR,AI,QR1,QI1,L,RMAX) !
CALL CMPMUL(NUMR,NUMI,AR2,AI2,QR2,QI2,L,RMAX) !
QR2(L+1)=QR2(L+1)-1 !
QI2(L+1)=QI2(L+1)-1 !
CALL CMPADD(QR1,QI1,QR2,QI2,NUMR,NUMI,L,RMAX) !
!
CALL CMPMUL(NUMR,NUMI,XR,XI,QR1,QI1,L,RMAX) !
CALL CMPMUL(NUMR,NUMI,XR2,XI2,QR2,QI2,L,RMAX) !
QR2(L+1)=QR2(L+1)-1 !
QI2(L+1)=QI2(L+1)-1 !
CALL CMPADD(QR1,QI1,QR2,QI2,NUMR,NUMI,L,RMAX) !
!
CALL CMPADD(SUMR,SUMI,NUMR,NUMI,SUMR,SUMI,L,RMAX) !
CNT=CNT+SIGFIG !
AR =AR+SIGFIG !
CR =CR+SIGFIG !
GO TO 110 !
!
190 CALL ARYDIV(SUMR,SUMI,DENOMR,DENOMI,FINAL,L,LNCHF,RMAX,BIT) !
CHGF=FINAL !
!
END FUNCTION CHGF
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * SUBROUTINE ARADD *
! * *
! * *
! * Description : Accepts two arrays of numbers and returns *
! * the sum of the array. Each array is holding the value *
! * of one number in the series. The parameter L is the *
! * size of the array representing the number and RMAX is *
! * the actual number of digits needed to give the numbers *
! * the desired accuracy. *
! * *
! * Subprograms called: none *
! * *
! ****************************************************************
!
SUBROUTINE ARADD(A,B,C,L,RMAX)
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,HALF,TEN
!
IMPLICIT NONE
!
REAL (WP) :: A(-1:*),B(-1:*),C(-1:*),Z(-1:777)
REAL (WP) :: RMAX
!
INTEGER :: L
INTEGER :: EDIFF,I,J
!
DO I=0,L+1 !
Z(I)=ZERO !
END DO !
EDIFF=IDNINT(A(L+1)-B(L+1)) !
!
IF (DABS(A(1)) < HALF .OR. EDIFF <= -L) GO TO 111 !
IF (DABS(B(1)) < HALF .OR. EDIFF >= L) GO TO 113 !
!
GO TO 115 !
!
111 DO I=-1,L+1 !
C(I)=B(I) !
END DO !
!
GO TO 311 !
!
113 DO I=-1,L+1 !
C(I)=A(I) !
END DO !
!
GO TO 311 !
!
115 Z(-1)=A(-1) !
IF (DABS(A(-1)-B(-1)) < HALF) GO TO 200 !
!
IF (EDIFF > 0) THEN !
Z(L+1)=A(L+1) !
GO TO 233 !
END IF !
IF (EDIFF < 0) THEN !
Z(L+1)=B(L+1) !
Z(-1)=B(-1) !
GO TO 266 !
END IF !
DO I=1,L !
IF (A(I) > B(I)) THEN !
Z(L+1)=A(L+1) !
GO TO 233 !
END IF !
IF (A(I) < B(I)) THEN !
Z(L+1)=B(L+1) !
Z(-1)=B(-1) !
GO TO 266 !
ENDIF !
END DO !
GO TO 300 !
!
200 IF (EDIFF > 0) GO TO 203 !
IF (EDIFF < 0) GO TO 207 !
!
Z(L+1)=A(L+1) !
DO I=L,1,-1 !
Z(I)=A(I)+B(I)+Z(I) !
IF (Z(I) >= RMAX) THEN !
Z(I)=Z(I)-RMAX !
Z(I-1)=ONE !
ENDIF !
END DO !
IF (Z(0) > HALF) THEN !
DO I=L,1,-1 !
Z(I)=Z(I-1) !
END DO !
Z(L+1)=Z(L+1)+ONE !
Z(0)=ZERO !
END IF !
!
GO TO 300 !
!
203 Z(L+1)=A(L+1) !
DO I=L,1+EDIFF,-1 !
Z(I)=A(I)+B(I-EDIFF)+Z(I) !
IF (Z(I) >= RMAX) THEN !
Z(I)=Z(I)-RMAX !
Z(I-1)=ONE !
END IF !
END DO !
DO I=EDIFF,1,-1 !
Z(I)=A(I)+Z(I) !
IF (Z(I) >= RMAX) THEN !
Z(I)=Z(I)-RMAX !
Z(I-1)=ONE !
END IF !
END DO !
IF (Z(0) > HALF) THEN !
DO I=L,1,-1 !
Z(I)=Z(I-1) !
END DO !
Z(L+1)=Z(L+1)+1 !
Z(0)=ZERO !
END IF !
!
GO TO 300 !
!
207 Z(L+1)=B(L+1) !
DO I=L,1-EDIFF,-1 !
Z(I)=A(I+EDIFF)+B(I)+Z(I) !
IF (Z(I) >= RMAX) THEN !
Z(I)=Z(I)-RMAX !
Z(I-1)=ONE !
ENDIF !
END DO !
DO I=0-EDIFF,1,-1 !
Z(I)=B(I)+Z(I) !
IF (Z(I) >= RMAX) THEN !
Z(I)=Z(I)-RMAX !
Z(I-1)=ONE !
END IF !
END DO !
IF (Z(0) > HALF) THEN !
DO I=L,1,-1 !
Z(I)=Z(I-1) !
END DO !
Z(L+1)=Z(L+1)+ONE !
Z(0)=ZERO !
END IF !
!
GO TO 300 !
!
233 IF (EDIFF > 0) GO TO 243 !
!
DO I=L,1,-1 !
Z(I)=A(I)-B(I)+Z(I) !
IF (Z(I) < ZERO) THEN !
Z(I)=Z(I)+RMAX !
Z(I-1)=-ONE !
END IF !
END DO !
!
GO TO 290 !
!
243 DO I=L,1+EDIFF,-1 !
Z(I)=A(I)-B(I-EDIFF)+Z(I) !
IF (Z(I) < ZERO) THEN !
Z(I)=Z(I)+RMAX !
Z(I-1)=-ONE !
END IF !
END DO !
DO I=EDIFF,1,-1 !
Z(I)=A(I)+Z(I) !
IF (Z(I) < ZERO) THEN !
Z(I)=Z(I)+RMAX !
Z(I-1)=-ONE !
END IF !
END DO !
!
GO TO 290 !
!
266 IF (EDIFF < 0) GO TO 276 !
!
DO I=L,1,-1 !
Z(I)=B(I)-A(I)+Z(I) !
IF (Z(I) < ZERO) THEN !
Z(I)=Z(I)+RMAX !
Z(I-1)=-ONE !
END IF !
END DO !
!
GO TO 290 !
!
276 DO I=L,1-EDIFF,-1 !
Z(I)=B(I)-A(I+EDIFF)+Z(I) !
IF (Z(I) < ZERO) THEN !
Z(I)=Z(I)+RMAX !
Z(I-1)=-ONE !
END IF !
END DO !
DO I=0-EDIFF,1,-1 !
Z(I)=B(I)+Z(I) !
IF (Z(I) < ZERO) THEN !
Z(I)=Z(I)+RMAX !
Z(I-1)=-ONE !
END IF !
END DO !
!
290 IF (Z(1) > HALF) GO TO 300 !
!
I=1 !
!
291 I=I+1 !
IF (Z(I) < HALF .AND. I < L+1) GO TO 291 !
!
IF (I == L+1) THEN !
Z(-1)=ONE !
Z(L+1)=ZERO !
GO TO 300 !
END IF !
!
292 DO J=1,L+1-I !
Z(J)=Z(J+I-1) !
END DO !
DO J=L+2-I,L !
Z(J)=ZERO !
END DO !
Z(L+1)=Z(L+1)-I+1 !
!
300 DO I=-1,L+1 !
C(I)=Z(I) !
END DO !
!
311 IF (C(1) < HALF) THEN !
C(-1)=ONE !
C(L+1)=ZERO !
END IF !
!
END SUBROUTINE ARADD
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * SUBROUTINE ARSUB *
! * *
! * *
! * Description : Accepts two arrays and subtracts each element *
! * in the second array from the element in the first array *
! * and returns the solution. The parameters L and RMAX are *
! * the size of the array and the number of digits needed for *
! * the accuracy, respectively. *
! * *
! * Subprograms called: ARADD *
! * *
! ****************************************************************
!
SUBROUTINE ARSUB(A,B,C,L,RMAX)
!
USE REAL_NUMBERS, ONLY : ONE
!
IMPLICIT NONE
!
INTEGER :: L,I
!
REAL (WP) :: A(-1:*),B(-1:*),C(-1:*)
REAL (WP) :: B2(-1:777)
REAL (WP) :: RMAX
!
DO I=-1,L+1 !
B2(I)=B(I) !
END DO !
!
B2(-1)=(-ONE)*B2(-1) !
!
CALL ARADD(A,B2,C,L,RMAX) !
!
END SUBROUTINE ARSUB
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * SUBROUTINE ARMULT *
! * *
! * *
! * Description : Accepts two arrays and returns the product. *
! * L and RMAX are the size of the arrays and the number of *
! * digits needed to represent the numbers with the required *
! * accuracy. *
! * *
! * Subprograms called: none *
! * *
! ****************************************************************
!
SUBROUTINE ARMULT(A,B,C,L,RMAX)
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,HALF,EPS
!
IMPLICIT NONE
!
INTEGER :: I,L
!
REAL (WP) :: A(-1:*),C(-1:*),Z(-1:777)
REAL (WP) :: B,B2,CARRY,RMAX,RMAX2
!
RMAX2=ONE/RMAX !
Z(-1)=DSIGN(ONE,B)*A(-1) !
B2=DABS(B) !
Z(L+1)=A(L+1) !
!
DO I=0,L !
Z(I)=ZERO !
END DO !
!
IF (B2 <= EPS .OR. A(1) <= EPS) THEN !
Z(-1)=ONE !
Z(L+1)=ZERO !
GO TO 198 !
END IF !
DO I=L,1,-1 !
Z(I)=A(I)*B2+Z(I) !
IF (Z(I) >= RMAX) THEN !
CARRY=DINT(Z(I)/RMAX) !
Z(I)=Z(I)-CARRY*RMAX !
Z(I-1)=CARRY !
END IF !
END DO !
!
IF (Z(0) < HALF) GO TO 150 !
!
DO I=L,1,-1 !
Z(I)=Z(I-1) !
END DO !
Z(0)=ZERO !
!
150 CONTINUE !
!
198 DO I=-1,L+1 !
C(I)=Z(I) !
END DO !
IF (C(1) < HALF) THEN !
C(-1)=ONE !
C(L+1)=ZERO !
END IF !
!
END SUBROUTINE ARMULT
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * SUBROUTINE CMPADD *
! * *
! * *
! * Description : Takes two arrays representing one real and *
! * one imaginary part, and adds two arrays representing *
! * another complex number and returns two array holding the *
! * complex sum. *
! * (CR,CI) = (AR+BR, AI+BI) *
! * *
! * Subprograms called: ARADD *
! * *
! ****************************************************************
!
SUBROUTINE CMPADD(AR,AI,BR,BI,CR,CI,L,RMAX)
!
IMPLICIT NONE
!
INTEGER :: L
!
REAL (WP) :: RMAX
REAL (WP) :: AR(-1:*),AI(-1:*)
REAL (WP) :: BR(-1:*),BI(-1:*)
REAL (WP) :: CR(-1:*),CI(-1:*)
!
CALL ARADD(AR,BR,CR,L,RMAX) !
CALL ARADD(AI,BI,CI,L,RMAX) !
!
END SUBROUTINE CMPADD
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * SUBROUTINE CMPSUB *
! * *
! * *
! * Description : Takes two arrays representing one real and *
! * one imaginary part, and subtracts two arrays representing *
! * another complex number and returns two array holding the *
! * complex sum. *
! * (CR,CI) = (AR+BR, AI+BI) *
! * *
! * Subprograms called: ARADD *
! * *
! ****************************************************************
!
SUBROUTINE CMPSUB(AR,AI,BR,BI,CR,CI,L,RMAX)
!
IMPLICIT NONE
!
INTEGER :: L
!
REAL (WP) :: RMAX
REAL (WP) :: AR(-1:*),AI(-1:*)
REAL (WP) :: BR(-1:*),BI(-1:*)
REAL (WP) :: CR(-1:*),CI(-1:*)
!
CALL ARSUB(AR,BR,CR,L,RMAX) !
CALL ARSUB(AI,BI,CI,L,RMAX) !
!
END SUBROUTINE CMPSUB
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * SUBROUTINE CMPMUL *
! * *
! * *
! * Description : Takes two arrays representing one real and *
! * one imaginary part, and multiplies it with two arrays *
! * representing another complex number and returns the *
! * complex product. *
! * *
! * Subprograms called: ARMULT, ARSUB, ARADD *
! * *
! ****************************************************************
!
SUBROUTINE CMPMUL(AR,AI,BR,BI,CR,CI,L,RMAX)
!
IMPLICIT NONE
!
INTEGER :: L
!
REAL (WP) :: BR,BI,RMAX
REAL (WP) :: AR(-1:*),AI(-1:*)
REAL (WP) :: CR(-1:*),CI(-1:*)
REAL (WP) :: D1(-1:777),D2(-1:777)
!
CALL ARMULT(AR,BR,D1,L,RMAX) !
CALL ARMULT(AI,BI,D2,L,RMAX) !
CALL ARSUB(D1,D2,CR,L,RMAX) !
CALL ARMULT(AR,BI,D1,L,RMAX) !
CALL ARMULT(AI,BR,D2,L,RMAX) !
CALL ARADD(D1,D2,CI,L,RMAX) !
!
END SUBROUTINE CMPMUL
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * SUBROUTINE ARYDIV *
! * *
! * *
! * Description : Returns the REAL*8 complex number *
! * resulting from the division of four arrays, representing *
! * two complex numbers. The number returned will be in one *
! * two different forms: either standard scientific or as *
! * the natural log of the number. *
! * *
! * Subprograms called: CONV21, CONV12, EADD, ECPDIV, EMULT *
! * *
! ****************************************************************
!
SUBROUTINE ARYDIV(AR,AI,BR,BI,C,L,LNCHF,RMAX,BIT)
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF,TEN
!
IMPLICIT NONE
!
INTEGER :: L,BIT,REXP,IR10,II10,LNCHF
!
COMPLEX (WP) :: C
!
REAL (WP) :: PHI,N1,N2,N3,E1,E2,E3,RR10,RI10,X
REAL (WP) :: X1,X2,DUM1,DUM2,RMAX
REAL (WP) :: AR(-1:*),AI(-1:*),BR(-1:*),BI(-1:*)
REAL (WP) :: AE(2,2),BE(2,2),CE(2,2)
!
REXP = BIT/2 !
X = REXP*(AR(L+1)-2) !
RR10 = X*DLOG10(TWO)/DLOG10(TEN) !
IR10 = INT(RR10) !
RR10 = RR10-IR10 !
X = REXP*(AI(L+1)-2) !
RI10 = X*DLOG10(TWO)/DLOG10(TEN) !
II10 = INT(RI10) !
RI10 = RI10-II10 !
DUM1 = DSIGN(AR(1)*RMAX*RMAX+AR(2)*RMAX+AR(3),AR(-1)) !
DUM2 = DSIGN(AI(1)*RMAX*RMAX+AI(2)*RMAX+AI(3),AI(-1)) !
DUM1 = DUM1*10**RR10 !
DUM2 = DUM2*10**RI10 !
!
CALL CONV12(DCMPLX(DUM1,DUM2),AE) !
!
AE(1,2) = AE(1,2)+IR10 !
AE(2,2) = AE(2,2)+II10 !
X = REXP*(BR(L+1)-2) !
RR10 = X*DLOG10(TWO)/DLOG10(TEN) !
IR10 = INT(RR10) !
RR10 = RR10-IR10 !
X = REXP*(BI(L+1)-2) !
RI10 = X*DLOG10(TWO)/DLOG10(TEN) !
II10 = INT(RI10) !
RI10 = RI10-II10 !
DUM1 = DSIGN(BR(1)*RMAX*RMAX+BR(2)*RMAX+BR(3),BR(-1)) !
DUM2 = DSIGN(BI(1)*RMAX*RMAX+BI(2)*RMAX+BI(3),BI(-1)) !
DUM1 = DUM1*10**RR10 !
DUM2 = DUM2*10**RI10 !
!
CALL CONV12(DCMPLX(DUM1,DUM2),BE) !
!
BE(1,2) = BE(1,2)+IR10 !
BE(2,2) = BE(2,2)+II10 !
!
CALL ECPDIV(AE,BE,CE) !
!
IF (LNCHF == 0) THEN !
CALL CONV21(CE,C) !
ELSE !
CALL EMULT(CE(1,1),CE(1,2),CE(1,1),CE(1,2),N1,E1) !
CALL EMULT(CE(2,1),CE(2,2),CE(2,1),CE(2,2),N2,E2) !
CALL EADD(N1,E1,N2,E2,N3,E3) !
N1=CE(1,1) !
E1=CE(1,2)-CE(2,2) !
X2=CE(2,1) !
IF (E1 > 74.0E0_WP) THEN !
X1=1.0E75_WP !
ELSE IF (E1 < -74.0E0_WP) THEN !
X1=0 !
ELSE !
X1=N1*(10**E1) !
END IF !
PHI=DATAN2(X2,X1) !
C=DCMPLX(HALF*(DLOG(N3)+E3*DLOG(TEN)),PHI) !
END IF !
!
END SUBROUTINE ARYDIV
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * SUBROUTINE EMULT *
! * *
! * *
! * Description : Takes one base and exponent and multiplies it *
! * by another numbers base and exponent to give the product *
! * in the form of base and exponent. *
! * *
! * Subprograms called: none *
! * *
! ****************************************************************
!
SUBROUTINE EMULT(N1,E1,N2,E2,NF,EF)
!
USE REAL_NUMBERS, ONLY : ONE,TEN
!
IMPLICIT NONE
!
REAL (WP) :: N1,E1,N2,E2,NF,EF
!
NF=N1*N2 !
EF=E1+E2 !
!
IF (DABS(NF) >= TEN) THEN !
NF=NF/TEN !
EF=EF+ONE !
END IF !
!
END SUBROUTINE EMULT
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * SUBROUTINE EDIV *
! * *
! * *
! * Description : returns the solution in the form of base and *
! * exponent of the division of two exponential numbers. *
! * *
! * Subprograms called: none *
! * *
! ****************************************************************
!
SUBROUTINE EDIV(N1,E1,N2,E2,NF,EF)
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TEN
!
IMPLICIT NONE
!
REAL (WP) :: N1,E1,N2,E2,NF,EF
!
NF=N1/N2 !
EF=E1-E2 !
!
IF ((DABS(NF) < ONE) .AND. (NF /= ZERO)) THEN !
NF=NF*TEN !
EF=EF-ONE !
END IF !
!
END SUBROUTINE EDIV
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * SUBROUTINE EADD *
! * *
! * *
! * Description : Returns the sum of two numbers in the form *
! * of a base and an exponent. *
! * *
! * Subprograms called: none *
! * *
! ****************************************************************
!
SUBROUTINE EADD(N1,E1,N2,E2,NF,EF)
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,TEN
!
IMPLICIT NONE
!
REAL (WP) :: N1,E1,N2,E2,NF,EF,EDIFF,THIRSIX
!
EDIFF=E1-E2 !
THIRSIX=(ONE+TWO)*(TWO+TEN) !
!
IF (EDIFF > THIRSIX) THEN !
NF=N1 !
EF=E1 !
ELSE IF (EDIFF < -THIRSIX) THEN !
NF=N2 !
EF=E2 !
ELSE !
NF=N1*(TEN**EDIFF)+N2 !
EF=E2 !
400 IF (DABS(NF) < TEN) GO TO 410 !
NF=NF/TEN !
EF=EF+ONE !
GO TO 400 !
410 IF ((DABS(NF) >= ONE) .OR. (NF == ZERO)) GO TO 420 !
NF=NF*TEN !
EF=EF-ONE !
GO TO 410 !
END IF !
!
420 RETURN !
!
END SUBROUTINE EADD
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * SUBROUTINE ESUB *
! * *
! * *
! * Description : Returns the solution to the subtraction of *
! * two numbers in the form of base and exponent. *
! * *
! * Subprograms called: EADD *
! * *
! ****************************************************************
!
SUBROUTINE ESUB(N1,E1,N2,E2,NF,EF)
!
USE REAL_NUMBERS, ONLY : ONE
!
IMPLICIT NONE
!
REAL (WP) :: N1,E1,N2,E2,NF,EF
!
CALL EADD(N1,E1,N2*(-ONE),E2,NF,EF) !
!
END SUBROUTINE ESUB
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * SUBROUTINE CONV12 *
! * *
! * *
! * Description : Converts a number from complex notation to a *
! * form of a 2x2 real array. *
! * *
! * Subprograms called: none *
! * *
! ****************************************************************
!
SUBROUTINE CONV12(CN,CAE)
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TEN
!
IMPLICIT NONE
!
COMPLEX (WP) :: CN
!
REAL (WP) :: CAE(2,2)
!
CAE(1,1)=DBLE(CN) !
CAE(1,2)=ZERO !
!
300 IF (DABS(CAE(1,1)) < TEN) GO TO 310 !
!
CAE(1,1)=CAE(1,1)/TEN !
CAE(1,2)=CAE(1,2)+ONE !
GO TO 300 !
!
310 IF ((DABS(CAE(1,1)) >= ONE) .OR. (CAE(1,1) == ZERO)) GO TO 320!
!
CAE(1,1)=CAE(1,1)*TEN !
CAE(1,2)=CAE(1,2)-ONE !
GO TO 310 !
!
320 CAE(2,1)=DIMAG(CN) !
CAE(2,2)=ZERO !
!
330 IF (DABS(CAE(2,1)) < TEN) GO TO 340 !
!
CAE(2,1)=CAE(2,1)/TEN !
CAE(2,2)=CAE(2,2)+ONE !
GO TO 330 !
!
340 IF ((DABS(CAE(2,1)) >= ONE) .OR. (CAE(2,1) == ZERO)) GO TO 350!
!
CAE(2,1)=CAE(2,1)*TEN !
CAE(2,2)=CAE(2,2)-ONE !
GO TO 340 !
!
350 RETURN
!
END SUBROUTINE CONV12
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * SUBROUTINE CONV21 *
! * *
! * *
! * Description : Converts a number represented in a 2x2 real *
! * array to the form of a complex number. *
! * *
! * Subprograms called: none *
! * *
! ****************************************************************
!
SUBROUTINE CONV21(CAE,CN)
!
USE REAL_NUMBERS, ONLY : ZERO
!
IMPLICIT NONE
!
COMPLEX (WP) :: CN
!
REAL (WP) :: CAE(2,2)
!
IF (CAE(1,2) > 75 .OR. CAE(2,2) > 75) THEN !
CN=DCMPLX(1.0D75,1.0D75) !
ELSE IF (CAE(2,2) < -75) THEN !
CN=DCMPLX(CAE(1,1)*(10**CAE(1,2)),ZERO) !
ELSE !
CN=DCMPLX(CAE(1,1)*(10**CAE(1,2)),CAE(2,1)*(10**CAE(2,2))) !
END IF !
!
END SUBROUTINE CONV21
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * SUBROUTINE ECPMUL *
! * *
! * *
! * Description : Multiplies two numbers which are each *
! * represented in the form of a two by two array and returns *
! * the solution in the same form. *
! * *
! * Subprograms called: EMULT, ESUB, EADD *
! * *
! ****************************************************************
!
SUBROUTINE ECPMUL(A,B,C)
!
IMPLICIT NONE
!
REAL (WP) :: N1,E1,N2,E2
REAL (WP) :: A(2,2),B(2,2),C(2,2),C2(2,2)
!
CALL EMULT(A(1,1),A(1,2),B(1,1),B(1,2),N1,E1) !
CALL EMULT(A(2,1),A(2,2),B(2,1),B(2,2),N2,E2) !
CALL ESUB(N1,E1,N2,E2,C2(1,1),C2(1,2)) !
CALL EMULT(A(1,1),A(1,2),B(2,1),B(2,2),N1,E1) !
CALL EMULT(A(2,1),A(2,2),B(1,1),B(1,2),N2,E2) !
CALL EADD(N1,E1,N2,E2,C(2,1),C(2,2)) !
!
C(1,1)=C2(1,1) !
C(1,2)=C2(1,2) !
!
END SUBROUTINE ECPMUL
!
!=======================================================================
!
!
! ****************************************************************
! * *
! * SUBROUTINE ECPDIV *
! * *
! * *
! * Description : Divides two numbers and returns the solution. *
! * All numbers are represented by a 2x2 array. *
! * *
! * Subprograms called: EADD, ECPMUL, EDIV, EMULT *
! * *
! ****************************************************************
!
SUBROUTINE ECPDIV(A,B,C)
!
USE REAL_NUMBERS, ONLY : ONE
!
IMPLICIT NONE
!
REAL (WP) :: N1,E1,N2,E2,N3,E3
REAL (WP) :: A(2,2),B(2,2),C(2,2),B2(2,2),C2(2,2)
!
B2(1,1)=B(1,1) !
B2(1,2)=B(1,2) !
B2(2,1)=-ONE*B(2,1) !
B2(2,2)=B(2,2) !
!
CALL ECPMUL(A,B2,C2) !
CALL EMULT(B(1,1),B(1,2),B(1,1),B(1,2),N1,E1) !
CALL EMULT(B(2,1),B(2,2),B(2,1),B(2,2),N2,E2) !
CALL EADD(N1,E1,N2,E2,N3,E3) !
CALL EDIV(C2(1,1),C2(1,2),N3,E3,C(1,1),C(1,2)) !
CALL EDIV(C2(2,1),C2(2,2),N3,E3,C(2,1),C(2,2)) !
!
END SUBROUTINE ECPDIV
!
!=======================================================================
!
! 7) Fermi-Dirac integral functions:
!
!=======================================================================
!
FUNCTION FDM0P5(XVALUE)
!
! DESCRIPTION:
!
! This function computes the Fermi-Dirac function of
! order -1/2, defined as
!
! Int{0 to inf} t**(-1/2) / (1+exp(t-x)) dt
! FDM0P5(x) = -----------------------------------------
! Gamma(1/2)
!
! The function uses Chebyshev expansions which are given to
! 16 decimal places for x <= 2, but only 10 decimal places
! for x > 2.
!
!
! ERROR RETURNS:
!
! None.
!
!
! MACHINE-DEPENDENT CONSTANTS:
!
! NTERMS1 - INTEGER - The number of terms used from the array
! ARRFD1. The recommended value is such that
! ABS(ARRFD1(NTERMS1)) < EPS/10
! subject to 1 <= NTERMS1 <= 14.
!
! NTERMS2 - INTEGER - The number of terms used from the array
! ARRFD2. The recommended value is such that
! ABS(ARRFD2(NTERMS2)) < EPS/10
! subject to 1 <= NTERMS1 <= 23.
!
! NTERMS3 - INTEGER - The number of terms used from the array
! ARRFD3. The recommended value is such that
! ABS(ARRFD3(NTERMS3)) < EPS/10
! subject to 1 <= NTERMS3 <= 28.
!
! XMIN1 - REAL - The value of x below which
! FDM0P5(x) = exp(x)
! to machine precision. The recommended value
! is LN ( SQRT(2) * EPSNEG )
!
! XMIN2 - REAL - The value of x below which
! FDM0P5(x) = 0.0
! to machine precision. The recommended value
! is LN ( XMIN )
!
! XHIGH - REAL - The value of x above which
! FDM0P5(x) = 2 sqrt (x/pi)
! to machine precision. The recommended value
! is 1 / sqrt( 2 * EPSNEG )
!
! For values of EPS, EPSNEG, and XMIN the user should refer to the
! paper by Cody in ACM. Trans. Math. Soft. Vol. 14 (1988) p303-311.
!
! This code is provided with single and REAL*8 values
! of the machine-dependent parameters, suitable for machines
! which satisfy the IEEE floating-point standard.
!
!
! AUTHOR:
! DR. ALLAN MACLEOD,
! DEPT. OF MATHEMATICS AND STATISTICS,
! UNIVERSITY OF PAISLEY,
! HIGH ST.,
! PAISLEY,
! SCOTLAND
! PA1 2BE
!
! (e-mail: macl-ms0@paisley.ac.uk )
!
!
! LATEST UPDATE:
! 20 NOVEMBER, 1996
!
!
!
! Last modified (DS) : 15 Jun 2020
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE
!
IMPLICIT NONE
!
INTEGER :: NTERM1,NTERM2,NTERM3
!
REAL (WP) :: FDM0P5
REAL (WP) :: ARRFD1(0:14),ARRFD2(0:23),ARRFD3(0:58)
REAL (WP) :: CHV,EXPX,FIFTY,FORTY2
REAL (WP) :: GAM1P5,T,TWOE
REAL (WP) :: X,XHIGH,XMIN1,XMIN2,XSQ,XVALUE
!
DATA ARRFD1/1.7863596385102264E0_WP, & !
-0.999372007632333E-1_WP, & !
0.64144652216054E-2_WP, & !
-0.4356415371345E-3_WP, & !
0.305216700310E-4_WP, & !
-0.21810648110E-5_WP, & !
0.1580050781E-6_WP, & !
-0.115620570E-7_WP, & !
0.8525860E-9_WP, & !
-0.632529E-10_WP, & !
0.47159E-11_WP, & !
-0.3530E-12_WP, & !
0.265E-13_WP, & !
-0.20E-14_WP, & !
0.2E-15_WP/ !
!
DATA ARRFD2( 0)/ 1.6877111526052352E0_WP/ !
DATA ARRFD2( 1)/ 0.5978360226336983E0_WP/ !
DATA ARRFD2( 2)/ 0.357226004541669E-1_WP/ !
DATA ARRFD2( 3)/-0.132144786506426E-1_WP/ !
DATA ARRFD2( 4)/-0.4040134207447E-3_WP/ !
DATA ARRFD2( 5)/ 0.5330011846887E-3_WP/ !
DATA ARRFD2( 6)/-0.148923504863E-4_WP/ !
DATA ARRFD2( 7)/-0.218863822916E-4_WP/ !
DATA ARRFD2( 8)/ 0.19652084277E-5_WP/ !
DATA ARRFD2( 9)/ 0.8565830466E-6_WP/ !
DATA ARRFD2(10)/-0.1407723133E-6_WP/ !
DATA ARRFD2(11)/-0.305175803E-7_WP/ !
DATA ARRFD2(12)/ 0.83524532E-8_WP/ !
DATA ARRFD2(13)/ 0.9025750E-9_WP/ !
DATA ARRFD2(14)/-0.4455471E-9_WP/ !
DATA ARRFD2(15)/-0.148342E-10_WP/ !
DATA ARRFD2(16)/ 0.219266E-10_WP/ !
DATA ARRFD2(17)/-0.6579E-12_WP/ !
DATA ARRFD2(18)/-0.10009E-11_WP/ !
DATA ARRFD2(19)/ 0.936E-13_WP/ !
DATA ARRFD2(20)/ 0.420E-13_WP/ !
DATA ARRFD2(21)/-0.71E-14_WP/ !
DATA ARRFD2(22)/-0.16E-14_WP/ !
DATA ARRFD2(23)/ 0.4E-15_WP/ !
!
DATA ARRFD3(0)/ 0.8707195029590563E0_WP/ !
DATA ARRFD3(1)/ 0.59833110231733E-2_WP/ !
DATA ARRFD3(2)/ -0.432670470895746E-1_WP/ !
DATA ARRFD3(3)/ -0.393083681608590E-1_WP/ !
DATA ARRFD3(4)/ -0.191482688045932E-1_WP/ !
DATA ARRFD3(5)/ -0.65582880980158E-2_WP/ !
DATA ARRFD3(6)/ -0.22276691516312E-2_WP/ !
DATA ARRFD3(7)/ -0.8466786936178E-3_WP/ !
DATA ARRFD3(8)/ -0.2807459489219E-3_WP/ !
DATA ARRFD3(9)/ -0.955575024348E-4_WP/ !
DATA ARRFD3(10)/-0.362367662803E-4_WP/ !
DATA ARRFD3(11)/-0.109158468869E-4_WP/ !
DATA ARRFD3(12)/-0.39356701000E-5_WP/ !
DATA ARRFD3(13)/-0.13108192725E-5_WP/ !
DATA ARRFD3(14)/-0.2468816388E-6_WP/ !
DATA ARRFD3(15)/-0.1048380311E-6_WP/ !
DATA ARRFD3(16)/ 0.236181487E-7_WP/ !
DATA ARRFD3(17)/ 0.227145359E-7_WP/ !
DATA ARRFD3(18)/ 0.145775174E-7_WP/ !
DATA ARRFD3(19)/ 0.153926767E-7_WP/ !
DATA ARRFD3(20)/ 0.56924772E-8_WP/ !
DATA ARRFD3(21)/ 0.50623068E-8_WP/ !
DATA ARRFD3(22)/ 0.23426075E-8_WP/ !
DATA ARRFD3(23)/ 0.12652275E-8_WP/ !
DATA ARRFD3(24)/ 0.8927773E-9_WP/ !
DATA ARRFD3(25)/ 0.2994501E-9_WP/ !
DATA ARRFD3(26)/ 0.2822785E-9_WP/ !
DATA ARRFD3(27)/ 0.910685E-10_WP/ !
DATA ARRFD3(28)/ 0.696285E-10_WP/ !
DATA ARRFD3(29)/ 0.366225E-10_WP/ !
DATA ARRFD3(30)/ 0.124351E-10_WP/ !
DATA ARRFD3(31)/ 0.145019E-10_WP/ !
DATA ARRFD3(32)/ 0.16645E-11_WP/ !
DATA ARRFD3(33)/ 0.45856E-11_WP/ !
DATA ARRFD3(34)/ 0.6092E-12_WP/ !
DATA ARRFD3(35)/ 0.9331E-12_WP/ !
DATA ARRFD3(36)/ 0.5238E-12_WP/ !
DATA ARRFD3(37)/-0.56E-14_WP/ !
DATA ARRFD3(38)/ 0.3170E-12_WP/ !
DATA ARRFD3(39)/-0.926E-13_WP/ !
DATA ARRFD3(40)/ 0.1265E-12_WP/ !
DATA ARRFD3(41)/-0.327E-13_WP/ !
DATA ARRFD3(42)/ 0.276E-13_WP/ !
DATA ARRFD3(43)/ 0.33E-14_WP/ !
DATA ARRFD3(44)/-0.42E-14_WP/ !
DATA ARRFD3(45)/ 0.101E-13_WP/ !
DATA ARRFD3(46)/-0.73E-14_WP/ !
DATA ARRFD3(47)/ 0.64E-14_WP/ !
DATA ARRFD3(48)/-0.37E-14_WP/ !
DATA ARRFD3(49)/ 0.23E-14_WP/ !
DATA ARRFD3(50)/-0.9E-15_WP/ !
DATA ARRFD3(51)/ 0.2E-15_WP/ !
DATA ARRFD3(52)/ 0.2E-15_WP/ !
DATA ARRFD3(53)/-0.3E-15_WP/ !
DATA ARRFD3(54)/ 0.4E-15_WP/ !
DATA ARRFD3(55)/-0.3E-15_WP/ !
DATA ARRFD3(56)/ 0.2E-15_WP/ !
DATA ARRFD3(57)/-0.1E-15_WP/ !
DATA ARRFD3(58)/ 0.1E-15_WP/ !
!
DATA FORTY2,FIFTY / 42.0E0_WP , 50.0E0_WP/ !
DATA GAM1P5 /0.8862269254527580E0_WP/ !
DATA TWOE /5.4365636569180905E0_WP/ !
!
! Machine-dependent constants
!
DATA NTERM1,NTERM2,NTERM3 /14,23,58/ !
DATA XMIN1,XMIN2,XHIGH /-36.39023E0_WP,-708.39641E0_WP, &!
67108864.0E0_WP / !
!
! Start calculation
!
X=XVALUE !
!
! Code for x < -1
!
IF ( X < -ONE ) THEN
IF ( X > XMIN1 ) THEN !
EXPX = DEXP(X) !
T = TWOE * EXPX - ONE !
FDM0P5 = EXPX * CHEVAL ( NTERM1 , ARRFD1 , T ) !
ELSE !
IF ( X < XMIN2 ) THEN !
FDM0P5 = ZERO !
ELSE !
FDM0P5 = DEXP(X) !
END IF !
END IF !
ELSE !
!
! Code for -1 <= x <= 2
!
IF ( X <= TWO ) THEN !
T = ( TWO * X - ONE ) / THREE !
FDM0P5 = CHEVAL ( NTERM2 , ARRFD2 , T ) !
ELSE !
!
! Code for x > 2
!
FDM0P5 = DSQRT(X) / GAM1P5 !
IF ( X <= XHIGH ) THEN !
XSQ = X * X !
T = ( FIFTY - XSQ ) / ( FORTY2 + XSQ ) !
CHV = CHEVAL ( NTERM3 , ARRFD3 , T ) !
FDM0P5 = FDM0P5 * ( ONE - CHV / XSQ ) !
END IF !
END IF !
END IF !
!
END FUNCTION FDM0P5
!
!=======================================================================
!
FUNCTION FDP0P5(XVALUE)
!
! DESCRIPTION:
!
! This function computes the Fermi-Dirac function of
! order 1/2, defined as
!
! Int{0 to inf} t**(1/2) / (1+exp(t-x)) dt
! FDP0P5(x) = -----------------------------------------
! Gamma(3/2)
!
! The function uses Chebyshev expansions which are given to
! 16 decimal places for x <= 2, but only 10 decimal places
! for x > 2.
!
!
! ERROR RETURNS:
!
! If XVALUE too large and positive, the function value
! will overflow. An error message is printed and the function
! returns the value 0.0.
!
!
! MACHINE-DEPENDENT CONSTANTS:
!
! NTERMS1 - INTEGER - The number of terms used from the array
! ARRFD1. The recommended value is such that
! ABS(ARRFD1(NTERMS1)) < EPS/10
! subject to 1 <= NTERMS1 <= 13.
!
! NTERMS2 - INTEGER - The number of terms used from the array
! ARRFD2. The recommended value is such that
! ABS(ARRFD2(NTERMS2)) < EPS/10
! subject to 1 <= NTERMS1 <= 23.
!
! NTERMS3 - INTEGER - The number of terms used from the array
! ARRFD3. The recommended value is such that
! ABS(ARRFD3(NTERMS3)) < EPS/10
! subject to 1 <= NTERMS3 <= 32.
!
! XMIN1 - REAL - The value of x below which
! FDP0P5(x) = exp(x)
! to machine precision. The recommended value
! is 1.5*LN(2) + LN(EPSNEG)
!
! XMIN2 - REAL - The value of x below which
! FDP0P5(x) = 0.0
! to machine precision. The recommended value
! is LN ( XMIN )
!
! XHIGH1 - REAL - The value of x above which
! FDP0P5(x) = x**(3/2)/GAMMA(5/2)
! to machine precision. The recommended value
! is pi / SQRT(8*EPS)
!
! XHIGH2 - REAL - The value of x above which FDP0P5 would
! overflow. The reommended value is
! (1.329*XMAX)**(2/3)
!
! For values of EPS, EPSNEG, and XMIN the user should refer to the
! paper by Cody in ACM. Trans. Math. Soft. Vol. 14 (1988) p303-311.
!
! This code is provided with single and REAL*8 values
! of the machine-dependent parameters, suitable for machines
! which satisfy the IEEE floating-point standard.
!
!
! AUTHOR:
! DR. ALLAN MACLEOD,
! DEPT. OF MATHEMATICS AND STATISTICS,
! UNIVERSITY OF PAISLEY,
! HIGH ST.,
! PAISLEY,
! SCOTLAND
! PA1 2BE
!
! (e-mail: macl-ms0@paisley.ac.uk )
!
!
! LATEST UPDATE:
! 20 NOVEMBER, 1996
!
!
! Last modified (DS) : 15 Jun 2020
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE
!
IMPLICIT NONE
!
INTEGER :: NTERM1,NTERM2,NTERM3
INTEGER :: LOGF
!
REAL (WP) :: FDP0P5
REAL (WP) :: ARRFD1(0:13),ARRFD2(0:23),ARRFD3(0:53)
REAL (WP) :: CHV,EXPX,FIFTY,FORTY2
REAL (WP) :: GAM2P5,T,TWOE
REAL (WP) :: X,XHIGH1,XHIGH2,XMIN1,XMIN2,XSQ,XVALUE
!
DATA ARRFD1/1.8862968392734597E0_WP, & !
-0.543580817644053E-1_WP, & !
0.23644975439720E-2_WP, & !
-0.1216929365880E-3_WP, & !
0.68695130622E-5_WP, & !
-0.4112076172E-6_WP, & !
0.256351628E-7_WP, & !
-0.16465008E-8_WP, & !
0.1081948E-9_WP, & !
-0.72392E-11_WP, & !
0.4915E-12_WP, & !
-0.338E-13_WP, & !
0.23E-14_WP, & !
-0.2E-15_WP/ !
!
DATA ARRFD2( 0)/ 2.6982492788170612E0_WP/ !
DATA ARRFD2( 1)/ 1.2389914141133012E0_WP/ !
DATA ARRFD2( 2)/ 0.2291439379816278E0_WP/ !
DATA ARRFD2( 3)/ 0.90316534687279E-2_WP/ !
DATA ARRFD2( 4)/-0.25776524691246E-2_WP/ !
DATA ARRFD2( 5)/-0.583681605388E-4_WP/ !
DATA ARRFD2( 6)/ 0.693609458725E-4_WP/ !
DATA ARRFD2( 7)/-0.18061670265E-5_WP/ !
DATA ARRFD2( 8)/-0.21321530005E-5_WP/ !
DATA ARRFD2( 9)/ 0.1754983951E-6_WP/ !
DATA ARRFD2(10)/ 0.665325470E-7_WP/ !
DATA ARRFD2(11)/-0.101675977E-7_WP/ !
DATA ARRFD2(12)/-0.19637597E-8_WP/ !
DATA ARRFD2(13)/ 0.5075769E-9_WP/ !
DATA ARRFD2(14)/ 0.491469E-10_WP/ !
DATA ARRFD2(15)/-0.233737E-10_WP/ !
DATA ARRFD2(16)/-0.6645E-12_WP/ !
DATA ARRFD2(17)/ 0.10115E-11_WP/ !
DATA ARRFD2(18)/-0.313E-13_WP/ !
DATA ARRFD2(19)/-0.412E-13_WP/ !
DATA ARRFD2(20)/ 0.38E-14_WP/ !
DATA ARRFD2(21)/ 0.16E-14_WP/ !
DATA ARRFD2(22)/-0.3E-15_WP/ !
DATA ARRFD2(23)/-0.1E-15_WP/ !
!
DATA ARRFD3(0)/ 2.5484384198009122E0_WP/ !
DATA ARRFD3(1)/ 0.510439408960652E-1_WP/ !
DATA ARRFD3(2)/ 0.77493527628294E-2_WP/ !
DATA ARRFD3(3)/ -0.75041656584953E-2_WP/ !
DATA ARRFD3(4)/ -0.77540826320296E-2_WP/ !
DATA ARRFD3(5)/ -0.45810844539977E-2_WP/ !
DATA ARRFD3(6)/ -0.23431641587363E-2_WP/ !
DATA ARRFD3(7)/ -0.11788049513591E-2_WP/ !
DATA ARRFD3(8)/ -0.5802739359702E-3_WP/ !
DATA ARRFD3(9)/ -0.2825350700537E-3_WP/ !
DATA ARRFD3(10)/-0.1388136651799E-3_WP/ !
DATA ARRFD3(11)/-0.680695084875E-4_WP/ !
DATA ARRFD3(12)/-0.335356350608E-4_WP/ !
DATA ARRFD3(13)/-0.166533018734E-4_WP/ !
DATA ARRFD3(14)/-0.82714908266E-5_WP/ !
DATA ARRFD3(15)/-0.41425714409E-5_WP/ !
DATA ARRFD3(16)/-0.20805255294E-5_WP/ !
DATA ARRFD3(17)/-0.10479767478E-5_WP/ !
DATA ARRFD3(18)/-0.5315273802E-6_WP/ !
DATA ARRFD3(19)/-0.2694061178E-6_WP/ !
DATA ARRFD3(20)/-0.1374878749E-6_WP/ !
DATA ARRFD3(21)/-0.702308887E-7_WP/ !
DATA ARRFD3(22)/-0.359543942E-7_WP/ !
DATA ARRFD3(23)/-0.185106126E-7_WP/ !
DATA ARRFD3(24)/-0.95023937E-8_WP/ !
DATA ARRFD3(25)/-0.49184811E-8_WP/ !
DATA ARRFD3(26)/-0.25371950E-8_WP/ !
DATA ARRFD3(27)/-0.13151532E-8_WP/ !
DATA ARRFD3(28)/-0.6835168E-9_WP/ !
DATA ARRFD3(29)/-0.3538244E-9_WP/ !
DATA ARRFD3(30)/-0.1853182E-9_WP/ !
DATA ARRFD3(31)/-0.958983E-10_WP/ !
DATA ARRFD3(32)/-0.504083E-10_WP/ !
DATA ARRFD3(33)/-0.262238E-10_WP/ !
DATA ARRFD3(34)/-0.137255E-10_WP/ !
DATA ARRFD3(35)/-0.72340E-11_WP/ !
DATA ARRFD3(36)/-0.37429E-11_WP/ !
DATA ARRFD3(37)/-0.20059E-11_WP/ !
DATA ARRFD3(38)/-0.10269E-11_WP/ !
DATA ARRFD3(39)/-0.5551E-12_WP/ !
DATA ARRFD3(40)/-0.2857E-12_WP/ !
DATA ARRFD3(41)/-0.1520E-12_WP/ !
DATA ARRFD3(42)/-0.811E-13_WP/ !
DATA ARRFD3(43)/-0.410E-13_WP/ !
DATA ARRFD3(44)/-0.234E-13_WP/ !
DATA ARRFD3(45)/-0.110E-13_WP/ !
DATA ARRFD3(46)/-0.67E-14_WP/ !
DATA ARRFD3(47)/-0.30E-14_WP/ !
DATA ARRFD3(48)/-0.19E-14_WP/ !
DATA ARRFD3(49)/-0.9E-15_WP/ !
DATA ARRFD3(50)/-0.5E-15_WP/ !
DATA ARRFD3(51)/-0.3E-15_WP/ !
DATA ARRFD3(52)/-0.1E-15_WP/ !
DATA ARRFD3(53)/-0.1E-15_WP/ !
!
DATA FORTY2,FIFTY / 42.0E0_WP , 50.0E0_WP/ !
DATA GAM2P5 /0.1329340388179137E1_WP/ !
DATA TWOE /5.4365636569180905E0_WP/ !
!
! Machine-dependent constants (suitable for IEEE machines)
!
DATA NTERM1,NTERM2,NTERM3 /13,23,53/ !
DATA XMIN1,XMIN2 /-35.7E0_WP,-708.394E0_WP/ !
DATA XHIGH1,XHIGH2 /7.45467E7_WP,3.8392996E205_WP/ !
!
LOGF=6 !
!
! Start calculation
!
X=XVALUE !
!
! Test for error condition
!
IF ( X > XHIGH2 ) THEN !
WRITE(LOGF,*)'** Error ** - X too large for FDP0P5' !
STOP !
END IF !
!
! Code for x < -1
!
IF ( X < -ONE ) THEN !
IF ( X > XMIN1 ) THEN !
EXPX = DEXP(X) !
T = TWOE * EXPX - ONE !
FDP0P5 = EXPX * CHEVAL ( NTERM1 , ARRFD1 , T ) !
ELSE !
IF ( X < XMIN2 ) THEN !
FDP0P5 = ZERO !
ELSE !
FDP0P5 = DEXP(X) !
END IF !
END IF !
ELSE !
!
! Code for -1 <= x <= 2
!
IF ( X <= TWO ) THEN !
T = ( TWO * X - ONE ) / THREE !
FDP0P5 = CHEVAL ( NTERM2 , ARRFD2 , T ) !
ELSE !
!
! Code for x > 2
!
FDP0P5 = X * DSQRT(X) / GAM2P5 !
IF ( X <= XHIGH1 ) THEN !
XSQ = X * X !
T = ( FIFTY - XSQ ) / ( FORTY2 + XSQ ) !
CHV = CHEVAL ( NTERM3 , ARRFD3 , T ) !
FDP0P5 = FDP0P5 * ( ONE + CHV / XSQ ) !
END IF !
END IF !
END IF !
!
END FUNCTION FDP0P5
!
!=======================================================================
!
FUNCTION FDP1P5(XVALUE)
!
! DESCRIPTION:
!
! This function computes the Fermi-Dirac function of
! order 3/2, defined as
!
! Int{0 to inf} t**(3/2) / (1+exp(t-x)) dt
! FDP1P5(x) = -----------------------------------------
! Gamma(5/2)
!
! The function uses Chebyshev expansions which are given to
! 16 decimal places for x <= 2, but only 10 decimal places
! for x > 2.
!
!
! ERROR RETURNS:
!
! If XVALUE too large and positive, the function value
! will overflow. An error message is printed and the function
! returns the value 0.0.
!
!
! MACHINE-DEPENDENT CONSTANTS:
!
! NTERMS1 - INTEGER - The number of terms used from the array
! ARRFD1. The recommended value is such that
! ABS(ARRFD1(NTERMS1)) < EPS/10
! subject to 1 <= NTERMS1 <= 12.
!
! NTERMS2 - INTEGER - The number of terms used from the array
! ARRFD2. The recommended value is such that
! ABS(ARRFD2(NTERMS2)) < EPS/10
! subject to 1 <= NTERMS1 <= 22.
!
! NTERMS3 - INTEGER - The number of terms used from the array
! ARRFD3. The recommended value is such that
! ABS(ARRFD3(NTERMS3)) < EPS/10
! subject to 1 <= NTERMS3 <= 33.
!
! XMIN1 - REAL - The value of x below which
! FDP1P5(x) = exp(x)
! to machine precision. The recommended value
! is 2.5*LN(2) + LN(EPSNEG)
!
! XMIN2 - REAL - The value of x below which
! FDP1P5(x) = 0.0
! to machine precision. The recommended value
! is LN ( XMIN )
!
! XHIGH1 - REAL - The value of x above which
! FDP1P5(x) = x**(5/2)/GAMMA(7/2)
! to machine precision. The recommended value
! is pi * SQRT(1.6/EPS)
!
! XHIGH2 - REAL - The value of x above which FDP1P5 would
! overflow. The reommended value is
! (3.233509*XMAX)**(2/5)
!
! For values of EPS, EPSNEG, and XMIN the user should refer to the
! paper by Cody in ACM. Trans. Math. Soft. Vol. 14 (1988) p303-311.
!
! This code is provided with single and REAL*8 values
! of the machine-dependent parameters, suitable for machines
! which satisfy the IEEE floating-point standard.
!
!
! AUTHOR:
! DR. ALLAN MACLEOD,
! DEPT. OF MATHEMATICS AND STATISTICS,
! UNIVERSITY OF PAISLEY,
! HIGH ST.,
! PAISLEY,
! SCOTLAND
! PA1 2BE
!
! (e-mail: macl_ms0@paisley.ac.uk )
!
!
! LATEST UPDATE:
! 21 NOVEMBER, 1996
!
!
! Last modified (DS) : 15 Jun 2020
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE
!
IMPLICIT NONE
!
INTEGER :: NTERM1,NTERM2,NTERM3
INTEGER :: LOGF
!
REAL (WP) :: FDP1P5
REAL (WP) :: ARRFD1(0:12),ARRFD2(0:22),ARRFD3(0:55)
REAL (WP) :: CHV,EXPX,FIFTY,FORTY2
REAL (WP) :: GAM3P5,T,TWOE
REAL (WP) :: X,XHIGH1,XHIGH2,XMIN1,XMIN2,XSQ,XVALUE
!
DATA ARRFD1/1.9406549210378650E0_WP, & !
-0.287867475518043E-1_WP, & !
0.8509157952313E-3_WP, & !
-0.332784525669E-4_WP, & !
0.15171202058E-5_WP, & !
-0.762200874E-7_WP, & !
0.40955489E-8_WP, & !
-0.2311964E-9_WP, & !
0.135537E-10_WP, & !
-0.8187E-12_WP, & !
0.507E-13_WP, & !
-0.32E-14_WP, & !
0.2E-15_WP/ !
!
DATA ARRFD2( 0)/ 3.5862251615634306E0_WP/ !
DATA ARRFD2( 1)/ 1.8518290056265751E0_WP/ !
DATA ARRFD2( 2)/ 0.4612349102417150E0_WP/ !
DATA ARRFD2( 3)/ 0.579303976126881E-1_WP/ !
DATA ARRFD2( 4)/ 0.17043790554875E-2_WP/ !
DATA ARRFD2( 5)/-0.3970520122496E-3_WP/ !
DATA ARRFD2( 6)/-0.70702491890E-5_WP/ !
DATA ARRFD2( 7)/ 0.76599748792E-5_WP/ !
DATA ARRFD2( 8)/-0.1857811333E-6_WP/ !
DATA ARRFD2( 9)/-0.1832237956E-6_WP/ !
DATA ARRFD2(10)/ 0.139249495E-7_WP/ !
DATA ARRFD2(11)/ 0.46702027E-8_WP/ !
DATA ARRFD2(12)/-0.6671984E-9_WP/ !
DATA ARRFD2(13)/-0.1161292E-9_WP/ !
DATA ARRFD2(14)/ 0.284438E-10_WP/ !
DATA ARRFD2(15)/ 0.24906E-11_WP/ !
DATA ARRFD2(16)/-0.11431E-11_WP/ !
DATA ARRFD2(17)/-0.279E-13_WP/ !
DATA ARRFD2(18)/ 0.439E-13_WP/ !
DATA ARRFD2(19)/-0.14E-14_WP/ !
DATA ARRFD2(20)/-0.16E-14_WP/ !
DATA ARRFD2(21)/ 0.1E-15_WP/ !
DATA ARRFD2(22)/ 0.1E-15_WP/ !
!
DATA ARRFD3( 0)/12.1307581736884627E0_WP/ !
DATA ARRFD3( 1)/-0.1547501111287255E0_WP/ !
DATA ARRFD3( 2)/-0.739007388850999E-1_WP/ !
DATA ARRFD3( 3)/-0.307235377959258E-1_WP/ !
DATA ARRFD3( 4)/-0.114548579330328E-1_WP/ !
DATA ARRFD3( 5)/-0.40567636809539E-2_WP/ !
DATA ARRFD3( 6)/-0.13980158373227E-2_WP/ !
DATA ARRFD3( 7)/-0.4454901810153E-3_WP/ !
DATA ARRFD3( 8)/-0.1173946112704E-3_WP/ !
DATA ARRFD3( 9)/-0.148408980093E-4_WP/ !
DATA ARRFD3(10)/ 0.118895154223E-4_WP/ !
DATA ARRFD3(11)/ 0.146476958178E-4_WP/ !
DATA ARRFD3(12)/ 0.113228741730E-4_WP/ !
DATA ARRFD3(13)/ 0.75762292948E-5_WP/ !
DATA ARRFD3(14)/ 0.47120400466E-5_WP/ !
DATA ARRFD3(15)/ 0.28132628202E-5_WP/ !
DATA ARRFD3(16)/ 0.16370517341E-5_WP/ !
DATA ARRFD3(17)/ 0.9351076272E-6_WP/ !
DATA ARRFD3(18)/ 0.5278689210E-6_WP/ !
DATA ARRFD3(19)/ 0.2951079870E-6_WP/ !
DATA ARRFD3(20)/ 0.1638600190E-6_WP/ !
DATA ARRFD3(21)/ 0.905205409E-7_WP/ !
DATA ARRFD3(22)/ 0.497756975E-7_WP/ !
DATA ARRFD3(23)/ 0.272955863E-7_WP/ !
DATA ARRFD3(24)/ 0.149214585E-7_WP/ !
DATA ARRFD3(25)/ 0.81420359E-8_WP/ !
DATA ARRFD3(26)/ 0.44349200E-8_WP/ !
DATA ARRFD3(27)/ 0.24116032E-8_WP/ !
DATA ARRFD3(28)/ 0.13105018E-8_WP/ !
DATA ARRFD3(29)/ 0.7109736E-9_WP/ !
DATA ARRFD3(30)/ 0.3856721E-9_WP/ !
DATA ARRFD3(31)/ 0.2089529E-9_WP/ !
DATA ARRFD3(32)/ 0.1131735E-9_WP/ !
DATA ARRFD3(33)/ 0.612785E-10_WP/ !
DATA ARRFD3(34)/ 0.331448E-10_WP/ !
DATA ARRFD3(35)/ 0.179419E-10_WP/ !
DATA ARRFD3(36)/ 0.96953E-11_WP/ !
DATA ARRFD3(37)/ 0.52463E-11_WP/ !
DATA ARRFD3(38)/ 0.28343E-11_WP/ !
DATA ARRFD3(39)/ 0.15323E-11_WP/ !
DATA ARRFD3(40)/ 0.8284E-12_WP/ !
DATA ARRFD3(41)/ 0.4472E-12_WP/ !
DATA ARRFD3(42)/ 0.2421E-12_WP/ !
DATA ARRFD3(43)/ 0.1304E-12_WP/ !
DATA ARRFD3(44)/ 0.707E-13_WP/ !
DATA ARRFD3(45)/ 0.381E-13_WP/ !
DATA ARRFD3(46)/ 0.206E-13_WP/ !
DATA ARRFD3(47)/ 0.111E-13_WP/ !
DATA ARRFD3(48)/ 0.60E-14_WP/ !
DATA ARRFD3(49)/ 0.33E-14_WP/ !
DATA ARRFD3(50)/ 0.17E-14_WP/ !
DATA ARRFD3(51)/ 0.11E-14_WP/ !
DATA ARRFD3(52)/ 0.5E-15_WP/ !
DATA ARRFD3(53)/ 0.3E-15_WP/ !
DATA ARRFD3(54)/ 0.1E-15_WP/ !
DATA ARRFD3(55)/ 0.1E-15_WP/ !
!
DATA FORTY2,FIFTY / 42.0E0_WP , 50.0E0_WP/ !
DATA GAM3P5 /0.3323350970447843E1_WP/ !
DATA TWOE /5.4365636569180905E0_WP/ !
!
! Machine-dependent constants (suitable for IEEE machines)
!
DATA NTERM1,NTERM2,NTERM3 /12,22,55/ !
DATA XMIN1,XMIN2 /-35.004E0_WP,-708.396418E0_WP/ !
DATA XHIGH1,XHIGH2 /166674733.2E0_WP,3.204467E123_WP/!
!
LOGF=6 !
!
! Start calculation
!
X=XVALUE !
!
! Test for error condition
!
IF ( X > XHIGH2 ) THEN !
WRITE(LOGF,*) '** Error ** - X too large for FDP1P5' !
STOP !
ENDIF !
!
! Code for x < -1
!
IF ( X < -ONE ) THEN
IF ( X > XMIN1 ) THEN !
EXPX = DEXP(X) !
T = TWOE * EXPX - ONE !
FDP1P5 = EXPX * CHEVAL ( NTERM1 , ARRFD1 , T ) !
ELSE !
IF ( X < XMIN2 ) THEN !
FDP1P5 = ZERO !
ELSE !
FDP1P5 = DEXP(X) !
END IF !
END IF !
ELSE !
!
! Code for -1 <= x <= 2
!
IF ( X <= TWO ) THEN !
T = ( TWO * X - ONE ) / THREE !
FDP1P5 = CHEVAL ( NTERM2 , ARRFD2 , T ) !
ELSE !
!
! Code for x > 2
!
FDP1P5 = X * X * DSQRT(X) / GAM3P5 !
IF ( X <= XHIGH1 ) THEN !
XSQ = X * X !
T = ( FIFTY - XSQ ) / ( FORTY2 + XSQ ) !
CHV = CHEVAL ( NTERM3 , ARRFD3 , T ) !
FDP1P5 = FDP1P5 * ( ONE + CHV / XSQ ) !
END IF !
END IF !
END IF !
!
END FUNCTION FDP1P5
!
!=======================================================================
!
FUNCTION FDP2P5(XVALUE)
!
! DESCRIPTION:
!
! This function computes the Fermi-Dirac function of
! order 5/2, defined as
!
! Int{0 to inf} t**(5/2) / (1+exp(t-x)) dt
! FDP2P5(x) = -----------------------------------------
! Gamma(7/2)
!
! The function uses Chebyshev expansions which are given to
! 16 decimal places for x <= 2, but only 10 decimal places
! for x > 2.
!
!
! ERROR RETURNS:
!
! If XVALUE too large and positive, the function value
! will overflow. An error message is printed and the function
! returns the value 0.0.
!
!
! MACHINE-DEPENDENT CONSTANTS:
!
! NTERMS1 - INTEGER - The number of terms used from the array
! ARRFD1. The recommended value is such that
! ABS(ARRFD1(NTERMS1)) < EPS/10
! subject to 1 <= NTERMS1 <= 11.
!
! NTERMS2 - INTEGER - The number of terms used from the array
! ARRFD2. The recommended value is such that
! ABS(ARRFD2(NTERMS2)) < EPS/10
! subject to 1 <= NTERMS1 <= 21.
!
! NTERMS3 - INTEGER - The number of terms used from the array
! ARRFD3. The recommended value is such that
! ABS(ARRFD3(NTERMS3)) < EPS/10
! subject to 1 <= NTERMS3 <= 39.
!
! XMIN1 - REAL - The value of x below which
! FDP2P5(x) = exp(x)
! to machine precision. The recommended value
! is 3.5*LN(2) + LN(EPSNEG)
!
! XMIN2 - REAL - The value of x below which
! FDP2P5(x) = 0.0
! to machine precision. The recommended value
! is LN ( XMIN )
!
! XHIGH1 - REAL - The value of x above which
! FDP2P5(x) = x**(7/2)/GAMMA(9/2)
! to machine precision. The recommended value
! is pi * SQRT(35/(12*EPS))
!
! XHIGH2 - REAL - The value of x above which FDP2P5 would
! overflow. The reommended value is
! (11.6317*XMAX)**(2/7)
!
! For values of EPS, EPSNEG, and XMIN the user should refer to the
! paper by Cody in ACM. Trans. Math. Soft. Vol. 14 (1988) p303-311.
!
! This code is provided with single and REAL*8 values
! of the machine-dependent parameters, suitable for machines
! which satisfy the IEEE floating-point standard.
!
!
! AUTHOR:
! DR. ALLAN MACLEOD,
! DEPT. OF MATHEMATICS AND STATISTICS,
! UNIVERSITY OF PAISLEY,
! HIGH ST.,
! PAISLEY,
! SCOTLAND
! PA1 2BE
!
! (e-mail: macl-ms0@paisley.ac.uk )
!
!
! LATEST UPDATE:
! 21 NOVEMBER, 1996
!
!
! Last modified (DS) : 15 Jun 2020
!
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE
!
IMPLICIT NONE
!
INTEGER :: NTERM1,NTERM2,NTERM3
INTEGER :: LOGF
!
REAL (WP) :: FDP2P5
REAL (WP) :: ARRFD1(0:11),ARRFD2(0:21),ARRFD3(0:61)
REAL (WP) :: CHV,EXPX,FIFTY,FORTY2
REAL (WP) :: GAM4P5,T,TWOE
REAL (WP) :: X,XHIGH1,XHIGH2,XMIN1,XMIN2,XSQ,XVALUE
!
DATA ARRFD1/1.9694416685896693E0_WP, & !
-0.149691794643492E-1_WP, & !
0.3006955816627E-3_WP, & !
-0.89462485950E-5_WP, & !
0.3298072025E-6_WP, & !
-0.139239298E-7_WP, & !
0.6455885E-9_WP, & !
-0.320623E-10_WP, & !
0.16783E-11_WP, & !
-0.916E-13_WP, & !
0.52E-14_WP, & !
-0.3E-15_WP/ !
!
DATA ARRFD2( 0)/ 4.2642838398655301E0_WP/ !
DATA ARRFD2( 1)/ 2.3437426884912867E0_WP/ !
DATA ARRFD2( 2)/ 0.6727119780052076E0_WP/ !
DATA ARRFD2( 3)/ 0.1148826327965569E0_WP/ !
DATA ARRFD2( 4)/ 0.109363968046758E-1_WP/ !
DATA ARRFD2( 5)/ 0.2567173957015E-3_WP/ !
DATA ARRFD2( 6)/-0.505889983911E-4_WP/ !
DATA ARRFD2( 7)/-0.7376215774E-6_WP/ !
DATA ARRFD2( 8)/ 0.7352998758E-6_WP/ !
DATA ARRFD2( 9)/-0.166421736E-7_WP/ !
DATA ARRFD2(10)/-0.140920499E-7_WP/ !
DATA ARRFD2(11)/ 0.9949192E-9_WP/ !
DATA ARRFD2(12)/ 0.2991457E-9_WP/ !
DATA ARRFD2(13)/-0.401332E-10_WP/ !
DATA ARRFD2(14)/-0.63546E-11_WP/ !
DATA ARRFD2(15)/ 0.14793E-11_WP/ !
DATA ARRFD2(16)/ 0.1181E-12_WP/ !
DATA ARRFD2(17)/-0.524E-13_WP/ !
DATA ARRFD2(18)/-0.11E-14_WP/ !
DATA ARRFD2(19)/ 0.18E-14_WP/ !
DATA ARRFD2(20)/-0.1E-15_WP/ !
DATA ARRFD2(21)/-0.1E-15_WP/ !
!
DATA ARRFD3( 0)/30.2895676859802579E0_WP/ !
DATA ARRFD3( 1)/ 1.1678976642060562E0_WP/ !
DATA ARRFD3( 2)/ 0.6420591800821472E0_WP/ !
DATA ARRFD3( 3)/ 0.3461723868407417E0_WP/ !
DATA ARRFD3( 4)/ 0.1840816790781889E0_WP/ !
DATA ARRFD3( 5)/ 0.973092435354509E-1_WP/ !
DATA ARRFD3( 6)/ 0.513973292675393E-1_WP/ !
DATA ARRFD3( 7)/ 0.271709801041757E-1_WP/ !
DATA ARRFD3( 8)/ 0.143833271401165E-1_WP/ !
DATA ARRFD3( 9)/ 0.76264863952155E-2_WP/ !
DATA ARRFD3(10)/ 0.40503695767202E-2_WP/ !
DATA ARRFD3(11)/ 0.21543961464149E-2_WP/ !
DATA ARRFD3(12)/ 0.11475689901777E-2_WP/ !
DATA ARRFD3(13)/ 0.6120622369282E-3_WP/ !
DATA ARRFD3(14)/ 0.3268340337859E-3_WP/ !
DATA ARRFD3(15)/ 0.1747145522742E-3_WP/ !
DATA ARRFD3(16)/ 0.934878457860E-4_WP/ !
DATA ARRFD3(17)/ 0.500692212553E-4_WP/ !
DATA ARRFD3(18)/ 0.268373821846E-4_WP/ !
DATA ARRFD3(19)/ 0.143957191251E-4_WP/ !
DATA ARRFD3(20)/ 0.77272440700E-5_WP/ !
DATA ARRFD3(21)/ 0.41503820336E-5_WP/ !
DATA ARRFD3(22)/ 0.22305118261E-5_WP/ !
DATA ARRFD3(23)/ 0.11993697093E-5_WP/ !
DATA ARRFD3(24)/ 0.6452344369E-6_WP/ !
DATA ARRFD3(25)/ 0.3472822881E-6_WP/ !
DATA ARRFD3(26)/ 0.1869964215E-6_WP/ !
DATA ARRFD3(27)/ 0.1007300272E-6_WP/ !
DATA ARRFD3(28)/ 0.542807561E-7_WP/ !
DATA ARRFD3(29)/ 0.292607829E-7_WP/ !
DATA ARRFD3(30)/ 0.157785918E-7_WP/ !
DATA ARRFD3(31)/ 0.85110768E-8_WP/ !
DATA ARRFD3(32)/ 0.45922760E-8_WP/ !
DATA ARRFD3(33)/ 0.24785001E-8_WP/ !
DATA ARRFD3(34)/ 0.13380255E-8_WP/ !
DATA ARRFD3(35)/ 0.7225103E-9_WP/ !
DATA ARRFD3(36)/ 0.3902350E-9_WP/ !
DATA ARRFD3(37)/ 0.2108157E-9_WP/ !
DATA ARRFD3(38)/ 0.1139122E-9_WP/ !
DATA ARRFD3(39)/ 0.615638E-10_WP/ !
DATA ARRFD3(40)/ 0.332781E-10_WP/ !
DATA ARRFD3(41)/ 0.179919E-10_WP/ !
DATA ARRFD3(42)/ 0.97288E-11_WP/ !
DATA ARRFD3(43)/ 0.52617E-11_WP/ !
DATA ARRFD3(44)/ 0.28461E-11_WP/ !
DATA ARRFD3(45)/ 0.15397E-11_WP/ !
DATA ARRFD3(46)/ 0.8331E-12_WP/ !
DATA ARRFD3(47)/ 0.4508E-12_WP/ !
DATA ARRFD3(48)/ 0.2440E-12_WP/ !
DATA ARRFD3(49)/ 0.1321E-12_WP/ !
DATA ARRFD3(50)/ 0.715E-13_WP/ !
DATA ARRFD3(51)/ 0.387E-13_WP/ !
DATA ARRFD3(52)/ 0.210E-13_WP/ !
DATA ARRFD3(53)/ 0.114E-13_WP/ !
DATA ARRFD3(54)/ 0.61E-14_WP/ !
DATA ARRFD3(55)/ 0.33E-14_WP/ !
DATA ARRFD3(56)/ 0.18E-14_WP/ !
DATA ARRFD3(57)/ 0.11E-14_WP/ !
DATA ARRFD3(58)/ 0.5E-15_WP/ !
DATA ARRFD3(59)/ 0.3E-15_WP/ !
DATA ARRFD3(60)/ 0.2E-15_WP/ !
DATA ARRFD3(61)/ 0.1E-15_WP/ !
!
DATA FORTY2,FIFTY / 42.0E0_WP , 50.0E0_WP/ !
DATA GAM4P5 /0.1163172839656745E2_WP/ !
DATA TWOE /5.4365636569180905E0_WP/ !
!
! Machine-dependent constants (suitable for IEEE machines)
!
DATA NTERM1,NTERM2,NTERM3 /11,21,61/ !
DATA XMIN1,XMIN2 /-34.3107854E0_WP,-708.396418E0_WP/!
DATA XHIGH1,XHIGH2 /254599860.5E0_WP,2.383665E88_WP/ !
!
LOGF=6 !
!
! Start calculation
!
X=XVALUE !
!
! Test for error condition
!
IF ( X > XHIGH2 ) THEN !
WRITE(LOGF,*) '** Error ** - X too large for FDP2P5' !
STOP !
END IF !
!
! Code for x < -1
!
IF ( X < -ONE ) THEN !
IF ( X > XMIN1 ) THEN !
EXPX = DEXP(X) !
T = TWOE * EXPX - ONE !
FDP2P5 = EXPX * CHEVAL ( NTERM1 , ARRFD1 , T ) !
ELSE !
IF ( X < XMIN2 ) THEN !
FDP2P5 = ZERO !
ELSE !
FDP2P5 = DEXP(X) !
END IF !
END IF !
ELSE !
!
! Code for -1 <= x <= 2
!
IF ( X <= TWO ) THEN !
T = ( TWO * X - ONE ) / THREE !
FDP2P5 = CHEVAL ( NTERM2 , ARRFD2 , T ) !
ELSE !
!
! Code for x > 2
!
FDP2P5 = X * X * X * DSQRT(X) / GAM4P5 !
IF ( X <= XHIGH1 ) THEN !
XSQ = X * X !
T = ( FIFTY - XSQ ) / ( FORTY2 + XSQ ) !
CHV = CHEVAL ( NTERM3 , ARRFD3 , T ) !
FDP2P5 = FDP2P5 * ( ONE + CHV / XSQ ) !
END IF !
END IF !
END IF !
!
END FUNCTION FDP2P5
!
!=======================================================================
!
FUNCTION CHEVAL(N,A,T)
!
! DESCRIPTION:
!
! This function evaluates a Chebyshev series, using the
! Clenshaw method with Reinsch modification, as analysed
! in the paper by Oliver.
!
!
! INPUT PARAMETERS
!
! N - INTEGER - The no. of terms in the sequence
!
! A - REAL ARRAY, dimension 0 to N - The coefficients of
! the Chebyshev series
!
! T - REAL - The value at which the series is to be
! evaluated
!
!
! REFERENCES
!
! "An error analysis of the modified Clenshaw method for
! evaluating Chebyshev and Fourier series" J. Oliver,
! J.I.M.A., vol. 20, 1977, pp379-391
!
!
! MACHINE-DEPENDENT CONSTANTS: NONE
!
!
! INTRINSIC FUNCTIONS USED;
!
! ABS
!
!
! AUTHOR: Dr. Allan J. MacLeod,
! Dept. of Mathematics and Statistics,
! University of Paisley ,
! High St.,
! PAISLEY,
! SCOTLAND
! ( e-mail: macl-ms0@paisley.ac.uk )
!
!
! LATEST MODIFICATION:
! 21 September , 1995
!
!
! Last modified (DS) : 15 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,TWO,HALF
!
IMPLICIT NONE
!
INTEGER :: I,N
!
REAL (WP) :: CHEVAL
REAL (WP) :: A(0:N),D1,D2,T,TEST,TT,U0,U1,U2
!
DATA TEST / 0.6E0_WP/ !
!
U1 = ZERO !
!
! If ABS ( T ) < 0.6 use the standard Clenshaw method
!
IF ( DABS( T ) < TEST ) THEN !
U0 = ZERO !
TT = T + T !
DO I = N , 0 , -1 !
U2 = U1 !
U1 = U0 !
U0 = TT * U1 + A( I ) - U2 !
END DO !
CHEVAL = ( U0 - U2 ) / TWO !
ELSE !
!
! If ABS ( T ) > = 0.6 use the Reinsch modification
!
D1 = ZERO !
!
! T > = 0.6 code
!
IF ( T > ZERO ) THEN !
TT = ( T - HALF ) - HALF !
TT = TT + TT !
DO I = N , 0 , -1 !
D2 = D1 !
U2 = U1 !
D1 = TT * U2 + A( I ) + D2 !
U1 = D1 + U2 !
END DO !
CHEVAL = ( D1 + D2 ) / TWO !
ELSE
!
! T < = -0.6 code
!
TT = ( T + HALF ) + HALF !
TT = TT + TT !
DO I = N , 0 , -1 !
D2 = D1 !
U2 = U1 !
D1 = TT * U2 + A( I ) - D2 !
U1 = D1 - U2 !
END DO !
CHEVAL = ( D1 - D2 ) / TWO !
END IF !
END IF !
!
END FUNCTION CHEVAL
!
!=======================================================================
!
! 8) Logarithm of Gamma function real argument
! FUNCTION DLGAMA(X)
!
!=======================================================================
!
FUNCTION DLGAMA(X)
!
!***********************************************************************
!* *
!* Fortran code written for inclusion in ibm research report RC20525, *
!* 'Fortran routines for use with the method of l-moments, version 3' *
!* *
!* J. R. M. HOSKING *
!* IBM Research Division *
!* T. J. Watson research center *
!* Yorktown Heights *
!* New York 10598, U.S.A. *
!* *
!* Version 3 August 1996 *
!* *
!***********************************************************************
!
! Logarithm of Gamma function
!
! Based on Algorithm ACM291, Commun. Assoc. Comput. Mach. (1966)
!
!
! Last modified (DS) : 15 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF
!
IMPLICIT NONE
!
REAL (WP) :: X,DLGAMA
REAL (WP) :: SMALL,CRIT,BIG,TOOBIG
REAL (WP) :: C0,C1,C2,C3,C4,C5,C6,C7
REAL (WP) :: S1,S2
REAL (WP) :: XX,Y,Z,SUM1,SUM2
!
DATA SMALL,CRIT / 1.0E-7_WP,13.0E+00_WP / !
DATA BIG,TOOBIG / 1.0E+9_WP, 2.0E+36_WP / !
!
! C0 is 0.5*LOG(2*PI)
!
DATA C0 /0.918938533204672742E0_WP/ !
!
! C1...C7 are the coefficientsts of the asymptotic expansion of DLGAMA
!
DATA C1,C2,C3,C4,C5,C6,C7/ & !
0.833333333333333333E-1_WP, & !
-0.277777777777777778E-2_WP, 0.793650793650793651E-3_WP, & !
-0.595238095238095238E-3_WP, 0.841750841750841751E-3_WP, & !
-0.191752691752691753E-2_WP, 0.641025641025641026E-2_WP/ !
!
! S1 is -(Euler's constant), S2 is PI**2/12
!
DATA S1 /-0.577215664901532861E0_WP/ !
DATA S2 / 0.822467033424113218E0_WP/ !
!
DLGAMA=ZERO !
!
IF(X <= ZERO) GO TO 1000 !
IF(X > TOOBIG) GO TO 1000 !
!
! Use small-x approximation if X is near 0, 1 or 2
!
IF(DABS(X-TWO) > SMALL) GO TO 10 !
!
DLGAMA=DLOG(X-ONE) !
XX=X-TWO !
GO TO 20 !
!
10 IF(DABS(X-ONE) > SMALL) GO TO 30 !
!
XX=X-ONE !
!
20 DLGAMA=DLGAMA+XX*(S1+XX*S2) !
RETURN !
!
30 IF(X > SMALL) GO TO 40 !
!
DLGAMA=-DLOG(X)+S1*X !
RETURN !
!
! Reduce to DLGAMA(X+N) where X+N >= CRIT
!
40 SUM1=ZERO !
Y=X !
!
IF(Y >= CRIT) GO TO 60 !
!
Z=ONE !
!
50 Z=Z*Y !
Y=Y+ONE !
!
IF(Y < CRIT) GO TO 50 !
!
SUM1=SUM1-DLOG(Z) !
!
! Use asymptotic expansion if Y >= CRIT
!
60 SUM1=SUM1+(Y-HALF)*DLOG(Y)-Y+C0 !
SUM2=ZERO !
!
IF(Y >= BIG) GO TO 70 !
!
Z=ONE/(Y*Y) !
SUM2=((((((C7*Z+C6)*Z+C5)*Z+C4)*Z+C3)*Z+C2)*Z+C1)/Y !
!
70 DLGAMA=SUM1+SUM2 !
RETURN !
!
1000 RETURN !
!
END FUNCTION DLGAMA
!
! 9) Incomplete gamma functions:
!
!
!=======================================================================
!
FUNCTION GAMMP(A,X)
!
! This function returns the incomplete Gamma function
!
! P(a,x) = gamma(a,x) / Gamma(a)
!
! where gamma(a,x) is the lower incomplete gamma function
!
! This is a REAL*8 version of the Numerical Recipes code
!
!
! Last modified (DS) : 15 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE
!
IMPLICIT NONE
!
REAL (WP) :: A,GAMMP,X
REAL (WP) :: GAMMCF,GAMSER,GLN
!
INTEGER :: LOGF
!
LOGF=6 !
!
! Uses GCF,GSER
!
IF(X < ZERO .OR. A <= ZERO) THEN !
WRITE(LOGF,*) 'Bad arguments in GAMMP' !
STOP !
END IF !
!
IF(X < A+ONE) THEN !
CALL GSER(GAMSER,A,X,GLN) !
GAMMP=GAMSER !
ELSE !
CALL GCF(GAMMCF,A,X,GLN) !
GAMMP=ONE-GAMMCF !
END IF !
!
END FUNCTION GAMMP
!
!=======================================================================
!
FUNCTION GAMMQ(A,X)
!
! This function returns the incomplete Gamma function
!
! Q(a,x) = 1 - P(a,x) = Gamma(a,x) / Gamma(a)
!
! where Gamma(a,x) is the upper incomplete gamma function
!
! This is a REAL*8 version of the Numerical Recipes code
!
!
! Last modified (DS) : 15 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE
!
IMPLICIT NONE
!
REAL (WP) :: A,GAMMQ,X
REAL (WP) :: GAMMCF,GAMSER,GLN
!
INTEGER :: LOGF
!
LOGF=6 !
!
IF(X < ZERO .OR. A <= ZERO) THEN !
WRITE(LOGF,*) 'Bad arguments in GAMMQ' !
END IF !
!
IF(X < A+ONE) THEN !
CALL GSER(GAMSER,A,X,GLN) !
GAMMQ=ONE-GAMSER !
ELSE !
CALL GCF(GAMMCF,A,X,GLN) !
GAMMQ=GAMMCF !
END IF !
!
END FUNCTION GAMMQ
!
!=======================================================================
!
SUBROUTINE GSER(GAMSER,A,X,GLN)
!
! Last modified (DS) : 15 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE
!
IMPLICIT NONE
!
INTEGER :: ITMAX
REAL (WP) :: EPS
PARAMETER (ITMAX=100,EPS=3.E-7_WP) !
!
REAL (WP) :: A,GAMSER,GLN,X
REAL (WP) :: AP,DEL,SUM
!
INTEGER :: N,LOGF
!
LOGF=6 !
!
GLN=GAMMLN(A) !
!
IF(X <= ZERO) THEN !
IF(X < ZERO) THEN !
WRITE(LOGF,*) 'X < 0 in GSER' !
STOP !
END IF !
ENDIF !
!
AP=A !
SUM=ONE/A !
DEL=SUM !
DO N=1,ITMAX !
AP=AP+ONE !
DEL=DEL*X/AP !
SUM=SUM+DEL !
IF(DABS(DEL) < DABS(SUM)*EPS) GO TO 1 !
END DO !
!
WRITE(LOGF,*) 'A too large, ITMAX too small in GSER' !
STOP !
!
1 GAMSER=SUM*DEXP(-X+A*DLOG(X)-GLN) !
!
END SUBROUTINE GSER
!
!=======================================================================
!
SUBROUTINE GCF(GAMMCF,A,X,GLN)
!
! Last modified (DS) : 15 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO
!
IMPLICIT NONE
!
INTEGER :: ITMAX
REAL (WP) :: EPS,FPMIN
PARAMETER (ITMAX=100,EPS=3.E-7_WP,FPMIN=1.E-30_WP) !
!
REAL (WP) :: A,GAMMCF,GLN,X,TWP
REAL (WP) :: AN,B,C,D,DEL,H
!
INTEGER :: I,LOGF
!
LOGF=6 !
!
GLN=GAMMLN(A) !
B=X+ONE-A !
C=ONE/FPMIN !
D=ONE/B !
H=D !
!
DO I=1,ITMAX !
AN=-I*(I-A) !
B=B+TWP !
D=AN*D+B !
IF(DABS(D) < FPMIN) D=FPMIN !
C=B+AN/C !
IF(DABS(C) < FPMIN) C=FPMIN !
D=ONE/D !
DEL=D*C !
H=H*DEL !
IF(DABS(DEL-ONE) < EPS) GO TO 1 !
END DO !
!
WRITE(LOGF,*) 'A too large, ITMAX too small in GCF' !
STOP !
!
1 GAMMCF=DEXP(-X+A*DLOG(X)-GLN)*H !
!
END SUBROUTINE GCF
!
!=======================================================================
!
FUNCTION GAMMLN(XX)
!
! Last modified (DS) : 15 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ONE,HALF
!
IMPLICIT NONE
!
REAL (WP) :: GAMMLN,XX
REAL (WP) :: SER,STP,TMP,X,Y,COF(6)
!
INTEGER :: J
!
DATA COF /76.18009172947146E0_WP,-86.50532032941677E0_WP, & !
24.01409824083091E0_WP,-1.231739572450155E0_WP, & !
0.1208650973866179E-2_WP,-0.5395239384953E-5_WP/ !
DATA STP /2.5066282746310005E0_WP/ !
!
X=XX !
Y=X !
TMP=X+5.5E0_WP !
TMP=(X+HALF)*DLOG(TMP)-TMP !
SER=1.000000000190015E0_WP !
!
DO J=1,6 !
Y=Y+ONE !
SER=SER+COF(J)/Y !
END DO !
!
GAMMLN=TMP+DLOG(STP*SER/X) !
!
END FUNCTION GAMMLN
!
!=======================================================================
!
! 10) Polygamma function Psi^(k)(x)
! FUNCTION DPSIPG(X,K)
!
!======================================================================
!
FUNCTION DPSIPG(X,K)
!
! This is the CERNLIB function computing the Polygamma function
! Psi^(k)(x) for REAL arguments
!
!
!
! Input parameters:
!
! * X : argument x of Psi^(k)(x)
! * K : order k of Psi^(k)(x)
!
! Warning: K is limited to 0, 1, 2, 3, 4, 5 or 6
! X cannot be a negative or null integer
!
!
! Output value:
!
! * DPSIPG
!
!
! Originally written by K. S. Kölbig (1992)
!
! Changes history:
!
! $Id: special_functions.f90,v 1.2 2004/09/21 18:50:24 salam Exp $
!
! $Log: special_functions.f90,v $
! Revision 1.2 2004/09/21 18:50:24 salam
! Various speed improvements in evaluation of grid quantities;
! added WGPLG to special functions -- no longer need CERNLIB linkage
!
! Revision 1.1 2001/06/27 13:40:17 gsalam
! Imported files from release-H1-1-0-7 (soon to become 1-0-8) of the disresum package
!
! Revision 1.4 2001/04/20 14:39:03 salam
! removed Id and Log entries from special functions
!
! Revision 1.3 2001/04/20 14:07:29 salam
! added new documentation figure
!
! Revision 1.2 2001/04/20 09:48:56 salam
! Added some Id keywords to files
!
! Revision 1.1 2001/04/19 15:09:16 salam
! imported all the basic files I hope!
!
! Revision 1.1.1.1 1996/04/01 15:02:59 mclareni
! Mathlib gen
!
!
! Last modified: D. Sébilleau 15 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,TEN,HALF
USE PI_ETC, ONLY : PI
!
IMPLICIT NONE
!
REAL (WP) :: X,DPSIPG
REAL (WP) :: B(0:20,6),C(7,6)
REAL (WP) :: P1(0:7),Q1(0:7),P2(0:4),Q2(0:4)
REAL (WP) :: SGN(6),SGF(0:6),SGH(6)
REAL (WP) :: DELTA,Z1,HF
REAL (WP) :: C1,C2,C3,C4,C5,C6
REAL (WP) :: A,V,H,S,AP,AQ,R
REAL (WP) :: ALFA,B0,B1,B2,P
REAL (WP) :: X0
!
INTEGER :: K,I,J,NB(6),IX,K1
!
CHARACTER (LEN=80) :: ERRTXT
!
PARAMETER (DELTA = 1.0E-13_WP) !
PARAMETER (Z1 = ONE, HF = Z1/TWO) !
PARAMETER (C1 = -PI**2, C2 = TWO*PI**3, C3 = TWO*PI**4) !
PARAMETER (C4 = -8.0E0_WP*PI**5, C5 = -8.0E0_WP*PI**6, & !
C6 = 16.0E0_WP*PI**7) !
!
DATA NB /16,17,17,18,19,20/ !
DATA SGN /-1.0E0_WP,1.0E0_WP,-1.0E0_WP,1.0E0_WP, & !
-1.0E0_WP,1.0E0_WP/ !
DATA SGF /1.0E0_WP,-1.0E0_WP,2.0E0_WP,-6.0E0_WP,24.0E0_WP, & !
-120.0E0_WP,720.0E0_WP/ !
DATA SGH /-0.5E0_WP,1.0E0_WP,-3.0E0_WP,12.0E0_WP,-60.0E0_WP,& !
360.0E0_WP / !
DATA X0 /1.46163214496836234E0_WP/ !
!
DATA (P1(J),Q1(J),J=0,7) & !
/ 1.35249996677263464E+4_WP, 6.93891117537634444E-7_WP, & !
4.52856016995472897E+4_WP, 1.97685742630467364E+4_WP, & !
4.51351684697366626E+4_WP, 4.12551608353538323E+4_WP, & !
1.85290118185826102E+4_WP, 2.93902871199326819E+4_WP, & !
3.32915251494069355E+3_WP, 9.08196660748551703E+3_WP, & !
2.40680324743572018E+2_WP, 1.24474777856708560E+3_WP, & !
5.15778920001390847E+0_WP, 6.74291295163785938E+1_WP, & !
6.22835069189847458E-3_WP, 1.0E0_WP/ !
!
DATA (P2(J),Q2(J),J=0,4) & !
/-2.72817575131529678E-15_WP,7.77788548522961604E+0_WP, & !
-6.48157123766196510E-1_WP, 5.46117738103215070E+1_WP, & !
-4.48616543918019358E+0_WP, 8.92920700481861370E+1_WP, & !
-7.01677227766758664E+0_WP, 3.22703493791143361E+1_WP, & !
-2.12940445131010517E+0_WP, 1.0E0_WP/ !
!
DATA B( 0,1) / 0.334838697910949386E0_WP/ !
DATA B( 1,1) /-0.055187482048730095E0_WP/ !
DATA B( 2,1) / 0.004510190736011502E0_WP/ !
DATA B( 3,1) /-0.000365705888303721E0_WP/ !
DATA B( 4,1) / 0.000029434627468223E0_WP/ !
DATA B( 5,1) /-0.000002352776815151E0_WP/ !
DATA B( 6,1) / 0.000000186853176633E0_WP/ !
DATA B( 7,1) /-0.000000014750720184E0_WP/ !
DATA B( 8,1) / 0.000000001157993337E0_WP/ !
DATA B( 9,1) /-0.000000000090439179E0_WP/ !
DATA B(10,1) / 0.000000000007029627E0_WP/ !
DATA B(11,1) /-0.000000000000543989E0_WP/ !
DATA B(12,1) / 0.000000000000041925E0_WP/ !
DATA B(13,1) /-0.000000000000003219E0_WP/ !
DATA B(14,1) / 0.000000000000000246E0_WP/ !
DATA B(15,1) /-0.000000000000000019E0_WP/ !
DATA B(16,1) / 0.000000000000000001E0_WP/ !
!
DATA B( 0,2) /-0.112592935345473830E0_WP/ !
DATA B( 1,2) / 0.036557001742820941E0_WP/ !
DATA B( 2,2) /-0.004435942496027282E0_WP/ !
DATA B( 3,2) / 0.000475475854728926E0_WP/ !
DATA B( 4,2) /-0.000047471836382632E0_WP/ !
DATA B( 5,2) / 0.000004521815237353E0_WP/ !
DATA B( 6,2) /-0.000000416300079620E0_WP/ !
DATA B( 7,2) / 0.000000037338998165E0_WP/ !
DATA B( 8,2) /-0.000000003279914474E0_WP/ !
DATA B( 9,2) / 0.000000000283211377E0_WP/ !
DATA B(10,2) /-0.000000000024104028E0_WP/ !
DATA B(11,2) / 0.000000000002026297E0_WP/ !
DATA B(12,2) /-0.000000000000168524E0_WP/ !
DATA B(13,2) / 0.000000000000013885E0_WP/ !
DATA B(14,2) /-0.000000000000001135E0_WP/ !
DATA B(15,2) / 0.000000000000000092E0_WP/ !
DATA B(16,2) /-0.000000000000000007E0_WP/ !
DATA B(17,2) / 0.000000000000000001E0_WP/ !
!
DATA B( 0,3) / 0.076012604655110384E0_WP/ !
DATA B( 1,3) /-0.036257186481828739E0_WP/ !
DATA B( 2,3) / 0.005797202338937002E0_WP/ !
DATA B( 3,3) /-0.000769646513610481E0_WP/ !
DATA B( 4,3) / 0.000091492082189884E0_WP/ !
DATA B( 5,3) /-0.000010097131488364E0_WP/ !
DATA B( 6,3) / 0.000001055777442831E0_WP/ !
DATA B( 7,3) /-0.000000105929577481E0_WP/ !
DATA B( 8,3) / 0.000000010285494201E0_WP/ !
DATA B( 9,3) /-0.000000000972314310E0_WP/ !
DATA B(10,3) / 0.000000000089884635E0_WP/ !
DATA B(11,3) /-0.000000000008153171E0_WP/ !
DATA B(12,3) / 0.000000000000727572E0_WP/ !
DATA B(13,3) /-0.000000000000064010E0_WP/ !
DATA B(14,3) / 0.000000000000005562E0_WP/ !
DATA B(15,3) /-0.000000000000000478E0_WP/ !
DATA B(16,3) / 0.000000000000000041E0_WP/ !
DATA B(17,3) /-0.000000000000000003E0_WP/ !
!
DATA B( 0,4) /-0.077234724056994793E0_WP/ !
DATA B( 1,4) / 0.047867163451599467E0_WP/ !
DATA B( 2,4) /-0.009440702186674632E0_WP/ !
DATA B( 3,4) / 0.001489544740103448E0_WP/ !
DATA B( 4,4) /-0.000204944023348860E0_WP/ !
DATA B( 5,4) / 0.000025671425065297E0_WP/ !
DATA B( 6,4) /-0.000003001393581584E0_WP/ !
DATA B( 7,4) / 0.000000332766437356E0_WP/ !
DATA B( 8,4) /-0.000000035365412111E0_WP/ !
DATA B( 9,4) / 0.000000003630622927E0_WP/ !
DATA B(10,4) /-0.000000000362096951E0_WP/ !
DATA B(11,4) / 0.000000000035237509E0_WP/ !
DATA B(12,4) /-0.000000000003357440E0_WP/ !
DATA B(13,4) / 0.000000000000314068E0_WP/ !
DATA B(14,4) /-0.000000000000028908E0_WP/ !
DATA B(15,4) / 0.000000000000002623E0_WP/ !
DATA B(16,4) /-0.000000000000000235E0_WP/ !
DATA B(17,4) / 0.000000000000000021E0_WP/ !
DATA B(18,4) /-0.000000000000000002E0_WP/ !
!
DATA B( 0,5) / 0.104933034459278632E0_WP/ !
DATA B( 1,5) /-0.078877901652793557E0_WP/ !
DATA B( 2,5) / 0.018397415112159397E0_WP/ !
DATA B( 3,5) /-0.003352284159396504E0_WP/ !
DATA B( 4,5) / 0.000522878230918016E0_WP/ !
DATA B( 5,5) /-0.000073179785814740E0_WP/ !
DATA B( 6,5) / 0.000009449729612085E0_WP/ !
DATA B( 7,5) /-0.000001146339856723E0_WP/ !
DATA B( 8,5) / 0.000000132269366108E0_WP/ !
DATA B( 9,5) /-0.000000014646669180E0_WP/ !
DATA B(10,5) / 0.000000001566940742E0_WP/ !
DATA B(11,5) /-0.000000000162791157E0_WP/ !
DATA B(12,5) / 0.000000000016490345E0_WP/ !
DATA B(13,5) /-0.000000000001634028E0_WP/ !
DATA B(14,5) / 0.000000000000158807E0_WP/ !
DATA B(15,5) /-0.000000000000015171E0_WP/ !
DATA B(16,5) / 0.000000000000001427E0_WP/ !
DATA B(17,5) /-0.000000000000000132E0_WP/ !
DATA B(18,5) / 0.000000000000000012E0_WP/ !
DATA B(19,5) /-0.000000000000000001E0_WP/ !
!
DATA B( 0,6) /-0.178617622142502753E0_WP/ !
DATA B( 1,6) / 0.155776462200520579E0_WP/ !
DATA B( 2,6) /-0.041723637673831277E0_WP/ !
DATA B( 3,6) / 0.008597141303245400E0_WP/ !
DATA B( 4,6) /-0.001496227761073229E0_WP/ !
DATA B( 5,6) / 0.000231089608557137E0_WP/ !
DATA B( 6,6) /-0.000032632044778436E0_WP/ !
DATA B( 7,6) / 0.000004296097867090E0_WP/ !
DATA B( 8,6) /-0.000000534528790204E0_WP/ !
DATA B( 9,6) / 0.000000063478151644E0_WP/ !
DATA B(10,6) /-0.000000007248699714E0_WP/ !
DATA B(11,6) / 0.000000000800521979E0_WP/ !
DATA B(12,6) /-0.000000000085888793E0_WP/ !
DATA B(13,6) / 0.000000000008985442E0_WP/ !
DATA B(14,6) /-0.000000000000919356E0_WP/ !
DATA B(15,6) / 0.000000000000092225E0_WP/ !
DATA B(16,6) /-0.000000000000009090E0_WP/ !
DATA B(17,6) / 0.000000000000000882E0_WP/ !
DATA B(18,6) /-0.000000000000000084E0_WP/ !
DATA B(19,6) / 0.000000000000000008E0_WP/ !
DATA B(20,6) /-0.000000000000000001E0_WP/ !
!
DATA C(1,1) / 1.66666666666666667E-1_WP/ !
DATA C(2,1) /-3.33333333333333333E-2_WP/ !
DATA C(3,1) / 2.38095238095238095E-2_WP/ !
DATA C(4,1) /-3.33333333333333333E-2_WP/ !
DATA C(5,1) / 7.57575757575757576E-2_WP/ !
DATA C(6,1) /-2.53113553113553114E-1_WP/ !
DATA C(7,1) / 1.16666666666666667E0_WP/ !
!
DATA C(1,2) / 5.00000000000000000E-1_WP/ !
DATA C(2,2) /-1.66666666666666667E-1_WP/ !
DATA C(3,2) / 1.66666666666666667E-1_WP/ !
DATA C(4,2) /-3.00000000000000000E-1_WP/ !
DATA C(5,2) / 8.33333333333333333E-1_WP/ !
DATA C(6,2) /-3.29047619047619048E0_WP/ !
DATA C(7,2) / 1.75000000000000000E1_WP/ !
!
DATA C(1,3) / 2.00000000000000000E0_WP/ !
DATA C(2,3) /-1.00000000000000000E0_WP/ !
DATA C(3,3) / 1.33333333333333333E0_WP/ !
DATA C(4,3) /-3.00000000000000000E0_WP/ !
DATA C(5,3) / 1.00000000000000000E+1_WP/ !
DATA C(6,3) /-4.60666666666666667E+1_WP/ !
DATA C(7,3) / 2.80000000000000000E+2_WP/ !
!
DATA (C(J,4),J=1,7) / 10.0E0_WP, -7.0E0_WP, 12.0E0_WP,& !
-33.0E0_WP, 130.0E0_WP, -691.0E0_WP,& !
4760.0E0_WP/ !
DATA (C(J,5),J=1,7) / 60.0E0_WP, -56.0E0_WP, 120.0E0_WP,& !
-396.0E0_WP, 1820.0E0_WP, -11056.0E0_WP,& !
85680.0E0_WP/ !
DATA (C(J,6),J=1,7) /420.0E0_WP, -504.0E0_WP, 1320.0E0_WP,& !
-5148.0E0_WP,27300.0E0_WP,-187952.0E0_WP,& !
1627920.0E0_WP/ !
!
A=DABS(X) !
V=A !
IX=INT(X-DELTA) !
!
IF(K < 0 .OR. K > 6) THEN !
!
H=ZERO !
WRITE(ERRTXT,101) K !
CALL MTLPRT('DPSIPG','C316.1',ERRTXT) !
!
ELSE IF(ABS(IX-X) <= DELTA) THEN !
!
H=ZERO !
WRITE(ERRTXT,102) X !
CALL MTLPRT('DPSIPG','C316.2',ERRTXT) !
!
ELSE IF(K == 0) THEN !
!
IF(A <= THREE) THEN !
S=ZERO !
IF(A < HF) THEN !
S=ONE/V !
V=V+ONE !
END IF !
AP=P1(7) !
AQ=Q1(7) !
DO I = 6,0,-1
AP=P1(I)+V*AP !
AQ=Q1(I)+V*AQ !
END DO !
H=(V-X0)*AP/AQ-S !
ELSE !
R=ONE/V**2 !
AP=P2(4) !
AQ=Q2(4) !
DO I = 3,0,-1 !
AP=P2(I)+R*AP !
AQ=Q2(I)+R*AQ !
END DO !
H=DLOG(V)-HF/V+AP/AQ !
END IF !
IF(X < ZERO) H=H+ONE/A+PI/DTAN(PI*A) !
!
ELSE !
!
K1=K+1 !
IF(A <= TEN) THEN !
IF(A < THREE) THEN !
S=-ONE/V**K1 !
DO J = 1,2-INT(A) !
V=V+ONE !
S=S-ONE/V**K1 !
END DO !
V=V+ONE !
ELSE IF(A .LE. FOUR) THEN !
S=ZERO !
ELSE !
V=V-ONE !
S=ONE/V**K1 !
DO J = 1,INT(A)-4 !
V=V-ONE !
S=S+ONE/V**K1 !
END DO !
END IF !
H=TWO*V-7.0E0_WP !
ALFA=H+H !
B1=ZERO !
B2=ZERO !
DO J = NB(K),0,-1 !
B0=B(J,K)+ALFA*B1-B2 !
B2=B1 !
B1=B0 !
END DO !
H=B0-H*B2+SGF(K)*S !
ELSE !
S=ZERO !
IF(A < 15.0E0_WP) THEN !
S=ONE/V**K1 !
DO J = 1,14-INT(A) !
V=V+ONE !
S=S+ONE/V**K1 !
END DO !
V=V+ONE !
END IF !
R=ONE/V**2 !
P=R*C(7,K) !
DO J = 6,1,-1 !
P=R*(C(J,K)+P) !
END DO !
H=((SGF(K-1)-SGN(K)*P)*V-SGH(K))/V**K1-SGF(K)*S !
END IF !
IF(X < ZERO) THEN !
P=PI*A !
IF(K == 1) THEN !
V=C1/DSIN(P)**2 !
ELSE IF(K == 2) THEN !
V=C2*DCOS(P)/DSIN(P)**3 !
ELSE IF(K == 3) THEN !
S=DSIN(P)**2 !
V=C3*(TWO*S-THREE)/S**2 !
ELSE IF(K == 4) THEN !
S=DSIN(P) !
V=C4*DCOS(P)*(S**2-THREE)/S**5 !
ELSE IF(K == 5) THEN !
S=DSIN(P)**2 !
V=C5*(15.0E0_WP-15.0E0_WP*S+TWO*S**2)/S**3 !
ELSE IF(K == 6) THEN !
S=DSIN(P) !
V=C6*DCOS(P)*(45.0E0_WP-30.0E0_WP*S**2+TWO*S**4)/S**7 !
END IF !
H=SGN(K)*(H+V+SGF(K)/A**K1) !
END IF !
!
END IF !
!
DPSIPG=H !
!
! Formats:
!
101 FORMAT('K = ',I5,' (< 0 OR > 6)')
102 FORMAT('Argument equals non-positive integer =',1P,E15.6)
!
END FUNCTION DPSIPG
!
!======================================================================
!
SUBROUTINE MTLPRT(NAME,ERC,TEXT)
!
CHARACTER (LEN=*) :: NAME,ERC,TEXT
!
WRITE( *,100) ERC(1:4),NAME,ERC,TRIM(TEXT)
!
STOP
!
100 FORMAT(7X,'***** CERN ',A,1X,A,' ERROR ',A,': ',A)
!
END SUBROUTINE MTLPRT
!
!=======================================================================
!
! 11) Carlson's elliptic integrals:
!
!=======================================================================
!
FUNCTION RF(X,Y,Z)
!
! This function computes Carlson's elliptic integral of the first kind,
! RF(Z,Y,Z).
!
! Z, Y and Z must be non-negative, and at most one can be zero.
!
! --> TINY must be at least 5 times the machine underflow limit
! --> BIG at most one fifth the machine overflow limit
!
! Taken from "Numerical Recipes"
!
! REAL*8 version
!
!
! Last modified: D. Sébilleau 15 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,THREE,THIRD,FOURTH
!
IMPLICIT NONE
!
REAL (WP) :: ERRTOL,TINY,BIG,C1,C2,C3,C4
PARAMETER (ERRTOL=.08E0_WP,TINY=1.5E-38_WP,BIG=3.E37_WP) !
PARAMETER (C1=ONE/24.0E0_WP,C2=.10E0_WP) !
PARAMETER (C3=THREE/44.0E0_WP,C4=ONE/14.0E0_WP) !
!
INTEGER :: LOGF
!
REAL (WP) :: RF,X,Y,Z
REAL (WP) :: ALAMB,AVE,DELX,DELY,DELZ,E2,E3
REAL (WP) :: SQRTX,SQRTY,SQRTZ,XT,YT,ZT
!
LOGF=6 !
!
IF( MIN(X,Y,Z) < ZERO .OR. MIN(X+Y,X+Z,Y+Z) < TINY & !
.OR. MAX(X,Y,Z) > BIG ) THEN !
WRITE(LOGF,*) 'Invalid arguments in RF' !
STOP !
END IF !
!
XT=X !
YT=Y !
ZT=Z !
!
1 CONTINUE !
!
SQRTX=DSQRT(XT) !
SQRTY=DSQRT(YT) !
SQRTZ=DSQRT(ZT) !
ALAMB=SQRTX*(SQRTY+SQRTZ)+SQRTY*SQRTZ !
XT=FOURTH*(XT+ALAMB) !
YT=FOURTH*(YT+ALAMB) !
ZT=FOURTH*(ZT+ALAMB) !
AVE=THIRD*(XT+YT+ZT) !
DELX=(AVE-XT)/AVE !
DELY=(AVE-YT)/AVE !
DELZ=(AVE-ZT)/AVE !
!
IF(MAX(DABS(DELX),DABS(DELY),DABS(DELZ)) > ERRTOL) GO TO 1 !
!
E2=DELX*DELY-DELZ**2 !
E3=DELX*DELY*DELZ !
RF=(ONE+(C1*E2-C2-C3*E3)*E2+C4*E3)/DSQRT(AVE) !
!
END FUNCTION RF
!
!=======================================================================
!
FUNCTION RJ(X,Y,Z,P)
!
! This function computes Carlson's elliptic integral of the second kind,
! RJ(z,y,z,p).
!
! If P < 0, the Cauchy principal value is returned
!
! --> TINY must be at least twice the cube root of the machine underflow limit
! --> BIG at most one fifth the cube root of the machine overflow limit
!
! Taken from "Numerical Recipes"
!
! REAL*8 version
!
!
! Last modified: D. Sébilleau 15 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,HALF,THIRD,FOURTH
!
IMPLICIT NONE
!
REAL (WP) :: RJ,P,X,Y,Z,ERRTOL,TINY,BIG
REAL (WP) :: C1,C2,C3,C4,C5,C6,C7,C8
PARAMETER (ERRTOL=.05E0_WP,TINY=2.5E-13_WP,BIG=9.E11_WP) !
PARAMETER (C1=THREE/14.0E0_WP,C2=THIRD) !
PARAMETER (C3=THREE/22.0E0_WP,C4=THREE/26.0E0_WP) !
PARAMETER (C5=.750E0_WP*C3,C6=1.50E0_WP*C4) !
PARAMETER (C7=HALF*C2,C8=C3+C3) !
!
! Uses RC,RF
!
REAL (WP) :: A,ALAMB,ALPHA,AVE,B,BETA
REAL (WP) :: DELP,DELX,DELY,DELZ,EA,EB,EC,ED,EE
REAL (WP) :: FAC,PT,RCX,RHO,SQRTX,SQRTY,SQRTZ
REAL (WP) :: SUM,TAU,XT,YT,ZT
!
INTEGER :: LOGF
!
LOGF=6 !
!
IF( MIN(X,Y,Z) < ZERO .OR. MIN(X+Y,X+Z,Y+Z,DABS(P)) < TINY & !
.OR. MAX(X,Y,Z,DABS(P)) > BIG ) THEN !
WRITE(LOGF,*) 'Invalid arguments in RJ' !
STOP !
ENDIF !
!
SUM=ZERO !
FAC=ONE !
!
IF(P > ZERO)THEN !
XT=X !
YT=Y !
ZT=Z !
PT=P !
ELSE !
XT=MIN(X,Y,Z) !
ZT=MAX(X,Y,Z) !
YT=X+Y+Z-XT-ZT !
A=ONE/(YT-P) !
B=A*(ZT-YT)*(YT-XT) !
PT=YT+B !
RHO=XT*ZT/YT !
TAU=P*PT/YT !
RCX=RC(RHO,TAU) !
END IF
!
1 CONTINUE !
!
SQRTX=DSQRT(XT) !
SQRTY=DSQRT(YT) !
SQRTZ=DSQRT(ZT) !
ALAMB=SQRTX*(SQRTY+SQRTZ)+SQRTY*SQRTZ !
ALPHA=(PT*(SQRTX+SQRTY+SQRTZ)+SQRTX*SQRTY*SQRTZ)**2 !
BETA=PT*(PT+ALAMB)**2 !
SUM=SUM+FAC*RC(ALPHA,BETA) !
FAC=FOURTH*FAC !
XT =FOURTH*(XT+ALAMB) !
YT =FOURTH*(YT+ALAMB) !
ZT =FOURTH*(ZT+ALAMB) !
PT =FOURTH*(PT+ALAMB) !
AVE=0.20E0_WP*(XT+YT+ZT+PT+PT) !
DELX=(AVE-XT)/AVE !
DELY=(AVE-YT)/AVE !
DELZ=(AVE-ZT)/AVE !
DELP=(AVE-PT)/AVE !
!
IF(MAX(DABS(DELX),DABS(DELY),DABS(DELZ),DABS(DELP)) & !
> ERRTOL) GO TO 1 !
!
EA=DELX*(DELY+DELZ)+DELY*DELZ !
EB=DELX*DELY*DELZ !
EC=DELP**2 !
ED=EA-THREE*EC !
EE=EB+TWO*DELP*(EA-EC) !
!
RJ=THREE*SUM + FAC*(ONE+ED*(-C1+C5*ED-C6*EE)+ & !
EB*(C7+DELP*(-C8+DELP*C4))+DELP*EA*(C2-DELP*C3)- & !
C2*DELP*EC)/(AVE*DSQRT(AVE)) !
!
IF (P <= ZERO) RJ=A*(B*RJ+THREE*(RCX-RF(XT,YT,ZT))) !
!
END FUNCTION RJ
!
!=======================================================================
!
FUNCTION RD(X,Y,Z)
!
! This function computes Carlson's elliptic integral of the third kind
! RD(X,Y,Z)
!
! X and Y must be non-negative, and at most one can be zero.
! Z must be positive.
!
! --> TINY must be at least twice the negative 2/3 power of the
! machine overflow limit.
! --> BIG must be at most 0.1 X ERRTOL times the negative 2/3 power
! of the machine underflow limit.
!
! Taken from "Numerical Recipes"
!
! REAL*8 version
!
!
! Last modified: D. Sébilleau 15 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,THREE,FOURTH
!
IMPLICIT NONE
!
REAL (WP) :: RD,X,Y,Z,ERRTOL,TINY,BIG
REAL (WP) :: C1,C2,C3,C4,C5,C6
PARAMETER (ERRTOL=0.05E0_WP,TINY=1.E-25_WP,BIG=4.5E21_WP) !
PARAMETER (C1=THREE/14.0E0_WP,C2=ONE/6.0E0_WP) !
PARAMETER (C3=9.0E0_WP/22.0E0_WP,C4=THREE/26.0E0_WP) !
PARAMETER (C5=FOURTH*C3,C6=1.50E0_WP*C4) !
!
REAL (WP) :: ALAMB,AVE,DELX,DELY,DELZ,EA,EB,EC,ED,EE,FAC
REAL (WP) :: SQRTX,SQRTY,SQRTZ,SUM,XT,YT,ZT
!
INTEGER :: LOGF
!
LOGF=6 !
!
IF( MIN(X,Y) < ZERO .OR. MIN(X+Y,Z) < TINY & !
.OR. MAX(X,Y,Z) > BIG ) THEN !
WRITE(LOGF,*) 'Invalid arguments in RD' !
STOP !
END IF !
!
XT=X !
YT=Y !
ZT=Z !
SUM=ZERO !
FAC=ONE !
!
1 CONTINUE !
!
SQRTX=DSQRT(XT) !
SQRTY=DSQRT(YT) !
SQRTZ=DSQRT(ZT) !
ALAMB=SQRTX*(SQRTY+SQRTZ)+SQRTY*SQRTZ !
SUM=SUM+FAC/(SQRTZ*(ZT+ALAMB)) !
FAC=FOURTH*FAC !
XT =FOURTH*(XT+ALAMB) !
YT =FOURTH*(YT+ALAMB) !
ZT =FOURTH*(ZT+ALAMB) !
AVE=0.20E0_WP*(XT+YT+THREE*ZT) !
DELX=(AVE-XT)/AVE !
DELY=(AVE-YT)/AVE !
DELZ=(AVE-ZT)/AVE !
!
IF(MAX(DABS(DELX),DABS(DELY),DABS(DELZ)) > ERRTOL) GO TO 1 !
!
EA=DELX*DELY !
EB=DELZ*DELZ !
EC=EA-EB !
ED=EA-6.0E0_WP*EB !
EE=ED+EC+EC !
!
RD=THREE*SUM+FAC*(ONE+ED*(-C1+C5*ED-C6*DELZ*EE)+ & !
DELZ*(C2*EE+DELZ*(-C3*EC+DELZ*C4*EA)))/(AVE*DSQRT(AVE)) !
!
END FUNCTION RD
!
!=======================================================================
!
FUNCTION RC(X,Y)
!
! This function computes Carlson's degenerate elliptic integral,
! RC(Z,Y)
!
! Z must be nonnegative and Y must be nonzero
! If Y < 0, the Cauchy principal value is returned
!
! --> TINY must be at least 5 times the machine underflow limit
! --> BIG at most one fifth the machine maximum overflow limit.
!
! Taken from "Numerical Recipes"
!
! REAL*8 version
!
!
!
! Last modified: D. Sébilleau 15 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,THIRD,FOURTH
!
IMPLICIT NONE
!
REAL (WP) :: RC,X,Y
REAL (WP) :: ERRTOL,TINY,SQRTNY,BIG,TNBG,COMP1,COMP2
REAL (WP) :: C1,C2,C3,C4
PARAMETER (ERRTOL=0.0E0_WP,TINY=1.69E-38_WP) !
PARAMETER (SQRTNY=1.E-19_WP,BIG=3.E37_WP) !
PARAMETER (TNBG=TINY*BIG,COMP1=2.236E0_WP/SQRTNY) !
PARAMETER (COMP2=TNBG*TNBG/25.0E0_WP,C1=0.3E0_WP) !
PARAMETER (C2=ONE/7.0E0_WP,C3=0.375E0_WP) !
PARAMETER (C4=9.0E0_WP/22.0E0_WP) !
!
REAL (WP) :: ALAMB,AVE,S,W,XT,YT
!
INTEGER :: LOGF
!
LOGF=6 !
!
IF( X < ZERO .OR. Y == ZERO .OR. (X+ABS(Y)) < TINY & !
.OR. (X+DABS(Y)) > BIG .OR. & !
(Y < -COMP1 .AND. X > ZERO .AND. X < COMP2) & !
) THEN !
WRITE(LOGF,*) 'Invalid arguments in RC' !
STOP !
END IF !
!
IF(Y > ZERO) THEN !
XT=X !
YT=Y !
W=ONE !
ELSE !
XT=X-Y !
YT=-Y !
W=DSQRT(X)/DSQRT(XT) !
END IF !
!
1 CONTINUE !
!
ALAMB=TWO*DSQRT(XT)*DSQRT(YT)+YT !
XT=FOURTH*(XT+ALAMB) !
YT=FOURTH*(YT+ALAMB) !
AVE=THIRD*(XT+YT+YT) !
S=(YT-AVE)/AVE !
!
IF(DABS(S) > ERRTOL) GO TO 1 !
!
RC=W*(ONE+S*S*(C1+S*(C2+S*(C3+S*C4))))/DSQRT(AVE) !
!
END FUNCTION RC
!
!=======================================================================
!
! 12) Exponential integral:
!
!=======================================================================
!
FUNCTION DEI (X1)
!
! An exponential integral routine.
! For X greater than 0, the exponential integral, EI, is defined by
! EI(X) = integral ( exp ( T ) / T DT ), from T = -infinity to T = X
! where the integral is to be interpreted as the Cauchy principal
! value. For X less than 0, EI(X) = -E1(-X), where
! E1(Z) = integral ( exp ( -T ) / T DT ) from T = Z TO T = infinity.
!
!
! Modified:
!
! 04 October 2006
!
! Reference:
!
! Kathleen Paciorek,
! Algorithm 385:
! Exponential Integral Ei(x),
! Communications of the ACM,
! Volume 13, Number 7, July 1970, pages 446-447.
!
!
!
!
! Last modified: D. Sébilleau 15 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,HALF
!
IMPLICIT NONE
!
REAL (WP) :: A(6),B(6),C(8),D(8),E(8),F(8)
REAL (WP) :: DEI,DENM,FRAC
REAL (WP) :: P0(6),P1(9),P2(9),P3(10),P4(10),PX(10)
REAL (WP) :: Q0(6),Q1(9),Q2(8),Q3(9),Q4(9),QX(10)
REAL (WP) :: R,SUMP,SUMQ,T,W,X,X0,X1,XMX0,Y,MAXEXP
REAL (WP) :: HUGE
!
INTEGER :: I,J,L,LOGF
!
DATA A / & !
-5.77215664901532863E-01_WP, & !
7.54164313663016620E-01_WP, & !
1.29849232927373234E-01_WP, & !
2.40681355683977413E-02_WP, & !
1.32084309209609371E-03_WP, & !
6.57739399753264501E-05_WP / !
DATA B / & !
1.0E+00_WP, & !
4.25899193811589822E-01_WP, & !
7.9779471841022822E-02_WP , & !
8.30208476098771677E-03_WP, & !
4.86427138393016416E-04_WP, & !
1.30655195822848878E-05_WP / !
DATA C / & !
8.67745954838443744E-08_WP, & !
9.99995519301390302E-01_WP, & !
1.18483105554945844E+01_WP, & !
4.55930644253389823E+01_WP, & !
6.99279451291003023E+01_WP, & !
4.25202034768840779E+01_WP, & !
8.83671808803843939E+00_WP, & !
4.01377664940664720E-01_WP / !
DATA D / & !
1.0E+00_WP, & !
1.28481935379156650E+01_WP, & !
5.64433569561803199E+01_WP, & !
1.06645183769913883E+02_WP, & !
8.97311097125289802E+01_WP, & !
3.14971849170440750E+01_WP, & !
3.79559003762122243E+00_WP, & !
9.08804569188869219E-02_WP / !
DATA E / & !
-9.99999999999973414E-01_WP, & !
-3.44061995006684895E+01_WP, & !
-4.27532671201988539E+02_WP, & !
-2.39601943247490540E+03_WP, & !
-6.16885210055476351E+03_WP, & !
-6.57609698748021179E+03_WP, & !
-2.10607737142633289E+03_WP, & !
-1.48990849972948169E+01_WP / !
DATA F / & !
1.0E+00_WP, & !
3.64061995006459804E+01_WP, & !
4.94345070209903645E+02_WP, & !
3.19027237489543304E+03_WP, & !
1.03370753085840977E+04_WP, & !
1.63241453557783503E+04_WP, & !
1.11497752871096620E+04_WP, & !
2.37813899102160221E+03_WP / !
!
DATA P0 / & !
1.0E+00_WP, & !
2.23069937666899751E+00_WP, & !
1.70277059606809295E+00_WP, & !
5.10499279623219400E-01_WP, & !
4.89089253789279154E-02_WP, & !
3.65462224132368429E-04_WP / !
DATA P1 / & !
5.99569946892370010E+09_WP, & !
-2.50389994886351362E+08_WP, & !
7.05921609590056747E+08_WP, & !
-3.36899564201591901E+06_WP, & !
8.98683291643758313E+06_WP, & !
7.37147790184657443E+04_WP, & !
2.85446881813647015E+04_WP, & !
4.12626667248911939E+02_WP, & !
1.10639547241639580E+01_WP / !
DATA P2 / & !
9.98957666516551704E-01_WP, & !
5.73116705744508018E+00_WP, & !
4.18102422562856622E+00_WP, & !
5.88658240753281111E+00_WP, & !
-1.94132967514430702E+01_WP, & !
7.89472209294457221E+00_WP, & !
2.32730233839039141E+01_WP, & !
-3.67783113478311458E+01_WP, & !
-2.46940983448361265E+00_WP / !
DATA P3 / & !
9.99993310616056874E-01_WP, & !
-1.84508623239127867E+00_WP, & !
2.65257581845279982E+01_WP, & !
2.49548773040205944E+01_WP, & !
-3.32361257934396228E+01_WP, & !
-9.13483569999874255E-01_WP, & !
-2.10574079954804045E+01_WP, & !
-1.00064191398928483E+01_WP, & !
-1.86009212172643758E+01_WP, & !
-1.64772117246346314E+00_WP / ! !
DATA P4 / & !
1.00000000000000486E+00_WP, & !
-3.00000000320981266E+00_WP, & !
-5.00006640413131002E+00_WP, & !
-7.06810977895029359E+00_WP, & !
-1.52856623636929637E+01_WP, & !
-7.63147701620253631E+00_WP, & !
-2.79798528624305389E+01_WP, & !
-1.81949664929868906E+01_WP, & !
-2.23127670777632410E+02_WP, & !
1.75338801265465972E+02_WP / !
!
DATA Q0 / & !
1.0E+00_WP, & !
2.73069937666899751E+00_WP, & !
2.73478695106925836E+00_WP, & !
1.21765962960151532E+00_WP, & !
2.28817933990526412E-01_WP, & !
1.31114151194977706E-02_WP / !
DATA Q1 / & !
2.55926497607616350E+09_WP, & !
-2.79673351122984591E+09_WP, & !
8.02827782946956507E+08_WP, & !
-1.44980714393023883E+08_WP, & !
1.77158308010799884E+07_WP, & !
-1.49575457202559218E+06_WP, & !
8.53771000180749097E+04_WP, & !
-3.02523682238227410E+03_WP, & !
5.12578125E+01_WP / !
DATA Q2 / & !
1.14625253249016191E+00_WP, & !
-1.99149600231235164E+02_WP, & !
3.41365212524375539E+02_WP, & !
5.23165568734558614E+01_WP, & !
3.17279489254369328E+02_WP, & !
-8.38767084189640707E+00_WP, & !
9.65405217429280303E+02_WP, & !
2.63983007318024593E+00_WP / !
DATA Q3 / & !
1.00153385204534270E+00_WP, & !
-1.09355619539109124E+01_WP, & !
1.99100447081774247E+02_WP, & !
1.19283242396860101E+03_WP, & !
4.42941317833792840E+01_WP, & !
2.53881931563070803E+02_WP, & !
5.99493232566740736E+01_WP, & !
6.40380040535241555E+01_WP, & !
9.79240359921729030E+01_WP / !
DATA Q4 / & !
1.99999999999048104E+00_WP, & !
-2.99999894040324960E+00_WP, & !
-7.99243595776339741E+00_WP, & !
-1.20187763547154743E+01_WP, & !
7.04831847180424676E+01_WP, & !
1.17179220502086455E+02_WP, & !
1.37790390235747999E+02_WP, & !
3.97277109100414518E+00_WP, & !
3.97845977167414721E+04_WP / !
!
DATA X0 / 0.372507410781366634E+00_WP / !
!
LOGF=6 !
!
! MAXEXP needs to be set to the largest argument of exp
! that will not cause an overflow. This is computed here
! but could be embedded as a constant for efficiency reasons.
!
MAXEXP = (DINT(DLOG(HUGE(ZERO))*100))/100.0E0_WP !
!
X = X1 !
1 IF ( X <= ZERO) GO TO 100 !
IF ( X >= 12.0E+00_WP ) GO TO 60 !
IF ( X >= 6.0E+00_WP ) GO TO 40 !
!
! X in (0,6).
!
T = X + X !
T = T / THREE - TWO !
PX(10) = ZERO !
QX(10) = ZERO !
PX(9) = P1(9) !
QX(9) = Q1(9) !
!
! The rational function is expressed as a ratio of finite sums of
! shifted Chebyshev polynomials, and is evaluated by noting that
! T*(X) = T(2*X-1) and using the Clenshaw-Rice algorithm found in
! reference (4).
!
DO L = 2, 8 !
I = 10 - L !
PX(I) = T * PX(I+1) - PX(I+2) + P1(I) !
QX(I) = T * QX(I+1) - QX(I+2) + Q1(I) !
END DO !
!
R = ( HALF * T * PX(2) - PX(3) + P1(1) ) & !
/ ( HALF * T * QX(2) - QX(3) + Q1(1) ) !
!
! ( X - X0 ) = ( X - X1 ) - X2, where X1 = 409576229586. / 2**40 and
! X2 = -.7671772501993940D-12.
!
XMX0 = ( X - 409576229586.0E+00_WP / 1099511627776.0E+00_WP )&!
- 0.7671772501993940E-12_WP !
IF ( DABS ( XMX0 ) < 0.037E+00_WP ) GO TO 15 !
DEI = DLOG ( X / X0 ) + XMX0 * R !
!
RETURN
!
15 Y = XMX0 / X0 !
!
! A rational approximation to LOG ( X / X0 ) * LOG ( 1 + Y ),
! where Y = ( X - X0 ) / X0, and DABS ( Y ) is less than 0.1,
! that is for DABS ( X - X0 ) less than 0.037.
!
SUMP = (((( P0(6) & !
* Y + P0(5) ) & !
* Y + P0(4) ) & !
* Y + P0(3) ) & !
* Y + P0(2) ) & !
* Y + P0(1) !
!
SUMQ = (((( Q0(6) & !
* Y + Q0(5) ) & !
* Y + Q0(4) ) & !
* Y + Q0(3) ) & !
* Y + Q0(2) ) & !
* Y + Q0(1) !
!
DEI = ( SUMP / ( SUMQ * X0 ) + R ) * XMX0 !
!
RETURN
!
! X in (6,12).
!
40 DENM = P2(9) + X !
FRAC = Q2(8) + X !
!
! The rational function is expressed as a J-fraction.
!
DO J = 2, 8 !
I = 9 - J !
DENM = P2(I+1) + X + FRAC !
FRAC = Q2(I) / DENM !
END DO !
!
DEI = DEXP ( X ) * ( ( P2(1) + FRAC ) / X ) !
!
RETURN
!
60 IF ( X >= 24.0E+00_WP ) GO TO 80 !
!
! X in (12,24).
!
DENM = P3(10) + X !
FRAC = Q3(9) / DENM !
!
! The rational function is expressed as a J-fraction.
!
DO J = 2, 9 !
I = 10 - J !
DENM = P3(I+1) + X + FRAC !
FRAC = Q3(I) / DENM !
END DO !
!
DEI = DEXP ( X ) * ( ( P3(1) + FRAC ) / X ) !
!
RETURN
!
! X greater than 24.
!
80 IF ( X <= MAXEXP ) GO TO 90 !
!
! X is greater than MAXEXP and DEI is set to infinity.
!
DEI = HUGE(ZERO) !
!
RETURN
!
90 Y = ONE / X !
DENM = P4(10) + X !
FRAC = Q4(9) / DENM !
!
! The rational function is expressed as a J-fraction.
!
DO J = 2, 9 !
I = 10 - J !
DENM = P4(I+1) + X + FRAC !
FRAC = Q4(I) / DENM !
END DO !
!
DEI = DEXP ( X ) * ( Y + Y * Y * ( P4(1) + FRAC ) ) !
!
RETURN
!
100 IF ( X /= ZERO ) GO TO 101 !
!
! X = 0 and DEI is set to -infinity.
!
DEI = -HUGE(ZERO) !
WRITE(LOGF,500) !
!
RETURN
!
101 Y = -X !
110 W = ONE / Y !
IF ( Y > FOUR ) GO TO 300 !
IF ( Y > ONE ) GO TO 200 !
!
! X in (-1,0).
!
DEI = LOG ( Y ) - ((((( & !
A(6) & !
* Y + A(5) ) & !
* Y + A(4) ) & !
* Y + A(4) ) & !
* Y + A(2) ) & !
* Y + A(1) ) / ((((( & !
B(6) & !
* Y + B(5) ) & !
* Y + B(4) ) & !
* Y + B(4) ) & !
* Y + B(2) ) & !
* Y + B(1) )
!
RETURN
!
! X in (-4,-1).
!
200 DEI = -DEXP ( -Y ) * (((((((( & !
C(8) & !
* W + C(7) ) & !
* W + C(6) ) & !
* W + C(5) ) & !
* W + C(4) ) & !
* W + C(3) ) & !
* W + C(2) ) & !
* W + C(1) ) / ((((((( & !
D(8) & !
* W + D(7) ) & !
* W + D(6) ) & !
* W + D(5) ) & !
* W + D(4) ) & !
* W + D(3) ) & !
* W + D(2) ) & !
* W + D(1) ) ) !
!
RETURN
!
! X less than -4.
!
300 DEI = -DEXP ( -Y ) * ( W * ( ONE + W * ((((((( & !
E(8) & !
* W + E(7) ) & !
* W + E(6) ) & !
* W + E(5) ) & !
* W + E(4) ) & !
* W + E(3) ) & !
* W + E(2) ) & !
* W + E(1) ) / ((((((( & !
F(8) & !
* W + F(7) ) & !
* W + F(6) ) & !
* W + F(5) ) & !
* W + F(4) ) & !
* W + F(3) ) & !
* W + F(2) ) & !
* W + F(1) ) ) ) !
!
RETURN
!
500 FORMAT ( & !
' DEI called with a zero argument, result set to -infinity') !
!
END FUNCTION DEI
!
!=======================================================================
!
SUBROUTINE E1Z(Z,CE1)
!
! E1Z computes the complex exponential integral E1(z).
!
! Licensing:
!
! This routine is copyrighted by Shanjie Zhang and Jianming Jin. However,
! they give permission to incorporate this routine into a user program
! provided that the copyright is acknowledged.
!
! Modified:
!
! 16 July 2012
!
! Author:
!
! Shanjie Zhang, Jianming Jin
!
! Reference:
!
! Shanjie Zhang, Jianming Jin,
! Computation of Special Functions,
! Wiley, 1996,
! ISBN: 0-471-11963-6,
! LC: QA351.C45.
!
! Parameters:
!
! Input, complex*16 Z, the argument.
!
! Output, complex*16 CE1, the function value.
!
!
! Last modified: D. Sébilleau 16 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,TEN,TWENTY
USE COMPLEX_NUMBERS
USE PI_ETC, ONLY : PI
USE EULER_CONST, ONLY : EUMAS
!
IMPLICIT NONE
!
REAL (WP) :: A0,EL,X
!
COMPLEX (WP) :: CE1,CR,CT,CT0,Z
!
INTEGER :: K
!
EL = EUMAS !
X = DREAL ( Z ) !
A0 = CDABS ( Z ) !
!
IF(A0 == ZERO) THEN !
!
CE1 = CMPLX ( 1.0E+30_WP, ZERO ) !
!
ELSE IF( (A0 <= TEN) .OR. & !
(X < ZERO) .AND. (A0 < TWENTY ) ) THEN !
!
CE1 = ONEC !
CR = ONEC !
!
DO K = 1, 150 !
CR = - CR * K * Z / ( K + ONE )**2 !
CE1 = CE1 + CR !
IF ( CDABS(CR) <= (CDABS(CE1)* 1.0E-15_WP) ) THEN !
GO TO 10 !
END IF !
END DO !
!
10 CONTINUE !
!
CE1 = - EL - CDLOG ( Z ) + Z * CE1 !
!
ELSE !
!
CT0 = ZEROC !
!
DO K = 120, 1, -1 !
CT0 = K / ( ONE + K / ( Z + CT0 ) ) !
END DO !
!
CT = ONE / ( Z + CT0 ) !
!
CE1 = CDEXP ( - Z ) * CT !
IF( (X <= ZERO) .AND. (DIMAG(Z) == ZERO) ) THEN !
CE1 = CE1 - PI * IC !
END IF !
!
END IF !
!
END SUBROUTINE E1Z
!
!=======================================================================
!
! 13) Error functions:
!
!=======================================================================
!
FUNCTION ERF(X)
!
! This function returns the error function erf(x)
!
! This is a REAL*8 version of the Numerical Recipes code
!
!
! Last modified: D. Sébilleau 16 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,HALF
!
IMPLICIT NONE
!
REAL (WP) :: ERF,X
! REAL (WP) :: GAMMP
!
! Uses GAMMP
!
IF(X < ZERO)THEN !
ERF=-GAMMP(HALF,X**2) !
ELSE !
ERF= GAMMP(HALF,X**2) !
END IF !
!
END FUNCTION ERF
!
!=======================================================================
!
FUNCTION ERFC(X)
!
! This function returns the complementary error function erfc(x)
!
! This is a REAL*8 version of the Numerical Recipes code
!
!
! Last modified: D. Sébilleau 16 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,HALF
!
IMPLICIT NONE
!
REAL (WP) :: ERFC,X
!ST REAL (WP) :: GAMMP,GAMMQ
!
! Uses GAMMP,GAMMQ
!
IF(X < ZERO)THEN !
ERFC=ONE+GAMMP(HALF,X**2) !
ELSE !
ERFC=GAMMQ(HALF,X**2) !
END IF !
!
END FUNCTION ERFC
!
!=======================================================================
!
! 14) Bessel functions:
!
!=======================================================================
!
FUNCTION DBESJ0(X)
!
! This function returns the Bessel J_0(x) function in double precision
!
! 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 16 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ONE,HALF
!
IMPLICIT NONE
!
REAL (WP) :: DBESJ0,X
REAL (WP) :: A(0:7),B(0:64),C(0:69),D(0:51)
REAL (WP) :: PI4
REAL (WP) :: W,T,Y,V,THETA
!
INTEGER :: I,K
!
DATA (A(I), I = 0, 7) / &!
-0.0000000000023655394E0_WP, 0.0000000004708898680E0_WP, &!
-0.0000000678167892231E0_WP, 0.0000067816840038636E0_WP, &!
-0.0004340277777716935E0_WP, 0.0156249999999992397E0_WP, &!
-0.2499999999999999638E0_WP, 0.9999999999999999997E0_WP / !
DATA (B(I), I = 0, 12) / &!
0.0000000000626681117E0_WP, -0.0000000022270614428E0_WP, &!
0.0000000662981656302E0_WP, -0.0000016268486502196E0_WP, &!
0.0000321978384111685E0_WP, -0.0005005237733315830E0_WP, &!
0.0059060313537449816E0_WP, -0.0505265323740109701E0_WP, &!
0.2936432097610503985E0_WP, -1.0482565081091638637E0_WP, &!
1.9181123286040428113E0_WP, -1.1319199475221700100E0_WP, &!
-0.1965480952704682000E0_WP / !
DATA (B(I), I = 13, 25) / &!
0.0000000000457457332E0_WP, -0.0000000015814772025E0_WP, &!
0.0000000455487446311E0_WP, -0.0000010735201286233E0_WP, &!
0.0000202015179970014E0_WP, -0.0002942392368203808E0_WP, &!
0.0031801987726150648E0_WP, -0.0239875209742846362E0_WP, &!
0.1141447698973777641E0_WP, -0.2766726722823530233E0_WP, &!
0.1088620480970941648E0_WP, 0.5136514645381999197E0_WP, &!
-0.2100594022073706033E0_WP / !
DATA (B(I), I = 26, 38) / &!
0.0000000000331366618E0_WP, -0.0000000011119090229E0_WP, &!
0.0000000308823040363E0_WP, -0.0000006956602653104E0_WP, &!
0.0000123499947481762E0_WP, -0.0001662951945396180E0_WP, &!
0.0016048663165678412E0_WP, -0.0100785479932760966E0_WP, &!
0.0328996815223415274E0_WP, -0.0056168761733860688E0_WP, &!
-0.2341096400274429386E0_WP, 0.2551729256776404262E0_WP, &!
0.2288438186148935667E0_WP / !
DATA (B(I), I = 39, 51) / &!
0.0000000000238007203E0_WP, -0.0000000007731046439E0_WP, &!
0.0000000206237001152E0_WP, -0.0000004412291442285E0_WP, &!
0.0000073107766249655E0_WP, -0.0000891749801028666E0_WP, &!
0.0007341654513841350E0_WP, -0.0033303085445352071E0_WP, &!
0.0015425853045205717E0_WP, 0.0521100583113136379E0_WP, &!
-0.1334447768979217815E0_WP, -0.1401330292364750968E0_WP, &!
0.2685616168804818919E0_WP / !
DATA (B(I), I = 52, 64) / &!
0.0000000000169355950E0_WP, -0.0000000005308092192E0_WP, &!
0.0000000135323005576E0_WP, -0.0000002726650587978E0_WP, &!
0.0000041513240141760E0_WP, -0.0000443353052220157E0_WP, &!
0.0002815740758993879E0_WP, -0.0004393235121629007E0_WP, &!
-0.0067573531105799347E0_WP, 0.0369141914660130814E0_WP, &!
0.0081673361942996237E0_WP, -0.2573381285898881860E0_WP, &!
0.0459580257102978932E0_WP / !
DATA (C(I), I = 0, 13) / &!
-0.00000000003009451757E0_WP,-0.00000000014958003844E0_WP,&!
0.00000000506854544776E0_WP, 0.00000001863564222012E0_WP,&!
-0.00000060304249068078E0_WP,-0.00000147686259937403E0_WP,&!
0.00004714331342682714E0_WP, 0.00006286305481740818E0_WP,&!
-0.00214137170594124344E0_WP,-0.00089157336676889788E0_WP,&!
0.04508258728666024989E0_WP,-0.00490362805828762224E0_WP,&!
-0.27312196367405374426E0_WP, 0.04193925184293450356E0_WP /!
DATA (C(I), I = 14, 27) / &!
-0.00000000000712453560E0_WP,-0.00000000041170814825E0_WP,&!
0.00000000138012624364E0_WP, 0.00000005704447670683E0_WP,&!
-0.00000019026363528842E0_WP,-0.00000533925032409729E0_WP,&!
0.00001736064885538091E0_WP, 0.00030692619152608375E0_WP,&!
-0.00092598938200644367E0_WP,-0.00917934265960017663E0_WP,&!
0.02287952522866389076E0_WP, 0.10545197546252853195E0_WP,&!
-0.16126443075752985095E0_WP,-0.19392874768742235538E0_WP /!
DATA (C(I), I = 28, 41) / &!
0.00000000002128344556E0_WP,-0.00000000031053910272E0_WP,&!
-0.00000000334979293158E0_WP, 0.00000004507232895050E0_WP,&!
0.00000036437959146427E0_WP,-0.00000446421436266678E0_WP,&!
-0.00002523429344576552E0_WP, 0.00027519882931758163E0_WP,&!
0.00097185076358599358E0_WP,-0.00898326746345390692E0_WP,&!
-0.01665959196063987584E0_WP, 0.11456933464891967814E0_WP,&!
0.07885001422733148815E0_WP,-0.23664819446234712621E0_WP /!
DATA (C(I), I = 42, 55) / &!
0.00000000003035295055E0_WP, 0.00000000005486066835E0_WP,&!
-0.00000000501026824811E0_WP,-0.00000000501246847860E0_WP,&!
0.00000058012340163034E0_WP, 0.00000016788922416169E0_WP,&!
-0.00004373270270147275E0_WP, 0.00001183898532719802E0_WP,&!
0.00189863342862291449E0_WP,-0.00113759249561636130E0_WP,&!
-0.03846797195329871681E0_WP, 0.02389746880951420335E0_WP,&!
0.22837862066532347461E0_WP,-0.06765394811166522844E0_WP /!
DATA (C(I), I = 56, 69) / &!
0.00000000001279875977E0_WP, 0.00000000035925958103E0_WP,&!
-0.00000000228037105967E0_WP,-0.00000004852770517176E0_WP,&!
0.00000028696428000189E0_WP, 0.00000440131125178642E0_WP,&!
-0.00002366617753349105E0_WP,-0.00024412456252884129E0_WP,&!
0.00113028178539430542E0_WP, 0.00708470513919789080E0_WP,&!
-0.02526914792327618386E0_WP,-0.08006137953480093426E0_WP,&!
0.16548380461475971846E0_WP, 0.14688405470042110229E0_WP /!
DATA (D(I), I = 0, 12) / &!
1.059601355592185731E-14_WP, -2.71150591218550377E-13_WP,&!
8.6514809056201638E-12_WP, -4.6264028554286627E-10_WP,&!
5.0815403835647104E-8_WP, -1.76722552048141208E-5_WP,&!
0.16286750396763997378E0_WP, 2.949651820598278873E-13_WP,&!
-8.818215611676125741E-12_WP, 3.571119876162253451E-10_WP,&!
-2.631924120993717060E-8_WP, 4.709502795656698909E-6_WP,&!
-5.208333333333283282E-3_WP / !
DATA (D(I), I = 13, 25) / &!
7.18344107717531977E-15_WP, -2.51623725588410308E-13_WP,&!
8.6017784918920604E-12_WP, -4.6256876614290359E-10_WP,&!
5.0815343220437937E-8_WP, -1.76722551764941970E-5_WP,&!
0.16286750396763433767E0_WP,2.2327570859680094777E-13_WP,&!
-8.464594853517051292E-12_WP, 3.563766464349055183E-10_WP,&!
-2.631843986737892965E-8_WP, 4.709502342288659410E-6_WP,&!
-5.2083333332278466225E-3_WP / !
DATA (D(I), I = 26, 38) / &!
5.15413392842889366E-15_WP, -2.27740238380640162E-13_WP,&!
8.4827767197609014E-12_WP, -4.6224753682737618E-10_WP,&!
5.0814848128929134E-8_WP, -1.76722547638767480E-5_WP,&!
0.16286750396748926663E0_WP,1.7316195320192170887E-13_WP,&!
-7.971122772293919646E-12_WP, 3.544039469911895749E-10_WP,&!
-2.631443902081701081E-8_WP, 4.709498228695400603E-6_WP,&!
-5.2083333315143653610E-3_WP / !
DATA (D(I), I = 39, 51) / &!
3.84653681453798517E-15_WP, -2.04464520778789011E-13_WP,&!
8.3089298605177838E-12_WP, -4.6155016158412096E-10_WP,&!
5.0813263696466650E-8_WP, -1.76722528311426167E-5_WP,&!
0.16286750396650065930E0_WP,1.3797879972460878797E-13_WP,&!
-7.448089381011684812E-12_WP, 3.512733797106959780E-10_WP,&!
-2.630500895563592722E-8_WP, 4.709483934775839193E-6_WP,&!
-5.2083333227940760113E-3_WP / !
!
PI4= 0.78539816339744830962E0_WP !
!
W = DABS(X) !
IF (W < ONE) THEN !
!
T = W * W !
Y = ((((((A(0) * T + A(1)) * T + & !
A(2)) * T + A(3)) * T + A(4)) * T + & !
A(5)) * T + A(6)) * T + A(7) !
!
ELSE IF (W < 8.5E0_WP) THEN !
!
T = W * W * 0.0625E0_WP !
K = INT(T) !
T = T - (K + HALF) !
K = K * 13 !
Y = (((((((((((B(K) * T + B(K + 1)) * T + & !
B(K + 2)) * T + B(K + 3)) * T + B(K + 4)) * T + & !
B(K + 5)) * T + B(K + 6)) * T + B(K + 7)) * T + & !
B(K + 8)) * T + B(K + 9)) * T + B(K + 10)) * T + & !
B(K + 11)) * T + B(K + 12) !
!
ELSE IF (W < 12.5E0_WP) THEN !
!
K = INT(W) !
T = W - (K + HALF) !
K = 14 * (K - 8) !
Y = ((((((((((((C(K) * T + C(K + 1)) * T + & !
C(K + 2)) * T + C(K + 3)) * T + C(K + 4)) * T + & !
C(K + 5)) * T + C(K + 6)) * T + C(K + 7)) * T + & !
C(K + 8)) * T + C(K + 9)) * T + C(K + 10)) * T + & !
C(K + 11)) * T + C(K + 12)) * T + C(K + 13) !
!
ELSE !
!
V = 24.0E0_WP / W !
T = V * V !
K = 13 * (INT(T)) !
Y = ((((((D(K) * T + D(K + 1)) * T + & !
D(K + 2)) * T + D(K + 3)) * T + D(K + 4)) * T + & !
D(K + 5)) * T + D(K + 6)) * DSQRT(V) !
THETA = (((((D(K + 7) * T + D(K + 8)) * T + & !
D(K + 9)) * T + D(K + 10)) * T + D(K + 11)) * T + & !
D(K + 12)) * V - PI4 !
Y = Y * DCOS(W + THETA) !
!
END IF !
!
DBESJ0 = Y !
!
END FUNCTION DBESJ0
!
!=======================================================================
!
FUNCTION DBESJ1(X)
!
! This function returns the Bessel J_1(x) function in double precision
!
! 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 16 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ZERO,ONE,HALF
!
IMPLICIT NONE
!
REAL (WP) :: DBESJ1,X
REAL (WP) :: A(0:7),B(0:64),C(0:69),D(0:51)
REAL (WP) :: PI4
REAL (WP) :: W,T,Y,V,THETA
!
INTEGER :: I,K
!
DATA (A(I), I = 0, 7) / &!
-0.00000000000014810349E0_WP, 0.00000000003363594618E0_WP, &!
-0.00000000565140051697E0_WP, 0.00000067816840144764E0_WP, &!
-0.00005425347222188379E0_WP, 0.00260416666666662438E0_WP, &!
-0.06249999999999999799E0_WP, 0.49999999999999999998E0_WP / !
DATA (B(I), I = 0, 12) / &!
0.00000000000243721316E0_WP, -0.00000000009400554763E0_WP, &!
0.00000000306053389980E0_WP, -0.00000008287270492518E0_WP, &!
0.00000183020515991344E0_WP, -0.00003219783841164382E0_WP, &!
0.00043795830161515318E0_WP, -0.00442952351530868999E0_WP, &!
0.03157908273375945955E0_WP, -0.14682160488052520107E0_WP, &!
0.39309619054093640008E0_WP, -0.47952808215101070280E0_WP, &!
0.14148999344027125140E0_WP / !
DATA (B(I), I = 13, 25) / &!
0.00000000000182119257E0_WP, -0.00000000006862117678E0_WP, &!
0.00000000217327908360E0_WP, -0.00000005693592917820E0_WP, &!
0.00000120771046483277E0_WP, -0.00002020151799736374E0_WP, &!
0.00025745933218048448E0_WP, -0.00238514907946126334E0_WP, &!
0.01499220060892984289E0_WP, -0.05707238494868888345E0_WP, &!
0.10375225210588234727E0_WP, -0.02721551202427354117E0_WP, &!
-0.06420643306727498985E0_WP / !
DATA (B(I), I = 26, 38) / &!
0.000000000001352611196E0_WP,-0.000000000049706947875E0_WP,&!
0.000000001527944986332E0_WP,-0.000000038602878823401E0_WP,&!
0.000000782618036237845E0_WP,-0.000012349994748451100E0_WP,&!
0.000145508295194426686E0_WP,-0.001203649737425854162E0_WP,&!
0.006299092495799005109E0_WP,-0.016449840761170764763E0_WP,&!
0.002106328565019748701E0_WP, 0.058527410006860734650E0_WP,&!
-0.031896615709705053191E0_WP / !
DATA (B(I), I = 39, 51) / &!
0.000000000000997982124E0_WP,-0.000000000035702556073E0_WP,&!
0.000000001062332772617E0_WP,-0.000000025779624221725E0_WP,&!
0.000000496382962683556E0_WP,-0.000007310776625173004E0_WP,&!
0.000078028107569541842E0_WP,-0.000550624088538081113E0_WP,&!
0.002081442840335570371E0_WP,-0.000771292652260286633E0_WP,&!
-0.019541271866742634199E0_WP, 0.033361194224480445382E0_WP,&!
0.017516628654559387164E0_WP / !
DATA (B(I), I = 52, 64) / &!
0.000000000000731050661E0_WP,-0.000000000025404499912E0_WP,&!
0.000000000729360079088E0_WP,-0.000000016915375004937E0_WP,&!
0.000000306748319652546E0_WP,-0.000004151324014331739E0_WP,&!
0.000038793392054271497E0_WP,-0.000211180556924525773E0_WP,&!
0.000274577195102593786E0_WP, 0.003378676555289966782E0_WP,&!
-0.013842821799754920148E0_WP,-0.002041834048574905921E0_WP,&!
0.032167266073736023299E0_WP / !
DATA (C(I), I = 0, 13) / &!
-0.00000000001185964494E0_WP, 0.00000000039110295657E0_WP,&!
0.00000000180385519493E0_WP, -0.00000005575391345723E0_WP,&!
-0.00000018635897017174E0_WP, 0.00000542738239401869E0_WP,&!
0.00001181490114244279E0_WP, -0.00033000319398521070E0_WP,&!
-0.00037717832892725053E0_WP, 0.01070685852970608288E0_WP,&!
0.00356629346707622489E0_WP, -0.13524776185998074716E0_WP,&!
0.00980725611657523952E0_WP, 0.27312196367405374425E0_WP /!
DATA (C(I), I = 14, 27) / &!
-0.00000000003029591097E0_WP, 0.00000000009259293559E0_WP,&!
0.00000000496321971223E0_WP, -0.00000001518137078639E0_WP,&!
-0.00000057045127595547E0_WP, 0.00000171237271302072E0_WP,&!
0.00004271400348035384E0_WP, -0.00012152454198713258E0_WP,&!
-0.00184155714921474963E0_WP, 0.00462994691003219055E0_WP,&!
0.03671737063840232452E0_WP, -0.06863857568599167175E0_WP,&!
-0.21090395092505707655E0_WP, 0.16126443075752985095E0_WP /!
DATA (C(I), I = 28, 41) / &!
-0.00000000002197602080E0_WP, -0.00000000027659100729E0_WP,&!
0.00000000374295124827E0_WP, 0.00000003684765777023E0_WP,&!
-0.00000045072801091574E0_WP, -0.00000327941630669276E0_WP,&!
0.00003571371554516300E0_WP, 0.00017664005411843533E0_WP,&!
-0.00165119297594774104E0_WP, -0.00485925381792986774E0_WP,&!
0.03593306985381680131E0_WP, 0.04997877588191962563E0_WP,&!
-0.22913866929783936544E0_WP, -0.07885001422733148814E0_WP /!
DATA (C(I), I = 42, 55) / &!
0.00000000000516292316E0_WP, -0.00000000039445956763E0_WP,&!
-0.00000000066220021263E0_WP, 0.00000005511286218639E0_WP,&!
0.00000005012579400780E0_WP, -0.00000522111059203425E0_WP,&!
-0.00000134311394455105E0_WP, 0.00030612891890766805E0_WP,&!
-0.00007103391195326182E0_WP, -0.00949316714311443491E0_WP,&!
0.00455036998246516948E0_WP, 0.11540391585989614784E0_WP,&!
-0.04779493761902840455E0_WP, -0.22837862066532347460E0_WP /!
DATA (C(I), I = 56, 69) / &!
0.00000000002697817493E0_WP,-0.00000000016633326949E0_WP,&!
-0.00000000433134860350E0_WP, 0.00000002508404686362E0_WP,&!
0.00000048528284780984E0_WP,-0.00000258267851112118E0_WP,&!
-0.00003521049080466759E0_WP, 0.00016566324273339952E0_WP,&!
0.00146474737522491617E0_WP,-0.00565140892697147306E0_WP,&!
-0.02833882055679300400E0_WP, 0.07580744376982855057E0_WP,&!
0.16012275906960187978E0_WP,-0.16548380461475971845E0_WP /!
DATA (D(I), I = 0, 12) / &!
-1.272346002224188092E-14_WP, 3.370464692346669075E-13_WP,&!
-1.144940314335484869E-11_WP, 6.863141561083429745E-10_WP,&!
-9.491933932960924159E-8_WP, 5.301676561445687562E-5_WP,&!
0.1628675039676399740E0_WP,-3.652982212914147794E-13_WP,&!
1.151126750560028914E-11_WP,-5.165585095674343486E-10_WP,&!
4.657991250060549892E-8_WP, -1.186794704692706504E-5_WP,&!
1.562499999999994026E-2_WP / !
DATA (D(I), I = 13, 25) / &!
-8.713069680903981555E-15_WP, 3.140780373478474935E-13_WP,&!
-1.139089186076256597E-11_WP, 6.862299023338785566E-10_WP,&!
-9.491926788274594674E-8_WP, 5.301676558106268323E-5_WP,&!
0.1628675039676466220E0_WP,-2.792555727162752006E-13_WP,&!
1.108650207651756807E-11_WP,-5.156745588549830981E-10_WP,&!
4.657894859077370979E-8_WP, -1.186794650130550256E-5_WP,&!
1.562499999987299901E-2_WP / !
DATA (D(I), I = 26, 38) / &!
-6.304859171204770696E-15_WP, 2.857249044208791652E-13_WP,&!
-1.124956921556753188E-11_WP, 6.858482894906716661E-10_WP,&!
-9.491867953516898460E-8_WP, 5.301676509057781574E-5_WP,&!
0.1628675039678191167E0_WP,-2.185193490132496053E-13_WP,&!
1.048820673697426074E-11_WP,-5.132819367467680132E-10_WP,&!
4.657409437372994220E-8_WP, -1.186794150862988921E-5_WP,&!
1.562499999779270706E-2_WP / !
DATA (D(I), I = 39, 51) / &!
-4.740417209792009850E-15_WP, 2.578715253644144182E-13_WP,&!
-1.104148898414138857E-11_WP, 6.850134201626289183E-10_WP,&!
-9.491678234174919640E-8_WP, 5.301676277588728159E-5_WP,&!
0.1628675039690033136E0_WP,-1.755122057493842290E-13_WP,&!
9.848723331445182397E-12_WP,-5.094535425482245697E-10_WP,&!
4.656255982268609304E-8_WP, -1.186792402114394891E-5_WP,&!
1.562499998712198636E-2_WP / !
!
W = DABS(X) !
IF (W < ONE) THEN !
!
T = W * W !
Y = (((((((A(0) * T + A(1)) * T + & !
A(2)) * T + A(3)) * T + A(4)) * T + & !
A(5)) * T + A(6)) * T + A(7)) * W !
!
ELSE IF (W < 8.5E0_WP) THEN !
!
T = W * W * 0.0625E0_WP !
K = INT(T) !
T = T - (K + HALF) !
K = K * 13 !
Y = ((((((((((((B(K) * T + B(K + 1)) * T + & !
B(K + 2)) * T + B(K + 3)) * T + B(K + 4)) * T + & !
B(K + 5)) * T + B(K + 6)) * T + B(K + 7)) * T + & !
B(K + 8)) * T + B(K + 9)) * T + B(K + 10)) * T + & !
B(K + 11)) * T + B(K + 12)) * W !
!
ELSE IF (W < 12.5E0_WP) THEN !
!
K = INT(W) !
T = W - (K + HALF) !
K = 14 * (K - 8) !
Y = ((((((((((((C(K) * T + C(K + 1)) * T + & !
C(K + 2)) * T + C(K + 3)) * T + C(K + 4)) * T + & !
C(K + 5)) * T + C(K + 6)) * T + C(K + 7)) * T + & !
C(K + 8)) * T + C(K + 9)) * T + C(K + 10)) * T + & !
C(K + 11)) * T + C(K + 12)) * T + C(K + 13) !
!
ELSE !
!
V = 24.0E0_WP / W !
T = V * V !
K = 13 * (INT(T)) !
Y = ((((((D(K) * T + D(K + 1)) * T + & !
D(K + 2)) * T + D(K + 3)) * T + D(K + 4)) * T + & !
D(K + 5)) * T + D(K + 6)) * DSQRT(V) !
THETA = (((((D(K + 7) * T + D(K + 8)) * T + & !
D(K + 9)) * T + D(K + 10)) * T + D(K + 11)) * T + & !
D(K + 12)) * V - PI4 !
Y = Y * DSIN(W + THETA) !
!
END IF !
!
IF (X < ZERO) Y = -Y !
!
DBESJ1 = Y !
!
END FUNCTION DBESJ1
!
!=======================================================================
!
! 15) Hermite polynomials H_n(x)
!
!=======================================================================
!
SUBROUTINE H_POLYNOMIAL_VALUE(M,N,X,P)
!
! THis subroutine evaluates the Hermite polynomials H(i,x).
!
! Discussion:
!
! H(i,x) is the physicist's Hermite polynomial of degree i.
!
! Differential equation:
!
! Y'' - 2 X Y' + 2 N Y = 0
!
! First terms:
!
! 1
! 2 X
! 4 X^2 - 2
! 8 X^3 - 12 X
! 16 X^4 - 48 X^2 + 12
! 32 X^5 - 160 X^3 + 120 X
! 64 X^6 - 480 X^4 + 720 X^2 - 120
! 128 X^7 - 1344 X^5 + 3360 X^3 - 1680 X
! 256 X^8 - 3584 X^6 + 13440 X^4 - 13440 X^2 + 1680
! 512 X^9 - 9216 X^7 + 48384 X^5 - 80640 X^3 + 30240 X
! 1024 X^10 - 23040 X^8 + 161280 X^6 - 403200 X^4 + 302400 X^2 - 30240
!
! Recursion:
!
! H(0,X) = 1,
! H(1,X) = 2*X,
! H(N,X) = 2*X * H(N-1,X) - 2*(N-1) * H(N-2,X)
!
! Norm:
!
! Integral ( -oo .lt. X .lt. oo ) exp ( - X^2 ) * H(N,X)^2 dX
! = sqrt ( PI ) * 2^N * N!
!
! H(N,X) = (-1)^N * exp ( X^2 ) * dn/dXn ( exp(-X^2 ) )
!
! Licensing:
!
! This code is distributed under the GNU LGPL license.
!
! Modified:
!
! 09 August 2013
!
! Author:
!
! John Burkardt
!
! Reference:
!
! Milton Abramowitz, Irene Stegun,
! Handbook of Mathematical Functions,
! National Bureau of Standards, 1964,
! ISBN: 0-486-61272-4,
! LC: QA47.A34.
!
! Larry Andrews,
! Special Functions of Mathematics for Engineers,
! Second Edition,
! Oxford University Press, 1998.
!
! Parameters:
!
! Input, integer M, the number of evaluation points.
!
! Input, integer N, the highest order polynomial to compute.
! Note that polynomials 0 through N will be computed.
!
! Input, double precision X(M), the evaluation points.
!
! Output, double precision P(M,0:N), the values of the first N+1 Hermite
! polynomials at the point X.
!
!
! Last modified: D. Sébilleau 16 Jun 2020
!
!
USE REAL_NUMBERS, ONLY : ONE,TWO
!
IMPLICIT NONE
!
INTEGER :: M,N
INTEGER :: I,J
INTEGER :: LOGF
!
REAL (WP) :: X(M),P(M,0:N)
!
LOGF=6 !
!
IF ( N < 0 ) THEN !
WRITE(LOGF,*) 'Error: N should be >=0 ' !
STOP !
END IF !
!
DO I = 1, M
P(I,0) = ONE
END DO
!
IF ( N == 0 ) THEN !
RETURN !
END IF !
!
DO I = 1, M !
P(I,1) = TWO * X(I) !
END DO !
!
DO J = 2, N !
DO I = 1, M !
P(I,J) = TWO * X(I) * P(I,J-1) & !
- TWO * DBLE ( J - 1 ) * P(I,J-2) !
END DO !
END DO !
!
END SUBROUTINE H_POLYNOMIAL_VALUE
!
END MODULE EXT_FUNCTIONS