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