commit 9893530eb79dcd379da99334e455fdbaa29bf87f Author: Sylvain Tricot Date: Wed Feb 2 16:19:10 2022 +0100 initial commit diff --git a/New_libraries/DFM_library/ACCURACY_LIBRARY/accuracy.f90 b/New_libraries/DFM_library/ACCURACY_LIBRARY/accuracy.f90 new file mode 100644 index 0000000..c85175d --- /dev/null +++ b/New_libraries/DFM_library/ACCURACY_LIBRARY/accuracy.f90 @@ -0,0 +1,401 @@ +! +!======================================================================= +! +MODULE ACCURACY_REAL +! + INTEGER, PARAMETER :: SP = SELECTED_REAL_KIND(6, 37) ! single precision + INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(15, 307) ! double precision + INTEGER, PARAMETER :: QP = SELECTED_REAL_KIND(33, 4931) ! quadruple precision +! + INTEGER, PARAMETER :: WP = DP ! selected value for code +! +END MODULE ACCURACY_REAL +! +!======================================================================= +! +MODULE ACCURACY_INTEGER +! + INTEGER, PARAMETER :: I1 = SELECTED_INT_KIND(8) ! default precision + INTEGER, PARAMETER :: I2 = SELECTED_INT_KIND(16) ! single precision + INTEGER, PARAMETER :: I4 = SELECTED_INT_KIND(32) ! double precision + INTEGER, PARAMETER :: I8 = SELECTED_INT_KIND(64) ! quadruple precision +! + INTEGER, PARAMETER :: IW = I1 ! selected value for code +! +END MODULE ACCURACY_INTEGER +! +!======================================================================= +! +MODULE MINMAX_VALUES +! + USE ACCURACY_REAL + USE ACCURACY_INTEGER +! + INTEGER (IW) :: III +! + REAL (WP) :: XXX +! + INTEGER (IW), PARAMETER :: INT_MAX = HUGE(III) ! maximal value of integer +! + REAL (WP), PARAMETER :: LN2 = 0.6931471805599453094172321214581765681D0 ! ln(2) + + REAL (WP), PARAMETER :: MAX_2XP = MAXEXPONENT(XXX) ! max value of y so that 2^x is defined + REAL (WP), PARAMETER :: MIN_2XP = MINEXPONENT(XXX) ! max value of y so that 2^-x is defined + REAL (WP), PARAMETER :: REL_MIN = TINY(XXX) ! minimum value of real number + REAL (WP), PARAMETER :: REL_MAX = HUGE(XXX) ! maximum value of real number + REAL (WP), PARAMETER :: EPS_MIN = EPSILON(XXX) ! smallest value real such that x + epsilon /= x and x = 1 + REAL (WP), PARAMETER :: DGT_SIG = DIGITS(XXX) ! number of significant digits +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE MINMAX_EXP(MAX_EXP,MIN_EXP) +! +! This module computes the maximal and minimal exponent +! so that e^x is defined +! + IMPLICIT NONE +! + REAL (WP), INTENT(OUT) :: MAX_EXP,MIN_EXP +! + REAL (WP), PARAMETER :: LN2 = 0.6931471805599453094172321214581765681D0 ! ln(2) +! + MAX_EXP = INT(MAXEXPONENT(XXX) * LN2) ! max value of y so that e^x is defined + MIN_EXP = INT(MINEXPONENT(XXX) * LN2) ! max value of y so that e^-x is defined +! + END SUBROUTINE MINMAX_EXP +! +END MODULE MINMAX_VALUES +! +!======================================================================= +! +MODULE MACHINE_ACCURACY +! +! This module provides the AMOS legacy routines for machine accuracy: +! +! * FUNCTION D1MACH(I) --> double precision reals +! +! * FUNCTION I1MACH(I) --> integers +! +! * FUNCTION R1MACH(I) --> single precision reals +! +! + USE ACCURACY_REAL + USE ACCURACY_INTEGER +! +CONTAINS +! +!======================================================================= +! + FUNCTION D1MACH(I) +! + IMPLICIT NONE +! + INTEGER (IW) :: I +! + REAL (WP) :: D1MACH + REAL (WP) :: B,X +! +!***BEGIN PROLOGUE D1MACH +!***PURPOSE Return floating point machine dependent constants. +!***LIBRARY SLATEC +!***CATEGORY R1 +!***TYPE SINGLE PRECISION (D1MACH-S, D1MACH-D) +!***KEYWORDS MACHINE CONSTANTS +!***AUTHOR Fox, P. A., (Bell Labs) +! Hall, A. D., (Bell Labs) +! Schryer, N. L., (Bell Labs) +!***DESCRIPTION +! +! D1MACH can be used to obtain machine-dependent parameters for the +! local machine environment. It is a function subprogram with one +! (input) argument, and can be referenced as follows: +! +! A = D1MACH(I) +! +! where I=1,...,5. The (output) value of A above is determined by +! the (input) value of I. The results for various values of I are +! discussed below. +! +! D1MACH(1) = B**(EMIN-1), the smallest positive magnitude. +! D1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude. +! D1MACH(3) = B**(-T), the smallest relative spacing. +! D1MACH(4) = B**(1-T), the largest relative spacing. +! D1MACH(5) = LOG10(B) +! +! Assume single precision numbers are represented in the T-digit, +! base-B form +! +! sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +! +! where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and +! EMIN .LE. E .LE. EMAX. +! +! The values of B, T, EMIN and EMAX are provided in I1MACH as +! follows: +! I1MACH(10) = B, the base. +! I1MACH(11) = T, the number of base-B digits. +! I1MACH(12) = EMIN, the smallest exponent E. +! I1MACH(13) = EMAX, the largest exponent E. +! +! +!***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +! a portable library, ACM Transactions on Mathematical +! Software 4, 2 (June 1978), pp. 177-188. +!***ROUTINES CALLED XERMSG +!***REVISION HISTORY (YYMMDD) +! 790101 DATE WRITTEN +! 960329 Modified for Fortran 90 (BE after suggestions by EHG) +!***END PROLOGUE D1MACH +! + X = 1.0E0_WP + B = RADIX(X) +! + SELECT CASE (I) + CASE (1) + D1MACH = B**(MINEXPONENT(X)-1) ! the smallest positive magnitude. + CASE (2) + D1MACH = HUGE(X) ! the largest magnitude. + CASE (3) + D1MACH = B**(-DIGITS(X)) ! the smallest relative spacing. + CASE (4) + D1MACH = B**(1-DIGITS(X)) ! the largest relative spacing. + CASE (5) + D1MACH = LOG10(B) + CASE DEFAULT + WRITE (*,10) + STOP + END SELECT +! +! Formats: +! + 10 FORMAT ('1ERROR 1 in D1MACH - I out of bounds') +! + END FUNCTION D1MACH +! +!======================================================================= +! + FUNCTION I1MACH(I) +! + IMPLICIT NONE +! + INTEGER :: I,I1MACH +! + REAL (SP) :: X +! + REAL (WP) :: XX +! +!***BEGIN PROLOGUE I1MACH +!***PURPOSE Return integer machine dependent constants. +!***LIBRARY SLATEC +!***CATEGORY R1 +!***TYPE INTEGER (I1MACH-I) +!***KEYWORDS MACHINE CONSTANTS +!***AUTHOR Fox, P. A., (Bell Labs) +! Hall, A. D., (Bell Labs) +! Schryer, N. L., (Bell Labs) +!***DESCRIPTION +! +! I1MACH can be used to obtain machine-dependent parameters for the +! local machine environment. It is a function subprogram with one +! (input) argument and can be referenced as follows: +! +! K = I1MACH(I) +! +! where I=1,...,16. The (output) value of K above is determined by +! the (input) value of I. The results for various values of I are +! discussed below. +! +! I/O unit numbers: +! I1MACH( 1) = the standard input unit. +! I1MACH( 2) = the standard output unit. +! I1MACH( 3) = the standard punch unit. +! I1MACH( 4) = the standard error message unit. +! +! Words: +! I1MACH( 5) = the number of bits per integer storage unit. +! I1MACH( 6) = the number of characters per integer storage unit. +! +! Integers: +! assume integers are represented in the S-digit, base-A form +! +! sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) +! +! where 0 .LE. X(I) .LT. A for I=0,...,S-1. +! I1MACH( 7) = A, the base. +! I1MACH( 8) = S, the number of base-A digits. +! I1MACH( 9) = A**S - 1, the largest magnitude. +! +! Floating-Point Numbers: +! Assume floating-point numbers are represented in the T-digit, +! base-B form +! sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +! +! where 0 .LE. X(I) .LT. B for I=1,...,T, +! 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. +! I1MACH(10) = B, the base. +! +! Single-Precision: +! I1MACH(11) = T, the number of base-B digits. +! I1MACH(12) = EMIN, the smallest exponent E. +! I1MACH(13) = EMAX, the largest exponent E. +! +! Double-Precision: +! I1MACH(14) = T, the number of base-B digits. +! I1MACH(15) = EMIN, the smallest exponent E. +! I1MACH(16) = EMAX, the largest exponent E. +! +! To alter this function for a particular environment, the desired +! set of DATA statements should be activated by removing the C from +! column 1. Also, the values of I1MACH(1) - I1MACH(4) should be +! checked for consistency with the local operating system. +! +!***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +! a portable library, ACM Transactions on Mathematical +! Software 4, 2 (June 1978), pp. 177-188. +!***ROUTINES CALLED (NONE) +!***REVISION HISTORY (YYMMDD) +! 750101 DATE WRITTEN +! 960411 Modified for Fortran 90 (BE after suggestions by EHG). +! 980727 Modified value of I1MACH(6) (BE after suggestion by EHG). +!***END PROLOGUE I1MACH +! + X = 1.0 + XX = 1.0E0_WP + + SELECT CASE (I) + CASE (1) + I1MACH = 5 ! Input unit + CASE (2) + I1MACH = 6 ! Output unit + CASE (3) + I1MACH = 0 ! Punch unit is no longer used + CASE (4) + I1MACH = 0 ! Error message unit + CASE (5) + I1MACH = BIT_SIZE(I) + CASE (6) + I1MACH = 4 ! Characters per integer is hopefully no + ! longer used. + ! If it is used it has to be set manually. + ! The value 4 is correct on IEEE-machines. + CASE (7) + I1MACH = RADIX(1) + CASE (8) + I1MACH = BIT_SIZE(I) - 1 + CASE (9) + I1MACH = HUGE(1) + CASE (10) + I1MACH = RADIX(X) + CASE (11) + I1MACH = DIGITS(X) + CASE (12) + I1MACH = MINEXPONENT(X) + CASE (13) + I1MACH = MAXEXPONENT(X) + CASE (14) + I1MACH = DIGITS(XX) + CASE (15) + I1MACH = MINEXPONENT(XX) + CASE (16) + I1MACH = MAXEXPONENT(XX) + CASE DEFAULT + WRITE (*,10) + STOP + END SELECT +! +! Formats +! + 10 FORMAT ('Fatal in I1MACH - I out of bounds') +! + END FUNCTION I1MACH +! +!======================================================================= +! + FUNCTION R1MACH (I) +! + IMPLICIT NONE +! + INTEGER :: I +! + REAL (SP) :: B,X,R1MACH +! +!***BEGIN PROLOGUE R1MACH +!***PURPOSE Return floating point machine dependent constants. +!***LIBRARY SLATEC +!***CATEGORY R1 +!***TYPE SINGLE PRECISION (R1MACH-S, D1MACH-D) +!***KEYWORDS MACHINE CONSTANTS +!***AUTHOR Fox, P. A., (Bell Labs) +! Hall, A. D., (Bell Labs) +! Schryer, N. L., (Bell Labs) +!***DESCRIPTION +! +! R1MACH can be used to obtain machine-dependent parameters for the +! local machine environment. It is a function subprogram with one +! (input) argument, and can be referenced as follows: +! +! A = R1MACH(I) +! +! where I=1,...,5. The (output) value of A above is determined by +! the (input) value of I. The results for various values of I are +! discussed below. +! +! R1MACH(1) = B**(EMIN-1), the smallest positive magnitude. +! R1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude. +! R1MACH(3) = B**(-T), the smallest relative spacing. +! R1MACH(4) = B**(1-T), the largest relative spacing. +! R1MACH(5) = LOG10(B) +! +! Assume single precision numbers are represented in the T-digit, +! base-B form +! +! sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +! +! where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and +! EMIN .LE. E .LE. EMAX. +! +! The values of B, T, EMIN and EMAX are provided in I1MACH as +! follows: +! I1MACH(10) = B, the base. +! I1MACH(11) = T, the number of base-B digits. +! I1MACH(12) = EMIN, the smallest exponent E. +! I1MACH(13) = EMAX, the largest exponent E. +! +! +!***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +! a portable library, ACM Transactions on Mathematical +! Software 4, 2 (June 1978), pp. 177-188. +!***ROUTINES CALLED XERMSG +!***REVISION HISTORY (YYMMDD) +! 790101 DATE WRITTEN +! 960329 Modified for Fortran 90 (BE after suggestions by EG) +!***END PROLOGUE R1MACH +! + X = 1.0 + B = RADIX(X) +! + SELECT CASE (I) + CASE (1) + R1MACH = B**(MINEXPONENT(X)-1) ! the smallest positive magnitude. + CASE (2) + R1MACH = HUGE(X) ! the largest magnitude. + CASE (3) + R1MACH = B**(-DIGITS(X)) ! the smallest relative spacing. + CASE (4) + R1MACH = B**(1-DIGITS(X)) ! the largest relative spacing. + CASE (5) + R1MACH = LOG10(B) + CASE DEFAULT + WRITE (*,10) + STOP + END SELECT +! +! Formats: +! + 10 FORMAT ('1ERROR 1 IN R1MACH - I out of bounds') +! + END FUNCTION R1MACH +! +END MODULE MACHINE_ACCURACY diff --git a/New_libraries/DFM_library/ASYMPTOTIC_VALUES_LIBRARY/calc_asymptotic.f90 b/New_libraries/DFM_library/ASYMPTOTIC_VALUES_LIBRARY/calc_asymptotic.f90 new file mode 100644 index 0000000..e508db8 --- /dev/null +++ b/New_libraries/DFM_library/ASYMPTOTIC_VALUES_LIBRARY/calc_asymptotic.f90 @@ -0,0 +1,61 @@ +! +!======================================================================= +! +MODULE ASYMPT +! +! This module defines the asymptotic quantities +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: G0,GI,GR0 +! +END MODULE ASYMPT +! +!======================================================================= +! +MODULE CALC_ASYMPT +! + USE ACCURACY_REAL +! +! This modules computes the asymptotic values: +! +! * gamma_0 +! * gamma_inf +! * g(0) +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_ASYMPT_VALUES +! + + USE ASYMPT +! + USE MATERIAL_PROP, ONLY : DMN,RS + USE EXT_FIELDS, ONLY : T +! + USE GAMMA_ASYMPT + USE PC_VALUES, ONLY : GR0_MODE + USE GR_0 +! + IMPLICIT NONE +! + IF(DMN == '3D') THEN ! + G0 = GAMMA_0_3D(RS,T) ! + GI = GAMMA_I_3D(RS,T) ! + GR0 = GR_0_3D(RS,GR0_MODE) ! + ELSE IF(DMN == '2D') THEN ! + G0 = GAMMA_0_2D(RS,T) ! + GI = GAMMA_I_2D(RS,T) ! + GR0 = GR_0_2D(RS,GR0_MODE) ! + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! not implemented yet + END IF ! +! + END SUBROUTINE CALC_ASYMPT_VALUES +! +END MODULE CALC_ASYMPT diff --git a/New_libraries/DFM_library/ASYMPTOTIC_VALUES_LIBRARY/gamma_asymptotic.f90 b/New_libraries/DFM_library/ASYMPTOTIC_VALUES_LIBRARY/gamma_asymptotic.f90 new file mode 100644 index 0000000..c7fa48c --- /dev/null +++ b/New_libraries/DFM_library/ASYMPTOTIC_VALUES_LIBRARY/gamma_asymptotic.f90 @@ -0,0 +1,404 @@ +! +!======================================================================= +! +MODULE GAMMA_ASYMPT +! + USE ACCURACY_REAL +! +! It contains the following functions/subroutines: +! +! * FUNCTION GAMMA_0_3D(RS,T) +! +! * FUNCTION GAMMA_I_3D(RS,T) +! +! * FUNCTION GAMMA_0_2D(RS,T) +! +! * FUNCTION GAMMA_I_2D(RS,T) +! +! * FUNCTION G0_INF_2D(X,RS,T) +! +! +CONTAINS +! +!======================================================================= +! + FUNCTION GAMMA_0_3D(RS,T) +! +! This function computes the coefficient gamma0 so that: +! +! lim (q --> 0) G(q) = gamma_0 (q / k_F)^2 +! +! +! References: (1) S. Ichimaru, Rev. Mod. Phys. 54, 1017-1059 (1982) +! (3) K. Utsumi and S. Ichimaru, Phys. Rev. B 22, 1522-1533 (1980) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Author : D. Sébilleau +! +! Last modified : 2 Dec 2020 +! +! + USE LF_VALUES, ONLY : GQ_TYPE,G0_TYPE + USE SF_VALUES, ONLY : SQ_TYPE + USE ENERGIES, ONLY : EC_TYPE +! + USE REAL_NUMBERS, ONLY : TWO,FOUR,HALF,FOURTH + USE PI_ETC, ONLY : PI + USE FERMI_SI, ONLY : KF_SI + USE UTILITIES_1, ONLY : ALFA + USE CORRELATION_ENERGIES, ONLY : DERIVE_EC_3D + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE SPECIFIC_INT_2 +! + IMPLICIT NONE +! + INTEGER :: IN_MODE,NMAX +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP) :: GAMMA_0_3D +! + REAL (WP) :: ALPHA + REAL (WP) :: RS2,RS3 + REAL (WP) :: D_EC_1,D_EC_2 + REAL (WP) :: KS,X_TF + REAL (WP) :: X_MAX,IN +! + IF(G0_TYPE == 'EC') THEN ! +! + ALPHA = ALFA('3D') ! + RS2 = RS * RS ! + RS3 = RS2 * RS ! +! +! Computing the correlation energy derivatives +! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! + GAMMA_0_3D = FOURTH - (PI * ALPHA / 24.0E0_WP) * & ! ref. (1) eq. (3.30a) + (RS3 * D_EC_2 - TWO * RS2 * D_EC_1) ! +! + ELSE IF(G0_TYPE == 'SQ') THEN ! +! + IN_MODE = 2 ! + NMAX = 1000 ! number of integration points + X_MAX = 50.0E0_WP ! +! +! Computing Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR('3D',KS) ! + X_TF = KS / KF_SI ! q_{TF} / k_F +! +! Computing the integral +! + CALL INT_SQM1(NMAX,X_MAX,IN_MODE,RS,T,X_TF,0,SQ_TYPE, & ! + GQ_TYPE,IN) +! + GAMMA_0_3D = - HALF * IN ! ref. (3) eq. (5.5) +! + END IF ! +! + END FUNCTION GAMMA_0_3D +! +!======================================================================= +! + FUNCTION GAMMA_I_3D(RS,T) +! +! This function computes the coefficient gamma_i so that: +! +! lim (q --> 0) I(q) = gamma_i (q / k_F)^2 --> 3D +! +! +! References: (1) S. Ichimaru, Rev. Mod. Phys. 54, 1017-1059 (1982) +! (2) N. Iwamoto, Phys. Rev. A 30, 3289-3304 (1984) +! (3) K. Utsumi and S. Ichimaru, Phys. Rev. B 22, 1522-1533 (1980) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Author : D. Sébilleau +! +! Last modified : 2 Dec 2020 +! +! + USE LF_VALUES, ONLY : GQ_TYPE,GI_TYPE + USE SF_VALUES, ONLY : SQ_TYPE + USE ENERGIES, ONLY : EC_TYPE +! + USE REAL_NUMBERS, ONLY : TWO,FOUR,TEN,FIFTH + USE PI_ETC, ONLY : PI + USE FERMI_SI, ONLY : KF_SI + USE UTILITIES_1, ONLY : ALFA + USE CORRELATION_ENERGIES, ONLY : DERIVE_EC_3D,EC_3D + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE SPECIFIC_INT_2 +! + IMPLICIT NONE +! + INTEGER :: IN_MODE,NMAX +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP) :: GAMMA_I_3D +! + REAL (WP) :: ALPHA + REAL (WP) :: RS2 + REAL (WP) :: EC,D_EC_1,D_EC_2 + REAL (WP) :: KS,X_TF + REAL (WP) :: X_MAX,IN +! + IF(GI_TYPE == 'EC') THEN ! +! + ALPHA = ALFA('3D') ! + RS2 = RS * RS ! +! +! Computing the correlation energy derivatives +! + EC = EC_3D(EC_TYPE,1,RS,T) ! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! + GAMMA_I_3D = 0.15E0_WP - (PI * ALPHA / TEN) * & ! ref. (1) eq. (3.30b) + (RS2 * D_EC_1 + TWO* RS * EC) ! +! + ELSE IF(GI_TYPE == 'SQ') THEN ! +! + IN_MODE = 1 ! + NMAX = 1000 ! number of integration points + X_MAX = 50.0E0_WP ! +! +! Computing Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR('3D',KS) ! + X_TF = KS / KF_SI ! q_{TF} / k_F +! +! Computing the integral +! + CALL INT_SQM1(NMAX,X_MAX,IN_MODE,RS,T,X_TF,0,SQ_TYPE, & ! + GQ_TYPE,IN) +! + GAMMA_I_3D = - FIFTH * IN ! ref. (3) eq. (5.6) +! + END IF ! +! + END FUNCTION GAMMA_I_3D +! +!======================================================================= +! + FUNCTION GAMMA_0_2D(RS,T) +! +! This function computes the coefficient gamma0 so that: +! +! lim (q --> 0) G(q) = gamma_i (q / k_F) --> 2D +! +! +! References: (2) N. Iwamoto, Phys. Rev. A 30, 3289-3304 (1984) +! (3) K. Utsumi and S. Ichimaru, Phys. Rev. B 22, 1522-1533 (1980) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Author : D. Sébilleau +! +! Last modified : 3 Dec 2020 +! +! + USE LF_VALUES, ONLY : GQ_TYPE,G0_TYPE + USE SF_VALUES, ONLY : SQ_TYPE + USE ENERGIES, ONLY : EC_TYPE +! + USE REAL_NUMBERS, ONLY : ONE,HALF,EIGHTH + USE PI_ETC, ONLY : PI_INV + USE FERMI_SI, ONLY : KF_SI + USE UTILITIES_1, ONLY : ALFA + USE CORRELATION_ENERGIES, ONLY : DERIVE_EC_2D + USE ENERGIES, ONLY : EC_TYPE + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE SPECIFIC_INT_2 +! + IMPLICIT NONE +! + INTEGER :: IN_MODE,NMAX +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP) :: GAMMA_0_2D +! + REAL (WP) :: ALPHA,RS2,RS3 + REAL (WP) :: D_EC_1,D_EC_2 + REAL (WP) :: KS,X_TF + REAL (WP) :: X_MAX,IN +! + IF(G0_TYPE == 'EC') THEN ! +! + ALPHA = ALFA('2D') ! + RS2 = RS * RS ! + RS3 = RS2 * RS ! +! +! Computing the correlation energy derivatives +! + CALL DERIVE_EC_2D(EC_TYPE,1,RS,T,D_EC_1,D_EC_2) ! +! + GAMMA_0_2D = PI_INV + EIGHTH * ALPHA * ( & ! + RS2 * D_EC_1 - RS3 * D_EC_2 & ! ref. (1) eq. (3.6c) + ) ! +! + ELSE IF(G0_TYPE == 'SQ') THEN ! +! + IN_MODE = 2 ! + NMAX = 1000 ! number of integration points + X_MAX = 50.0E0_WP ! +! +! Computing Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR('2D',KS) ! + X_TF = KS / KF_SI ! q_{TF} / k_F +! +! Computing the integral +! + CALL INT_SQM1(NMAX,X_MAX,IN_MODE,RS,T,X_TF,0,SQ_TYPE, & ! + GQ_TYPE,IN) +! + GAMMA_0_2D = - HALF * IN ! ref. (3) eq. (5.5) +! + END IF ! +! + END FUNCTION GAMMA_0_2D +! +!======================================================================= +! + FUNCTION GAMMA_I_2D(RS,T) +! +! This function computes the coefficient gamma0 so that: +!{\bf 33} +! lim (q --> 0) I(q) = gamma_i (q / k_F) --> 2D +! +! +! References: (2) N. Iwamoto, Phys. Rev. A 30, 3289-3304 (1984) +! (3) K. Utsumi and S. Ichimaru, Phys. Rev. B 22, 1522-1533 (1980) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Author : D. Sébilleau +! +! Last modified : 3 Dec 2020 +! +! + USE LF_VALUES, ONLY : GQ_TYPE,GI_TYPE + USE SF_VALUES, ONLY : SQ_TYPE + USE ENERGIES, ONLY : EC_TYPE +! + USE REAL_NUMBERS, ONLY : TWO,FIVE,SIX,FIFTH + USE PI_ETC, ONLY : PI_INV + USE FERMI_SI, ONLY : KF_SI + USE UTILITIES_1, ONLY : ALFA + USE CORRELATION_ENERGIES, ONLY : DERIVE_EC_2D,EC_2D + USE ENERGIES, ONLY : EC_TYPE + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE SPECIFIC_INT_2 +! + IMPLICIT NONE +! + INTEGER :: IN_MODE,NMAX +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP) :: GAMMA_I_2D +! + REAL (WP) :: ALPHA,RS2 + REAL (WP) :: EC,D_EC_1,D_EC_2 + REAL (WP) :: KS,X_TF + REAL (WP) :: X_MAX,IN +! + IF(GI_TYPE == 'EC') THEN ! +! + ALPHA = ALFA('3D') ! + RS2 = RS * RS ! +! +! Computing the correlation energy derivatives +! + EC = EC_2D(EC_TYPE,RS,T) ! + CALL DERIVE_EC_2D(EC_TYPE,1,RS,T,D_EC_1,D_EC_2) ! +! + GAMMA_I_2D = FIVE * PI_INV / SIX - & ! + (FIVE * ALPHA / 16.0E0_WP) * & ! + (RS2 * D_EC_1 + TWO * RS * EC) ! ref. (2) eq. (D9c) +! + ELSE IF(GI_TYPE == 'SQ') THEN ! +! + IN_MODE = 1 ! + NMAX = 1000 ! number of integration points + X_MAX = 50.0E0_WP ! +! +! Computing Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR('3D',KS) ! + X_TF = KS / KF_SI ! q_{TF} / k_F +! +! Computing the integral +! + CALL INT_SQM1(NMAX,X_MAX,IN_MODE,RS,T,X_TF,0,SQ_TYPE, & ! + GQ_TYPE,IN) +! + GAMMA_I_2D = - FIFTH * IN ! ref. (3) eq. (5.6) +! + END IF ! +! + END FUNCTION GAMMA_I_2D +! +!======================================================================= +! + FUNCTION G0_INF_2D(X,RS,T) +! +! This function computes G(0,infinity), the value of the dynamic +! local-field correction for q --> 0 and omega = infinity, for 2D systems +! +! References: (1) B. Tanatar, Phys. Lett. A 158, 153-157 (1991) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Author : D. Sébilleau +! +! Last modified : 2 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,SEVEN,EIGHT,HALF,THIRD + USE SQUARE_ROOTS, ONLY : SQR2 + USE PI_ETC, ONLY : PI_INV + USE CORRELATION_ENERGIES, ONLY : DERIVE_EC_2D,EC_2D + USE ENERGIES, ONLY : EC_TYPE +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: G0_INF_2D +! + REAL (WP) :: Y + REAL (WP) :: A + REAL (WP) :: EC,D_EC_1,D_EC_2 +! + Y = X + X ! Y = q / k_F +! + A = ONE / SQR2 ! +! +! Computing the correlation energy derivatives +! + EC = EC_2D(EC_TYPE,RS,T) ! + CALL DERIVE_EC_2D(EC_TYPE,1,RS,T,D_EC_1,D_EC_2) ! +! + G0_INF_2D = Y *(0.20E0_WP * HALF * THIRD * PI_INV + & ! + SEVEN * A * RS * EC / EIGHT + & ! ref. (1) eq. (7) + 19.0E0_WP * A * RS * D_EC_1 / 16.0E0_WP) ! +! + END FUNCTION G0_INF_2D +! +END MODULE GAMMA_ASYMPT diff --git a/New_libraries/DFM_library/ASYMPTOTIC_VALUES_LIBRARY/gr_asymptotic.f90 b/New_libraries/DFM_library/ASYMPTOTIC_VALUES_LIBRARY/gr_asymptotic.f90 new file mode 100644 index 0000000..f1dcfdc --- /dev/null +++ b/New_libraries/DFM_library/ASYMPTOTIC_VALUES_LIBRARY/gr_asymptotic.f90 @@ -0,0 +1,195 @@ +! +!======================================================================= +! +MODULE GR_0 +! + USE ACCURACY_REAL +! +! It contains the following functions/subroutines: +! +! * FUNCTION GR_0_2D(RS,GR0_MODE) +! +! * FUNCTION GR_0_3D(RS,GR0_MODE) +! +CONTAINS +! +!======================================================================= +! + FUNCTION GR_0_2D(RS,GR0_MODE) +! +! This function computes the value of the pair correlation function +! g(r) at r = 0 for 2D systems +! +! References: (1) J. Moreno and D. C. Marinescu, +! J. Phys.: Condens. Matter 15, 6321-6329 (2003) +! (2) M. L. Glasser, J. Phys. C: Solid State Phys. 10, +! L121-L123 (1977) +! (3) S. Nagano, K. S. Singwi and S. Ohnishi, +! Phys. Rev. B 29, 1209-1213 (1984) +! S. Nagano, K. S. Singwi and S. Ohnishi, +! Phys. Rev. B 31, 3166 (1985) +! (4) L. Calmels and A. Gold, Phys. Rev. B 57, +! 1436-1443 (1998) +! (5) Z. Qian, Phys. Rev. B 73, 035106 (2006) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * GR0_MODE : g(0) (2D) +! GR0_MODE = 'MOMA' --> Moreno-Marinescu +! GR0_MODE = 'HAFO' --> Hartree-Fock +! GR0_MODE = 'NSOA' --> Nagano-Singwi-Ohnishi +! GR0_MODE = 'CAGO' --> Calmels-Gold +! GR0_MODE = 'QIAN' --> Qian +! +! +! Author : D. Sébilleau +! +! Last modified : 24 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,HALF + USE FERMI_AU, ONLY : KF_AU + USE BESSEL, ONLY : BESSI0 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GR0_MODE +! + REAL (WP), INTENT(IN) :: RS + REAL (WP) :: GR_0_2D +! + REAL (WP) :: L2_1,L2_2,L2_3 + REAL (WP) :: NUM,DEN +! + REAL (WP) :: SQRT +! + IF(GR0_MODE == 'MOMA') THEN ! + GR_0_2D = HALF / (ONE + 0.6032E0_WP * RS + & ! + 0.07263E0_WP * RS * RS)**2 ! ref. (1) eq. (1) + ELSE IF(GR0_MODE == 'HAFO') THEN ! + GR_0_2D = 0.75E0_WP ! ref. (2) + ELSE IF(GR0_MODE == 'NSOA') THEN ! + GR_0_2D = HALF / BESSI0(TWO / SQRT(KF_AU)) ! + ELSE IF(GR0_MODE == 'CAGO') THEN ! + GR_0_2D = HALF / (ONE + TWO / KF_AU + 1.5E0_WP / & ! + (KF_AU * KF_AU)) ! ref. (4) eq. (18) + ELSE IF(GR0_MODE == 'QIAN') THEN ! + L2_1 = RS / SQRT(TWO) ! lambda_2 + L2_2 = L2_1 * L2_1 ! + L2_3 = L2_2 * L2_1 ! + NUM = 15.0E0 * ( 64.0E0_WP + 25.0E0_WP * L2_1 + & ! + THREE * L2_2 ) ! + DEN = 960.0E0_WP + 1335.0E0_WP * L2_1 + & ! + 509.0E0_WP * L2_2 + 64.0E0_WP * L2_3 ! + GR_0_2D = NUM * NUM / (DEN * DEN) ! ref. (5) eq. (10) + END IF ! +! + END FUNCTION GR_0_2D +! +!======================================================================= +! + FUNCTION GR_0_3D(RS,GR0_MODE) +! +! This function computes the value of the pair correlation function +! g(r) at r = 0 for 3D systems +! +! References: (1) B. Davoudi, M. Polini, G. F. Giuliani and M. P. Tosi, +! Phys. Rev. B 64, 153101 (2001) +! (2) G. E. Simion and G. F. Giuliani, Phys. Rev. B 77, +! 035131 (2008) +! (3) A. Holas, P. K. Aravind and K. S. Singwi, +! Phys. Rev. B 20, 4912-4934 (1979) +! (4) S. Ichimaru, Rev. Mod. Phys. 54, 1017-1059 (1982) +! (5) L. Calmels and A. Gold, Phys. Rev. B 57, +! 1436-1443 (1998) +! (6) V. D. Gorobchenko, V. N. Kohn and E. G. Maksimov, +! in "Modern Problems in Condensed Matter" Vol. 24, +! L. V. Keldysh, D. A. Kirzhnitz and A. A. Maradudin ed. +! pp. 87-219 (North-Holland, 1989) +! (7) Z. Qian, Phys. Rev. B 73, 035106 (2006) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * GR0_MODE : g(0) (3D) +! GR0_MODE = 'DPGT' --> Davoudi-Polini-Giuliani-Tosi +! GR0_MODE = 'OVE1' --> Overhauser 1 +! GR0_MODE = 'OVE2' --> Overhauser 2 +! GR0_MODE = 'HASA' --> Holas-Aravind-Singwi (small r_s) +! GR0_MODE = 'ICHI' --> Ichimaru +! GR0_MODE = 'CAGO' --> Calmels-Gold +! GR0_MODE = 'KIMB' --> Kimball +! GR0_MODE = 'QIAN' --> Qian +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,SIX,EIGHT, & + NINE,HALF,FOURTH,FIFTH,EIGHTH + USE FERMI_AU, ONLY : KF_AU + USE PI_ETC, ONLY : PI,PI2,PI_INV + USE UTILITIES_1, ONLY : ALFA + USE BESSEL, ONLY : BESSI1 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GR0_MODE +! + REAL (WP), INTENT(IN) :: RS + REAL (WP) :: GR_0_3D +! + REAL (WP) :: Z + REAL (WP) :: ALPHA + REAL (WP) :: C,D,ARP + REAL (WP) :: L3_1,L3_2,L3_3 + REAL (WP) :: NUM,DEN +! + REAL (WP) :: LOG,SQRT +! + ALPHA = ALFA('3D') ! +! + IF(GR0_MODE == 'DPGT') THEN ! + GR_0_3D = HALF / ( ONE + 1.372E0_WP * RS + & ! + 0.0830E0_WP * RS * RS ) ! ref. (1) eq. (9) + ELSE IF(GR0_MODE == 'OVE1') THEN ! + GR_0_3D = 32.0E0_WP / (EIGHT + THREE * RS)**2 ! ref. (2) eq. (35) + ELSE IF(GR0_MODE == 'HASA') THEN ! + GR_0_3D = HALF * FIFTH * ALPHA * PI_INV * & ! + (PI2 + SIX * LOG(TWO) - THREE) * RS - & ! ref. (3) eq. (7.13) + (1.5E0_WP * ALPHA * PI_INV)**2 * & ! + (THREE - FOURTH * PI2) * RS * RS * LOG(RS) ! + ELSE IF(GR0_MODE == 'ICHI') THEN ! + Z =FOUR * SQRT(ALPHA * RS / PI) ! ref. (4) eq. (3.67) + GR_0_3D = EIGHTH * (Z / BESSI1(Z))**2 ! + ELSE IF(GR0_MODE == 'CAGO') THEN ! + GR_0_3D = HALF * TWO * PI_INV * KF_AU + & ! ref. (5) eq. (11) + 14.0E0_WP / (THREE * (PI * KF_AU)**2) ! + ELSE IF(GR0_MODE == 'OVE2') THEN ! + GR_0_3D = HALF / ( ONE + 0.75E0_WP * RS + & ! + 0.141E0_WP * RS * RS ) ! ref. (5) + ELSE IF(GR0_MODE == 'KIMB') THEN ! + C = FIFTH * (PI2 + SIX * LOG(TWO) - THREE) ! ref. (6) eq. (2.55) + D = NINE * (12.0E0_WP - PI2) / 16.0E0_WP ! ref. (6) eq. (2.55) + ARP = ALPHA * PI_INV * RS ! + GR_0_3D = HALF - C * ARP - D * ARP * ARP * LOG(RS) ! ref. (6) eq. (2.54) + ELSE IF(GR0_MODE == 'QIAN') THEN ! + L3_1 = TWO * ALPHA * RS * PI_INV ! + L3_2 = L3_1 * L3_1 ! + L3_3 = L3_2 * L3_1 ! + NUM = 45.0E0_WP * ( 45.0E0_WP + 24.0E0_WP * L3_1 + & ! + FOUR * L3_2 ) ! + DEN = 2025.0E0_WP + 3105.0E0_WP * L3_1 + & ! + 1512.0E0_WP * L3_2 + 256.0E0_WP * L3_3 ! + GR_0_3D = NUM * NUM / (DEN * DEN) ! ref. (7) eq. (9) + END IF ! +! + END FUNCTION GR_0_3D +! +END MODULE GR_0 + diff --git a/New_libraries/DFM_library/ASYMPTOTIC_VALUES_LIBRARY/sq_asymptotic.f90 b/New_libraries/DFM_library/ASYMPTOTIC_VALUES_LIBRARY/sq_asymptotic.f90 new file mode 100644 index 0000000..4facbc6 --- /dev/null +++ b/New_libraries/DFM_library/ASYMPTOTIC_VALUES_LIBRARY/sq_asymptotic.f90 @@ -0,0 +1,64 @@ +! +!======================================================================= +! +MODULE SQ_I +! + USE ACCURACY_REAL +! +! It contains the following functions/subroutines: +! +! * FUNCTION SQ_I_3D(X,GR0_MODE) +! +CONTAINS +! +! +!======================================================================= +! + FUNCTION SQ_I_3D(X,RS,GR0_MODE) +! +! This function computes the asymptotic behaviour of the static +! structure factor at infinity: +! +! lim (q --> infinity) S(q) +! +! References: (1) N. Iwamoto, E. Krotscheck and D. Pines, +! Phys. Rev. B 28, 3936-3951 (1984) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * GR0_MODE : g(0) (3D) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,SIX + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE GR_0, ONLY : GR_0_3D +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GR0_MODE +! + REAL (WP), INTENT(IN) :: X,RS + REAL (WP) :: SQ_I_3D + REAL (WP) :: COEF +! + COEF = ONE / (SIX * PI * BOHR * KF_SI) ! +! + SQ_I_3D = ONE - COEF * GR_0_3D(RS,GR0_MODE) / (X * X * X * X) ! +! + RETURN +! + END +! +END MODULE SQ_I + diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_1.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_1.f90 new file mode 100644 index 0000000..d7efacf --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_1.f90 @@ -0,0 +1,532 @@ +! +!======================================================================= +! +MODULE CALCULATORS_1 +! + USE ACCURACY_REAL +! +! This module contains the subroutines allowing to compute +! various properties of the electron/plasma liquids: +! +! * dielectric function : CALC_EPS +! * polarization function : CALC_POL +! * susceptibility function : CALC_SUS +! * electrical conductivity : CALC_CDV +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_EPS(X,E,EPSR,EPSI) +! +! This subroutine computes the dielectric function epsilon(q, omega) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Output parameters: +! +! * E : energy array +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ZERO,FOURTH,SMALL + USE MATERIAL_PROP, ONLY : RS + USE EXT_FIELDS, ONLY : T,H +! + USE E_GRID +! + USE OUT_VALUES_1, ONLY : I_DF + USE PRINT_FILES, ONLY : IO_DF +! + USE DF_VALUES, ONLY : ESTDY,EPS_T,D_FUNC + USE DFUNC_STATIC + USE DFUNCT_STAN_DYNAMIC + USE DFUNCL_STAN_DYNAMIC + USE DFUNCL_MAGN_DYNAMIC +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL,D_FUNCT +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: EPSR(NSIZE),EPSI(NSIZE),E(NSIZE) + REAL (WP) :: Y + REAL (WP) :: REPS,IEPS + REAL (WP) :: Z,EN,KS,A,NU +! + REAL (WP) :: FLOAT +! + INTEGER :: IE +! + Y = X + X ! q / k_F +! + IF(ESTDY == ' STATIC') THEN ! +! +! Static dielectric function +! + IF(EPS_T == 'LONG') THEN ! +! + D_FUNCL = D_FUNC ! + CALL DFUNCL_STATIC(X,D_FUNCL,REPS,IEPS) ! longitudinal eps + EPSR(1) = REPS ! + EPSI(1) = IEPS ! +! + IF(I_DF == 1) THEN ! + WRITE(IO_DF,*) Y,REPS,IEPS ! + END IF ! +! + ELSE ! + D_FUNCT = D_FUNC ! + CONTINUE ! transverse eps + END IF ! +! + ELSE ! +! +! Dynamic dielectric function +! + DO IE = 1, N_E ! energy loop +! + EN = E_MIN + FLOAT(IE - 1) * E_STEP ! EN = hbar omega / E_F +! + Z = FOURTH * EN / (X * X) ! Z = omega / omega_q +! + IF(EPS_T == 'LONG') THEN ! longitudinal eps +! + D_FUNCL = D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNCL,IE,REPS,IEPS) ! no magnetic field + ELSE ! + CALL DFUNCL_DYNAMIC_M(X,Z,KS,A,NU,D_FUNCL,REPS,IEPS) ! magnetic field + END IF ! + ELSE ! transverse eps + D_FUNCT = D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCT_DYNAMIC(X,Z,D_FUNCT,REPS,IEPS) ! no magnetic field + ELSE ! + CONTINUE ! magnetic field + END IF ! + END IF ! +! + EPSR(IE)=REPS ! + EPSI(IE)=IEPS ! + E(IE)=EN ! +! + IF(I_DF == 1) THEN ! writing to + WRITE(IO_DF,*) Y,EN,REPS,IEPS ! file + END IF ! +! + END DO ! end of energy loop +! + END IF ! +! + END SUBROUTINE CALC_EPS +! +!======================================================================= +! + SUBROUTINE CALC_POL(X) +! +! This subroutine computes the polarisation function Pi(q, omega) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * DIM : problem dimension +! +! +! Output parameters: +! +! * E : energy array +! * POLR : real part of the dielectric function +! * POLI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE EXT_FIELDS, ONLY : T,H + USE REAL_NUMBERS, ONLY : ZERO,TWO,FOURTH,SMALL + USE FERMI_SI, ONLY : KF_SI + USE DF_VALUES, ONLY : ESTDY,EPS_T,D_FUNC + USE MATERIAL_PROP, ONLY : RS,DMN + USE UTILITIES_3, ONLY : EPS_TO_PI + USE COULOMB_K, ONLY : COULOMB_FF +! + USE E_GRID + USE UNITS, ONLY : UNIT +! + USE DFUNC_STATIC + USE DFUNCT_STAN_DYNAMIC + USE DFUNCL_STAN_DYNAMIC + USE DFUNCL_MAGN_DYNAMIC +! + USE OUT_VALUES_1, ONLY : I_PZ + USE PRINT_FILES, ONLY : IO_PZ +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL,D_FUNCT +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: REPS,IEPS,RPOL,IPOL + REAL (WP) :: Z,EN,Q,VC,KS,A,NU + REAL (WP) :: Y +! + REAL (WP) :: FLOAT +! + INTEGER :: IE +! + Y = X + X ! q / k_F + Q = TWO * X * KF_SI ! q in SI +! +! Computing the Coulomb potential +! + CALL COULOMB_FF(DMN,UNIT,Q,ZERO,VC) ! +! + IF(ESTDY == ' STATIC') THEN ! +! +! Static polarisation function +! + IF(EPS_T == 'LONG') THEN ! +! + D_FUNCL = D_FUNC ! + CALL DFUNCL_STATIC(X,D_FUNCL,REPS,IEPS) ! longitudinal eps +! + CALL EPS_TO_PI(REPS,IEPS,VC,RPOL,IPOL) ! +! + IF(I_PZ == 1) THEN ! + WRITE(IO_PZ,*) Y,RPOL,IPOL ! + END IF ! +! + ELSE ! + D_FUNCT = D_FUNC ! + CONTINUE ! transverse eps + END IF ! +! + ELSE ! +! +! Dynamic polarisation function +! + DO IE = 1, N_E ! energy loop +! + EN = E_MIN + FLOAT(IE - 1) * E_STEP ! E = hbar omega / E_F +! + Z = FOURTH * EN / (X * X) ! Z = omega / omega_q +! + IF(EPS_T == 'LONG') THEN ! longitudinal eps +! + D_FUNCL = D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNCL,IE,REPS,IEPS) ! no magnetic field + ELSE ! + CALL DFUNCL_DYNAMIC_M(X,Z,KS,A,NU,D_FUNCL,REPS,IEPS) ! magnetic field + END IF ! + ELSE ! transverse eps + D_FUNCT = D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCT_DYNAMIC(X,Z,D_FUNCT,REPS,IEPS) ! no magnetic field + ELSE ! + CONTINUE ! magnetic field + END IF ! + END IF ! +! + CALL EPS_TO_PI(REPS,IEPS,VC,RPOL,IPOL) ! +! + IF(I_PZ == 1) THEN ! writing to + WRITE(IO_PZ,*) Y,EN,RPOL,IPOL ! file + END IF ! +! + END DO ! end of energy loop +! + END IF ! +! + END SUBROUTINE CALC_POL +! +!======================================================================= +! + SUBROUTINE CALC_SUS(X) +! +! This subroutine computes the susceptibility function chi(q, omega) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * DIM : problem dimension +! +! +! Output parameters: +! +! * E : energy array +! * SUSR : real part of the susceptibility function +! * SUSI : imaginary part of the susceptibility function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ZERO,TWO,FOURTH,SMALL + USE FERMI_SI, ONLY : KF_SI + USE DF_VALUES, ONLY : ESTDY,EPS_T,D_FUNC + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T,H + USE UTILITIES_3, ONLY : EPS_TO_CHI + USE COULOMB_K, ONLY : COULOMB_FF +! + USE E_GRID + USE UNITS, ONLY : UNIT +! + USE DFUNC_STATIC + USE DFUNCT_STAN_DYNAMIC + USE DFUNCL_STAN_DYNAMIC + USE DFUNCL_MAGN_DYNAMIC +! + USE OUT_VALUES_1, ONLY : I_SU + USE PRINT_FILES, ONLY : IO_SU +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL,D_FUNCT +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: REPS,IEPS,RSUS,ISUS + REAL (WP) :: Z,EN,Q,VC,KS,A,NU + REAL (WP) :: Y +! + REAL (WP) :: FLOAT +! + INTEGER :: IE +! + Y = X + X ! q / k_F + Q = TWO * X * KF_SI ! q in SI +! +! Computing the Coulomb potential +! + CALL COULOMB_FF(DMN,UNIT,Q,ZERO,VC) ! +! + IF(ESTDY == ' STATIC') THEN ! +! +! Static susceptibility function +! + IF(EPS_T == 'LONG') THEN ! +! + D_FUNCL = D_FUNC ! + CALL DFUNCL_STATIC(X,D_FUNCL,REPS,IEPS) ! longitudinal eps +! + CALL EPS_TO_CHI(REPS,IEPS,VC,RSUS,ISUS) ! +! + IF(I_SU == 1) THEN ! + WRITE(IO_SU,*) Y,RSUS,ISUS ! + END IF ! +! + ELSE ! + D_FUNCT = D_FUNC ! + CONTINUE ! transverse eps + END IF ! +! + ELSE ! +! +! Dynamic suceptibility function +! + DO IE = 1, N_E ! energy loop +! + EN = E_MIN + FLOAT(IE - 1) * E_STEP ! E = hbar omega / E_F +! + Z = FOURTH * EN / (X * X) ! Z = omega / omega_q +! + IF(EPS_T == 'LONG') THEN ! longitudinal eps +! + D_FUNCL = D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNCL,IE,REPS,IEPS) ! no magnetic field + ELSE ! + CALL DFUNCL_DYNAMIC_M(X,Z,KS,A,NU,D_FUNCL,REPS,IEPS) ! magnetic field + END IF ! + ELSE ! transverse eps + D_FUNCT = D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCT_DYNAMIC(X,Z,D_FUNCT,REPS,IEPS) ! no magnetic field + ELSE ! + CONTINUE ! magnetic field + END IF ! + END IF ! +! + CALL EPS_TO_CHI(REPS,IEPS,VC,RSUS,ISUS) ! +! + IF(I_SU == 1) THEN ! writing to + WRITE(IO_SU,*) Y,EN,RSUS,ISUS ! file + END IF ! +! + END DO ! end of energy loop +! + END IF ! +! + END SUBROUTINE CALC_SUS +! +!======================================================================= +! + SUBROUTINE CALC_CDV(X) +! +! This subroutine computes the conductivity function sigma(q, omega) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Output parameters: +! +! * E : energy array +! * CDVR : real part of the conductivity function +! * CDVI : imaginary part of the conductivity function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ZERO,TWO,FOURTH,SMALL + USE FERMI_SI, ONLY : KF_SI + USE DF_VALUES, ONLY : ESTDY,EPS_T,D_FUNC + USE MATERIAL_PROP, ONLY : RS + USE EXT_FIELDS, ONLY : T,H + USE UTILITIES_3, ONLY : EPS_TO_SIGMA +! + USE E_GRID +! + USE DFUNC_STATIC + USE DFUNCT_STAN_DYNAMIC + USE DFUNCL_STAN_DYNAMIC + USE DFUNCL_MAGN_DYNAMIC +! + USE OUT_VALUES_1, ONLY : I_CD + USE PRINT_FILES, ONLY : IO_CD +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL,D_FUNCT +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: REPS,IEPS,EPSR,EPSI,RCDV,ICDV + REAL (WP) :: Z,EN,KS,A,NU + REAL (WP) :: Y +! + REAL (WP) :: FLOAT +! + INTEGER :: IE +! + Y = X + X ! q / k_F +! + IF(ESTDY == ' STATIC') THEN ! +! +! Static susceptibility function +! + IF(EPS_T == 'LONG') THEN ! +! + D_FUNCL = D_FUNC ! + CALL DFUNCL_STATIC(X,D_FUNCL,REPS,IEPS) ! longitudinal eps +! + CALL EPS_TO_SIGMA(X,ZERO,REPS,IEPS,RCDV,ICDV) ! +! + IF(I_CD == 1) THEN ! + WRITE(IO_CD,*) Y,RCDV,ICDV ! + END IF ! +! + ELSE ! + D_FUNCT = D_FUNC ! + CONTINUE ! transverse eps + END IF ! +! + ELSE ! +! +! Dynamic suceptibility function +! + DO IE = 1, N_E ! energy loop +! + EN = E_MIN + FLOAT(IE - 1) * E_STEP ! E = hbar omega / E_F +! + Z = FOURTH * EN / (X * X) ! Z = omega / omega_q +! + IF(EPS_T == 'LONG') THEN ! longitudinal eps +! + D_FUNCL = D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNCL,IE,REPS,IEPS) ! no magnetic field + ELSE ! + CALL DFUNCL_DYNAMIC_M(X,Z,KS,A,NU,D_FUNCL,REPS,IEPS) ! magnetic field + END IF ! + ELSE ! transverse eps + D_FUNCT = D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCT_DYNAMIC(X,Z,D_FUNCT,REPS,IEPS) ! no magnetic field + ELSE ! + CONTINUE ! magnetic field + END IF ! + END IF ! +! + CALL EPS_TO_SIGMA(X,Z,REPS,IEPS,RCDV,ICDV) ! +! + IF(I_CD == 1) THEN ! writing to + WRITE(IO_CD,*) Y,EN,RCDV,ICDV ! file + END IF ! +! + END DO ! end of energy loop +! + END IF ! +! + END SUBROUTINE CALC_CDV +! +END MODULE CALCULATORS_1 diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_2.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_2.f90 new file mode 100644 index 0000000..6f1686d --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_2.f90 @@ -0,0 +1,485 @@ +! +!======================================================================= +! +MODULE CALCULATORS_2 +! + USE ACCURACY_REAL +! +! This module contains the subroutines allowing to compute +! various properties of the electron/plasma liquids: +! +! * plasmon dispersion : CALC_PDI +! * electron-hole dispersion : CALC_EHD +! * two electron-hole dispersion : CALC_E2D +! * k-space e-e potential : CALC_EEK +! * r-space e-e potential : CALC_EER +! * plasmon kinetic energy : CALC_EKP +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_PDI(X) +! +! +! This subroutine computes the analytical plasmon dispersion +! without damping +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Output variables : +! +! * ENE_P_Q : plasmon energy at q in J +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Dec 2020 +! +! +! + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T + USE REAL_NUMBERS, ONLY : ONE,TWO + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PLASMON_DISPERSION + USE PLASMON_DISP_REAL + USE SCREENING_TYPE + USE SCREENING_VEC + USE COULOMB_K +! + USE OUT_VALUES_2, ONLY : I_PD + USE PRINT_FILES, ONLY : IO_PD +! +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X +! + REAL (WP) :: ENE_P_Q + REAL (WP) :: Y +! + IF(PL_DISP == ' EXACT') GO TO 10 ! +! + Y = X + X ! q / k_F +! + IF(DMN == '3D') THEN ! + CALL PLASMON_DISP_3D(X,RS,T,PL_DISP,ENE_P_Q) ! + ELSE IF(DMN == '2D') THEN ! + CALL PLASMON_DISP_2D(X,RS,T,PL_DISP,ENE_P_Q) ! + ELSE IF(DMN == '1D') THEN ! + CALL PLASMON_DISP_1D(X,RS,T,PL_DISP,ENE_P_Q) ! + END IF ! +! +! Writes the plasmon dispersion as a function of x +! + IF(I_PD == 1) THEN ! + WRITE(IO_PD,*) Y,ENE_P_Q / EF_SI ! x : q/k_F, y : E/E_F + END IF ! +! + 10 RETURN ! +! + END SUBROUTINE CALC_PDI +! +!======================================================================= +! + SUBROUTINE CALC_EHD +! +! This subroutine gives the electron-hole pair dispersion curves. +! +! ---> The result is given in eV <--- +! +! We have written: hbar^2 / 2m = a_0^2 * Ryd where a_0 is Bohr's radius +! and Ryd is one Rydberg in eV +! +! +! Output variables : +! +! * EH_M : right-handside dispersion curve +! * EH_P : left-handside dispersion curve +! +! +! In order to compare to the plasmon dispersion, where the coeffiecients +! of (hbar omega)^2 have been stored, we store here the coefficients +! of (EH_M)^2 = AE(0)+AE(1)*Q + AE(2)*Q^2 + AE(3)*Q^3 + AE(4)*Q^4 +! +! +! Author : D. Sébilleau +! +! Last modified : 15 Sep 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE MATERIAL_PROP, ONLY : DMN + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,FOURTH + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE ENE_CHANGE, ONLY : RYD + USE DISP_COEF_EH +! + USE Q_GRID +! + USE OUT_VALUES_2, ONLY : I_EH + USE PRINT_FILES, ONLY : IO_EH +! + IMPLICIT NONE +! + REAL (WP) :: QM,Q + REAL (WP) :: EH_P(NSIZE),EH_M(NSIZE) +! + REAL (WP) :: EF,KF,Y,Q0,Q02,STEP +! + REAL (WP) :: FLOAT,ABS +! + INTEGER :: QN,I,IO +! + KF = BOHR * KF_SI ! k_F in unit of a_O^{-1} + EF = KF * KF * RYD ! E_F in eV +! + STEP = Q_STEP * KF_SI ! step in SI +! +! Initialisation of the coefficients +! + DO I = 0, 6 ! + AE(I) = ZERO ! + END DO ! +! +! Loop on q-points +! + DO QN = 1, N_Q ! +! + Q = Q_MIN * KF_SI + FLOAT(QN - 1) * STEP ! step incremented +! + Q0 = BOHR * Q ! q in unit of a_O^{-1} + Q02 = Q0 * Q0 ! + Y = Q0 / KF ! dimensionless momentum +! + IF(DMN == '3D') THEN ! +! +!.......... 3D case .......... +! + EH_P(QN) = (Q02 + TWO * Q0 * KF) * RYD ! + EH_M(QN) = (Q02 - TWO * Q0 * KF) * RYD ! + AE(2) = FOUR * KF * KF * FOURTH ! division by 4 because + AE(3) = FOUR * KF * FOURTH ! AU = Hartree = 2 Rydbergs + AE(4) = ONE * FOURTH ! and AE in AU +! + ELSE IF(DMN == '2D') THEN ! +! +!.......... 2D case .......... +! +! Reference: G. F. Giuliani and J. J. Quinn, Phys. Rev. B 26, 4421 (1982) +! + EH_P(QN) = (TWO * Q0 * KF + Q02) * RYD ! + EH_M(QN) = (TWO * Q0 * KF - Q02) * RYD ! + AE(2) = FOUR * KF * KF * FOURTH ! division by 4 because + AE(3) = FOUR * KF * FOURTH ! AU = Hartree = 2 Rydbergs + AE(4) = ONE * FOURTH ! and AE in AU +! + ELSE IF(DMN == '1D') THEN ! +! +!.......... 1D case .......... +! + EH_P(QN) = ABS(Q02 + TWO * Q0 * KF) * RYD ! + EH_M(QN) = ABS(Q02 - TWO * Q0 * KF) * RYD ! + AE(2) = FOUR * KF * KF * FOURTH ! division by 4 because + AE(3) = FOUR * KF * FOURTH ! AU = Hartree = 2 Rydbergs + AE(4) = ONE * FOURTH ! and AE in AU +! + END IF ! +! +! Writes the dispersion curves E/E_F as a function of q/k_F +! + IF(I_EH == 1) THEN ! + WRITE(IO_EH,*) Y,EH_P(QN) / EF,EH_M(QN) / EF ! x : q/k_F, y : E/E_F + END IF ! +! + END DO ! +! + END SUBROUTINE CALC_EHD +! +!======================================================================= +! + SUBROUTINE CALC_E2D +! +! This subroutine gives the 2 electron-hole pairs dispersion curves. +! +! Note: in this case, there is no letf-hand side, but only a limit +! on the right-hand side +! +! References: (1) M. E. Bachlechner, A. Holas, H. M. Böhm and A. Schinner, +! Nucl. Instr. and Meth. B 115, 23-26 (1996) +! +! ---> The result is given in eV <--- +! +! +! Output variables : +! +! * TWO_EH_M : right-handside dispersion curve +! +! +! Author : D. Sébilleau +! +! Last modified : 15 Sep 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE MATERIAL_PROP, ONLY : DMN + USE REAL_NUMBERS, ONLY : ZERO,TWO + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE ENE_CHANGE, ONLY : RYD +! + USE Q_GRID +! + USE OUT_VALUES_2, ONLY : I_E2 + USE PRINT_FILES, ONLY : IO_E2 +! + IMPLICIT NONE +! + INTEGER :: QN +! + REAL (WP) :: QM,Q + REAL (WP) :: Y,Q0,Q02,XN,STEP + REAL (WP) :: N_EH_M + REAL (WP) :: EF,KF +! + REAL (WP) :: FLOAT +! + XN = TWO ! number of e-h pairs created +! + STEP = Q_STEP * KF_SI ! step in SI +! + KF = BOHR * KF_SI ! k_F in unit of a_O^{-1} + EF = KF * KF * RYD ! E_F in eV +! +! Loop on q-points +! + DO QN = 1, N_Q ! +! + Q = Q_MIN * KF_SI + FLOAT(QN - 1) * STEP ! step incremented +! + Q0 = BOHR * Q ! q in unit of a_O^{-1} + Q02 = Q0 * Q0 ! + Y = Q0 / KF ! dimensionless momentum +! + IF(DMN == '3D') THEN ! +! +!.......... 3D case .......... +! + IF(Y <= TWO * XN) THEN ! + N_EH_M = ZERO ! + ELSE ! + N_EH_M = (Q02 - TWO * XN * Q0 * KF) * RYD / XN ! ref. (1) eq. (9) + END IF ! +! + ELSE IF(DMN == '2D') THEN ! +! +!.......... 2D case .......... +! + CONTINUE +! + ELSE IF(DMN == '1D') THEN ! +! +!.......... 1D case .......... +! + CONTINUE +! +! + END IF ! +! +! Writes the dispersion curves E/E_F as a function of q/k_F +! + IF(I_E2 == 1) THEN ! + WRITE(IO_E2,*) Y,N_EH_M / EF ! x : q/k_F, y : E/E_F + END IF ! +! + END DO ! +! + END SUBROUTINE CALC_E2D +! +!======================================================================= +! + SUBROUTINE CALC_EEK(X) +! +! +! This subroutine computes the electron-electron interaction potential +! in the k-space +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 7 Oct 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE MATERIAL_PROP, ONLY : DMN,RS + USE EXT_FIELDS, ONLY : T + USE UNITS + USE SCREENING_TYPE + USE SCREENING_VEC + USE INTERACTION_POTENTIALS_K +! + USE Q_GRID +! + USE EL_ELE_INTER +! + USE REAL_NUMBERS, ONLY : ONE + USE FERMI_AU, ONLY : KF_AU + USE FERMI_SI, ONLY : KF_SI +! + USE OUT_VALUES_2, ONLY : I_CK + USE PRINT_FILES, ONLY : IO_CK +! + IMPLICIT NONE +! + INTEGER :: IQ +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: KS_SI,KS + REAL (WP) :: Q,VQ +! + REAL (WP) :: FLOAT +! +! Computing the screening vector +! + CALL SCREENING_VECTOR(SC_TYPE,DMN,X,RS,T,KS_SI) ! +! +! Screening vector in units of UNIK +! + IF(UNIK == 'SI') THEN ! + KS = KS_SI ! + ELSE IF(UNIK == 'AU') THEN ! + KS = KS_SI * KF_AU / KF_SI ! + END IF ! +! +! Loop on q-points +! + DO IQ = 1,N_Q ! +! + Q = Q_MIN * KF_SI + FLOAT(IQ - 1) * Q_STEP ! step incremented +! + CALL INTERACT_POT_K_3D(INT_POT,UNIT,UNIK,ONE,ONE,ONE,ONE, & ! + Q,KS,VQ) ! +! + IF(I_CK == 1) THEN ! + WRITE(IO_CK,*) Q,VQ ! + END IF ! +! + END DO ! +! + END SUBROUTINE CALC_EEK +! +!======================================================================= +! + SUBROUTINE CALC_EER(X) +! +! +! This subroutine computes the electron-electron interaction potential +! in the real space +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Apr 2021 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE MATERIAL_PROP, ONLY : DMN,RS + USE EXT_FIELDS, ONLY : T + USE SCREENING_TYPE + USE SCREENING_VEC + USE INTERACTION_POTENTIALS_R +! + USE R_GRID +! + USE REAL_NUMBERS, ONLY : ONE + USE FERMI_AU, ONLY : KF_AU + USE FERMI_SI, ONLY : KF_SI +! + USE OUT_VALUES_2, ONLY : I_CR + USE PRINT_FILES, ONLY : IO_CR +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: UNIT +! + INTEGER :: IR +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: KS_SI,KS + REAL (WP) :: R,VR +! + REAL (WP) :: FLOAT +! + UNIT = 'CGS' ! +! +! Computing the screening vector +! + CALL SCREENING_VECTOR(SC_TYPE,DMN,X,RS,T,KS_SI) ! +! +! Screening vector in units of 1/a_0 +! + KS = KS_SI * KF_AU / KF_SI ! +! + DO IR = 1,N_R ! r loop +! + R = R_MIN + FLOAT(IR - 1) * R_STEP ! r/a0 point +! + CALL INTERACT_POT_R_3D(UNIT,R,ONE,ONE,KS,VR) ! +! + IF(I_CR == 1) THEN ! + WRITE(IO_CR,*) R,VR ! + END IF ! +! + END DO ! +! + END SUBROUTINE CALC_EER +! +!======================================================================= +! + SUBROUTINE CALC_EKP(X) +! +! +! This subroutine computes the plasmon kinetic energy +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 29 Oct 2020 +! +! +! + USE OUT_VALUES_2, ONLY : I_PK + USE PRINT_FILES, ONLY : IO_PK +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: Y,Y2 +! + Y = X + X ! q / k_F + Y2 = Y * Y ! +! + IF(I_PK == 1) THEN ! + WRITE(IO_PK,*) X,Y2 ! + END IF ! +! + END SUBROUTINE CALC_EKP +! +END MODULE CALCULATORS_2 diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_3.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_3.f90 new file mode 100644 index 0000000..ccada0a --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_3.f90 @@ -0,0 +1,1491 @@ +! +!======================================================================= +! +MODULE CALCULATORS_3 +! + USE ACCURACY_REAL +! +! This module contains the subroutines allowing to compute +! various properties of the electron/plasma liquids: +! +! * local field corrections : CALC_LFC +! * I(q) function : CALC_IQF +! * structure factor : CALC_SFC +! * pair correlation function : CALC_PCF +! +! * pair distribution function : CALC_PDF +! * vertex function : CALC_VTX +! * plasmon damping coefficient: CALC_DMP +! +! * q bounds : CALC_QBD +! * relaxation time : CALC_RLX +! * screening wave number : CALC_SCR +! * omega = q * v_F : CALC_QVF +! +! * moments of Im[epsilon] : CALC_MEP +! * moments of S(q,omega) : CALC_MSF +! * moments of loss function : CALC_MLO +! +! * zeros of Re [epsilon] : CALC_RE0 +! +! * inelastic mean free path : CALC_MFP +! +! * Fourier-space Nevalinna : CALC_NEV +! * time-space memory function : CALC_MEM +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_LFC(X) +! +! This subroutine computes the local field correction G(q, omega) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Output parameters: +! +! * E : energy array +! * LFCR : real part of local field correction +! * LFCI : imaginary part of local field correction +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 3 Dec 2020 +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ZERO + USE MATERIAL_PROP, ONLY : RS + USE EXT_FIELDS, ONLY : T + USE LF_VALUES, ONLY : GSTDY,GQ_TYPE,GQO_TYPE + USE SF_VALUES, ONLY : SQ_TYPE +! + USE E_GRID +! + USE LOCAL_FIELD_STATIC + USE LOCAL_FIELD_STATIC_2 + USE LOCAL_FIELD_DYNAMIC +! + USE OUT_VALUES_3, ONLY : I_LF + USE PRINT_FILES, ONLY : IO_LF +! + IMPLICIT NONE +! + REAL (WP) :: X + REAL (WP) :: LFCR(NSIZE),LFCI(NSIZE),E(NSIZE) + REAL (WP) :: RLFC,ILFC + REAL (WP) :: EN,ETA + REAL (WP) :: Y +! + INTEGER :: IE,LOGF +! + LOGF = 6 ! +! + Y = X + X ! q/k_F +! + IF(GSTDY == ' STATIC') THEN ! +! +! Static local field correction: +! +! 1) G(q) not based on S(q) +! + IF(GQ_TYPE /= 'HNCA' .AND. GQ_TYPE /= 'IKPA') THEN ! + CALL LFIELD_STATIC(X,RS,T,GQ_TYPE,RLFC) ! + ELSE +! +! 1) G(q) based on S(q) +! + IF(SQ_TYPE /= 'GEA' .AND. SQ_TYPE /= 'ICH' .AND. & ! + SQ_TYPE /= 'PKA' .AND. SQ_TYPE /= 'SIN' .AND. & ! + SQ_TYPE /= 'SPA') THEN ! + CALL LFIELD_STATIC_2(X,RS,T,GQ_TYPE,RLFC) ! + ELSE ! + WRITE(LOGF,10) ! + STOP ! + END IF ! +! + END IF ! +! + LFCR(1) = RLFC ! + LFCI(1) = ZERO ! +! + IF(I_LF == 1) THEN ! writing to + WRITE(IO_LF,*) Y,ZERO,RLFC,ZERO ! file + END IF ! +! + ELSE ! +! +! Dynamic local field correction +! + CALL LFIELD_DYNAMIC(X,RS,E_MIN,E_MAX,N_E,T,ETA, & ! + GQO_TYPE,E,LFCR,LFCI) ! +! + IF(I_LF == 1) THEN ! + DO IE = 1, N_E ! writing to + WRITE(IO_LF,*) Y,E(IE),LFCR(IE),LFCI(IE) ! file + END DO ! + END IF ! +! + END IF ! +! +! Format: +! + 10 FORMAT(//,10X,'<<<<< ERROR IN CALCULATOR_3 :: CALC_LFC >>>>>', & + /,10X,'<<<<< WRONG CHOICE OF GQ_TYPE :: SQ_TYPE >>>>>', & + //,10X,' --> G(q) choice uses S(q) which uses G(q) <--',//) +! + END SUBROUTINE CALC_LFC +! +!======================================================================= +! + SUBROUTINE CALC_IQF(X) +! +! This subroutine computes the local field correction I(q) = G(q,inf) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Output parameters: +! +! * IQR : real part of I(q) +! * IQI : imaginary of I(q) +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 15 Sep 2020 +! + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T +! + USE REAL_NUMBERS, ONLY : ZERO + USE LF_VALUES, ONLY : GQ_TYPE,IQ_TYPE + USE SF_VALUES, ONLY : SQ_TYPE + USE ENERGIES, ONLY : EC_TYPE + USE IQ_FUNCTIONS_1 +! + USE OUT_VALUES_3, ONLY : I_IQ + USE PRINT_FILES, ONLY : IO_IQ +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: IQ + REAL (WP) :: Y +! + Y = X + X ! q/k_F +! + IF(DMN == '3D') THEN ! + CALL IQ_3D(X,RS,IQ_TYPE,IQ) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! not implemented yet + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! not implemented yet + END IF ! +! + IF(I_IQ == 1) THEN ! writing to + WRITE(IO_IQ,*) Y,IQ ! file + END IF ! +! + END SUBROUTINE CALC_IQF +! +!======================================================================= +! + SUBROUTINE CALC_SFC(X) +! +! This subroutine computes the structure factor S(q, omega) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Output parameters: +! +! * E : energy array +! * SFCR : real part of the structure factor +! * SFCI : imaginary part of structure factor +! +! +! Note: as S(q,omega) is proportional to the inverse of a +! frequency, we renormalize it by multiplicating it +! by E_F / h_bar to obtain a dimensionless quantity +! +! +! +! Author : D. Sébilleau +! +! Last modified : 21 Dec 2020 +! + USE DIMENSION_CODE, ONLY : NSIZE +! + USE MATERIAL_PROP, ONLY : DMN,RS + USE EXT_FIELDS, ONLY : T +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOURTH + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : EF_SI +! + USE E_GRID +! + USE LF_VALUES, ONLY : GQ_TYPE,IQ_TYPE + USE SF_VALUES + USE STRUCTURE_FACTOR_STATIC + USE STRUCTURE_FACTOR_STATIC_2 + USE STRUCTURE_FACTOR_DYNAMIC + USE STRUCTURE_FACTOR_DYNAMIC_2 +! + USE UTIC_VALUES + USE RELAXATION_TIME_STATIC + USE PLASMON_ENE_SI + USE PLASMON_DISP_REAL + USE DECAY_RATE + USE UTIC_PARAMETERS +! + USE OUT_VALUES_3, ONLY : I_SF + USE PRINT_FILES, ONLY : IO_SF +! + IMPLICIT NONE +! + REAL (WP) :: X + REAL (WP) :: RSFC,ISFC + REAL (WP) :: Z,EN,SQ,SQ_RN + REAL (WP) :: Y + REAL (WP) :: HOM_Q + REAL (WP) :: E1,E2,E3,E4,E5,E6 +! + REAL (WP) :: FLOAT +! + INTEGER :: IE,LOGF +! + LOGF = 6 ! +! + Y = X + X ! q/k_F +! +! Storing the omega-independent UTIC parameters whenever necessary +! + IF(SQO_TYPE == 'UTI') THEN ! + IF(DMN == '3D') THEN ! + TAU_Q = UTIC_RT_3D(X,RS,T,SQ_TYPE,GQ_TYPE) ! tau(q) + CALL PLASMON_DISP_3D_2(X,RS,T,'UTI_MOD',HOM_Q) ! + OM_Q = HOM_Q / H_BAR ! omega(q) + GAM_Q = UTIC_DR_3D(X,RS,T,SQ_TYPE,GQ_TYPE,IQ_TYPE) ! gamma(q) + CALL UTIC_PARAM(X,RS,T,MO_Q,MO_0) ! Omega(q), Omega(0) +! + E1 = H_BAR / (TAU_Q * EF_SI) ! + E2 = ENE_P_SI / EF_SI ! + E3 = H_BAR * OM_Q / EF_SI ! + E4 = ABS(H_BAR * GAM_Q / EF_SI) ! + E5 = H_BAR * MO_Q / EF_SI ! + E6 = H_BAR * MO_0 / EF_SI ! +! + WRITE(1,*) Y,E1,E2,E3,E4,E5,E6 ! + END IF + END IF ! +! + IF(SSTDY == ' STATIC') THEN ! +! +! Static structure factor +! +! 1) S(q) not based on G(q) +! + IF(SQ_TYPE /= 'GEA' .AND. SQ_TYPE /= 'ICH' .AND. & ! + SQ_TYPE /= 'PKA' .AND. SQ_TYPE /= 'SIN' .AND. & ! + SQ_TYPE /= 'SPA') THEN ! + CALL STFACT_STATIC(X,RS,T,SQ_TYPE,RSFC) ! +! +! 2) S(q) based on G(q) +! + ELSE ! +! + IF(GQ_TYPE /= 'HNCA' .AND. GQ_TYPE /= 'IKPA') THEN ! + CALL STFACT_STATIC_2(X,RS,T,SQ_TYPE,RSFC) ! + ELSE + WRITE(LOGF,10) ! + STOP ! + END IF ! +! + END IF ! + IF(I_SF == 1) THEN ! writing to + WRITE(IO_SF,*) Y,ZERO,RSFC,ZERO ! file + END IF ! +! + ELSE ! +! +! Dynamic structure factor +! + DO IE = 1, N_E ! energy loop +! + EN = E_MIN + FLOAT(IE - 1) * E_STEP ! E = hbar omega / E_F +! + Z = FOURTH * EN / (X * X) ! Z = omega / omega_q +! + IF(SQO_TYPE /= 'EPS') THEN ! + CALL STFACT_DYNAMIC(X,Z,RS,T,SQO_TYPE,SQ_TYPE,SQ) ! + ELSE + CALL STFACT_DYNAMIC_FROM_EPS(X,Z,RS,T,SQ) ! + END IF ! +! + SQ_RN = SQ * EF_SI / H_BAR ! renormalized S(q,omega) +! + IF(I_SF == 1) THEN ! writing to + WRITE(IO_SF,*) Y,EN,SQ_RN,ZERO ! file + END IF ! +! + END DO ! +! + END IF ! +! +! Format: +! + 10 FORMAT(//,10X,'<<<<< ERROR IN CALCULATOR_3 :: CALC_SFC >>>>>', & + /,10X,'<<<<< WRONG CHOICE OF SQ_TYPE :: GQ_TYPE >>>>>', & + //,10X,' --> S(q) choice uses G(q) which uses S(q) <--',//) +! + END SUBROUTINE CALC_SFC +! +!======================================================================= +! + SUBROUTINE CALC_PCF +! +! This subroutine computes the pair correlation function g(r) +! +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * DMN : problem dimension +! +! +! Output parameters: +! +! * GR : g(r) ar r +! +! +! +! Author : D. Sébilleau +! +! Last modified : 29 Jul 2020 +! +! + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T + USE PC_VALUES, ONLY : GR_TYPE + USE PD_VALUES, ONLY : RH_TYPE + USE PAIR_CORRELATION +! + USE R_GRID +! + USE OUT_VALUES_3, ONLY : I_PC + USE PRINT_FILES, ONLY : IO_PC +! + IMPLICIT NONE +! + REAL (WP) :: R,GR +! + REAL (WP) :: FLOAT +! + INTEGER :: IR +! + DO IR = 1, N_R ! r loop +! + R = R_MIN + FLOAT(IR - 1) * R_STEP ! r/a0 point +! + IF(DMN == '3D') THEN ! + CALL PAIR_CORRELATION_3D(R,RS,T,GR_TYPE,RH_TYPE,GR) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! + END IF ! +! + IF(I_PC == 1) THEN ! + WRITE(IO_PC,*) R,GR ! + END IF ! +! + ENDDO ! +! + END SUBROUTINE CALC_PCF +! +!======================================================================= +! + SUBROUTINE CALC_PDF +! +! This subroutine computes the pair distribution function rho2(r) +! +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * DMN : problem dimension +! +! +! Output parameters: +! +! * R2 : rho2(r) ar r +! +! +! +! Author : D. Sébilleau +! +! Last modified : 29 Jul 2020 +! +! + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T + USE PD_VALUES, ONLY : RH_TYPE + USE PAIR_DISTRIBUTION +! + USE R_GRID +! + USE OUT_VALUES_3, ONLY : I_P2 + USE PRINT_FILES, ONLY : IO_P2 +! + IMPLICIT NONE +! + REAL (WP) :: R,R2 +! + REAL (WP) :: FLOAT +! + INTEGER :: IR +! + DO IR = 1, N_R ! r loop +! + R = R_MIN + FLOAT(IR - 1) * R_STEP ! r/a0 point +! + IF(DMN == '3D') THEN ! + CALL PAIR_DISTRIBUTION_3D(R,RS,T,RH_TYPE,R2) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! + END IF ! +! + IF(I_P2 == 1) THEN ! + WRITE(IO_P2,*) R,R2 ! + END IF ! +! + END DO ! +! + END SUBROUTINE CALC_PDF +! +!======================================================================= +! + SUBROUTINE CALC_VTX(X) +! +! This subroutine computes the vertex function Gamma(q, omega) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Output parameters: +! +! * E : energy array +! * VTXR : real part of vertex function +! * VTXI : imaginary part vertex function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2020 +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOURTH,SMALL,INF + USE COMPLEX_NUMBERS, ONLY : IC + USE MATERIAL_PROP, ONLY : DMN,RS + USE EXT_FIELDS, ONLY : T,H + USE LF_VALUES, ONLY : GSTDY,GQ_TYPE,GQO_TYPE + USE DF_VALUES, ONLY : ESTDY,EPS_T,D_FUNC +! + USE E_GRID +! + USE SCREENING_TYPE + USE SCREENING_VEC +! + USE LOCAL_FIELD_STATIC + USE LOCAL_FIELD_DYNAMIC + USE DFUNC_STATIC + USE DFUNCT_STAN_DYNAMIC + USE DFUNCL_STAN_DYNAMIC + USE DFUNCL_MAGN_DYNAMIC +! + USE OUT_VALUES_3, ONLY : I_VX + USE PRINT_FILES, ONLY : IO_VX +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL,D_FUNCT +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: E(NSIZE) + REAL (WP) :: LFCR(NSIZE),LFCI(NSIZE) + REAL (WP) :: EPSR(NSIZE),EPSI(NSIZE) + REAL (WP) :: VTXR,VTXI + REAL (WP) :: RLFC,ILFC + REAL (WP) :: REPS,IEPS + REAL (WP) :: ETA + REAL (WP) :: Z,EN + REAL (WP) :: Y +! + REAL (WP) :: A,NU,KS_SI +! + REAL (WP) :: FLOAT +! + COMPLEX (WP) :: EPS,LFC,VTX +! + INTEGER :: IE +! + A = ZERO ! temporary + NU = ZERO ! +! + Y = X + X ! q / k_F +! +! Computing the screening wave vector +! + CALL SCREENING_VECTOR(SC_TYPE,DMN,X,RS,T,KS_SI) +! +! 1) Computing the local field correction +! + IF(GSTDY == ' STATIC') THEN ! +! +! Static local field correction +! + CALL LFIELD_STATIC(X,RS,T,GQ_TYPE,RLFC) ! +! + LFCR(1) = RLFC ! + LFCI(1) = ZERO ! +! + ELSE ! +! +! Dynamic local field correction +! + CALL LFIELD_DYNAMIC(X,RS,E_MIN,E_MAX,N_E,T,ETA, & ! + GQO_TYPE,E,LFCR,LFCI) ! +! + END IF ! +! +! 2) Computing the dielectric function +! + IF(ESTDY == ' STATIC') THEN ! +! +! Static dielectric function +! + IF(EPS_T == 'LONG') THEN ! +! + D_FUNCL = 'RPA1' ! + CALL DFUNCL_STATIC(X,D_FUNCL,REPS,IEPS) ! longitudinal eps + EPSR(1) = REPS ! + EPSI(1) = IEPS ! +! + ELSE ! + D_FUNCT = D_FUNC ! + CONTINUE ! transverse eps + END IF ! +! + ELSE ! +! +! Dynamic dielectric function +! + DO IE = 1, N_E ! energy loop +! + EN = E_MIN + FLOAT(IE - 1) * E_STEP ! EN = hbar omega / E_F +! + Z = FOURTH * EN / (X * X) ! Z = omega / omega_q +! + IF(EPS_T == 'LONG') THEN ! longitudinal eps +! + D_FUNCL = 'RPA1' ! + IF(H < SMALL) THEN ! + CALL DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNCL,IE,REPS,IEPS) ! no magnetic field + ELSE ! + CALL DFUNCL_DYNAMIC_M(X,Z,KS_SI,A,NU,D_FUNCL,REPS,IEPS) ! magnetic field + END IF ! + ELSE ! transverse eps + D_FUNCT = D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCT_DYNAMIC(X,Z,D_FUNCT,REPS,IEPS) ! no magnetic field + ELSE ! + CONTINUE ! magnetic field + END IF ! + END IF ! +! + EPSR(IE) = REPS ! + EPSI(IE) = IEPS ! + E(IE) = EN ! +! + END DO ! end of energy loop +! + END IF ! +! +! 3) Computing the vertex function and writing to file +! +! As we have chosen D_FUNCL='RPA1', PI = PI0 and the +! vertex function is: +! +! 1 +! --------------------- +! 1 + LFC * (EPS - 1) +! +! + IF(I_VX == 1) THEN ! + DO IE = 1, N_E ! +! + LFC = LFCR(IE) + IC * LFCI(IE) ! + EPS = EPSR(IE) + IC * EPSI(IE) ! + VTX = ONE / (ONE + LFC * (EPS - ONE)) ! + VTXR = REAL(VTX,KIND=WP) ! + VTXI = AIMAG(VTX) ! + + WRITE(IO_VX,*) Y,E(IE),VTXR,VTXI ! +! + END DO ! + END IF ! +! + END SUBROUTINE CALC_VTX +! +!======================================================================= +! + SUBROUTINE CALC_DMP(IX,X) +! +! This subroutine computes the plasmon damping coefficient gamma_q +! +! +! Im[ epsilon ] | +! gamma_q = - _______________ | +! | +! d Re[ epsilon ]/d omega | omega=Omega_q +! +! where epsilon is the dielectric function. +! +! +! Input parameters: +! +! * IX : index of X-point +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Output parameters: +! +! * E : energy array +! * VTXR : real part of vertex function +! * VTXI : imaginary part vertex function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE MATERIAL_PROP, ONLY : RS + USE EXT_FIELDS, ONLY : T +! + USE REAL_NUMBERS, ONLY : ZERO,TWO,FOURTH,TTINY,INF + USE FERMI_SI, ONLY : KF_SI +! + USE E_GRID +! + USE DF_VALUES, ONLY : D_FUNC +! + USE INTEGRATION, ONLY : INTEGR_L + USE DFUNCL_STAN_DYNAMIC +! + USE FIND_ZERO, ONLY : FIND_ZERO_FUNC + USE PLASMON_DAMPING, ONLY : EXACT_DAMPING +! + USE OUT_VALUES_3, ONLY : I_DC + USE PRINT_FILES, ONLY : IO_DC +! + IMPLICIT NONE +! + INTEGER,INTENT(IN) :: IX + INTEGER :: IE + INTEGER :: IDERIV +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: D,TAU + REAL (WP) :: Y,E,V,Z + REAL (WP) :: REPS,IEPS + REAL (WP) :: EN(NSIZE) + REAL (WP) :: EPSR(NSIZE),EPSI(NSIZE) + REAL (WP) :: ZEROF,GAMMA_Q +! + REAL (WP) :: FLOAT +! + IDERIV = 5 ! +! + Y = X + X ! q/k_F +! +! Constructing the e-grid +! + DO IE = 1, N_E ! E_F +! + E = E_MIN + FLOAT(IE - 1) * E_STEP ! in units of + V = E ! hbar * omega / E_F + Z = FOURTH * V / (X * X) ! omega / omega_q +! +! Computing the dielectric function epsilon(q,E) +! + CALL DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNC,IE,REPS,IEPS) ! +! + EN(IE) = E ! + EPSR(IE) = REPS ! + EPSI(IE) = IEPS ! +! + END DO ! +! +! Computing the plasmon energy at q: +! Only the highest energy zero is kept +! + CALL FIND_ZERO_FUNC(EN,EPSR,N_E,ZEROF) ! +! +! Computing the damping coefficient +! + CALL EXACT_DAMPING(IX,IDERIV,N_E,EN,EPSR,EPSI,ZEROF,GAMMA_Q) ! +! + IF(I_DC == 1) THEN ! + WRITE(IO_DC,*) Y,GAMMA_Q ! + END IF ! +! + END SUBROUTINE CALC_DMP +! +!======================================================================= +! + SUBROUTINE CALC_QBD +! +! This subroutine computes the plasmon q-bounds +! +! +! Output parameters: +! +! * Q_MIN : plasmon lower q-bound +! * Q_MAX : plasmon upper q-bound +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Oct 2020 +! +! + USE Q_BOUNDS +! + USE OUT_VALUES_3, ONLY : I_QC + USE PRINT_FILES, ONLY : IO_QC +! + IMPLICIT NONE +! + REAL (WP) :: Q_MIN,Q_MAX +! + CALL QBOUNDS(Q_MIN,Q_MAX) +! + IF(I_QC == 1) THEN ! + WRITE(IO_QC,*) Q_MIN,Q_MAX ! + END IF ! +! + END SUBROUTINE CALC_QBD +! +!======================================================================= +! + SUBROUTINE CALC_RLX(X) +! +! This subroutine computes the relaxation time +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Output parameters: +! +! * TAU : relaxation time +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 7 Oct 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN,RS + USE EXT_FIELDS, ONLY : T + USE PLASMA, ONLY : ZION +! + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE DAMPING_VALUES, ONLY : VI_TYPE + USE RELAXATION_TIME_STATIC + USE VISCOSITY +! + USE EL_PHO_INTER +! + USE REAL_NUMBERS, ONLY : ZERO +! + USE OUT_VALUES_3, ONLY : I_RL + USE PRINT_FILES, ONLY : IO_RL +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: Y,ETA,KD_SI,TAU + REAL (WP) :: LR,S_L +! + Y = X + X ! q/k_F +! + LR = ZERO ! residual mfp (temporary) + S_L = ZERO ! scattering length (temporary) +! +! Computing the Debye momentum +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! +! Computation of the viscosity +! + IF(DMN == '3D') THEN ! + CALL VISCOSITY_3D(RS,T,ZION,KD_SI,X,ZERO,NA,MA,RA, & ! + DEBYE_T,EP_C,LR,VI_TYPE,ETA) ! + ELSE IF(DMN == '2D') THEN ! + CALL VISCOSITY_2D(T,S_L,VI_TYPE,ETA) ! + ELSE IF(DMN == '1D') THEN ! + ETA = ZERO ! not yet implemented + END IF ! +! +! Computing the relaxation time +! + CALL RELAXATION_TIME(X,TAU) ! +! + IF(I_RL == 1) THEN ! + WRITE(IO_RL,*) Y,TAU ! + END IF ! +! + END SUBROUTINE CALC_RLX +! +!======================================================================= +! + SUBROUTINE CALC_SCR(X) +! +! This subroutine computes the screening wave number +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Output parameters: +! +! * KS : screening wave number +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 13 Oct 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN,RS + USE EXT_FIELDS, ONLY : T +! + USE CONSTANTS_P1, ONLY : BOHR + USE SCREENING_TYPE + USE SCREENING_VEC + USE SCREENING_VEC2 +! + USE OUT_VALUES_3, ONLY : I_KS + USE PRINT_FILES, ONLY : IO_KS +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: Y + REAL (WP) :: KS_SI,KS +! + Y = X + X ! q / k_F +! + IF(SC_TYPE == 'DH' .OR. SC_TYPE == 'TF') THEN ! + CALL SCREENING_VECTOR(SC_TYPE,DMN,X,RS,T,KS_SI) ! + ELSE ! + CALL SCREENING_VECTOR2(SC_TYPE,DMN,X,RS,T,KS_SI) ! + END IF ! +! + KS = KS_SI * BOHR ! KS in units of a_0 +! + IF(I_KS == 1) THEN ! + WRITE(IO_KS,*) Y,KS ! + END IF ! +! + END SUBROUTINE CALC_SCR +! +!======================================================================= +! + SUBROUTINE CALC_QVF(X) +! +! This subroutine computes the omega = q * v_F (U = 1) equation, as well +! as U + X = 1 and U - X = 1 +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Output parameters: +! +! * OM : omega +! +! +! hbar omega +! Note: We use here the fact that V = ------------ = 4 * U * X +! E_F +! +! +! Therefore U = 1 <==> V = 4 * X +! U + X = 1 <==> V = 4 * (1 - X) * X +! U - X = 1 <==> V = 4 * (1 + X) * X +! +! +! Author : D. Sébilleau +! +! Last modified : 25 Nox 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,FOUR +! + USE OUT_VALUES_3, ONLY : I_OQ + USE PRINT_FILES, ONLY : IO_OQ +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: Y,OM0,OM1,OM2 +! + Y = X + X ! q / k_F +! + OM0 = FOUR * X ! + OM1 = FOUR * (ONE - X) * X ! + OM2 = FOUR * (ONE + X) * X ! +! + IF(I_OQ == 1) THEN ! + WRITE(IO_OQ,*) Y,OM0,OM1,OM2 ! + END IF ! +! + END SUBROUTINE CALC_QVF +! +!======================================================================= +! + SUBROUTINE CALC_MEP(X) +! +! This subroutine computes the moments of the +! imaginary part of the dielectric function +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Output parameters: +! +! * MEP : moment of S(q,omega) function in reduced units +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 21 Oct 2020 +! +! + USE MOMENTS + USE MOMENTS_CALC +! + USE OUT_VALUES_3, ONLY : I_ME + USE PRINT_FILES, ONLY : IO_ME +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: Y,MEP +! + Y = X + X ! q/k_F +! + CALL MOMENTS_EPSILON(X,N_M,MEP) ! +! + IF(I_ME == 1) THEN ! writing to + WRITE(IO_ME,*) Y,MEP ! file + END IF ! +! + END SUBROUTINE CALC_MEP +! +!======================================================================= +! + SUBROUTINE CALC_MSF(X) +! +! This subroutine computes the moments of the +! dynamical structure factor +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Output parameters: +! +! * MSF : moment of S(q,omega) function in reduced units +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Oct 2020 +! +! + USE MOMENTS + USE MOMENTS_CALC +! + USE OUT_VALUES_3, ONLY : I_MS + USE PRINT_FILES, ONLY : IO_MS +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: Y,MSF +! + Y = X + X ! q/k_F +! + CALL MOMENTS_STRUCT_FACTOR(X,N_M,MSF) ! +! + IF(I_MS == 1) THEN ! writing to + WRITE(IO_MS,*) Y,MSF ! file + END IF ! +! + END SUBROUTINE CALC_MSF +! +!======================================================================= +! + SUBROUTINE CALC_MLO(X) +! +! This subroutine computes the moments of the loss function +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Output parameters: +! +! * MLO : moment of loss function in reduced units +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Oct 2020 +! +! + USE MOMENTS + USE MOMENTS_CALC +! + USE OUT_VALUES_3, ONLY : I_ML + USE PRINT_FILES, ONLY : IO_ML +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: Y,MLO +! + Y = X + X ! q/k_F +! + CALL MOMENTS_LOSS_FUNCTION(X,N_M,MLO) ! +! + IF(I_ML == 1) THEN ! writing to + WRITE(IO_ML,*) Y,MLO ! file + END IF ! +! + END SUBROUTINE CALC_MLO +! +!======================================================================= +! + SUBROUTINE CALC_RE0(X) +! +! This subroutine computes the zeros of the real part of +! the dielectric function: Re[ epsilon(q,omega) ] +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Output parameters: +! +! * Y : q / k_F +! * RE0 : zeros of real part dielectric function +! +! +! Note: By setting a non-zero value to variable SHF, the subroutine +! will solve Re[ epsilon(q,omega) ] = - SHF +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE MATERIAL_PROP, ONLY : DMN,RS + USE EXT_FIELDS, ONLY : T,H + USE DF_VALUES, ONLY : ESTDY,EPS_T,D_FUNC +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ZERO,FOURTH,SMALL,INF +! + USE E_GRID +! + USE SCREENING_TYPE + USE SCREENING_VEC +! + USE DFUNC_STATIC + USE DFUNCT_STAN_DYNAMIC + USE DFUNCL_STAN_DYNAMIC + USE DFUNCL_MAGN_DYNAMIC +! + USE FIND_ZERO +! + USE OUT_VALUES_3, ONLY : I_ZE + USE PRINT_FILES, ONLY : IO_ZE +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL,D_FUNCT +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: EN + REAL (WP) :: Y,Z + REAL (WP) :: REPS,IEPS + REAL (WP) :: E(NSIZE) + REAL (WP) :: EPSR(NSIZE) + REAL (WP) :: ZEROF +! + REAL (WP) :: A,NU,KS_SI + REAL (WP) :: LFT,TAU,DR,D,ETA +! + REAL (WP), PARAMETER :: SHF = 0.0E0_WP +! + REAL (WP) :: FLOAT +! + INTEGER :: IE +! + A = ZERO ! temporary + NU = ZERO ! +! + Y = X + X ! q / k_F +! +! Computing the screening wave vector +! + CALL SCREENING_VECTOR(SC_TYPE,DMN,X,RS,T,KS_SI) +! +! Computing the dynamic dielectric function +! + DO IE = 1, N_E ! energy loop +! + EN = E_MIN + FLOAT(IE - 1) * E_STEP ! EN = hbar omega / E_F +! + Z = FOURTH * EN / (X * X) ! Z = omega / omega_q +! + IF(EPS_T == 'LONG') THEN ! longitudinal eps +! + D_FUNCL = D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNCL,IE,REPS,IEPS) ! no magnetic field + ELSE ! + CALL DFUNCL_DYNAMIC_M(X,Z,KS_SI,A,NU,D_FUNCL,REPS,IEPS) ! magnetic field + END IF ! + ELSE ! transverse eps + D_FUNCT = D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCT_DYNAMIC(X,Z,D_FUNCT,REPS,IEPS) ! no magnetic field + ELSE ! + CONTINUE ! magnetic field + END IF ! + END IF ! +! + EPSR(IE) = REPS + SHF ! + E(IE) = EN ! +! + END DO ! end of energy loop +! +! Computing the zeros of EPSR +! + IF(I_ZE == 1) THEN ! + CALL PRINT_ZERO_FUNC(Y,E,EPSR,N_E) ! + END IF ! +! + END SUBROUTINE CALC_RE0 +! +!======================================================================= +! + SUBROUTINE CALC_MFP +! +! This subroutine computes the inelastic mean free path +! +! +! +! Author : D. Sébilleau +! +! Last modified : 19 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : SMALL + USE FERMI_SI, ONLY : EF_SI + USE ENE_CHANGE, ONLY : EV,ANG +! + USE ELECTRON_MEAN_FREE_PATH + USE IMFP +! + USE OUT_VALUES_3, ONLY : I_MF + USE PRINT_FILES, ONLY : IO_MF +! + IMPLICIT NONE +! + INTEGER :: IE + INTEGER, PARAMETER :: NE_MAX = 1480 ! max. number of energy points +! + REAL (WP) :: LAMBDA + REAL (WP) :: E_STEP + REAL (WP) :: E,EK + REAL (WP) :: E_MIN,E_MAX +! + REAL (WP) :: FLOAT +! + E_MIN = EK_INI ! lower value in eV + E_MAX = EK_FIN ! upper value in eV +! + E_STEP = (E_MAX - E_MIN) / FLOAT(NE_MAX - 1) ! e-step in eV +! + DO IE = 1, NE_MAX ! +! + E = E_MIN + FLOAT(IE - 1) * E_STEP ! E in eV + EK = E * EV ! E in SI +! + CALL MEAN_FREE_PATH(EK,LAMBDA) ! IMFP in SI + LAMBDA = LAMBDA / ANG ! IMFP in Angström +! + IF(I_MF == 1) THEN ! + WRITE(IO_MF,*) E,LAMBDA ! + END IF ! +! + END DO ! end of energy loop +! + END SUBROUTINE CALC_MFP +! +!======================================================================= +! + SUBROUTINE CALC_NEV(X) +! +! This subroutine computes the Fourier space Nevalinna/memory function +! +! +! Author : D. Sébilleau +! +! Last modified : 28 Jan 2021 +! +! + USE MATERIAL_PROP, ONLY : RS + USE EXT_FIELDS, ONLY : T +! + USE E_GRID +! + USE REAL_NUMBERS, ONLY : FOURTH +! + USE RELAXATION_TIME_STATIC + USE MEMORY_FUNCTIONS_F + USE NEVALINNA_FUNCTIONS +! + USE DF_VALUES, ONLY : D_FUNC,NEV_TYPE,MEM_TYPE,ALPHA,BETA + USE DAMPING_SI + USE DAMPING_VALUES, ONLY : PCT +! + USE OUT_VALUES_3, ONLY : I_NV + USE PRINT_FILES, ONLY : IO_NV +! + IMPLICIT NONE +! + INTEGER :: IE,I_F +! + REAL (WP), INTENT(IN) :: X +! + REAL (WP) :: Y,Z + REAL (WP) :: E + REAL (WP) :: NEVR,NEVI +! + REAL (WP) :: FLOAT,REAL,AIMAG +! + COMPLEX (WP) :: FUNC +! + Y = X + X ! q / k_F +! +! Check for Nevanlinna or memory function --> switch I_F +! + IF(D_FUNC(1:3) == 'NEV') THEN ! + I_F = 1 ! + ELSE IF(D_FUNC(1:3) == 'MEM') THEN ! + I_F = 2 ! + ELSE ! + I_F = 0 ! + END IF ! +! + DO IE = 1, N_E ! energy loop +! + E = E_MIN + FLOAT(IE - 1) * E_STEP ! E = hbar omega / E_F +! + Z = FOURTH * E / (X * X) ! Z = omega / omega_q +! + IF(I_F == 1) THEN ! + FUNC = NEVAN2(X,Z,RS,T,TAU,NEV_TYPE) ! + ELSE IF(I_F == 2) THEN ! + FUNC = MEMORY_F(E,TAU,TAU2,PCT,ALPHA,BETA,MEM_TYPE) ! + END IF ! +! + NEVR = REAL(FUNC,KIND=WP) ! + NEVI = AIMAG(FUNC) ! +! + IF(I_NV == 1) THEN ! + WRITE(IO_NV,*) Y,E,NEVR,NEVI ! + END IF ! +! + END DO ! end of energy loop +! + END SUBROUTINE CALC_NEV +! +!======================================================================= +! + SUBROUTINE CALC_MEM +! +! This subroutine computes the time-domain memory function +! as a function of t / tau +! +! When tau is q-dependent, the only vamue considered is the first one +! +! Author : D. Sébilleau +! +! Last modified : 28 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,TEN,HALF +! + USE Q_GRID, ONLY : Q_MIN +! + USE DF_VALUES, ONLY : ALPHA,BETA,MEM_TYPE + USE DAMPING_SI + USE DAMPING_VALUES, ONLY : PCT +! + USE RELAXATION_TIME_STATIC + USE MEMORY_FUNCTIONS_T +! + USE OUT_VALUES_3, ONLY : I_MT + USE PRINT_FILES, ONLY : IO_MT +! + IMPLICIT NONE +! + INTEGER :: IT + INTEGER, PARAMETER :: NT_MAX = 200 ! max. number of time points +! + REAL (WP) :: MEMR + REAL (WP) :: T ! t / tau + REAL (WP) :: T1 ! t + REAL (WP) :: T_MIN,T_MAX,T_STEP + REAL (WP) :: X +! + REAL (WP) :: FLOAT +! + T_MIN = ZERO ! lower time value + T_MAX = TEN ! upper time value + X = Q_MIN * HALF ! initial value of q / 2 k_F +! + T_STEP = (T_MAX - T_MIN) / FLOAT(NT_MAX - 1) ! t-step in units of tau +! + DO IT = 1, NT_MAX ! +! + T = T_MIN + FLOAT(IT - 1) * T_STEP ! t in units of tau +! + T1 = T * TAU ! time is SI +! + MEMR = MEMORY_T(T1,TAU,TAU2,PCT,ALPHA,BETA,MEM_TYPE) * & ! + TAU * TAU ! in units of 1 / tau^2 +! + IF(I_MT == 1) THEN ! + WRITE(IO_MT,*) T,MEMR ! + END IF ! +! + END DO ! end of time loop +! + END SUBROUTINE CALC_MEM +! +END MODULE CALCULATORS_3 diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_4.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_4.f90 new file mode 100644 index 0000000..8d1c8b6 --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_4.f90 @@ -0,0 +1 @@ + diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_5.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_5.f90 new file mode 100644 index 0000000..654ad3d --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_5.f90 @@ -0,0 +1,154 @@ +! +!======================================================================= +! +MODULE CALCULATORS_5 +! +! This module contains the subroutines allowing to compute +! various Fermi properties of the electron/plasma liquids: +! +! * Fermi energy : CALC_EFF +! * Fermi momentum : CALC_KFF +! * Fermi velocity : CALC_VFF +! * Fermi temperature : CALC_TFF +! * Fermi density of states : CALC_NFF +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_EFF +! +! This subroutine computes the Fermi energy and writes it into a file +! +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Sep 2020 +! +! + USE FERMI_SI, ONLY : EF_SI + USE ENE_CHANGE, ONLY : EV +! + USE OUT_VALUES_5, ONLY : I_EF + USE PRINT_FILES, ONLY : IO_EF +! + IMPLICIT NONE +! + IF(I_EF == 1) THEN ! + WRITE(IO_EF,*) EF_SI / EV ! + END IF ! +! + END SUBROUTINE CALC_EFF +! +!======================================================================= +! + SUBROUTINE CALC_KFF +! +! This subroutine computes the Fermi momentum and writes it into a file +! +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Sep 2020 +! +! + USE FERMI_SI, ONLY : KF_SI + USE ENE_CHANGE, ONLY : ANG +! + USE OUT_VALUES_5, ONLY : I_KF + USE PRINT_FILES, ONLY : IO_KF +! + IMPLICIT NONE +! + IF(I_KF == 1) THEN ! + WRITE(IO_KF,*) KF_SI * ANG ! + END IF ! +! + END SUBROUTINE CALC_KFF +! +!======================================================================= +! + SUBROUTINE CALC_VFF +! +! This subroutine computes the Fermi velocity and writes it into a file +! +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Sep 2020 +! +! + USE FERMI_SI, ONLY : VF_SI +! + USE OUT_VALUES_5, ONLY : I_VF + USE PRINT_FILES, ONLY : IO_VF +! + IMPLICIT NONE +! + IF(I_VF == 1) THEN ! + WRITE(IO_VF,*) VF_SI ! + END IF ! +! + END SUBROUTINE CALC_VFF +! +!======================================================================= +! + SUBROUTINE CALC_TFF +! +! This subroutine computes the Fermi temperature and writes it into a file +! +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Sep 2020 +! +! + USE FERMI_SI, ONLY : TF_SI +! + USE OUT_VALUES_5, ONLY : I_TE + USE PRINT_FILES, ONLY : IO_TE +! + IMPLICIT NONE +! + IF(I_TE == 1) THEN ! + WRITE(IO_TE,*) TF_SI ! + END IF ! +! + END SUBROUTINE CALC_TFF +! +!======================================================================= +! + SUBROUTINE CALC_NFF +! +! This subroutine computes the Fermi density of states +! and writes it into a file +! +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Sep 2020 +! +! + USE FERMI_SI, ONLY : NF_SI + USE ENE_CHANGE, ONLY : EV +! + USE OUT_VALUES_5, ONLY : I_DL + USE PRINT_FILES, ONLY : IO_DL +! + IMPLICIT NONE +! + IF(I_DL == 1) THEN ! + WRITE(IO_DL,*) NF_SI * EV ! + END IF ! +! + END SUBROUTINE CALC_NFF +! +END MODULE CALCULATORS_5 diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_6.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_6.f90 new file mode 100644 index 0000000..8d1c8b6 --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_6.f90 @@ -0,0 +1 @@ + diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_7.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_7.f90 new file mode 100644 index 0000000..751eb2a --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_7.f90 @@ -0,0 +1,215 @@ +! +!======================================================================= +! +MODULE CALCULATORS_7 +! + USE ACCURACY_REAL +! +! This module contains the subroutines allowing to compute +! various properties of the electron/plasma liquids: +! +! * Exchange energy : CALC_EXX +! * Exchange-correlation energy : CALC_EXC +! * correlation energy : CALC_ECO +! * kinetic energy : CALC_KIN +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_EXX +! +! This subroutine computes the exchange energy +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Dec 2020 +! +! +! + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T + USE EXCHANGE_ENERGIES +! + USE ENE_CHANGE, ONLY : RYD +! + USE ENERGIES, ONLY : EX_TYPE + USE SPIN_POLARIZATION +! + USE OUT_VALUES_7, ONLY : I_EX + USE PRINT_FILES, ONLY : IO_EX +! + REAL (WP) :: E_EX +! + IF(DMN == '3D') THEN ! + E_EX = EX_3D(EX_TYPE,IMODE,RS,T,XI) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! not implemented yet + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! not implemented yet + END IF ! +! + IF(I_EX == 1) THEN ! + WRITE(IO_EX,*) RS,T,E_EX * RYD ! exchange energy in eV + END IF ! +! + END SUBROUTINE CALC_EXX +! +!======================================================================= +! + SUBROUTINE CALC_EXC +! +! This subroutine computes the exchange and correlation energy +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Dec 2020 +! +! +! + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T + USE XC_ENERGIES +! + USE ENE_CHANGE, ONLY : RYD +! + USE ENERGIES, ONLY : FXC_TYPE,EXC_TYPE +! + USE OUT_VALUES_7, ONLY : I_XC + USE PRINT_FILES, ONLY : IO_XC +! + IMPLICIT NONE +! + REAL (WP) :: E_XC +! + IF(EXC_TYPE /= 'NO') THEN ! +! +! Exchange and correlation energy functionals (EXC_TYPE) +! + IF(DMN == '3D') THEN ! + E_XC = EXC_3D(EXC_TYPE,RS,T) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! not implemented yet + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! not implemented yet + END IF ! +! + ELSE ! +! +! Exchange and correlation free energy functionals (FXC_TYPE) +! + IF(DMN == '3D') THEN ! + CALL FXC_TO_EXC_3D(FXC_TYPE,RS,T,E_XC) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! not implemented yet + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! not implemented yet + END IF ! +! + END IF +! + IF(I_XC == 1) THEN ! + WRITE(IO_XC,*) RS,T,E_XC * RYD ! XC energy in eV + END IF ! +! + END SUBROUTINE CALC_EXC +! +!======================================================================= +! + SUBROUTINE CALC_ECO +! +! This subroutine computes the correlation energy +! +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Dec 2020 +! +! +! + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T + USE CORRELATION_ENERGIES +! + USE ENE_CHANGE, ONLY : RYD +! + USE ENERGIES, ONLY : EC_TYPE + USE SPIN_POLARIZATION +! + USE OUT_VALUES_7, ONLY : I_EC + USE PRINT_FILES, ONLY : IO_EC +! + IMPLICIT NONE +! + REAL (WP) :: E_CORR +! + IF(DMN == '3D') THEN ! + E_CORR = EC_3D(EC_TYPE,IMODE,RS,T) ! + ELSE IF(DMN == '2D') THEN ! + E_CORR = EC_2D(EC_TYPE,RS,T) ! + ELSE IF(DMN == '1D') THEN ! + E_CORR = EC_1D(EC_TYPE,RS,T) ! + END IF ! +! + IF(I_EC == 1) THEN ! + WRITE(IO_EC,*) RS,T,E_CORR * RYD ! correlation energy in eV + END IF ! +! + END SUBROUTINE CALC_ECO +! +!======================================================================= +! + SUBROUTINE CALC_KIN +! +! This subroutine computes the kinetic energy +! +! +! Reference: H. T. Tran and J. P. Perdew, Am. J. Phys. 1048-1061 (2003) +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Dec 2020 +! +! +! + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T + USE KINETIC_ENERGIES +! + USE ENE_CHANGE, ONLY : RYD +! + USE ENERGIES, ONLY : EK_TYPE + USE SPIN_POLARIZATION +! + USE OUT_VALUES_7, ONLY : I_EK + USE PRINT_FILES, ONLY : IO_EK +! + IMPLICIT NONE +! + REAL (WP) :: E_KIN + REAL (WP) :: ALPHA +! + IF(DMN == '3D') THEN ! + E_KIN = EK_3D(EK_TYPE,RS,T,XI) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! not implemented yet + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! not implemented yet + END IF ! +! + IF(I_EK == 1) THEN ! + WRITE(IO_EK,*) RS,E_KIN * RYD ! kinetic energy in eV + END IF ! +! + END SUBROUTINE CALC_KIN +! +END MODULE CALCULATORS_7 diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_8.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_8.f90 new file mode 100644 index 0000000..25731da --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_8.f90 @@ -0,0 +1,100 @@ +! +!======================================================================= +! +MODULE CALCULATORS_8 +! + USE ACCURACY_REAL +! +! This module contains the subroutines allowing to compute +! various properties of the electron/plasma liquids: +! +! +! * shear viscosity : CALC_VIS +! * diffusion coefficient : CALC_DIF +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_VIS(X) +! +! This subroutine computes the shear viscosity +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Output parameters: +! +! * ETA : shear viscosity +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Oct 2020 +! +! + USE VISCOSITY +! + USE OUT_VALUES_8, ONLY : I_VI + USE PRINT_FILES, ONLY : IO_VI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: ETA +! +! Computing the viscosity +! + CALL VISCOSITY_COEF(X,ETA) ! +! + IF(I_VI == 1) THEN ! + WRITE(IO_VI,*) X,ETA ! + END IF ! +! + END SUBROUTINE CALC_VIS +! +!======================================================================= +! + SUBROUTINE CALC_DIF +! +! This subroutine computes the diffusion coefficient +! +! +! +! Output parameters: +! +! * DC : diffusion coefficient +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Oct 2020 +! +! + USE DIFFUSION_COEFFICIENT +! + USE OUT_VALUES_8, ONLY : I_DI + USE PRINT_FILES, ONLY : IO_DI +! + IMPLICIT NONE +! + REAL (WP) :: DC +! +! Computing the viscosity +! + CALL DIFFUSION_COEF(DC) ! +! + IF(I_DI == 1) THEN ! + WRITE(IO_DI,*) DC ! + END IF ! +! + END SUBROUTINE CALC_DIF +! +END MODULE CALCULATORS_8 diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_9.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_9.f90 new file mode 100644 index 0000000..a7cf19b --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_9.f90 @@ -0,0 +1,305 @@ +! +!======================================================================= +! +MODULE CALCULATORS_9 +! + USE ACCURACY_REAL + USE CALCULATORS_1 +! +! This module contains the subroutines allowing to compute +! various properties of the electron/plasma liquids: +! +! +! * loss function : CALC_LOS +! * screened potential : CALC_VSC +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_LOS(X) +! +! This subroutine computes the loss function L(q, omega), +! defined by +! _ _ +! | - 1 | +! L(q, omega) = Im | --------------- | +! |_ EPS(q, omega) _| +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * DMN : problem dimension +! +! +! Output parameters: +! +! * E : energy array +! * VSCR : real part of the screened potential +! * VSCI : imaginary part of the screened potential +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 15 Oct 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOURTH,SMALL,TTINY,INF + USE FERMI_SI, ONLY : KF_SI + USE DF_VALUES, ONLY : ESTDY,EPS_T,D_FUNC + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T,H +! + USE E_GRID + USE UNITS, ONLY : UNIT +! + USE DFUNC_STATIC + USE DFUNCT_STAN_DYNAMIC + USE DFUNCL_STAN_DYNAMIC + USE DFUNCL_MAGN_DYNAMIC + USE COULOMB_K +! + USE OUT_VALUES_9, ONLY : I_EL + USE PRINT_FILES, ONLY : IO_EL +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL,D_FUNCT +! + REAL (WP) :: X + REAL (WP) :: REPS,IEPS,LOS + REAL (WP) :: Q,Z,EN,VC,A,NU,KS + REAL (WP) :: Y +! + REAL (WP) :: FLOAT +! + INTEGER :: IE +! + Y = X + X ! q/k_F + Q = Y * KF_SI ! q in SI +! +! Computing the Coulomb potential +! + CALL COULOMB_FF(DMN,UNIT,Q,ZERO,VC) ! +! + IF(ESTDY == ' STATIC') THEN ! +! +! Static susceptibility function +! + IF(EPS_T == 'LONG') THEN ! +! + D_FUNCL = D_FUNC ! + CALL DFUNCL_STATIC(X,D_FUNCL,REPS,IEPS) ! longitudinal eps +! + ELSE ! + D_FUNCT = D_FUNC ! + CONTINUE ! transverse eps + END IF ! +! + LOS = IEPS / (REPS * REPS + IEPS * IEPS) ! +! + IF(I_EL == 1) THEN ! + WRITE(IO_EL,*) Y,LOS ! + END IF ! +! + ELSE ! +! +! Loss function +! + DO IE = 1, N_E ! energy loop +! + EN = E_MIN + FLOAT(IE - 1) * E_STEP ! E = hbar omega / E_F +! + Z = FOURTH * EN / (X * X) ! Z = omega / omega_q +! + IF(EPS_T == 'LONG') THEN ! longitudinal eps +! + D_FUNCL = D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNCL,IE,REPS,IEPS) ! no magnetic field + ELSE ! + CALL DFUNCL_DYNAMIC_M(X,Z,KS,A,NU,D_FUNCL,REPS,IEPS) ! magnetic field + END IF ! + ELSE ! transverse eps + D_FUNCT = D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCT_DYNAMIC(X,Z,D_FUNCT,REPS,IEPS) ! no magnetic field + ELSE ! + CONTINUE ! magnetic field + END IF ! + END IF ! +! + LOS = IEPS / (REPS * REPS + IEPS * IEPS) ! +! + IF(I_EL == 1) THEN ! writing to + WRITE(IO_EL,*) Y,EN,LOS ! file + END IF ! +! + END DO ! end of energy loop +! + END IF ! +! + END SUBROUTINE CALC_LOS +! +!======================================================================= +! + SUBROUTINE CALC_VSC(X) +! +! This subroutine computes the screened Vc(q, omega) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * DMN : problem dimension +! +! +! Output parameters: +! +! * E : energy array +! * VSCR : real part of the screened potential +! * VSCI : imaginary part of the screened potential +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ZERO,FOURTH,SMALL,TTINY,INF + USE FERMI_SI, ONLY : KF_SI + USE DF_VALUES, ONLY : ESTDY,EPS_T,D_FUNC + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T,H +! + USE E_GRID + USE UNITS, ONLY : UNIT +! + USE DFUNC_STATIC + USE DFUNCT_STAN_DYNAMIC + USE DFUNCL_STAN_DYNAMIC + USE DFUNCL_MAGN_DYNAMIC + USE COULOMB_K +! + USE OUT_VALUES_9, ONLY : I_VC + USE PRINT_FILES, ONLY : IO_VC +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL,D_FUNCT +! + REAL (WP) :: X + REAL (WP) :: VSCR(NSIZE),VSCI(NSIZE),E(NSIZE) + REAL (WP) :: REPS,IEPS,RVSC,IVSC + REAL (WP) :: Q,Z,EN,VC,A,NU,KS + REAL (WP) :: Y +! + REAL (WP) :: FLOAT +! + INTEGER :: IE +! + Y = X + X ! q/k_F + Q = Y * KF_SI ! q in SI +! +! Computing the Coulomb potential +! + CALL COULOMB_FF(DMN,UNIT,Q,ZERO,VC) ! +! + IF(ESTDY == ' STATIC') THEN ! +! +! Static dielectric function +! + IF(EPS_T == 'LONG') THEN ! +! + D_FUNCL = D_FUNC ! + CALL DFUNCL_STATIC(X,D_FUNCL,REPS,IEPS) ! longitudinal eps +! + IF(REPS > TTINY) THEN ! + VSCR(1)= VC / REPS ! + ELSE ! + VSCR(1) = INF ! + END IF ! + IF(IEPS > TTINY) THEN ! + VSCI(1) = VC / IEPS ! + ELSE ! + VSCI(1) = INF ! + END IF ! +! + IF(I_VC == 1) THEN ! + WRITE(IO_VC,*) Y,VSCR(1),VSCI(1) ! + END IF ! +! + ELSE ! + D_FUNCT = D_FUNC ! + CONTINUE ! transverse eps + END IF ! +! + ELSE ! +! +! Dynamic dielectric function +! + DO IE = 1, N_E ! energy loop +! + EN = E_MIN + FLOAT(IE - 1) * E_STEP ! E = hbar omega / E_F +! + Z = FOURTH * EN / (X * X) ! Z = omega / omega_q +! + IF(EPS_T == 'LONG') THEN ! longitudinal eps +! + D_FUNCL = D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNCL,IE,REPS,IEPS) ! no magnetic field + ELSE ! + CALL DFUNCL_DYNAMIC_M(X,Z,KS,A,NU,D_FUNCL,REPS,IEPS) ! magnetic field + END IF ! + ELSE ! transverse eps + D_FUNCT = D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCT_DYNAMIC(X,Z,D_FUNCT,REPS,IEPS) ! no magnetic field + ELSE ! + CONTINUE ! magnetic field + END IF ! + END IF ! +! + IF(REPS > TTINY) THEN ! + VSCR(IE) = VC / REPS ! + ELSE ! + VSCR(IE) = INF ! + END IF ! + IF(IEPS > TTINY) THEN ! + VSCI(IE) = VC / IEPS ! + ELSE ! + VSCI(IE) = INF ! + END IF ! + E(IE) = EN ! +! + IF(I_VC == 1) THEN ! writing to + WRITE(IO_VC,*) Y,EN,VSCR(IE),VSCI(IE) ! file + END IF ! +! + END DO ! end of energy loop +! + END IF ! +! + END SUBROUTINE CALC_VSC +! +END MODULE CALCULATORS_9 diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_p.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_p.f90 new file mode 100644 index 0000000..4fa6b75 --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/calculators_p.f90 @@ -0,0 +1,260 @@ +! +!======================================================================= +! +MODULE CALCULATORS_P +! + USE ACCURACY_REAL +! +! This module contains the subroutines allowing to compute +! various properties of the electron/plasma liquids: +! +! +! * exact plasmon dispersion : CALC_EPD +! +! * fluctuation potential : CALC_FLP +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_EPD +! +! This subroutine computes the exact plasmon dispersion +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Dec 2020 +! +! + USE FERMI_SI, ONLY : EF_SI +! + USE PLASMON_DISP_EXACT +! + USE PRINT_FILES, ONLY : IO_PD +! + IMPLICIT NONE +! + INTEGER, PARAMETER :: N_ZERO = 10000 ! max number of zeros +! + INTEGER :: IS,IC ! lower and upper indices + INTEGER :: IP +! + REAL (WP) :: ENE_P_Q(N_ZERO) + REAL (WP) :: YQ(N_ZERO) +! + CALL PLASMON_DISP_EX(IS,IC,YQ,ENE_P_Q) +! + DO IP = IS, IC ! + WRITE(IO_PD,*) YQ(IP),ENE_P_Q(IP) / EF_SI ! + END DO ! +! + END SUBROUTINE CALC_EPD +! +!======================================================================= +! + SUBROUTINE CALC_FLP +! +! This subroutine computes the modulus of the fluctuation potential. +! The fluctuation potential is given by +! +! V_q = A_q e^{i q . r} +! +! with +! +! | V_C(q) | ^{1/2} +! A_q = | ______________________ | +! | | +! | d [ epsilon] / d omega | omega = omega(q) (1) +! +! +! +! where omega(q) is the plasmon dispersion +! +! +! +! References: (1) B. I. Lundqvist, Phys. kondens. Materie 9, 236-248 (1969) +! +! +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * DMN : problem dimension +! +! +! Output parameters: +! +! * FLPR : real part of the screened potential +! * FLPI : imaginary part of the screened potential +! +! +! +! WARNING : only REAL a at present +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2021 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ZERO,TWO,THREE,TEN, & + HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE DF_VALUES, ONLY : ESTDY,EPS_T,D_FUNC + USE MATERIAL_PROP, ONLY : RS,DMN + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,EPS_0 + USE ENE_CHANGE, ONLY : EV + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE EXT_FIELDS, ONLY : T + USE SCREENING_TYPE + USE SCREENING_VEC +! + USE E_GRID + USE Q_GRID + USE R_GRID + USE UNITS, ONLY : UNIT + USE OUT_VALUES_P + USE PLASMON_DISPERSION +! + USE COULOMB_K, ONLY : COULOMB_FF + USE INTERPOLATION + USE DERIVATION + USE PLASMON_ENE_SI + USE PLASMON_DISP_EXACT + USE PLASMON_DISP_REAL + USE RE_EPS_0_TREATMENT +! + USE CALCULATORS_1 + USE CALCULATORS_3 +! + USE OUT_VALUES_3, ONLY : I_ZE + USE OUT_VALUES_P, ONLY : I_FP + USE PRINT_FILES, ONLY : IO_ZE,IO_FP +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL,D_FUNCT +! + INTEGER, PARAMETER :: N_ZERO = 10000 ! max number of zeros +! + INTEGER :: LOGF + INTEGER :: IE,IQ,IR + INTEGER :: NB + INTEGER :: IQ_MIN,IQ_MAX +! + REAL (WP) :: Y,X + REAL (WP) :: ENE_P_Q(N_ZERO),ENE_P_Q1 + REAL (WP) :: YB(N_ZERO) + REAL (WP) :: ENE_P + REAL (WP) :: EPSR(NSIZE),EPSI(NSIZE),EN(NSIZE) + REAL (WP) :: EPSR1(NSIZE),EPSI1(NSIZE) + REAL (WP) :: REPS,IEPS,DEPSR_Q,DEPSI_Q + REAL (WP) :: FLPR(NSIZE),FLPI(NSIZE),R(NSIZE) + REAL (WP) :: RN,Q_SI,KS_SI,VC,A_Q + REAL (WP) :: H +! + REAL (WP) :: SQRT,FLOAT,COS,SIN +! + COMPLEX (WP) :: DEPS +! + LOGF = 6 ! +! +! Computing the exact plasmon dispersion in SI +! + IF(I_FP == 1) THEN ! + I_ZE = 1 ! + IO_ZE = 1 ! + CALL PLASMON_DISP_EX(IQ_MIN,IQ_MAX,YB,ENE_P_Q) ! + END IF ! +! +! Computing the dielectric function from IQ_MIN to IQ_MAX +! (plasmon dispersion bounds) +! + DO IQ = IQ_MIN,IQ_MAX ! start of q-loop +! + Y = Q_MIN + FLOAT(IQ - 1) * Q_STEP ! Y = q/k_F +! + X = HALF * Y ! X = q/(2k_F) +! + Q_SI = Y * KF_SI ! q in SI +! +! Computing an approximate plasmon dispersion +! + IF(I_FP == 3) THEN ! + CALL PLASMON_DISP_R(X,RS,T,PL_DISP,ENE_P_Q1) ! + END IF ! +! +! Computing the dielectric function EPS(omega) for q +! + CALL CALC_EPS(X,EN,EPSR,EPSI) ! EN = E / E_F +! +! Plasmon energy at q in units of E / E_F +! + IF(I_FP == 1) THEN ! + ENE_P = ENE_P_Q(IQ) / EF_SI ! + ELSE IF(I_FP == 3) THEN ! + ENE_P = ENE_P_Q1 / EF_SI ! + END IF ! +! +! Checking for screening vector +! + CALL SCREENING_VECTOR(SC_TYPE,DMN,X,RS,T,KS_SI) ! +! +! Initialisation of derivative arrays +! + DO IE = 1, N_E ! + EPSR1(IE) = ZERO ! + EPSI1(IE) = ZERO ! + END DO ! +! + H = EN(2) - EN(1) ! step for energy derivation (E / E_F) +! +! Computing the derivatives of EPSR and EPSI +! + CALL DERIV_1(EPSR,N_E,5,H,EPSR1) ! + CALL DERIV_1(EPSI,N_E,5,H,EPSI1) ! +! +! Cubic spline interpolation of EPSR1(N) and EPSI1(N) at E = ENE_P +! + DEPSR_Q = CUBIC_SPLINE_INTERP(EPSR1,EN,N_E,ENE_P) ! + DEPSI_Q = CUBIC_SPLINE_INTERP(EPSI1,EN,N_E,ENE_P) ! +! + DEPS = ABS(DEPSR_Q + IC * DEPSI_Q) ! +! +! Calculation of Fourier transform of Coulomb potential in SI +! + CALL COULOMB_FF(DMN,UNIT,Q_SI,KS_SI,VC) ! +! +! Computing the amplitude of the fluctuation potential (in eV) +! + A_Q = SQRT(ABS(VC / DEPS)) / EV ! ref. (1) eq. (17) +! +! Writing the results +! + IF(I_FP == 1) THEN ! writing to + WRITE(IO_FP,*) Y,A_Q ! file + ELSE IF(I_FP == 2) THEN ! +! +! Loop in R +! + DO IR = 1, N_R ! +! + RN = R_MIN + FLOAT(IR - 1) * R_STEP ! R = k_F * r +! + FLPR(IR) = A_Q * COS(TWO * X * RN) ! + FLPI(IR) = A_Q * SIN(TWO * X * RN) ! + R(IR) = RN ! +! + WRITE(IO_FP,*) Y,RN,FLPR(IE),FLPI(IE) ! +! + END DO ! + END IF ! + END DO ! end of q-loop +! + END SUBROUTINE CALC_FLP +! +END MODULE CALCULATORS_P diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_1.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_1.f90 new file mode 100644 index 0000000..92608e3 --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_1.f90 @@ -0,0 +1,71 @@ +! +!======================================================================= +! +MODULE CALL_CALC_1 +! + USE ACCURACY_REAL + USE CALCULATORS_1 + USE OUT_VALUES_1 +! +! This module calls the subroutines of calculator 1 whenever necessary +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE USE_CALC_1(X,EN,EPSR,EPSI) +! +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! Output parameters: +! +! * E : energy array +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 25 Sep 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE +! + IMPLICIT NONE +! + REAL (WP) :: X + REAL (WP) :: EPSR(NSIZE),EPSI(NSIZE),EN(NSIZE) +! +! Computing the dielectric function +! + IF(I_DF == 1) THEN ! + CALL CALC_EPS(X,EN,EPSR,EPSI) ! + END IF ! +! +! Computing the polarization function +! + IF(I_PZ == 1) THEN ! + CALL CALC_POL(X) ! + END IF ! +! +! Computing the susceptibility function +! + IF(I_SU == 1) THEN ! + CALL CALC_SUS(X) ! + END IF ! +! +! Computing the conductivity function +! + IF(I_CD == 1) THEN ! + CALL CALC_CDV(X) ! + END IF ! +! + END SUBROUTINE USE_CALC_1 +! +END MODULE CALL_CALC_1 diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_2.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_2.f90 new file mode 100644 index 0000000..ed36c1d --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_2.f90 @@ -0,0 +1,77 @@ +! +!======================================================================= +! +MODULE CALL_CALC_2 +! + USE ACCURACY_REAL + USE CALCULATORS_2 + USE OUT_VALUES_2 +! +! This module calls the subroutines of calculator 2 whenever necessary +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE USE_CALC_2(IQ,X) +! +! +! +! Input parameters: +! +! * IQ : q index +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 7 Oct 2020 +! +! + IMPLICIT NONE +! + INTEGER :: IQ +! + REAL (WP) :: X +! +! Computing the electron-hole pairs continua +! + IF(IQ == 1) THEN ! + IF(I_EH == 1) THEN ! + CALL CALC_EHD ! + END IF ! + IF(I_E2 == 1) THEN ! + CALL CALC_E2D ! + END IF ! + END IF ! +! +! Computing the analytical plasmon dispersion +! + IF(I_PD == 1) THEN ! + CALL CALC_PDI(X) ! + END IF ! +! +! Computing the electron-electron interaction in k-space +! + IF(I_CK == 1) THEN ! + CALL CALC_EEK(X) ! + END IF ! +! +! Computing the electron-electron interaction in real space +! + IF(I_CR == 1) THEN ! + CALL CALC_EER(X) ! + END IF ! +! +! Computing the plasmon kinetic energy +! + IF(I_PK == 1) THEN ! + CALL CALC_EKP(X) ! + END IF ! +! + END SUBROUTINE USE_CALC_2 +! +END MODULE CALL_CALC_2 + diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_3.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_3.f90 new file mode 100644 index 0000000..a7a718b --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_3.f90 @@ -0,0 +1,155 @@ +! +!======================================================================= +! +MODULE CALL_CALC_3 +! + USE ACCURACY_REAL + USE CALCULATORS_3 + USE OUT_VALUES_3 +! +! This module calls the subroutines of calculator 3 whenever necessary +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE USE_CALC_3(IQ,X) +! +! +! +! Input parameters: +! +! * IQ : q index +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 28 Jan 2021 +! +! + IMPLICIT NONE +! + INTEGER :: IQ +! + REAL (WP) :: X +! +! Computing the local-field corrections G(q,omega) +! + IF(I_LF == 1) THEN ! + CALL CALC_LFC(X) ! + END IF ! +! +! Computing the I(q) function = G(q,inf) +! + IF(I_IQ == 1) THEN ! + CALL CALC_IQF(X) ! + END IF ! +! +! Computing the structure factor S(q,omega) +! + IF(I_SF == 1) THEN ! + CALL CALC_SFC(X) ! + END IF ! +! + IF(IQ == 1) THEN ! +! +! Computing the pair correlation/distribution functions +! + IF(I_PC == 1) THEN ! + CALL CALC_PCF ! + END IF ! + IF(I_P2 == 1) THEN ! + CALL CALC_PDF ! + END IF ! + END IF ! +! +! Computing the vertex function Gamma(q,omega) +! + IF(I_DC == 1) THEN ! + CALL CALC_VTX(X) ! + END IF ! +! +! Computing the plasmon damping from eps(q,omega) +! + IF(I_VX == 1) THEN ! + CALL CALC_DMP(IQ,X) ! + END IF ! +! +! Computing the q bounds +! + IF(I_QC == 1) THEN ! + CALL CALC_QBD ! + END IF ! +! +! Computing the relaxation time +! + IF(I_RL == 1) THEN ! + CALL CALC_RLX(X) ! + END IF ! +! +! Computing the screening vector +! + IF(I_KS == 1) THEN ! + CALL CALC_SCR(X) ! + END IF ! +! +! Computing the omega = q * v_F file +! +! + IF(I_OQ == 1) THEN ! + CALL CALC_QVF(X) ! + END IF ! +! +! Computing the moments of Im[ epsilon ] +! + IF(I_ME == 1) THEN ! + CALL CALC_MEP(X) ! + END IF ! +! +! Computing the moments of the dynamical structure factor +! + IF(I_MS == 1) THEN ! + CALL CALC_MSF(X) ! + END IF ! +! +! Computing the moments of the loss function +! + IF(I_ML == 1) THEN ! + CALL CALC_MLO(X) ! + END IF ! +! +! Computing the zeros of Re[ eps(q,omega) ] +! + IF(I_ZE == 1) THEN ! + CALL CALC_RE0(X) ! + END IF ! +! +! Computing the inelastic mean free path +! + IF(IQ == 1) THEN ! + IF(I_MF == 1) THEN ! + CALL CALC_MFP ! + END IF ! + END IF ! +! +! Computing the Fourier-space Nevalinna/memory function +! + IF(I_NV == 1) THEN ! + CALL CALC_NEV(X) ! + END IF ! +! +! Computing the time-domain memory function +! + IF(IQ == 1) THEN ! + IF(I_MT == 1) THEN ! + CALL CALC_MEM ! + END IF ! + END IF ! +! + END SUBROUTINE USE_CALC_3 +! +END MODULE CALL_CALC_3 + diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_4.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_4.f90 new file mode 100644 index 0000000..8d1c8b6 --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_4.f90 @@ -0,0 +1 @@ + diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_5.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_5.f90 new file mode 100644 index 0000000..67d8f77 --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_5.f90 @@ -0,0 +1,41 @@ +! +!======================================================================= +! +MODULE CALL_CALC_5 +! + USE ACCURACY_REAL + USE CALCULATORS_5 + USE OUT_VALUES_5 +! +! This module calls the subroutines of calculator 5 whenever necessary +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE USE_CALC_5 +! + IMPLICIT NONE +! +! Computing the Fermi properties +! + IF(I_EF == 1) THEN ! + CALL CALC_EFF ! + END IF ! + IF(I_KF == 1) THEN ! + CALL CALC_KFF ! + END IF ! + IF(I_VF == 1) THEN ! + CALL CALC_VFF ! + END IF ! + IF(I_TE == 1) THEN ! + CALL CALC_TFF ! + END IF ! + IF(I_DL == 1) THEN ! + CALL CALC_NFF ! + END IF ! +! + END SUBROUTINE USE_CALC_5 +! +END MODULE CALL_CALC_5 + diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_6.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_6.f90 new file mode 100644 index 0000000..8d1c8b6 --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_6.f90 @@ -0,0 +1 @@ + diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_7.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_7.f90 new file mode 100644 index 0000000..e97086c --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_7.f90 @@ -0,0 +1,46 @@ +! +!======================================================================= +! +MODULE CALL_CALC_7 +! + USE ACCURACY_REAL + USE CALCULATORS_7 + USE OUT_VALUES_7 +! +! This module calls the subroutines of calculator 7 whenever necessary +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE USE_CALC_7 +! + IMPLICIT NONE +! +! Computing the exchange energy +! + IF(I_EX == 1) THEN ! + CALL CALC_EXX ! + END IF ! +! +! Computing the exchange and correlation energy +! + IF(I_XC == 1) THEN ! + CALL CALC_EXC ! + END IF ! +! +! Computing the correlation energy +! + IF(I_EC == 1) THEN ! + CALL CALC_ECO ! + END IF ! +! +! Computing the kinetic energy +! + IF(I_EK == 1) THEN ! + CALL CALC_KIN ! + END IF ! +! + END SUBROUTINE USE_CALC_7 +! +END MODULE CALL_CALC_7 diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_8.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_8.f90 new file mode 100644 index 0000000..0babd66 --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_8.f90 @@ -0,0 +1,50 @@ +! +!======================================================================= +! +MODULE CALL_CALC_8 +! + USE ACCURACY_REAL + USE CALCULATORS_8 + USE OUT_VALUES_8 +! +! This module calls the subroutines of calculator 8 whenever necessary +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE USE_CALC_8(X) +! +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Oct 2020 +! +! + IMPLICIT NONE +! + REAL (WP) :: X +! +! Computing the shear viscosity +! + IF(I_VI == 1) THEN ! + CALL CALC_VIS(X) ! + END IF ! +! +! Computing the diffusion coefficient +! + IF(I_DI == 1) THEN ! + CALL CALC_DIF ! + END IF ! +! + END SUBROUTINE USE_CALC_8 +! +END MODULE CALL_CALC_8 diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_9.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_9.f90 new file mode 100644 index 0000000..1af904b --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_9.f90 @@ -0,0 +1,51 @@ +! +!======================================================================= +! +MODULE CALL_CALC_9 +! + USE ACCURACY_REAL + USE CALCULATORS_9 + USE OUT_VALUES_9 +! +! This module calls the subroutines of calculator 9 whenever necessary +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE USE_CALC_9(X) +! +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 25 Sep 2020 +! +! + IMPLICIT NONE +! + REAL (WP) :: X +! +! Computing the loss function +! + IF(I_EL == 1) THEN ! + CALL CALC_LOS(X) ! + END IF ! +! +! Computing the screened Coulomb interaction V(q,omega) +! + IF(I_VC == 1) THEN ! + CALL CALC_VSC(X) ! + END IF ! +! + END SUBROUTINE USE_CALC_9 +! +END MODULE CALL_CALC_9 + diff --git a/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_p.f90 b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_p.f90 new file mode 100644 index 0000000..e91f674 --- /dev/null +++ b/New_libraries/DFM_library/CALCULATORS_LIBRARY/call_calc_p.f90 @@ -0,0 +1,46 @@ +! +!======================================================================= +! +MODULE CALL_CALC_P +! + USE ACCURACY_REAL + USE PLASMON_DISPERSION + USE CALCULATORS_P +! + USE OUT_VALUES_2, ONLY : I_PD + USE OUT_VALUES_P +! +! This module calls the subroutines of calculators requesting +! post-processsing +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE USE_CALC_P +! +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Dec 2020 +! +! + IMPLICIT NONE +! +! Computing the plasmon dispersion +! + IF(I_PD == 1 .AND. PL_DISP == ' EXACT') THEN ! + CALL CALC_EPD ! + END IF ! +! +! Computing the fluctuation potential +! + IF(I_FP == 1) THEN ! + CALL CALC_FLP ! + END IF ! +! + END SUBROUTINE USE_CALC_P +! +END MODULE CALL_CALC_P + diff --git a/New_libraries/DFM_library/CONFINEMENT_LIBRARY/Note.txt b/New_libraries/DFM_library/CONFINEMENT_LIBRARY/Note.txt new file mode 100644 index 0000000..335f24f --- /dev/null +++ b/New_libraries/DFM_library/CONFINEMENT_LIBRARY/Note.txt @@ -0,0 +1,11 @@ + + Note concerning the coding of the form factors FF + +In the coding of the different form factors, we have taken the +following convention: + + 3D : V(q) = e^2 / (EPS_0 * q^2) * FF + + 2D : V(q) = e^2 / (2*EPS_0 * q) * FF + + 1D : V(q) = e^2 / EPS_0 * FF diff --git a/New_libraries/DFM_library/CONFINEMENT_LIBRARY/confinement_ff.f90 b/New_libraries/DFM_library/CONFINEMENT_LIBRARY/confinement_ff.f90 new file mode 100644 index 0000000..10de281 --- /dev/null +++ b/New_libraries/DFM_library/CONFINEMENT_LIBRARY/confinement_ff.f90 @@ -0,0 +1,648 @@ +! +!======================================================================= +! +MODULE CONFINEMENT_FF +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + FUNCTION CONFIN_FF(X) +! +! This function computes the confinement form factor +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Intermediate parameters: +! +! * CONFIN : type of confinement +! CONFIN = 'NO-CONF' +! CONFIN = 'INF_QWW' +! CONFIN = 'CC-1111' cylindrical within subband 1 +! CONFIN = 'CC-1122' cylindrical between subbands 1 and 2 +! CONFIN = 'CC-1221' cylindrical between subbands 1 and 2 +! CONFIN = 'CC-2222' cylindrical within subband 2 +! CONFIN = 'HC-1111' harmonic within subband 1 +! CONFIN = 'HC-1122' harmonic between subbands 1 and 2 +! CONFIN = 'HC-1221' harmonic between subbands 1 and 2 +! CONFIN = 'HC-2222' harmonic within subband 2 +! CONFIN = 'INVLAYE' +! CONFIN = 'IQWE_LB' +! CONFIN = 'PC1_QWI' +! CONFIN = 'PC2_QWI' +! CONFIN = 'SWC_QWI' +! * R0 : radius of the quantum wire in SI --> m +! * L : length of the quantum well (SI) +! * DL : distance between the stacked layers (SI) +! +! +! Output parameters: +! +! * CONFIN_FF : form factor +! +! +! +! Author : D. Sébilleau +! +! Last modified : 3 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE CONFIN_VAL + USE MULTILAYER +! + IMPLICIT NONE +! + REAL (WP) :: CONFIN_FF,X +! + IF(CONFIN == 'NO-CONF') THEN ! + CONFIN_FF=ONE ! + ELSE IF(CONFIN == 'DSEPLAY') THEN ! + CONFIN_FF=DSEPLAY_FF(X,DL) ! + ELSE IF(CONFIN == 'CC-1111') THEN ! + CONFIN_FF=INF_QWW_FF(X,R0,CONFIN) ! + ELSE IF(CONFIN == 'CC-1122') THEN ! + CONFIN_FF=INF_QWW_FF(X,R0,CONFIN) ! + ELSE IF(CONFIN == 'CC-1221') THEN ! + CONFIN_FF=INF_QWW_FF(X,R0,CONFIN) ! + ELSE IF(CONFIN == 'CC-2222') THEN ! + CONFIN_FF=INF_QWW_FF(X,R0,CONFIN) ! + ELSE IF(CONFIN == 'HC-1111') THEN ! + CONFIN_FF=HCM_QWW_FF(X,R0,CONFIN) ! + ELSE IF(CONFIN == 'HC-1122') THEN ! + CONFIN_FF=HCM_QWW_FF(X,R0,CONFIN) ! + ELSE IF(CONFIN == 'HC-1221') THEN ! + CONFIN_FF=HCM_QWW_FF(X,R0,CONFIN) ! + ELSE IF(CONFIN == 'HC-2222') THEN ! + CONFIN_FF=HCM_QWW_FF(X,R0,CONFIN) ! + ELSE IF(CONFIN == 'INVLAYE') THEN ! + CONFIN_FF=INVLAYE_FF(X,DL,N_DEP,N_INV,EPS_2,EPS_1) ! + ELSE IF(CONFIN == 'IQWE_LB') THEN ! + CONFIN_FF=IQWE_LB_FF(X,L) ! + ELSE IF(CONFIN == 'PC1_QWI') THEN ! + CONFIN_FF=PC1_QWI_FF(X,OM0) ! + ELSE IF(CONFIN == 'PC2_QWI') THEN ! + CONFIN_FF=PC2_QWI_FF(X,OM0) ! + ELSE IF(CONFIN == 'SOF_COR') THEN ! + CONFIN_FF=SOF_COR_FF(X,R0) ! + ELSE IF(CONFIN == 'SWC_QWI') THEN ! + CONFIN_FF=SWC_QWI_FF(X,L) ! + END IF ! +! + END FUNCTION CONFIN_FF +! +!======================================================================= +! + FUNCTION DSEPLAY_FF(X,D) +! +! This function computes the form factor of a 2D layer within a +! stacking of layers separated by a distance D along the z axis +! +! Reference: (1) A. C. Sharma, Solid State Comm. 70, 1171-1174 (1989) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * D : distance between the stacked layers (SI) +! +! Output parameters: +! +! * DSEPLAY_FF : form factor +! +! +! Method: from eq. (7a) and (7b) adapted for SI, we have +! +! e^2 +! EPS(q,omega,qz) = 1 - --------- S(q,qz) * PI(q,omega) +! q EPS_0 +! +! Applying eq. (10), we find that the Coulomb potential +! for intralayer interaction must be +! +! / + pi/d +! e^2 d | +! VC(q) = --------- * ------ | S(q,qz) dqz +! q EPS_0 2 pi | +! / - pi/d +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE FERMI_SI, ONLY : KF_SI + USE SPECIFIC_INT_1, ONLY : SQQZ_INT +! + IMPLICIT NONE +! + REAL (WP) :: X,D + REAL (WP) :: DSEPLAY_FF + REAL (WP) :: Q +! + Q=TWO*X*KF_SI ! +! + DSEPLAY_FF=SQQZ_INT(Q,D) ! +! + END FUNCTION DSEPLAY_FF +! +!======================================================================= +! + FUNCTION INF_QWW_FF(X,R0,CONFIN) +! +! This function computes the form factor of the a quantum-well wire +! with an infinite barrier when only the two lower subbands are filled +! +! Reference: (1) A. Gold and A. Ghazali, Phys. Rev. B 41, 7626 (1990) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * R0 : radius of the quantum wire in SI --> m +! * CONFIN : type of confinement +! CONFIN = 'CC-1111' cylindrical within subband 1 +! CONFIN = 'CC-1122' cylindrical between subbands 1 and 2 +! CONFIN = 'CC-1221' cylindrical between subbands 1 and 2 +! CONFIN = 'CC-2222' cylindrical within subband 2 +! +! Output parameters: +! +! * INF_QWW_FF : form factor +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,SIX,EIGHT,THIRD + USE FERMI_SI, ONLY : KF_SI + USE BESSEL +! + IMPLICIT NONE +! + CHARACTER*7 CONFIN +! + REAL (WP) :: X,R0 + REAL (WP) :: INF_QWW_FF + REAL (WP) :: Q,QR0,QR02,QR04,QR06 + REAL (WP) :: I3,K3,I4,K4 +! + Q=TWO*X*KF_SI ! + QR0=Q*R0 ! + QR02=QR0*QR0 ! + QR04=QR02*QR02 ! + QR06=QR04*QR02 ! +! +! Computing the Bessel functions +! + I3=BESSI(3,QR0) ! + K3=BESSK(3,QR0) ! + I4=BESSI(4,QR0) ! + K4=BESSK(4,QR0) ! +! + IF(CONFIN == 'CC-1111') THEN ! + INF_QWW_FF=72.0E0_WP*( 0.10E0_WP - TWO*THIRD/QR02 + & ! + 32.0E0_WP*THIRD/QR04 - 64.0E0_WP*I3*K3/QR04 & ! ref. 1 eq. (11a) + ) / QR02 ! + ELSE IF(CONFIN == 'CC-1122') THEN ! + INF_QWW_FF=288.0E0_WP*( 0.050E0_WP*THIRD - & ! + 0.20E0_WP*THIRD/QR02 + & ! + EIGHT*THIRD/QR04 - & ! ref. 1 eq. (11b) + 64.0E0_WP*K3/QR04 * & ! + (I3 - SIX*I4/QR0) & ! + ) / QR02 ! + ELSE IF(CONFIN == 'CC-1221') THEN ! + INF_QWW_FF=576.0E0_WP*( 0.050E0_WP*THIRD - & ! + 0.80E0_WP*THIRD/QR02 + & ! + EIGHT/QR04 - 64.0E0_WP*I4*K4/QR04 & ! ref. 1 eq. (11c) + ) / QR02 ! + ELSE IF(CONFIN == 'CC-2222') THEN ! + INF_QWW_FF=1152.0E0_WP*( ONE/210.0E0_WP - & ! + 0.20E0_WP*THIRD/QR02 + & ! + 12.80E0_WP*THIRD/QR04 + & ! + 96.0E0_WP/QR06 - & ! + 64.0E0_WP/QR04 * & ! + (I3 - SIX*I4/QR0) * & ! ref. 1 eq. (11d) + (K3 + SIX*K4/QR0) & ! + ) / QR02 ! + END IF ! +! + END FUNCTION INF_QWW_FF +! +!======================================================================= +! + FUNCTION HCM_QWW_FF(X,B,CONFIN) +! +! This function computes the form factor of the a quantum-well wire +! with a harmonic confinement when only the two lower subbands are filled +! +! Reference: (1) G. Y. Hu and R. F. O'Connell, +! J. Phys.: Condens. Matter 2 9381 (1990) +! +! Note: Here, the two sub-bands are labelled 1 and 2 instead of 0 and 1 +! in ref. (1). This is for consistency with function INF_QWW_FF +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * B : confinement parameter (b = sqrt(h_bar / m* omega_0) +! * CONFIN : type of confinement +! CONFIN = 'HC-1111' harmonic within subband 1 +! CONFIN = 'HC-1122' harmonic between subbands 1 and 2 +! CONFIN = 'HC-1221' harmonic between subbands 1 and 2 +! CONFIN = 'HC-2222' harmonic within subband 2 +! +! Output parameters: +! +! * HCM_QWW_FF : form factor +! +! Author : D. Sébilleau +! +! Last modified : 3 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF,FOURTH,EIGHTH + USE FERMI_SI, ONLY : KF_SI + USE BESSEL, ONLY : BESSK0,BESSK1 +! + IMPLICIT NONE +! + CHARACTER*7 CONFIN +! + REAL (WP) :: X,B + REAL (WP) :: HCM_QWW_FF + REAL (WP) :: Q,Q2B2,COEF + REAL (WP) :: K0,K1 +! + REAL (WP) :: DEXP +! + Q=TWO*X*KF_SI ! + Q2B2=(Q*B)*Q*B ! +! + COEF=DEXP(FOURTH*Q2B2) ! +! +! Computing the Bessel functions +! + K0=BESSK0(FOURTH*Q2B2) ! + K1=BESSK1(FOURTH*Q2B2) ! +! + IF(CONFIN == 'HC-1111') THEN ! + HCM_QWW_FF=COEF*K0 ! ref. (1) eq. (2.5a) + ELSE IF(CONFIN == 'HC-1122') THEN ! + HCM_QWW_FF=COEF*( K0 + FOURTH*Q2B2*(K0-K1) ) ! ref. (1) eq. (2.5c) + ELSE IF(CONFIN == 'HC-1221') THEN ! + HCM_QWW_FF=COEF*FOURTH*Q2B2*(K1-K0) ! ref. (1) eq. (2.5d) + ELSE IF(CONFIN == 'HC-2222') THEN ! + HCM_QWW_FF=COEF*( (ONE+HALF*Q2B2+EIGHTH*Q2B2*Q2B2)*K0 - & ! + FOURTH*Q2B2*(ONE+HALF*Q2B2)*K1 & ! ref. (1) eq. (2.5b) + ) ! + END IF ! +! + END FUNCTION HCM_QWW_FF +! +!======================================================================= +! + FUNCTION INVLAYE_FF(X,D,N_DEP,N_INV,EPSO,EPSS) +! +! This function computes the form factor of the surface inversion layer +! of a semiconductor +! +! Reference: (1) T. K. Lee, C. S. Tin and J. J. Quinn, +! Solid. State Comm. 16, 1309-1312 (1975) +! (2) M. Jonson, J. Phys. C: Solid State Phys. 9, 3055-3071 (1976) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * D : width of the insulation layer (SI) +! * N_DEP : electron concentration in depletion layer (SI) +! * N_INV : electron concentration in inversion layer (SI) +! * EPSO : dielectric constant of the insulating layer (oxide) +! * EPSS : dielectric constant of the semiconductor +! +! Output parameters: +! +! * INVLAYE_FF : form factor +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,THIRD + USE CONSTANTS_P1, ONLY : H_BAR,E,M_E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP) :: X,D,N_DEP,N_INV,EPSO,EPSS + REAL (WP) :: INVLAYE_FF + REAL (WP) :: B + REAL (WP) :: Q,NU1,NU2,NUM,DEN + REAL (WP) :: Y,Y2,Y3,Y4 +! + REAL (WP) :: DTANH +! +! Computation of parameter B +! + NUM=48.0E0_WP*PI*E*E*M_E ! + DEN=EPSS*H_BAR*H_BAR ! +! + B=( NUM*(N_DEP+11.0E0_WP*N_INV/32.0E0_WP)/DEN )**THIRD ! ref. 2 eq. (21) +! + Q=TWO*X*KF_SI ! + Y=Q/B ! + Y2=Y*Y ! + Y3=Y2*Y ! + Y4=Y3*Y ! +! + NU1=0.125E0_WP*Y*( 33.0E0_WP + 54.0E0_WP*Y + 44.0E0_WP*Y2 + & ! + 18.0E0_WP*Y3+THREE*Y4 & ! + ) ! + NU2=TWO*EPSS/( EPSS+EPSO/DTANH(Q*D) ) ! + DEN=(ONE+Y)**6 ! +! + INVLAYE_FF=(NU1+NU2)/DEN ! ref. 1 eq. (5) +! + END FUNCTION INVLAYE_FF +! +!======================================================================= +! + FUNCTION IQWE_LB_FF(X,L) +! +! This function computes the form factor of the a quantum well +! with an infinite barrier when only the lower subband is filled +! +! Reference: (1) T. Vazifehshenas and T. Salavati-fard, +! Physica E 41, 1297–1300 (2009) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * L : length of the quantum well (SI) +! +! Output parameters: +! +! * IQWE_LB_FF : form factor +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,EIGHT + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI2 +! + IMPLICIT NONE +! + REAL (WP) :: X,L + REAL (WP) :: IQWE_LB_FF + REAL (WP) :: Q,Y,Y2 + REAL (WP) :: NU1,NU2,DE1,DE2 +! + REAL (WP) :: DEXP +! + Q=TWO*X*KF_SI ! + Y=Q*L ! + Y2=Y*Y ! +! + NU1=THREE*Y + EIGHT*PI2/Y ! + NU2=32.0E0_WP*PI2*PI2*(ONE-DEXP(-Y)) ! + DE1=Y2 + FOUR*PI2 ! + DE2=Y2 * DE1*DE1 ! +! + IQWE_LB_FF=NU1/DE1 - NU2/DE2 ! +! + END FUNCTION IQWE_LB_FF +! +!======================================================================= +! + FUNCTION PC1_QWI_FF(X,OM0) +! +! This function computes the form factor of a quantum wire under +! an harmonic confinement potential of the form 1/2 m omega_0^2 y^2 +! in the y direction +! +! Reference: (1) M. Tas, PhD thesis, Middle East Technical University (2004) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * OM0 : frequency of the confinement potential (SI) +! +! Output parameters: +! +! * PC1_QWI_FF : form factor +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOURTH + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE BESSEL +! + IMPLICIT NONE +! + REAL (WP) :: X,OM0 + REAL (WP) :: PC1_QWI_FF + REAL (WP) :: Q,B,ZZ,K0 +! + REAL (WP) :: DSQRT,DEXP +! + Q=TWO*X*KF_SI ! +! +! Characteristic length of the harmonic potential +! (serves as effective diameter of quantum wire) +! + B=DSQRT(H_BAR/(M_E*OM0)) ! +! + ZZ=FOURTH*Q*Q*B*B ! +! +! Computing the Bessel function +! + K0=BESSK(0,ZZ) ! +! + PC1_QWI_FF=DEXP(ZZ)*K0 ! ref. 1 eq. (3.70) +! + END FUNCTION PC1_QWI_FF +! +!======================================================================= +! + FUNCTION PC2_QWI_FF(X,OM0) +! +! This function computes the form factor of a quantum wire under +! an harmonic confinement potential of the form 1/8 m omega_0^2 (x^2 + y^2) +! in the y direction +! +! Reference: (1) M. Tas, PhD thesis, Middle East Technical University (2004) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * OM0 : frequency of the confinement potential (SI) +! +! Output parameters: +! +! * PC2_QWI_FF : form factor +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE BESSEL, ONLY : EXPINT +! + IMPLICIT NONE +! + REAL (WP) :: X,OM0 + REAL (WP) :: PC2_QWI_FF + REAL (WP) :: Q,B,ZZ +! + REAL (WP) :: DSQRT,DEXP +! + Q=TWO*X*KF_SI ! +! +! Characteristic length of the harmonic potential +! (serves as effective diameter of quantum wire) +! + B=DSQRT(H_BAR/(M_E*OM0)) ! +! + ZZ=Q*Q*B*B ! +! + PC2_QWI_FF=DEXP(ZZ) * EXPINT(1,ZZ) ! ref. 1 eq. (3.75) +! + END FUNCTION PC2_QWI_FF +! +!======================================================================= +! + FUNCTION SOF_COR_FF(X,R0) +! +! This function computes the form factor of a quantum wire under +! the soft core potential +! +! Reference: (1) N. Nessi and A. Iucci, Phys. Rev. B 87, 085137 (2013) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * R0 : quantum wire radius (SI) +! +! Output parameters: +! +! * SOF_COR_FF : form factor +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE FERMI_SI, ONLY : KF_SI + USE BESSEL +! + IMPLICIT NONE +! + REAL (WP) :: X,R0 + REAL (WP) :: Q,SOF_COR_FF +! + Q=TWO*X*KF_SI ! +! + SOF_COR_FF=TWO*BESSK(0,Q*R0) ! +! + END FUNCTION SOF_COR_FF +! +!======================================================================= +! + FUNCTION SWC_QWI_FF(X,A) +! +! This function computes the form factor of the a quantum-well wire +! modelled as a square well with an infinite barrier when only +! the lower subband is filled +! +! The barrier is from -a/2 to a/2 +! +! +! Reference: (1) M. Tas, PhD thesis, Middle East Technical University (2004) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * A : length of the quantum well (SI) +! +! Output parameters: +! +! * SWC_QWI_FF : form factor +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ONE,TWO + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI,PI_INV + USE INTEGRATION, ONLY : INTEGR_L + USE BESSEL +! + IMPLICIT NONE +! ! points + REAL (WP) :: X,A + REAL (WP) :: SWC_QWI_FF + REAL (WP) :: Q,XX,F(NZ_MAX),H,AA +! + REAL (WP) :: DFLOAT,DCOS,DSIN +! + INTEGER :: K,ID +! + ID=1 ! +! + Q=TWO*X*KF_SI ! +! +! Constructing the integrand function +! + DO K=1,NZ_MAX ! +! + XX=DFLOAT(K-1)/DFLOAT(NZ_MAX-1) ! + F(K)=BESSK(0,Q*A*XX) * ( & ! + TWO-(ONE-XX)*DCOS(TWO*PI*XX) + & ! + 1.5E0_WP*PI_INV*DSIN(TWO*PI*XX) & ! + ) ! +! + ENDDO ! +! + H=ONE/DFLOAT(NZ_MAX-1) ! step +! +! Performing the integration +! + CALL INTEGR_L(F,H,NZ_MAX,NZ_MAX,AA,ID) ! + + SWC_QWI_FF=TWO*AA ! ref. 1 eq. (3.87) +! + END FUNCTION SWC_QWI_FF +! +END MODULE CONFINEMENT_FF + diff --git a/New_libraries/DFM_library/CONFINEMENT_LIBRARY/confinement_wf.f90 b/New_libraries/DFM_library/CONFINEMENT_LIBRARY/confinement_wf.f90 new file mode 100644 index 0000000..547fdde --- /dev/null +++ b/New_libraries/DFM_library/CONFINEMENT_LIBRARY/confinement_wf.f90 @@ -0,0 +1,414 @@ +! +!======================================================================= +! +MODULE CONFINEMENT_WF +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + FUNCTION CONFIN_WF(R,TH,SB_I,OM0,N_DEP,N_INV,EPSS) +! +! This function computes the confinement wave function +! +! +! +! Input parameters: +! +! * R : radial parameter +! * TH : polar angle +! * SB_I : sub-band index (0, 1, 2, ...) --> limited to 10 +! * N_DEP : electron concentration in depletion layer (SI) +! * N_INV : electron concentration in inversion layer (SI) +! * EPSS : dielectric constant of the semiconductor +! * OM0 : frequency of the confinement potential (SI) +! +! Intermediate parameters: +! +! * CONFIN : type of confinement +! CONFIN = 'INF_QWW' +! CONFIN = 'INVLAYE' +! CONFIN = 'IQWE_LB' +! CONFIN = 'PC1_QWI' +! CONFIN = 'PC2_QWI' +! CONFIN = 'SWC_QWI' +! * L : length of the quantum well (SI) +! +! +! Output parameters: +! +! * CONFIN_WF : wave function +! +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO + USE CONFIN_VAL, ONLY : CONFIN,R0,L +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: SB_I +! + REAL (WP), INTENT(IN) :: R,TH,OM0 + REAL (WP), INTENT(IN) :: N_DEP,N_INV,EPSS + REAL (WP) :: CONFIN_WF +! + IF(CONFIN == 'NO-CONF') THEN ! + CONFIN_WF = ZERO ! + ELSE IF(CONFIN == 'INF_QWW') THEN ! + CONFIN_WF = INF_QWW_WF(R,TH,R0,SB_I) ! + ELSE IF(CONFIN == 'INVLAYE') THEN ! + CONFIN_WF = INVLAYE_WF(R,N_DEP,N_INV,EPSS) ! + ELSE IF(CONFIN == 'IQWE_LB') THEN ! + CONFIN_WF = IQWE_LB_WF(R,L) ! + ELSE IF(CONFIN == 'PC1_QWI') THEN ! + CONFIN_WF = PC1_QWI_WF(R,OM0,SB_I) ! + ELSE IF(CONFIN == 'PC2_QWI') THEN ! + CONFIN_WF = PC2_QWI_WF(R,OM0) ! + ELSE IF(CONFIN == 'SWC_QWI') THEN ! + CONFIN_WF = SWC_QWI_WF(R,L) ! + END IF ! + +! + END FUNCTION CONFIN_WF +! +!======================================================================= +! + FUNCTION INF_QWW_WF(R,TH,R0,SB_I) +! +! This function computes the wave function in the two lower subbands +! of a quantum-well wire. +! +! Reference: (1) A. Gold and A. Ghazali, Phys. Rev. B 41, 7626 (1990) +! +! +! Input parameters: +! +! * R : radial parameter +! * TH : polar angle +! * R0 : radius of the quantum wire (same unit as R) +! * SB_I : sub-band index +! +! Output parameters: +! +! * INF_QWW_FF : form factor +! +! Author : D. Sébilleau +! +! Last modified : 21 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THREE + USE COMPLEX_NUMBERS + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + INTEGER :: SB_I +! + REAL (WP), INTENT(IN) :: R,TH,R0 + REAL (WP) :: R02,R03,R2,R3 + REAL (WP) :: COEF +! + REAL (WP) :: SQRT +! + COMPLEX (WP) :: INF_QWW_WF +! + COMPLEX (WP) :: CMPLX,EXP +! + R02 = R0 * R0 ! + R03 = R02 * R0 ! + R2 = R * R ! + R3 = R2 * R ! +! +! + IF(SB_I == 1) THEN ! + IF(R < R0) THEN ! + COEF = SQRT(THREE * PI_INV / R02) ! + INF_QWW_WF = CMPLX(COEF * (ONE - R2 / R02),KIND=WP) ! + ELSE ! + INF_QWW_WF = ZEROC ! + END IF ! + ELSE IF(SB_I == 2) THEN ! + IF(R < R0) THEN ! + COEF = SQRT(12.0E0_WP * PI_INV / R02) ! + INF_QWW_WF = COEF * (R / R0 - R3 / R03) * EXP(IC * TH) ! + ELSE ! + INF_QWW_WF = ZEROC ! + END IF ! + END IF ! +! + END FUNCTION INF_QWW_WF +! +!======================================================================= +! + FUNCTION INVLAYE_WF(Z,N_DEP,N_INV,EPSS) +! +! This function computes the wave function of the surface inversion layer +! of a semiconductor in the z direction +! +! Reference: (1) M. Jonson, J. Phys. C: Solid State Phys. 9, 3055-3071 (1976) +! +! +! Input parameters: +! +! * Z : z coordinate +! * N_DEP : electron concentration in depletion layer (SI) +! * N_INV : electron concentration in inversion layer (SI) +! * EPSS : dielectric constant of the semiconductor +! +! Output parameters: +! +! * INVLAYE_WF : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 21 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : HALF,THIRD + USE PI_ETC, ONLY : PI + USE CONSTANTS_P1, ONLY : H_BAR,E,M_E +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: Z,N_DEP,N_INV,EPSS + REAL (WP) :: INVLAYE_WF + REAL (WP) :: B,B3 + REAL (WP) :: NUM,DEN +! + REAL (WP) :: SQRT,EXP +! +! Computation of parameter B +! + NUM = 48.0E0_WP * PI * E * E * M_E ! + DEN = EPSS * H_BAR * H_BAR ! +! + B = (NUM * ( N_DEP + 11.0E0_WP * & ! + N_INV / 32.0E0_WP ) / DEN)**THIRD ! ref. 1 eq. (21) +! + B3 = B * B * B ! +! + INVLAYE_WF = SQRT(HALF * B3) * Z * EXP(- HALF * B * Z) ! ref. 1 eq. (19) +! + END FUNCTION INVLAYE_WF +! +!======================================================================= +! + FUNCTION IQWE_LB_WF(Z,L) +! +! This function computes the z-axis wave function of the a quantum well +! with an infinite barrier when only the lower subband is filled +! +! Reference: (1) T. Vazifehshenas and T. Salavati-fard, +! Physica E 41, 1297–1300 (2009) +! +! +! Input parameters: +! +! * Z : z value +! * L : length of the quantum well (SI) +! +! Output parameters: +! +! * IQWE_LB_WF : form factor +! +! Author : D. Sébilleau +! +! Last modified : 21 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: Z,L + REAL (WP) :: IQWE_LB_WF +! + REAL (WP) :: SQRT,SIN +! + IQWE_LB_WF = SQRT(TWO / L) * SIN(PI * Z / L) ! +! + END FUNCTION IQWE_LB_WF +! +!======================================================================= +! + FUNCTION PC1_QWI_WF(Y,OM0,N) +! +! This function computes the wave function of a quantum wire under +! an harmonic confinement potential of the form 1/2 m omega_0^2 y^2 +! in the y direction +! +! Reference: (1) M. Tas, PhD thesis, Middle East Technical University (2004) +! +! +! Input parameters: +! +! * Y : parameter in the confinement direction +! * OM0 : frequency of the confinement potential (SI) +! * N : sub-band index (0, 1, 2, ...) --> limited to 10 +! +! Output parameters: +! +! * PC1_QWI_WF : form factor +! +! Author : D. Sébilleau +! +! Last modified : 21 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF + USE PI_ETC, ONLY : PI + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE EXT_FUNCTIONS, ONLY : H_POLYNOMIAL_VALUE +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: N +! + REAL (WP), INTENT(IN) :: Y,OM0 + REAL (WP) :: PC1_QWI_WF + REAL (WP) :: B,YB,ZZ,COEF + REAL (WP) :: FC(0:10),X(1),P(1,0:10) +! + REAL (WP) :: SQRT,EXP +! + DATA FC / 1.0E0_WP, 1.0E0_WP, 2.0E0_WP, & ! + 6.0E0_WP, 24.0E0_WP, 120.0E0_WP, & ! factorials + 720.0E0_WP, 5040.0E0_WP, 40320.0E0_WP, & ! + 362880.0E0_WP, 3628800.0E0_WP / ! +! + IF(N > 10) THEN ! + WRITE(6,10) ! + STOP ! + END IF ! +! +! Characteristic length of the harmonic potential +! (serves as effective diameter of quantum wire) +! + B = SQRT(H_BAR / (M_E * OM0)) ! +! + YB = Y / B ! +! + ZZ = HALF * YB * YB ! +! + COEF = SQRT(ONE / (TWO**N * FC(N) * SQRT(PI * B))) ! +! +! Computing the Hermite polynomial +! + X(1) = YB ! + CALL H_POLYNOMIAL_VALUE(1,N,X,P) ! +! + PC1_QWI_WF = COEF * EXP(- ZZ) * P(1,N) ! ref. 1 eq. (3.67) +! +! Format +! + 10 FORMAT(//,5X,'<<<<< SUB-BAND INDEX TOO LARGE >>>>>',//) +! + END FUNCTION PC1_QWI_WF +! +!======================================================================= +! + FUNCTION PC2_QWI_WF(R,OM0) +! +! This function computes the wave function of a quantum wire under +! an harmonic confinement potential of the form 1/8 m omega_0^2 (x^2+y^2) +! in the (x,y) direction (lowest sub-band only) +! +! Reference: (1) M. Tas, PhD thesis, Middle East Technical University (2004) +! +! +! Input parameters: +! -> +! * R : parameter in the confinement directions (projection of r +! onto the(xy) plane) +! * OM0 : frequency of the confinement potential (SI) +! +! Output parameters: +! +! * PC2_QWI_WF : form factor +! +! Author : D. Sébilleau +! +! Last modified : 21 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOURTH + USE PI_ETC, ONLY : PI + USE CONSTANTS_P1, ONLY : H_BAR,M_E +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: R,OM0 + REAL (WP) :: PC2_QWI_WF + REAL (WP) :: B,ZZ,COEF +! + REAL (WP) :: SQRT,EXP +! +! Characteristic length of the harmonic potential +! (serves as effective diameter of quantum wire) +! + B = SQRT(H_BAR / (M_E * OM0)) ! +! + ZZ = FOURTH * R * R / (B * B) ! +! + COEF =ONE / SQRT(TWO * PI * B * B) ! +! + PC2_QWI_WF = COEF * EXP(- ZZ) ! ref. 1 eq. (3.74) +! + END FUNCTION PC2_QWI_WF +! +!======================================================================= +! + FUNCTION SWC_QWI_WF(Y,A) +! +! This function computes the wave function of the a quantum-well wire +! with an infinite barrier when only the lowest subband is filled +! +! The barrier is from -a/2 to a/2 +! +! +! Reference: (1) M. Tas, PhD thesis, Middle East Technical University (2004) +! +! +! Input parameters: +! +! * Y : parameter along the y axis +! * A : length of the quantum well (SI) +! +! Output parameters: +! +! * SWC_QWI_WF : form factor +! +! Author : D. Sébilleau +! +! Last modified : 21 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,TWO,HALF + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: Y,A + REAL (WP) :: SWC_QWI_WF +! + REAL (WP) :: COS +! + IF( (- HALF * A <= Y) .AND. (Y <= HALF * A) ) THEN ! + SWC_QWI_WF = TWO * COS(PI * Y / A) / A ! ref. 1 eq. (3.86) + ELSE ! + SWC_QWI_WF = ZERO ! + END IF ! +! + END FUNCTION SWC_QWI_WF +! +END MODULE CONFINEMENT_WF diff --git a/New_libraries/DFM_library/CONFINEMENT_LIBRARY/coulomb.f90 b/New_libraries/DFM_library/CONFINEMENT_LIBRARY/coulomb.f90 new file mode 100644 index 0000000..7ec8810 --- /dev/null +++ b/New_libraries/DFM_library/CONFINEMENT_LIBRARY/coulomb.f90 @@ -0,0 +1,113 @@ +! +!======================================================================= +! +MODULE COULOMB_K +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE COULOMB_FF(DMN,UNIT,Q,KS,V_C) +! +! This subroutine computes Coulomb potentials in the k-space +! in all dimensions, including the form factors +! to account for various confinements +! +! +! Input parameters: +! +! * DMN : dimension of the system +! * UNIT : system unit +! * Q : wave vector in UNIT +! * KS : screening wave vector in UNIT +! +! +! Output variables : +! +! * V_C : Coulomb potential in k-space (in UNIT) +! +! +! +! Note: In the coding of the different form factors, +! we have taken the following convention: +! +! 3D : V(q) = e^2 / (EPS_0 * q^2) * FF [SI] +! 4 pi e^2 / q^2 * FF [CGS] +! +! Q2D,2D : V(q) = e^2 / (2*EPS_0 * q) * FF [SI] +! 2 pi e^2 / q * FF [CGS] +! +! Q1D,1D : V(q) = e^2 / EPS_0 * FF [SI] +! 4 pi e^2 * FF [CGS] +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : FOUR,HALF + USE PI_ETC, ONLY : PI + USE CONFIN_VAL, ONLY : R0 + USE CONFINEMENT_FF, ONLY : CONFIN_FF + USE CONSTANTS_P1, ONLY : E,EPS_0 + USE FERMI_SI, ONLY : KF_SI + USE FERMI_AU, ONLY : KF_AU +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: UNIT + CHARACTER (LEN = 2) :: DMN +! + REAL (WP) :: Q,KS + REAL (WP) :: V_C + REAL (WP) :: X,COEF,Q2,KS2,QKS2 + REAL (WP) :: FF +! + REAL (WP) :: SQRT +! +! Unit-dependent factors +! + IF(UNIT == 'SIU') THEN ! + COEF = E * E / EPS_0 ! + X = HALF * Q / KF_SI ! X = q / (2 * k_F) + ELSE IF(UNIT == 'CGS') THEN ! + COEF = FOUR * PI * E * E ! + X = HALF * Q / KF_AU ! X = q / (2 * k_F) + END IF ! +! + Q2 = Q * Q ! + KS2 = KS * KS ! + QKS2 = Q2 + KS2 ! +! + IF(DMN == '3D') THEN ! +! + V_C = COEF / QKS2 ! +! + ELSE IF(DMN == '2D') THEN ! +! + FF = CONFIN_FF(X) ! + V_C = HALF * COEF * FF / SQRT(QKS2) ! +! + ELSE IF(DMN == 'Q2') THEN ! +! + FF = CONFIN_FF(X) ! + V_C = HALF * COEF * FF / SQRT(QKS2) ! +! + ELSE IF(DMN == 'Q1') THEN ! +! + FF = CONFIN_FF(X) ! + V_C = COEF * FF ! +! + ELSE IF(DMN == '1D') THEN ! +! + FF = CONFIN_FF(X) ! + V_C = COEF * FF ! +! + END IF ! +! + END SUBROUTINE COULOMB_FF +! +END MODULE COULOMB_K diff --git a/New_libraries/DFM_library/DAMPING_LIBRARY/calc_damping.f90 b/New_libraries/DFM_library/DAMPING_LIBRARY/calc_damping.f90 new file mode 100644 index 0000000..e84539b --- /dev/null +++ b/New_libraries/DFM_library/DAMPING_LIBRARY/calc_damping.f90 @@ -0,0 +1,178 @@ +! +!======================================================================= +! +MODULE DAMPING_SI +! +! This module defines the damping coefficients in SI +! +! +! --> SI version <-- +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: LFT,TAU,TAU2,NNU,DIF,ETA +! +END MODULE DAMPING_SI +! +!======================================================================= +! +MODULE DAMPING_COEF +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_DAMPING(IQ,X) +! +! This subroutine calculates and stores the value of the damping +! coefficient selected +! +! +! Input parameters: +! +! * IQ : q_loop index +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Output parameters: +! +! * LFT : quasiparticle lifetime in seconds +! * TAU : 1st relaxation time in seconds +! * TAU2 : 2nd relaxation time in seconds +! * NNU : decay rate in 1/s +! * DIF : diffusion coefficient in SI +! * ETA : shear viscosity in SI +! +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Aug 2021 +! +! + USE OUT_VALUES_10, ONLY : I_WR +! + USE REAL_NUMBERS, ONLY : ZERO,LARGE +! + USE DAMPING_VALUES +! + USE LIFETIME + USE RELAXATION_TIME_STATIC + USE DECAY_RATE + USE DIFFUSION_COEFFICIENT + USE VISCOSITY + USE EXTERNAL_DAMPING +! + USE DAMPING_SI +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: IQ +! + INTEGER :: I,LOGF +! + REAL (WP), INTENT(IN) :: X ! q / 2k_F +! + REAL (WP) :: POW1,POW2 +! + LOGF = 6 ! log file unit +! +! Initialization +! + LFT = LARGE ! + TAU = LARGE ! + TAU2 = LARGE ! + NNU = ZERO ! + DIF = ZERO ! + ETA = ZERO ! +! +! Power for external value +! + CALL CALC_POWER(POWER_1,POW1) ! +! + IF(DAMPING == 'RELA' .AND. RT_TYPE == 'EX2') THEN ! + CALL CALC_POWER(POWER_2,POW2) ! + END IF ! +! +! Setting up the selected kind of damping +! + IF(DAMPING == 'LFTM') THEN ! + IF(LT_TYPE == 'EXTE') THEN ! + LFT = D_VALUE_1 * POW1 ! + ELSE ! + CALL LIFETIME_COEF(X,LFT) ! + END IF ! + ELSE IF (DAMPING == 'RELA') THEN ! + IF(RT_TYPE == 'EX1') THEN ! + TAU = D_VALUE_1 * POW1 ! + ELSE IF(RT_TYPE == 'EX2') THEN ! + TAU = D_VALUE_1 * POW1 ! + TAU2 = D_VALUE_2 * POW2 ! + ELSE ! + CALL RELAXATION_TIME(X,TAU) ! + END IF ! + ELSE IF (DAMPING == 'DECA') THEN ! + IF(DR_TYPE == 'EXTE') THEN ! + NNU = D_VALUE_1 * POW1 ! + ELSE ! + CALL DECAY_RATE_COEF(X,NNU) ! + END IF ! + ELSE IF (DAMPING == 'DIFF') THEN ! + IF(DC_TYPE == 'EXTE') THEN ! + DIF = D_VALUE_1 * POW1 ! + ELSE ! + CALL DIFFUSION_COEF(DIF) ! + END IF ! + ELSE IF (DAMPING == 'VISC') THEN ! + IF(VI_TYPE == 'EXTE') THEN ! + ETA = D_VALUE_1 * POW1 ! + ELSE ! + CALL VISCOSITY_COEF(X,ETA) ! + END IF ! + END IF ! +! +! Printing the results +! + IF( (I_WR == 1) .OR. ( (I_WR == 2) .AND. (IQ == 1) ) ) THEN ! + DO I = 1, 3 ! + WRITE(LOGF,5) ! + END DO ! + IF(DAMPING /= 'NONE') THEN ! + WRITE(LOGF,10) ! + WRITE(LOGF,20) ! + IF(DAMPING == 'LFTM') THEN ! + WRITE(LOGF,31) LFT ! + ELSE IF (DAMPING == 'RELA') THEN ! + WRITE(LOGF,32) TAU ! + IF(RT_TYPE == 'EX2') WRITE(LOGF,33) TAU2 ! + ELSE IF (DAMPING == 'DECA') THEN ! + WRITE(LOGF,34) NNU ! + ELSE IF (DAMPING == 'DIFF') THEN ! + WRITE(LOGF,35) DIF ! + ELSE IF (DAMPING == 'VISC') THEN ! + WRITE(LOGF,36) ETA ! + END IF ! + WRITE(LOGF,40) ! + END IF ! + END IF ! +! +! Formats: +! + 5 FORMAT(' ') + 10 FORMAT(6X,'_________________________________________________________') + 20 FORMAT(5X,'| |') + 31 FORMAT(5X,'| DAMPING CHOSEN: lifetime = ',E12.6,' s |') + 32 FORMAT(5X,'| DAMPING CHOSEN: relaxation time = ',E12.6,' s |') + 33 FORMAT(5X,'| DAMPING CHOSEN: relaxation time 2 = ',E12.6,' s |') + 34 FORMAT(5X,'| DAMPING CHOSEN: decay time = ',E12.6,' /s|') + 35 FORMAT(5X,'| DAMPING CHOSEN: diffusion coefficient = ',E12.6,' SI|') + 36 FORMAT(5X,'| DAMPING CHOSEN: viscosity = ',E12.6,' SI|') + 40 FORMAT(5X,'|_________________________________________________________|',/) +! + END SUBROUTINE CALC_DAMPING +! +END MODULE DAMPING_COEF diff --git a/New_libraries/DFM_library/DAMPING_LIBRARY/classical_fluid.f90 b/New_libraries/DFM_library/DAMPING_LIBRARY/classical_fluid.f90 new file mode 100644 index 0000000..57376b9 --- /dev/null +++ b/New_libraries/DFM_library/DAMPING_LIBRARY/classical_fluid.f90 @@ -0,0 +1,382 @@ +! +!======================================================================= +! +MODULE CLASSICAL_FLUID +! + USE ACCURACY_REAL +! +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE CFLUID_3D(R,N0,T,EPS,CF_TYPE,D,LAMBDA,ETA,ZETA) +! +! This subroutine computes the self-diffusion, thermal conductivity, +! shear viscosity and bulk viscosity of a classical 3D fluid +! composed of identical spheres. +! +! References: (1) O. Kravchenko and M. Thachuk, J. Chem. Phys. 136, 044520 (2012) +! (2) K. M. Dyer, B. M. Pettitt and G. Stell, J. Chem. Phys. 126, +! 034502 (2007) +! (3) J.-M. Bomont and J.-L. Bretonnet, Chem. Phys. 439, 85-94 (2014) +! +! +! Input parameters: +! +! * R : sphere's radius (SI) +! * N0 : number density of spheres (SI) +! * T : temperature (SI) +! * EPS : depth of Lennard-Jones potential (SI) +! * CF_TYPE : type of classical fluid calculation +! CF_TYPE = 'SHS' smooth hard spheres +! CF_TYPE = 'RH1' rough hard spheres (Pidduck) +! CF_TYPE = 'RH2' rough hard spheres (Condiff-Lu-Dahler) +! CF_TYPE = 'RH3' rough hard spheres (McCoy-Sandler-Dahler) +! CF_TYPE = 'DCE' dilute Chapman-Enskog +! CF_TYPE = 'HCE' heavy (i.e. dense) Chapman-Enskog +! CF_TYPE = 'LJF' Lennard-Jones fluid +! +! +! Note: The Lennard-Jones potential is written as +! +! _ _ +! | ( 2R )^12 ( 2R )^6 | +! V(r) = 4*EPS * | ( ---- ) - ( ---- ) | +! |_ ( r ) ( r ) _| +! +! +! Output parameters: +! +! * D : (self-)diffusion coefficient +! * LAMBDA : thermal conductivity +! * ETA : shear viscosity +! * ZETA : bulk viscosity +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,FIVE, & + SIX,SEVEN,EIGHT,NINE,TEN, & + HALF,THIRD + USE CONSTANTS_P1, ONLY : M_E,K_B + USE PI_ETC, ONLY : PI,PI_INV + USE PACKING_FRACTION, ONLY : PACK_FRAC_3D +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: CF_TYPE +! + REAL (WP) :: R,N0,T,EPS + REAL (WP) :: D,LAMBDA,ETA,ZETA + REAL (WP) :: SG,S2,S3,AL,AL2,AL3,AL4 + REAL (WP) :: DZ,L0,E0,Z0 + REAL (WP) :: K1,K2,NUM,DEN,C0,C1,C2 + REAL (WP) :: B,G,BRG,PF + REAL (WP) :: TS,NS,Y,Z +! + SG=R+R ! particle diameter + S2=SG*SG ! + S3=S2*SG ! + B=TWO*PI*SG*S2*THIRD ! 2nd virial coefficient + AL=0.40E0_WP ! reduced moment of inertia +! ! of sphere with uniform mass density + AL2=AL*AL ! + AL3=AL2*AL ! + AL4=AL3*AL ! +! + K1=DSQRT(K_B*T*PI_INV/M_E) ! + K2=DSQRT(K_B*T*PI_INV*M_E) ! +! +! Computing the packing fraction +! + PF=PACK_FRAC_3D(N0,SG,'HSM') ! +! +! Carnahan-Starling value of contact value of radial distribution +! + G=(ONE-HALF*PF) / (ONE-PF)**3 ! ref. 1 eq. (32) +! + BRG=B*N0*G +! + IF(CF_TYPE == 'SHS') THEN ! +! + NUM=ONE+AL ! + DEN=ONE+AL+AL ! + D=THREE*K1/(EIGHT*N0*S2) ! ref. 1 eq. (17) +! + NUM=12.0E0_WP * (ONE+AL)**2 * ( & ! + 37.0E0_WP + 151.0E0_WP*AL +& ! + 50.0E0_WP*AL2 & ! + ) ! + DEN=25.0E0_WP*( 12.0E0_WP + 75.0E0_WP*AL + & ! + 101.0E0_WP*AL2 + 102.0E0_WP*AL3 & ! + ) ! + LAMBDA=75.0E0_WP*K_B*K1/(64.0E0_WP*S2) ! ref. 1 eq. (18) +! + NUM=SIX*(ONE+AL)*(ONE+AL) ! + DEN=SIX+13.0E0_WP*AL ! + ETA=FIVE*K2/(16.0E0_WP*S2) ! ref. 1 eq. (19) +! + ZETA=ZERO ! +! + ELSE IF(CF_TYPE == 'RH1') THEN ! +! + NUM=ONE+AL ! + DEN=ONE+AL+AL ! + DZ=THREE*K1/(EIGHT*N0*S2) ! + D=DZ*NUM/DEN ! ref. 1 eq. (17) +! + NUM=12.0E0_WP * (ONE+AL)**2 * ( 37.0E0_WP + & ! + 151.0E0_WP*AL + & ! + 50.0E0_WP*AL2 & ! + ) ! + DEN=25.0E0_WP*( 12.0E0_WP + 75.0E0_WP*AL + & ! + 101.0E0_WP*AL2 + 102.0E0_WP*AL3 & ! + ) ! + L0=75.0E0_WP*K_B*K1/(64.0E0_WP*S2) ! + LAMBDA=L0*NUM/DEN ! ref. 1 eq. (18) +! + NUM=SIX*(ONE+AL)*(ONE+AL) ! + DEN=SIX+13.0E0_WP*AL ! + E0=FIVE*K2/(16.0E0_WP*S2) ! + ETA=E0*NUM/DEN ! ref. 1 eq. (19) +! + NUM=(ONE+AL)*(ONE+AL) ! + DEN=AL ! + Z0=K2/(32.0E0_WP*S2) ! + ZETA=Z0*NUM/DEN ! ref. 1 eq. (20) +! + ELSE IF(CF_TYPE == 'RH2') THEN ! +! + NUM=ONE+AL ! + DEN=ONE+AL+AL ! + DZ=THREE*K1/(EIGHT*N0*S2) ! + D=DZ*NUM/DEN ! + NUM=PI*AL*(ONE+AL) ! + DEN=TWO*(ONE+AL+AL)*(FIVE+NINE*AL+EIGHT*AL2) ! + D=D/(ONE + NUM/DEN) ! ref. 1 eq. (21) +! + NUM=FOUR*(ONE+AL)*( 1121.0E0_WP + 733.0E0_WP*AL + & ! + 13449.0E0_WP*AL2 + 9490.0E0_WP*AL3 + & ! + 2000.0E0_WP*AL4 & ! + ) ! + DEN=25.0E0_WP*( 116.0E0_WP + 853.0E0_WP*AL + & ! + 1707.0E0_WP*AL2 + 2266.0E0_WP*AL3 + & ! + 1360.0E0_WP*AL4 & ! + ) ! + L0=75.0E0_WP*K_B*K1/(64.0E0_WP*S2) ! + LAMBDA=L0*NUM/DEN ! ref. 1 eq. (22) +! + NUM=TWO*(ONE+AL)*(ONE+AL)*(THREE+TEN*AL) ! + DEN=SIX+33.0E0_WP*AL+35.0E0_WP*AL2 ! + E0=FIVE*K2/(16.0E0_WP*S2) ! + ETA=E0*NUM/DEN ! ref. 1 eq. (23) +! + NUM=(ONE+AL)*(ONE+AL) ! + DEN=AL ! + Z0=K2/(32.0E0_WP*S2) ! + ZETA=Z0*NUM/DEN ! ref. 1 eq. (20) +! + ELSE IF(CF_TYPE == 'RH3') THEN ! +! + NUM=ONE+AL ! + DEN=ONE+AL+AL ! + DZ=THREE*K1/(EIGHT*N0*S2) ! + D=DZ*NUM/DEN ! + NUM=PI*AL*(ONE+AL) ! + DEN=TWO*(ONE+AL+AL)*(FIVE+NINE*AL+EIGHT*AL2) ! + D=D/(ONE + NUM/DEN) ! ref. 1 eq. (21) +! + NUM=FOUR*(ONE+AL)*( 1121.0E0_WP + 733.0E0_WP*AL + & ! + 13449.0E0_WP*AL2 + 9490.0E0_WP*AL3 + & ! + 2000.0E0_WP*AL4 & ! + ) ! + DEN=25.0E0_WP*( 116.0E0_WP + 853.0E0_WP*AL + & ! + 1707.0E0_WP*AL2 + 2266.0E0_WP*AL3 + & ! + 1360.0E0_WP*AL4 & ! + ) ! + L0=75.0E0_WP*K_B*K1/(64.0E0_WP*S2) ! + LAMBDA=L0*NUM/DEN ! ref. 1 eq. (22) +! + NUM=TWO*( 731.0E0_WP + 4958.0E0_WP*AL + 8005.0E0_WP*AL2 +& ! + 5650.0E0_WP*AL3 + 2000.0E0_WP*AL4 & ! + ) ! + DEN=1121.0E0_WP + 7336.0E0_WP*AL + 13449.0E0_WP*AL2 + & ! + 9490.0E0_WP*AL3 + 2000.0E0_WP*AL4 ! + C1=NUM/DEN ! +! + C0=501.0E0_WP + 3355.0E0_WP*AL + 4860.0E0_WP*AL2 + & ! + 3850.0E0_WP*AL3 + 2000.0E0_WP*AL4 ! + NUM=16.0E0_WP*( 116.0E0_WP + 853.0E0_WP*AL + & ! + 1707.0E0_WP*AL2 + 2266.0E0_WP*AL3 + & ! + 1360.0E0_WP*AL4 & ! + ) * PI_INV/(ONE+AL) ! + NUM=C0+NUM ! + C2=NUM/DEN ! + LAMBDA=LAMBDA/G * (ONE + C1*BRG + C2*BRG*BRG) ! ref. 1 eq. (29) +! + NUM=TWO*(ONE+AL)*(ONE+AL)*(THREE+TEN*AL) ! + DEN=SIX+33.0E0_WP*AL+35.0E0_WP*AL2 ! + E0=FIVE*K2/(16.0E0_WP*S2) ! + ETA=E0*NUM/DEN ! ref. 1 eq. (23) + C1=0.40E0_WP*(TWO+FIVE*AL)/(ONE+AL) ! + NUM=SIX*( SIX + 33.0E0_WP*AL + 35.0E0_WP*AL2 & ! + ) * (FOUR+SEVEN*AL) ! + DEN=PI*(THREE+TEN*AL)*(ONE+AL) ! + C2=( (TWO+FIVE*AL)**2 + NUM/DEN ) / (25.0E0_WP*(ONE+AL)**2) ! + ETA=ETA/G * (ONE + C1*BRG + C2*BRG*BRG) ! ref. 1 eq. (26) +! + NUM=(ONE+AL)*(ONE+AL) ! + DEN=AL ! + Z0=K2/(32.0E0_WP*S2) ! + ZETA=Z0*NUM/DEN ! ref. 1 eq. (20) + C1=TWO ! + C2=ONE + 32.0E0_WP*AL/(PI*(ONE+AL)**2) ! + ZETA=ZETA/G * (ONE + C1*BRG + C2*BRG*BRG) ! ref. 1 eq. (27) +! + ELSE IF(CF_TYPE == 'DCE') THEN ! +! + NUM=ONE+AL ! + DEN=ONE+AL+AL ! + D=1.019E0_WP*THREE*K1/(EIGHT*N0*S2) ! ref. 3 eq. (19) +! + NUM=12.0E0_WP * (ONE+AL)**2 * ( 37.0E0_WP + & ! + 151.0E0_WP*AL + & ! + 50.0E0_WP*AL2 & ! + ) ! + DEN=25.0E0_WP*( 12.0E0_WP + 75.0E0_WP*AL + & ! + 101.0E0_WP*AL2 + 102.0E0_WP*AL3 & ! + ) ! + LAMBDA=1.025E0_WP*75.0E0_WP*K_B*K1/(64.0E0_WP*S2) ! ref. 3 eq. (21) +! + NUM=SIX*(ONE+AL)*(ONE+AL) ! + DEN=SIX+13.0E0_WP*AL ! + ETA=1.016E0_WP*FIVE*K2/(16.0E0_WP*S2) ! ref. 3 eq. (20) +! + ZETA=ZERO ! +! + ELSE IF(CF_TYPE == 'HCE') THEN ! +! + Z=FOUR*PF*G ! ref. 3 eq. (4) +! + NUM=ONE+AL ! + DEN=ONE+AL+AL ! + D=1.019E0_WP*THREE*K1/(EIGHT*N0*S2) ! + D=D*FOUR*PF/Z ! ref. 3 eq. (15) +! + NUM=12.0E0_WP * (ONE+AL)**2 * ( 37.0E0_WP + & ! + 151.0E0_WP*AL + & ! + 50.0E0_WP*AL2 & ! + ) ! + DEN=25.0E0_WP*( 12.0E0_WP + 75.0E0_WP*AL + & ! + 101.0E0_WP*AL2 + 102.0E0_WP*AL3 & ! + ) ! + LAMBDA=1.025E0_WP*75.0E0_WP*K_B*K1/(64.0E0_WP*S2) ! + LAMBDA=LAMBDA*FOUR*PF*(ONE/Z + 1.2E0_WP + 0.755E0_WP*Z) ! ref. 3 eq. (18) +! + NUM=SIX*(ONE+AL)*(ONE+AL) ! + DEN=SIX+13.0E0_WP*AL ! + ETA=1.016E0_WP*FIVE*K2/(16.0E0_WP*S2) ! + ETA=ETA*FOUR*PF*(ONE/Z + 0.8E0_WP + 0.761E0_WP*Z) ! ref. 3 eq. (16) +! + ZETA=ETA*FOUR*PF*1.002E0_WP*Z ! ref. 3 eq. (17) +! + ELSE IF(CF_TYPE == 'LJF') THEN ! +! + TS=K_B*T/EPS ! T* + NS=N0*S3 ! rho* + Y=TWO*PI*NS*THIRD ! +! + DZ=0.375E0_WP*DSQRT(TS*PI_INV/M_E)/SG ! + D=DZ/(NS*G) ! ref. 2 eq. (3) +! + LAMBDA=ZERO ! not provided +! + E0=0.3125E0_WP*DSQRT(M_E*TS*PI_INV)/S2 ! + ETA=E0*(ONE/G + 0.8E0_WP*Y + 0.761E0_WP*Y*Y*G) ! ref. 2 eq. (4) +! + ZETA=E0*1.002E0_WP*Y*Y*G ! +! + END IF ! +! + END SUBROUTINE CFLUID_3D +! +!======================================================================= +! + SUBROUTINE CFLUID_2D(R,N0,T,CF_TYPE,D,LAMBDA,ETA,ZETA) +! +! This subroutine computes the self-diffusion, thermal conductivity, +! shear viscosity and bulk viscosity of a classical 2D fluid +! composed of identical spheres. +! +! References: (1) R. Garcia-Rojo, S. Luding and J. J. Brey, +! Phys. Rev. E 74, 061395 (2006) +! +! +! Input parameters: +! +! * R : disks radius (SI) +! * N0 : number density of spheres (SI) +! * T : temperature (SI) +! * CF_TYPE : type of classical fluid calculation +! CF_TYPE = 'DHD' dense hard disks +! +! +! Output parameters: +! +! * D : (self-)diffusion coefficient +! * LAMBDA : thermal conductivity +! * ETA : shear viscosity +! * ZETA : bulk viscosity +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,SEVEN, & + EIGHT,NINE,HALF + USE CONSTANTS_P1, ONLY : M_E,K_B + USE PI_ETC, ONLY : PI_INV + USE PACKING_FRACTION, ONLY : PACK_FRAC_2D +! + IMPLICIT NONE +! + CHARACTER*3 CF_TYPE +! + REAL (WP) :: R,N0,T + REAL (WP) :: K1,K2,SG,PF,G + REAL (WP) :: D,LAMBDA,ETA,ZETA +! + K1=DSQRT(K_B*T*PI_INV/M_E) ! + K2=DSQRT(K_B*T*PI_INV*M_E) ! +! + SG=R+R ! particle diameter +! +! Computing the packing fraction +! + PF=PACK_FRAC_2D(N0,SG,'HDM') ! +! +! Henderson's value of contact value of radial distribution +! + G=(ONE -SEVEN*PF/16.0E0_WP) / (ONE-PF)**2 ! ref. 1 eq. (6) +! + IF(CF_TYPE == 'DHD') THEN ! + D=HALF*K1 / (N0*SG*G) ! ref. 1 eq. (5) + LAMBDA=TWO*K_B*K1* ( &! + ONE/G + THREE*PF + &! + (NINE/FOUR + FOUR*PI_INV)*G*PF*PF &! ref. 1 eq. (24) + ) / SG ! + ETA=HALF*K2* ( &! + ONE/G + TWO*PF + &! + (ONE+EIGHT*PI_INV)*G*PF*PF &! ref. 1 eq. (15) + ) / SG ! + ZETA=EIGHT*K2*PF*PF*G*PI_INV/SG ! ref. 1 eq. (22) + END IF ! +! + END SUBROUTINE CFLUID_2D +! +END MODULE CLASSICAL_FLUID diff --git a/New_libraries/DFM_library/DAMPING_LIBRARY/decay_rate.f90 b/New_libraries/DFM_library/DAMPING_LIBRARY/decay_rate.f90 new file mode 100644 index 0000000..1ec0007 --- /dev/null +++ b/New_libraries/DFM_library/DAMPING_LIBRARY/decay_rate.f90 @@ -0,0 +1,225 @@ +! +!======================================================================= +! +MODULE DECAY_RATE +! + USE ACCURACY_REAL +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE DECAY_RATE_COEF(X,DR) +! +! This subroutine computes the decay rate +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Output parameters: +! +! * DR : decay rate +! +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Nov 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN,RS + USE EXT_FIELDS, ONLY : T + USE LF_VALUES, ONLY : GQ_TYPE,IQ_TYPE + USE SF_VALUES, ONLY : SQ_TYPE +! + USE DAMPING_VALUES, ONLY : DR_TYPE +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP), INTENT(OUT) :: DR +! + IF(DMN == '3D') THEN ! + CALL DECAY_RATE_3D(X,T,RS,DR_TYPE,SQ_TYPE,GQ_TYPE, & ! + IQ_TYPE,DR) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! not implemented yet + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! not implemented yet + END IF ! +! + END SUBROUTINE DECAY_RATE_COEF +! +!======================================================================= +! + SUBROUTINE DECAY_RATE_3D(X,T,RS,DR_TYPE,SQ_TYPE,GQ_TYPE, & + IQ_TYPE,DR) +! +! This subroutine computes the plasmon decay rate +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * T : temperature (in SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! * DR_TYPE : type of decay rate +! DR_TYPE = 'UTIC' --> Utsumi-Ichimaru approximation +! DR_TYPE = 'VLAS' --> Vlasov approximation +! * SQ_TYPE : structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! * IQ_TYPE : type of approximation for I(q) +! +! Output parameters: +! +! * DR : decay rate +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: DR_TYPE,GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE,IQ_TYPE +! + REAL (WP) :: X,T,RS + REAL (WP) :: DR +! + IF(DR_TYPE == 'UTIC') THEN ! + DR=UTIC_DR_3D(X,RS,T,SQ_TYPE,GQ_TYPE,IQ_TYPE) ! + ELSE IF(DR_TYPE == 'VLAS') THEN ! + DR=VLAS_DR_3D(X,T,RS) ! + END IF ! +! + END SUBROUTINE DECAY_RATE_3D +! +!======================================================================= +! + FUNCTION UTIC_DR_3D(X,RS,T,SQ_TYPE,GQ_TYPE,IQ_TYPE) +! +! This function computes Utsumi-Ichimaru approximation for +! the decay rate in the 3D case +! +! Reference: (1) K. Utsumi and S. Ichimaru, +! Phys. Rev. B 22, 1522-1533 (1980) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (in SI) +! * SQ_TYPE : structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! * IQ_TYPE : type of approximation for I(q) +! +! Output parameters: +! +! * UTIC_DR : decay rate +! +! Author : D. Sébilleau +! +! Last modified : 3 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : HALF + USE CONSTANTS_P1, ONLY : H_BAR + USE UTIC_PARAMETERS, ONLY : UTIC_PARAM + USE RELAXATION_TIME_STATIC, ONLY : UTIC_RT_3D + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE,IQ_TYPE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: UTIC_DR_3D +! + REAL (WP) :: OMP + REAL (WP) :: TAU_Q,OMQ,OM0 +! + REAL (WP) :: EXP +! + OMP = ENE_P_SI / H_BAR ! omega_p in SI +! +! Computing the Utsumi-Ichimaru parameters OMEGA(q) and OMEGA(0) +! + CALL UTIC_PARAM(X,RS,T,OMQ,OM0) ! +! +! Computing the relaxation time TAU_Q +! + TAU_Q = UTIC_RT_3D(X,RS,T,SQ_TYPE,GQ_TYPE) ! +! + UTIC_DR_3D = - HALF * EXP(- HALF * (OMP / OM0)**2) / TAU_Q ! ref. 1 eq. (5.13) +! + END FUNCTION UTIC_DR_3D +! +!======================================================================= +! + FUNCTION VLAS_DR_3D(X,RS,T) +! +! This function computes Vlasov approximation for +! the decay rate in the 3D case +! +! Reference: (1) S. Ichimaru, "Statistical Plasma Physics - Vol1", +! CRC Press (2004) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (in SI) +! +! Output parameters: +! +! * VLAS_DR : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,THREE,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,RS,T + REAL (WP) :: VLAS_DR_3D + REAL (WP) :: Q_SI,KD_SI,OQ2,AA +! + REAL (WP) :: DSQRT,DEXP +! + Q_SI=TWO*X*KF_SI ! q +! +! Computing the Debye screening vector +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! +! Computing the square of the Vlasov plasmon dispersion +! + OQ2=ENE_P_SI*ENE_P_SI + THREE*K_B*T*Q_SI*Q_SI/M_E ! ref. 1 eq. (4.30) +! + AA=HALF*M_E*OQ2/(Q_SI*Q_SI*K_B*T) ! +! + VLAS_DR_3D=DSQRT(0.125E0_WP*PI)*ENE_P_SI*(KD_SI/Q_SI)**3 * & ! ref. 1 eq. (4.31) + DEXP(-AA) / H_BAR ! +! + END FUNCTION VLAS_DR_3D +! +END MODULE DECAY_RATE diff --git a/New_libraries/DFM_library/DAMPING_LIBRARY/diffusion_coefficient.f90 b/New_libraries/DFM_library/DAMPING_LIBRARY/diffusion_coefficient.f90 new file mode 100644 index 0000000..52abe88 --- /dev/null +++ b/New_libraries/DFM_library/DAMPING_LIBRARY/diffusion_coefficient.f90 @@ -0,0 +1,152 @@ +! +!======================================================================= +! +MODULE DIFFUSION_COEFFICIENT +! + USE ACCURACY_REAL +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE DIFFUSION_COEF(DC) +! +! This subroutine computes the diffusion coefficient +! +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Oct 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN,RS + USE EXT_FIELDS, ONLY : T +! + USE DAMPING_VALUES, ONLY : DC_TYPE +! + USE EL_ELE_INTER, ONLY : S,EPS +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + REAL (WP), INTENT(OUT) :: DC +! + IF(DMN == '3D') THEN ! + CALL DIFFUSION_COEFFICIENT_3D(T,S,EPS,RS,DC_TYPE,DC) + ELSE IF(DMN == '2D') THEN ! + DC = ZERO ! not yet implemented + ELSE IF(DMN == '1D') THEN ! + DC = ZERO ! not yet implemented + END IF ! +! + END SUBROUTINE DIFFUSION_COEF +! +!======================================================================= +! + SUBROUTINE DIFFUSION_COEFFICIENT_3D(T,S,EPS,RS,DC_TYPE,DC) +! +! This subroutine computes the diffusion coefficient for 3D systems +! +! Input parameters: +! +! * T : temperature (SI) +! * S : \ +! * EPS : / parameters of the soft-sphere potential +! * RS : Wigner-Seitz radius (in units of a_0) +! * DC_TYPE : diffusion coefficient in 3D +! DC_TYPE = 'ASHO' --> Ashurst-Hoover +! +! +! Output parameters: +! +! * DC : diffusion coefficient +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: DC_TYPE +! + REAL (WP) :: T,S,EPS,RS + REAL (WP) :: DC +! + IF(DC_TYPE == 'ASHO') THEN ! + DC = ASHO_DC_3D(T,S,EPS,RS) ! + END IF ! +! + END SUBROUTINE DIFFUSION_COEFFICIENT_3D +! +!======================================================================= +! + FUNCTION ASHO_DC_3D(T,S,EPS,RS) +! +! This function computes the Ashurst-Hoover diffusion coefficient +! for 3D hard-sphere fluid at a given value of the temperature T +! +! References: (1) W. T. Ashusrt and W. G. Hoover, Phys. Rev. A 11, +! 658 (1975) +! +! Note: the model uses a soft-sphere interaction potential given by +! +! V_SS(R) = EPS * ( S/R )**12 +! +! Warning: the result is valid for reduced densities XX > 0.6 +! +! with XX = N0 * (EPS / K_B*T)**0.25 +! +! +! Input parameters: +! +! * T : temperature (SI) +! * S : \ +! * EPS : / parameters of the soft-sphere potential +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Output parameters: +! +! * ASHO_DC_3D +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOURTH + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : RS_TO_N0 +! + IMPLICIT NONE +! + REAL (WP) :: T,S,EPS,RS + REAL (WP) :: ASHO_DC_3D + REAL (WP) :: N0 + REAL (WP) :: D0,CC,XX,KK,S3 +! + REAL (WP) :: SQRT,EXP +! + KK = 0.416666666666666666666666666666666667E0_WP ! 5/12 +! + S3 = S * S * S ! +! +! Computing the electron density +! + N0 = RS_TO_N0('3D',RS) ! +! + D0 = 4.9E0_WP ! + CC = 6.3E0_WP ! + XX = N0 * S3 * (EPS / (K_B*T))**FOURTH / SQRT(TWO) ! reduced density p. 663 +! + ASHO_DC_3D = S * SQRT(EPS / M_E) * (K_B * T / EPS)**KK * & ! + D0 * EXP(- CC * XX) ! ref. 1 p. 666 +! + END FUNCTION ASHO_DC_3D +! +END MODULE DIFFUSION_COEFFICIENT diff --git a/New_libraries/DFM_library/DAMPING_LIBRARY/diffusion_coefficient_2.f90 b/New_libraries/DFM_library/DAMPING_LIBRARY/diffusion_coefficient_2.f90 new file mode 100644 index 0000000..c0c3e4d --- /dev/null +++ b/New_libraries/DFM_library/DAMPING_LIBRARY/diffusion_coefficient_2.f90 @@ -0,0 +1,101 @@ +! +!======================================================================= +! +MODULE DIFFUSION_COEFFICIENT_2 +! + USE ACCURACY_REAL +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE DIFFUSION_COEF2(X,DC) +! +! This subroutine computes the diffusion coefficient from +! the knowledge of the static susceptibility +! +! Reference: (1) M. Le Bellac, F. Mortessagne and G. G. Batrouni, +! "Equilibrium and Non-Equilibrium Statistical +! Thermodynamics", (Cambridge University Press, 2004) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! Output parameters: +! +! * DC : diffusion coefficient +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE MATERIAL_PROP, ONLY : DMN,RS + USE EXT_FIELDS, ONLY : T + USE UNITS, ONLY : UNIT +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO + USE CONSTANTS_P1, ONLY : M_E + USE FERMI_SI, ONLY : KF_SI +! + USE LF_VALUES, ONLY : GQ_TYPE + USE DF_VALUES, ONLY : EPS_T,D_FUNC +! + USE DFUNC_STATIC + USE LOCAL_FIELD_STATIC + USE DAMPING_COEF + USE COULOMB_K, ONLY : COULOMB_FF + USE UTILITIES_1, ONLY : RS_TO_N0 + USE DAMPING_SI +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP), INTENT(IN) :: X + REAL (WP), INTENT(OUT) :: DC +! + REAL (WP) :: EPSR,EPSI + REAL (WP) :: GQ,CHI_0,CHI_Q + REAL (WP) :: NUM,DEN + REAL (WP) :: Q_SI,VC + REAL (WP) :: NN +! + Q_SI = TWO * X * KF_SI ! q in SI +! + IF(EPS_T == 'LONG') THEN ! + D_FUNCL = D_FUNC ! + END IF ! +! +! Computing the Coulomb potential VC +! + CALL COULOMB_FF(DMN,UNIT,Q_SI,ZERO,VC) ! Coulomb pot. +! +! Computing the static dielectric function and +! the static local field correction +! + CALL DFUNCL_STATIC(X,D_FUNCL,EPSR,EPSI) ! + CALL LFIELD_STATIC(X,RS,T,GQ_TYPE,GQ) ! +! + CHI_0 = (ONE - EPSR) / VC ! +! + NUM = CHI_0 ! + DEN = ONE + VC * (GQ - ONE) * CHI_0 ! + CHI_Q = NUM / DEN ! +! +! Computing the density NN +! + NN = RS_TO_N0(DMN,RS) ! +! + DC = TAU * NN / (M_E * CHI_Q) ! ref. 1 eq. (9.91) +! + END SUBROUTINE DIFFUSION_COEF2 +! +END MODULE DIFFUSION_COEFFICIENT_2 + + diff --git a/New_libraries/DFM_library/DAMPING_LIBRARY/electron_phonon_int.f90 b/New_libraries/DFM_library/DAMPING_LIBRARY/electron_phonon_int.f90 new file mode 100644 index 0000000..e936a27 --- /dev/null +++ b/New_libraries/DFM_library/DAMPING_LIBRARY/electron_phonon_int.f90 @@ -0,0 +1,98 @@ +! +!======================================================================= +! +MODULE ELECTRON_PHONON_INT +! + USE ACCURACY_REAL +! +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE EL_PHONON_INT_3D(X,EPH,EPS0,EPSI,IP) +! +! This subroutine computes the electron-phonon interaction +! for 3D systems +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * EPH : phonon energy -SI) +! * EPS0 : +! * EPSI : +! * IP_TYPE : type of electron-phonon interaction +! IP_TYPE = 'DEHI' --> Degani-Hipolito approximation +! +! Output parameters: +! +! * IP : electron-phonon interaction +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: IP_TYPE +! + REAL (WP), INTENT(IN) :: X,EPH,EPS0,EPSI +! + COMPLEX (WP) :: IP +! + IF(IP_TYPE == 'DEHI') THEN ! + IP = DEHI_EP_3D(X,EPH,EPS0,EPSI) ! + END IF ! +! + END SUBROUTINE EL_PHONON_INT_3D +! +!======================================================================= +! + FUNCTION DEHI_EP_3D(X,EPH,EPS0,EPSI) +! +! This function computes the Fourier coefficient of the electron-phonon +! interaction +! +! Reference: (1) M. H. Degani and O. Hipolito, Phys. Rev. B 35, 9345-9348 (1987) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * EPH : phonon energy -SI) +! * EPS0 : +! * EPSI : +! +! Output parameters: +! +! * DEHI_EPI : Fourier coefficient +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI +! +! + REAL (WP), INTENT(IN) :: X,EPH,EPS0,EPSI + REAL (WP) :: Q,SQR +! + REAL (WP) :: SQRT +! + COMPLEX (WP) :: DEHI_EP_3D +! + Q = TWO * X * KF_SI ! phonon momentum + SQR = SQRT(TWO * PI * E * E * (ONE / EPSI - ONE / EPS0) /EPH) ! +! + DEHI_EP_3D = - IC * EPH * SQR / Q ! ref. 1 eq. (2) +! + END FUNCTION DEHI_EP_3D +! +END MODULE ELECTRON_PHONON_INT diff --git a/New_libraries/DFM_library/DAMPING_LIBRARY/external_damping.f90 b/New_libraries/DFM_library/DAMPING_LIBRARY/external_damping.f90 new file mode 100644 index 0000000..854eb99 --- /dev/null +++ b/New_libraries/DFM_library/DAMPING_LIBRARY/external_damping.f90 @@ -0,0 +1,79 @@ +! +!======================================================================= +! +MODULE EXTERNAL_DAMPING +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_POWER(POWER,POW) +! +! This subroutine sets up the power coefficient of the damping +! +! +! Input parameters: +! +! * POWER : string for the power coefficient +! +! +! Output parameters: +! +! * POW : value of the power coefficient +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE POWERS_OF_TEN + USE DAMPING_VALUES +! + IMPLICIT NONE +! + REAL (WP), INTENT(OUT) :: POW +! + CHARACTER (LEN = 5) :: POWER +! + IF(POWER == ' KILO') THEN ! + POW = KILO ! + ELSE IF(POWER == ' MEGA') THEN ! + POW = MEGA ! + ELSE IF(POWER == ' GIGA') THEN ! + POW = GIGA ! + ELSE IF(POWER == ' TERA') THEN ! + POW = TERA ! + ELSE IF(POWER == ' PETA') THEN ! + POW = PETA ! + ELSE IF(POWER == ' EXA') THEN ! + POW = EXA ! + ELSE IF(POWER == 'ZETTA') THEN ! + POW = ZETTA ! + ELSE IF(POWER == 'YOTTA') THEN ! + POW = YOTTA ! +! + ELSE IF(POWER == 'MILLI') THEN ! + POW = MILLI ! + ELSE IF(POWER == 'MICRO') THEN ! + POW = MICRO ! + ELSE IF(POWER == ' NANO') THEN ! + POW = NANO ! + ELSE IF(POWER == ' PICO') THEN ! + POW = PICO ! + ELSE IF(POWER == 'FEMTO') THEN ! + POW = FEMTO ! + ELSE IF(POWER == ' ATTO') THEN ! + POW = ATTO ! + ELSE IF(POWER == 'ZEPTO') THEN ! + POW = ZEPTO ! + ELSE IF(POWER == 'YOCTO') THEN ! + POW = YOCTO ! + END IF ! +! + END SUBROUTINE CALC_POWER +! +END MODULE EXTERNAL_DAMPING + diff --git a/New_libraries/DFM_library/DAMPING_LIBRARY/lifetime.f90 b/New_libraries/DFM_library/DAMPING_LIBRARY/lifetime.f90 new file mode 100644 index 0000000..96a228c --- /dev/null +++ b/New_libraries/DFM_library/DAMPING_LIBRARY/lifetime.f90 @@ -0,0 +1,1111 @@ +! +!======================================================================= +! +MODULE LIFETIME +! + USE ACCURACY_REAL +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE LIFETIME_COEF(X,LFT) +! +! This subroutine computes the lifetime of a quasiparticle +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Output parameters: +! +! * LFT : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 12 Nov 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN,RS + USE EXT_FIELDS, ONLY : T +! + USE REAL_NUMBERS, ONLY : TWO,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI +! + USE SCREENING_TYPE + USE DAMPING_VALUES, ONLY : LT_TYPE + USE CLASSICAL_FLUID_VALUES, ONLY : SL_TYPE + USE EL_ELE_INTER, ONLY : S,EPS +! + USE SCREENING_VEC + USE SCATTERING_LENGTH +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP), INTENT(OUT) :: LFT +! + REAL (WP) :: Q_SI + REAL (WP) :: EK + REAL (WP) :: A_SC,KS_SI +! + Q_SI = TWO * KF_SI * X ! q in SI +! +! Computing the quasiparticle energy +! + EK = HALF * H_BAR* H_BAR * Q_SI * Q_SI / M_E ! +! +! Computing the screening vector +! + CALL SCREENING_VECTOR(SC_TYPE,'3D',X,RS,T,KS_SI) ! +! + IF(DMN == '3D') THEN ! + A_SC = SCAT_LENGTH_3D(EPS,S,Q_SI,KS_SI,SL_TYPE) ! + CALL LIFETIME_3D(EK,RS,T,A_SC,LT_TYPE,LFT) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! not yet implemented + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! not yet implemented + END IF ! +! + END SUBROUTINE LIFETIME_COEF +! +!------ 1) 3D case -------------------------------------------- +! +!======================================================================= +! + SUBROUTINE LIFETIME_3D(EK,RS,T,A_SC,LT_TYPE,TAU) +! +! This subroutine computes the lifetime of a quasiparticle +! in a 3D systems. +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! * A_SC : quasiparticle scattering length in SI +! * LT_TYPE : approximation used +! LT_TYPE = 'QUFE' Quinn-Ferrell formula +! LT_TYPE = 'GIVI' Giuliani-Vignale formula +! LT_TYPE = 'DAVI' Davies formula +! LT_TYPE = 'QIVI' Qian-Vignale formula +! LT_TYPE = 'INPE' Inogamov-Petrov formula +! LT_TYPE = 'LUBR' Lugovskoy-Bray formula +! LT_TYPE = 'GALI' Galitskii formula +! LT_TYPE = 'NAEC' Nagy-Echenique formula +! LT_TYPE = 'GIQU' Giuliani-Quinn formula +! +! +! Output parameters: +! +! * TAU : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: LT_TYPE +! + REAL (WP) :: EK,RS,T,A_SC + REAL (WP) :: TAU +! + IF(LT_TYPE == 'QUFE') THEN ! + TAU = QUFE_LT_3D(EK,RS) ! + ELSE IF(LT_TYPE == 'GIVI') THEN ! + TAU = GIVI_LT_3D(EK,RS,T) ! + ELSE IF(LT_TYPE == 'DAVI') THEN ! + TAU = DAVI_LT_3D(EK,T) ! + ELSE IF(LT_TYPE == 'QIVI') THEN ! + TAU = QIVI_LT_3D(EK,T) ! + ELSE IF(LT_TYPE == 'INPE') THEN ! + TAU = INPE_LT_3D(EK,T) ! + ELSE IF(LT_TYPE == 'LUBR') THEN ! + TAU = LUBR_LT_3D(EK,T) ! + ELSE IF(LT_TYPE == 'GALI') THEN ! + TAU = GALI_LT_3D(EK,A_SC,RS) ! + ELSE IF(LT_TYPE == 'NAEC') THEN ! + TAU = NAEC_LT_3D(EK,RS) ! + ELSE IF(LT_TYPE == 'GIQU') THEN ! + TAU = GIQU_LT_3D(EK,T) ! + END IF ! +! + END SUBROUTINE LIFETIME_3D +! +!======================================================================= +! + FUNCTION DAVI_LT_3D(EK,T) +! +! This function computes Davies approximation for +! the quasiparticle lifetime in the 3D case +! +! References: (1) R. W. Davies, J. Phys. Chem. Solids 28, +! 1001-1008 (1967) +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * T : system temperature in SI +! +! Output parameters: +! +! * DAVI_LT_3D : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR + USE CONSTANTS_P1, ONLY : H_BAR,E,K_B + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,T + REAL (WP) :: DAVI_LT_3D + REAL (WP) :: UAT + REAL (WP) :: R4,K_TF_SI + REAL (WP) :: CP,DELTA,EMKT,GAMMA +! + REAL (WP) :: ATAN +! +! Computing the Thomas-Fermi momentum +! + CALL THOMAS_FERMI_VECTOR('3D',K_TF_SI) ! +! + R4 = KF_SI / K_TF_SI ! + CP = MU('3D',T) ! chemical potential + DELTA = EK - CP ! + EMKT = DELTA**2 + (PI * K_B * T)**2 ! +! + GAMMA = E * E * R4 * ( ATAN(TWO * R4) + & ! + TWO * R4 / (ONE + FOUR * R4 * R4) ) *& ! ref. (1) eq. (A.10) + R4 * EMKT / (32.0E0_WP * EF_SI * EF_SI) ! +! + UAT = TWO * GAMMA / H_BAR ! ref. (1) eq. (28) +! + DAVI_LT_3D = ONE / UAT ! +! + END FUNCTION DAVI_LT_3D +! +!======================================================================= +! + FUNCTION GALI_LT_3D(EK,A_SC,RS) +! +! This function computes Galitskii approximation for +! the quasiparticle lifetime in the 3D case +! +! References: (1) I. Nagy and P. M. Echenique, Phys. Rev. B 85, +! 115131 (2012) +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * A_SC : quasiparticle scattering length in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Output parameters: +! +! * GALI_LT_3D : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,FIVE, & + SEVEN,EIGHT,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : EF_SI,VF_SI + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : RS_TO_N0 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,A_SC,RS + REAL (WP) :: GALI_LT_3D + REAL (WP) :: UAT + REAL (WP) :: R1,V + REAL (WP) :: N0 +! + REAL (WP) :: SQRT +! + N0 = RS_TO_N0('3D',RS) ! +! + R1 = EK / EF_SI ! + V = FOUR * PI * A_SC * H_BAR * H_BAR / M_E ! interaction potential +! ! + UAT = N0 * THREE * VF_SI * ( EIGHT * V * V / & ! + (15.0E0_WP * SQRT(R1)) * ( & ! + (TWO - R1)**2.5E0_WP + & ! ref. (1) eq. (1) + HALF * (FIVE * R1 - SEVEN) ) & ! + ) / (16.0E0_WP * PI) ! +! + GALI_LT_3D = ONE / UAT ! +! + END FUNCTION GALI_LT_3D +!======================================================================= +! + FUNCTION GIQU_LT_3D(EK,T) +! +! This function computes Giuliani-Quinn approximation for +! the quasiparticle lifetime in the 3D case +! +! References: (1) G. F. Giuliani and J. J. Quinn, Phys. Rev. B 26, +! 4421-4428 (1982) +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * T : system temperature in SI +! +! Output parameters: +! +! * GIQU_LT_3D : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOURTH + USE CONSTANTS_P1, ONLY : H_BAR,E + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP) :: EK,T + REAL (WP) :: GIQU_LT_3D + REAL (WP) :: UAT + REAL (WP) :: R4,K_TF_SI + REAL (WP) :: CP,DELTA +! + REAL (WP) :: ATAN +! + CP = MU('3D',T) ! chemical potential +! + DELTA = EK - CP ! +! +! Computing the Thomas-Fermi momentum +! + CALL THOMAS_FERMI_VECTOR('3D',K_TF_SI) ! +! + R4 = KF_SI / K_TF_SI ! k_F / k_TF +! + UAT = E * E * KF_SI * ( ONE / (ONE + FOURTH / (R4 * R4)) + & ! + TWO * R4 * ATAN(TWO * R4) & ! + ) * & ! ref. (1) eq. (C1) + (DELTA / EF_SI)**2 & ! + / (32.0E0_WP * H_BAR) ! +! + GIQU_LT_3D = ONE / UAT ! +! + END FUNCTION GIQU_LT_3D +! +!======================================================================= +! + FUNCTION GIVI_LT_3D(EK,RS,T) +! +! This function computes Giuliani-Vignale approximation for +! the quasiparticle lifetime in the 3D case +! +! References: (1) G. Giuliani and G. Vignale, "Quantum Theory of the +! Electron Liquid", Cambridge Uiversity Press (2005) +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! Output parameters: +! +! * GIVI_LT_3D : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,EIGHT,HALF,FOURTH + USE CONSTANTS_P1, ONLY : H_BAR,K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : ALFA + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,RS,T + REAL (WP) :: GIVI_LT_3D + REAL (WP) :: UAT + REAL (WP) :: R3,ALPHA + REAL (WP) :: CP,DELTA,EMKT,ZETA,EXPO +! + REAL (WP) :: SQRT,TAN,EXP +! + ALPHA = ALFA('3D') ! +! + R3 = PI / (ALPHA * RS) ! + CP = MU('3D',T) ! chemical potential + DELTA = EK - CP ! + EMKT = DELTA**2 + (PI * K_B * T)**2 ! +! + ZETA = SQRT(FOURTH / R3) * TAN(SQRT(R3)) + HALF / (ONE + R3) ! ref. (1) eq. (8.92) + EXPO = EXP(- DELTA / (K_B * T)) ! +! + UAT = PI * EMKT * ZETA / & ! ref. (1) eq. (8.93) + (EIGHT * H_BAR * EF_SI * (ONE + EXPO)) ! +! + GIVI_LT_3D = ONE / UAT ! +! + END FUNCTION GIVI_LT_3D +! +!======================================================================= +! + FUNCTION INPE_LT_3D(EK,T) +! +! This function computes Inogamov-Petrov approximation for +! the quasiparticle lifetime in the 3D case +! +! References: (1) N. A. Inogamov and Yu. V. Petrov, JETP 110, 505-529 (2010) +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * T : system temperature in SI +! +! Output parameters: +! +! * INPE_LT_3D : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,SEVEN,EIGHT + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,K_B + USE PI_ETC, ONLY : PI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,T + REAL (WP) :: INPE_LT_3D + REAL (WP) :: UAT + REAL (WP) :: R4,COEF1,COEF2 + REAL (WP) :: K_TF_SI,K1 + REAL (WP) :: G,ETA +! + REAL (WP) :: SQRT,ATAN +! +! Computing the Thomas-Fermi momentum +! + CALL THOMAS_FERMI_VECTOR('3D',K_TF_SI) ! +! + K1 = SQRT(TWO * M_E * EK) / H_BAR ! k + R4 = K1 / K_TF_SI ! k / k_TF +! + COEF1 = M_E * M_E * M_E * E * E * E * E ! m^3 * e^4 + COEF2 = H_BAR**SEVEN * K1 * K1 * K1 * K1 ! h_bar^7 * k^4 + ETA = TWO * R4 ! + G = ETA**4 / (ONE + ETA * ETA) + ETA**3 * ATAN(ETA) ! +! + UAT = PI * COEF1 * G *K_B * T * K_B * T / (EIGHT * COEF2) ! ref. (1) eq. (24) +! + INPE_LT_3D = ONE / UAT ! +! + END FUNCTION INPE_LT_3D +! +!======================================================================= +! + FUNCTION LUBR_LT_3D(EK,T) +! +! This function computes Lugovskoy-Bray approximation for +! the quasiparticle lifetime in the 3D case +! +! References: (1) +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * T : system temperature in SI +! +! Output parameters: +! +! * LUBR_LT_3D : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,SEVEN,FOUR + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,K_B + USE PI_ETC, ONLY : PI,PI2 + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,T + REAL (WP) :: LUBR_LT_3D + REAL (WP) :: UAT + REAL (WP) :: R4,COEF1,COEF2 + REAL (WP) :: K_TF_SI,K1 + REAL (WP) :: CP,DELTA + REAL (WP) :: G,ETA +! + REAL (WP) :: SQRT,ATAN +! +! Computing the Thomas-Fermi momentum +! + CALL THOMAS_FERMI_VECTOR('3D',K_TF_SI) ! +! + CP = MU('3D',T) ! chemical potential +! + DELTA = EK - CP ! +! + K1 = SQRT(TWO * M_E * EK) / H_BAR ! k + R4 = K1 / K_TF_SI ! k / k_TF +! + COEF1 = M_E * M_E * M_E * E * E * E * E ! m^3 * e^4 + COEF2 = H_BAR**SEVEN * K1 * K1 * K1 * K1 ! h_bar^7 * k^4 + ETA = TWO * R4 ! + G = ETA**4 / (ONE + ETA * ETA) + ETA**3 * ATAN(ETA) - & ! + ATAN(ETA * SQRT(ETA * ETA + TWO)) / & ! + DSQRT(ETA * ETA + TWO) ! +! + UAT = PI * COEF1 * G / (FOUR * COEF2) * ( & ! + (K_B * T)**2 + DELTA * DELTA / PI2 & ! + ) ! +! + LUBR_LT_3D = ONE / UAT ! +! + END FUNCTION LUBR_LT_3D +! +!======================================================================= +! + FUNCTION NAEC_LT_3D(EK,RS) +! +! This function computes Nagy_Echenique approximation for +! the quasiparticle lifetime in the 3D case +! +! References: (1) I. Nagy and P. M. Echenique, Phys. Rev. B 85, +! 115131 (2012) +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Output parameters: +! +! * NAEC_LT_3D : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,EIGHT,THIRD + USE FERMI_SI, ONLY : EF_SI,KF_SI,VF_SI + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : RS_TO_N0 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,RS + REAL (WP) :: NAEC_LT_3D + REAL (WP) :: UAT,KF2 + REAL (WP) :: R1,G1,G2 + REAL (WP) :: N0 +! + REAL (WP) :: LOG,SQRT,ABS +! + N0 = RS_TO_N0('3D',RS) ! + KF2 = KF_SI * KF_SI ! +! + R1 = EK / EF_SI ! + G1 = LOG(R1 - ONE) + EIGHT * THIRD - TWO * LOG(TWO) ! + G2 = TWO * THIRD * (TWO - R1)**1.5E0_WP + & ! + TWO * SQRT(TWO - R1) + & ! + LOG(ABS((SQRT(TWO - R1) - ONE) / (SQRT(TWO - R1) + ONE)))! +! + UAT = N0 * THREE * VF_SI *( (THREE * PI / KF2)**2 * & ! ref. (1) eq. (7) + FOUR * (G1 - G2) * THIRD / & ! + SQRT(R1) & ! + ) ! pb of units ! +! + NAEC_LT_3D = ONE / UAT ! +! + END FUNCTION NAEC_LT_3D +! +!======================================================================= +! + FUNCTION QIVI_LT_3D(EK,T) +! +! This function computes Qian-Vignale approximation for +! the quasiparticle lifetime in the 3D case +! +! References: (1) Z. Qian and G. Vignale, Phys. Rev. B 71, +! 075112 (2005) +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * T : system temperature in SI +! +! Output parameters: +! +! * QIVI_LT_3D : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,K_B + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,T + REAL (WP) :: QIVI_LT_3D + REAL (WP) :: UAT + REAL (WP) :: COEF1,COEF2 + REAL (WP) :: K_TF_SI,KS_SI,K + REAL (WP) :: CP,DELTA,EMKT,LAMBDA,EXPO + REAL (WP) :: UAT_E,UAT_D +! + REAL (WP) :: SQRT,EXP,ATAN +! +! Computing the Thomas-Fermi momentum +! + CALL THOMAS_FERMI_VECTOR('3D',K_TF_SI) ! +! + CP = MU('3D',T) ! chemical potential +! + DELTA = EK - CP ! +! + EMKT = DELTA**2 + (PI * K_B * T)**2 ! +! + KS_SI = K_TF_SI ! + K = SQRT(TWO * M_E * EK / (H_BAR * H_BAR)) ! quasiparticle k in SI + COEF1 = M_E * M_E * M_E * E * E * E * E ! m^3 * e^4 + COEF2 = H_BAR *K * KS_SI * KS_SI * KS_SI ! p * k_s^3 + LAMBDA = TWO * KF_SI / KS_SI ! + EXPO = EXP(- DELTA / (K_B * T)) ! +! + UAT_E = - COEF1 / (PI * COEF2) * & ! + EMKT / (ONE + EXPO) * ONE / & ! + SQRT(LAMBDA * LAMBDA + TWO) * & ! ref. (1) eq. (32) + ( HALF * PI - & ! + ATAN(ONE / (LAMBDA * SQRT(LAMBDA * LAMBDA + TWO)))&! + ) ! +! + UAT_D = PI * COEF1 / (TWO * COEF2) * (K_B * T)**2 * & ! ref. (1) eq. (33) + (LAMBDA / (LAMBDA * LAMBDA + ONE) + ATAN(LAMBDA)) ! +! + UAT = UAT_D + UAT_E ! ref. (1) eq. (3) +! + QIVI_LT_3D = ONE / UAT ! +! + END FUNCTION QIVI_LT_3D +! +!======================================================================= +! + FUNCTION QUFE_LT_3D(EK,RS) +! +! This function computes Quinn-Ferrel approximation for +! the quasiparticle lifetime in the 3D case +! +! References: (1) W. S. Fann et al, Phys. Rev. B 46, 13592-13595 (1992) +! 4421-4428 (1982) +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Output parameters: +! +! * QUFE_LT_3D : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THREE + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI2 + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,RS + REAL (WP) :: QUFE_LT_3D + REAL (WP) :: UAT + REAL (WP) :: R1 +! + REAL (WP) :: SQRT +! + R1 = EK / EF_SI ! +! + UAT = PI2 * SQRT(THREE) * ENE_P_SI * (R1 - ONE) * & ! + (R1 - ONE) / (128.0E0_WP * H_BAR) ! ref. (1) eq. (1)-(2) +! + QUFE_LT_3D = ONE / UAT ! +! + END FUNCTION QUFE_LT_3D +! +!------ 2) 2D case -------------------------------------------- +! +! +!======================================================================= +! + SUBROUTINE LIFETIME_2D(EK,RS,T,A_SI,LT_TYPE,TAU) +! +! This subroutine computes the lifetime of a quasiparticle +! in a 2D systems. +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! * A_SI : layer interspacing in SI +! * LT_TYPE : approximation used +! LT_TYPE = 'GIVI' Giuliani-Vignale formula +! LT_TYPE = 'GIQ1' Giuliani-Quinn formula for e-h loss +! LT_TYPE = 'GIQ2' Giuliani-Quinn formula for plasmon loss +! LT_TYPE = 'QIVI' Qian-Vignale formula +! LT_TYPE = 'MELA' Menashe-Laikhtman formula +! LT_TYPE = 'HAWR' Hawrylak formula +! +! +! Output parameters: +! +! * TAU : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 June 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: LT_TYPE +! + REAL (WP), INTENT(IN) :: EK,RS,T,A_SI + REAL (WP), INTENT(OUT) :: TAU +! + IF(LT_TYPE == 'GIVI') THEN ! + TAU = GIVI_LT_2D(EK,RS,T) ! + ELSE IF(LT_TYPE == 'GIQ1') THEN ! + TAU = GIQ1_LT_2D(EK,T) ! + ELSE IF(LT_TYPE == 'GIQ2') THEN ! + TAU = GIQ2_LT_2D(EK,T) ! + ELSE IF(LT_TYPE == 'QIVI') THEN ! + TAU = QIVI_LT_2D(EK,RS,T) ! + ELSE IF(LT_TYPE == 'MELA') THEN ! + TAU = MELA_LT_2D(EK,T) ! + ELSE IF(LT_TYPE == 'HAWR') THEN ! + TAU = HAWR_LT_2D(EK,A_SI,RS) ! + END IF ! +! + END SUBROUTINE LIFETIME_2D +! +!======================================================================= +! + FUNCTION GIQ1_LT_2D(EK,T) +! +! This function computes Giuliani-Quinn approximation for +! the quasiparticle lifetime in the 2D case +! +! In this approximation, the lifetime is limited by the decay into +! an electron-hole pair +! +! References: (1) G. F. Giuliani and J. J. Quinn, Phys. Rev. B 26, +! 4421-4428 (1982) +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * T : system temperature in SI +! +! Output parameters: +! +! * GIQ1_LT_2D : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF,FOUR + USE CONSTANTS_P1, ONLY : H_BAR,K_B + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,T + REAL (WP) :: GIQ1_LT_2D + REAL (WP) :: UAT + REAL (WP) :: R1,R2,K_TF_SI + REAL (WP) :: CP,DELTA + REAL (WP) :: SMALL +! + REAL (WP) :: LOG +! + SMALL = 1.E-1_WP ! +! +! Computing the Thomas-Fermi momentum +! + CALL THOMAS_FERMI_VECTOR('3D',K_TF_SI) ! +! + CP = MU('2D',T) ! chemical potential + DELTA = EK - CP ! + R1 = DELTA / EF_SI ! + R2 = K_B * T / EF_SI ! +! ! decay into e-h pair + IF(T <= SMALL) THEN ! +! + UAT = - EF_SI * R1 * R1 *( LOG(R1) - HALF - & ! + LOG(TWO * K_TF_SI / KF_SI) & ! ref. (1) eq. (13) + ) / (FOUR * PI * H_BAR) ! +! + ELSE ! +! + UAT = - EF_SI * R2 * R2*( LOG(R2) - LOG(K_TF_SI / KF_SI) -& ! + LOG(TWO) - ONE ) / & ! ref. (1) eq. (14) + (TWO * PI * H_BAR) ! +! + END IF ! +! + GIQ1_LT_2D = ONE / UAT ! +! + END FUNCTION GIQ1_LT_2D +! +!======================================================================= +! + FUNCTION GIQ2_LT_2D(EK,T) +! +! This function computes Giuliani-Quinn approximation for +! the quasiparticle lifetime in the 2D case. +! +! In this approximation, the lifetime is limited by the decay into +! a plasmon mode +! +! References: (1) G. F. Giuliani and J. J. Quinn, Phys. Rev. B 26, +! 4421-4428 (1982) +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * T : system temperature in SI +! +! Output parameters: +! +! * GIQ2_LT_2D : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE CONSTANTS_P1, ONLY : H_BAR,E,M_E + USE FERMI_SI, ONLY : EF_SI + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,T + REAL (WP) :: GIQ2_LT_2D + REAL (WP) :: UAT + REAL (WP) :: R1 + REAL (WP) :: CP,DELTA +! + REAL (WP) :: SQRT +! + CP = MU('2D',T) ! chemical potential + DELTA = EK - CP ! + R1 = DELTA / EF_SI ! +! ! decay into plasmon mode + UAT = TWO * E * E * E * E * M_E * DSQRT(R1) / & ! + (H_BAR * H_BAR * H_BAR) ! ref. (1) eq. (22) +! + GIQ2_LT_2D = ONE / UAT ! +! + END FUNCTION GIQ2_LT_2D +! +!======================================================================= +! + FUNCTION GIVI_LT_2D(EK,RS,T) +! +! This function computes Giuliani-Vignale approximation for +! the quasiparticle lifetime in the 2D case +! +! References: (1) G. Giuliani and G. Vignale, "Quantum Theory of the +! Electron Liquid", Cambridge Uiversity Press (2005) +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! Output parameters: +! +! * GIVI_LT_2D : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,EIGHT,HALF + USE CONSTANTS_P1, ONLY : H_BAR,K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,RS,T + REAL (WP) :: GIVI_LT_2D + REAL (WP) :: UAT + REAL (WP) :: ZETA + REAL (WP) :: SMALL +! + REAL (WP) :: LOG,ABS +! + SMALL = 1.E-1_WP ! +! + ZETA = ONE + HALF * (RS / (RS + SQRT(TWO)))**2 ! ref. (1) eq. (8.100) +! + IF(T <= SMALL) THEN ! + UAT = ZETA * (EK - EF_SI)**2 * LOG( FOUR * EF_SI / & ! + DABS(EK - EF_SI) & ! + ) / & ! ref. (1) eq. (8.102) + (FOUR * PI * H_BAR * EF_SI) ! + ELSE ! + UAT = ZETA * (PI * K_B * T)**2 * LOG( FOUR * EF_SI / & ! + (K_B * T) & ! + ) / & ! ref. (1) eq. (8.103) + (EIGHT * PI * H_BAR * EF_SI)! + END IF ! +! + GIVI_LT_2D = ONE / UAT ! +! + END FUNCTION GIVI_LT_2D +! +!======================================================================= +! + FUNCTION HAWR_LT_2D(EK,A_SI,RS) +! +! This function computes Hawrylak approximation for +! the quasiparticle lifetime in the 2D case +! +! This is for a layered system +! +! References: (1) P. Hawrylak, Phys. Rev. Lett. 59, 485-488 (1987) +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * A_SI : layer interspacing in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Output parameters: +! +! * HAWR_LT_2D : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,EIGHT + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE ENE_CHANGE, ONLY : RYD +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,A_SI,RS + REAL (WP) :: HAWR_LT_2D + REAL (WP) :: A,CC + REAL (WP) :: K,KC + REAL (WP) :: UAT +! + REAL (WP) :: SQRT +! + A = A_SI / BOHR ! spacing in a.u. + CC = ONE + ONE / A ! +! + K = SQRT(TWO * M_E * EK) / H_BAR ! k + KC = KF_SI * (CC /DSQRT(CC * CC - ONE)) ! k_c +! + UAT = EIGHT * RYD *A * ( CC / (CC * CC - ONE) )**1.5E0_WP * & ! + (K / KC - ONE)**2 / & ! ref. (1) eq. (8) + (SQRT(TWO) * RS * RS) ! +! + HAWR_LT_2D = ONE / UAT ! +! + END FUNCTION HAWR_LT_2D +! +!======================================================================= +! + FUNCTION MELA_LT_2D(EK,T) +! +! This function computes Menashe-Laikhtman approximation for +! the quasiparticle lifetime in the 2D case +! +! In this approximation, the lifetime is limited by +! electron-electron scattering +! +! References: (1) D. Menashe and B. Laikhtman, Phys. Rev. B 54, +! 11561-11574 (1996) +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * T : system temperature in SI +! +! Output parameters: +! +! * MELA_LT_2D : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE CONSTANTS_P1, ONLY : H_BAR,K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,T + REAL (WP) :: MELA_LT_2D + REAL (WP) :: UAT + REAL (WP) :: CP,DELTA + REAL (WP) :: R1,R2 +! + REAL (WP) :: LOG,ABS +! + CP = MU('2D',T) ! chemical potential +! + DELTA = EK - CP ! + R1 = DELTA / EF_SI ! + R2 = K_B * T / EF_SI ! +! ! e-e scattering + IF(R2 <= R1) THEN ! k_B T << EK-CP +! + UAT = EF_SI * ((EK - EF_SI)**2 / EF_SI**2) * & ! + LOG(EF_SI / (ABS(EK - EF_SI))) / & ! ref. (1) eq. (27) + 16.0E0_WP * PI * H_BAR ! +! + ELSE ! +! + UAT = PI * EF_SI * (K_B * T / EF_SI)**2 * & ! + LOG(EF_SI / (K_B * T)) / & ! ref. (1) eq. (27) + 16.0E0_WP * H_BAR ! +! + END IF ! +! + MELA_LT_2D=ONE/UAT ! +! + END FUNCTION MELA_LT_2D +! +!======================================================================= +! + FUNCTION QIVI_LT_2D(EK,RS,T) +! +! This function computes Qian-Vignale approximation for +! the quasiparticle lifetime in the 2D case +! +! References: (1) Z. Qian and G. Vignale, Phys. Rev. B 71, +! 075112 (2005) +! +! Input parameters: +! +! * EK : quasiparticle energy in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! Output parameters: +! +! * QIVI_LT_2D : lifetime in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,EIGHT,HALF + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,RS,T + REAL (WP) :: QIVI_LT_2D + REAL (WP) :: UAT + REAL (WP) :: CP,DELTA + REAL (WP) :: BRAK,R1,R2 +! + REAL (WP) :: SQRT,LOG +! + CP = MU('2D',T) ! chemical potential +! + DELTA = EK - CP ! + BRAK = 0.75E0_WP - RS / (SQRT(TWO) * (RS + SQRT(TWO)))**2 ! ref. (1) eq. (61) +! + R1 = DELTA / EF_SI ! + R2 = K_B * T / EF_SI ! +! + IF(R2 <= R1) THEN ! k_B T << EK-CP +! + UAT = DELTA * DELTA * BRAK * LOG(TWO / R1) / & ! + (FOUR * PI * EF_SI) ! ref. (1) eq. (60) +! + ELSE ! +! + UAT = -PI * EF_SI * R2 * R2 * BRAK * LOG(HALF * R2) / EIGHT! ref. (1) eq. (72) +! + END IF ! +! + QIVI_LT_2D = ONE / UAT ! +! + END FUNCTION QIVI_LT_2D +! +END MODULE LIFETIME diff --git a/New_libraries/DFM_library/DAMPING_LIBRARY/mean_free_path.f90 b/New_libraries/DFM_library/DAMPING_LIBRARY/mean_free_path.f90 new file mode 100644 index 0000000..b958de3 --- /dev/null +++ b/New_libraries/DFM_library/DAMPING_LIBRARY/mean_free_path.f90 @@ -0,0 +1,167 @@ +!======================================================================= +! +MODULE IMFP +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE MEAN_FREE_PATH(EK,MFP) +! +! This subroutine computes the electron inelastic mean free path +! +! +! Reference: (1) D. R. Penn, Phys. Rev. B 13, 5248-5254 (1976) +! (2) B. Da, H. Shinotsuka, H. Yoshikawa, Z.J. Ding and +! S. Tanuma, Phys. Rev. Lett. 113, 063201 (2014) +! +! +! Input parameters: +! +! * EK : electron kinetic energy (in SI) +! +! +! Output variables : +! +! * IMPF : inelastic mean free path (in SI) +! +! +! Note: eps(q,omega) is in fact stored as a function of Y = q / k_F +! and V = hbar omega / E_F +! +! Therefore, in order to be consistent, the integrations have +! to be performed in Y and V +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE MATERIAL_PROP, ONLY : RS + USE EXT_FIELDS, ONLY : T +! + USE Q_GRID, ONLY : Q_MIN + USE E_GRID, ONLY : E_MIN +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF,FOURTH,SMALL,TTINY,INF + USE PI_ETC, ONLY : PI + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,M_E + USE ENE_CHANGE, ONLY : EV +! + USE DF_VALUES, ONLY : D_FUNC +! + USE INTEGRATION, ONLY : INTEGR_L + USE INTEGRATION4 + USE DFUNCL_STAN_DYNAMIC +! + IMPLICIT NONE +! + INTEGER :: IQ,IE + INTEGER :: ID + INTEGER :: I_ZQ,I_ZE +! + INTEGER, PARAMETER :: NE_MAX = 2000 ! max. number of points in e-grid + INTEGER, PARAMETER :: NQ_MAX = 1000 ! max. number of points in q-grid +! + REAL (WP), INTENT(IN) :: EK + REAL (WP), INTENT(OUT):: MFP + REAL (WP) :: MIN_E,MAX_E,MIN_Q,MAX_Q + REAL (WP) :: STEP_E,STEP_Q + REAL (WP) :: E,Q + REAL (WP) :: X,V,Z,EKF,KOEF + REAL (WP) :: EPSR,EPSI + REAL (WP) :: ELF(NSIZE),IN(NSIZE) + REAL (WP) :: A,B +! + REAL (WP) :: FLOAT,SQRT +! + EKF = EK / EF_SI ! in units of E_F +! + KOEF = EKF * PI * BOHR / RS ! +! + MIN_E = E_MIN ! in units of E_F + MAX_E = EKF - ONE ! in units of E_F + STEP_E = (MAX_E - MIN_E) / FLOAT(NE_MAX - 1) ! in units of E_F +! +! Constructing the e-grid +! + DO IE = 1, NE_MAX ! E_F +! + E = MIN_E + FLOAT(IE - 1) * STEP_E ! in units of + V = E ! hbar * omega / E_F +! +! Constructing the q-grid +! + MIN_Q = MAX( Q_MIN, SQRT(EKF) - SQRT(EKF - V) ) ! for Z to be defined + MAX_Q = SQRT(EKF) + SQRT(EKF - V) ! in units of k_F + STEP_Q = (MAX_Q - MIN_Q) / FLOAT(NQ_MAX - 1) ! in units of k_F +! + I_ZQ = 0 ! switch for integrand = 0 +! + DO IQ = 1, NQ_MAX ! +! + Q = MIN_Q + FLOAT(IQ - 1) * STEP_Q ! in units of k_F +! + X = HALF * Q ! (q / 2k_F) + Z = FOURTH * V / (X * X) ! omega / omega_q +! +! Computing the dielectric function epsilon(q,E) +! + CALL DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNC,IE,EPSR,EPSI) ! +! +! Computing the loss function ELF = Im [ -1 / epsilon(q,E) ] +! + ELF(IQ) = EPSI / ( (EPSR * EPSR + EPSI * EPSI) * Q) ! integrand function +! +! IF(ELF(IQ) /= ZERO) I_ZQ = IQ ! + IF(ELF(IQ) == ZERO) ELF(IQ) = SMALL ! +! + END DO ! end of q-grid +! +! IF(I_ZQ > 0) THEN ! +! +! Performing the q-integration +! + ID = 1 ! EPSI = 0 at origin + CALL INTEGR_L(ELF,STEP_Q,NSIZE,NQ_MAX,A,ID) ! +! +! ELSE ! ELF always = 0 +! +! A = TTINY ! +! +! END IF ! +! +! Constructing the e-integrand +! + IN(IE) = A ! +! +! IF(A /= ZERO) I_ZE = IE ! + IF(IN(IE) == ZERO) IN(IE) = SMALL ! +! + END DO ! end of e-grid +! +! IF(I_ZE > 0) THEN ! +! +! Performing the e-integration +! + ID = 1 ! + CALL INTEGR_L(IN,STEP_E,NSIZE,NE_MAX,B,ID) ! +! +! ELSE ! IN always = 0 +! +! B = TTINY ! +! +! END IF ! +! + MFP = KOEF / B ! ref. (2) eq. (2) +! + END SUBROUTINE MEAN_FREE_PATH +! +END MODULE IMFP diff --git a/New_libraries/DFM_library/DAMPING_LIBRARY/packing_fraction.f90 b/New_libraries/DFM_library/DAMPING_LIBRARY/packing_fraction.f90 new file mode 100644 index 0000000..3942793 --- /dev/null +++ b/New_libraries/DFM_library/DAMPING_LIBRARY/packing_fraction.f90 @@ -0,0 +1,116 @@ +! +!======================================================================= +! +MODULE PACKING_FRACTION +! + USE ACCURACY_REAL +! +! +CONTAINS +! +! +!======================================================================= +! + FUNCTION PACK_FRAC_3D(N0,DIA,PF_TYPE) +! +! This function computes the 3D packing fraction of a hard-sphere fluid +! +! References: (1) J.-M. Bomont and J.-L. Bretonnet, +! Chem. Phys. 439, 85-94 (2014) +! +! +! Input parameters: +! +! * N0 : number density ! in same +! * DIA : diameter of particles ! units +! * PF_TYPE : type of packing fraction +! PF_TYPE = 'HSM' --> hard sphere model +! PF_TYPE = 'RCP' --> random closed-packed +! PF_TYPE = 'FCC' --> FCC closed-packed +! PF_TYPE = 'FRE' --> freezing +! PF_TYPE = 'MEL' --> melting +! +! +! Output parameters: +! +! * PACK_FRAC_3D +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,SIXTH + USE PI_ETC, ONLY : PI + USE SQUARE_ROOTS, ONLY : SQR2 +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: PF_TYPE +! + REAL (WP), INTENT(IN) :: N0,DIA + REAL (WP) :: PACK_FRAC_3D +! + IF(PF_TYPE == 'HSM') THEN ! + PACK_FRAC_3D = PI * N0 * DIA * DIA * DIA * SIXTH ! + ELSE IF(PF_TYPE == 'RCP') THEN ! + PACK_FRAC_3D = 0.64E0_WP ! + ELSE IF(PF_TYPE == 'FCC') THEN ! + PACK_FRAC_3D = PI * SQR2 * SIXTH ! + ELSE IF(PF_TYPE == 'FRE') THEN ! + PACK_FRAC_3D = 0.494E0_WP ! + ELSE IF(PF_TYPE == 'MEL') THEN ! + PACK_FRAC_3D = 0.545E0_WP ! + END IF ! +! + END FUNCTION PACK_FRAC_3D +! +!======================================================================= +! + FUNCTION PACK_FRAC_2D(N0,DIA,PF_TYPE) +! +! This function computes the 2D packing fraction of a hard-sphere fluid +! +! References: (1) R. Garcia-Rojo, S. Luding and J. J. Brey, +! Phys. Rev. E 74, 061395 (2006) +! +! +! Input parameters: +! +! * N0 : number density ! in same +! * DIA : diameter of disks ! units +! * PF_TYPE : type of packing fraction +! PF_TYPE = 'HDM' --> hard disk model +! +! +! Output parameters: +! +! * PACK_FRAC_2D +! +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : FOURTH + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: PF_TYPE +! +! + REAL (WP), INTENT(IN) :: N0,DIA + REAL (WP) :: PACK_FRAC_2D +! + IF(PF_TYPE == 'HDM') THEN ! + PACK_FRAC_2D = PI * N0 * DIA * DIA * FOURTH ! + END IF ! +! + END FUNCTION PACK_FRAC_2D +! +END MODULE PACKING_FRACTION diff --git a/New_libraries/DFM_library/DAMPING_LIBRARY/plasmon_damping.f90 b/New_libraries/DFM_library/DAMPING_LIBRARY/plasmon_damping.f90 new file mode 100644 index 0000000..27adfed --- /dev/null +++ b/New_libraries/DFM_library/DAMPING_LIBRARY/plasmon_damping.f90 @@ -0,0 +1,626 @@ +! +!======================================================================= +! +MODULE PLASMON_DAMPING +! + USE ACCURACY_REAL +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE PLAS_DAMP_EG_3D(X,RS,T,TAU,PD_TYPE,PL_DISP,SQ_TYPE, & + GQ_TYPE,EC_TYPE,IQ_TYPE,GAMMA_Q) +! +! This subroutine computes the plasmon damping in the 3D case. +! +! ---> electron gas case <--- +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! * TAU : relaxation time (used for damping) in SI +! * PD_TYPE : method used to compute the plasmon damping (3D) +! PD_TYPE = 'NONE' --> no plasmon damping +! PD_TYPE = 'CALL' --> Callen approximation +! PD_TYPE = 'DGKA' --> DuBois-Gilinsky-Kivelson approximation +! PD_TYPE = 'FEWA' --> Fetter and Walecka approximation +! PD_TYPE = 'JEWS' --> Jewsbury approximation +! PD_TYPE = 'LITI' --> Giuliani-Quinn lifetime approximation +! PD_TYPE = 'MOPE' --> Molinari-Peerani approximation +! PD_TYPE = 'NPSA' --> Ninham-Powel-Swanson approximation +! PD_TYPE = 'SGAA' --> Segui-Gervasoni-Arista approximation +! * PL_DISP : method used to compute the dispersion (3D) +! * SQ_TYPE : structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! * IQ_TYPE : type of approximation for I(q) +! +! +! Output variables : +! +! * GAMMA_Q : plasmon damping in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: PL_DISP + CHARACTER (LEN = 6) :: EC_TYPE + CHARACTER (LEN = 4) :: PD_TYPE,GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE,IQ_TYPE +! + REAL (WP) :: X,RS,T,TAU + REAL (WP) :: GAMMA_Q +! + IF(PD_TYPE == 'NONE') THEN ! + GAMMA_Q = ZERO ! + ELSE IF(PD_TYPE == 'CALL') THEN ! + GAMMA_Q = CALL_PD_3D(X,RS,T) ! + ELSE IF(PD_TYPE == 'DGKA') THEN ! + GAMMA_Q = DGKA_PD_3D(X,RS,T) ! + ELSE IF(PD_TYPE == 'FEWA') THEN ! + GAMMA_Q = FEWA_PD_3D(X,RS) ! + ELSE IF(PD_TYPE == 'JEWS') THEN ! + GAMMA_Q = JEWS_PD_3D(X,RS) ! + ELSE IF(PD_TYPE == 'LITI') THEN ! + GAMMA_Q = LITI_PD_3D(X,TAU) ! + ELSE IF(PD_TYPE == 'MOPE') THEN ! + GAMMA_Q = MOPE_PD_3D(X,RS,T) ! + ELSE IF(PD_TYPE == 'NPSA') THEN ! + GAMMA_Q = NPSA_PD_3D(X,RS,T) ! + ELSE IF(PD_TYPE == 'SGAA') THEN ! + GAMMA_Q = SGAA_PD_3D(X,RS,T,PL_DISP,SQ_TYPE,GQ_TYPE, & ! + EC_TYPE,IQ_TYPE) ! + END IF ! +! + END SUBROUTINE PLAS_DAMP_EG_3D +! +!======================================================================= +! + FUNCTION CALL_PD_3D(X,RS,T) +! +! This function computes the plasmon damping gamma_q in the +! Callen approximation for the Landau damping +! in a Maxwellian 3D plasma +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! Output variables : +! +! * CALL_PD_3D : plasmon damping (dimensionless) +! +! References: (1) J. D. Callen, Physics of Plasmas 21, 052106 (2014) +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : EIGHT,HALF + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : SQR_PI + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,RS,T,Y,U,U2,U3 + REAL (WP) :: CALL_PD_3D + REAL (WP) :: KD_SI + REAL (WP) :: NUM,DEN +! + REAL (WP) :: SQRT,EXP +! + Y = X + X ! q / k_F +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + U = KD_SI / (Y * KF_SI) ! q /k_D + U2 = U * U ! + U3 = U2 * U ! +! + NUM = ENE_P_SI * U3 * SQR_PI ! + DEN = H_BAR * SQRT(EIGHT) ! +! + CALL_PD_3D = NUM* EXP(- HALF * U2 - 1.5E0_WP) / DEN ! ref. (1) eq. (9) +! + END FUNCTION CALL_PD_3D +! +!======================================================================= +! + FUNCTION DGKA_PD_3D(X,RS,T) +! +! This function computes the plasmon Landau damping gamma_q in the +! DuBois-Gilinsky-Kivelson approximation +! +! References: +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! Output variables : +! +! * DGKA_PD_3D : plasmon damping +! +! References: (1) D. F. DuBois, V. Gilinsky and M. G. Kivelson, +! Phys. Rev. Lett. 8, 419 (1962) +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOUR + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI3 + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE EULER_CONST, ONLY : EUMAS + USE UTILITIES_1, ONLY : RS_TO_N0 + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: DGKA_PD_3D + REAL (WP) :: Y,Q_SI,KT_SI,XX,YY + REAL (WP) :: N0,KD_SI + REAL (WP) :: NUM,DEN +! + REAL (WP) :: SQRT,LOG,EXP +! + Y = X + X ! q / k_F +! + Q_SI = Y * KF_SI ! q in SI +! + N0 = RS_TO_N0('3D',RS) ! +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + KT_SI = SQRT(M_E * K_B*T / (H_BAR * H_BAR)) ! De Broglie thermal wave vector + XX = Q_SI / KD_SI ! + YY = KT_SI / KD_SI ! +! + NUM = TWO * XX * XX * KD_SI * KD_SI * KD_SI ! + DEN = 15.0E0_WP * SQRT(PI3) * N0 ! +! + DGKA_PD_3D = ENE_P_SI * NUM * LOG( FOUR * YY *EXP(- EUMAS) )& ! + / DEN ! ref. (1) eq. (2) +! + END FUNCTION DGKA_PD_3D +! +!======================================================================= +! + FUNCTION FEWA_PD_3D(X,RS) +! +! This function computes the plasmon damping gamma_q in the +! Fetter and Walecka approximation +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Output variables : +! +! * FEWA_PD_3D : plasmon damping (dimensionless) +! +! References: (1) A. L. Fetter and J. D. Walecka, +! "Quantum Theory of Many-Particle Systems", +! McGraw-Hill, ex. 9.12 p. 324 +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI3 + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP) :: X,RS,Y + REAL (WP) :: FEWA_PD_3D + REAL (WP) :: ALPHA +! + REAL (WP) :: SQRT +! + Y = X + X ! q / k_F + ALPHA = ALFA('3D') ! +! + FEWA_PD_3D = EF_SI * SQRT(ALPHA * RS * PI3) * & ! + (Y-ONE) * (Y-ONE) ! ref. (1) ex. (9.12) +! + END FUNCTION FEWA_PD_3D +! +!======================================================================= +! + FUNCTION JEWS_PD_3D(X,RS) +! +! This function computes the plasmon damping gamma_q in the +! Jewsbury approximation +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Output variables : +! +! * JEWS_PD_3D : plasmon damping (dimensionless) +! +! References: (1) P. Jewsbury, Aust. J. Phys. 32, 361-368 (1979) +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : HALF +! + IMPLICIT NONE +! + REAL (WP) :: X,RS,Y + REAL (WP) :: JEWS_PD_3D + REAL (WP) :: G0,G1 +! + REAL (WP) :: SQRT +! + Y = X + X ! q / k_F +! + G0 = 0.033E0_WP * RS ! ref. (1) eq. (25b) + G1 = 0.15E0_WP * SQRT(RS) ! ref. (1) eq. (25a) +! + JEWS_PD_3D = HALF * (G0 + G1 * Y * Y) ! ref. (1) eq. (24) +! + END FUNCTION JEWS_PD_3D +! +!======================================================================= +! + FUNCTION LITI_PD_3D(X,TAU) +! +! This function computes the plasmon damping gamma_q in the +! Giuliani-Quinn approximation +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * TAU : relaxation time (used for damping) in SI +! +! +! Output variables : +! +! * LITI_PD_3D : plasmon damping (dimensionless) +! +! References: (1) G. F. Giuliani and J. J. Quinn, Phys. Rev. B 29, +! 2321 (1984) +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO +! + IMPLICIT NONE +! + REAL (WP) :: X,TAU,Y + REAL (WP) :: LITI_PD_3D +! + Y = X + X ! q / k_F +! + LITI_PD_3D = (ONE + Y) / (TWO + Y) * ONE / TAU ! ref. (1) eq. (2) +! + END FUNCTION LITI_PD_3D +! +!======================================================================= +! + FUNCTION MOPE_PD_3D(X,RS,T) +! +! This function computes the plasmon damping gamma_q in the +! Molinari-Peerani approximation for the Landau damping +! in a Maxwellian 3D plasma +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! Output variables : +! +! * MOPE_PD_3D : plasmon damping (dimensionless) +! +! References: (1) V. G. Molinari and P. Peerani, +! Il Nuovo Cimento D 5, 527 (1985) +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : SQR_PI + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,RS,T,Y,U,U2,U3 + REAL (WP) :: MOPE_PD_3D + REAL (WP) :: Q_SI,BETA + REAL (WP) :: NUM,DEN +! + REAL (WP) :: SQRT,EXP +! + Y = X + X ! q / k_F +! + Q_SI = Y *KF_SI ! q in SI +! + BETA = HALF *M_E / (K_B * T) ! ref. (1), after eq. (10) +! + U = ENE_P_SI / (H_BAR * Q_SI) ! omega_p / q + U2 = U * U ! + U3 = U2 * U ! +! + NUM = SQR_PI * SQRT(BETA * BETA * BETA) * ENE_P_SI * U3 ! + DEN = H_BAR ! +! + MOPE_PD_3D = NUM * EXP(- BETA * U2 - 1.5E0_WP) / DEN ! ref. (1) between (24) and (25) +! + END FUNCTION MOPE_PD_3D +! +!======================================================================= +! + FUNCTION NPSA_PD_3D(X,RS,T) +! +! This function computes the plasmon damping gamma_q in the +! Ninham-Powel-Swanson approximation +! +! References: +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! Output variables : +! +! * NPSA_PD_3D : plasmon damping +! +! References: (1) B. W. Ninham, C. J. Powell and N. Swanson, +! Phys. Rev. 145, 209 (1966) +! H. T. Nguyen-Truong, J. Phys. Chem. C 119, +! 7883-7887 (2015) +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,FIVE + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : ALFA + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,RS,T,Q_C,Y + REAL (WP) :: NPSA_PD_3D + REAL (WP) :: GAMMA_Q,Y2,Y4,OM0 + REAL (WP) :: ALPHA +! + REAL (WP) :: SQRT,LOG +! + Y = X + X ! q / k_F +! +! plasmon cut-off in q +! + ALPHA = ALFA('3D') ! + Q_C = ALPHA * SQRT(THREE / RS) ! ref. (1b) eq. (14) +! + OM0 = ALPHA * ALPHA * SQRT(THREE * RS) ! ref. (1b) eq. (14) +! + IF(Y <= Q_C) THEN ! + Y2 = Y * Y ! + Y4 = Y2 * Y2 ! + GAMMA_Q = PI * OM0 * OM0 * OM0 * (FIVE * LOG(TWO) + ONE) *& ! + Y2 / 30.0E0_WP + & ! + PI * OM0 * ( 30.0E0_WP *LOG(TWO) + & ! + 37.0E0_WP / FOUR - & ! ref. (1b) eq. (14) + 13.0E0_WP * OM0 * OM0 / & ! + 16.0E0_WP & ! + ) * Y4 ! dimensionless +! + NPSA_PD_3D = GAMMA_Q * EF_SI ! in SI + ELSE ! + NPSA_PD_3D = ZERO ! + END IF ! +! + END FUNCTION NPSA_PD_3D +! +!======================================================================= +! + FUNCTION SGAA_PD_3D(X,RS,T,PL_DISP,SQ_TYPE,GQ_TYPE,EC_TYPE, & + IQ_TYPE) +! +! This function computes the plasmon damping gamma_q in the +! Segui-Gervasoni-Arista approximation +! +! References: (1) S. Segui, J. L. Gervasoni and N. R. Arista, Nucl. Instr. +! Meth. Phys. Res. B 408, 217-222 (2017) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! * PL_DISP : method used to compute the dispersion (3D) +! * SQ_TYPE : structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! * IQ_TYPE : type of approximation for I(q) +! +! +! Output variables : +! +! * SGAA_PD_3D : plasmon damping +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E + USE FERMI_SI, ONLY : KF_SI + USE PLASMON_DISP_REAL + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: PL_DISP + CHARACTER (LEN = 6) :: EC_TYPE + CHARACTER (LEN = 4) :: PD_TYPE,GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE,IQ_TYPE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: SGAA_PD_3D + REAL (WP) :: Y,Q_SI + REAL (WP) :: RQ_SI,ENE_P_Q,OM_Q,OM_QQ,K1_SI + REAL (WP) :: NUM,DEN +! + Y = X + X ! q / k_F +! + Q_SI = Y * KF_SI ! +! +! Computing the plasmon dispersion +! + CALL PLASMON_DISP_3D(X,RS,T,PL_DISP,ENE_P_Q) ! + OM_Q = ENE_P_Q / H_BAR ! omega_q +! + OM_QQ = HALF * H_BAR * Q_SI * Q_SI / M_E ! +! + K1_SI = M_E * (OM_Q - OM_QQ) / (H_BAR * Q_SI) ! +! + NUM = M_E * E * E * ENE_P_SI * ENE_P_SI * & ! + (KF_SI * KF_SI - K1_SI * K1_SI) ! ref. (1) eq. (17) + DEN = H_BAR * H_BAR * H_BAR * H_BAR * & ! + Q_SI * Q_SI * Q_SI * OM_Q ! +! + SGAA_PD_3D = NUM / DEN ! in SI +! + END FUNCTION SGAA_PD_3D +! +!======================================================================= +! + SUBROUTINE EXACT_DAMPING(IX,IDERIV,N_E,EN,EPSR,EPSI,EN_Q,GAMMA_Q) +! +! This subroutine computes the plasmon damping gamma_q according to +! +! Im[ epsilon ] | +! gamma_q = - _______________ | +! | +! d Re[ epsilon ]/d omega | omega=Omega_q +! +! where epsilon is the dielectric function. +! +! +! Input parameters: +! +! * IX : index of q-point +! * IDERIV : type of n_point formula used for derivation (n = IDERIV) +! * N_E : number of energy points +! * EN : energy grid in units of E_F +! * EPSR : real part of the dielectric function at q +! * EPSI : imaginary part of the dielectric function at q +! * EN_Q : plasmon energy at q in units of E_F +! +! +! Output parameters: +! +! * GAMMA_Q : plasmon damping coefficient in units of E_F +! +! +! +! Author : D. Sébilleau +! +! Last modified : 22 Oct 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ONE + USE DERIVATION + USE INTERPOLATION, ONLY : INTERP_NR,SPLINE,SPLINT + USE OUTFILES, ONLY : FN +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: IX,IDERIV,N_E +! + REAL (WP), INTENT(IN) :: EN(NSIZE) + REAL (WP), INTENT(IN) :: EPSR(NSIZE),EPSI(NSIZE) + REAL (WP), INTENT(IN) :: EN_Q +! + REAL (WP), INTENT(OUT):: GAMMA_Q +! + REAL (WP) :: H + REAL (WP) :: DEPSR(NSIZE) + REAL (WP) :: DEPSR_Q,EPSI_Q +! + H = EN(2) - EN(1) ! step for energy derivation +! +! Derivation of EPSR(N) using a n-point formula --> result in DEPSR(N) +! + CALL DERIV_1(EPSR,N_E,IDERIV,H,DEPSR) ! +! +! Cubic spline interpolation of DEPSR(N) and EPSI(N) at E = EN_Q_ +! + CALL INTERP_NR(6,EN,DEPSR,N_E,EN_Q,DEPSR_Q) ! + CALL INTERP_NR(6,EN,EPSI,N_E,EN_Q,EPSI_Q) ! +! + GAMMA_Q = - EPSI_Q / DEPSR_Q ! units of E_F +! + END SUBROUTINE EXACT_DAMPING +! +END MODULE PLASMON_DAMPING diff --git a/New_libraries/DFM_library/DAMPING_LIBRARY/relaxation_time_dynamic.f90 b/New_libraries/DFM_library/DAMPING_LIBRARY/relaxation_time_dynamic.f90 new file mode 100644 index 0000000..2c96d91 --- /dev/null +++ b/New_libraries/DFM_library/DAMPING_LIBRARY/relaxation_time_dynamic.f90 @@ -0,0 +1,18 @@ +! +!======================================================================= +! +MODULE RELAXATION_TIME_DYNAMIC +! + USE ACCURACY_REAL +! +! +CONTAINS +! +!======================================================================= +! + FUNCTION TAIC_RT_D_3D() +! +! + END FUNCTION TAIC_RT_D_3D +! +END MODULE RELAXATION_TIME_DYNAMIC diff --git a/New_libraries/DFM_library/DAMPING_LIBRARY/relaxation_time_static.f90 b/New_libraries/DFM_library/DAMPING_LIBRARY/relaxation_time_static.f90 new file mode 100644 index 0000000..a4b6892 --- /dev/null +++ b/New_libraries/DFM_library/DAMPING_LIBRARY/relaxation_time_static.f90 @@ -0,0 +1,2721 @@ +! +!======================================================================= +! +MODULE RELAXATION_TIME_STATIC +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE RELAXATION_TIME(X,TAU) +! +! This subroutine computes the rélaxation time +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Dec 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN,RS,MSOM,EPS_B + USE EXT_FIELDS, ONLY : T + USE MULTILAYER, ONLY : DL,H_TYPE + USE LF_VALUES, ONLY : GQ_TYPE + USE SF_VALUES, ONLY : SQ_TYPE + USE DAMPING_VALUES +! + USE EL_ELE_INTER + USE EL_PHO_INTER + USE EL_IMP_INTER +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,INF + USE CONSTANTS_P1, ONLY : M_E + USE ENE_CHANGE, ONLY : EV +! + IMPLICIT NONE +! + INTEGER :: I_ET + INTEGER :: I_E,I_P,I_I +! + REAL (WP), INTENT(IN) :: X + REAL (WP), INTENT(OUT):: TAU +! + REAL (WP) :: EK_SI + REAL (WP) :: TAU_EE,TAU_EP,TAU_EI + REAL (WP) :: INV_EE,INV_EP,INV_EI + REAL (WP) :: SUM_INV + REAL (WP) :: MASS_E,LR + REAL (WP) :: TEI,TAU_E,S_L +! +! Kinetic energy of the electrin in SI +! + EK_SI = EK * EV ! +! + MASS_E = MSOM * M_E ! effective mass of electron + LR = ZERO ! residual mfp (temporary) + TEI = ZERO ! e-imp collision time (temporary) + TAU_E = ZERO ! elastic scattering time (temporary) + S_L = ZERO ! scattering length (temporary) +! + I_E = 0 ! e-e calculation switch + I_P = 0 ! e-p calculation switch + I_I = 0 ! e-i calculation switch +! +! Relaxation time initialization +! + IF(RT_TYPE == ' NO') THEN ! + INV_EE = ZERO ! + INV_EP = ZERO ! + INV_EI = ZERO ! + GO TO 10 ! + ELSE IF(RT_TYPE == 'E-E') THEN ! + INV_EP = ZERO ! + INV_EI = ZERO ! + I_E = 1 ! + ELSE IF(RT_TYPE == 'E-P') THEN ! + INV_EE = ZERO ! + INV_EI = ZERO ! + I_P = 1 ! + ELSE IF(RT_TYPE == 'E-I') THEN ! + INV_EE = ZERO ! + INV_EP = ZERO ! + I_I = 1 ! + ELSE IF(RT_TYPE == 'ALL') THEN ! + I_E = 1 ! + I_P = 1 ! + I_I = 1 ! + END IF ! +! +! Computation of the electron-electron inverse relaxation time +! + IF(EE_TYPE /= 'NONE' .AND. I_E == 1) THEN ! + IF(DMN == '3D') THEN ! + CALL EE_RT_3D(EE_TYPE,SQ_TYPE,GQ_TYPE,X,RS,T, & ! + EK_SI,EI_C,TAU_EE) ! + ELSE IF(DMN == '2D') THEN ! + I_ET = 2 ! temporary + CALL EE_RT_2D(EE_TYPE,RS,T,EK_SI,TAU_E,EPS_B,EI_C,DL, & ! + I_ET,H_TYPE,TEI,TAU_EE) ! + ELSE IF(DMN == '1D') THEN ! + CALL EE_RT_1D(EE_TYPE,EK_SI,TEI,TAU_EE) ! + END IF ! + INV_EE = ONE / TAU_EE ! + END IF ! +! +! Computation of the electron-phonon inverse relaxation time +! + IF(EP_TYPE /= 'NONE' .AND. I_P == 1) THEN ! + IF(DMN == '3D') THEN ! + CALL EP_RT_3D(EP_TYPE,T,NA,MA,RA,DEBYE_T,EP_C,EK_SI, & ! + RS,TAU_EP) ! + ELSE IF(DMN == '2D') THEN ! + INV_EP = ZERO ! not yet implemented + ELSE IF(DMN == '1D') THEN ! + INV_EP = ZERO ! not yet implemented + END IF ! + INV_EP = ONE / TAU_EP ! + END IF ! +! +! Computation of the electron-impurity inverse relaxation time +! + IF(EI_TYPE /= 'NONE' .AND. I_I == 1) THEN ! + IF(DMN == '3D') THEN ! + CALL EI_RT_3D(EI_TYPE,EK_SI,T,RS,NI,EPS_B,MASS_E,TAU_EI) ! + ELSE IF(DMN == '2D') THEN ! + INV_EI = ZERO ! not yet implemented + ELSE IF(DMN == '1D') THEN ! + INV_EI = ZERO ! not yet implemented + END IF ! + INV_EI = ONE / TAU_EI ! + END IF ! +! + 10 SUM_INV = INV_EE + INV_EP + INV_EI ! + IF(SUM_INV /= ZERO) THEN ! + TAU = ONE / SUM_INV ! + ELSE ! + TAU = INF ! + END IF ! +! + END SUBROUTINE RELAXATION_TIME +! +! Specific cases: +! +!------ 1) electron-phonon case -------------------------------------------- +! +!======================================================================= +! + SUBROUTINE EP_RT_3D(EP_TYPE,T,NA,MA,RA,TH,CA,EE,RS,TAU) +! +! This subroutine computes the electron-phonon relaxation time +! in 3D systems +! +! +! Input parameters: +! +! * EP_TYPE : relaxation time functional for electron-phonon +! EP_TYPE = 'STEH' --> Steinberg high-T approximation +! EP_TYPE = 'STEL' --> Steinberg low-T approximation +! * T : temperature (in SI) +! * MA : mass of lattice atoms +! * RA : radius of atoms +! * TH : Debye temperature of the material in SI +! * CA : electron-phonon coupling +! * EE : energy of electron in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: EP_TYPE +! + REAL (WP) :: T,NA,MA,RA,TH,CA,EE,RS + REAL (WP) :: TAU +! + IF(EP_TYPE == 'STEH') THEN ! + TAU = STEH_RT_3D(T,MA,RA,TH,CA,EE,RS) ! + ELSE IF(EP_TYPE == 'STEL') THEN ! + TAU = STEL_RT_3D(T,MA,RA,TH,CA,RS) ! + END IF ! +! + END SUBROUTINE EP_RT_3D +! +!======================================================================= +! + FUNCTION STEH_RT_3D(T,MA,RA,TH,CA,EE,RS) +! +! This function computes Steinberg's high-temperature relaxation time. +! +! In this model; the electron interacts with acoustic lattice vibrations +! +! +! Reference: (1) M. S. Steinberg, Phys. Rev. 109, 1486 (1958) +! +! Input parameters: +! +! * T : temperature (in SI) +! * MA : mass of lattice atoms +! * RA : radius of atoms +! * TH : Debye temperature of the material in SI +! * CA : electron-phonon coupling +! * EE : energy of electron in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Output parameters: +! +! * STEH_RT_3D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,THREE,FOUR,SIX,HALF,THIRD + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE PI_ETC, ONLY : PI,PI2 +! + IMPLICIT NONE +! + REAL (WP) :: T,NA,MA,RA,TH,CA,EE,RS + REAL (WP) :: STEH_RT_3D + REAL (WP) :: N0 + REAL (WP) :: H,AL,GA,D + REAL (WP) :: NUM,DEN1,DEN2 +! + REAL (WP) :: SQRT +! + AL = (FOUR * PI * THIRD)**THIRD ! (4 pi / 4)^{1/3} +! + H = TWO * PI * H_BAR ! h = 2 pi * h_bar +! + GA = AL * (FOUR * MA * RA * K_B * TH) / & ! + (THREE * H * H * CA * CA) ! /\ +! + D = (SIX * PI2)**(TWO * THIRD) * H_BAR * H_BAR / & ! D + (FOUR * M_E * RA * RA) ! +! + NUM = TWO * H_BAR * H_BAR * GA * TH * EE**1.5E0_WP ! + DEN1 = D * SQRT(HALF * M_E) * T ! + DEN2 = THREE - D / EE ! +! + STEH_RT_3D = NUM / (DEN1 * DEN2) ! ref. 1 eq. (4.2) +! + END FUNCTION STEH_RT_3D +! +!======================================================================= +! + FUNCTION STEL_RT_3D(T,MA,RA,TH,CA,RS) +! +! This function computes Steinberg's low-temperature relaxation time. +! +! In this model; the electron interacts with acoustic lattice vibrations +! +! +! Reference: (1) M. S. Steinberg, Phys. Rev. 109, 1486 (1958) +! +! Input parameters: +! +! * T : temperature (in SI) +! * MA : mass of lattice atoms +! * RA : radius of atoms +! * TH : Debye temperature of the material in SI +! * CA : electron-phonon coupling +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Output parameters: +! +! * STEL_RT_3D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,SIX,THIRD,LARGE + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI,PI2 + USE SPECIFIC_INT_1, ONLY : STEI_INT +! + IMPLICIT NONE +! + REAL (WP) :: T,NA,MA,RA,TH,CA,RS + REAL (WP) :: STEL_RT_3D + REAL (WP) :: H,AL,GA,D,EF3,M3 + REAL (WP) :: NUM,DEN1,DEN2 + REAL (WP) :: X,J5,J7,X5 +! + REAL (WP) :: SQRT +! + AL = (FOUR * PI * THIRD)**THIRD ! (4 pi / 4)^{1/3} +! + H = TWO * PI * H_BAR ! h = 2 pi * h_bar +! + GA = AL * (FOUR * MA * RA * K_B * TH) / & ! + (THREE * H * H * CA * CA) ! /\ +! + D = (SIX * PI2)**(TWO * THIRD) * H_BAR * H_BAR / & ! D + (FOUR * M_E * RA * RA) ! +! + EF3 = EF_SI * EF_SI * EF_SI ! + M3 = M_E * M_E * M_E ! +! +! Computation of the J_p(x) functions +! + X = TH/T ! + X5 = X * X * X * X * X ! +! + NUM = H_BAR * H_BAR * GA * SQRT(EF3) * X5 ! + DEN1 = THREE * SQRT(TWO * M3) * D ! +! +! Computation of the J_p(x) functions +! + IF(T > ONE) THEN ! +! + J5 = STEI_INT(X,5) ! + J7 = STEI_INT(X,7) ! +! + DEN2 = J5 - J7 / ( X*X / (TWO * EF_SI) ) ! +! + ELSE ! +! + J5 = STEI_INT(LARGE,5) ! +! + DEN2 = J5 ! +! + END IF ! +! + STEL_RT_3D = NUM / (DEN1 * DEN2) ! ref. 1 eq. (4.9) +! ! ref. 1 eq. (4.10) + END FUNCTION STEL_RT_3D +! +!------ 2) electron-electron case -------------------------------------------- +! +! +!======================================================================= +! + SUBROUTINE EE_RT_3D(EE_TYPE,SQ_TYPE,GQ_TYPE,X,RS,T, & + EK,U,TAU) +! +! This subroutine computes the electron-electron relaxation time +! in 3D systems +! +! +! Input parameters: +! +! * EE_TYPE : relaxation time functional for electron-phonon +! EE_TYPE = 'ALAR' --> Al'tshuler-Aronov approximation +! EE_TYPE = 'ALA2' --> Al'tshuler-Aronov approximation +! EE_TYPE = 'BACA' --> Barriga-Carrasco approximation +! EE_TYPE = 'FSTB' --> Fann et al approximation +! EE_TYPE = 'PIN1' --> Pines-Nozières 1st approximation +! EE_TYPE = 'PIN2' --> Pines-Nozières 2nd approximation +! EE_TYPE = 'QIV2' --> Qian-Vignale high-density limit +! EE_TYPE = 'QIVI' --> Qian-Vignale approximation +! EE_TYPE = 'RASM' --> Rammer-Smith approximation +! EE_TYPE = 'TAI0' --> Tanaka-Ichimaru approximation (q = 0) +! EE_TYPE = 'TAIQ' --> q-dependent Tanaka-Ichimaru approximation +! EE_TYPE = 'UTIC' --> Utsumi-Ichimaru approximation +! * SQ_TYPE : structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional (3D) +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! * EK : electron kinetic energy (SI) +! * U : strength of impurity scattering +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Dec 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: EE_TYPE,GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE +! + REAL (WP) :: X,RS,T,EK,U,DC + REAL (WP) :: TAU +! + IF(EE_TYPE == 'ALAR') THEN ! + TAU = ALAR_RT_3D(X,EK) ! + ELSE IF(EE_TYPE == 'ALA2') THEN ! + TAU = ALAR_RT_ND('3D',X,EK) ! + ELSE IF(EE_TYPE == 'BACA') THEN ! + TAU = BACA_RT_3D(RS,T) ! + ELSE IF(EE_TYPE == 'FSTB') THEN ! + TAU = FSTB_RT_3D(RS) ! + ELSE IF(EE_TYPE == 'PIN1') THEN ! + TAU = PIN1_RT_3D(EK,T) ! + ELSE IF(EE_TYPE == 'PIN2') THEN ! + TAU = PIN2_RT_3D(EK,T) ! + ELSE IF(EE_TYPE == 'QIV2') THEN ! + TAU = QIV2_RT_3D(EK,X,T) ! + ELSE IF(EE_TYPE == 'QIVI') THEN ! + TAU = QIVI_RT_3D(EK,X,T) ! + ELSE IF(EE_TYPE == 'RASM') THEN ! + TAU = RASM_RT_3D(EK,T,RS,U) ! + ELSE IF(EE_TYPE == 'TAI0') THEN ! + TAU = TAI0_RT_3D(RS,T) ! + ELSE IF(EE_TYPE == 'TAIQ') THEN ! + TAU = TAIQ_RT_3D(X,RS,T) ! + ELSE IF(EE_TYPE == 'UTIC') THEN ! + TAU = UTIC_RT_3D(X,RS,T,SQ_TYPE,GQ_TYPE) ! + END IF ! +! + END SUBROUTINE EE_RT_3D +! +!======================================================================= +! + FUNCTION ALAR_RT_3D(X,EK) +! +! This function computes Al'tshuler-Aronov approximation for +! the relaxation time in the presence of impurities for 3D systems +! +! Reference: (1) B. L. Al'tshuler and A. G. Aronov, JETP Lett. 30, +! 482-484 (1979) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * EK : electron kinetic energy (SI) +! +! Output parameters: +! +! * ALAR_RT_3D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,HALF,THIRD + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,EF_SI,VF_SI + USE PI_ETC, ONLY : PI2,PI3 + USE SQUARE_ROOTS, ONLY : SQR2 + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE DAMPING_VALUES, ONLY : DC_TYPE,D_VALUE_1,POWER_1 + USE DIFFUSION_COEFFICIENT + USE EXTERNAL_DAMPING +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,EK + REAL (WP) :: ALAR_RT_3D +! + REAL (WP) :: ZK + REAL (WP) :: D,L,TAU + REAL (WP) :: POW + REAL (WP) :: Q,NU0 + REAL (WP) :: KS + REAL (WP) :: NUM,DEN,XXX +! + REAL (WP) :: SQRT +! + ZK = EK - EF_SI ! xi_p in SI +! +! Computing the diffusion coefficient +! + IF(DC_TYPE == 'EXTE') THEN ! + CALL CALC_POWER(POWER_1,POW) ! + D = D_VALUE_1 * POW ! + ELSE ! + CALL DIFFUSION_COEF(D) ! + END IF ! +! + L = THREE * D / VF_SI ! mean free path in SI + TAU = L / VF_SI ! + Q = X * TWO * KF_SI ! q in SI +! + NU0 = HALF * KF_SI * KF_SI * KF_SI / (PI2 * EF_SI) ! DoS at Fermi level +! +! Computing the Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR('3D',KS) ! +! + IF( (Q < ONE / L) .AND. (KS * L > ONE) ) THEN ! +! + NUM = ZK**1.5E0_WP ! + DEN = 12.0E0_WP * SQR2 * PI3 * H_BAR * NU0 * & ! + (H_BAR * D)**1.5E0_WP ! +! + XXX = NUM / DEN ! ref. 1 eq. (8) +! + ELSE ! +! + NUM = PI2 * KS * ZK * ZK ! + DEN = 64.0E0_WP * H_BAR * KF_SI * EF_SI ! +! + XXX = NUM / DEN ! ref. 1 eq. (8) +! + END IF ! +! + ALAR_RT_3D = ONE / XXX ! ref. 1 eq. (8) +! + END FUNCTION ALAR_RT_3D +! +!======================================================================= +! + FUNCTION ALAR_RT_ND(DMN,X,EK) +! +! This function computes Al'tshuler-Aronov approximation for +! the relaxation time in the presence of impurities +! +! Reference: (1) B. L. Al'tshuler and A. G. Aronov, in +! "Electron-Electron Interactions in Disordered +! Solids", A. L. Efros and M. Pollak eds. +! (North-Holland,1985) +! +! +! Input parameters: +! +! * DMN : system dimension +! * X : dimensionless factor --> X = q / (2 * k_F) +! * EK : electron kinetic energy (SI) +! +! Output parameters: +! +! * ALAR_RT_ND : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,HALF,FOURTH + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,EF_SI + USE PI_ETC, ONLY : PI,PI_INV + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE UTILITIES_1, ONLY : D,DOS_EF + USE DAMPING_VALUES, ONLY : DC_TYPE,D_VALUE_1,POWER_1 + USE DIFFUSION_COEFFICIENT + USE EXTERNAL_DAMPING +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP), INTENT(IN) :: X,EK + REAL (WP) :: ALAR_RT_ND +! + REAL (WP) :: ZK + REAL (WP) :: DC,POW,KS + REAL (WP) :: NF,DI,DD + REAL (WP) :: XX,DS,F,OD + REAL (WP) :: K1,K2,NUM,DEN,XXX +! + REAL (WP) :: SQRT,LOG,SIN +! + ZK = EK - EF_SI ! xi_p in SI +! +! Computing the diffusion coefficient +! + IF(DC_TYPE == 'EXTE') THEN ! + CALL CALC_POWER(POWER_1,POW) ! + DC = D_VALUE_1 * POW ! + ELSE ! + CALL DIFFUSION_COEF(DC) ! + END IF ! +! +! Computing the Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR(DMN,KS) ! +! +! Computing the density of state at Fermi level +! + NF = DOS_EF(DMN) ! +! + DI = D(DMN) ! + DD = HALF * DI ! +! + XX = TWO * KF_SI / KS ! +! + IF(DMN == '2D') THEN ! + DS = SQRT(XX * XX - ONE) ! + F = PI_INV * LOG((XX + DS)/(XX - DS)) / DS ! ref. 1 eq. (3.36a) + ELSE ! + F= TWO * LOG(ONE + XX * XX)/(XX * XX) ! ref. 1 eq. (3.36b) + END IF ! +! + IF(DMN == '3D') THEN ! + OD = FOURTH * PI_INV * PI_INV ! + ELSE IF(DMN == '2D') THEN ! + OD = HALF * PI_INV ! + ELSE IF(DMN == '1D') THEN ! + OD = PI_INV ! + END IF ! +! + K1 = ONE - THREE * F * ( ONE - (ONE + HALF * F)**DD ) & ! + / (FOUR + F) ! + K2 = OD / ( TWO * DI ** SIN(FOURTH * PI * DI) ) ! + ! + NUM = ZK**DD ! + DEN = H_BAR * NF * (H_BAR * DC)**DD ! +! + XXX = K1 * K2 * NUM / DEN ! ref. 1 eq. (4.4) +! + ALAR_RT_ND = ONE / XXX ! ref. 1 eq. (4.4) +! + END FUNCTION ALAR_RT_ND +! +!======================================================================= +! + FUNCTION BACA_RT_3D(RS,T) +! +! This function computes Barriga-Carrasco approximation for +! the relaxation time in the 3D case +! +! References: (1) M. D. Barriga-Carrasco, Phys. Rev. E 76, 016405 (2007) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (in SI) +! +! Output parameters: +! +! * BACA_RT_3D : relaxation time in seconds +! +! Note: result given in a.u. in ref. (1) eq. (17) --> h nu in Hartree +! +! --> h nu * Hartree in J +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,NINE + USE PI_ETC, ONLY : PI,SQR_PI + USE CONSTANTS_P2, ONLY : HARTREE + USE CONSTANTS_P3, ONLY : PLANCK + USE SQUARE_ROOTS, ONLY : SQR2 + USE UTILITIES_1, ONLY : RS_TO_N0 + USE PLASMON_SCALE_P, ONLY : NONID +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP) :: BACA_RT_3D +! + REAL (WP) :: N0 + REAL (WP) :: CL,NU +! + REAL (WP) :: SQRT,LOG +! + N0 = RS_TO_N0('3D',RS) ! +! + CL = LOG(SQRT(N0)) / NONID**(1.5E0_WP) ! Coulomb logarithm +! + NU = 16.0E0_WP * SQR2 * (NONID**(1.5E0_WP)) * CL / & ! ref. 1 eq. (17) + (NINE * PI * SQR_PI) ! in a.u. +! + BACA_RT_3D = ONE / (NU * HARTREE / PLANCK) ! in SI +! + END FUNCTION BACA_RT_3D +! +!======================================================================= +! + FUNCTION FSTB_RT_3D(RS) +! +! This function computes Fann et al approximation for +! the relaxation time in the 3D case +! +! References: (1) W. S. Fann et al, Phys. Rev. B 46, 13592-13595 (1992) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Output parameters: +! +! * FSTB_RT : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE CONSTANTS_P1, ONLY : H_BAR + USE PI_ETC, ONLY : PI2 + USE SQUARE_ROOTS, ONLY : SQR3 + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS + REAL (WP) :: FSTB_RT_3D +! + FSTB_RT_3D = 128.0E0_WP * H_BAR / (PI2 * SQR3 * ENE_P_SI) ! ref. (1) eq. (2) +! + END FUNCTION FSTB_RT_3D +! +!======================================================================= +! + FUNCTION PIN1_RT_3D(EK,T) +! +! This function computes Pines-Nozières approximation for +! the relaxation time in the 3D case +! +! Reference: (1) D. Pines and P. Nozi\`{e}res, +! "The Theory of Quantum Liquids -- Normal Fermi Liquids", +! (Benjamin, 1966) +! +! +! Input parameters: +! +! * EK : electron kinetic energy (SI) +! * T : temperature (SI) +! +! Output parameters: +! +! * PIN1_RT_3D : relaxation time in seconds +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF + USE PI_ETC, ONLY : PI2 + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI + USE SQUARE_ROOTS, ONLY : SQR3 + USE PLASMON_ENE_SI + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,T + REAL (WP) :: PIN1_RT_3D +! + REAL (WP) :: MM,ZK + REAL (WP) :: OMP + REAL (WP) :: XXX +! + OMP = ENE_P_SI / H_BAR ! omega_p +! +! Computing the chemical potential +! + MM = MU('3D',T) ! chemical potential is SI +! + ZK = EK - MM ! xi_p in SI +! + XXX = PI2 * SQR3 * OMP * (ZK / MM)**2 / 128.0E0_WP ! +! + PIN1_RT_3D = ONE / XXX ! ref. (1) eq. (5.134c) +! + END FUNCTION PIN1_RT_3D +! +!======================================================================= +! + FUNCTION PIN2_RT_3D(EK,T) +! +! This function computes Pines-Nozières approximation for +! the relaxation time in the 3D case +! +! Reference: (1) D. Pines and P. Nozi\`{e}res, +! "The Theory of Quantum Liquids -- Normal Fermi Liquids", +! (Benjamin, 1966) +! +! +! Input parameters: +! +! * EK : electron kinetic energy (SI) +! * T : temperature (SI) +! +! Output parameters: +! +! * PIN2_RT_3D : relaxation time in seconds +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF + USE PI_ETC, ONLY : PI_INV + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,E,M_E + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE CHEMICAL_POTENTIAL, ONLY : MU + USE SPECIFIC_INT_10 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,T + REAL (WP) :: PIN2_RT_3D +! + REAL (WP) :: MM,ZK,K + REAL (WP) :: NUM,DEN,KOEF + REAL (WP) :: INTG + REAL (WP) :: XXX +! + REAL (WP) :: SQRT +! +! Computing the chemical potential +! + MM = MU('3D',T) ! chemical potential is SI +! + ZK = EK - MM ! xi_p in SI + K = SQRT(TWO * M_E * EK) / H_BAR ! k in SI +! + NUM = TWO * PI_INV * E * E * KF_SI * ZK * ZK ! + DEN = H_BAR * H_BAR * H_BAR * BOHR * VF_SI * VF_SI ! + KOEF = NUM / DEN ! +! +! Computing the integral +! + CALL INT_PINO(INTG) ! +! + XXX = KOEF * INTG ! +! + PIN2_RT_3D = ONE / XXX ! ref. (1) eq. (5.134b) +! + END FUNCTION PIN2_RT_3D +! +!======================================================================= +! + FUNCTION QIVI_RT_3D(EK,X,T) +! +! This function computes Qian-Vignale approximation for +! the relaxation time in the 3D case +! +! Reference: (1) Z. Qian and G. Vignale, +! Phys. Rev. B 71, 075112 (2005) +! (2) J. Daligault, Phys. Rev. Lett. 119, 045002 (2017) +! +! +! Input parameters: +! +! * EK : electron kinetic energy (SI) +! * X : dimensionless factor --> X = q / (2 * k_F) +! * T : temperature (SI) +! +! Output parameters: +! +! * QIVI_RT_3D : relaxation time in seconds +! +! +! Note: There is a factor 1/ h_bar^6 missing in ref. (1) (see eq. (5) ref. (2)) +! +! In order to avoid dealing with too large or small numbers, we rewrite +! +! 3 4 +! m e m 1 +! ------- = -------- ------- +! 6 2 2 +! h_bar h_bar a +! 0 +! +! +! so that the first coefficient becomes +! +! 1 1 k 1 +! ------------ ---- ---- ------------- = K0 +! 2 pi h_bar EK KS (a_0 KS)^2 +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Dec 2020 +! +! + USE MATERIAL_PROP, ONLY : RS + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF,TTINY,INF + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,M_E,K_B + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI,PI2,PI_INV + USE SCREENING_TYPE + USE SCREENING_VEC + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,X,T + REAL (WP) :: QIVI_RT_3D +! + REAL (WP) :: MM,ZK,K + REAL (WP) :: KS,LD + REAL (WP) :: ND,NE,BE + REAL (WP) :: NUM,DEN,CC + REAL (WP) :: R0,R1,R2 + REAL (WP) :: K0,K1,K2 +! + REAL (WP) :: SQRT,EXP,LOG,ATAN +! +! Computing the chemical potential +! + MM = MU('3D',T) ! chemical potential is SI +! + ZK = EK - MM ! xi_p in SI + K = SQRT(TWO * M_E * EK) / H_BAR ! k in SI +! +! Pathological cases +! + IF(EK <= MM) THEN ! + QIVI_RT_3D = INF ! + GO TO 10 ! + END IF ! +! +! Computing the screening vector +! + IF(SC_TYPE == 'NO') THEN ! + CALL SCREENING_VECTOR('TF','3D',X,RS,T,KS) ! + ELSE ! + CALL SCREENING_VECTOR(SC_TYPE,'3D',X,RS,T,KS) ! in SI + END IF ! +! + R0 = HALF * PI_INV / H_BAR + R1 = K / KS ! + R2 = ONE / (BOHR * KS)**2 ! +! + LD = TWO * KF_SI / KS ! lambda + BE = ONE / (K_B * T) ! beta +! +! Direct contribution ND and exchange contribution NE +! + IF(ZK < LOG(TTINY)/BE) THEN ! + CC = EXP(- BE * ZK) ! + ELSE ! <-- pathological + CC = ZERO ! case + END IF ! +! + NUM = PI2 / (BE * BE) + ZK * ZK ! + DEN = ONE + CC ! +! + K0 = R0 * R1 * R2 / EK ! see Note + K1 = NUM / DEN ! + K2 = ONE / SQRT(LD * LD + TWO) ! +! + ND = K0 * K1 * ( LD / (LD * LD + ONE) + ATAN(LD) ) ! ref. 1 eq. (29) + NE = - K0 * K1 * K2 * ( HALF * PI - ATAN(SQRT(K2 / LD)) ) ! ref. 1 eq. (32) +! + QIVI_RT_3D = ONE / (ND + NE) ! ref. 1 eq. (3) +! + 10 RETURN +! + END FUNCTION QIVI_RT_3D +! +!======================================================================= +! + FUNCTION QIV2_RT_3D(EK,X,T) +! +! This function computes the high-density limit Qian-Vignale approximation +! for the relaxation time in the 3D case (direct term onmy) +! +! Reference: (1) Z. Qian and G. Vignale, +! Phys. Rev. B 71, 075112 (2005) +! (2) J. Daligault, Phys. Rev. Lett. 119, 045002 (2017) +! +! +! Input parameters: +! +! * EK : electron kinetic energy (SI) +! * X : dimensionless factor --> X = q / (2 * k_F) +! * T : temperature (SI) +! +! Output parameters: +! +! * QIV2_RT_3D : relaxation time in seconds +! +! +! Note: There is a factor 1/ h_bar^6 missing in ref. (1) (see eq. (5) ref. (2)) +! +! In order to avoid dealing with too large or small numbers, we rewrite +! +! 3 4 +! m e m 1 +! ------- = -------- ------- +! 6 2 2 +! h_bar h_bar a +! 0 +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Dec 2020 +! +! + USE MATERIAL_PROP, ONLY : RS + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF,FOURTH + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : ALFA + USE SCREENING_TYPE + USE SCREENING_VEC + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EK,X,T + REAL (WP) :: QIV2_RT_3D +! + REAL (WP) :: MM,ZK,K + REAL (WP) :: KS + REAL (WP) :: R0,R1,R2,DEN +! + REAL (WP) :: SQRT +! +! Computing the chemical potential +! + MM = MU('3D',T) ! chemical potential is SI +! + ZK = EK - MM ! xi_p in SI + K = SQRT(TWO * M_E * EK) / H_BAR ! k in SI +! +! Computing the screening vector +! +! + IF(SC_TYPE == 'NO') THEN ! + CALL SCREENING_VECTOR('TF','3D',X,RS,T,KS) ! + ELSE ! + CALL SCREENING_VECTOR(SC_TYPE,'3D',X,RS,T,KS) ! in SI + END IF ! +! + R0 = FOURTH / H_BAR ! + R1 = K / KS ! + R2 = ONE / (BOHR * KS)**2 ! +! + DEN = R0 * R1 * R2 * ZK * ZK / EK ! +! + QIV2_RT_3D = ONE / DEN ! +! + END FUNCTION QIV2_RT_3D +! +!======================================================================= +! + FUNCTION RASM_RT_3D(EK,T,RS,U) +! +! This function computes Rammer-Smith approximation for +! the e-e relaxation time in the 3D case +! +! Reference: (1) J. Rammer and H. Smith, Rev. Mod. Phys. 58, 323 (1986) +! +! Note: uses the e-impurity scattering time as a reference time +! +! +! Input parameters: +! +! * EK : electron energy (SI) +! * T : temperature (in SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! * U : strength of impurity scattering +! +! Output parameters: +! +! * RASM_RT_3D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THREE,FOUR,SIX,EIGHT + USE CONSTANTS_P1, ONLY : E + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI,PI2,PI3 + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE CHEMICAL_POTENTIAL, ONLY : MU + USE UTILITIES_1, ONLY : DOS_EF +! + IMPLICIT NONE +! + REAL (WP) :: EK,T,RS,U + REAL (WP) :: RASM_RT_3D + REAL (WP) :: KS,IS,NF + REAL (WP) :: MM,L,NUM,DEN + REAL (WP) :: EPS,ZZ +! + REAL (WP) :: SQRT +! + EPS = 1.E-2_WP ! + ZZ = 2.612375348685488343348567567924071630571E0_WP ! zeta(3/2) +! +! Computing the Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR('3D',KS) ! +! +! Computing the chemical potential +! + MM = MU('3D',T) ! +! +! Computing the density of states at Fermi level +! + NF = DOS_EF('3D') ! +! +! Impurity scattering rate (1/tau) +! + IS = PI * U * U * NF ! ref. 1 eq. (4.13) +! +! Mean free path +! + L = VF_SI / IS ! +! + IF(T < EPS) THEN ! zero temperature +! + IF(EK < IS) THEN ! +! + NUM = FOUR * SQRT(IS) * KF_SI * KF_SI * L * L ! + DEN = EK * SQRT(SIX * EK) ! +! + RASM_RT_3D = NUM / DEN ! ref. 1 eq. (4.73) +! + ELSE ! +! + IF(KS < KF_SI) THEN ! +! + NUM = 64.0E0_WP * KF_SI * MM ! + DEN = PI2 * KS * EK * EK ! +! + RASM_RT_3D = NUM / DEN ! ref. 1 eq. (4.74) +! + ELSE ! +! + NUM = 16.0E0_WP * MM ! + DEN = PI * EK * EK ! +! + RASM_RT_3D = NUM / DEN ! ref. 1 eq. (4.74) +! + END IF ! + END IF ! +! + ELSE ! +! + IF(T < IS) THEN ! +! + NUM = 16.0E0_WP * KF_SI * L * MM ! + DEN = THREE * SQRT(THREE * PI) * ZZ * & ! + (SQRT(EIGHT) - ONE) * SQRT(IS * T * T * T ) ! +! + RASM_RT_3D = NUM / DEN ! ref. 1 eq. (4.76) +! + ELSE ! +! + IF(KS < KF_SI) THEN ! +! + NUM = EIGHT * VF_SI * VF_SI * KS ! + DEN = PI3 * E * E * T * T ! +! + RASM_RT_3D = NUM / DEN ! ref. 1 eq. (4.77) +! + ELSE ! +! + NUM = 16.0E0_WP * MM ! + DEN = PI3 * T * T ! +! + RASM_RT_3D = NUM / DEN ! ref. 1 eq. (4.77) +! + END IF ! + END IF ! +! + END IF ! +! + END FUNCTION RASM_RT_3D +! +!======================================================================= +! + FUNCTION TAI0_RT_3D(RS,T) +! +! This function computes Tanaka-Ichimaru approximation for +! the relaxation time at q = 0 in the 3D case +! +! References: (1) S. Tanaka and S. Ichimaru, Phys. Rev. A 35, +! 4743-4754 (1987) +! (2) S. Ichimaru, Rev. Mod. Phys. 54, 1017-1059 (1982) +! +! +! Validity: This relaxation time is valid for strongly coupled, +! classical one-component plasma +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (in SI) +! +! Output parameters: +! +! * TAI0_RT_3D : relaxation time in seconds +! +! +! Formula: Following the derivation in the user's guide, we obtain +! +! +! 1 +! TAU = ETA_L x --------------------------------------------------- +! n k_B T + 1 - n h_bar omega_p^2 Gamma_I +! ----- --------------------------- +! K_T omega_F +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF,THIRD + USE PI_ETC, ONLY : PI_INV + USE CONSTANTS_P1, ONLY : H_BAR,K_B + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE UTILITIES_1, ONLY : ALFA,RS_TO_N0 + USE VISCOSITY, ONLY : LHPO_VISC_3D + USE ASYMPT, ONLY : G0,GI + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP) :: TAI0_RT_3D +! + REAL (WP) :: ETA,ETA_L + REAL (WP) :: N0,ALPHA,KBT + REAL (WP) :: OMP,OMF + REAL (WP) :: E1,E2,E3 + REAL (WP) :: NUM,DEN,TAU_0 +! +! Computing the viscosity (LHPO case only) +! + ETA = LHPO_VISC_3D(RS,T) ! +! + ETA_L = FOUR * THIRD * ETA ! longitudinal viscosity +! +! Computing the electron density +! + N0 = RS_TO_N0('3D',RS) ! +! + ALPHA = ALFA('3D') ! +! + KBT = K_B * T ! + OMP = ENE_P_SI / H_BAR ! + OMF = EF_SI / H_BAR ! +! +! Computing the energies in the denominator +! + E1 = KBT ! + E2 = TWO * THIRD * EF_SI * (ONE - FOUR * PI_INV * & ! + ALPHA * RS * G0) ! + E3 = - HALF * ENE_P_SI * OMP * GI / OMF ! +! + NUM = ETA_L ! + DEN = N0 * (E1 + E2 + E3) ! +! + TAI0_RT_3D = NUM / DEN ! +! + END FUNCTION TAI0_RT_3D +! +!======================================================================= +! + FUNCTION TAIQ_RT_3D(X,RS,T) +! +! This function computes the relaxation time as a function of q +! +! References: (1) S. Tanaka and S. Ichimaru, Phys. Rev. A 35, +! 4743-4754 (1987) +! +! +! Validity: This relaxation time is valid for strongly coupled, +! classical one-component plasma +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * TAIQ_RT_3D : relaxation time in seconds +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE FERMI_SI, ONLY : KF_SI + USE CONSTANTS_P1, ONLY : BOHR + USE DAMPING_VALUES, ONLY : QD_TYPE,ZETA +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: Q_SI,Q_FACT,XX,X2,TAU_0 + REAL (WP) :: TAIQ_RT_3D +! + REAL (WP) :: EXP +! + Q_SI = TWO * X * KF_SI ! q in SI +! + XX = RS * BOHR * Q_SI / ZETA ! + X2 = XX * XX ! +! +! Computing the q-dependent factor +! + IF(QD_TYPE == 'NONE') THEN ! +! + Q_FACT = ONE ! +! + ELSE IF(QD_TYPE == 'GAUS') THEN ! +! + Q_FACT = EXP(- X2) ! +! + ELSE IF(QD_TYPE == 'LORE') THEN ! +! + Q_FACT = ONE / (ONE + X2) ! +! + END IF ! +! +! Computing the q = 0 value (TAIC case only) +! + TAU_0 = TAI0_RT_3D(RS,T) ! +! + TAIQ_RT_3D = TAU_0 * Q_FACT ! +! + END FUNCTION TAIQ_RT_3D +! +!======================================================================= +! + FUNCTION UTIC_RT_3D(X,RS,T,SQ_TYPE,GQ_TYPE) +! +! This function computes low-q Utsumi-Ichimaru approximation for +! the relaxation time in the 3D case +! +! Reference: (1) K. Utsumi and S. Ichimaru, +! Phys. Rev. B 22, 1522-1533 (1980) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (in SI) +! * SQ_TYPE : structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! +! Output parameters: +! +! * UTIC_RT : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 2 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOUR,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI + USE SQUARE_ROOTS, ONLY : SQR3 + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE SPECIFIC_INT_2, ONLY : INT_SQM1 + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: UTIC_RT_3D +! + REAL (WP) :: MAX_X + REAL (WP) :: Q_SI + REAL (WP) :: OMQ,OMP,OMF + REAL (WP) :: KS,X_TF + REAL (WP) :: IN + REAL (WP) :: NUM,DEN +! + INTEGER :: IN_MODE,NSIZE,LL +! + CHARACTER (LEN = 4) :: GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE +! + IN_MODE = 3 ! +! + MAX_X = TWO ! integral upper bound + NSIZE = 200 ! number of integration points + LL = 0 ! unused parameter for INT_SQM1 +! + Q_SI = TWO * X * KF_SI ! q in SI +! + OMQ = HALF * H_BAR * Q_SI * Q_SI / M_E ! omega_q in SI + OMP = ENE_P_SI / H_BAR ! omega_p in SI + OMF = EF_SI / H_BAR ! omega_F in SI +! +! Computing Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR('3D',KS) ! +! + X_TF = KS / KF_SI ! q_{TF} / k_F +! +! Computing the integral +! + CALL INT_SQM1(NSIZE,MAX_X,IN_MODE,RS,T,X_TF,LL,SQ_TYPE, &! + GQ_TYPE,IN) ! +! + NUM = - FOUR * SQR3 * OMF * KF_SI ! + DEN = PI * OMQ * OMP * KS * IN ! +! + UTIC_RT_3D = NUM / DEN ! ref. 1 eq. (5.4) +! + END FUNCTION UTIC_RT_3D +! +!======================================================================= +! + SUBROUTINE EE_RT_2D(EE_TYPE,RS,T,EK,TAU_E,EPS,U,B,I_ET, & + H_TYPE,TEI,TAU) +! +! This subroutine computes the electron-electron relaxation time +! in 2D systems +! +! +! Input parameters: +! +! * EE_TYPE : relaxation time functional for electron-phonon +! EE_TYPE = 'FUAB' --> Fukuyama-Abrahams approx. +! EE_TYPE = 'LUFO' --> Lucas-Fong approx. -graphene- +! EE_TYPE = 'QIVI' --> Quinn-Vignale approx. +! EE_TYPE = 'RASM' --> Rammer-Smith approx. +! EE_TYPE = 'REWI' --> Reizer-Wilkins approx. +! EE_TYPE = 'SHAS' --> Sharma-Ashraf approx. +! EE_TYPE = 'ZHDA' --> Zhang-Das Sarma approx. +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! * EK : electron kinetic energy (SI) +! * TAU_E : ELASTIC scattering time (SI) +! * EPS : substrate dielectric constant +! * U : strength of impurity scattering +! * B : interlayer distance (SI) +! * I_ET : switch +! I_ET = 1 --> relaxation time = f(T) +! I_ET = 2 --> relaxation time = f(EK) +! * H_TYPE : heterostructure type +! H_TYPE = 'SSL1' semiconductor superlattice of type I +! H_TYPE = 'SSL2' semiconductor superlattice of type II +! * TEI : electron-impurity collision time +! +! +! Internal parameter +! +! * I_F : switch for choice of formula (for 'LUFO') +! I_F = 1 --> eq. (4) ref. 1 graphene +! I_F = 2 --> eq. (20) ref. 1 2D Fermi liquid +! I_F = 3 --> eq. (129) ref. 1 collinear scattering +! I_F = 4 --> eq. (134) ref. 1 imbalance mode +! I_F = 5 --> eq. (143) ref. 1 graphene in Fermi liquid limit +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: EE_TYPE,H_TYPE +! + REAL (WP) :: RS,T,EK,TAU_E,EPS,U,B,TEI + REAL (WP) :: TAU +! + INTEGER :: I_ET,I_F +! + I_F=1 ! +! + IF(EE_TYPE == 'FUAB') THEN ! + TAU=FUAB_RT_2D(TAU_E,T) ! + ELSE IF(EE_TYPE == 'LUFO') THEN ! + TAU=LUFO_RT_2D(T,EPS,I_F) ! + ELSE IF(EE_TYPE == 'QIVI') THEN ! + TAU=QIVI_RT_2D(EK,T,RS) ! + ELSE IF(EE_TYPE == 'RASM') THEN ! + TAU=RASM_RT_2D(EK,T,RS,U) ! + ELSE IF (EE_TYPE == 'REWI') THEN ! + TAU=REWI_RT_2D(EK,T,RS,B,I_ET,H_TYPE) ! + ELSE IF(EE_TYPE == 'SHAS') THEN ! + TAU=SHAS_RT_2D(EK,TEI) ! + ELSE IF(EE_TYPE == 'ZHDA') THEN ! + TAU=ZHDA_RT_2D(EK,T) ! + END IF ! +! + END SUBROUTINE EE_RT_2D +! +!======================================================================= +! + FUNCTION FUAB_RT_2D(TAU,T) +! +! This function computes Fukuyama-Abrahams approximation for +! the INELASTIC scattering time in 2D disordered metals +! +! Reference: (1) H. Fukuyama and E. Abrahams, Phys. Rev. B 27, +! 5976-5980 (1983) +! +! +! Input parameters: +! +! * TAU : ELASTIC scattering time (SI) +! * T : temperature (SI) +! +! Output parameters: +! +! * FUAB_RT_2D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOUR,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,K_B + USE FERMI_SI, ONLY : EF_SI,VF_SI + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP) :: TAU,T + REAL (WP) :: FUAB_RT_2D + REAL (WP) :: KBT,HBT,D,T1,KK +! + REAL (WP) :: DLOG +! + KBT=K_B*T ! + HBT=H_BAR/TAU ! + D=HALF*VF_SI*VF_SI*TAU ! diffusion coefficient + KK=TWO*M_E*E*E ! + T1=FOUR*EF_SI*EF_SI*TAU*TAU*D*KK*KK ! ref. 1 eq. (2.25) +! + IF(KBT > HBT) THEN ! + FUAB_RT_2D=HALF*PI*KBT*KBT*DLOG(EF_SI/KBT)/EF_SI ! ref. 1 eq. (3.1) + ELSE ! + FUAB_RT_2D=HALF*KBT*DLOG(T1/KBT)/(EF_SI*TAU) ! ref. 1 eq. (3.2) + END IF ! +! + END FUNCTION FUAB_RT_2D +! +!======================================================================= +! + FUNCTION LUFO_RT_2D(T,EPS,I_F) +! +! This function computes Lucas-Fong 2D relaxation time in graphene +! due to e-e interactions +! +! +! Reference: (1) A. Lucas and K. C. Fong, J. Phys.: Condens. Matter +! 30, 053001 (2018) +! +! Input parameters: +! +! * T : temperature (in SI) +! * EPS : substrate dielectric constant +! * I_F : switch for choice of formula +! I_F = 1 --> eq. (4) ref. 1 graphene +! I_F = 2 --> eq. (20) ref. 1 2D Fermi liquid +! I_F = 3 --> eq. (129) ref. 1 collinear scattering +! I_F = 4 --> eq. (134) ref. 1 imbalance mode +! I_F = 5 --> eq. (143) ref. 1 graphene in Fermi liquid limit +! +! Output parameters: +! +! * LUFO_RT_2D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 23 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE CONSTANTS_P1, ONLY : H_BAR,E,K_B + USE FERMI_SI, ONLY : EF_SI,VF_SI + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP) :: T,EPS + REAL (WP) :: LUFO_RT_2D + REAL (WP) :: AL,NEE +! + REAL (WP) :: MIN,DLOG +! + INTEGER :: I_F +! + AL=E*E/(EPS*H_BAR*VF_SI) ! eff. fine struct. const. +! + IF(I_F == 1) THEN ! + NEE=AL*AL*K_B*T*MIN(ONE,K_B*T/EF_SI)/H_BAR ! + LUFO_RT_2D=ONE/NEE ! ref. 1 eq. (4) + ELSE IF(I_F == 2) THEN ! + LUFO_RT_2D=H_BAR*EF_SI/(AL*AL*K_B*T*K_B*T) ! ref. 1 eq. (20) + ELSE IF(I_F == 3) THEN ! + NEE=AL*AL*K_B*T/(H_BAR*DLOG(ONE/AL)) ! + LUFO_RT_2D=ONE/NEE ! ref. 1 eq. (129) + ELSE IF(I_F == 4) THEN ! + NEE=AL*AL*AL*AL*K_B*T/H_BAR ! + LUFO_RT_2D=ONE/NEE ! ref. 1 eq. (134) + ELSE IF(I_F == 5) THEN ! + NEE=T*T/DLOG(K_B*T/EF_SI) ! + LUFO_RT_2D=ONE/NEE ! ref. 1 eq. (143) + END IF ! +! + END FUNCTION LUFO_RT_2D +! +!======================================================================= +! + FUNCTION QIVI_RT_2D(EK,T,RS) +! +! This function computes Qian-Vignale approximation for +! the relaxation time in the 2D case +! +! Reference: (1) Z. Qian and G. Vignale, +! Phys. Rev. B 71, 075112 (2005) +! +! +! Input parameters: +! +! * EK : electron energy (SI) +! * T : temperature (in SI) +! * RS : Wigner-Seitz radius (dimensionless factor) +! +! Output parameters: +! +! * QIVI_RT_2D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF,FOURTH + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI,PI_INV + USE SQUARE_ROOTS, ONLY : SQR2 + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP) :: EK,T,RS + REAL (WP) :: QIVI_RT_2D + REAL (WP) :: MM,ZK,KS,KT + REAL (WP) :: NN + REAL (WP) :: K0,K1,K2 +! + REAL (WP) :: DLOG +! +! Computing the chemical potential +! + MM=MU('2D',T) ! +! + ZK=EK-MM ! + KT=K_B*T ! +! +! Computing the Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR('2D',KS) ! +! + K0=FOURTH*ZK*ZK*PI_INV/EF_SI ! + K1=0.75E0_WP - ( RS/(SQR2 * (RS+SQR2)**2) ) ! ref. 1 eq. (61) +! + IF(KT < ZK) THEN ! +! + K0=FOURTH*ZK*ZK*PI_INV/EF_SI ! + K2=TWO*EF_SI/ZK ! + NN=K0*K1*DLOG(K2) ! ref. 1 eq. (60) +! + ELSE ! +! + K0=-0.125E0_WP*PI*KT*KT/EF_SI ! + K2=HALF*KT/EF_SI ! + NN=K0*K1*DLOG(K2) ! ref. 1 eq. (72) +! + END IF ! +! + QIVI_RT_2D=ONE/NN ! +! + END FUNCTION QIVI_RT_2D +! +!======================================================================= +! + FUNCTION RASM_RT_2D(EK,T,RS,U) +! +! This function computes Rammer-Smith approximation for +! the e-e relaxation time in the 2D case +! +! Reference: (1) J. Rammer and H. Smith, Rev. Mod. Phys. 58, 323 (1986) +! +! Note: uses the e-impurity scattering time as a reference time +! +! +! Input parameters: +! +! * EK : electron energy (SI) +! * T : temperature (in SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! * U : strength of impurity scattering +! +! Output parameters: +! +! * RASM_RT_3D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,EIGHT,HALF + USE CONSTANTS_P1, ONLY : M_E + USE FERMI_SI, ONLY : VF_SI + USE PI_ETC, ONLY : PI,PI2 + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE CHEMICAL_POTENTIAL, ONLY : MU + USE UTILITIES_1, ONLY : RS_TO_N0 +! + IMPLICIT NONE +! + REAL (WP) :: EK,T,RS,U + REAL (WP) :: RASM_RT_2D + REAL (WP) :: KS,IS,MM + REAL (WP) :: N0,NUM,DEN + REAL (WP) :: D,T1 + REAL (WP) :: EPS +! + REAL (WP) :: DLOG,DABS +! + EPS=1.0E-2_WP ! +! +! Computing the Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR('2D',KS) ! +! +! Computing the chemical potential +! + MM=MU('2D',T) ! +! +! Computing the electron density +! + N0=RS_TO_N0('2D',RS) ! +! +! Impurity scattering rate (1/tau) +! + IS=PI*U*U*N0 ! ref. 1 eq. (4.13) +! +! 2D diffusion coefficient +! + D=HALF*VF_SI*VF_SI/IS ! +! + T1=(TWO*M_E*D)**2 * D*KS*KS ! +! + IF(T < EPS) THEN ! zero temperature +! + NUM=EIGHT*PI2*MM ! + DEN=EK*EK*DLOG(DABS(EK/MM)) ! + RASM_RT_2D=NUM/DEN ! ref. 1 eq. (4.81) +! + ELSE +! + IF(T < IS) THEN ! + NUM=TWO*M_E*D ! + DEN=T*DLOG(T1/T) ! + RASM_RT_2D=NUM/DEN ! ref. 1 eq. (4.83) + ELSE ! + NUM=TWO*PI*MM ! + DEN=T*T*DLOG(MM/T) ! + RASM_RT_2D=NUM/DEN ! ref. 1 eq. (4.84) + END IF ! +! + END IF ! +! + END FUNCTION RASM_RT_2D +! +!======================================================================= +! + FUNCTION REWI_RT_2D(EK,T,RS,B,I_ET,H_TYPE) +! +! This function computes Reizer-Wilkins approximation for +! the electron-electron relaxation time in heterostructures +! +! Reference: (1) M. Reizer and J. W. Wilkins, Phys. Rev. B 55, +! R7363-R7366 (1997) +! +! +! Input parameters: +! +! * EK : electron energy (SI) +! * T : temperature (SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! * B : interlayer distance (SI) +! * I_ET : switch +! I_ET = 1 --> relaxation time = f(T) +! I_ET = 2 --> relaxation time = f(EK) +! * H_TYPE : heterostructure type +! H_TYPE = 'SSL1' semiconductor superlattice of type I +! H_TYPE = 'SSL2' semiconductor superlattice of type II +! +! Output parameters: +! +! * REWI_RT_2D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI,PI_INV + USE SCREENING_VEC, ONLY : DEBYE_VECTOR +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: H_TYPE +! + INTEGER :: I_ET,LOGF +! + REAL (WP) :: EK,T,RS,B + REAL (WP) :: REWI_RT_2D + REAL (WP) :: K0,K1,KD,KBT,KDB,TKDB,PB + REAL (WP) :: CF,NUM,DEN,NEE +! + REAL (WP) :: DLOG +! + LOGF=6 ! +! + KBT=K_B*T ! + K0=KBT/EF_SI ! + K1=EK/EF_SI ! + PB=MIN(TWO*KF_SI*B,ONE) ! ref. 1 eq. (19) +! +! Computing the Debye screening vector +! + CALL DEBYE_VECTOR('2D',T,RS,KD) ! +! + KDB=KD*B ! + TKDB=KD*B+KD*B ! +! + IF(H_TYPE == 'SSL1') THEN ! + IF(I_ET == 1) THEN ! + CF=0.125E0_WP*PI*KBT*KBT/EF_SI ! + NUM=TWO*(TWO*KF_SI-K0)*KD ! + DEN=(TWO*KF_SI+KD)*(KD+K0) ! + NEE=CF*( DLOG(FOUR*EF_SI/KBT) - & ! + DLOG(TWO*KF_SI/(KD+K0)) - NUM/DEN & ! + ) ! ref. 1 eq. (13) + ELSE IF(I_ET == 2) THEN ! + CF=0.125E0_WP*EK*EK*PI_INV/EF_SI ! + NUM=TWO*(TWO*KF_SI-K1)*KD ! + DEN=(TWO*KF_SI+KD)*(KD+K1) ! + NEE=CF*( DLOG(FOUR*EF_SI/KBT) - & ! ref. 1 eq. (14) + DLOG(TWO*KF_SI/(KD+K1)) - NUM/DEN & ! + ) ! + END IF ! + ELSE IF(H_TYPE == 'SSL2') THEN ! + IF(I_ET == 1) THEN ! + CF=PI*KBT*KBT/( 32.0E0_WP*EF_SI*(ONE+KDB)*(ONE+KDB) ) ! + NUM=FOUR*(ONE+(ONE+TKDB)**2) * KDB * (PB-K0*B)*(ONE+KDB) ! + DEN=(PB+TKDB*(ONE+KDB))*(K0*B+TKDB*(ONE+KDB)) ! + NEE=CF*( ( TWO+(ONE+TKDB)**2 ) * & ! + ( DLOG(TWO*EF_SI*PB/(KBT*KF_SI*B)) - & ! ref. 1 eq. (19) + DLOG(PB+TKDB*(ONE+KDB)/(K0*B+TKDB*(ONE+KDB)))& ! + ) - NUM/DEN & ! + ) ! + ELSE IF(I_ET == 2) THEN ! + WRITE(LOGF,10) ! + STOP ! + END IF ! + END IF ! +! + REWI_RT_2D=ONE/NEE ! +! +! Format +! + 10 FORMAT(//,5X,'<<<<< I_ET=2 not defined for SSL2 >>>>>',//) +! + END FUNCTION REWI_RT_2D +! +!======================================================================= +! + FUNCTION SHAS_RT_2D(EK,TEI) +! +! This function computes Sharma-Ashraf approximation for +! the relaxation time in the presence of a random +! impurity potential for a quantum well +! +! Reference: (1) A. C. Sharma and S. S. Z. Ashraf, J. Phys.: +! Condens. Matter 16, 3117-3132 (2004) +! +! +! Input parameters: +! +! * EK : electron energy (SI) +! * TEI : electron-impurity collision time +! +! Output parameters: +! +! * SHAS_RT_2D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : FOUR + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR +! + IMPLICIT NONE +! + REAL (WP) :: EK,TEI + REAL (WP) :: SHAS_RT_2D + REAL (WP) :: KS,K,X,S,K2,S2,X2,NN + REAL (WP) :: NU1,NU2,DE1,DE2 +! + REAL (WP) :: DLOG +! +! Computing the Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR('2D',KS) ! +! +! Dimensionless variables +! + K=KS/KF_SI ! + X=EK/EF_SI ! + S=H_BAR/(TEI*EF_SI) ! + K2=K*K ! + S2=S*S ! + X2=X*X ! +! + NU1=FOUR*K2+S2 ! + DE1=NU1-X2 ! + NU2=NU1-X2 ! + DE2=S2+S2 ! + NN=NU1*DLOG(NU1/DE1) + X2*DLOG(NU2/DE2) - X2 ! +! + SHAS_RT_2D=16.0E0_WP*PI*H_BAR/(NN*EF_SI) ! ref. 1 eq. (17) +! + END FUNCTION SHAS_RT_2D +! +!======================================================================= +! + FUNCTION ZHDA_RT_2D(EK,T) +! +! This function computes Zhang-Das Sarma approximation for +! the relaxation time in the 2D case +! +! References: (1) L. Zhang and S. Das Sarma, Phys. Rev. B 53, +! 9964-9967 (1996) +! +! Input parameters: +! +! * EK : electron energy in J +! * T : temperature (in SI) +! +! Output parameters: +! +! * ZHDA_RT_2D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOURTH + USE CONSTANTS_P1, ONLY : H_BAR,K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI,PI_INV +! + IMPLICIT NONE +! + REAL (WP) :: EK,T + REAL (WP) :: ZHDA_RT_2D + REAL (WP) :: R1,R2,R3,DE + REAL (WP) :: GAMMA +! + REAL (WP) :: DLOG +! + DE=EK-EF_SI ! energy with respect to E_F + R1=K_B*T/EF_SI ! + R2=DE/EF_SI ! + R3=K_B*T/DE ! +! + IF(R3 > DE) THEN ! + GAMMA=-FOURTH*PI*EF_SI*R1*R1*DLOG(R1)/H_BAR ! ref. (1) eq. (7) + ELSE ! + GAMMA=-FOURTH*PI_INV*EF_SI*R2*R2*DLOG(R2)/H_BAR ! ref. (1) eq. (8) + END IF ! +! + ZHDA_RT_2D=TWO/GAMMA ! +! + END FUNCTION ZHDA_RT_2D +! +!======================================================================= +! + SUBROUTINE EE_RT_1D(EE_TYPE,EK,TEI,TAU) +! +! This subroutine computes the electron-electron relaxation time +! in 1D systems +! +! +! Input parameters: +! +! * EE_TYPE : relaxation time functional for electron-phonon +! EE_TYPE = 'SHAS' --> Sharma-Ashraf approx. +! +! * EK : electron energy (SI) +! * TEI : electron-impurity collision time +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: EE_TYPE +! + REAL (WP) :: EK,TEI + REAL (WP) :: TAU +! + IF(EE_TYPE == 'SHAS') THEN ! + TAU=SHAS_RT_1D(EK,TEI) ! + END IF ! +! + END SUBROUTINE EE_RT_1D +! +!======================================================================= +! + FUNCTION SHAS_RT_1D(EK,TEI) +! +! This function computes Sharma-Ashraf approximation for +! the relaxation time in the presence of a random +! impurity potential for a quantum wire +! +! Reference: (1) A. C. Sharma and S. S. Z. Ashraf, J. Phys.: +! Condens. Matter 16, 3117-3132 (2004) +! +! +! Input parameters: +! +! * EK : electron energy (SI) +! * TEI : electron-impurity collision time +! +! Output parameters: +! +! * QIVI_RT_1D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI,PI_INV +! + IMPLICIT NONE +! + REAL (WP) :: EK,TEI + REAL (WP) :: SHAS_RT_1D + REAL (WP) :: X,S,S2,X2,NN + REAL (WP) :: NU1,NU2,DE1,DE2 +! + REAL (WP) :: DSQRT,DLOG +! +! Dimensionless variables +! + X=EK/EF_SI ! + S=H_BAR/(TEI*EF_SI) ! + S2=S*S ! + X2=X*X ! +! + NU1=S2 ! + DE1=TWO*PI*DSQRT(S2+X2) ! + NU2=DSQRT(S2+X2) - X ! + DE2=DSQRT(S2+X2)+ X ! + NN=X*PI_INV + NU1*DLOG(NU2/DE2)/DE1 ! +! + SHAS_RT_1D=H_BAR/(NN*EF_SI) ! ref. 1 eq. (33) +! + END FUNCTION SHAS_RT_1D +! +!------ 3) electron-impurity case -------------------------------------------- +! +! +!======================================================================= +! + SUBROUTINE EI_RT_3D(EI_TYPE,EK,T,RS,NI,EPS_B,MASS_E,TAU) +! +! This subroutine computes the electron-impurity relaxation time +! in 3D systems +! +! +! Input parameters: +! +! * EI_TYPE : relaxation time functional for electron-impurity +! EI_TYPE = 'HEAP' --> Hertel-Appel approximation +! * EK : electron energy +! * T : temperature (in SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! * NI : impurity concentration (SI) +! * EPS_B : background dielectric constant +! * MASS_E : electron effective mass +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: EI_TYPE +! + REAL (WP) :: EK,T,RS,NI + REAL (WP) :: EPS_B,MASS_E + REAL (WP) :: TAU +! + IF(EI_TYPE == 'HEAP') THEN ! + TAU=HEAP_RT_3D(EK,T,RS,NI,EPS_B,MASS_E) ! + END IF ! +! + END SUBROUTINE EI_RT_3D +! +!======================================================================= +! + FUNCTION HEAP_RT_3D(EK,T,RS,NI,EPS_B,MASS_E) +! +! This function computes Hertel and Appel approximation for +! the electron-impurity relaxation time in the 3D case +! +! References: (1) P. Hertel and J. Appel, Phys. Rev. B 26, 5730-5742 (1982) +! +! +! Input parameters: +! +! * EK : electron energy +! * T : temperature (in SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! * NI : impurity concentration (SI) +! * EPS_B : background dielectric constant +! * MASS_E : electron effective mass +! +! Output parameters: +! +! * HEAP_RT_3D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE CONSTANTS_P1, ONLY : E + USE PI_ETC, ONLY : PI + USE SQUARE_ROOTS, ONLY : SQR2 + USE UTILITIES_1, ONLY : RS_TO_N0 + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP) :: EK,T,RS,NI + REAL (WP) :: EPS_B,MASS_E + REAL (WP) :: HEAP_RT_3D + REAL (WP) :: B,NU,E2,E4 + REAL (WP) :: EPS_INF + REAL (WP) :: N0 +! + REAL (WP) :: DSQRT,DLOG +! + E2=E*E ! + E4=E2*E2 ! +! +! Computing the electron density +! + N0=RS_TO_N0('3D',RS) ! +! + B=TWO*EPS_B*MASS_E*T/(PI*E2*N0) ! ref. (1) eq. (41) + NU=PI*NI*E4*(DLOG(ONE+B*EK) - B*EK/(ONE+B*EK))/ & ! + (SQR2*EPS_INF*EPS_INF*DSQRT(MASS_E)*(EK**(1.5E0_WP))) ! +! + HEAP_RT_3D=ONE/NU ! +! + END FUNCTION HEAP_RT_3D +! +!------ 4) ion-plasma case -------------------------------------------- +! +! +!======================================================================= +! + SUBROUTINE IP_RT_3D(IP_TYPE,RS,T,TAU) +! +! This subroutine computes the ion plasma relaxation time +! in 3D systems +! +! +! Input parameters: +! +! * IP_TYPE : relaxation time functional for ion plasma +! IP_TYPE = 'SEMO' --> Selchow-Morawetz +! IP_TYPE = 'SPIT' --> Spitzer +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (in SI) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: IP_TYPE +! + REAL (WP) :: RS,T + REAL (WP) :: TAU +! + IF(IP_TYPE == 'SEMO') THEN ! + TAU=SEMO_RT_3D(RS,T) ! + ELSE IF(IP_TYPE == 'BLAN') THEN ! + TAU=SPIT_RT_3D(RS,T) ! + END IF ! +! + END SUBROUTINE IP_RT_3D +! +!======================================================================= +! + FUNCTION SEMO_RT_3D(RS,T) +! +! This function computes Selchow-Morawetz approximation for +! the relaxation time in the 3D case +! +! References: (1) A. Selchow and K. Morawetz, Phys. Rev. E 59, 1015-1023 (1999) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (in SI) +! +! Output parameters: +! +! * SEMO_RT : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THIRD + USE CONSTANTS_P1, ONLY : M_E,E,EPS_0,K_B + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE COULOMB_LOG, ONLY : COU_LOG + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP) :: T + REAL (WP) :: SEMO_RT_3D + REAL (WP) :: E2,G,BETA,V_TH + REAL (WP) :: RS,N0 +! + REAL (WP) :: DSQRT,DEXP +! + INTEGER :: ICL +! + ICL=1 ! choice of Coulomb +! ! logarithm + BETA=ONE/(K_B*T) ! + V_TH=DSQRT(TWO/(BETA*M_E)) ! thermal velocity + E2=E*E ! +! + N0=RS_TO_N0('3D',RS) ! +! + G=DEXP(COU_LOG(ICL,'3D',T,RS)) ! +! + SEMO_RT_3D=ONE/(N0*TWO*THIRD*PI*E2*G*BETA*V_TH/EPS_0) ! ref. (1) eq. (7) +! + END FUNCTION SEMO_RT_3D +! +!======================================================================= +! + FUNCTION SPIT_RT_3D(RS,T) +! +! This function computes Spitzer approximation for +! the relaxation time in the 3D case +! +! References: (1) A. Selchow, G. Röpke and A. Wierling, +! Contrib. Plasma Phys. 42, 43-54 (2002) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (in SI) +! +! Output parameters: +! +! * SPIT_RT : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 23 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,HALF + USE CONSTANTS_P1, ONLY : M_E,E,COULOMB,K_B + USE UTILITIES_1, ONLY : RS_TO_N0 + USE PLASMA, ONLY : ZION + USE PLASMA_SCALE +! + IMPLICIT NONE +! + REAL (WP) :: T + REAL (WP) :: SPIT_RT_3D + REAL (WP) :: BETA,M_EI,E2,E4 + REAL (WP) :: NONID,DEGEN + REAL (WP) :: RS,N0 +! + REAL (WP) :: DSQRT,DLOG +! + M_EI=M_E ! + BETA=ONE/(K_B*T) ! + E2=E*E ! + E4=E2*E2 ! +! + N0=RS_TO_N0('3D',RS) ! +! +! Computing the plasmon scales +! + CALL PLASMON_SCALE(RS,T,ZION,NONID,DEGEN) ! + SPIT_RT_3D=0.591E0_WP*DSQRT(M_EI)/(COULOMB*COULOMB*N0* & ! ref. (1) eq. (30) + (BETA**1.5E0_WP)*E4*HALF*DLOG(1.5E0_WP/(NONID**3)))! +! + END FUNCTION SPIT_RT_3D +! +!------ 5) phase-breaking case -------------------------------------------- +! +! +!======================================================================= +! + SUBROUTINE PB_RT_3D(PB_TYPE,T,D,DC,A,TAU) +! +! This subroutine computes the phase-breaking relaxation time +! in 3D systems +! +! +! Input parameters: +! +! * PB_TYPE : relaxation time functional for phase_breaking +! PB_TYPE = 'ALAR' --> Al'tshuler-Aronov +! PB_TYPE = 'BLAN' --> Blanter +! +! * T : temperature (SI) +! * D : diffusion coefficient (SI) +! * DC : diffusion constant (due to imputities) +! * A : width of 2D systems (SI) (unused) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: PB_TYPE +! + REAL (WP) :: T,D,DC,A + REAL (WP) :: TAU +! + IF(PB_TYPE.EQ.'ALAR') THEN ! + TAU=ALAR_PB_ND(T,DC,A,'3D') ! + ELSE IF(PB_TYPE.EQ.'BLAN') THEN ! + TAU=BLAN_PB_3D(T,D) ! + END IF ! +! + END SUBROUTINE PB_RT_3D +! +!======================================================================= +! + FUNCTION ALAR_PB_ND(T,DC,A,DMN) +! +! This function computes Al'tshuler-Aronov approximation for +! the phase relaxation time in the presence of impurities +! +! Reference: (1) B. L. Al'tshuler and A. G. Aronov, in +! "Electron-Electron Interactions in Disordered +! Solids", A. L. Efros and M. Pollak eds. +! (North-Holland,1985) +! +! +! Input parameters: +! +! * T : temperature (SI) +! * DC : diffusion constant (due to imputities) +! * A : width of 2D systems (SI) +! * DMN : system dimension +! +! Output parameters: +! +! * ARAL_PB_ND : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,COULOMB + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : D,DOS_EF,KF_TO_N0 +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP) :: T,DC,A + REAL (WP) :: ALAR_PB_ND + REAL (WP) :: N0,DD,L,EX,TS,SG + REAL (WP) :: N,TAU + REAL (WP) :: K1,NUM,DEN +! + REAL (WP) :: DLOG,DSQRT +! + DD=HALF*D(DMN) ! +! +! Computing the density of state at Fermi level +! + N0=DOS_EF(DMN) ! +! + EX=TWO/(FOUR-D(DMN)) ! +! +! Computing the elastic mean free path from: +! +! D = l^2 /(tau*d) and D = v_F^2 * tau / d +! + L=DC*D(DMN)/VF_SI ! +! +! Computing the electron density +! + N=KF_TO_N0(DMN,KF_SI) ! +! + TAU=L/VF_SI ! +! +! Computing the Drude conductivity: +! +! sigma = e^2 tau * N / m +! + SG=E*E*TAU*N/M_E ! +! + IF(DMN == '1D') THEN ! + TS=ZERO ! + K1=ONE ! + NUM=T**EX ! + DEN=(DC**DD * N0 * H_BAR*H_BAR)**EX ! + ELSE IF(DMN == '2D') THEN ! + TS=ZERO ! + K1=DLOG( KF_SI*KF_SI*L*A/(H_BAR*H_BAR) ) ! + NUM=T**EX ! + DEN=(DC**DD * N0 * H_BAR*H_BAR)**EX ! + ELSE IF(DMN == '3D') THEN ! + TS=(KF_SI*L)**2 / (DSQRT(L/VF_SI) * T**1.5E0_WP) ! tau* + K1=-TS*DLOG(T*TS/H_BAR) ! + NUM=E*E*COULOMB*T*DSQRT(TS) ! + DEN=TWO*PI*SG*DSQRT(DC)*H_BAR*H_BAR ! + END IF ! +! + ALAR_PB_ND=TS+K1*NUM/DEN ! ref. 1 eq. (4.9) +! + END FUNCTION ALAR_PB_ND +! +!======================================================================= +! + FUNCTION BLAN_PB_3D(T,D) +! +! This function computes Blanter approximation for phase-breaking +! relaxation time in 3D. +! +! Reference: (1) Ya. M. Blanter, Phys. Rev. B 54, 12807 (1996) +! +! +! Input parameters: +! +! * T : temperature (SI) +! * D : diffusion coefficient (SI) +! +! Output parameters: +! +! * BLAN_PB_3D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI2 +! + IMPLICIT NONE +! + REAL (WP) :: T,D + REAL (WP) :: BLAN_PB_3D + REAL (WP) :: N3 +! + N3=M_E*KF_SI/(PI2*H_BAR*H_BAR) ! +! + BLAN_PB_3D=(D/T)**1.5E0_WP * N3 ! ref. 1 eq. (1) +! + RETURN +! + END FUNCTION BLAN_PB_3D +! +!======================================================================= +! + SUBROUTINE PB_RT_2D(PB_TYPE,T,D,DC,A,DMN,TAU) +! +! This subroutine computes the phase-breaking relaxation time +! in 2D systems +! +! +! Input parameters: +! +! * PB_TYPE : relaxation time functional for phase-breaking +! PB_TYPE = 'ALAR' --> Al'tshuler-Aronov +! PB_TYPE = 'BLAN' --> Blanter +! +! * T : temperature (SI) +! * D : diffusion coefficient (SI) +! * DC : diffusion constant (due to imputities) +! * A : width of 2D systems (SI) +! * DMN : dimension of the system +! DMN = '3D' +! DMN = '2D' +! DMN = 'Q2' quasi-2D +! DMN = '1D' +! DMN = 'Q1' quasi-1D +! DMN = 'Q0' quasi-0D +! +! +! +! Author : D. Sébilleau +! +! Last modified : 22 May 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN + CHARACTER (LEN = 4) :: PB_TYPE +! + REAL (WP) :: T,D,DC,A + REAL (WP) :: TAU +! + IF(PB_TYPE == 'ALAR') THEN ! + TAU=ALAR_PB_ND(T,DC,A,'2D') ! + ELSE IF(PB_TYPE == 'BLAN') THEN ! + TAU=BLAN_PB_2D(T,D,DMN,A) ! + END IF ! +! + END SUBROUTINE PB_RT_2D +! +!======================================================================= +! + FUNCTION BLAN_PB_2D(T,D,DMN,A) +! +! This function computes Blanter approximation for phase-breaking +! relaxation time in 2D. +! +! Reference: (1) Ya. M. Blanter, Phys. Rev. B 54, 12807 (1996) +! +! +! Input parameters: +! +! * T : temperature (SI) +! * D : diffusion coefficient (SI) +! * DMN : dimension of the system +! * A : length of confined direction (SI) +! +! Output parameters: +! +! * BLAN_PB_2D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE FERMI_SI, ONLY : EF_SI,KF_SI,VF_SI + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP) :: T,D,A + REAL (WP) :: BLAN_PB_2D + REAL (WP) :: N2,TAU,L +! + REAL (WP) :: DLOG,DSQRT +! + N2=KF_SI*KF_SI/(TWO*PI*EF_SI) ! + TAU=TWO*D / (VF_SI*VF_SI) ! elastic scattering time + L=DSQRT(TWO*D*TAU) ! mean free path +! + IF(DMN == '2D') THEN ! + BLAN_PB_2D=N2*D/T / DLOG(KF_SI*L) ! ref. 1 eq. (10) + ELSE IF(DMN == 'Q2') THEN ! + BLAN_PB_2D=N2*D/T * KF_SI*A / DLOG(KF_SI*KF_SI*L*A) ! ref. 1 eq. (10) + END IF ! +! + END FUNCTION BLAN_PB_2D +! +!======================================================================= +! + SUBROUTINE PB_RT_1D(PB_TYPE,T,D,DC,A,TAU) +! +! This subroutine computes the phase-breaking relaxation time +! in 1D systems +! +! +! Input parameters: +! +! * PB_TYPE : relaxation time functional for phase breaking +! PB_TYPE = 'ALAR' --> Al'tshuler-Aronov +! PB_TYPE = 'BLAN' --> Blanter +! +! * T : temperature (SI) +! * D : diffusion coefficient (SI) +! * DC : diffusion constant (due to imputities) +! * A : length of confined direction (SI) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: PB_TYPE +! + REAL (WP) :: T,D,DC,A + REAL (WP) :: TAU +! + IF(PB_TYPE == 'ALAR') THEN ! + TAU=ALAR_PB_ND(T,DC,A,'1D') ! + ELSE IF(PB_TYPE == 'BLAN') THEN ! + TAU=BLAN_PB_1D(T,D,A) ! + END IF ! +! + END SUBROUTINE PB_RT_1D +! +!======================================================================= +! + FUNCTION BLAN_PB_1D(T,D,A) +! +! This function computes Blanter approximation for phase-breaking +! relaxation time in 1D. +! +! Reference: (1) Ya. M. Blanter, Phys. Rev. B 54, 12807 (1996) +! +! +! Input parameters: +! +! * T : temperature (SI) +! * D : diffusion coefficient (SI) +! * A : length of confined direction (SI) +! +! Output parameters: +! +! * BLAN_PB_1D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOUR,THIRD + USE FERMI_SI, ONLY : KF_SI,VF_SI +! + IMPLICIT NONE +! + REAL (WP) :: T,D,A + REAL (WP) :: BLAN_PB_1D + REAL (WP) :: TAU +! + TAU=TWO*D / (VF_SI*VF_SI) ! elastic scattering time +! + BLAN_PB_1D=TAU**THIRD * (KF_SI*A)**(FOUR*THIRD) / & ! + T**(TWO*THIRD) ! ref. 1 eq. (13) +! + END FUNCTION BLAN_PB_1D +! +END MODULE RELAXATION_TIME_STATIC diff --git a/New_libraries/DFM_library/DAMPING_LIBRARY/scattering_length.f90 b/New_libraries/DFM_library/DAMPING_LIBRARY/scattering_length.f90 new file mode 100644 index 0000000..4723422 --- /dev/null +++ b/New_libraries/DFM_library/DAMPING_LIBRARY/scattering_length.f90 @@ -0,0 +1,160 @@ +! +!======================================================================= +! +MODULE SCATTERING_LENGTH +! + USE ACCURACY_REAL +! +! +CONTAINS +! +! +!======================================================================= +! + FUNCTION SCAT_LENGTH_3D(V0,R0,KP,KD,SL_TYPE) +! +! This function computes the s-wave scattering length for various +! types of 3D potentials. It can be considered as the effective radius +! of the potential at zero energy. It is defined as: +! +! a = lim_{k --> 0} - tan(delta_0)/k +! +! where delta_0 is the s-wave phaseshift (l = 0) +! +! Note: the negative scattering length of a repulsive potential +! is always positive. For an attractive potential, it is +! negative if there is no s-bound-state and positive otherwise. +! +! +! References: (1) C. J. Joachain, "Quantum Collision Theory", +! North-Holland (1975) +! (2) F. Calogero, "Variable Phase Approach to +! Potential Scattering" Academic Press (1967) +! (3) X. Chu, C. Garcia-Cely and H. Murayama, +! arXiv:1908.06067v2 [hep-ph] 6 Sep 2019 +! (4) S. Postnikov and M. Prakash, Int. J. Modern Phys. E 22, +! 1330023 (2013) +! +! +! Input parameters: +! +! * V0 : strength/depth of potential in SI (assumed to be an energy) +! * R0 : radius/half-length of potential in SI +! * KP : particle momentum in SI +! * KD : damping momentum in SI +! * SL_TYPE : type of scattering length calculation +! SL_TYPE = 'HSP' --> hard sphere potential +! SL_TYPE = 'ASW' --> attractive square well (without bound state) +! SL_TYPE = 'RSW' --> repulsive square well +! SL_TYPE = 'DSP' --> delta-shell potential +! SL_TYPE = 'AYP' --> attractive Yukawa potential +! SL_TYPE = 'CCO' --> Coulomb cut-off potential +! SL_TYPE = 'HUL' --> Hulthén potential +! +! +! Output parameters: +! +! * SCAT_LENGTH_3D +! +! +! Definition of potentials: +! +! / + inf if r < R0 +! SL_TYPE = 'HSP' : V(r) = < hard sphere +! \ 0 if r > R0 +! +! +! / -|V0| if 0 < r < 2R0 +! SL_TYPE = 'ASW' : V(r) = < (spherical) attractive square well +! \ 0 otherwise (no bound state) = soft sphere +! +! +! / +|V0| if 0 < r < 2R0 +! SL_TYPE = 'RSW' : V(r) = < (spherical) repulsive square well +! \ 0 otherwise = soft sphere +! +! +! +! SL_TYPE = 'DSP' : V(r) = V0 delta(r-R0) delta-shell +! +! +! +! -exp(- KD*r) +! SL_TYPE = 'AYP' : V(r) = V0 ------------- attractive Yukawa +! r +! +! +! V0 1 +! SL_TYPE = 'CCO' : V(r) = ---- --- Theta(R0-r) Coulomb cut-off +! R0 r (computed with R0=1) +! +! +! exp(-KD*R) +! SL_TYPE = 'Hul' : V(r) = V0 KD ------------------ Hulthén +! ( 1-exp(-KD*R) ) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE EULER_CONST, ONLY : EUMAS + USE EXT_FUNCTIONS, ONLY : DBESJ0,DBESJ1,DPSIPG +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: SL_TYPE +! + REAL (WP), INTENT(IN) :: V0,R0,KP,KD + REAL (WP) :: SCAT_LENGTH_3D + REAL (WP) :: U0,KE,R,K0,G + REAL (WP) :: J0,J1,J2,XX + REAL (WP) :: PG1,PG2,ETA + +! + REAL (WP) :: SQRT,ABS,TAN,TANH +! +! Potential strength in reduced units --> = square momentum KO^2 +! + U0 = TWO * M_E * V0/ (H_BAR * H_BAR) ! + K0 = SQRT(ABS(U0)) ! + G = ABS(U0 * R0) ! +! +! Effective momentum from energy conservation +! ! U0 > 0 for repulsive + KE = SQRT(ABS(KP * KP -U0)) ! U0 < 0 for attractive +! + R = R0 + R0 ! potential length for SW +! + IF(SL_TYPE == 'HSP') THEN ! + SCAT_LENGTH_3D = R0 ! + ELSE IF(SL_TYPE == 'ASW') THEN ! negative + SCAT_LENGTH_3D = R * (ONE - TAN(KE * R)/(KE * R)) ! ref. 1 eq. (4.157) + ELSE IF(SL_TYPE == 'RSW') THEN ! + SCAT_LENGTH_3D = R * (TANH(KE * R)/( KE * R) - ONE) ! positive + ELSE IF(SL_TYPE == 'AYP') THEN ! + SCAT_LENGTH_3D = U0 / (KD * KD * KD) ! + ELSE IF(SL_TYPE == 'DSP') THEN ! + SCAT_LENGTH_3D = R0 * G / (G - ONE) ! ref. 4 eq. (56) + ELSE IF(SL_TYPE == 'CCO') THEN ! + XX = TWO * DSQRT(- U0) ! + J0 = DBESJ0(XX) ! + J1 = DBESJ1(XX) ! + J2 = - J0 + TWO * J1 / XX ! recurrence +! + SCAT_LENGTH_3D = - J2 / (U0 * J0) ! ref. 2 eq. (5a) + ELSE IF(SL_TYPE == 'HUL') THEN ! + ETA = SQRT(U0 * M_E / KD) ! + PG1 = DPSIPG(ONE+ETA,0) ! + PG2 = DPSIPG(ONE-ETA,0) ! +! + SCAT_LENGTH_3D = (PG1 + PG2 + EUMAS + EUMAS) / KD ! ref. 3 eq. (A21) + END IF ! +! + END FUNCTION SCAT_LENGTH_3D +! +END MODULE SCATTERING_LENGTH diff --git a/New_libraries/DFM_library/DAMPING_LIBRARY/viscosity.f90 b/New_libraries/DFM_library/DAMPING_LIBRARY/viscosity.f90 new file mode 100644 index 0000000..b1a5acf --- /dev/null +++ b/New_libraries/DFM_library/DAMPING_LIBRARY/viscosity.f90 @@ -0,0 +1,937 @@ +! +!======================================================================= +! +MODULE VISCOSITY +! + USE ACCURACY_REAL +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE VISCOSITY_COEF(X,ETA) +! +! This subroutine computes the shear viscosity +! +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Oct 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN,RS + USE EXT_FIELDS, ONLY : T + USE PLASMA, ONLY : ZION +! + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE DAMPING_VALUES, ONLY : VI_TYPE +! + USE EL_PHO_INTER, ONLY : NA,MA,RA,DEBYE_T,EP_C +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP), INTENT(OUT) :: ETA + REAL (WP) :: LR,S_L + REAL (WP) :: KD_SI +! + LR = ZERO ! residual mfp (temporary) + S_L = ZERO ! scattering length (temporary) +! +! Computing the Debye momentum +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + IF(DMN == '3D') THEN ! + CALL VISCOSITY_3D(RS,T,ZION,KD_SI,X,ZERO,NA,MA,RA, & ! + DEBYE_T,EP_C,LR,VI_TYPE,ETA) ! + ELSE IF(DMN == '2D') THEN ! + CALL VISCOSITY_2D(T,S_L,VI_TYPE,ETA) ! + ELSE IF(DMN == '1D') THEN ! + ETA = ZERO ! not yet implemented + END IF ! +! + END SUBROUTINE VISCOSITY_COEF +! +!======================================================================= +! + SUBROUTINE VISCOSITY_3D(RS,T,ZION,K_SC,X,Z,NA,MA,RA,TH,CA,LR, & + VI_TYPE,ETA) +! +! This subroutine computes the shear viscosity for 3D electron gas +! at a given value of the temperature T +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! * ZION : atomic number of the ions of the plasma +! * K_SC : screening vector in SI +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * NA : number of atoms per unit volume +! * MA : mass of lattice atoms +! * RA : radius of atoms +! * TH : Debye temperature of the material in SI +! * CA : electron-phonon coupling +! * LR : residual mean free path +! * VI_TYPE : viscosity in 3D +! VI_TYPE = 'AMPP' Angilella et al hard-sphere fluid --> T-dependent +! VI_TYPE = 'DRBA' Daligault-Rasmussen-Baalrud (plasmas) --> T-dependent +! VI_TYPE = 'KHRA' Khrapak for Yukawa fluid --> T-dependent +! VI_TYPE = 'LHPO' Longuet-Higgins-Pope --> T-dependent +! VI_TYPE = 'LLPA' Landau-Lifshitz-Pitaevskii--> T-dependent +! VI_TYPE = 'SCHA' Schäfer --> T-dependent +! VI_TYPE = 'SCHD' Schäfer (dynamic) --> T-dependent +! VI_TYPE = 'SHTE' Shternin --> T-dependent +! VI_TYPE = 'STEI' Steinberg low-temperature --> T-dependent +! +! +! Output parameters: +! +! * ETA : shear viscosity in SI +! +! +! Internal parameters: +! +! * I_F : switch for choice of formula +! I_F = 1 --> eq. (31) ref. 1 +! I_F = 2 --> eq. (32) ref. 1 Landau-Spitzer formula +! I_F = 3 --> eq. (34) ref. 1 +! I_F = 4 --> after eq. (34) ref. 1 Bastea formula +! I_F = 5 --> eq. (38) ref. 1 Braun formula +! I_F = 6 --> eq. (36)-(40) ref. 1 Tanaka-Ichimaru formula +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: VI_TYPE +! + REAL (WP) :: RS,T,ZION,K_SC,X,Z,NA,MA,RA,TH,CA,LR + REAL (WP) :: ETA +! + INTEGER :: I_F +! + IF(VI_TYPE == 'AMPP') THEN ! + ETA=AMPP_VISC_3D(RS,T) ! + ELSE IF(VI_TYPE == 'DRBA') THEN ! + ETA=DRBA_VISC_3D(RS,T,ZION,I_F) ! + ELSE IF(VI_TYPE == 'KHRA') THEN ! + ETA=KHRA_VISC_3D(RS,T,ZION,K_SC,I_F) ! + ELSE IF(VI_TYPE == 'LHPO') THEN ! + ETA=LHPO_VISC_3D(RS,T) ! + ELSE IF(VI_TYPE == 'SCHA') THEN ! + ETA=SCHA_VISC_3D(T) ! + ELSE IF(VI_TYPE == 'SCHD') THEN ! + ETA=SCHA_VISC_3D_D(X,Z,T) ! + ELSE IF(VI_TYPE == 'SHTE') THEN ! + ETA=SHTE_VISC_3D(RS,T) ! + ELSE IF(VI_TYPE == 'STEI') THEN ! + ETA=STEI_VISC_LT_3D(RS,T,NA,MA,RA,TH,CA,LR) ! + END IF ! +! + END SUBROUTINE VISCOSITY_3D +! +!======================================================================= +! + FUNCTION AMPP_VISC_3D(RS,T) +! +! This function computes the Angilella shear viscosity +! for 3D hard-sphere fluid at a given value of the temperature T +! +! References: (1) G. G. N. Angilella et al, Phys. Lett. A, 992-998 (2009) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! +! Output parameters: +! +! * AMPP_VISC_3D +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FIVE,HALF,THIRD + USE CONSTANTS_P1, ONLY : BOHR,M_E,K_B + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : RS_TO_N0 +! + IMPLICIT NONE +! + REAL (WP) :: T,RS + REAL (WP) :: AMPP_VISC_3D + REAL (WP) :: N0 + REAL (WP) :: SI,PF,D0,D,X,X4,NUM,DEN +! + REAL (WP) :: DSQRT +! +! Computing the electron density +! + N0=RS_TO_N0('3D',RS) ! +! +! Hard-sphere diameter +! + SI=TWO*RS*BOHR ! sigma +! +! Computing the packing fraction PF +! + PF=HALF*THIRD*PI*N0 * SI**3 ! +! + D0=(THREE*0.125E0_WP*SI/N0) * DSQRT(K_B*T/(PI*M_E)) ! ref. 1 eq. (9) +! +! Speedy diffusion coefficient +! + X=N0*SI*SI*SI ! + X4=X*X*X*X ! x^4 + D=D0*(ONE - X/1.09E0_WP) * (ONE + X4*(0.4E0_WP-0.83E0_WP*X4)) ! ref. 1 eq. (8) +! + NUM=D0*THREE*PF*K_B*T ! + DEN=D*FIVE*PI*SI*D0 ! + AMPP_VISC_3D=NUM/DEN ! ref. 1 eq. (A5) +! + END FUNCTION AMPP_VISC_3D +! +!======================================================================= +! + FUNCTION DRBA_VISC_3D(RS,T,ZION,I_F) +! +! This function computes the Daligault-Rasmussen_Baalrud shear viscosity +! for 3D plasmas at a given value of the temperature T +! +! References: (1) J. Daligault, K. O. Rasmussen and S. D. Baalrud, +! Phys. Rev. E 90, 033105 (2014) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! * ZION : atomic number of the ions of the plasma +! * I_F : switch for choice of formula +! I_F = 1 --> eq. (31) ref. 1 +! I_F = 2 --> eq. (32) ref. 1 Landau-Spitzer formula +! I_F = 3 --> eq. (34) ref. 1 +! I_F = 4 --> after eq. (34) ref. 1 Bastea formula +! I_F = 5 --> eq. (38) ref. 1 Braun formula +! I_F = 6 --> eq. (36)-(40) ref. 1 Tanaka-Ichimaru formula +! +! +! Output parameters: +! +! * DRBA_VISC_3D +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,COULOMB,K_B + USE PI_ETC, ONLY : PI + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE UTILITIES_1, ONLY : RS_TO_N0 + USE EXT_FUNCTIONS, ONLY : E1Z ! Exponential integral + USE PLASMON_ENE_SI + USE PLASMA_SCALE +! + IMPLICIT NONE +! + REAL (WP) :: T,RS,ZION + REAL (WP) :: DRBA_VISC_3D + REAL (WP) :: N0 + REAL (WP) :: NONID,DEGEN + REAL (WP) :: KD_SI,ETA_0,DELTA,C,LD,RL,Q2 + REAL (WP) :: G1,G2,G3,G4,OP + REAL (WP) :: A,B,A1,A2,A3,B1,B2,B3,B4,K + REAL (WP) :: TTI,GG + REAL (WP) :: NUM,DEN +! + REAL (WP) :: DLOG,DSQRT,DREAL +! + INTEGER :: I_F +! + COMPLEX (WP) :: CE1,CE2 +! +! Computing the electron density and plasmon properties +! + IF( (I_F == 3) .OR. (I_F == 4) ) THEN ! + CALL PLASMON_SCALE(RS,T,ZION,NONID,DEGEN) ! + N0=RS_TO_N0('3D',RS) ! + G1=DEGEN ! Gamma + G2=G1*G1 ! + G3=G2*G1 ! powers of Gamma + G4=G3*G1 ! + OP=ENE_P_SI/H_BAR ! omega_p + A=0.794811E0_WP ! + B=0.862151E0_WP ! + A1=0.0425698E0_WP ! + A2=0.00205782E0_WP ! + A3=7.03658E-5_WP ! ref. 1 table IV + B1=0.0429942E0_WP ! + B2=-0.000270798E0_WP ! + B3=3.25441E-6_WP ! + B4=-1.15019E-8_WP ! + K=G1**2.5E0_WP * DLOG(ONE + B / G1**1.5E0_WP) ! + END IF ! +! +! Computing the Debye vector +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + LD=ONE/KD_SI ! Debye length + DELTA=0.466E0_WP ! + C=1.493E0_WP ! + Q2=E*E*COULOMB ! + RL=Q2/(K_B*T) ! + ETA_0=1.25E0_WP*DSQRT(M_E/PI)* (K_B*T)**2.5E0_WP / (Q2*Q2) ! + GG=LD/RL ! +! + IF(I_F == 1) THEN ! + DRBA_VISC_3D=ETA_0*DELTA / DLOG(ONE + C*GG) ! ref. 1 eq. (31) + ELSE IF(I_F == 2) THEN ! + DRBA_VISC_3D=ETA_0/DLOG(GG) ! ref. 1 eq. (32) + ELSE IF(I_F == 3) THEN ! + NUM=A*(ONE+A1*G1+A2*G2+A3*G3) ! + DEN=K*(ONE+B1*G1+B2*G2+B3*G3+B4*G4) ! + DRBA_VISC_3D=M_E*N0*A*A*OP*NUM/DEN ! + ELSE IF(I_F == 4) THEN ! + DRBA_VISC_3D=M_E*N0*A*A*OP* ( & ! + 0.482E0_WP/G2 + 0.629E0_WP/(G1**0.878E0_WP) & ! + ) ! + ELSE IF(I_F == 6) THEN ! + DRBA_VISC_3D=ETA_0/DLOG(LD/RL) / & ! ref. 1 eq. (38) + (ONE + 0.346E0_WP/DLOG(GG)) ! + ELSE IF(I_F == 5) THEN ! + CALL E1Z( IC/GG,CE1) ! + CALL E1Z(-IC/GG,CE2) ! + TTI=HALF*DREAL( CE1*CDEXP( IC/GG) + & ! ref. 1 eq. (40) + CE2*CDEXP(-IC/GG) & ! + ) ! + DRBA_VISC_3D=ETA_0/TTI ! + END IF ! +! + END FUNCTION DRBA_VISC_3D +! +!======================================================================= +! + FUNCTION KHRA_VISC_3D(RS,T,ZION,K_SC,I_F) +! +! This function computes the Khrapak shear viscosity +! for 3D Yukawa fluid at a given value of the temperature T +! +! References: (1) S. Khrapak, AIP Advances 8, 105226 (2018) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! * ZION : atomic number of the ions of the plasma +! * K_SC : screening vector in SI +! * I_F : switch for choice of formula +! I_F = 1 --> eq. (7) ref. 1 +! I_F = 2 --> eq. (8) ref. 1 +! +! +! Output parameters: +! +! * KHRA_VISC_3D +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,HALF,FOUR,THIRD,FOURTH + USE CONSTANTS_P1, ONLY : BOHR,M_E,K_B + USE UTILITIES_1, ONLY : ALFA + USE PLASMA_SCALE +! + IMPLICIT NONE +! + REAL (WP) :: RS,T,ZION,K_SC + REAL (WP) :: KHRA_VISC_3D + REAL (WP) :: AL,GA,GA_M,KA,X,ETA_R + REAL (WP) :: NONID,DEGEN + REAL (WP) :: BETA,V_TH,F1,F2 +! + REAL (WP) :: DSQRT,DEXP +! + INTEGER :: I_F +! + AL=ALFA('3D') ! parameter alpha +! +! Computing the plasma degeneracy +! + CALL PLASMON_SCALE(RS,T,ZION,NONID,DEGEN) ! +! +! Computing the thermal velocity +! + BETA=ONE/(K_B*T) ! + V_TH=DSQRT(M_E/BETA) ! thermal velocity +! + KA=K_SC*RS*BOHR ! parameter kappa +! +! Coupling parameters +! + GA=DEGEN ! ref. 1 notation + GA_M=(172.0E0_WP*DEXP(AL*KA))/(ONE+AL*KA+HALF*AL*AL*KA*KA) ! ref. 1 eq. (2) + X=GA/GA_M ! +! + IF(I_F == 1) THEN ! + F1=0.104E0_WP / X**0.4E0_WP ! ref. 1 eq. (5) + F2=0.126E0_WP * DEXP(3.64E0_WP*DSQRT(X)) ! ref. 1 eq. (6) + ETA_R=(F1**FOUR + F2**FOUR)**FOURTH ! ref. 1 eq. (7) + ELSE IF(I_F == 2) THEN ! + ETA_R=0.00022E0_WP / X**1.5E0_WP + & ! + 0.096E0_WP / X**0.378E0_WP + & ! ref. 1 eq. (8) + 4.68E0_WP * X**1.5E0_WP ! + END IF ! +! + KHRA_VISC_3D=ETA_R*M_E*V_TH*( AL*AL*RS*RS*BOHR*BOHR ) ! ref. 1 eq. (4) +! + END FUNCTION KHRA_VISC_3D +! +!======================================================================= +! + FUNCTION LHPO_VISC_3D(RS,T) +! +! This function computes the Longuet-Higgins and Pope shear viscosity +! for 3D hard-sphere fluid at a given value of the temperature T +! +! References: (1) G. G. N. Angilella et al, Phys. Lett. A, 992-998 (2009) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! +! Output parameters: +! +! * LHPO_VISC_3D +! +! Author : D. Sébilleau +! +! Last modified : 9 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF,THIRD + USE CONSTANTS_P1, ONLY : BOHR,M_E,K_B + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE PACKING_FRACTION +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP) :: LHPO_VISC_3D +! + REAL (WP) :: N0 + REAL (WP) :: COEF + REAL (WP) :: PF,PF2,PF3,PR,SI +! + REAL (WP) :: SQRT +! +! Computing the electron density +! + N0 = RS_TO_N0('3D',RS) ! +! + COEF = SQRT(M_E * K_B * T / PI) ! +! +! Hard-sphere diameter +! + SI = TWO * RS * BOHR ! sigma +! +! Computing the packing fraction PF +! + PF = PACK_FRAC_2D(N0,SI,'HSM') ! + PF2 = PF * PF ! + PF3 = PF2 * PF ! +! + PR = (ONE + PF + PF2 - PF3) / (ONE - PF)**3 - ONE ! ref. 1 eq. (2) +! + LHPO_VISC_3D = 0.40E0_WP * N0 * SI * COEF * PR ! ref. 1 eq. (1) +! + END FUNCTION LHPO_VISC_3D +! +!======================================================================= +! + FUNCTION LLPA_VISC_3D(X,RS,T) +! +! This function computes the Landau-Lifschitz-Pitaevskii shear viscosity +! for 3D hard-sphere fluid at a given value of the temperature T +! +! Reference: (1) J. Daligault, Phys. Rev. Lett. 119, 045002 (2017) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! +! Output parameters: +! +! * LLPA_VISC_3D +! +! +! Note: we find that the average over solid angles in note [13] ref. (1) is +! +! _ _ +! | 2 | +! e^2 | 2 1 ( k_s ) | 1 +! / __ \ = ----------- | --- + --- ( ----- ) | ------- +! \ / epsilon_0 | 3 2 ( k_F ) | k_F^2 +! |_ _| +! +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,FIVE,EIGHT, & + HALF,THIRD,EIGHTH + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,M_E,K_B,EPS_0 + USE PI_ETC, ONLY : PI,PI3,PI_INV +! + USE PLASMON_SCALE_P, ONLY : NONID + USE COULOMB_LOG, ONLY : DALI_CL_3D + USE SCREENING_TYPE + USE SCREENING_VEC +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,T,RS + REAL (WP) :: LLPA_VISC_3D + REAL (WP) :: Y,Q,Q2,Q4 + REAL (WP) :: CL,KBT,KS,TH + REAL (WP) :: NUM,DEN,BRA +! + REAL (WP) :: SQRT +! + TH = ONE / NONID ! Theta +! + Y = X + X ! q / k_F +! + Q = Y * KF_SI ! q in SI + Q2 = Q * Q ! q^2 in SI + Q4 = Q2 * Q2 ! q^4 in SI +! + KBT = K_B * T ! +! +! Computing the screening vector +! + IF(SC_TYPE == 'NO') THEN ! + CALL SCREENING_VECTOR('TF','3D',X,RS,T,KS) ! + ELSE ! + CALL SCREENING_VECTOR(SC_TYPE,'3D',X,RS,T,KS) ! in SI + END IF ! +! +! Computing the Coulomb logarithm +! + CL = DALI_CL_3D(X) ! +! + IF(TH >= ONE) THEN ! + NUM = FIVE * EIGHTH * SQRT(PI * M_E) * KBT**2.5E0_WP ! \ + DEN = Q4 * CL ! > ref. (1) note [13] + LLPA_VISC_3D = NUM / DEN ! / + ELSE ! + NUM = 16.0E0_WP * EF_SI * BOHR * KF_SI ! \ + DEN = 45.0E0_WP * TH * TH * EIGHT * PI3 * Q4 ! \ + BRA = TWO * THIRD + HALF * (KS / KF_SI)**2 ! / + LLPA_VISC_3D = NUM / (DEN + BRA) ! / + END IF ! +! + END FUNCTION LLPA_VISC_3D +! +!======================================================================= +! + FUNCTION SCHA_VISC_3D(T) +! +! This function computes the Schäfer shear viscosity for +! 3D systems at a given value of the temperature T +! +! References: (1) T. Schäfer, Phys. Rev. A 85, 033623 (2012) +! +! +! Input parameters: +! +! * T : temperature (SI) +! +! +! Output parameters: +! +! * SCHA_VISC_3D +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE CONSTANTS_P1, ONLY : M_E + USE PI_ETC, ONLY : SQR_PI +! + IMPLICIT NONE +! + REAL (WP) :: T + REAL (WP) :: SCHA_VISC_3D +! + SCHA_VISC_3D=15.0E0_WP*(M_E*T)**1.5E0_WP / (32.0E0_WP*SQR_PI) ! ref. 1 eq. (14) +! + END FUNCTION SCHA_VISC_3D +! +!======================================================================= +! + FUNCTION SCHA_VISC_3D_D(X,Z,T) +! +! This function computes the dynamic Schäfer shear viscosity for +! 3D systems at a given value of the low temperature T +! +! References: (2) C. Chafin and T. Schäfer, Phys. Rev. A 87, 023629 (2013) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * T : temperature (SI) +! +! +! Output parameters: +! +! * SCHA_VISC_3D +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : SEVEN,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : KF_TO_N0 +! + IMPLICIT NONE +! + REAL (WP) :: X,Y,Y2,Z,V,T + REAL (WP) :: SCHA_VISC_3D_D + REAL (WP) :: OMEGA,ETA,D_ETA + REAL (WP) :: N0 + REAL (WP) :: NUM,DEN +! + REAL (WP) :: DSQRT +! + Y=X+X ! Y = q / k_F + Y2=Y*Y ! + V=Z*Y2 ! omega / omega_{k_F} + OMEGA=V*HALF*H_BAR*KF_SI*KF_SI/M_E ! omega +! +! Computing the static Schäfer viscosity +! + ETA=SCHA_VISC_3D(T) ! +! +! Computing the electron density +! + N0=KF_TO_N0('3D',KF_SI) ! +! + D_ETA=ETA/N0 ! momentum diffusion constant + NUM=SEVEN + (1.5E0_WP)**1.5E0_WP ! + DEN=240.0E0_WP*PI * D_ETA**1.5E0_WP ! +! + SCHA_VISC_3D_D=ETA - DSQRT(OMEGA)*T * NUM/DEN ! ref. 1 eq. (33) +! + END FUNCTION SCHA_VISC_3D_D +! +!======================================================================= +! + FUNCTION SHTE_VISC_3D(RS,T) +! +! This function computes the Shternin shear viscosity +! for 3D electron gas at a given value of the temperature T +! +! References: (1) P. S. Shternin, J. Phys. A: Math. Theor. 41 205501 (2008) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! +! Output parameters: +! +! * SHTE_VISC_3D +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,SIX,EIGHT,TEN,THIRD + USE CONSTANTS_P1, ONLY : H_BAR,K_B + USE CONSTANTS_P2, ONLY : ALPHA + USE CONSTANTS_P3, ONLY : C + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI,PI3 + USE SQUARE_ROOTS, ONLY : SQR3 + USE UTILITIES_1, ONLY : KF_TO_N0 + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR +! + IMPLICIT NONE +! + REAL (WP) :: RS,T + REAL (WP) :: SHTE_VISC_3D + REAL (WP) :: N0 + REAL (WP) :: NUM,DEN + REAL (WP) :: K_TF_SI + REAL (WP) :: I_ETA,I_L,I_T,I_TL + REAL (WP) :: TH,T_TPE,U,SCF + REAL (WP) :: XI +! + REAL (WP) :: DLOG +! + INTEGER :: REGIME +! + SCF=1.0E-2_WP ! << + XI=1.813174518048293088675271480395889E0_WP ! xi ref. 1 eq. (15) +! +! Computing the electron density +! + N0=KF_TO_N0('3D',KF_SI) ! +! +! Computing the Thomas-Fermi screening verctor +! + CALL THOMAS_FERMI_VECTOR('3D',K_TF_SI) ! +! +! Computing TH, T_TPE and U +! + TH=H_BAR*VF_SI*K_TF_SI/(K_B*T) ! ref. 1 eq. (11) + T_TPE=SQR3/TH ! T / T_pe (idem) + U=VF_SI/C ! idem +! +! Checking the regime +! + IF(U < SCF) THEN ! + IF(T_TPE < SCF) THEN ! + REGIME=2 ! + ELSE ! + REGIME=1 ! + END IF ! ref. 1 table 1. + ELSE ! + IF(T_TPE < SCF) THEN ! + REGIME=4 ! + ELSE ! + REGIME=3 ! + END IF ! + END IF ! +! +! Calculation of the integral I_ETA +! + IF(REGIME == 1) THEN ! + I_L=TWO*THIRD*(DLOG(ONE/TH)+1.919E0_WP) ! + I_T=EIGHT*U*U*U*U*(DLOG(ONE/(U*TH))+3.413E0_WP)/35.0E0_WP ! ref. 1 eq. (13) + I_TL=EIGHT*U*U*(DLOG(ONE/TH)+2.512E0_WP)/15.0E0_WP ! + ELSE IF(REGIME == 3) THEN ! + I_L=TWO*THIRD*(DLOG(ONE/TH)+1.919E0_WP) ! + I_T=THIRD*(DLOG(ONE/TH)+2.742E0_WP) ! ref. 1 eq. (14) + I_TL=TWO*THIRD*(DLOG(ONE/TH)+2.052E0_WP) ! + ELSE ! + I_L=PI3 / (12.0E0_WP*TH) ! + I_T=XI * U**(TEN*THIRD) / (TH*TH)**THIRD ! ref. 1 eq. (15) + I_TL=PI3 * U*U / (SIX*TH) ! + END IF ! +! + I_ETA=I_L+I_T+I_TL ! ref. 1 eq. (12) +! + NUM=PI*H_BAR*H_BAR*N0*KF_SI*VF_SI*VF_SI*VF_SI ! + DEN=60.0E0_WP*ALPHA*ALPHA*C*C*K_B*T*I_ETA ! +! + SHTE_VISC_3D=NUM/DEN ! ref. 1 eq. (9) +! + END FUNCTION SHTE_VISC_3D +! +!======================================================================= +! + FUNCTION STEI_VISC_LT_3D(RS,T,NA,MA,RA,TH,CA,LR) +! +! This function computes Steinberg's low-temperature viscosity. +! +! In this model; the electron interacts with acoustic lattice vibrations +! +! +! Reference: (1) M. S. Steinberg, Phys. Rev. 109, 1486 (1958) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (in SI) +! * NA : number of atoms per unit volume +! * MA : mass of lattice atoms +! * RA : radius of atoms +! * TH : Debye temperature of the material in SI +! * CA : electron-phonon coupling +! * LR : residual mean free path +! +! Output parameters: +! +! * STEI_VISC_LT_3D : relaxation time in seconds +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,THREE,FOUR,FIVE,HALF,THIRD + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI,PI2 + USE UTILITIES_1, ONLY : ALFA,RS_TO_N0 + USE SPECIFIC_INT_1, ONLY : STEI_INT +! + IMPLICIT NONE +! + REAL (WP) :: T,NA,MA,RA,TH,CA,RS + REAL (WP) :: STEI_VISC_LT_3D + REAL (WP) :: N0 + REAL (WP) :: H,AL,GA,D + REAL (WP) :: NUM,DEN,NU1,DE1,DE2,A02,D00 + REAL (WP) :: X,J5,J7,X5,LR +! + REAL (WP) :: DSQRT +! +! Computation of the electron density +! + N0=RS_TO_N0('3D',RS) ! +! + AL=ALFA('3D') ! + H=TWO*PI*H_BAR ! + GA=AL * (FOUR*MA*RA*K_B*TH) / (THREE*H*H*CA*CA) ! + D=EF_SI / ( TWO**THIRD * (N0/NA)**(TWO*THIRD) ) ! +! +! Computation of the J_p(x) functions +! + X=TH/T ! + J5=STEI_INT(X,5) ! + J7=STEI_INT(X,7) ! +! + X5=X*X*X*X*X ! +! + NUM=FOUR*DSQRT(TWO*M_E* M_E*M_E) ! + DEN=15.0E0_WP*PI2* H_BAR*H_BAR*H_BAR ! + A02=EF_SI**FIVE ! + NU1=THREE*DSQRT(M_E+M_E)*D*EF_SI ! + DE1=H_BAR*H_BAR*GA*X5 ! + DE2=J5 - J7/(X*X* 16.0E0_WP**THIRD * (N0/NA)**(TWO*THIRD) ) ! + D00=NU1/(DE1*DE2) + & ! + TWO*EF_SI*EF_SI*EF_SI/(DSQRT(HALF*M_E)*LR) ! +! + STEI_VISC_LT_3D=NUM*A02 / (DEN*D00) ! ref. 1 eq. (7.13) +! + END FUNCTION STEI_VISC_LT_3D +! +!======================================================================= +! + SUBROUTINE VISCOSITY_2D(T,S_L,VI_TYPE,ETA) +! +! This subroutine computes the shear viscosity for 2D electron gas +! at a given value of the temperature T +! +! +! Input parameters: +! +! * T : temperature (SI) +! * S_L : scattering length (SI) +! * VI_TYPE : viscosity in 2D +! VI_TYPE = 'SCHA' Schäfer --> T-dependent +! +! +! Output parameters: +! +! * ETA : shear viscosity in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: VI_TYPE +! + REAL (WP) :: T,S_L + REAL (WP) :: ETA +! + IF(VI_TYPE == 'SCHA') THEN ! + ETA=SCHA_VISC_2D(T,S_L) ! + END IF ! +! + END SUBROUTINE VISCOSITY_2D +! +!======================================================================= +! + FUNCTION SCHA_VISC_2D(T,S_L) +! +! This function computes the Schäfer shear viscosity for +! 2D systems at a given value of the temperature T +! +! References: (1) T. Schäfer, Phys. Rev. A 85, 033623 (2012) +! +! +! Input parameters: +! +! * T : temperature (SI) +! * S_L : scattering length (SI) +! +! +! Output parameters: +! +! * SCHA_VISC_2D +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE CONSTANTS_P1, ONLY : M_E + USE PI_ETC, ONLY : PI2 +! + IMPLICIT NONE +! + REAL (WP) :: T,S_L + REAL (WP) :: SCHA_VISC_2D + REAL (WP) :: T_A2D +! + REAL (WP) :: DLOG +! + T_A2D=ONE/(M_E*M_E*S_L*S_L) ! +! + SCHA_VISC_2D=M_E*T* ( & ! + DLOG(2.5E0_WP*T/T_A2D)**2 + PI2 & ! ref. 1 eq. (10) + ) / (TWO*PI2) ! +! + END FUNCTION SCHA_VISC_2D +! +END MODULE VISCOSITY diff --git a/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_magn_dynamic.f90 b/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_magn_dynamic.f90 new file mode 100644 index 0000000..529e54a --- /dev/null +++ b/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_magn_dynamic.f90 @@ -0,0 +1,245 @@ +! +!======================================================================= +! +MODULE DFUNCL_MAGN_DYNAMIC +! + USE ACCURACY_REAL +! +! +CONTAINS +! +! +!======================================================================= +! +! Longitudinal Dielectric Functions with External Magnetic Field +! +!======================================================================= +! +! + SUBROUTINE DFUNCL_DYNAMIC_M(X,Z,KS,A,NU,D_FUNCL,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in the presence of an external +! magnetic field +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * KS : screening wave vector in SI +! * A : sqrt(mu_B * B) : magnitude of the magnetic field in SI +! * NU : dimensionless filling factor +! * D_FUNCL : type of longitudinal dielectric function (2D) +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 18 Jun 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,KS,A,NU + REAL (WP) :: EPSR,EPSI +! + IF(DMN == '3D') THEN ! + CONTINUE ! + ELSE IF(DMN == '2D') THEN ! + CALL DFUNCL_DYNAMIC_2D_M(X,Z,KS,A,NU,D_FUNCL,EPSR,EPSI) ! + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! + END IF ! +! + END SUBROUTINE DFUNCL_DYNAMIC_M +! +!======================================================================= +! +! 1) 3D case +! +!======================================================================= +! +! 2) 2D case +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC_2D_M(X,Z,KS,A,NU,D_FUNCL,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in 2D in the presence of an external +! magnetic field +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * KS : screening wave vector in SI +! * A : sqrt(mu_B * B) : magnitude of the magnetic field in SI +! * NU : dimensionless filling factor +! * D_FUNCL : type of longitudinal dielectric function (2D) +! D_FUNCL = 'RPA3' random phase approximation +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 18 Jun 2020 +! +! +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,KS,A,NU + REAL (WP) :: EPSR,EPSI +! + IF(D_FUNCL == 'RPA3') THEN ! + CALL RPA3_EPS_D_LG_2D(X,Z,KS,A,NU,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCL_DYNAMIC_2D_M +! +!======================================================================= +! + SUBROUTINE RPA3_EPS_D_LG_2D(X,Z,KS,A,NU,EPSR,EPSI) +! +! This subroutine computes the longitudinal 2D dynamical +! RPA dielectric function with an external magnetic field +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * KS : screening wave vector in SI +! * A : sqrt(mu_B * B) : magnitude of the magnetic field in SI +! * NU : dimensionless filling factor +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 22 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE COMPLEX_NUMBERS, ONLY : ZEROC,IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,EPS_0 + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI_INV + USE SQUARE_ROOTS, ONLY : SQR2 + USE EXT_FUNCTIONS, ONLY : CONHYP +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,KS,A,NU,U + REAL (WP) :: Q_SI,Q2,KS2,COEF,V_C + REAL (WP) :: HOC,QL2,L2O,OM,KK + REAL (WP) :: EPSR,EPSI + REAL (WP) :: GLD(1000) + REAL (WP) :: CONV,DELTA + REAL (WP) :: SUMJ + REAL (WP) :: LKJ,BIN +! + INTEGER :: K,KMAX,J,JMIN,JMAX,I,NFAC +! + COMPLEX (WP) :: EPS,SUMK,KSUM + COMPLEX (WP) :: NUM1,NUM2 + COMPLEX (WP) :: AA,BB,ZZ +! + CONV = 1.0E-6_WP ! Convergence value + DELTA= 1.0E-6_WP ! imaginary part +! + U=X*Z ! omega / (q * v_F) +! + KMAX=100 ! +! + COEF=E*E/EPS_0 ! +! + Q_SI=TWO*X*KF_SI ! + Q2=Q_SI*Q_SI ! + KS2=KS*KS ! + OM=Q_SI*VF_SI*U ! omega +! + HOC=SQR2*A ! hbar * omega_c + QL2=HALF*H_BAR*H_BAR*Q_SI*Q_SI/(M_E*HOC) ! q^2 l^2 / 2 + L2O=H_BAR*H_BAR/M_E ! l^2 hbar omega_c + V_C=HALF*COEF/DSQRT(Q2+KS2) ! 2D Coulomb pot. + KK=DEXP(-QL2)*PI_INV/L2O ! +! +! Storage of the logarithms of the factorials +! + NFAC=KMAX+INT(NU) ! + GLD(1)=ZERO ! + DO I=2,NFAC ! + J=I-1 ! + GLD(I)=GLD(J)+DLOG(DFLOAT(J)) ! + END DO ! +! + SUMK=ZEROC ! + DO K=1,KMAX ! + NUM1=H_BAR*OM - DFLOAT(K)*HOC + IC*DELTA ! + NUM2=H_BAR*OM + DFLOAT(K)*HOC + IC*DELTA ! + AA=DCMPLX(-DFLOAT(K)) ! + JMIN=MAX(0,INT(NU)-K) ! + JMAX=INT(NU) ! + SUMJ=ZERO ! + DO J=JMIN,JMAX ! +! +! Computing the generalized Laguerre polynomials from +! the confluent hypergeometric function: +! +! L(n,k,x) = (n+k) * 1F1(-n,k+1;x) +! ( n ) +! + BIN=DEXP(GLD(K+J+1)/(GLD(K+1)*GLD(J+1))) ! binomial coefficient + BB=DCMPLX(DFLOAT(J)+ONE) ! + ZZ=DCMPLX(QL2) ! + LKJ=BIN*DREAL(CONHYP(AA,BB,ZZ,0,10)) ! +! + SUMJ=SUMJ+DEXP(GLD(J+1)-GLD(J+K+1))*LKJ*LKJ ! + END DO ! + KSUM=SUMJ*(ONE/NUM1 - ONE/NUM2)*(QL2**K) ! + SUMK=SUMK+KSUM ! + IF(CDABS(KSUM).LT.CONV) GO TO 10 ! + END DO ! +! + 10 EPS=ONE-V_C*KK*SUMK ! +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE RPA3_EPS_D_LG_2D +! +!======================================================================= +! +! 1) 1D case +! +!======================================================================= +! +! +END MODULE DFUNCL_MAGN_DYNAMIC diff --git a/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_stan_dynamic.f90 b/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_stan_dynamic.f90 new file mode 100644 index 0000000..2554f42 --- /dev/null +++ b/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_stan_dynamic.f90 @@ -0,0 +1,5343 @@ +! +!======================================================================= +! +MODULE DFUNCL_STAN_DYNAMIC +! + USE ACCURACY_REAL + USE ACCURACY_INTEGER + USE MINMAX_VALUES +! +! +CONTAINS +! +! +!======================================================================= +! +! Standard Longitudinal Dielectric Functions i.e. with: +! +! * no external magnetic field +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNCL,FLAG,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * D_FUNCL : type of longitudinal dielectric function (3D) +! * FLAG : current index of the omega loop calling this subroutine +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE MATERIAL_PROP, ONLY : DMN + USE REAL_NUMBERS, ONLY : ZERO,INF +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,RS,T + REAL (WP) :: EPSR,EPSI +! + INTEGER :: FLAG +! + IF(DMN == '3D') THEN ! + CALL DFUNCL_DYNAMIC_3D(X,Z,RS,T,D_FUNCL,FLAG,EPSR,EPSI) ! + ELSE IF(DMN == '2D') THEN ! + CALL DFUNCL_DYNAMIC_2D(X,Z,RS,T,D_FUNCL,EPSR,EPSI) ! + ELSE IF(DMN == 'BL') THEN ! + CALL DFUNCL_DYNAMIC_BL(X,Z,RS,T,D_FUNCL,EPSR,EPSI) ! + ELSE IF(DMN == 'ML') THEN ! + CALL DFUNCL_DYNAMIC_ML(X,Z,RS,T,D_FUNCL,EPSR,EPSI) ! + ELSE IF(DMN == 'Q1') THEN ! + CALL DFUNCL_DYNAMIC_Q1(X,Z,D_FUNCL,EPSR,EPSI) ! + ELSE IF(DMN == '1D') THEN ! + CALL DFUNCL_DYNAMIC_1D(X,Z,RS,T,D_FUNCL,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCL_DYNAMIC +! +! 1) 3D case +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC_3D(X,Z,RS,T,D_FUNCL,FLAG,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in 3D +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * V : dimensionless factor --> V = hbar * omega / E_F +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * D_FUNCL : type of longitudinal dielectric function (3D) +! D_FUNCL = 'ARBR' Arista-Brandt 1 <-- T-dependent +! D_FUNCL = 'ATAS' Atwal-Ashcroft <-- T-dependent +! D_FUNCL = 'BLZ1' Boltzmann +! D_FUNCL = 'BLZ2' damped Boltzmann +! D_FUNCL = 'DACA' Arista-Brandt 2 <-- T-dependent +! D_FUNCL = 'GOTZ' Götze memory function +! D_FUNCL = 'HEAP' Hertel-Appel +! D_FUNCL = 'HAFO' Hartree-Fock +! D_FUNCL = 'HUCO' Hu-O'Connell <-- damping +! D_FUNCL = 'HYDR' hydrodynamic <-- damping +! D_FUNCL = 'KLEI' Kleinman <-- T-dependent +! D_FUNCL = 'KLKD' Klimontovich-Kraeft <-- T-dependent +! D_FUNCL = 'KLKN' Klimontovich-Kraeft <-- T-dependent +! D_FUNCL = 'LAND' Landau parameters-based +! D_FUNCL = 'LVL1' linearized Vlasov (weak coupling) <-- T-dependent +! D_FUNCL = 'LVL2' linearized Vlasov (strong coupling) <-- T-dependent +! D_FUNCL = 'MEM2' Two-moment memory function <-- T-dependent +! D_FUNCL = 'MEM3' Three-moment memory function <-- T-dependent +! D_FUNCL = 'MEM4' Four-moment memory function <-- T-dependent +! D_FUNCL = 'MER1' Mermin 1 <-- damping +! D_FUNCL = 'MER2' Mermin 2 <-- T-dependent +! D_FUNCL = 'MER+' Mermin with Local Field Corrections <-- damping +! D_FUNCL = 'MSAP' mean spherical approximation +! D_FUNCL = 'NEV2' Nevanlinna <-- T-dependent +! D_FUNCL = 'NEV3' Nevanlinna <-- T-dependent +! D_FUNCL = 'PLPO' plasmon pole +! D_FUNCL = 'RDF1' Altshuler et al <-- damping +! D_FUNCL = 'RDF2' Altshuler et al <-- damping +! D_FUNCL = 'RPA1' RPA +! D_FUNCL = 'RPA2' RPA <-- T-dependent +! D_FUNCL = 'RPA+' RPA + static local field corrections +! D_FUNCL = 'UTIC' Utsumi-Ichimaru <-- T-dependent +! D_FUNCL = 'VLFP' Vlasov-Fokker-Planck <-- damping +! * FLAG : current index of the omega loop calling this subroutine +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOURTH +! + USE LF_VALUES, ONLY : LANDAU +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,RS,T + REAL (WP) :: D ! dopant concentration + REAL (WP) :: EPSR,EPSI + REAL (WP) :: XC,U0,W +! + INTEGER :: FLAG +! +! Computing the dielectric function +! + IF(D_FUNCL.EQ.'ARBR') THEN ! + CALL ARBR_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'ATAS') THEN ! + CALL ATAS_EPS_D_LG_3D(X,Z,T,RS,FLAG,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'BLZ1') THEN ! + CALL BLZ1_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'BLZ2') THEN ! + CALL BLZ2_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'DACA') THEN ! + CALL DACA_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'GOTZ') THEN ! + CALL GOTZ_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'HEAP') THEN ! + CALL HEAP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'HAFO') THEN ! + CALL HAFO_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'HUCO') THEN ! + CALL HUCO_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'HYDR') THEN ! + CALL HYDR_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'KLEI') THEN ! + CALL KLEI_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'KLKD') THEN ! + CALL KLKD_EPS_D_LG_3D(X,Z,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'KLKN') THEN ! + CALL KLKN_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'LAND') THEN ! + CALL LAND_EPS_D_LG_3D(X,Z,XC,U0,W,D,RS,LANDAU,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'LVL1') THEN ! + CALL LVL1_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'LVL2') THEN ! + CALL LVL2_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'MEM2') THEN ! + CALL MEM2_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'MEM3') THEN ! + CALL MEM3_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'MER1') THEN ! + CALL MER1_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'MER2') THEN ! + CALL MER2_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'MER+') THEN ! + CALL MERP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'MSAP') THEN ! + CALL MSAP_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'NEV2') THEN ! + CALL NEV2_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'NEV3') THEN ! + CALL NEV3_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'PLPO') THEN ! + CALL PLPO_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'RDF1') THEN ! + CALL RDF1_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'RDF2') THEN ! + CALL RDF2_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'RPA1') THEN ! + CALL RPA1_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'RPA2') THEN ! + CALL RPA2_EPS_D_LG_3D(X,Z,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'RPA+') THEN ! + CALL RPAP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'UTIC') THEN ! + CALL UTIC_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'VLFP') THEN ! + CALL VLFP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCL_DYNAMIC_3D +! +!======================================================================= +! + SUBROUTINE ARBR_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) +! +! This subroutine computes Arista-Brandt expression +! for the longitudinal temperature-dependent +! dielectric function EPS(q,omega,T) in 3D systems. +! +! References: (1) N. R. Arista and W. Brandt, Phys. Rev. A 29, +! 1471-1480 (1984) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOUR,& + FOURTH,EIGHTH,SMALL,INF + USE CONSTANTS_P1, ONLY : BOHR,K_B + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI +! + USE CHEMICAL_POTENTIAL, ONLY : MU_T + USE SPECIFIC_INT_8 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: X2,X3,Y,U + REAL (WP) :: KBT,D,THETA,ETA + REAL (WP) :: CHI0_2 + REAL (WP) :: UPX,UMX + REAL (WP) :: G_UPX,G_UMX + REAL (WP) :: ENU,EDE,NUM,DEN + REAL (WP) :: LN + REAL (WP) :: MAX_EXP,MIN_EXP +! + REAL (WP) :: ABS,EXP,LOG +! +! Computing the max and min value of the exponent of e^x +! +! + CALL MINMAX_EXP(MAX_EXP,MIN_EXP) ! +! + X2 = X * X ! + X3 = X2 * X ! + Y = X + X ! q / k_F + U = X * Z ! U = omega / (q v_F) +! + KBT = K_B * T ! + THETA = KBT / EF_SI ! 1 / degeneracy + D = ONE / THETA ! degeneracy + ETA = MU_T('3D',T) / KBT ! +! + CHI0_2 = ONE / (PI * KF_SI * BOHR) ! ref. (1) eq. (4) +! + UPX = U + X ! + UMX = U - X ! +! + IF(ABS(UMX) <= SMALL) UMX = 0.01E0_WP ! +! +! Computing the integrals involved in the real part +! + CALL INT_ARB(UPX,D,ETA,G_UPX) ! + CALL INT_ARB(UMX,D,ETA,G_UMX) ! +! + EPSR = ONE + FOURTH * CHI0_2 * (G_UPX - G_UMX) / X3 ! ref. (1) eq. (7) +! +! Computing the imaginary part +! + ENU = ETA - D * (UMX)**2 ! exponent of numerator + EDE = ETA - D * (UPX)**2 ! exponent of denominator +! +! Numerator of Log +! + IF(ENU >= ZERO) THEN ! + IF(ENU < MAX_EXP) THEN ! + NUM = ONE + EXP(ENU) ! + ELSE ! + NUM = INF ! + END IF ! + ELSE ! + IF(ENU > MIN_EXP) THEN ! + NUM = ONE + EXP(ENU) ! + ELSE ! + NUM = ONE ! + END IF ! + END IF ! +! +! Denominator of Log +! + IF(EDE >= ZERO) THEN ! + IF(EDE < MAX_EXP) THEN ! + DEN = ONE + EXP(EDE) ! + ELSE ! + DEN = INF ! + END IF ! + ELSE ! + IF(EDE > MIN_EXP) THEN ! + DEN = ONE + EXP(EDE) ! + ELSE ! + DEN = ONE ! + END IF ! + END IF ! +! +! Computing the Log +! + IF(ENU /= INF .AND. EDE /= INF) THEN ! + LN = LOG(NUM/DEN) ! + ELSE IF(ENU /= INF .AND. EDE == INF) THEN ! + LN = LOG( EXP(- EDE) + EXP(ENU - EDE) ) ! + ELSE IF(ENU == INF .AND. EDE /= INF) THEN ! + LN = - LOG( EXP(- ENU) + EXP(EDE - ENU) ) ! + ELSE IF(ENU == INF .AND. EDE == INF) THEN ! + LN = ENU - EDE ! + END IF ! +! + EPSI = EIGHTH * PI * CHI0_2 * THETA * LN / X3 ! ref. (1) eq. (23) +! + END SUBROUTINE ARBR_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE ATAS_EPS_D_LG_3D(X,Z,T,RS,FLAG,EPSR,EPSI) +! +! This subroutine computes Arkhipov et al parametrization +! for the longitudinal temperature-dependent Atwal-Ashcroft +! dielectric function EPS(q,omega,T) in 3D systems. +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 90, 053102 (2014) +! (2) G. S. Atwal and N. W. Ashcroft, Phys. Rev. B 65, 115109 (2002) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * T : temperature (SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! * FLAG : current index of the omega loop calling this subroutine +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Warning: the subroutine is suppose to be called in a omega-loop +! starting from omega ~ zero. During the first run of +! the subroutine, it will store Pi_mu(q,omega=0) for further use +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR, & + HALF,FOURTH + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,EPS_0,K_B + USE FERMI_SI, ONLY : EF_SI,KF_SI,VF_SI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE EXT_FUNCTIONS, ONLY : FDP1P5 + USE CHEMICAL_POTENTIAL, ONLY : MU + USE COULOMB_K, ONLY : COULOMB_FF +! + USE UNITS, ONLY : UNIT +! + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,T,RS,U,GM + REAL (WP) :: D,NU,ITA,VC + REAL (WP) :: Q_SI + REAL (WP) :: K0,K2,K4,N0,XSI,OM + REAL (WP) :: EPSR,EPSI +! + REAL (WP) :: DREAL,DIMAG +! + COMPLEX (WP) :: S1,S2,W + COMPLEX (WP) :: G11,G12,G31,G32,G51,G52 + COMPLEX (WP) :: PP0,PP2,PP4 + COMPLEX (WP) :: PI0Q,PI2Q,PI4Q + COMPLEX (WP) :: B0,B2,B4,D2,D4 + COMPLEX (WP) :: EQO,FQO +! + INTEGER :: FLAG +! + Q_SI = TWO * X * KF_SI ! q in SI +! + CALL COULOMB_FF('3D',UNIT,Q_SI,ZERO,VC) ! Coulomb pot. +! + NU = ONE / TAU ! collision freq. + U = X * Z ! omega / (q * v_F) + GM = NU / (Q_SI * VF_SI) ! gamma + D = EF_SI / (K_B*T) ! + ITA = MU('3D',T) / (K_B*T) ! +! +! Computing the electron density +! + N0 = RS_TO_N0('3D',RS) ! +! + S1 = U + X + IC * GM ! sigma_1 + S2 = U - X + IC * GM ! sigma_2 +! + OM = Z * H_BAR * Q_SI * Q_SI * HALF / M_E ! omega in SI + XSI = OM * NU * M_E / (N0 * Q_SI *Q_SI) ! + W = OM + IC * NU ! +! +! Computing the G_l(sigma) functions +! + G11 = G1(S1,D,ITA) ! + G12 = G1(S2,D,ITA) ! + G31 = G3(S1,D,ITA) ! ref. 1 eq. (40) + G32 = G3(S2,D,ITA) ! + G51 = G5(S1,D,ITA) ! + G52 = G5(S2,D,ITA) ! +! +! Computing the polarization operators PPx +! + K0 = THREE * M_E * N0 / (FOUR*X*H_BAR*H_BAR*KF_SI*KF_SI) ! + K2 = M_E * N0 / (H_BAR * H_BAR) ! + K4 = M_E * N0 * KF_SI * KF_SI / (H_BAR * H_BAR) ! +! + PP0 = K0 * (G11 - G12) ! ref. 1 eq. (37) +! + PP2=K2*( FOURTH*(TWO+THREE*X*(G11-G12)) - & ! + HALF*(THREE*(S1*G11+S2*G12)) + & ! ref. 1 eq. (38) + FOURTH*(THREE*(G31-G32)/X) & ! + ) ! +! + PP4 = K4*( TWO*(THREE*FDP1P5(ITA) / D**2.5E0_WP - TWO*X*U)+ & ! + THREE*FOURTH*(G51-G52)/X + & ! + THREE*HALF*(THREE*X*(G31-G32)) - & ! + THREE*(S1*G31+S2*G32) + & ! ref. 1 eq. (39) + THREE*FOURTH*X*X*X*(G11-G12) - & ! + THREE*X*(S1*S1*G11-S2*S2*G12) - & ! + THREE*X*X*(S1*G11+S2*G12) & ! + ) ! +! +! Computing the coefficients Bs and Ds +! + IF(FLAG == 1) THEN ! + PI0Q = PP0 ! + PI2Q = PP2 ! + PI4Q = PP4 ! + END IF ! +! + B0 = - PI0Q ! + B2 = - PI2Q ! + B4 = - PI4Q ! + D2 = (IC * NU * PI2Q - OM * B2) / W ! + D4 = (IC * NU * PI4Q - OM * B4) / W ! +! +! Computing the functions E(q,omega) and F(q,omega) +! + EQO = - IC*NU*PP2*( (PP2*B0-PP0*B2)/(D4*B0-B2*D2) )/OM ! + FQO = IC*NU*( (D2*PP2-D4*PP0-IC*XSI*PP2*(PP2*B0-PP0*B2)) /& ! + (D4*B0-B2*D2) - ONE & ! + ) / OM + IC*XSI*PP0 ! +! +! Computing the dielectric function +! + EPSR = ONE + VC * REAL( (PP0 + EQO) / (ONE + FQO) ) ! + EPSI = VC * AIMAG( (PP0 + EQO) / (ONE + FQO) ) ! +! + END SUBROUTINE ATAS_EPS_D_LG_3D +! +!======================================================================= +! + FUNCTION G1(S,D,ETA) +! +! This function computes Arkhipov et al G1 function +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 90, 053102 (2014) +! +! Input parameters: +! +! * S : sigma +! * D : D +! * ETA : eta +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ONE,TWO + USE COMPLEX_NUMBERS, ONLY : IC + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + REAL (WP) :: D,ETA + REAL (WP) :: Y,Y_MAX,Y1 + REAL (WP) :: F(NZ_MAX),G(NZ_MAX) + REAL (WP) :: SR,SI,A,B,RLN,ILN,RIN,IIN + REAL (WP) :: H +! + REAL (WP) :: FLOAT,REAL,AIMAG,LOG + REAL (WP) :: SQRT,ATAN,EXP +! + COMPLEX (WP) :: G1,S +! + INTEGER :: J,ID +! + Y_MAX = 100.0E0_WP ! max of y + H = Y_MAX / FLOAT(NZ_MAX - 1) ! y-step + ID = 1 ! +! +! Setting up the grid Y and the integrand functions +! F(I) and G(I) +! +! F(I) : real part of integrand +! G(I) : imaginary part of integrand +! +! Here, we make use of the fact that, if z = a + i b +! +! Ln(z) = ln|z| + r atan(b/a) +! +! Notation: SR = Re [ sigma ] +! SI = Im [ sigma ] +! A = Re[ (sigma + y)/(sigma-y) ] +! B = Im[ (sigma + y)/(sigma-y) ] +! + DO J = 1, NZ_MAX ! +! + Y = FLOAT(J - 1) * Y_MAX / FLOAT(NZ_MAX - 1) ! + Y1 = Y ! + SR = REAL(S) ! + SI = AIMAG(S) ! + A = (SR*SR + SI*SI - Y*Y) / ((SR-Y) * (SR-Y) + SI*SI) ! + B = - TWO * SI * Y ! + RLN = LOG( SQRT(A * A + B * B) ) ! + ILN = ATAN(B / A) ! + F(J) = Y1 * RLN / (EXP(D * Y * Y - ETA) + ONE) ! + G(J) = Y1 * ILN / (EXP(D * Y * Y - ETA) + ONE) ! +! + END DO ! +! +! Performing the integrations +! + CALL INTEGR_L(F,H,NZ_MAX,NZ_MAX,RIN,ID) ! + CALL INTEGR_L(G,H,NZ_MAX,NZ_MAX,IIN,ID) ! +! + G1 = RIN + IC *IIN ! +! + END FUNCTION G1 +! +!======================================================================= +! + FUNCTION G3(S,D,ETA) +! +! This function computes Arkhipov et al G3 function +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 90, 053102 (2014) +! +! Input parameters: +! +! * S : sigma +! * D : D +! * ETA : eta +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ONE,TWO + USE COMPLEX_NUMBERS, ONLY : IC + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + REAL (WP) :: D,ETA + REAL (WP) :: Y,Y_MAX,Y3 + REAL (WP) :: F(NZ_MAX),G(NZ_MAX) + REAL (WP) :: SR,SI,A,B,RLN,ILN,RIN,IIN + REAL (WP) :: H +! + REAL (WP) :: FLOAT,REAL,AIMAG,LOG + REAL (WP) :: SQRT,ATAN,EXP +! + COMPLEX (WP) :: G3,S +! + INTEGER :: J,ID +! + Y_MAX = 100.0E0_WP ! max of y + H = Y_MAX / FLOAT(NZ_MAX - 1) ! y-step + ID = 1 ! +! +! Setting up the grid Y and the integrand functions +! F(I) and G(I) +! +! F(I) : real part of integrand +! G(I) : imaginary part of integrand +! +! Here, we make use of the fact that, if z = a + i b +! +! Ln(z) = ln|z| + r atan(b/a) +! +! Notation: SR = Re [ sigma ] +! SI = Im [ sigma ] +! A = Re[ (sigma + y)/(sigma-y) ] +! B = Im[ (sigma + y)/(sigma-y) ] +! + DO J = 1, NZ_MAX ! +! + Y = FLOAT(J - 1) * Y_MAX / FLOAT(NZ_MAX - 1) ! + Y3 = Y * Y * Y ! + SR = REAL(S) ! + SI = AIMAG(S) ! + A = (SR*SR + SI*SI - Y*Y) / ((SR-Y) * (SR-Y) + SI*SI) ! + B = - TWO * SI * Y ! + RLN = LOG( SQRT(A * A + B * B) ) ! + ILN = ATAN(B / A) ! + F(J) = Y3 *RLN /(EXP(D * Y * Y - ETA) + ONE) ! + G(J) = Y3 *ILN /(EXP(D * Y * Y - ETA) + ONE) ! +! + END DO ! +! +! Performing the integrations +! + CALL INTEGR_L(F,H,NZ_MAX,NZ_MAX,RIN,ID) ! + CALL INTEGR_L(G,H,NZ_MAX,NZ_MAX,IIN,ID) ! +! + G3 = RIN + IC * IIN ! +! + END FUNCTION G3 +! +!======================================================================= +! + FUNCTION G5(S,D,ETA) +! +! This function computes Arkhipov et al G5 function +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 90, 053102 (2014) +! +! Input parameters: +! +! * S : sigma +! * D : D +! * ETA : eta +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Mar 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ONE,TWO + USE COMPLEX_NUMBERS, ONLY : IC + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + REAL (WP) :: D,ETA + REAL (WP) :: Y,Y_MAX,Y5 + REAL (WP) :: F(NZ_MAX),G(NZ_MAX) + REAL (WP) :: SR,SI,A,B,RLN,ILN,RIN,IIN + REAL (WP) :: H +! + REAL (WP) :: FLOAT,REAL,AIMAG,LOG + REAL (WP) :: SQRT,ATAN,EXP +! + COMPLEX (WP) :: G5,S +! + INTEGER :: J,ID +! + Y_MAX = 100.0E0_WP ! max of y + H = Y_MAX / FLOAT(NZ_MAX - 1) ! y-step + ID = 1 ! +! +! Setting up the grid Y and the integrand functions +! F(I) and G(I) +! +! F(I) : real part of integrand +! G(I) : imaginary part of integrand +! +! Here, we make use of the fact that, if z = a + i b +! +! Ln(z) = ln|z| + r atan(b/a) +! +! Notation: SR = Re [ sigma ] +! SI = Im [ sigma ] +! A = Re[ (sigma + y)/(sigma-y) ] +! B = Im[ (sigma + y)/(sigma-y) ] +! + DO J=1,NZ_MAX ! +! + Y = FLOAT(J - 1) * Y_MAX / FLOAT(NZ_MAX - 1) ! + Y5 = Y * Y * Y * Y * Y ! + SR = REAL(S) ! + SI = AIMAG(S) ! + A = (SR*SR + SI*SI - Y*Y) / ((SR-Y)*(SR-Y) + SI*SI) ! + B = - TWO * SI * Y ! + RLN = LOG( SQRT(A * A + B * B) ) ! + ILN = ATAN(B / A) ! + F(J) = Y5 * RLN /(EXP(D * Y * Y - ETA) + ONE) ! + G(J) = Y5 * ILN /(EXP(D * Y * Y - ETA) + ONE) ! + + END DO ! +! +! Performing the integrations +! + CALL INTEGR_L(F,H,NZ_MAX,NZ_MAX,RIN,ID) ! + CALL INTEGR_L(G,H,NZ_MAX,NZ_MAX,IIN,ID) ! +! + G5 = RIN + IC * IIN ! +! + END FUNCTION G5 +! +!======================================================================= +! + SUBROUTINE BLZ1_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) +! +! This subroutine computes the longitudinal Boltzmann dynamical +! dielectric function in 3D +! +! References: (1) P. Halevi, Phys. Rev. B 51, 7497-7499 (1995) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,THREE,FOUR, & + HALF + USE FERMI_SI, ONLY : EF_SI + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS + REAL (WP), INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: U,U2,V + REAL (WP) :: COEF,ENE2 +! + REAL (WP) :: LOG +! + U = X * Z ! omega / (q * v_F) + V = FOUR * U * X ! omega / omega_F + U2 = U * U ! +! + ENE2 = (V * EF_SI)**2 ! (h_bar omega)^2 + COEF = THREE * U * ENE_P_SI * ENE_P_SI / ENE2 ! +! + EPSR = ONE + COEF * ( U + HALF * U2 * LOG( & ! + ABS((U - ONE) / (U + ONE)) & ! + ) & ! + ) ! + EPSI = ZERO ! +! + END SUBROUTINE BLZ1_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE BLZ2_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) +! +! This subroutine computes the longitudinal Boltzmann dynamical +! dielectric function in 3D +! +! References: (1) R. Esquivel and V. B. Stetovoy, Phys. Rev. A 69, 062102 (2004) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PLASMON_ENE_SI + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS + REAL (WP), INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: U + REAL (WP) :: Q_SI,O_SI + REAL (WP) :: OMP,OMT + REAL (WP) :: RAT +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: UU,U3,COEF + COMPLEX (WP) :: KK,NUM,DEN + COMPLEX (WP) :: LLOG,FL +! + U = X * Z ! omega / (q * v_F) +! + Q_SI = TWO * X * KF_SI ! q in SI + O_SI = U * Q_SI * VF_SI ! omega in SI + OMP = ENE_P_SI / H_BAR ! omega_p + OMT = ONE / TAU ! omega_tau + RAT = OMT / O_SI ! omega_tau / omega +! + UU = Q_SI * VF_SI / (O_SI + IC * OMT) ! ref. (1) eq. (16) + U3 = UU * UU * UU ! +! + COEF = OMP * OMP / (O_SI * O_SI + IC * O_SI * OMT) ! + LLOG = LOG((ONE + UU) / (ONE - UU)) ! + KK = THREE / U3 ! + NUM = - UU + HALF * LLOG ! + DEN = ONE + IC * RAT * (ONE - HALF * LLOG / UU) ! +! + FL = KK * NUM / DEN ! ref. (1) eq. (15) +! + EPSR = ONE - REAL(COEF * FL, KIND=WP) ! + EPSI = AIMAG(COEF * FL) ! +! + END SUBROUTINE BLZ2_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE DACA_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes Dandrea-Ashcroft-Carlsson parametrization +! for the longitudinal temperature-dependent Arista-Brandt +! dielectric function EPS(q,omega,T) for 3D systems. +! +! References: (1) R. G. Dandrea, N. W. Ashcroft and A. E. Carlsson, +! Phys. Rev. B 34, 2097-2111 (1986) +! (2) N. R. Arista and W. Brandt, Phys. Rev. A 29, +! 1471-1480 (1984) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 21 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,FOUR,HALF,THIRD,FOURTH + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI_INV,SQR_PI + USE UTILITIES_1, ONLY : ALFA + USE LF_VALUES, ONLY : GQ_TYPE + USE LOCAL_FIELD_STATIC + USE PHI_FUNCTION +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,RS,T,U + REAL (WP) :: EPSR,EPSI + REAL (WP) :: ETA0,THETA,ALPHA + REAL (WP) :: F10,F20,U1,U2,COEF,NUM,DEN + REAL (WP) :: GQ +! + REAL (WP) :: DLOG,DEXP,DREAL,DIMAG +! + COMPLEX (WP) :: EPS +! + U=X*Z ! omega / (q * v_F) +! + THETA=K_B*T/EF_SI ! + ALPHA=ALFA('3D') ! + COEF=FOURTH*ALPHA*RS/(X*X*X) ! +! + IF(THETA < ONE) THEN ! + ETA0=EF_SI/(K_B*T) ! ref. (2) eq. (A4') + ELSE + ETA0=DLOG(FOUR*THIRD/(SQR_PI * THETA**1.5E0_WP)) ! ref. (2) eq. (A5') + END IF ! +! + U1=U+X ! + U2=U-X ! +! + F10=COEF*PI_INV*(PHI(U1,THETA)-PHI(U2,THETA)) ! ref. (1) eq. (4.6) +! + NUM=ONE+DEXP(ETA0 - U2*U2/THETA) ! + DEN=ONE+DEXP(ETA0 - U1*U1/THETA) ! + F20=-HALF*COEF*THETA*DLOG(NUM/DEN) ! ref. (1) eq. (4.7) +! +! Calling the local-field correction +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ) ! +! + EPS=(ONE-F10-IC*F20)/(ONE+GQ*F10+IC*GQ*F20) ! +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE DACA_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE GOTZ_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) +! +! This subroutine computes the Götze memory function approach, +! which can be considered as a generalization of the Mermin's +! dielectric function. +! +! References: (1) F. Yoshida and S. Takeno, Phys. Rep. 173, +! 301-381 (1989) +! (2) H. B. Nersiyan and A. K. Das, Phys. Rev. E 69, +! 046404 (2004) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * T : temperature (SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! * V : dimensionless factor --> V = h_bar omega / E_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Note: We use the eq. (10) of ref. (2): V_C chi = - COEF1 * V_C * (f_1 + i f_2) +! to obtain CHI_ = - COEF1 * (f_1 + i f_2) +! +! Then, the exact CHI is obtained from ref. (1): +! CHI = COEF2 * CHI_ +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE MATERIAL_PROP, ONLY : DMN + USE UNITS, ONLY : UNIT +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,EIGHT,HALF + USE COMPLEX_NUMBERS, ONLY : ONEC,IC + USE PI_ETC, ONLY : PI,PI_INV + USE CONSTANTS_P1, ONLY : BOHR,H_BAR + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE COULOMB_K, ONLY : COULOMB_FF +! + USE UNITS, ONLY : UNIT +! + USE DF_VALUES, ONLY : MEM_TYPE,ALPHA,BETA + USE LF_VALUES, ONLY : GQ_TYPE +! + USE DFUNC_STATIC, ONLY : RPA1_EPS_S_LG + USE LOCAL_FIELD_STATIC + USE DAMPING_SI + USE DAMPING_VALUES, ONLY : PCT + USE MEMORY_FUNCTIONS_F +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,T,RS + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: EPS0R,EPS0I + REAL (WP) :: GQ,CHI_0,CHI_Q + REAL (WP) :: NUM,DEN + REAL (WP) :: COEF1,COEF2 + REAL (WP) :: Q_SI,VC,CHI2 + REAL (WP) :: U,V,X2,X3 + REAL (WP) :: MEM + REAL (WP) :: GAMMA,GAMMA2 + REAL (WP) :: UP,UM,UP2,UM2 + REAL (WP) :: Y1P,Y2P,Y1M,Y2M + REAL (WP) :: F1,F2 + REAL (WP) :: REPSM1,IEPSM1 + REAL (WP) :: REPS00 +! + REAL (WP) :: LOG,ATAN,REAL,AIMAG +! + COMPLEX (WP) :: NUMI,DENI + COMPLEX (WP) :: CHI,EPS + COMPLEX (WP) :: MEMO +! + X2 = X * X ! + X3 = X2 * X ! +! + U = X * Z ! omega / (q * v_F) + V = FOUR * U * X ! h_bar omega / E_F + CHI2 = PI_INV / (KF_SI * BOHR) ! + COEF1 = CHI2 / X2 ! +! +! Computation of the coefficient chi(0) / chi_0(0) +! +! + Q_SI = TWO * X * KF_SI ! q in SI +! +! Computing the Coulomb potential VC +! + CALL COULOMB_FF(DMN,UNIT,Q_SI,ZERO,VC) ! Coulomb pot. +! +! Computing the static dielectric function and +! the static local field correction +! + CALL RPA1_EPS_S_LG(X,'3D',EPS0R,EPS0I) + CALL LFIELD_STATIC(X,RS,T,GQ_TYPE,GQ) ! +! + CHI_0 = (ONE - EPS0R) / VC ! +! + NUM = CHI_0 ! + DEN = ONE + VC * (GQ - ONE) * CHI_0 ! + CHI_Q = NUM / DEN ! +! + COEF2 = CHI_Q / CHI_0 ! + coef2 = one +! +! Computation of the memory function +! + MEMO = MEMORY_F(V,TAU,TAU2,PCT,ALPHA,BETA,MEM_TYPE) ! + MEM = TWO * PI * REAL(MEMO,KIND=WP) ! +! + GAMMA = H_BAR * MEM / (FOUR * EF_SI) ! + GAMMA2 = GAMMA * GAMMA ! +! + UP = U + X ! U_+ + UM = U - X ! U_- +! + UP2 = UP * UP ! + UM2 = UM * UM ! +! + NUM = X2 * (UP + ONE) * (UP + ONE) + GAMMA2 ! + DEN = X2 * (UP - ONE) * (UP - ONE) + GAMMA2 ! ref. (2) eq. (13) + Y1P = LOG(NUM / DEN) ! Y_1(z,U_+) +! + NUM = X2 * (UM + ONE) * (UM + ONE) + GAMMA2 ! + DEN = X2 * (UM - ONE) * (UM - ONE) + GAMMA2 ! ref. (2) eq. (13) + Y1M = LOG(NUM / DEN) ! Y_1(z,U_-) +! + Y2P = ATAN(X * (UP - ONE) / GAMMA) - & ! ref. (2) eq. (14) + ATAN(X * (UP + ONE) / GAMMA) ! Y_2(z,U_+) + Y2M = ATAN(X * (UM - ONE) / GAMMA) - & ! ref. (2) eq. (14) + ATAN(X * (UM + ONE) / GAMMA) ! Y_2(z,U_-) +! + F1 = HALF + ONE / (16.0E0_WP * X3) * ( &! + ( X2 * (UM2 - ONE) - GAMMA2 &! + ) * Y1M - &! + ( X2 * (UP2 - ONE) - GAMMA2 &! ref. (2) eq. (11) + ) * Y1P + &! + FOUR * GAMMA * X * &! + (UP * Y2P - UM * Y2M) &! + ) ! +! + F2 = ONE / (EIGHT * X3) * ( &! + GAMMA * X * (UM * Y1M - UP * Y1P) + &! + X2 * ((UM2 - ONE) - GAMMA2) * Y2M - &! ref. (2) eq. (12) + X2 * ((UP2 - ONE) - GAMMA2) * Y2P &! + ) ! +! +! Computation of EPS_{RPA}(x,u,Gamma) - 1 +! + REPSM1 = COEF1 * F1 ! ref. (2) eq. (10) + IEPSM1 = COEF1 * F2 ! +! +! Computation of EPS_{RPA}(x,0) - 1 +! + CALL RPA1_EPS_S_LG(X,'3D',EPS0R,EPS0I) +! + REPS00 = EPS0R - ONE ! +! + NUMI = (X * U + IC * GAMMA) * (REPSM1 + IC * IEPSM1) ! + DENI = X * U + IC * GAMMA * (REPSM1 + IC * IEPSM1) / REPS00 ! +! + CHI = - COEF2 * NUMI / DENI ! ref. (1) eq. (2.124) +! + EPS = ONEC / (ONEC + VC * CHI) ! + EPS = ONE + NUMI / DENI ! ref. (1) eq. (9) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE GOTZ_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE HEAP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal Hertel-Appel dynamical +! dielectric function in 3D +! +! References: (1) P. Hertel and J. Appel, Phys. Rev. B 26, 5730-5742 (1982) +! +! Note: for TAU --> infinity, we should recover the RPA values +! +! Remark: In order to simplify the equation, we introduce +! the quantities q_T and omega_T so that +! +! k_B T = h_bar^2 q_T^2 / 2m = h_bar omega_T +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF,FOURTH,TTINY + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,K_B,EPS_0 + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI,SQR_PI + USE MATERIAL_PROP, ONLY : MSOM,EPS_B + USE PLASMON_ENE_SI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE EXT_FUNCTIONS, ONLY : WOFZ + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: U,KBT,QT + REAL (WP) :: A,C + REAL (WP) :: Q_SI,OM_P,OM_Q,OM_T,OME,TOM + REAL (WP) :: XR1,XR2,XI1,BR1,BI1,BR2,BI2 + REAL (WP) :: MASS_E +! + REAL (WP) :: SQRT,REAL,AIMAG +! + LOGICAL :: FLAG +! + COMPLEX (WP) :: BQOT,BQ0I,Z12,Z22 + COMPLEX (WP) :: NUM,DEN,EPS +! + U = X * Z ! omega / (q * v_F) +! + MASS_E = M_E * MSOM ! effective mass + KBT = K_B * T ! +! + Q_SI = TWO * X * KF_SI ! q in SI + QT = SQRT(TWO * MASS_E * KBT) / H_BAR ! +! + OM_P = ENE_P_SI / H_BAR ! omega_p + OM_Q = HALF * H_BAR * Q_SI * Q_SI / MASS_E ! omega_q + OM_T = HALF * H_BAR * QT * QT / MASS_E ! omega_T +! + OME = U * Q_SI * VF_SI ! omega + TOM = TAU * OME ! tau * omega +! + KBT = K_B * T ! +! + C = FOURTH * OM_P * OM_P / (OM_Q * OM_T * SQR_PI) ! see notes +! + XR1 = (U + X) * KF_SI / QT ! \ + XR2 = (U - X) * KF_SI / QT ! > see notes + XI1 = MASS_E / (H_BAR * Q_SI * QT * TAU) ! / +! +! Computing B(q,omega,tau) +! +! Calling Faddeeva function W(z) = exp(-z^2) * [ 1 - erf(-iz) ] +! +! Here, from ref. (1) eq. (28): w(z) = exp(-z^2) - W(z) +! + CALL WOFZ(XR1,XI1,BR1,BI1,FLAG) ! + CALL WOFZ(XR2,XI1,BR2,BI2,FLAG) ! +! + Z12 = (XR1 + IC * XI1) * (XR1 + IC * XI1) ! + Z22 = (XR2 + IC * XI1) * (XR2 + IC * XI1) ! +! +! w(z1) - w(z2) = W(z2) - W(z1) + exp(-z1^2) - exp(-z2^2) +! +! + BQOT = - IC * PI * C * ( BR2 + IC * BI2 - BR1 - IC * BR1 + & ! ref. (1) eq. (27) + EXP(- Z12) - EXP(- Z22) ) ! +! +! Computing B(q,0,inf) +! + XR1 = X * KF_SI / QT + XR2 = - XR1 + XI1 = ZERO +! + CALL WOFZ(XR1,XI1,BR1,BI1,FLAG) ! + CALL WOFZ(XR2,XI1,BR2,BI2,FLAG) ! +! + Z12 = (XR1 + IC * XI1) * (XR1 + IC * XI1) ! z1^2 + Z22 = (XR2 + IC * XI1) * (XR2 + IC * XI1) ! z2^2 +! +! w(z1) - w(z2) = W(z2) - W(z1) + exp(-z1^2) - exp(-z2^2) +! + BQ0I = - IC * PI * C * ( BR2 + IC * BI2 - BR1 - IC * BR1 + & ! ref. (1) eq. (27) + EXP(- Z12) - EXP(- Z22) ) ! +! + NUM = (ONE + IC / TOM) * BQOT ! + DEN = ONE + IC * BQOT / (TOM * BQ0I) ! +! + EPS = ONE + NUM / DEN ! ref. (1) eq. (21) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE HEAP_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE HAFO_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! Hartree-Fock dielectric function +! +! References: (1) V. D. Gorobchenko, V. N. Kohn and E. G. Maksimov, +! in "Modern Problems in Condensed Matter" Vol. 24, +! L. V. Keldysh, D. A. Kirzhnitz and A. A. Maradudin ed. +! pp. 87-219 (North-Holland, 1989) +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Note: in ref. (1), omega is in unit of E_F/h_bar and q in unit of k_F +! +! Therefore: omega/q in ref. (1) is given in SI by 2 * omega / (q * v_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP) :: X,Y,Z,RS,Y2,U + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q0R,Q0I,ALPHA,Z1,Z2 + REAL (WP) :: COEF,LN1,LN2 +! + REAL (WP) :: DLOG,DABS,DREAL,DIMAG +! + COMPLEX (WP) :: EPS +! + ALPHA=ALFA('3D') ! +! + Y=X+X ! Y = q / k_F + Y2=Y*Y ! +! + U=X*Z ! omega / (q * v_F) +! + Z1=X+U ! + Z2=X-U ! + COEF=TWO*PI_INV*ALPHA*RS ! + LN1=DLOG(DABS(ONE+Z1)/(ONE-Z1)) ! + LN2=DLOG(DABS(ONE+Z2)/(ONE-Z2)) ! +! + Q0R=COEF*(ONE + HALF*(ONE-Z1*Z1)*LN1/Y + & ! ref. (1) eq. (3.2) + HALF*(ONE-Z2*Z2)*LN2/Y) ! +! + IF(U < (ONE-X)) THEN ! +! + Q0I=TWO*ALPHA*RS*U/Y2 ! ref. (1) eq. (3.3) +! + ELSE ! +! + IF( (U <= (ONE+U)) .AND. (U >= DABS(ONE-U)) ) THEN ! + Q0I=ALPHA*RS*(ONE - (X-U)**2)/(Y2*Y) ! ref. (1) eq. (3.3) + ELSE ! + Q0I=ZERO ! ref. (1) eq. (3.3) + END IF ! +! + END IF ! +! + EPS=ONE/(ONE-Q0R-IC*Q0I) ! ref. (1) eq. (3.1) +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE HAFO_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE HUCO_EPS_D_LG_3D(X,Z,EPSR,EPSI) +! +! This subroutine computes the Hu-O'Connell dielectric function that +! including damping effect through electron-electron and electron-impurity +! fluctuation, leading to a diffusion coefficient D, for 3D systems +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = hbar omega / E_F +! +! +! Output variables : +! +! * EPSR : real part of the dielectric function at q +! * EPSI : imaginary part of the dielectric function at q +! +! Reference : (1) G. Y. Hu and R. F. O'Connell, Phys. Rev. B 40, 3600-3604 (1989) +! +! +! Author : D. Sébilleau +! +! Last modified : 13 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,EIGHT, & + HALF,FOURTH,EIGHTH + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z + REAL (WP), INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: Q_SI,KTF_SI + REAL (WP) :: K2Q2 + REAL (WP) :: COEF,KOEF + REAL (WP) :: U,B,NUP,NUM + REAL (WP) :: NP2,NM2 + REAL (WP) :: BX,B2X2 + REAL (WP) :: OPNP,OMNP + REAL (WP) :: OPNM,OMNM + REAL (WP) :: OBXP,OBXM + REAL (WP) :: LOGP,LOGM + REAL (WP) :: TOPP,TOMP + REAL (WP) :: TOPM,TOMM +! + REAL (WP) :: LOG,ATAN +! + U = X * Z ! omega / (q * v_F) + Q_SI = TWO * KF_SI * X ! q in SI +! +! Computing the Thomas-Fermi vector +! + CALL THOMAS_FERMI_VECTOR('3D',KTF_SI) ! +! + K2Q2 = KTF_SI * KTF_SI / (Q_SI * Q_SI) ! +! + COEF = HALF * K2Q2 ! coeff. of real part + KOEF = K2Q2 / (EIGHT * X) ! coeff. of imag part +! +! Setting the Hu-O'Connell parameters +! + B = TWO * M_E * DIF / H_BAR ! \ + NUP = X + U ! > ref. (1) eq. (8) + NUM = X - U ! / +! + NP2 = NUP * NUP ! + NM2 = NUM * NUM ! +! + OPNP = ONE + NUP ! + OMNP = ONE - NUP ! + OPNM = ONE + NUM ! + OMNM = ONE - NUM ! +! + BX = B * X ! + B2X2 = BX * BX ! +! + LOGP = LOG( ABS( (OPNP**2 + B2X2) / (OMNP**2 + B2X2) ) ) ! + LOGM = LOG( ABS( (OPNM**2 + B2X2) / (OMNM**2 + B2X2) ) ) ! +! + OBXP = ONE + B2X2 - NP2 ! + OBXM = ONE + B2X2 - NM2 ! +! + TOPP = OPNP / BX ! \ + TOMP = OMNP / BX ! | arguments of + TOPM = OPNM / BX ! | arctan[ ] + TOMM = OMNM / BX ! / +! +! Real part of epsilon +! + EPSR = ONE + COEF * ( ONE + EIGHTH / X * ( & ! + OBXP * LOGP + OBXM * LOGM & ! + ) & ! + - HALF * B * ( & ! ref. (1) es. (7) + NUP * ( ATAN(TOMP) + ATAN(TOPP) ) & ! + + NUM * ( ATAN(TOMM) + ATAN(TOPM) ) & ! + ) & ! + ) ! +! +! Imaginary part of epsilon +! + EPSI= KOEF * ( & ! + OBXM * ( ATAN(TOMM) + ATAN(TOPM) ) & ! + - OBXP * ( ATAN(TOMP) + ATAN(TOPP) ) & ! + + BX * ( & ! ref. (1) es. (9) + NUM * LOGM - NUP * LOGP & ! + ) & ! + ) ! +! + END SUBROUTINE HUCO_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE HYDR_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) +! +! This subroutine computes the longitudinal hydrodynamic dynamical +! dielectric function in 3D +! +! References: (1) R. Esquivel-Sirvent and G. C. Schatz, +! J. Phys. Chem. C 116, 420-424 (2011) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THIRD + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PLASMON_ENE_SI + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,RS,U + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,O_SI + REAL (WP) :: O_PL,GAMMA +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EPS,BETA2,NUM,DEN +! + U = X * Z ! omega / (q * v_F) +! + Q_SI = TWO * X * KF_SI ! q in SI + O_SI = U * Q_SI * VF_SI ! omega in SI + O_PL = ENE_P_SI / H_BAR ! omega_p in SI +! + GAMMA = ONE / TAU ! +! + NUM = 0.20E0_WP * THIRD * O_SI + IC * THIRD * GAMMA ! + DEN = O_SI + IC * GAMMA ! + BETA2 = VF_SI * VF_SI * NUM / DEN ! +! + EPS = ONE - O_PL * O_PL / (O_SI * DEN - BETA2 * Q_SI * Q_SI) ! ref. (1) eq. (6) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE HYDR_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE KLEI_EPS_D_LG_3D(X,Z,EPSR,EPSI) +! +! This subroutine computes Kleinman longitudinal +! dielectric function EPS(q,omega,T) in 3D systems. +! +! References: (1) P. R. Antoniewicz and L. Kleinman, Phys. Rev. B2, +! 2808-2811 (1970) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Warning: there is an inhomogeneity in Kleinman's equation. His Delta (D) +! is an energy shift and should be proportional to an energy and it +! is in fact proportional to a momentum ... +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,EIGHT, & + HALF,THIRD + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI_INV + USE SCREENING_VEC2, ONLY : KLEINMAN_VECTOR +! + IMPLICIT NONE +! + REAL (WP) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: A,B,D,AL,KS_A,KS_B,Q_SI,Q2,OM + REAL (WP) :: NUM,DEN,DEN_A,DEN_B,KK,K2,K3,AA + REAL (WP) :: A1,A2,A3 + REAL (WP) :: CHI1P,CHI1M,CHI2P,CHI2M +! + REAL (WP) :: EXP,LOG,ABS +! + COMPLEX (WP) :: EPS,CHIP,CHIM,G1,G2,G3 +! + COMPLEX (WP) :: CONJG +! + Q_SI = TWO * X * KF_SI ! q in SI + OM = Z * H_BAR * Q_SI * Q_SI * HALF / M_E ! omega in SI +! + Q2 = Q_SI * Q_SI ! + K2 = KF_SI * KF_SI ! + K3 = K2 * KF_SI ! +! + AL = HALF * (ONE + EXP(-X)) ! ref. 1 eq. (21) +! +! Computation of the screening vectors KS +! + CALL KLEINMAN_VECTOR('3D',X,1,KS_A) ! for coef A + CALL KLEINMAN_VECTOR('3D',X,2,KS_B) ! for coef B +! + NUM = Q2 ! + DEN_A = TWO * AL * KF_SI * KF_SI + KS_A * KS_A ! + DEN_B = TWO * AL * KF_SI * KF_SI + KS_B * KS_B + Q2 ! + A = HALF * NUM / DEN_A ! ref. 1 eq. (2) + B = HALF * NUM / DEN_B ! ref. 1 eq. (3) + D = EIGHT * THIRD * PI_INV * K3 * (A - B) / Q2 ! ref. 1 eq. (7) +! + KK = TWO / (Q2 * Q_SI) ! +! +! Chi(q,+omega) +! + AA = Q2 + D + OM ! + NUM = AA + TWO * Q_SI * KF_SI ! + DEN = AA - TWO * Q_SI * KF_SI ! +! + CHI1P = KK * PI_INV * ( (K2 - (HALF * AA / Q_SI)**2) * & ! real part + LOG(ABS(NUM / DEN)) + & ! + KF_SI * AA / Q_SI & ! ref. 1 eq. (5) + ) ! +! + A1 = - (Q2 + TWO * Q_SI * KF_SI) ! + A2 = OM + D ! + A3 = TWO * Q_SI * KF_SI * Q2 ! +! + IF( (A1 < A2) .AND. (A2 < A3) ) THEN ! + CHI2P = KK * (K2 - (HALF * AA / Q_SI)**2) ! imaginary part + ELSE ! + CHI2P = ZERO ! ref. 1 eq. (5) + END IF ! +! +! Chi(q,-omega) +! + AA = Q2 + D - OM ! + NUM = AA + TWO * Q_SI * KF_SI ! + DEN = AA - TWO * Q_SI * KF_SI ! +! + CHI1M = KK * PI_INV *( (K2 - (HALF * AA / Q_SI)**2) * & ! real part + LOG(ABS(NUM / DEN)) + & ! + KF_SI * AA / Q_SI & ! ref. 1 eq. (5) + ) ! +! + A2 = - OM + D ! +! + IF( (A1 < A2) .AND. (A2 < A3) ) THEN ! + CHI2M = KK * (K2 - (HALF * AA / Q_SI)**2) ! imaginary part + ELSE ! + CHI2M = ZERO ! + END IF ! +! + CHIP = CHI1P - IC * CHI2P ! ref. 1 eq. (4) + CHIM = CHI1M - IC * CHI2M ! ref. 1 eq. (4) +! +! Computing the dielectric function +! + G1 = CHIP + CONJG(CHIM) ! + G2 = CHIP * CHIP + CONJG(CHIM) * CONJG(CHIM) ! + G3 = CHIP * CONJG(CHIM) ! +! + EPS = ONE + HALF * G1 / ( ONE - HALF * & ! + (A * G2 + TWO * B * G3) / G1 & ! ref. 1 eq. (1) + ) ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE KLEI_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE KLKD_EPS_D_LG_3D(X,Z,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal Klimontovich-Kraeft +! dynamical dielectric function in 3D +! +! This result is valid in the highly degenerate case +! +! References: (1) W.-D. Kraeft, D. Kremp, W. Ebeling and G. Röpke, +! "Quantum Statistics of Charged Particle Systems", +! (Plenum Press, 1986) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * T : temperature (SI) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Note: We rewrite m*omega/q +/- h_bar*q/2 as +! +! m*v_F * ( U +/- X) +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : EF_SI,KF_SI,VF_SI + USE PI_ETC, ONLY : PI,PI2 + USE COULOMB_K, ONLY : COULOMB_FF +! + USE UNITS, ONLY : UNIT +! + IMPLICIT NONE +! + REAL (WP) :: X,X2,Z,T,U,U2 + REAL (WP) :: EPSR,EPSI + REAL (WP) :: BETA,VC,Q_SI,TF,O_SI + REAL (WP) :: CR,CI,C2,PIR,PII + REAL (WP) :: A,BP,BM +! + REAL (WP) :: DLOG,DEXP +! + X2=X*X ! +! + U=X*Z ! omega / (q * v_F) + U2=U*U ! +! + BETA=ONE/(K_B*T) ! +! + Q_SI=TWO*X*KF_SI ! q in SI + O_SI=U*Q_SI*VF_SI ! omega in SI +! + CALL COULOMB_FF('3D',UNIT,Q_SI,ZERO,VC) ! Coulomb potential +! + TF=EF_SI/K_B ! Fermi temperature +! + CR=M_E*KF_SI/(FOUR*PI2*H_BAR*H_BAR*X) ! + CI=M_E*M_E/(TWO*PI*H_BAR*H_BAR*H_BAR*H_BAR*BETA*Q_SI) ! + C2=CI*O_SI*BETA ! +! + A=PI2 * (T/TF) /(BETA*12.0E0_WP) ! + BP=EF_SI*(U+X)*(U+X) - EF_SI ! + BM=EF_SI*(U-X)*(U-X) - EF_SI ! +! + PIR=CR * ( TWO*X - HALF*(ONE-X2-U2)* &! + DLOG(((ONE-X)**2 - U2)/((ONE+X)**2 - U2)) +&! + X*U*DLOG(((ONE-X)**2 - X2)/((ONE+X)**2 - X2)) +&! + HALF*PI* (T/TF)**2 * ( &! ref. (1) eq. (4.91) + HALF*DLOG(((ONE-X)**2 - U2)/((ONE+X)**2 - U2)) +&! + (ONE+X)/((ONE+X)**2 - U2) - &! + (ONE-X)/((ONE-X)**2 - U2) &! + ) &! + ) ! +! + IF(U > (ONE+X)) THEN ! + PII=CI*DEXP(-BETA*A)*( DEXP(-BETA*BP) - DEXP(-BETA*BM) ) ! ref. (1) eq. (4.92) + ELSE IF(U < (ONE-X)) THEN ! + PII=CI*DEXP(BETA*A)*( DEXP(BETA*BP) - DEXP(-BETA*BM) ) - C2 ! ref. (1) eq. (4.92) + ELSE ! + PII=CI*BETA*(BM+A) + CI* ( &! + DEXP(-BETA*(A+BP)) - DEXP(BETA*(A+BM)) &! ref. (1) eq. (4.92) + ) ! + END IF ! +! + EPSR=ONE-VC*PIR ! + EPSI=PII ! +! + END SUBROUTINE KLKD_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE KLKN_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal Klimontovich-Kraeft +! dynamical dielectric function in 3D +! +! This result is valid in the nondegenerate case +! +! References: (1) W.-D. Kraeft, D. Kremp, W. Ebeling and G. Röpke, +! "Quantum Statistics of Charged Particle Systems", +! (Plenum Press, 1986) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Note: we rewrite m*omega/q +/- h_bar*q/2 as +! +! m*v_F * ( U +/- X) +! +! +! Author : D. Sébilleau +! +! Last modified : 19 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO + USE COMPLEX_NUMBERS, ONLY : ONEC + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE EXT_FUNCTIONS, ONLY : CONHYP + USE COULOMB_K, ONLY : COULOMB_FF +! + USE UNITS, ONLY : UNIT +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,T,U + REAL (WP) :: EPSR,EPSI + REAL (WP) :: BETA,COEF,GAMMA,VC,Q_SI + REAL (WP) :: AP,AM,CR,CI + REAL (WP) :: ZZRP,ZZRM + REAL (WP) :: RS,N0 +! + REAL (WP) :: DSQRT,DREAL +! + COMPLEX (WP) :: A,B,ZZCP,ZZCM + COMPLEX (WP) :: PIR,PII +! + COMPLEX (WP) :: DCMPLX +! + U=X*Z ! omega / (q * v_F) +! + BETA=ONE/(K_B*T) ! + COEF=TWO*M_E*K_B*T ! + GAMMA=TWO*PI*H_BAR/DSQRT(PI*COEF) ! +! + Q_SI=TWO*X*KF_SI ! q in SI +! + N0=RS_TO_N0('3D',RS) ! +! + CALL COULOMB_FF('3D',UNIT,Q_SI,ZERO,VC) ! Coulomb potential +! + AP=M_E*VF_SI*( U + X ) ! + AM=M_E*VF_SI*( U - X ) ! +! + CR=N0*BETA/(H_BAR*Q_SI) ! coef. of real part + CI=N0*M_E*GAMMA/(TWO*H_BAR*H_BAR*Q_SI) ! coef. of imaginary +! + A=ONEC ! parameters of + B=(1.5E0_WP,0.0E0_WP) ! 1F1(a,b;z) +! + ZZRP=-AP*AP/COEF ! + ZZRM=-AM*AM/COEF ! arguments of + ZZCP=DCMPLX(ZZRP) ! 1F1(a,b;z) + ZZCM=DCMPLX(ZZRM) ! +! + PIR=CR*( AP*CONHYP(A,B,ZZCP,0,0) - & ! ref. (1) eq. (4.71) + AM*CONHYP(A,B,ZZCM,0,0) & ! + ) ! + PII=CI*( CDEXP(ZZCP) - CDEXP(ZZCM) ) ! ref. (1) eq. (4.72) +! + EPSR=ONE-VC*DREAL(PIR) ! + EPSI=DREAL(PII) ! +! + END SUBROUTINE KLKN_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE LAND_EPS_D_LG_3D(X,Z,XC,U0,W,D,RS,LANDAU,EPSR,EPSI) +! +! This subroutine computes the dielectric function EPS(q,omega) +! in 3D systems in terms of Landau's parameters. +! +! References: (1) E. Lipparini, "Modern Many-Particle Physics - Atomic Gases, +! Quantum Dots and Quantum Fluids", World Scientific (2003) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * XC : dimensionless cut-off --> XC = q_c / (2 * k_F) +! * U0 / A : bare interaction constant / hard sphere radius (in SI) +! * W : half bandwidth for bare particle +! * D : filling (dopant concentration) +! * RS : dimensionless factor +! * LANDAU : model chosen for the calculation of the parameters +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE, & + HALF,THIRD + USE COMPLEX_NUMBERS, ONLY : ONEC,IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,EPS_0 + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI,PI2 + USE LANDAU_PARAM +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: LANDAU +! + REAL (WP) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,XC,U0,W,D,RS + REAL (WP) :: U,NU0,TH,V_C + REAL (WP) :: F0S,F0A,F1S,F1A,F2S,F2A +! + REAL (WP) :: DLOG,DABS,DREAL,DIMAG +! + COMPLEX (WP) :: EPS,CHIS,OM00,OM20,OM22 + COMPLEX (WP) :: NUM,DEN,NU1,DE1 +! + COMPLEX (WP) :: DCMPLX +! + U=X*Z ! omega / (q * v_F) + Q_SI=TWO*X*KF_SI ! q in SI + NU0=M_E*KF_SI/(PI2*H_BAR*H_BAR) ! DoS at Fermi level +! +! Computing the Coulomb potential +! + V_C=E*E/(EPS_0*Q_SI*Q_SI) ! +! +! Computing Landau's parameters +! + CALL LANDAU_PARAMETERS_3D(X,XC,U0,W,D,RS,LANDAU, & ! + F0S,F0A,F1S,F1A,F2S,F2A) ! +! +! Computing the Omega_{l,l} parameters +! + IF(ONE.GT.U) THEN ! + TH=HALF*PI*U ! + ELSE ! + TH=ZERO ! + ENDIF ! + OM00=ONE + HALF*U*DLOG(DABS((U-ONE)/(U+ONE))) + IC*TH ! + OM20=HALF + HALF*(THREE*U*U-ONE)*OM00 ! ref. 1 eq. (8.14) + OM22=0.20E0_WP+HALF*(THREE*U*U-ONE)*OM20 ! +! +! Computation of the density-density response function +! + NU1=TWO*(ONE+THIRD*F1S)*(ONE+0.2E0_WP*F2S)*OM20 ! + DE1=THREE*(OM00+F2S*(OM22*OM00-OM20*OM20)) ! + NUM=DCMPLX(THIRD*NU0*(ONE+THIRD*F1S)) ! + DEN=U*U - THIRD*(ONE+THIRD*F1S)*(ONE+F0S) - NU1/DE1 ! + CHIS=NUM/DEN ! ref. 1 eq. (8.23) +! + EPS=ONE/(ONE+V_C*CHIS) ! +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE LAND_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE LVL1_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) +! +! This subroutine computes the longitudinal linearized Vlasov dynamical +! dielectric function in 3D for a weakly coupled plasma +! +! References: (1) S. Ichimaru, Rev. Mod. Phys. 54, 1017-1059 (1982) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * T : temperature (SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE CONSTANTS_P1, ONLY : M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE EXT_FUNCTIONS, ONLY : W +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,T,RS,U + REAL (WP) :: EPSR,EPSI + REAL (WP) :: ZZ,Q_SI + REAL (WP) :: KD_SI +! + REAL (WP) :: DSQRT,DREAL,DIMAG +! + U=X*Z ! omega / (q * v_F) + Q_SI=TWO*X*KF_SI ! q +! +! Computation of the Debye screening vector +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + ZZ=U*VF_SI/DSQRT(K_B*T/M_E) ! argument of PDF W(zz) +! + EPSR=ONE + (KD_SI/Q_SI)**2 * DREAL(W(ZZ)) ! ref. (1) eq. (2.112) + EPSI=(KD_SI/Q_SI)**2 * DIMAG(W(ZZ)) ! +! + END SUBROUTINE LVL1_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE LVL2_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) +! +! This subroutine computes the longitudinal linearized Vlasov dynamical +! dielectric function in 3D for a strongly coupled plasma +! +! References: (1) S. Ichimaru, Rev. Mod. Phys. 54, 1017-1059 (1982) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * T : temperature (SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE CONSTANTS_P1, ONLY : M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE LF_VALUES, ONLY : GQ_TYPE + USE SF_VALUES, ONLY : SQ_TYPE + USE EXT_FUNCTIONS, ONLY : W + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE LOCAL_FIELD_STATIC +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,T,RS,U + REAL (WP) :: EPSR,EPSI + REAL (WP) :: ZZ,Q_SI,FR + REAL (WP) :: GQ,KD_SI +! + REAL (WP) :: DSQRT,DREAL,DIMAG +! + COMPLEX (WP) :: NUM,DEN +! + U=X*Z ! omega / (q * v_F) + Q_SI=TWO*X*KF_SI ! q +! +! Computation of the Debye screening vector +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + ZZ=U*VF_SI/DSQRT(K_B*T/M_E) ! argument of PDF W(zz) + FR=(KD_SI/Q_SI)**2 ! (k_D/q)^2 +! +! Computing the static local-field correction +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ) ! +! + NUM=FR*W(ZZ) !ref. (1) eq. (2.114) + DEN=ONE-NUM*GQ ! +! + EPSR=ONE + DREAL(NUM/DEN) ! + EPSI=DIMAG(NUM/DEN) ! +! + END SUBROUTINE LVL2_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE MEM2_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the dielectric function following +! the Nevanlinna formula of the classical Hamburger theory of moments +! +! It makes use of the moments: +! +! Cn(q) = 1/pi int_{-inf}^{+inf} omega^n L(q,omega) d omega +! +! with the loss function given by +! +! L(q,omega) = -1/omega * Im[ 1/epsilon(q,omega) ] +! +! +! ---> This is the two-moment version +! +! +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 76, 026403 (2007) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Intermediate parameters: +! +! * C0 : 0-th order moment of the loss function +! * C2 : 2-th order moment of the loss function +! +! Output parameters: +! +! * EPS : value of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOUR + USE COMPLEX_NUMBERS, ONLY : ONEC,IC + USE PI_ETC, ONLY : PI + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE LOSS_MOMENTS + USE DF_VALUES, ONLY : MEM_TYPE,ALPHA,BETA + USE MEMORY_FUNCTIONS_F + USE DAMPING_SI + USE DAMPING_VALUES, ONLY : PCT +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: Q_SI,U,V + REAL (WP) :: OM,OM2,OMP + REAL (WP) :: C0,C2,C4 + REAL (WP) :: OM12 +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EEE,EPS + COMPLEX (WP) :: NUM,DEN + COMPLEX (WP) :: MEMO,MEM +! + Q_SI = TWO * X * KF_SI ! q in SI + U = X * Z ! omega / (q * v_F) + V = FOUR * U * X ! h_bar omega / E_F + OM = U * Q_SI * VF_SI ! omega in SI + OM2 = OM * OM ! +! +! Computing the moments of the loss function +! + CALL LOSS_MOMENTS_AN(X,C0,C2,C4) +! + OM12 = C2 / C0 ! +! +! Choice of the memory function MEM +! + MEMO = MEMORY_F(V,TAU,TAU2,PCT,ALPHA,BETA,MEM_TYPE) ! + MEM = TWO * PI * IC * MEMO ! +! +! Nevanlinna's formula +! + NUM = OM12 ! + DEN = OM2 - OM12 + OM * MEM ! +! + EEE = ONEC + NUM / DEN ! +! + EPS = ONEC / EEE ! ref. (1) eq. (5) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE MEM2_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE MEM3_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the dielectric function following +! the Nevanlinna formula of the classical Hamburger theory of moments +! +! It makes use of the moments: +! +! Cn(q) = 1/pi int_{-inf}^{+inf} omega^n L(q,omega) d omega +! +! with the loss function given by +! +! L(q,omega) = -1/omega * Im[ 1/epsilon(q,omega) ] +! +! +! ---> This is the three-moment version +! +! +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 76, 026403 (2007) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Intermediate parameters: +! +! * C0 : 0-th order moment of the loss function +! * C2 : 2-th order moment of the loss function +! * C4 : 4-th order moment of the loss function +! +! Output parameters: +! +! * EPS : value of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE DF_VALUES, ONLY : MEM_TYPE,ALPHA,BETA +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR + USE COMPLEX_NUMBERS, ONLY : ZEROC,IC + USE PI_ETC, ONLY : PI + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PLASMON_ENE_SI + USE LOSS_MOMENTS + USE DF_VALUES, ONLY : MEM_TYPE,ALPHA,BETA + USE MEMORY_FUNCTIONS_F + USE DAMPING_SI + USE DAMPING_VALUES, ONLY : PCT +! + IMPLICIT NONE +! + INTEGER :: EXPN,EXPD +! + INTEGER :: EXPONENT +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: Q_SI,U,V + REAL (WP) :: OM,OMP + REAL (WP) :: C0,C2,C4 + REAL (WP) :: OM12,OM22 + REAL (WP) :: REN,RED,IMN,IMD +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: OMB,OM2 + COMPLEX (WP) :: EPS + COMPLEX (WP) :: NUM,DEN + COMPLEX (WP) :: MEMO,MEM +! + Q_SI = TWO * X * KF_SI ! q in SI + U = X * Z ! omega / (q * v_F) + V = FOUR * U * X ! h_bar omega / E_F + OM = U * Q_SI * VF_SI ! omega in SI + OMB = OM + IC / TAU ! + OM2 = OMB * OMB ! + OMP = ENE_P_SI / H_BAR ! omega_p +! +! Computing the moments of the loss function +! + CALL LOSS_MOMENTS_AN(X,C0,C2,C4) +! + OM12 = C2 / C0 ! + OM22 = C4 / C2 ! +! +! Choice of the memory function MEM +! + MEMO = MEMORY_F(V,TAU,TAU2,PCT,ALPHA,BETA,MEM_TYPE) ! + MEM = TWO * PI * IC * MEMO ! +! +! Memory function formula +! + NUM = OMP * OMP * (OMB + MEM) ! + DEN = OMB * (OM2 - OM22) + MEM * (OM2 - OM12) ! +! +! Real and imaginary part of NUM and DEN +! + REN = REAL(NUM,KIND=WP) ! + RED = REAL(DEN,KIND=WP) ! + IMN = AIMAG(NUM) ! + IMD = AIMAG(DEN) ! +! +! Checking the real/imaginary parts when infinitesimal +! +! + EXPN = EXPONENT(IMN) ! + EXPD = EXPONENT(IMD) ! +! + IF(EXPN < -100) THEN ! + NUM = REN + ZEROC ! + END IF ! + IF(EXPD < -100) THEN ! + DEN = RED + ZEROC ! + END IF ! +! +! EPS = DEN / (NUM + DEN) +! + EPS = DEN / (NUM + DEN) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE MEM3_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE MER1_EPS_D_LG_3D(X,Z,EPSR,EPSI) +! +! This subroutine computes the longitudinal Mermin dynamical +! dielectric function in 3D +! +! References: (1) H. B. Nersiyan and A. K. Das, Phys. Rev. E 69, 046404 (2004) +! (2) H. B. Nersiyan , A. K. Das, and H. H. Matevosyan, +! Phys. Rev. E 66, 046415 (2002) +! +! Note: for TAU --> infinity, we recover the RPA values +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! * TAU : relaxation time (used for damping) in SI +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Note: in order to be more general, we use EPS_B (background +! dielectric constant) instead of 1 (vacuum case) +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Aug 2021 +! +! + USE MATERIAL_PROP, ONLY : EPS_B +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,EIGHT,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : BOHR,H_BAR + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI_INV +! + USE DFUNC_STATIC, ONLY : RPA1_EPS_S_LG + USE DAMPING_SI, ONLY : TAU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: U,X2,X3 + REAL (WP) :: CHI2,COEF + REAL (WP) :: REPSM1,IEPSM1 + REAL (WP) :: REPS00 + REAL (WP) :: EPS0R,EPS0I + REAL (WP) :: GAMMA,GAMMA2 + REAL (WP) :: UP,UM,UP2,UM2 + REAL (WP) :: NUM,DEN + REAL (WP) :: Y1P,Y2P,Y1M,Y2M + REAL (WP) :: F1,F2 +! + REAL (WP) :: LOG,ATAN,REAL,AIMAG +! + COMPLEX (WP) :: NUMI,DENI,EPS +! + X2 = X * X ! + X3 = X2 * X ! +! + U = X * Z ! omega / (q * v_F) + CHI2 = PI_INV / (KF_SI * BOHR) ! + GAMMA = H_BAR / (FOUR * EF_SI * TAU) ! + GAMMA2 = GAMMA * GAMMA ! +! + COEF = CHI2 / X2 ! +! + UP = U + X ! U_+ + UM = U - X ! U_- +! + UP2 = UP * UP ! + UM2 = UM * UM ! +! + NUM = X2 * (UP + ONE) * (UP + ONE) + GAMMA2 ! + DEN = X2 * (UP - ONE) * (UP - ONE) + GAMMA2 ! ref. (1) eq. (13) + Y1P = LOG(NUM / DEN) ! Y_1(z,U_+) +! + NUM = X2 * (UM + ONE) * (UM + ONE) + GAMMA2 ! + DEN = X2 * (UM - ONE) * (UM - ONE) + GAMMA2 ! ref. (1) eq. (13) + Y1M = LOG(NUM / DEN) ! Y_1(z,U_-) +! + Y2P = ATAN(X * (UP - ONE) / GAMMA) - & ! ref. (1) eq. (14) + ATAN(X * (UP + ONE) / GAMMA) ! Y_2(z,U_+) + Y2M = ATAN(X * (UM - ONE) / GAMMA) - & ! ref. (1) eq. (14) + ATAN(X * (UM + ONE) / GAMMA) ! Y_2(z,U_-) +! + F1 = HALF + ONE / (16.0E0_WP * X3) * ( &! + ( X2 * (UM2 - ONE) - GAMMA2 &! + ) * Y1M - &! + ( X2 * (UP2 - ONE) - GAMMA2 &! ref. (1) eq. (11) + ) * Y1P + &! + FOUR * GAMMA * X * &! + (UP * Y2P - UM * Y2M) &! + ) ! +! + F2 = ONE / (EIGHT * X3) * ( &! + GAMMA * X * (UM * Y1M - UP * Y1P) + &! + X2 * ((UM2 - ONE) - GAMMA2) * Y2M - &! ref. (1) eq. (12) + X2 * ((UP2 - ONE) - GAMMA2) * Y2P &! + ) ! +! +! Computation of EPS_{RPA}(x,u,Gamma) - 1 +! + REPSM1 = COEF * F1 ! ref. (1) eq. (10) + IEPSM1 = COEF * F2 ! +! +! Computation of EPS_{RPA}(x,0) - EPS_B +! + CALL RPA1_EPS_S_LG(X,'3D',EPS0R,EPS0I) ! +! + REPS00 = EPS0R - EPS_B ! +! + NUMI = (X * U + IC * GAMMA) * (REPSM1 + IC * IEPSM1) ! + DENI = X * U + IC * GAMMA * (REPSM1 + IC * IEPSM1) / REPS00 ! +! + EPS = EPS_B + NUMI / DENI ! ref. (1) eq. (9) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE MER1_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE MER2_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal Lindhard-Mermin dynamical +! dielectric function in 3D +! +! References: (1) P.-O. Chapuis et al, Phys. Rev. B 77, 035441 (2008) +! +! Note: for TAU --> infinity, we should recover the RPA values +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * TAU : relaxation time (used for damping) in SI +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Aug 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,EIGHT, & + HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE MATERIAL_PROP, ONLY : EPS_B + USE PLASMON_ENE_SI + USE DAMPING_SI, ONLY : TAU +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,U,RS,T + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,O_SI +! + REAL (WP) :: ABS,REAL,AIMAG +! + COMPLEX (WP) :: UU,FL_U,FL_0 + COMPLEX (WP) :: ZPU,ZMU + COMPLEX (WP) :: OB,COEF + COMPLEX (WP) :: NUM,DEN,EPS +! + U = X * Z ! omega / (q * v_F) + Q_SI = TWO * X * KF_SI ! q in SI + O_SI = U * Q_SI * VF_SI ! omega in SI + OB = O_SI + IC / TAU ! +! + COEF = THREE * ENE_P_SI * ENE_P_SI / (H_BAR * H_BAR * OB) ! +! + UU = OB / (Q_SI * VF_SI) ! u + ZPU = X + UU ! z + u + ZMU = X - UU ! z - u +! + FL_0 = HALF + (ONE - X * X) * LOG( ABS((X + ONE) / & ! + (X - ONE)) & ! ref (1) eq. (13) + ) / (FOUR * X) ! + FL_U = HALF + (ONE - ZMU * ZMU) * LOG( (ZMU + ONE) / & ! + (ZMU - ONE) & ! + ) / (EIGHT * X) + & ! ref (1) eq. (11) + (ONE - ZPU * ZPU) * LOG( (ZPU + ONE) / & ! + (ZPU - ONE) & ! + ) / (EIGHT * X) ! +! + NUM = UU * UU * FL_U + DEN = O_SI + IC * FL_U / (TAU * FL_0) ! + EPS = EPS_B + COEF * NUM / DEN ! +! + EPSR = REAL(EPS,KIND=WP) ! ref (1) eq. (9) + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE MER2_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE MERP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal Mermin dynamical +! dielectric function in 3D, with local field corrections +! +! References: (1) H. B. Nersiyan and A. K. Das, Phys. Rev. E 69, 046404 (2004) +! +! Note: for TAU --> infinity, we recover the RPA values +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * TAU : relaxation time (used for damping) in SI +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! --> This version uses RPA + LFC instead of RPA +! +! +! Note: in order to be more general, we use EPS_B (background +! dielectric constant) instead of 1 (vacuum case) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Aug 2021 +! +! + USE MATERIAL_PROP, ONLY : EPS_B +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,EIGHT,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : BOHR,H_BAR + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI_INV +! + USE LF_VALUES, ONLY : GQ_TYPE +! + USE DFUNC_STATIC, ONLY : RPA1_EPS_S_LG + USE LOCAL_FIELD_STATIC + USE DAMPING_SI, ONLY : TAU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: EPSR,EPSI + REAL (WP) :: U,X2,X3 + REAL (WP) :: CHI2,COEF + REAL (WP) :: REPSM1,IEPSM1 + REAL (WP) :: REPS00 + REAL (WP) :: EPS0R,EPS0I + REAL (WP) :: GAMMA,GAMMA2 + REAL (WP) :: UP,UM,UP2,UM2 + REAL (WP) :: NUM,DEN + REAL (WP) :: Y1P,Y2P,Y1M,Y2M + REAL (WP) :: F1,F2 + REAL (WP) :: GQ +! + REAL (WP) :: LOG,ATAN,REAL,AIMAG +! + COMPLEX (WP) :: ERL,NUML,DENL,NUMI,DENI,EPS +! + X2 = X * X ! + X3 = X2 * X ! + +! + U = X * Z ! omega / (q * v_F) + CHI2 = PI_INV / (KF_SI * BOHR) ! + GAMMA = H_BAR / (FOUR * EF_SI * TAU) ! + GAMMA2 = GAMMA * GAMMA ! +! + COEF = CHI2 / X2 ! +! + UP = U + X ! U_+ + UM = U - X ! U_- +! +! Computing the static local field correction GQ +! + CALL LFIELD_STATIC(X,RS,T,GQ_TYPE,GQ) ! +! +! Computation of EPS_{RPA+LFC}(x,0) - EPS_B +! + CALL RPA1_EPS_S_LG(X,'3D',EPS0R,EPS0I) ! EPS_{RPA}(x,0) + REPS00 = (EPS0R - EPS_B) / (ONE - GQ * (EPS0R - ONE)) ! EPS_{RPA+LFC}(x,0) - EPS_B +! +! Computation of F1 and F2 +! + UP2 = UP * UP ! + UM2 = UM * UM ! +! + NUM = X2 * (UP + ONE) * (UP + ONE) + GAMMA2 ! + DEN = X2 * (UP - ONE) * (UP - ONE) + GAMMA2 ! ref. (1) eq. (13) + Y1P = LOG(NUM / DEN) ! Y_1(z,U_+) +! + NUM = X2 * (UM + ONE) * (UM + ONE) + GAMMA2 ! + DEN = X2 * (UM - ONE) * (UM - ONE) + GAMMA2 ! ref. (1) eq. (13) + Y1M = LOG(NUM / DEN) ! Y_1(z,U_-) +! + Y2P = ATAN(X * (UP - ONE) / GAMMA) - & ! ref. (1) eq. (14) + ATAN(X * (UP + ONE) / GAMMA) ! Y_2(z,U_+) + Y2M = ATAN(X * (UM - ONE) / GAMMA) - & ! ref. (1) eq. (14) + ATAN(X * (UM + ONE) / GAMMA) ! Y_2(z,U_-) +! + F1 = HALF + ONE / (16.0E0_WP * X3) * ( &! + ( X2 * (UM2 - ONE) - GAMMA2 &! + ) * Y1M - &! + ( X2 * (UP2 - ONE) - GAMMA2 &! ref. (1) eq. (11) + ) * Y1P + &! + FOUR * GAMMA * X * &! + (UP * Y2P - UM * Y2M) &! + ) ! +! + F2 = ONE / (EIGHT * X3) * ( &! + GAMMA * X * (UM * Y1M - UP * Y1P) + &! + X2 * ((UM2 - ONE) - GAMMA2) * Y2M - &! ref. (1) eq. (12) + X2 * ((UP2 - ONE) - GAMMA2) * Y2P &! + ) ! +! + REPSM1 = COEF * F1 ! ref. (1) eq. (10) + IEPSM1 = COEF * F2 ! +! +! Computation of EPS_{RPA+LFC}(x,u,Gamma) - 1 = ERL +! + NUML = (REPSM1 + IC * IEPSM1) ! + DENL = ONE - GQ * NUML ! + ERL = NUML / DENL ! +! + NUMI = (X * U + IC * GAMMA) * ERL ! + DENI = X * U + IC * GAMMA * ERL / REPS00 ! +! + EPS = EPS_B + NUMI / DENI ! ref. (1) eq. (9) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE MERP_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE MSAP_EPS_D_LG_3D(X,Y,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! mean spherical approximation dielectric function +! +! References: (1) N. Iwamoto, E. Krotscheck and D. Pines, +! Phys. Rev. B 29, 3936-3951 (1984) +! (2) B. Tanatar and N. Mutulay, Eur. Phys. J. B 1, +! 409-417 (1998) +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Y : dimensionless factor --> Y = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,SIX + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE STRUCTURE_FACTOR_STATIC, ONLY : HFA_SF +! + IMPLICIT NONE +! + REAL (WP) :: X,Y + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,A0Q,S0 +! + Q_SI=TWO*KF_SI ! q in SI + A0Q=BOHR*Q_SI ! a_0 * q (dimensionless) + S0=HFA_SF(X) ! HF structure factor +! + EPSR=ONE - ( ONE/(SIX*PI) * ONE/(X*X*X) * ONE/A0Q * & ! + ONE/(Y*Y - ONE/(S0*S0)) & ! + ) ! + EPSI=ZERO ! +! + END SUBROUTINE MSAP_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE NEV2_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the dielectric function following +! the Nevanlinna formula of the classical Hamburger theory of moments +! +! It makes use of the moments: +! +! Cn(q) = 1/pi int_{-inf}^{+inf} omega^n L(q,omega) d omega +! +! with the loss function given by +! +! L(q,omega) = -1/omega * Im[ 1/epsilon(q,omega) ] +! +! +! ---> This is the two-moment version +! +! +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 76, 026403 (2007) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Intermediate parameters: +! +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! * SQ_TYPE : static structure factor approximation (3D) +! * PL_TYPE : type of plasma considered +! PL_TYPE = 'OCP' --> one-component plasma (~ electron gas) +! PL_TYPE = 'DCP' --> two-component plasma +! * NEV_TYPE : type of Nevalinna function used +! NEV_TYPE = 'NONE' --> no function +! NEV_TYPE = 'STA2' --> static value h(q) +! +! Intermediate parameters: +! +! * C0 : 0-th order moment of the loss function +! * C2 : 2-th order moment of the loss function +! +! Output parameters: +! +! * EPS : value of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE COMPLEX_NUMBERS, ONLY : ONEC + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE LOSS_MOMENTS + USE DF_VALUES, ONLY : NEV_TYPE + USE NEVALINNA_FUNCTIONS + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: Q_SI,U,OM,OM2,OMP + REAL (WP) :: C0,C2,C4 + REAL (WP) :: OM12 +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EEE,EPS + COMPLEX (WP) :: QN,NUM,DEN +! + Q_SI = TWO * X * KF_SI ! q in SI + U = X * Z ! omega / (q * v_F) + OM = U * Q_SI * VF_SI ! omega in SI + OM2 = OM * OM ! +! +! Computing the moments of the loss function +! + CALL LOSS_MOMENTS_AN(X,C0,C2,C4) +! + OM12 = C2 / C0 ! +! +! Choice of the Nevanlinna function Q(X,V) = QN +! + QN = NEVAN2(X,Z,RS,T,TAU,NEV_TYPE) ! +! +! Nevanlinna's formula +! + NUM = OM12 ! + DEN = OM2 - OM12 + OM * QN ! +! + EEE = ONEC + NUM / DEN ! +! + EPS = ONEC / EEE ! ref. (1) eq. (5) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE NEV2_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE NEV3_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the dielectric function following +! the Nevanlinna formula of the classical Hamburger theory of moments +! +! It makes use of the moments: +! +! Cn(q) = 1/pi int_{-inf}^{+inf} omega^n L(q,omega) d omega +! +! with the loss function given by +! +! L(q,omega) = -1/omega * Im[ 1/epsilon(q,omega) ] +! +! +! ---> This is the three-moment version +! +! +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 76, 026403 (2007) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Intermediate parameters: +! +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! * SQ_TYPE : static structure factor approximation (3D) +! * PL_TYPE : type of plasma considered +! PL_TYPE = 'OCP' --> one-component plasma (~ electron gas) +! PL_TYPE = 'DCP' --> two-component plasma +! * NEV_TYPE : type of Nevalinna function used +! NEV_TYPE = 'NONE' --> no function +! NEV_TYPE = 'STA1' --> static value h(q) +! NEV_TYPE = 'STA2' --> static value h(q) +! NEV_TYPE = 'CLCO' --> Classical Coulomb OCP +! NEV_TYPE = 'AMTA' --> +! NEV_TYPE = 'PEEL' --> Perel'-Eliashberg function +! NEV_TYPE = 'PE76' --> +! +! Intermediate parameters: +! +! * C0 : 0-th order moment of the loss function +! * C2 : 2-th order moment of the loss function +! * C4 : 4-th order moment of the loss function +! +! Output parameters: +! +! * EPS : value of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE COMPLEX_NUMBERS, ONLY : ONEC + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PLASMON_ENE_SI + USE LOSS_MOMENTS + USE DF_VALUES, ONLY : NEV_TYPE + USE NEVALINNA_FUNCTIONS + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: Q_SI,U,OM,OM2,OMP + REAL (WP) :: C0,C2,C4 + REAL (WP) :: OM12,OM22 +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EEE,EPS + COMPLEX (WP) :: QN,NUM,DEN +! + Q_SI = TWO * X * KF_SI ! q in SI + U = X * Z ! omega / (q * v_F) + OM = U * Q_SI * VF_SI ! omega in SI + OM2 = OM * OM ! + OMP = ENE_P_SI / H_BAR ! omega_p +! +! Computing the moments of the loss function +! + CALL LOSS_MOMENTS_AN(X,C0,C2,C4) +! + OM12 = C2 / C0 ! + OM22 = C4 / C2 ! +! +! Choice of the Nevanlinna function Q(X,V) = QN +! + QN = NEVAN2(X,Z,RS,T,TAU,NEV_TYPE) ! +! +! Nevanlinna's formula +! + NUM = OMP * OMP * (OM + QN) ! + DEN = OM * (OM2 - OM22) + QN * (OM2 - OM12) ! +! + EEE = ONEC + NUM / DEN ! +! + EPS = ONEC / EEE ! ref. (1) eq. (5) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE NEV3_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE PLPO_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic plasmon pole +! dielectric function for 3D systems +! +! References: (1) L. Hedin, J. Michiels and J. Inglesfield, +! Phys. Rev. B 8, 15565-582 (1998) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Intermediate parameters: +! +! * PL_DISP : type of analytical plasmon dispersion +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOUR + USE COMPLEX_NUMBERS, ONLY : ONEC + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PLASMON_DISP_REAL + USE PLASMON_ENE_SI + USE PLASMON_DISPERSION +! + IMPLICIT NONE +! + REAL (WP),INTENT(IN) :: X,Z,RS,T + REAL (WP),INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: ENE_SI,ENE_QR,ENE_P_Q +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: NUM,DEN + COMPLEX (WP) :: EPS,ENE_Q_SI +! + COMPLEX (WP) :: CMPLX +! + ENE_SI = FOUR * X * X * Z * EF_SI ! +! +! Calculation of the analytical plasmon dispersion +! + CALL PLASMON_DISP_3D(X,RS,T,PL_DISP,ENE_P_Q) ! +! + ENE_Q_SI = CMPLX(ENE_P_Q) ! +! + NUM = ENE_P_SI * ENE_P_SI ! + DEN = ENE_SI * ENE_SI + NUM - ENE_Q_SI * ENE_Q_SI ! +! + EPS = ONEC - NUM / DEN ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE PLPO_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE RDF1_EPS_D_LG_3D(X,Z,EPSR,EPSI) +! +! This subroutine computes random delta-function electron-impurity +! interaction form of the dielectric function for disordered 3D +! conductors +! +! Reference: (1) B. L. Altshuler, A. G. Aronov, D.E. Khmelnitskii and +! A. I. Larkin, in "Quantum Theory of Solids", +! I. M. Lifschits editor, MIR (1982), pp. 129-236 +! (2) D. V. Livanov, M. Yu. Reizer and A. V. Sergeev, +! Sov. Phys. JETP 72, 760-764 (1991) --> for sign +! correction +! +! Note: this version valid for omega*tau << 1 and q*l << 1 +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,E,M_E + USE PI_ETC, ONLY : PI_INV + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE UTILITIES_1, ONLY : D + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z + REAL (WP), INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: U,Q,Q2,OM,DC,K3 + REAL (WP) :: NUM +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EPS,DEN +! + U = X * Z ! omega / q v_F + Q = TWO * X * KF_SI ! q in SI + Q2 = Q * Q ! + OM = U * Q * VF_SI ! omega in SI +! + DC = VF_SI * VF_SI * LFT / D('3D') ! diffusion coefficient +! + K3 = FOUR * PI_INV * KF_SI / BOHR ! +! + NUM = K3 * DC ! ref. 1 eq. (3.4.18) + DEN = DC * Q2 - IC * OM ! +! + EPS = ONE - NUM / DEN ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE RDF1_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE RDF2_EPS_D_LG_3D(X,Z,EPSR,EPSI) +! +! This subroutine computes random delta-function electron-impurity +! interaction form of the dielectric function for disordered 3D +! conductors +! +! Reference: (1) B. L. Altshuler, A. G. Aronov, D.E. Khmelnitskii and +! A. I. Larkin, in "Quantum Theory of Solids", +! I. M. Lifschits editor, MIR (1982), pp. 129-236 +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE UTILITIES_1, ONLY : D,DOS_EF + USE COULOMB_K, ONLY : COULOMB_FF + USE DAMPING_SI +! + USE UNITS, ONLY : UNIT +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,VC + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q,OM,DC,N0,L,QL +! + REAL (WP) :: SQRT,REAL,AIMAG +! + COMPLEX (WP) :: EPS,ZETA,PI0 + COMPLEX (WP) :: NUM,DEN +! + Q = TWO * X * KF_SI ! q in SI + OM = Z * H_BAR * Q * Q * HALF / M_E ! omega in SI +! + CALL COULOMB_FF('3D',UNIT,Q,ZERO,VC) ! Coulomb potential +! + DC = VF_SI * VF_SI * LFT / D('3D') ! diffusion coefficient + L = SQRT(DC * LFT * D('3D')) ! elastic MFP + QL = Q * L ! +! +! Computing the density of states at Fermi level +! + N0=DOS_EF('3D') ! +! + NUM = ONE - IC * (OM * LFT + QL) ! + DEN = ONE - IC * (OM * LFT - QL) ! + ZETA = IC * HALF * CDLOG(NUM / DEN) / QL ! ref. (1), above +! + PI0 = N0 * (ONE + IC * OM * LFT * (ZETA / (ONE - ZETA))) ! +! + EPS = ONE - VC * PI0 ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE RDF2_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE RPA1_EPS_D_LG_3D(X,Z,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! RPA dielectric function for 3D systems +! +! References: (1) J. Solyom, "Fundamental of the Physics of Solids", +! Vol3, Chap. 29, p. 61-138, Springer +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! In the RPA case, we have +! +! EPS(RPA) = 1 - V_C * Pi_0 Pi_0 : RPA polarisability +! +! which we will write as +! +! EPS(RPA) = 1 + ZZ * L ZZ : (q_{TF}/q)^2 +! L : Lindhard function +! +! where q_{TF} is the Thomas-Fermi screening vector, and EPS(TF) = 1 + ZZ +! is the Thomas-Fermi dieclectric function. +! +! +! Author : D. Sébilleau +! +! Last modified : 18 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE LINDHARD_FUNCTION, ONLY : LINDHARD_D +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z + REAL (WP), INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: LR,LI + REAL (WP) :: Q_SI,ZZ +! + Q_SI = TWO * X * KF_SI ! +! +! Coefficient Z: (q_{TF}/q)^2 --> dimension-dependent +! +! + ZZ = FOUR * KF_SI / (PI * BOHR * Q_SI * Q_SI) ! +! +! Calling the dynamic Lindhard function +! + CALL LINDHARD_D(X,Z,'3D',LR,LI) ! +! +! Calculation of the RPA dielectric function +! + EPSR = ONE + ZZ * LR ! + EPSI = ZZ * LI ! EPS(RPA) = 1 + ZZ * L +! + END SUBROUTINE RPA1_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE RPA2_EPS_D_LG_3D(X,Z,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal temperature-dependent +! RPA dielectric function EPS(q,omega,T) for 3D systems. +! +! References: (1) M. Barriga-Carrasco, Phys. Rev. E 76, 016405 (2007) +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * T : temperature (SI) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,EIGHT, & + HALF,THIRD + USE CONSTANTS_P1, ONLY : BOHR,K_B + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI + USE CHEMICAL_POTENTIAL, ONLY : MU + USE EXT_FUNCTIONS, ONLY : PDF + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + INTEGER :: IY + INTEGER :: ID + INTEGER, PARAMETER :: N_Y = 100 +! + REAL (WP) :: X,Z,T,U + REAL (WP) :: EPSR,EPSI + REAL (WP) :: BETA,D,KFA0,COEFR,COEFI + REAL (WP) :: SMALL,LARGE,Z3 + REAL (WP) :: G1,G2,NUM,DEN + REAL (WP) :: X1,X2,X12,X22 + REAL (WP) :: BMU + REAL (WP) :: F1(N_Y),F2(N_Y) + REAL (WP) :: Y,Y_STEP +! + REAL (WP), PARAMETER :: Y_MAX = EIGHT +! + REAL (WP) :: LOG,ABS,SQRT,REAL,EXP +! + SMALL = 1.0E-1_WP ! + LARGE = 1.0E+1_WP ! +! + ID = 2 ! +! + U = X * Z ! omega / (q * v_F) + Z3 = Z * Z * Z ! +! + BETA = ONE / (K_B * T) ! + KFA0 = KF_SI * BOHR ! dimensionless parameter + D = EF_SI * BETA ! plasma degeneracy parameter + COEFR = ONE / (FOUR * PI * Z3 * KFA0) ! + COEFI = ONE / (EIGHT * Z3 * KFA0) ! +! + BMU = BETA * MU('3D',T) ! +! + X1 = U + Z ! + X2 = U - Z ! + X12 = X1 * X1 ! + X22 = X2 * X2 ! +! +! Calculation of G1 = g(u+z) and G2 = g(u-z) +! + IF(D <= SMALL) THEN ! ref. (1) eq. (8) + G1 = X1 + HALF * (ONE - X12) * & ! g(u+z) + LOG(ABS((ONE + X1) / (ONE - X1))) ! + G2 = X2 + HALF * (ONE - X22) * & ! g(u-z) + LOG(ABS((ONE + X2) / (ONE - X2))) ! + ELSE IF(D >= LARGE) THEN ! + G1 = TWO * THIRD * SQRT(D) * REAL(PDF(SQRT(D)*X1),KIND=WP) ! ref. (1) eq. (9) + G2 = TWO * THIRD * SQRT(D) * REAL(PDF(SQRT(D)*X2),KIND=WP) ! ref. (1) eq. (9) + ELSE ! + DO IY = 1, N_Y ! + Y_STEP = Y_MAX / FLOAT(N_Y - 1) ! + Y = FLOAT(IY - 1) * Y_STEP ! integration step + F1(IY) = Y * LOG(ABS((X1 + Y) / (X1 - Y))) / & ! + EXP(D * Y * Y - BMU) ! ref. (1) eq. (7) + F2(IY) = Y * LOG(ABS((X2 + Y) / (X2 - Y))) / & ! + EXP(D * Y * Y - BMU) ! + END DO ! + CALL INTEGR_L(F1,Y_STEP,N_Y,N_Y,G1,ID) ! g(u+z) + CALL INTEGR_L(F2,Y_STEP,N_Y,N_Y,G2,ID) ! g(u-z) + END IF ! +! + NUM = ONE + EXP(BMU - D * X22) ! + DEN = ONE + EXP(BMU - D * X12) ! +! + EPSR = ONE + COEFR * (G1 - G2) ! ref. (1) eq. (6) + EPSI = COEFI * LOG(NUM / DEN) / D ! ref. (1) eq. (11) +! + END SUBROUTINE RPA2_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE RPAP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! RPA dielectric function + STATIC local field corrections +! for 3D systems +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Apr 2021 +! +! + USE LF_VALUES +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR + USE COMPLEX_NUMBERS, ONLY : ONEC,IC + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE LINDHARD_FUNCTION, ONLY : LINDHARD_D + USE LOCAL_FIELD_STATIC +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: LR,LI + REAL (WP) :: Q_SI,ZZ + REAL (WP) :: GR +! + COMPLEX (WP) :: GQ + COMPLEX (WP) :: NUM,DEN + COMPLEX (WP) :: EPS,EPS0 +! + Q_SI = TWO * X * KF_SI ! +! +! Coefficient Z: (q_{TF}/q)^2 --> dimension-dependent +! +! + ZZ = FOUR * KF_SI / (PI * BOHR * Q_SI * Q_SI) ! +! +! Calling the dynamic Lindhard function +! + CALL LINDHARD_D(X,Z,'3D',LR,LI) ! +! +! Calling the local-field calculation +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GR) ! + GQ = CMPLX(GR) ! +! +! Calculation of the RPA dielectric function +! + EPSR = ONE + ZZ * LR ! + EPSI = ZZ * LI ! EPS(RPA) = 1 + ZZ * L +! + EPS0 = EPSR + IC * EPSI ! +! +! Computing the LFC dielectric function +! + NUM = ONEC - EPS0 ! V_C * Pi_{RPA} + DEN = ONEC + GQ * NUM ! 1 + V_C * G * Pi_{RPA} +! + EPS = ONEC - NUM / DEN ! +! + EPSR = REAL(EPS, KIND = WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE RPAP_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE UTIC_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in 3D in the Utsumi-Ichimaru approximation +! +! Reference: (1) K. Utsumi and S. Ichimaru, +! Phys. Rev. B 22, 1522-1533 (1980) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * T : temperature in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * SQ_TYPE : static structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! * IQ_TYPE : type of approximation for I(q) +! IQ_TYPE = 'IKP' Iwamoto-Krotscheck-Pines parametrization +! IQ_TYPE = 'KU1' +! IQ_TYPE = 'KU2' +! IQ_TYPE = 'TWA' +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR, & + HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : RS_TO_N0 + USE LF_VALUES, ONLY : GQ_TYPE + USE ENERGIES, ONLY : EC_TYPE + USE SF_VALUES, ONLY : SQ_TYPE + USE EXT_FUNCTIONS, ONLY : PDF + USE RELAXATION_TIME_STATIC, ONLY : UTIC_RT_3D + USE CALC_ENERGIES, ONLY : ENERGIES_3D + USE COULOMB_K, ONLY : COULOMB_FF + USE UTIC_PARAMETERS, ONLY : UTIC_PARAM + USE LOCAL_FIELD_STATIC + USE DFUNC_STATIC +! + USE UNITS, ONLY : UNIT +! + IMPLICIT NONE +! + REAL (WP) :: X,Y,T,Y2,Z,V,RS + REAL (WP) :: EPSR,EPSI,EPS0R,EPS0I + REAL (WP) :: OMEGA,Q_SI,OMG0,VC,N0,COEF + REAL (WP) :: GQ,TAU_Q,Q1,Q3,OM0,OMQ,OO + REAL (WP) :: E_0,E_X,E_X_HF,E_C,E_XC + REAL (WP) :: E_HF,E_GS,E_KIN,E_POT +! + REAL (WP) :: DSQRT,DREAL,DIMAG +! + COMPLEX (WP) :: EPS,OMB,OOB,NUM,DEN,QQO,QQ0 +! + Y=X+X ! Y = q / k_F + Y2=Y*Y ! + V=Z*Y2 ! omega / omega_{k_F} +! + OMEGA=V*HALF*H_BAR*KF_SI*KF_SI/M_E ! omega +! + Q_SI=Y*KF_SI ! + OMG0=HALF*H_BAR*Q_SI*Q_SI/M_E ! ref. 1 eq. (2.6) +! +! Computing the Coulomb potential +! + CALL COULOMB_FF('3D',UNIT,Q_SI,ZERO,VC) ! +! +! Computing electron density +! + N0=RS_TO_N0('3D',RS) ! +! +! Computing the local-field correction +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ) ! +! +! Computing the UTIC relaxation time +! + TAU_Q=UTIC_RT_3D(X,RS,T,SQ_TYPE,GQ_TYPE) ! +! +! Computing the UTIC parameters OMEGA(q) and OMEGA(0) +! + CALL UTIC_PARAM(X,RS,T,OMQ,OM0) ! +! + OO=OMEGA/OMQ ! +! +! Coefficient \bar{omega} +! + OMB=OMEGA+DSQRT(TWO*PI_INV)*(PDF(OO)-ONE) /(OO*TAU_Q) ! ref. 1 eq. (3.13) +! + OOB=OMB/OMEGA ! +! +! Computing the averaged kinetic energy per electron +! + CALL ENERGIES_3D(X,EC_TYPE,RS,T,0,ZERO,E_0,E_X,E_X_HF,E_C, & ! + E_XC,E_HF,E_GS,E_KIN,E_POT) ! +! +! Coefficients Q1 and Q3 +! + Q1=N0*Q_SI*Q_SI/M_E ! + Q3=Q1*(FOUR*E_KIN*OMG0/H_BAR + OMG0*OMG0) ! +! +! Susceptibility function Q(q,omega) +! + QQO=Q1/(OMB*OMB) + Q3/(OMB*OMB*OMB*OMB) ! ref. 1 eq. (3.17) +! +! Computing the RPA susceptibility Q(q,0) +! + CALL DFUNCL_STATIC(X,'LRPA',EPS0R,EPS0I) ! + QQ0=ONE-(EPS0R+IC*EPS0I)/VC ! ref. 1 eq. (3.15) +! +! Computing eps(q,omega) +! + NUM=VC*OOB*QQO ! + DEN=ONE + (VC*OOB*GQ + (OOB-ONE)/QQ0)*QQO ! + EPS=ONE - NUM/DEN ! ref. 1 eq. (3.12) +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE UTIC_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE VLFP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal Vlasov-Fokker-Planck +! dynamical dielectric function in 3D +! +! References: (1) A. Selchow and K. Morawetz, Phys. Rev. E 59, 1015-1023 (1999) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! Alternatively, the diffusion coefficient D can be used, with the +! relation: +! TAU * D = K_B * T / M_E +! +! Note: lambda = 1 / tau ! ref. (1) eq. (7) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE COMPLEX_NUMBERS, ONLY : ONEC,IC + USE CONSTANTS_P1, ONLY : M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE EXT_FUNCTIONS, ONLY : CONHYP + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: U + REAL (WP) :: Q_SI,OMG + REAL (WP) :: KD_SI + REAL (WP) :: AA,BB,Q2,RAT +! + REAL (WP) :: REAL,IMAG +! + COMPLEX (WP) :: EPS + COMPLEX (WP) :: A,B,ZZ,COEF +! + COMPLEX (WP) :: CMPLX +! + U = X * Z ! omega / (q * v_F) + Q_SI = TWO * X * KF_SI ! q in SI + OMG = U * Q_SI * VF_SI ! omega in SI +! + Q2 = Q_SI * Q_SI ! +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + RAT = KD_SI * KD_SI / Q2 + AA = K_B * T * TAU / M_E ! k_B * T / (m * lambda) + BB = AA * Q2 ! + COEF = IC * OMG / (BB - IC * OMG) ! +! +! Parameters/arguments of 1F1 +! + A = ONEC ! + B = ONEC + CMPLX( (BB - IC * OMG) * TAU) ! + ZZ = CMPLX(BB * TAU) ! +! + EPS = ONEC + RAT * (ONEC + COEF * CONHYP(A,B,ZZ,0,10)) ! ref. (1) eq. (27) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE VLFP_EPS_D_LG_3D +! +!======================================================================= +! +! 2) BL case (bilayer) +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC_BL(X,Z,RS,T,D_FUNCL,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in a bilayer +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * D_FUNCL : type of longitudinal dielectric function (2D) +! +! +! Intermediate parameters: +! +! * DL : distance between the two layers (SI) +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,TWO + USE FERMI_SI, ONLY : KF_SI + USE MULTILAYER, ONLY : DL + USE UTILITIES_3, ONLY : EPS_TO_PI + USE COULOMB_K, ONLY : COULOMB_FF +! + USE UNITS, ONLY : UNIT +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,RS,T,D + REAL (WP) :: EPSR,EPSI + REAL (WP) :: REPS,IEPS + REAL (WP) :: PIR,PII + REAL (WP) :: Q_SI,VC +! + Q_SI = TWO * X * KF_SI ! q +! +! Computing the single layer dielectric function +! + CALL DFUNCL_DYNAMIC_2D(X,Z,RS,T,D_FUNCL,REPS,IEPS) ! +! +! Computing the single layer polarisability +! + CALL COULOMB_FF('2D',UNIT,Q_SI,ZERO,VC) ! + CALL EPS_TO_PI(EPSR,EPSI,VC,PIR,PII) ! +! +! Computing the bilayer dielectric function +! + CALL BILA_EPS_D_LG_2D(X,DL,PIR,PII,EPSR,EPSI) ! +! + END SUBROUTINE DFUNCL_DYNAMIC_BL +! +!======================================================================= +! + SUBROUTINE BILA_EPS_D_LG_2D(X,DL,PIR,PII,EPSR,EPSI) +! +! This subroutine computes the dielectric function of a bilayer system +! It assumes that the two layers are identical +! +! Reference: (1) S. Das Sarma and A. Madhukar, Phys. Rev. B 23, +! 805-815 (1981) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * DL : distance between the two layers (SI) +! * PIR : real part of polarization of one layer +! * PII : imaginary part of polarization of one layer +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 19 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : E + USE FERMI_SI, ONLY : KF_SI + USE MULTILAYER, ONLY : EPS_1 + USE CONFINEMENT_FF +! + IMPLICIT NONE +! + REAL (WP) :: X,DL,VC,PIR,PII + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI +! + REAL (WP) :: DEXP,DREAL,DIMAG +! + COMPLEX (WP) :: PI,EPS +! + Q_SI=TWO*X*KF_SI ! q +! +! Computing the intralayer Coulomb potential +! + VC=E*E*CONFIN_FF(X)/(Q_SI*EPS_1) ! +! + PI=PIR+IC*PII ! +! + EPS=ONE - TWO*VC*PI + VC*PI*VC*PI*(ONE-DEXP(-TWO*Q_SI*DL)) ! ref. (1) eq. (12) +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE BILA_EPS_D_LG_2D +! +!======================================================================= +! +! 3) ML case (multilayers) +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC_ML(X,Z,RS,T,D_FUNCL,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in an infinite stacking of +! (identical) layers +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * D_FUNCL : type of longitudinal dielectric function (2D) +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE CONSTANTS_P1, ONLY : E + USE FERMI_SI, ONLY : KF_SI + USE MULTILAYER, ONLY : H_TYPE,D1,EPS_1 + USE UTILITIES_3, ONLY : EPS_TO_PI + USE CONFINEMENT_FF +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,RS,T + REAL (WP) :: EPSR,EPSI + REAL (WP) :: REPS,IEPS + REAL (WP) :: PIR,PII + REAL (WP) :: Q_SI,VC +! + Q_SI=TWO*X*KF_SI ! q +! +! Computing the single layer dielectric function +! + CALL DFUNCL_DYNAMIC_2D(X,Z,RS,T,D_FUNCL,REPS,IEPS) ! +! +! Computing the intralayer Coulomb potential +! + VC=E*E*CONFIN_FF(X)/(Q_SI*EPS_1) ! +! +! Computing the single layer polarisability +! + CALL EPS_TO_PI(EPSR,EPSI,VC,PIR,PII) ! +! +! Computing the multilayer dielectric function +! + IF(H_TYPE == 'MLA1') THEN ! + CALL MLA1_EPS_D_LG_2D(X,PIR,PII,EPSR,EPSI) ! + ELSE IF (H_TYPE == 'MLA2') THEN ! + CALL MLA2_EPS_D_LG_2D(X,PIR,PII,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCL_DYNAMIC_ML +! +!======================================================================= +! + SUBROUTINE MLA1_EPS_D_LG_2D(X,PIR,PII,EPSR,EPSI) +! +! This subroutine computes the dielectric function of a infinite +! stacking of layers with one layer per unit cell. +! It assumes that all layers are identical +! +! Reference: (1) A. C. Sharma, Solid State Comm. 70, 1171-1174 (1989) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * PIR : real part of polarization of one layer +! * PII : imaginary part of polarization of one layer +! +! Intermediate parameters: +! +! * DL : size of stacking unit cell +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : E + USE FERMI_SI, ONLY : KF_SI + USE MULTILAYER, ONLY : DL,EPS_1 + USE CONFINEMENT_FF +! + IMPLICIT NONE +! + REAL (WP) :: X,VC,PIR,PII + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,SGN +! + REAL (WP) :: DSINH,DCOSH,DREAL,DIMAG +! + COMPLEX (WP) :: PI,EPS,AQ +! + Q_SI=TWO*X*KF_SI ! q in SI +! +! Computing the intralayer Coulomb potential +! + VC=E*E*CONFIN_FF(X)/(Q_SI*EPS_1) ! +! + PI=PIR+IC*PII ! +! + AQ=VC*PI*DSINH(Q_SI*DL) - DCOSH(Q_SI*DL) ! ref. 1 eq. (12) +! + IF(DREAL(AQ) >= ZERO) THEN ! + SGN=ONE ! + ELSE ! sign of Re [ AQ ] + SGN=-ONE ! + END IF ! +! + EPS=CDSQRT(AQ*AQ-ONE) / (SGN*DSINH(Q_SI*DL)) ! ref. 1 eq. (11) +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE MLA1_EPS_D_LG_2D +! +!======================================================================= +! + SUBROUTINE MLA2_EPS_D_LG_2D(X,PIR,PII,EPSR,EPSI) +! +! This subroutine computes the dielectric function of a infinite +! stacking of layers with two layers per unit cell. +! It assumes that all layers are identical +! +! Reference: (1) A. C. Sharma, N. Chatuverdi and Y. M. Gupta, +! Physica C 209, 507-512 (1993) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * PIR : real part of polarization of one layer +! * PII : imaginary part of polarization of one layer +! +! Intermediate parameters: +! +! * DL : size of stacking unit cell +! * D1 : distance between the two layers in the unit cell (SI) +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : E + USE FERMI_SI, ONLY : KF_SI + USE MULTILAYER, ONLY : DL,D1,EPS_1 + USE CONFINEMENT_FF +! + IMPLICIT NONE +! + REAL (WP) :: X,VC,PIR,PII + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q,DPR,FQ,SGN +! + REAL (WP) :: DSINH,DCOSH,DREAL,DIMAG +! + COMPLEX (WP) :: PI,EPS,HQ +! + Q=TWO*X*KF_SI ! q in SI +! +! Computing the intralayer Coulomb potential +! + VC=E*E*CONFIN_FF(X)/(Q*EPS_1) ! +! + DPR=TWO*D1-DL ! d' + FQ=(DCOSH(Q*DL)-DCOSH(Q*DPR)) / DSINH(Q*DL) ! ref. (1) eq. (10) +! + PI=PIR+IC*PII ! +! + HQ=DCOSH(Q*DL) - DSINH(Q*DL)*(TWO-VC*PI*FQ)*VC*PI ! ref. (1) eq. (14) +! + IF(DREAL(HQ) >= ZERO) THEN ! + SGN=ONE ! + ELSE ! sign of Re [ HQ ] + SGN=-ONE ! + END IF ! +! + EPS=CDSQRT(HQ*HQ-ONE) / (SGN*DSINH(Q*DL)*(ONE-VC*PI*FQ)) ! ref. 1 eq. (12) +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END +! +!======================================================================= +! +! 4) 2D case +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC_2D(X,Z,RS,T,D_FUNCL,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in 2D +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * D_FUNCL : type of longitudinal dielectric function (2D) +! D_FUNCL = 'LAND' Landau parameter formulation +! D_FUNCL = 'PLPO' plasmon pole approximation +! D_FUNCL = 'RPA1' random phase approximation +! D_FUNCL = 'MER1' Mermin 1 <-- damping +! D_FUNCL = 'HUCO' Hu-O'Connell <-- with loss +! D_FUNCL = 'NEVA' Nevalinna <-- with loss +! D_FUNCL = 'RDF1' Altshuler et al <-- with loss +! D_FUNCL = 'RDF2' Sharma-Ashraf <-- with loss +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Aug 2021 +! +! + USE LF_VALUES, ONLY : LANDAU + USE PLASMON_DISPERSION +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,RS,T + REAL (WP) :: EPSR,EPSI +! + IF(D_FUNCL == 'LAND') THEN ! + CALL LAND_EPS_D_LG_2D(X,Z,RS,LANDAU,EPSR,EPSI) ! + ELSE IF(D_FUNCL == 'PLPO') THEN ! + CALL PLPO_EPS_D_LG_2D(X,Z,RS,T,PL_DISP,EPSR,EPSI) ! + ELSE IF(D_FUNCL == 'RPA1') THEN ! + CALL RPA1_EPS_D_LG_2D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL == 'MER1') THEN ! + CALL MER1_EPS_D_LG_2D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL == 'HUCO') THEN ! + CALL HUCO_EPS_D_LG_2D(X,Z,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL == 'NEVA') THEN ! + CONTINUE ! + ELSE IF(D_FUNCL == 'RDF1') THEN ! + CALL RDF1_EPS_D_LG_2D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL == 'RDF2') THEN ! + CALL RDF2_EPS_D_LG_2D(X,Z,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCL_DYNAMIC_2D +! +!======================================================================= +! + SUBROUTINE LAND_EPS_D_LG_2D(X,Z,RS,LANDAU,EPSR,EPSI) +! +! This subroutine computes the dielectric function EPS(q,omega) +! in 2D systems in terms of Landau's parameters. +! +! References: (1) E. Lipparini, "Modern Many-Particle Physics - Atomic Gases, +! Quantum Dots and Quantum Fluids", World Scientific (2003) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : dimensionless factor +! * LANDAU : model chosen for the calculation of the parameters +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! +! Last modified : 17 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF,THIRD,FOURTH + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : E,EPS_0 + USE FERMI_SI, ONLY : KF_SI + USE UTILITIES_1, ONLY : DOS_EF + USE CHEMICAL_POTENTIAL, ONLY : MU_RS + USE ENERGIES, ONLY : EC_TYPE + USE LANDAU_PARAM +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: LANDAU +! + REAL (WP) :: X,Z,RS + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI + REAL (WP) :: U,NU0,MU,V_C + REAL (WP) :: F0S,F0A,F1S,F1A,F2S,F2A +! + REAL (WP) :: DSQRT,DREAL,DIMAG +! + COMPLEX (WP) :: EPS,CHIS,G00,G20,G22 + COMPLEX (WP) :: NUM,DEN,NU1,DE1 +! + U=X*Z ! omega / (q * v_F) + Q_SI=TWO*X*KF_SI ! q in SI + NU0=DOS_EF('2D') ! DoS at Fermi level +! +! Computing the Coulomb potential +! + V_C=HALF*E*E/(EPS_0*Q_SI) ! +! +! Computing the chemical potential +! + MU=MU_RS(RS,EC_TYPE) ! +! +! Computing the Landau parameters using chemical potential +! + CALL LANDAU_PARAMETERS_2D(RS,LANDAU,MU,1, & ! + F0S,F0A,F1S,F1A,F2S,F2A) ! +! +! Calculation of the coefficients Gamma_{l,l'} +! + IF(U <= ONE) THEN ! + G00=ONE + IC*U/DSQRT(ONE-U*U) ! + ELSE ! ref. 1 eq. (8.53) + G00=ONE - U/DSQRT(U*U-ONE) ! + END IF ! +! + G20=ONE + (TWO*U*U-ONE)*G00 ! + G22=HALF+ (TWO*U*U-ONE)*G20 ! ref. 1 eq. (8.54) +! + NU1=(ONE+HALF*F1S)*(ONE+FOURTH*F2S)*G20 ! + DE1=TWO*(G00 + HALF*F2S*(G22*G00-G20*G20)) ! + NUM=HALF*NU0*(ONE+HALF*F1S) ! + DEN=U*U - HALF*(ONE+HALF*F1S)*(ONE+F0S) - NU1/DE1 ! +! + CHIS=NUM/DEN ! ref. 1 eq. (8.60) +! + EPS=ONE/(ONE+V_C*CHIS) ! +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE LAND_EPS_D_LG_2D +! +!======================================================================= +! + SUBROUTINE PLPO_EPS_D_LG_2D(X,Z,RS,T,PL_DISP,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic plasmon pole +! dielectric function for 2D systems +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * PL_DISP : type of analytical plasmon dispersion +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PLASMON_DISP_REAL + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: PL_DISP +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: ENE_SI,ENE_P_Q + REAL (WP) :: Q_SI + REAL (WP) :: NUM,DEN,EPS +! + ENE_SI = FOUR * X * X * Z * EF_SI ! hbar omega +! + Q_SI = TWO * X * KF_SI ! q in SI +! +! Calculation of the analytical plasmon dispersion +! + CALL PLASMON_DISP_2D(X,RS,T,PL_DISP,ENE_P_Q) ! hbar omega(q) +! + NUM = ENE_P_SI * ENE_P_SI * Q_SI ! + DEN = ENE_SI * ENE_SI + NUM - ENE_P_Q * ENE_P_Q ! +! + EPS = ONE - NUM / DEN ! +! + EPSR = EPS ! + EPSI = ZERO ! +! + END SUBROUTINE PLPO_EPS_D_LG_2D +! +!======================================================================= +! + SUBROUTINE RPA1_EPS_D_LG_2D(X,Z,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! RPA dielectric function for 2D systems +! +! References: (1) J. Solyom, "Fundamental of the Physics of Solids", +! Vol3, Chap. 29, p. 61-138, Springer +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! In the RPA case, we have +! +! EPS(RPA) = 1 - V_C * Pi_0 Pi_0 : RPA polarisability +! +! which we will write as +! +! EPS(RPA) = 1 + ZZ * L ZZ: q_{TF} / q +! L : Lindhard function +! +! where q_{TF} is the Thomas-Fermi screening vector, and EPS(TF) = 1 + ZZ +! is the Thomas-Fermi dieclectric function. +! +! +! Note: There is a misprint in eq. (29.5.2) of ref. (1) : +! +! 4 pi e^2 / q^2 should be replaced by 2 pi e^2 / q +! +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,EIGHT + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE LINDHARD_FUNCTION, ONLY : LINDHARD_D +! + IMPLICIT NONE +! + REAL (WP) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: LR,LI + REAL (WP) :: Q_SI,K_TF_SI,ZZ +! + Q_SI = TWO * X * KF_SI ! +! +! Coefficient ZZ: (q_{TF}/q)^2 --> dimension-dependent +! + CALL THOMAS_FERMI_VECTOR('2D',K_TF_SI) ! + ZZ = K_TF_SI / Q_SI ! +! +! Calling the dynamic Lindhard function +! + CALL LINDHARD_D(X,Z,'2D',LR,LI) ! +! +! Calculation of the RPA dielectric function +! + EPSR = ONE + ZZ * LR ! + EPSI = ZZ * LI ! EPS(RPA) = 1 + ZZ * L +! + END SUBROUTINE RPA1_EPS_D_LG_2D +! +!======================================================================= +! + SUBROUTINE MER1_EPS_D_LG_2D(X,Z,EPSR,EPSI) +! +! This subroutine computes the longitudinal Mermin dynamical +! dielectric function in 2D +! +! References: (1) H. B. Nersiyan and A. K. Das, Phys. Rev. E 80, 016402 (2009) +! +! Note: for TAU --> infinity, we recover the RPA values +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! * TAU : relaxation time (used for damping) in SI +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Note: in order to be more general, we use EPS_B (background +! dielectric constant) instead of 1 (vacuum case) +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Aug 2021 +! +! + USE MATERIAL_PROP, ONLY : EPS_B +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE SQUARE_ROOTS, ONLY : SQR2 + USE CONSTANTS_P1, ONLY : BOHR,H_BAR + USE FERMI_SI, ONLY : EF_SI,KF_SI +! + USE DFUNC_STATIC, ONLY : RPA1_EPS_S_LG + USE DAMPING_SI, ONLY : TAU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: U,X2 + REAL (WP) :: CHI2,COEF,KOEF + REAL (WP) :: REPSM1,IEPSM1 + REAL (WP) :: REPS00 + REAL (WP) :: EPS0R,EPS0I + REAL (WP) :: GAMMA,GAMMA2 + REAL (WP) :: UP,UM,UP2,UM2 + REAL (WP) :: NU1,NU2,DEN + REAL (WP) :: YPP,YPM,YMP,YMM + REAL (WP) :: F1,F2 +! + REAL (WP) :: SQRT,REAL,AIMAG +! + COMPLEX (WP) :: NUMI,DENI,EPS +! + X2 = X * X ! +! + U = X * Z ! omega / (q * v_F) + CHI2 = ONE / (KF_SI * BOHR) ! + GAMMA = H_BAR / (FOUR * EF_SI * TAU) ! + GAMMA2 = GAMMA * GAMMA ! +! + COEF = HALF * CHI2 / X2 ! + KOEF = HALF * SQR2 ! 1 / sqrt(2) +! + UP = U + X ! U_+ + UM = U - X ! U_- +! + UP2 = UP * UP ! + UM2 = UM * UM ! +! + NU1 = X2 * (UP + ONE) * (UP + ONE) + GAMMA2 ! + NU2 = X2 * (UP2 - ONE) + GAMMA2 ! ref. (1) eq. (5) + DEN = X2 * (UP - ONE) * (UP - ONE) + GAMMA2 ! +! + YPP = KOEF * SQRT( SQRT(NU1 / DEN) + NU2 / DEN ) ! Y_+(z,U_+) + YMP = KOEF * SQRT( SQRT(NU1 / DEN) - NU2 / DEN ) ! Y_-(z,U_+) +! + NU1 = X2 * (UM + ONE) * (UM + ONE) + GAMMA2 ! + NU2 = X2 * (UM2 - ONE) + GAMMA2 ! ref. (1) eq. (5) + DEN = X2 * (UM - ONE) * (UM - ONE) + GAMMA2 ! +! + YPM = KOEF * SQRT( SQRT(NU1 / DEN) + NU2 / DEN ) ! Y_+(z,U_-) + YMM = KOEF * SQRT( SQRT(NU1 / DEN) - NU2 / DEN ) ! Y_-(z,U_-) +! + F1 = TWO * X + GAMMA * (YMM - YMP) / X + & ! ref. (1) eq. (3) + (UM - ONE) * YPM - & ! + (UP - ONE) * YPP ! +! + F2 = GAMMA * (YPM - YPP) / X + & ! ref. (1) eq. (4) + (UP - ONE) * YMP - & ! + (UM - ONE) * YMM ! +! +! Computation of EPS_{RPA}(x,u,Gamma) - 1 +! + REPSM1 = COEF * F1 ! ref. (1) eq. (2) + IEPSM1 = COEF * F2 ! +! +! Computation of EPS_{RPA}(x,0) - EPS_B +! + CALL RPA1_EPS_S_LG(X,'2D',EPS0R,EPS0I) ! EPS_{RPA}(x,0) +! + REPS00 = EPS0R - EPS_B ! EPS_{RPA}(x,0) - EPS_B +! + NUMI = (X * U + IC * GAMMA) * (REPSM1 + IC * IEPSM1) ! + DENI = X * U + IC * GAMMA * (REPSM1 + IC * IEPSM1) / REPS00 ! +! + EPS = EPS_B + NUMI / DENI ! ref. (1) eq. (1) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE MER1_EPS_D_LG_2D +! +!======================================================================= +! + SUBROUTINE HUCO_EPS_D_LG_2D(X,Z,RS,EPSR,EPSI) +! +! This subroutine computes the Hu-O'Connell dielectric function that +! including damping effect through electron-electron and electron-impurity +! fluctuation, leading to a diffusion coefficient D, for 2D systems +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = hbar omega / E_F +! * RS : Wigner-Seitz radius (in units of a_0) +! * D : diffusion coefficient (in SI) +! +! +! Output variables : +! +! * EPSR : real part of the dielectric function at q +! * EPSI : imaginary part of the dielectric function at q +! +! Reference : (1) G. Y. Hu and R. F. O'Connell, +! J. Phys. C: Solid State Phys. 21, 4325-4331 (1988) +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,FOURTH + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE SQUARE_ROOTS, ONLY : SQR2 + USE FERMI_SI, ONLY : KF_SI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: U + REAL (WP) :: Q_SI,KTF_SI + REAL (WP) :: FF + REAL (WP) :: KOQ + REAL (WP) :: COEF,KOEF + REAL (WP) :: B,NUP,NUM + REAL (WP) :: NP2,NM2 + REAL (WP) :: SIP,SIM + REAL (WP) :: SP2,SM2 + REAL (WP) :: BX,B2X2 + REAL (WP) :: OBXP,OBXM + REAL (WP) :: FBNP,FBNM + REAL (WP) :: SQP1,SQM1 + REAL (WP) :: SQP2,SQM2 +! + REAL (WP) :: SIGN,SQRT +! + U = X * Z ! omega / (q * v_F) + Q_SI = TWO * KF_SI * X ! q in SI +! + FF = ONE ! +! +! Computing the Thomas-Fermi vector +! + CALL THOMAS_FERMI_VECTOR('3D',KTF_SI) ! +! + KOQ = KTF_SI / Q_SI ! +! + COEF = FF * KOQ ! + KOEF = FF * KOQ / (TWO * SQR2 * X) ! +! +! Setting the Hu-O'Connell parameters +! + B = TWO * M_E * DIF / H_BAR ! \ + NUP = X + U ! > ref. (1) eq. (8) + NUM = X - U ! / +! + NP2 = NUP * NUP ! + NM2 = NUM * NUM ! +! + SIP = SIGN(ONE,NUP) ! + SIM = SIGN(ONE,NUM) ! +! + SP2 = SIP / (TWO * SQR2 * X) ! + SM2 = SIM / (TWO * SQR2 * X) ! +! + BX = B * X ! + B2X2 = BX * BX ! +! + OBXP = ONE + B2X2 - NP2 ! + OBXM = ONE + B2X2 - NM2 ! +! + FBNP = FOUR * B2X2 * NP2 ! + FBNM = FOUR * B2X2 * NM2 ! +! + SQP1 = SQRT( SQRT(OBXP**2 + FBNP) - OBXP ) ! + SQM1 = SQRT( SQRT(OBXM**2 + FBNM) - OBXM ) ! + SQP2 = SQRT( SQRT(OBXP**2 + FBNP) + OBXP ) ! + SQM2 = SQRT( SQRT(OBXM**2 + FBNM) + OBXM ) ! +! +! Real part of epsilon +! + EPSR = ONE + COEF * ( ONE - SM2 * SQM1 - SP2 * SQP1 ) ! +! +! Imaginary part of epsilon +! +! + EPSI = KOEF * ( SQM2 - SQP2 ) ! +! + END SUBROUTINE HUCO_EPS_D_LG_2D +! +!======================================================================= +! + SUBROUTINE RDF1_EPS_D_LG_2D(X,Z,EPSR,EPSI) +! +! This subroutine computes random delta-function electron-impurity +! interaction form of the dielectric function for disordered 2D +! conductors +! +! Reference: (1) B. L. Altshuler, A. G. Aronov, D.E. Khmelnitskii and +! A. I. Larkin, in "Quantum Theory of Solids", +! I. M. Lifschits editor, MIR (1982), pp. 129-236 +! (2) D. V. Livanov, M. Yu. Reizer and A. V. Sergeev, +! Sov. Phys. JETP 72, 760-764 (1991) --> for sign +! correction +! +! Note: this version valid for omega*tau << 1 and q*l << 1 +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE UTILITIES_1, ONLY : D + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q,Q2,OM,DC + REAL (WP) :: K_TF,NUM +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EPS,DEN +! + Q = TWO * X * KF_SI ! q in SI + Q2 = Q * Q ! + OM = Z * H_BAR * Q * Q * HALF / M_E ! omega in SI +! + DC = VF_SI * VF_SI * LFT / D('2D') ! diffusion coefficient +! +! Computing the Thomas-Fermi screening vector ! +! + CALL THOMAS_FERMI_VECTOR('2D',K_TF) ! +! + NUM = DC * Q * K_TF ! ref. 1 eq. (3.4.19) + DEN = DC * Q2 - IC * OM ! +! + EPS = ONE + NUM / DEN ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE RDF1_EPS_D_LG_2D +! +!======================================================================= +! + SUBROUTINE RDF2_EPS_D_LG_2D(X,Z,EPSR,EPSI) +! +! This subroutine computes random delta-function electron-impurity +! interaction form of the dielectric function for disordered 2D +! conductors +! +! Reference: (1) A. C. Sharma and S. S. Z. Ashraf, +! J. Phys.: Condens. Matter 16, 3117 (2004) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE UTILITIES_1, ONLY : D,DOS_EF + USE COULOMB_K, ONLY : COULOMB_FF +! + USE UNITS, ONLY : UNIT + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,VC + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q,OM,DC,N0,L,QL +! + REAL (WP) :: SQRT,REAL,AIMAG +! + COMPLEX (WP) :: EPS,ZETA,PI0 +! + COMPLEX (WP) :: CDSQRT +! + Q = TWO * X * KF_SI ! q in SI + OM = Z * H_BAR * Q * Q * HALF / M_E ! omega in SI +! + CALL COULOMB_FF('2D',UNIT,Q,ZERO,VC) ! +! + DC = VF_SI * VF_SI * LFT / D('2D') ! diffusion coefficient + L = SQRT(DC * LFT * D('2D')) ! elastic MFP + QL = Q * L ! +! +! Computing the density of states at Fermi level +! + N0 = DOS_EF('2D') ! +! + ZETA = ONE / CDSQRT((ONE - IC * OM * LFT)**2 + QL * QL) ! eq. (3.4.11a) +! + PI0 = N0 * (ONE + IC * OM * LFT * (ZETA / (ONE - ZETA))) ! +! + EPS = ONE - VC * PI0 ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE RDF2_EPS_D_LG_2D +! +!======================================================================= +! +! 5) Q1D case +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC_Q1(X,Z,D_FUNCL,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in Q1D +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * D_FUNCL : type of longitudinal dielectric function (1D) +! D_FUNCL = 'HUCO' Hu-O'Connell +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE PLASMON_DISPERSION +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,RS,T + REAL (WP) :: EPSR,EPSI +! + IF(D_FUNCL.EQ.'HUCO') THEN ! + CALL HUCO_EPS_D_LG_Q1(X,Z,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCL_DYNAMIC_Q1 +! +!======================================================================= +! + SUBROUTINE HUCO_EPS_D_LG_Q1(X,Z,EPSR,EPSI) +! +! This subroutine computes the Hu-O'Connell dielectric function that +! including damping effect through electron-electron and electron-impurity +! fluctuation, leading to a diffusion coefficient D, for Q1D systems +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = hbar omega / E_F +! * D : diffusion coefficient (in SI) +! +! +! Output variables : +! +! * EPSR : real part of the dielectric function at q +! * EPSI : imaginary part of the dielectric function at q +! +! Reference : (1) G. Y. Hu and R. F. O'Connell, J. Phys. C: Condens. +! Matter 2, 9381-9397 (1990) +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE MATERIAL_PROP, ONLY : MSOM + USE CONFIN_VAL, ONLY : OM0,CONFIN + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI + USE COULOMB_K +! + USE UNITS, ONLY : UNIT + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: A,B,XX,Y,B1,B2 + REAL (WP) :: NU_P(0:1),NU_M(0:1) + REAL (WP) :: Q_SI,MS + REAL (WP) :: COEF,V_C +! + REAL (WP) :: DSQRT,DREAL,DIMAG +! + COMPLEX (WP) :: IC + COMPLEX (WP) :: NUM,DEN,CHI,EPS +! + Q_SI = TWO * X * KF_SI ! q in SI + MS = MSOM * M_E ! m* +! + COEF = - MS / (PI * Q_SI) ! +! +! Computing the Coulomb potential +! + CALL COULOMB_FF('Q1',UNIT,Q_SI,ZERO,V_C) ! +! +! Setting the Hu-O'Connell parameters +! + B = SQRT( H_BAR / (MS * OM0) ) ! + A = TWO * MSOM * MS * DIF / H_BAR ! ref. (1) eq. (3.3) + XX = B * Q_SI ! \ ref. (1) eq. (3.4) + Y = Z * EF_SI / H_BAR ! / +! + NU_P(0) = Y / XX + HALF * X ! \ + NU_P(1) = (Y - ONE) / XX + HALF * X ! \ + NU_M(0) = Y/ XX - HALF * X ! / ref. (1) eq. (3.4) + NU_M(1) = (Y - ONE) / XX - HALF * X ! / +! + B1 = B * SQRT(TWO * MS * (EF_SI - H_BAR * OM0)) / H_BAR ! \ ref. (1) eq. (3.3) + B2 = B * SQRT(TWO * MS * (EF_SI - ONE * H_BAR * OM0)) / H_BAR ! / +! + IF(CONFIN == 'HC-1111') THEN ! + NUM = (B1 - NU_M(0) - IC * HALF * A * XX) * & ! + (B1 + NU_P(0) + IC * HALF * A * XX) ! + DEN = (B1 + NU_M(0) + IC * HALF * A *XX) * & ! + (B1 - NU_P(0) - IC * HALF * A * XX) ! + CHI = COEF * CDLOG(NUM / DEN) ! + EPS = ONE - CHI * V_C ! + ELSE IF(CONFIN == 'HC-1122') THEN ! + NUM = (B1 - NU_M(0) - IC * HALF * A * XX) * & ! + (B1 + NU_P(0) + IC * HALF * A * XX) ! + DEN = (B1 + NU_M(0) + IC * HALF * A * XX) * & ! + (B1 - NU_P(0) - IC * HALF * A * XX) ! + CHI = COEF * CDLOG(NUM / DEN) ! + EPS = - CHI * V_C ! + ELSE IF(CONFIN == 'HC-1221') THEN ! + NUM = (B1 - NU_M(1) - IC * HALF * A * XX) * & ! + (B2 + NU_P(1) + IC * HALF * A * XX) ! + DEN = (B1 + NU_M(1) + IC * HALF * A * XX) * & ! + (B2 - NU_P(1) - IC * HALF * A * XX) ! + CHI = COEF * CDLOG(NUM / DEN) ! + EPS = -CHI * V_C ! + ELSE IF(CONFIN == 'HC-2222') THEN ! + NUM = (B2 - NU_M(0) - IC * HALF * A * XX) * & ! + (B2 + NU_P(0) + IC * HALF * A * XX) ! + DEN = (B2 + NU_M(0) + IC * HALF * A * XX) * & ! + (B2 - NU_P(0) - IC * HALF * A * XX) ! + CHI = COEF * CDLOG(NUM / DEN) ! + EPS = ONE - CHI * V_C ! + END IF ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE HUCO_EPS_D_LG_Q1 +! +!======================================================================= +! +! 6) 1D case +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC_1D(X,Z,RS,T,D_FUNCL,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in 1D +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * D_FUNCL : type of longitudinal dielectric function (1D) +! D_FUNCL = 'RPA1' random phase approximation +! D_FUNCL = 'PLPO' plamson pole approximation +! D_FUNCL = 'RDF1' Altshuler et al model +! D_FUNCL = 'RDF2' Sharma-Ashraf model +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE PLASMON_DISPERSION +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,RS,T + REAL (WP) :: EPSR,EPSI +! + IF(D_FUNCL == 'RPA1') THEN ! + CALL RPA1_EPS_D_LG_1D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL == 'PLPO') THEN ! + CALL PLPO_EPS_D_LG_1D(X,Z,RS,T,PL_DISP,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'RDF1') THEN ! + CALL RDF1_EPS_D_LG_1D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'RDF2') THEN ! + CALL RDF2_EPS_D_LG_1D(X,Z,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCL_DYNAMIC_1D +! +!======================================================================= +! + SUBROUTINE RPA1_EPS_D_LG_1D(X,Z,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! RPA dielectric function for 1D systems +! +! References: (1) J. Solyom, "Fundamental of the Physics of Solids", +! Vol3, Chap. 29, p. 61-138, Springer +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! In the RPA case, we have +! +! EPS(RPA) = 1 - V_C * Pi_0 Pi_0 : RPA polarisability +! +! which we will write as +! +! EPS(RPA) = 1 + ZZ * L ZZ: (q_{TF}/q)^2 +! L : Lindhard function +! +! where q_{TF} is the Thomas-Fermi screening vector, and EPS(TF) = 1 + ZZ +! is the Thomas-Fermi dieclectric function. +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,EIGHT + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE LINDHARD_FUNCTION, ONLY : LINDHARD_D +! + IMPLICIT NONE +! + REAL (WP) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: LR,LI + REAL (WP) :: Q_SI,K_TF_SI,ZZ +! + Q_SI = TWO * X * KF_SI ! +! +! Coefficient ZZ: (q_{TF}/q)^2 --> dimension-dependent +! + CALL THOMAS_FERMI_VECTOR('1D',K_TF_SI) ! + ZZ = (K_TF_SI/Q_SI)**2 ! +! +! Calling the dynamic Lindhard function +! + CALL LINDHARD_D(X,Z,'1D',LR,LI) ! +! +! Calculation of the RPA dielectric function +! + EPSR = ONE + ZZ * LR ! + EPSI = ZZ * LI ! EPS(RPA) = 1 + ZZ * L +! + END SUBROUTINE RPA1_EPS_D_LG_1D +! +!======================================================================= +! + SUBROUTINE PLPO_EPS_D_LG_1D(X,Z,RS,T,PL_DISP,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic plasmon pole +! dielectric function for 1D systems +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * PL_DISP : type of analytical plasmon dispersion +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 22 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PLASMON_DISP_REAL, ONLY : PLASMON_DISP_1D + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: PL_DISP +! + REAL (WP) :: X,Z,RS,T + REAL (WP) :: EPSR,EPSI + REAL (WP) :: ENE_SI,ENE_P_Q,EPS +! + ENE_SI=FOUR*X*X*Z*EF_SI ! hbar omega +! +! Calculation of the analytical plasmon dispersion +! + CALL PLASMON_DISP_1D(X,RS,T,PL_DISP,ENE_P_Q) ! hbar omega(q) +! + EPS=ONE-ENE_P_SI*ENE_P_SI/(ENE_SI*ENE_SI+ENE_P_SI*ENE_P_SI - &! + ENE_P_Q*ENE_P_Q) ! +! + EPSR=EPS ! + EPSI=ZERO ! +! + END SUBROUTINE PLPO_EPS_D_LG_1D +! +!======================================================================= +! + SUBROUTINE RDF1_EPS_D_LG_1D(X,Z,EPSR,EPSI) +! +! This subroutine computes random delta-function electron-impurity +! interaction form of the dielectric function for disordered 1D +! conductors +! +! Reference: (1) B. L. Altshuler, A. G. Aronov, D.E. Khmelnitskii and +! A. I. Larkin, in "Quantum Theory of Solids", +! I. M. Lifschits editor, MIR (1982), pp. 129-236 +! (2) D. V. Livanov, M. Yu. Reizer and A. V. Sergeev, +! Sov. Phys. JETP 72, 760-764 (1991) --> for sign +! correction +! +! Note: this version valid for omega*tau << 1 and q*l << 1 +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,COULOMB + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE UTILITIES_1, ONLY : D,DOS_EF + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE CONFIN_VAL, ONLY : R0 + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q,Q2,OM,DC,N0 + REAL (WP) :: K_TF,NUM +! + REAL (WP) :: LOG,REAL,AIMAG +! + COMPLEX (WP) :: EPS,DEN +! + Q = TWO * X * KF_SI ! q in SI + Q2 = Q * Q ! + OM = Z * H_BAR * Q2 * HALF / M_E ! omega in SI +! + DC = VF_SI * VF_SI * LFT / D('3D') ! diffusion coefficient +! +! Computing the density of states at Fermi level +! + N0 = DOS_EF('3D') ! +! +! Computing the Thomas-Fermi screening vector ! +! + CALL THOMAS_FERMI_VECTOR('3D',K_TF) ! +! + NUM = DC * Q2 * N0 * E * E * COULOMB * LOG(ONE / (Q2 * R0*R0))! ref. 2 eq. (26) + DEN = DC * Q2 - IC * OM ! +! + EPS = ONE + NUM / DEN ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE RDF1_EPS_D_LG_1D +! +!======================================================================= +! + SUBROUTINE RDF2_EPS_D_LG_1D(X,Z,EPSR,EPSI) +! +! This subroutine computes random delta-function electron-impurity +! interaction form of the dielectric function for disordered 1D +! conductors +! +! Reference: (1) A. C. Sharma and S. S. Z. Ashraf, +! J. Phys.: Condens. Matter 16, 3117 (2004) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE UTILITIES_1, ONLY : DOS_EF + USE COULOMB_K, ONLY : COULOMB_FF +! + USE UNITS, ONLY : UNIT + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,VC + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q,OM,N0 +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EPS,ZETA,PI0 + COMPLEX (WP) :: NUM,DEN,PHI,PSI +! + Q = TWO * X *KF_SI ! q in SI + OM = Z * H_BAR * Q * Q * HALF / M_E ! omega in SI +! + CALL COULOMB_FF('1D',UNIT,Q,ZERO,VC) ! +! +! Computing the density of states at Fermi level +! + N0 = DOS_EF('1D') ! +! + PHI = CDSQRT(ONE + IC * HALF / (LFT * EF_SI)) ! ref. 1 eq. (27) + PSI = CDSQRT(ONE - (OM + IC * HALF / LFT) / EF_SI) ! ref. 1 eq. (28) + NUM = IC * (PHI - PSI) ! + DEN = LFT * EF_SI * ( PHI*PSI *( (PHI-PSI)**2 - FOUR*X*X ) ) ! + ZETA = NUM / DEN ! ref. 1 eq. (26) +! + PI0 = N0 * (ONE + IC * OM * LFT * (ZETA / (ONE - ZETA))) ! +! + EPS = ONE - VC * PI0 ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE RDF2_EPS_D_LG_1D +! +END MODULE DFUNCL_STAN_DYNAMIC diff --git a/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_stan_dynamic.f90~ b/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_stan_dynamic.f90~ new file mode 100644 index 0000000..4e7d0be --- /dev/null +++ b/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_stan_dynamic.f90~ @@ -0,0 +1,5344 @@ +! +!======================================================================= +! +MODULE DFUNCL_STAN_DYNAMIC +! + USE ACCURACY_REAL + USE ACCURACY_INTEGER + USE MINMAX_VALUES +! +! +CONTAINS +! +! +!======================================================================= +! +! Standard Longitudinal Dielectric Functions i.e. with: +! +! * no external magnetic field +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNCL,FLAG,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * D_FUNCL : type of longitudinal dielectric function (3D) +! * FLAG : current index of the omega loop calling this subroutine +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE MATERIAL_PROP, ONLY : DMN + USE REAL_NUMBERS, ONLY : ZERO,INF +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,RS,T + REAL (WP) :: EPSR,EPSI +! + INTEGER :: FLAG +! + IF(DMN == '3D') THEN ! + CALL DFUNCL_DYNAMIC_3D(X,Z,RS,T,D_FUNCL,FLAG,EPSR,EPSI) ! + ELSE IF(DMN == '2D') THEN ! + CALL DFUNCL_DYNAMIC_2D(X,Z,RS,T,D_FUNCL,EPSR,EPSI) ! + ELSE IF(DMN == 'BL') THEN ! + CALL DFUNCL_DYNAMIC_BL(X,Z,RS,T,D_FUNCL,EPSR,EPSI) ! + ELSE IF(DMN == 'ML') THEN ! + CALL DFUNCL_DYNAMIC_ML(X,Z,RS,T,D_FUNCL,EPSR,EPSI) ! + ELSE IF(DMN == 'Q1') THEN ! + CALL DFUNCL_DYNAMIC_Q1(X,Z,D_FUNCL,EPSR,EPSI) ! + ELSE IF(DMN == '1D') THEN ! + CALL DFUNCL_DYNAMIC_1D(X,Z,RS,T,D_FUNCL,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCL_DYNAMIC +! +! 1) 3D case +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC_3D(X,Z,RS,T,D_FUNCL,FLAG,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in 3D +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * V : dimensionless factor --> V = hbar * omega / E_F +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * D_FUNCL : type of longitudinal dielectric function (3D) +! D_FUNCL = 'ARBR' Arista-Brandt 1 <-- T-dependent +! D_FUNCL = 'ATAS' Atwal-Ashcroft <-- T-dependent +! D_FUNCL = 'BLZ1' Boltzmann +! D_FUNCL = 'BLZ2' damped Boltzmann +! D_FUNCL = 'DACA' Arista-Brandt 2 <-- T-dependent +! D_FUNCL = 'GOTZ' Götze memory function +! D_FUNCL = 'HEAP' Hertel-Appel +! D_FUNCL = 'HAFO' Hartree-Fock +! D_FUNCL = 'HUCO' Hu-O'Connell <-- damping +! D_FUNCL = 'HYDR' hydrodynamic <-- damping +! D_FUNCL = 'KLEI' Kleinman <-- T-dependent +! D_FUNCL = 'KLKD' Klimontovich-Kraeft <-- T-dependent +! D_FUNCL = 'KLKN' Klimontovich-Kraeft <-- T-dependent +! D_FUNCL = 'LAND' Landau parameters-based +! D_FUNCL = 'LVL1' linearized Vlasov (weak coupling) <-- T-dependent +! D_FUNCL = 'LVL2' linearized Vlasov (strong coupling) <-- T-dependent +! D_FUNCL = 'MEM2' Two-moment memory function <-- T-dependent +! D_FUNCL = 'MEM3' Three-moment memory function <-- T-dependent +! D_FUNCL = 'MEM4' Four-moment memory function <-- T-dependent +! D_FUNCL = 'MER1' Mermin 1 <-- damping +! D_FUNCL = 'MER2' Mermin 2 <-- T-dependent +! D_FUNCL = 'MER+' Mermin with Local Field Corrections <-- damping +! D_FUNCL = 'MSAP' mean spherical approximation +! D_FUNCL = 'NEV2' Nevanlinna <-- T-dependent +! D_FUNCL = 'NEV3' Nevanlinna <-- T-dependent +! D_FUNCL = 'PLPO' plasmon pole +! D_FUNCL = 'RDF1' Altshuler et al <-- damping +! D_FUNCL = 'RDF2' Altshuler et al <-- damping +! D_FUNCL = 'RPA1' RPA +! D_FUNCL = 'RPA2' RPA <-- T-dependent +! D_FUNCL = 'RPA+' RPA + static local field corrections +! D_FUNCL = 'UTIC' Utsumi-Ichimaru <-- T-dependent +! D_FUNCL = 'VLFP' Vlasov-Fokker-Planck <-- damping +! * FLAG : current index of the omega loop calling this subroutine +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOURTH +! + USE LF_VALUES, ONLY : LANDAU +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,RS,T + REAL (WP) :: D ! dopant concentration + REAL (WP) :: EPSR,EPSI + REAL (WP) :: XC,U0,W +! + INTEGER :: FLAG +! +! Computing the dielectric function +! + IF(D_FUNCL.EQ.'ARBR') THEN ! + CALL ARBR_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'ATAS') THEN ! + CALL ATAS_EPS_D_LG_3D(X,Z,T,RS,FLAG,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'BLZ1') THEN ! + CALL BLZ1_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'BLZ2') THEN ! + CALL BLZ2_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'DACA') THEN ! + CALL DACA_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'GOTZ') THEN ! + CALL GOTZ_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'HEAP') THEN ! + CALL HEAP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'HAFO') THEN ! + CALL HAFO_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'HUCO') THEN ! + CALL HUCO_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'HYDR') THEN ! + CALL HYDR_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'KLEI') THEN ! + CALL KLEI_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'KLKD') THEN ! + CALL KLKD_EPS_D_LG_3D(X,Z,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'KLKN') THEN ! + CALL KLKN_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'LAND') THEN ! + CALL LAND_EPS_D_LG_3D(X,Z,XC,U0,W,D,RS,LANDAU,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'LVL1') THEN ! + CALL LVL1_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'LVL2') THEN ! + CALL LVL2_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'MEM2') THEN ! + CALL MEM2_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'MEM3') THEN ! + CALL MEM3_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'MER1') THEN ! + CALL MER1_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'MER2') THEN ! + CALL MER2_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'MER+') THEN ! + CALL MERP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'MSAP') THEN ! + CALL MSAP_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'NEV2') THEN ! + CALL NEV2_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'NEV3') THEN ! + CALL NEV3_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'PLPO') THEN ! + CALL PLPO_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'RDF1') THEN ! + CALL RDF1_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'RDF2') THEN ! + CALL RDF2_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'RPA1') THEN ! + CALL RPA1_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'RPA2') THEN ! + CALL RPA2_EPS_D_LG_3D(X,Z,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'RPA+') THEN ! + CALL RPAP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'UTIC') THEN ! + CALL UTIC_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'VLFP') THEN ! + CALL VLFP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCL_DYNAMIC_3D +! +!======================================================================= +! + SUBROUTINE ARBR_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) +! +! This subroutine computes Arista-Brandt expression +! for the longitudinal temperature-dependent +! dielectric function EPS(q,omega,T) in 3D systems. +! +! References: (1) N. R. Arista and W. Brandt, Phys. Rev. A 29, +! 1471-1480 (1984) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOUR,& + FOURTH,EIGHTH,SMALL,INF + USE CONSTANTS_P1, ONLY : BOHR,K_B + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI +! + USE CHEMICAL_POTENTIAL, ONLY : MU_T + USE SPECIFIC_INT_8 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: X2,X3,Y,U + REAL (WP) :: KBT,D,THETA,ETA + REAL (WP) :: CHI0_2 + REAL (WP) :: UPX,UMX + REAL (WP) :: G_UPX,G_UMX + REAL (WP) :: ENU,EDE,NUM,DEN + REAL (WP) :: LN + REAL (WP) :: MAX_EXP,MIN_EXP +! + REAL (WP) :: ABS,EXP,LOG +! +! Computing the max and min value of the exponent of e^x +! +! + CALL MINMAX_EXP(MAX_EXP,MIN_EXP) ! +! + X2 = X * X ! + X3 = X2 * X ! + Y = X + X ! q / k_F + U = X * Z ! U = omega / (q v_F) +! + KBT = K_B * T ! + THETA = KBT / EF_SI ! 1 / degeneracy + D = ONE / THETA ! degeneracy + ETA = MU_T('3D',T) / KBT ! +! + CHI0_2 = ONE / (PI * KF_SI * BOHR) ! ref. (1) eq. (4) +! + UPX = U + X ! + UMX = U - X ! +! + IF(ABS(UMX) <= SMALL) UMX = 0.01E0_WP ! +! +! Computing the integrals involved in the real part +! + CALL INT_ARB(UPX,D,ETA,G_UPX) ! + CALL INT_ARB(UMX,D,ETA,G_UMX) ! +! + EPSR = ONE + FOURTH * CHI0_2 * (G_UPX - G_UMX) / X3 ! ref. (1) eq. (7) +! +! Computing the imaginary part +! + ENU = ETA - D * (UMX)**2 ! exponent of numerator + EDE = ETA - D * (UPX)**2 ! exponent of denominator +! +! Numerator of Log +! + IF(ENU >= ZERO) THEN ! + IF(ENU < MAX_EXP) THEN ! + NUM = ONE + EXP(ENU) ! + ELSE ! + NUM = INF ! + END IF ! + ELSE ! + IF(ENU > MIN_EXP) THEN ! + NUM = ONE + EXP(ENU) ! + ELSE ! + NUM = ONE ! + END IF ! + END IF ! +! +! Denominator of Log +! + IF(EDE >= ZERO) THEN ! + IF(EDE < MAX_EXP) THEN ! + DEN = ONE + EXP(EDE) ! + ELSE ! + DEN = INF ! + END IF ! + ELSE ! + IF(EDE > MIN_EXP) THEN ! + DEN = ONE + EXP(EDE) ! + ELSE ! + DEN = ONE ! + END IF ! + END IF ! +! +! Computing the Log +! + IF(ENU /= INF .AND. EDE /= INF) THEN ! + LN = LOG(NUM/DEN) ! + ELSE IF(ENU /= INF .AND. EDE == INF) THEN ! + LN = LOG( EXP(- EDE) + EXP(ENU - EDE) ) ! + ELSE IF(ENU == INF .AND. EDE /= INF) THEN ! + LN = - LOG( EXP(- ENU) + EXP(EDE - ENU) ) ! + ELSE IF(ENU == INF .AND. EDE == INF) THEN ! + LN = ENU - EDE ! + END IF ! +! + EPSI = EIGHTH * PI * CHI0_2 * THETA * LN / X3 ! ref. (1) eq. (23) +! + END SUBROUTINE ARBR_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE ATAS_EPS_D_LG_3D(X,Z,T,RS,FLAG,EPSR,EPSI) +! +! This subroutine computes Arkhipov et al parametrization +! for the longitudinal temperature-dependent Atwal-Ashcroft +! dielectric function EPS(q,omega,T) in 3D systems. +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 90, 053102 (2014) +! (2) G. S. Atwal and N. W. Ashcroft, Phys. Rev. B 65, 115109 (2002) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * T : temperature (SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! * FLAG : current index of the omega loop calling this subroutine +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Warning: the subroutine is suppose to be called in a omega-loop +! starting from omega ~ zero. During the first run of +! the subroutine, it will store Pi_mu(q,omega=0) for further use +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR, & + HALF,FOURTH + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,EPS_0,K_B + USE FERMI_SI, ONLY : EF_SI,KF_SI,VF_SI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE EXT_FUNCTIONS, ONLY : FDP1P5 + USE CHEMICAL_POTENTIAL, ONLY : MU + USE COULOMB_K, ONLY : COULOMB_FF +! + USE UNITS, ONLY : UNIT +! + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,T,RS,U,GM + REAL (WP) :: D,NU,ITA,VC + REAL (WP) :: Q_SI + REAL (WP) :: K0,K2,K4,N0,XSI,OM + REAL (WP) :: EPSR,EPSI +! + REAL (WP) :: DREAL,DIMAG +! + COMPLEX (WP) :: S1,S2,W + COMPLEX (WP) :: G11,G12,G31,G32,G51,G52 + COMPLEX (WP) :: PP0,PP2,PP4 + COMPLEX (WP) :: PI0Q,PI2Q,PI4Q + COMPLEX (WP) :: B0,B2,B4,D2,D4 + COMPLEX (WP) :: EQO,FQO +! + INTEGER :: FLAG +! + Q_SI = TWO * X * KF_SI ! q in SI +! + CALL COULOMB_FF('3D',UNIT,Q_SI,ZERO,VC) ! Coulomb pot. +! + NU = ONE / TAU ! collision freq. + U = X * Z ! omega / (q * v_F) + GM = NU / (Q_SI * VF_SI) ! gamma + D = EF_SI / (K_B*T) ! + ITA = MU('3D',T) / (K_B*T) ! +! +! Computing the electron density +! + N0 = RS_TO_N0('3D',RS) ! +! + S1 = U + X + IC * GM ! sigma_1 + S2 = U - X + IC * GM ! sigma_2 +! + OM = Z * H_BAR * Q_SI * Q_SI * HALF / M_E ! omega in SI + XSI = OM * NU * M_E / (N0 * Q_SI *Q_SI) ! + W = OM + IC * NU ! +! +! Computing the G_l(sigma) functions +! + G11 = G1(S1,D,ITA) ! + G12 = G1(S2,D,ITA) ! + G31 = G3(S1,D,ITA) ! ref. 1 eq. (40) + G32 = G3(S2,D,ITA) ! + G51 = G5(S1,D,ITA) ! + G52 = G5(S2,D,ITA) ! +! +! Computing the polarization operators PPx +! + K0 = THREE * M_E * N0 / (FOUR*X*H_BAR*H_BAR*KF_SI*KF_SI) ! + K2 = M_E * N0 / (H_BAR * H_BAR) ! + K4 = M_E * N0 * KF_SI * KF_SI / (H_BAR * H_BAR) ! +! + PP0 = K0 * (G11 - G12) ! ref. 1 eq. (37) +! + PP2=K2*( FOURTH*(TWO+THREE*X*(G11-G12)) - & ! + HALF*(THREE*(S1*G11+S2*G12)) + & ! ref. 1 eq. (38) + FOURTH*(THREE*(G31-G32)/X) & ! + ) ! +! + PP4 = K4*( TWO*(THREE*FDP1P5(ITA) / D**2.5E0_WP - TWO*X*U)+ & ! + THREE*FOURTH*(G51-G52)/X + & ! + THREE*HALF*(THREE*X*(G31-G32)) - & ! + THREE*(S1*G31+S2*G32) + & ! ref. 1 eq. (39) + THREE*FOURTH*X*X*X*(G11-G12) - & ! + THREE*X*(S1*S1*G11-S2*S2*G12) - & ! + THREE*X*X*(S1*G11+S2*G12) & ! + ) ! +! +! Computing the coefficients Bs and Ds +! + IF(FLAG == 1) THEN ! + PI0Q = PP0 ! + PI2Q = PP2 ! + PI4Q = PP4 ! + END IF ! +! + B0 = - PI0Q ! + B2 = - PI2Q ! + B4 = - PI4Q ! + D2 = (IC * NU * PI2Q - OM * B2) / W ! + D4 = (IC * NU * PI4Q - OM * B4) / W ! +! +! Computing the functions E(q,omega) and F(q,omega) +! + EQO = - IC*NU*PP2*( (PP2*B0-PP0*B2)/(D4*B0-B2*D2) )/OM ! + FQO = IC*NU*( (D2*PP2-D4*PP0-IC*XSI*PP2*(PP2*B0-PP0*B2)) /& ! + (D4*B0-B2*D2) - ONE & ! + ) / OM + IC*XSI*PP0 ! +! +! Computing the dielectric function +! + EPSR = ONE + VC * REAL( (PP0 + EQO) / (ONE + FQO) ) ! + EPSI = VC * AIMAG( (PP0 + EQO) / (ONE + FQO) ) ! +! + END SUBROUTINE ATAS_EPS_D_LG_3D +! +!======================================================================= +! + FUNCTION G1(S,D,ETA) +! +! This function computes Arkhipov et al G1 function +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 90, 053102 (2014) +! +! Input parameters: +! +! * S : sigma +! * D : D +! * ETA : eta +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ONE,TWO + USE COMPLEX_NUMBERS, ONLY : IC + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + REAL (WP) :: D,ETA + REAL (WP) :: Y,Y_MAX,Y1 + REAL (WP) :: F(NZ_MAX),G(NZ_MAX) + REAL (WP) :: SR,SI,A,B,RLN,ILN,RIN,IIN + REAL (WP) :: H +! + REAL (WP) :: FLOAT,REAL,AIMAG,LOG + REAL (WP) :: SQRT,ATAN,EXP +! + COMPLEX (WP) :: G1,S +! + INTEGER :: J,ID +! + Y_MAX = 100.0E0_WP ! max of y + H = Y_MAX / FLOAT(NZ_MAX - 1) ! y-step + ID = 1 ! +! +! Setting up the grid Y and the integrand functions +! F(I) and G(I) +! +! F(I) : real part of integrand +! G(I) : imaginary part of integrand +! +! Here, we make use of the fact that, if z = a + i b +! +! Ln(z) = ln|z| + r atan(b/a) +! +! Notation: SR = Re [ sigma ] +! SI = Im [ sigma ] +! A = Re[ (sigma + y)/(sigma-y) ] +! B = Im[ (sigma + y)/(sigma-y) ] +! + DO J = 1, NZ_MAX ! +! + Y = FLOAT(J - 1) * Y_MAX / FLOAT(NZ_MAX - 1) ! + Y1 = Y ! + SR = REAL(S) ! + SI = AIMAG(S) ! + A = (SR*SR + SI*SI - Y*Y) / ((SR-Y) * (SR-Y) + SI*SI) ! + B = - TWO * SI * Y ! + RLN = LOG( SQRT(A * A + B * B) ) ! + ILN = ATAN(B / A) ! + F(J) = Y1 * RLN / (EXP(D * Y * Y - ETA) + ONE) ! + G(J) = Y1 * ILN / (EXP(D * Y * Y - ETA) + ONE) ! +! + END DO ! +! +! Performing the integrations +! + CALL INTEGR_L(F,H,NZ_MAX,NZ_MAX,RIN,ID) ! + CALL INTEGR_L(G,H,NZ_MAX,NZ_MAX,IIN,ID) ! +! + G1 = RIN + IC *IIN ! +! + END FUNCTION G1 +! +!======================================================================= +! + FUNCTION G3(S,D,ETA) +! +! This function computes Arkhipov et al G3 function +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 90, 053102 (2014) +! +! Input parameters: +! +! * S : sigma +! * D : D +! * ETA : eta +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ONE,TWO + USE COMPLEX_NUMBERS, ONLY : IC + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + REAL (WP) :: D,ETA + REAL (WP) :: Y,Y_MAX,Y3 + REAL (WP) :: F(NZ_MAX),G(NZ_MAX) + REAL (WP) :: SR,SI,A,B,RLN,ILN,RIN,IIN + REAL (WP) :: H +! + REAL (WP) :: FLOAT,REAL,AIMAG,LOG + REAL (WP) :: SQRT,ATAN,EXP +! + COMPLEX (WP) :: G3,S +! + INTEGER :: J,ID +! + Y_MAX = 100.0E0_WP ! max of y + H = Y_MAX / FLOAT(NZ_MAX - 1) ! y-step + ID = 1 ! +! +! Setting up the grid Y and the integrand functions +! F(I) and G(I) +! +! F(I) : real part of integrand +! G(I) : imaginary part of integrand +! +! Here, we make use of the fact that, if z = a + i b +! +! Ln(z) = ln|z| + r atan(b/a) +! +! Notation: SR = Re [ sigma ] +! SI = Im [ sigma ] +! A = Re[ (sigma + y)/(sigma-y) ] +! B = Im[ (sigma + y)/(sigma-y) ] +! + DO J = 1, NZ_MAX ! +! + Y = FLOAT(J - 1) * Y_MAX / FLOAT(NZ_MAX - 1) ! + Y3 = Y * Y * Y ! + SR = REAL(S) ! + SI = AIMAG(S) ! + A = (SR*SR + SI*SI - Y*Y) / ((SR-Y) * (SR-Y) + SI*SI) ! + B = - TWO * SI * Y ! + RLN = LOG( SQRT(A * A + B * B) ) ! + ILN = ATAN(B / A) ! + F(J) = Y3 *RLN /(EXP(D * Y * Y - ETA) + ONE) ! + G(J) = Y3 *ILN /(EXP(D * Y * Y - ETA) + ONE) ! +! + END DO ! +! +! Performing the integrations +! + CALL INTEGR_L(F,H,NZ_MAX,NZ_MAX,RIN,ID) ! + CALL INTEGR_L(G,H,NZ_MAX,NZ_MAX,IIN,ID) ! +! + G3 = RIN + IC * IIN ! +! + END FUNCTION G3 +! +!======================================================================= +! + FUNCTION G5(S,D,ETA) +! +! This function computes Arkhipov et al G5 function +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 90, 053102 (2014) +! +! Input parameters: +! +! * S : sigma +! * D : D +! * ETA : eta +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Mar 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ONE,TWO + USE COMPLEX_NUMBERS, ONLY : IC + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + REAL (WP) :: D,ETA + REAL (WP) :: Y,Y_MAX,Y5 + REAL (WP) :: F(NZ_MAX),G(NZ_MAX) + REAL (WP) :: SR,SI,A,B,RLN,ILN,RIN,IIN + REAL (WP) :: H +! + REAL (WP) :: FLOAT,REAL,AIMAG,LOG + REAL (WP) :: SQRT,ATAN,EXP +! + COMPLEX (WP) :: G5,S +! + INTEGER :: J,ID +! + Y_MAX = 100.0E0_WP ! max of y + H = Y_MAX / FLOAT(NZ_MAX - 1) ! y-step + ID = 1 ! +! +! Setting up the grid Y and the integrand functions +! F(I) and G(I) +! +! F(I) : real part of integrand +! G(I) : imaginary part of integrand +! +! Here, we make use of the fact that, if z = a + i b +! +! Ln(z) = ln|z| + r atan(b/a) +! +! Notation: SR = Re [ sigma ] +! SI = Im [ sigma ] +! A = Re[ (sigma + y)/(sigma-y) ] +! B = Im[ (sigma + y)/(sigma-y) ] +! + DO J=1,NZ_MAX ! +! + Y = FLOAT(J - 1) * Y_MAX / FLOAT(NZ_MAX - 1) ! + Y5 = Y * Y * Y * Y * Y ! + SR = REAL(S) ! + SI = AIMAG(S) ! + A = (SR*SR + SI*SI - Y*Y) / ((SR-Y)*(SR-Y) + SI*SI) ! + B = - TWO * SI * Y ! + RLN = LOG( SQRT(A * A + B * B) ) ! + ILN = ATAN(B / A) ! + F(J) = Y5 * RLN /(EXP(D * Y * Y - ETA) + ONE) ! + G(J) = Y5 * ILN /(EXP(D * Y * Y - ETA) + ONE) ! + + END DO ! +! +! Performing the integrations +! + CALL INTEGR_L(F,H,NZ_MAX,NZ_MAX,RIN,ID) ! + CALL INTEGR_L(G,H,NZ_MAX,NZ_MAX,IIN,ID) ! +! + G5 = RIN + IC * IIN ! +! + END FUNCTION G5 +! +!======================================================================= +! + SUBROUTINE BLZ1_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) +! +! This subroutine computes the longitudinal Boltzmann dynamical +! dielectric function in 3D +! +! References: (1) P. Halevi, Phys. Rev. B 51, 7497-7499 (1995) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,THREE,FOUR, & + HALF + USE FERMI_SI, ONLY : EF_SI + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS + REAL (WP), INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: U,U2,V + REAL (WP) :: COEF,ENE2 +! + REAL (WP) :: LOG +! + U = X * Z ! omega / (q * v_F) + V = FOUR * U * X ! omega / omega_F + U2 = U * U ! +! + ENE2 = (V * EF_SI)**2 ! (h_bar omega)^2 + COEF = THREE * U * ENE_P_SI * ENE_P_SI / ENE2 ! +! + EPSR = ONE + COEF * ( U + HALF * U2 * LOG( & ! + ABS((U - ONE) / (U + ONE)) & ! + ) & ! + ) ! + EPSI = ZERO ! +! + END SUBROUTINE BLZ1_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE BLZ2_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) +! +! This subroutine computes the longitudinal Boltzmann dynamical +! dielectric function in 3D +! +! References: (1) R. Esquivel and V. B. Stetovoy, Phys. Rev. A 69, 062102 (2004) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PLASMON_ENE_SI + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS + REAL (WP), INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: U + REAL (WP) :: Q_SI,O_SI + REAL (WP) :: OMP,OMT + REAL (WP) :: RAT +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: UU,U3,COEF + COMPLEX (WP) :: KK,NUM,DEN + COMPLEX (WP) :: LLOG,FL +! + U = X * Z ! omega / (q * v_F) +! + Q_SI = TWO * X * KF_SI ! q in SI + O_SI = U * Q_SI * VF_SI ! omega in SI + OMP = ENE_P_SI / H_BAR ! omega_p + OMT = ONE / TAU ! omega_tau + RAT = OMT / O_SI ! omega_tau / omega +! + UU = Q_SI * VF_SI / (O_SI + IC * OMT) ! ref. (1) eq. (16) + U3 = UU * UU * UU ! +! + COEF = OMP * OMP / (O_SI * O_SI + IC * O_SI * OMT) ! + LLOG = LOG((ONE + UU) / (ONE - UU)) ! + KK = THREE / U3 ! + NUM = - UU + HALF * LLOG ! + DEN = ONE + IC * RAT * (ONE - HALF * LLOG / UU) ! +! + FL = KK * NUM / DEN ! ref. (1) eq. (15) +! + EPSR = ONE - REAL(COEF * FL, KIND=WP) ! + EPSI = AIMAG(COEF * FL) ! +! + END SUBROUTINE BLZ2_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE DACA_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes Dandrea-Ashcroft-Carlsson parametrization +! for the longitudinal temperature-dependent Arista-Brandt +! dielectric function EPS(q,omega,T) for 3D systems. +! +! References: (1) R. G. Dandrea, N. W. Ashcroft and A. E. Carlsson, +! Phys. Rev. B 34, 2097-2111 (1986) +! (2) N. R. Arista and W. Brandt, Phys. Rev. A 29, +! 1471-1480 (1984) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 21 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,FOUR,HALF,THIRD,FOURTH + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI_INV,SQR_PI + USE UTILITIES_1, ONLY : ALFA + USE LF_VALUES, ONLY : GQ_TYPE + USE LOCAL_FIELD_STATIC + USE PHI_FUNCTION +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,RS,T,U + REAL (WP) :: EPSR,EPSI + REAL (WP) :: ETA0,THETA,ALPHA + REAL (WP) :: F10,F20,U1,U2,COEF,NUM,DEN + REAL (WP) :: GQ +! + REAL (WP) :: DLOG,DEXP,DREAL,DIMAG +! + COMPLEX (WP) :: EPS +! + U=X*Z ! omega / (q * v_F) +! + THETA=K_B*T/EF_SI ! + ALPHA=ALFA('3D') ! + COEF=FOURTH*ALPHA*RS/(X*X*X) ! +! + IF(THETA < ONE) THEN ! + ETA0=EF_SI/(K_B*T) ! ref. (2) eq. (A4') + ELSE + ETA0=DLOG(FOUR*THIRD/(SQR_PI * THETA**1.5E0_WP)) ! ref. (2) eq. (A5') + END IF ! +! + U1=U+X ! + U2=U-X ! +! + F10=COEF*PI_INV*(PHI(U1,THETA)-PHI(U2,THETA)) ! ref. (1) eq. (4.6) +! + NUM=ONE+DEXP(ETA0 - U2*U2/THETA) ! + DEN=ONE+DEXP(ETA0 - U1*U1/THETA) ! + F20=-HALF*COEF*THETA*DLOG(NUM/DEN) ! ref. (1) eq. (4.7) +! +! Calling the local-field correction +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ) ! +! + EPS=(ONE-F10-IC*F20)/(ONE+GQ*F10+IC*GQ*F20) ! +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE DACA_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE GOTZ_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) +! +! This subroutine computes the Götze memory function approach, +! which can be considered as a generalization of the Mermin's +! dielectric function. +! +! References: (1) F. Yoshida and S. Takeno, Phys. Rep. 173, +! 301-381 (1989) +! (2) H. B. Nersiyan and A. K. Das, Phys. Rev. E 69, +! 046404 (2004) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * T : temperature (SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! * V : dimensionless factor --> V = h_bar omega / E_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Note: We use the eq. (10) of ref. (2): V_C chi = - COEF1 * V_C * (f_1 + i f_2) +! to obtain CHI_ = - COEF1 * (f_1 + i f_2) +! +! Then, the exact CHI is obtained from ref. (1): +! CHI = COEF2 * CHI_ +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE MATERIAL_PROP, ONLY : DMN + USE UNITS, ONLY : UNIT +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,EIGHT,HALF + USE COMPLEX_NUMBERS, ONLY : ONEC,IC + USE PI_ETC, ONLY : PI,PI_INV + USE CONSTANTS_P1, ONLY : BOHR,H_BAR + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE COULOMB_K, ONLY : COULOMB_FF +! + USE UNITS, ONLY : UNIT +! + USE DF_VALUES, ONLY : MEM_TYPE,ALPHA,BETA + USE LF_VALUES, ONLY : GQ_TYPE +! + USE DFUNC_STATIC, ONLY : RPA1_EPS_S_LG + USE LOCAL_FIELD_STATIC + USE DAMPING_SI + USE DAMPING_VALUES, ONLY : PCT + USE MEMORY_FUNCTIONS_F +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,T,RS + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: EPS0R,EPS0I + REAL (WP) :: GQ,CHI_0,CHI_Q + REAL (WP) :: NUM,DEN + REAL (WP) :: COEF1,COEF2 + REAL (WP) :: Q_SI,VC,CHI2 + REAL (WP) :: U,V,X2,X3 + REAL (WP) :: MEM + REAL (WP) :: GAMMA,GAMMA2 + REAL (WP) :: UP,UM,UP2,UM2 + REAL (WP) :: Y1P,Y2P,Y1M,Y2M + REAL (WP) :: F1,F2 + REAL (WP) :: REPSM1,IEPSM1 + REAL (WP) :: REPS00 +! + REAL (WP) :: LOG,ATAN,REAL,AIMAG +! + COMPLEX (WP) :: NUMI,DENI + COMPLEX (WP) :: CHI,EPS + COMPLEX (WP) :: MEMO +! + X2 = X * X ! + X3 = X2 * X ! +! + U = X * Z ! omega / (q * v_F) + V = FOUR * U * X ! h_bar omega / E_F + CHI2 = PI_INV / (KF_SI * BOHR) ! + COEF1 = CHI2 / X2 ! +! +! Computation of the coefficient chi(0) / chi_0(0) +! +! + Q_SI = TWO * X * KF_SI ! q in SI +! +! Computing the Coulomb potential VC +! + CALL COULOMB_FF(DMN,UNIT,Q_SI,ZERO,VC) ! Coulomb pot. +! +! Computing the static dielectric function and +! the static local field correction +! + CALL RPA1_EPS_S_LG(X,'3D',EPS0R,EPS0I) + CALL LFIELD_STATIC(X,RS,T,GQ_TYPE,GQ) ! +! + CHI_0 = (ONE - EPS0R) / VC ! +! + NUM = CHI_0 ! + DEN = ONE + VC * (GQ - ONE) * CHI_0 ! + CHI_Q = NUM / DEN ! +! + COEF2 = CHI_Q / CHI_0 ! + coef2 = one +! +! Computation of the memory function +! + MEMO = MEMORY_F(V,TAU,TAU2,PCT,ALPHA,BETA,MEM_TYPE) ! + MEM = TWO * PI * REAL(MEMO,KIND=WP) ! +! + GAMMA = H_BAR * MEM / (FOUR * EF_SI) ! + GAMMA2 = GAMMA * GAMMA ! +! + UP = U + X ! U_+ + UM = U - X ! U_- +! + UP2 = UP * UP ! + UM2 = UM * UM ! +! + NUM = X2 * (UP + ONE) * (UP + ONE) + GAMMA2 ! + DEN = X2 * (UP - ONE) * (UP - ONE) + GAMMA2 ! ref. (2) eq. (13) + Y1P = LOG(NUM / DEN) ! Y_1(z,U_+) +! + NUM = X2 * (UM + ONE) * (UM + ONE) + GAMMA2 ! + DEN = X2 * (UM - ONE) * (UM - ONE) + GAMMA2 ! ref. (2) eq. (13) + Y1M = LOG(NUM / DEN) ! Y_1(z,U_-) +! + Y2P = ATAN(X * (UP - ONE) / GAMMA) - & ! ref. (2) eq. (14) + ATAN(X * (UP + ONE) / GAMMA) ! Y_2(z,U_+) + Y2M = ATAN(X * (UM - ONE) / GAMMA) - & ! ref. (2) eq. (14) + ATAN(X * (UM + ONE) / GAMMA) ! Y_2(z,U_-) +! + F1 = HALF + ONE / (16.0E0_WP * X3) * ( &! + ( X2 * (UM2 - ONE) - GAMMA2 &! + ) * Y1M - &! + ( X2 * (UP2 - ONE) - GAMMA2 &! ref. (2) eq. (11) + ) * Y1P + &! + FOUR * GAMMA * X * &! + (UP * Y2P - UM * Y2M) &! + ) ! +! + F2 = ONE / (EIGHT * X3) * ( &! + GAMMA * X * (UM * Y1M - UP * Y1P) + &! + X2 * ((UM2 - ONE) - GAMMA2) * Y2M - &! ref. (2) eq. (12) + X2 * ((UP2 - ONE) - GAMMA2) * Y2P &! + ) ! +! +! Computation of EPS_{RPA}(x,u,Gamma) - 1 +! + REPSM1 = COEF1 * F1 ! ref. (2) eq. (10) + IEPSM1 = COEF1 * F2 ! +! +! Computation of EPS_{RPA}(x,0) - 1 +! + CALL RPA1_EPS_S_LG(X,'3D',EPS0R,EPS0I) +! + REPS00 = EPS0R - ONE ! +! + NUMI = (X * U + IC * GAMMA) * (REPSM1 + IC * IEPSM1) ! + DENI = X * U + IC * GAMMA * (REPSM1 + IC * IEPSM1) / REPS00 ! +! + CHI = - COEF2 * NUMI / DENI ! ref. (1) eq. (2.124) +! + EPS = ONEC / (ONEC + VC * CHI) ! + EPS = ONE + NUMI / DENI ! ref. (1) eq. (9) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE GOTZ_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE HEAP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal Hertel-Appel dynamical +! dielectric function in 3D +! +! References: (1) P. Hertel and J. Appel, Phys. Rev. B 26, 5730-5742 (1982) +! +! Note: for TAU --> infinity, we should recover the RPA values +! +! Remark: In order to simplify the equation, we introduce +! the quantities q_T and omega_T so that +! +! k_B T = h_bar^2 q_T^2 / 2m = h_bar omega_T +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF,FOURTH,TTINY + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,K_B,EPS_0 + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI,SQR_PI + USE MATERIAL_PROP, ONLY : MSOM,EPS_B + USE PLASMON_ENE_SI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE EXT_FUNCTIONS, ONLY : WOFZ + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: U,KBT,QT + REAL (WP) :: A,C + REAL (WP) :: Q_SI,OM_P,OM_Q,OM_T,OME,TOM + REAL (WP) :: XR1,XR2,XI1,BR1,BI1,BR2,BI2 + REAL (WP) :: MASS_E +! + REAL (WP) :: SQRT,REAL,AIMAG +! + LOGICAL :: FLAG +! + COMPLEX (WP) :: BQOT,BQ0I,Z12,Z22 + COMPLEX (WP) :: NUM,DEN,EPS +! + U = X * Z ! omega / (q * v_F) +! + MASS_E = M_E * MSOM ! effective mass + KBT = K_B * T ! +! + Q_SI = TWO * X * KF_SI ! q in SI + QT = SQRT(TWO * MASS_E * KBT) / H_BAR ! +! + OM_P = ENE_P_SI / H_BAR ! omega_p + OM_Q = HALF * H_BAR * Q_SI * Q_SI / MASS_E ! omega_q + OM_T = HALF * H_BAR * QT * QT / MASS_E ! omega_T +! + OME = U * Q_SI * VF_SI ! omega + TOM = TAU * OME ! tau * omega +! + KBT = K_B * T ! +! + C = FOURTH * OM_P * OM_P / (OM_Q * OM_T * SQR_PI) ! see notes +! + XR1 = (U + X) * KF_SI / QT ! \ + XR2 = (U - X) * KF_SI / QT ! > see notes + XI1 = MASS_E / (H_BAR * Q_SI * QT * TAU) ! / +! +! Computing B(q,omega,tau) +! +! Calling Faddeeva function W(z) = exp(-z^2) * [ 1 - erf(-iz) ] +! +! Here, from ref. (1) eq. (28): w(z) = exp(-z^2) - W(z) +! + CALL WOFZ(XR1,XI1,BR1,BI1,FLAG) ! + CALL WOFZ(XR2,XI1,BR2,BI2,FLAG) ! +! + Z12 = (XR1 + IC * XI1) * (XR1 + IC * XI1) ! + Z22 = (XR2 + IC * XI1) * (XR2 + IC * XI1) ! +! +! w(z1) - w(z2) = W(z2) - W(z1) + exp(-z1^2) - exp(-z2^2) +! +! + BQOT = - IC * PI * C * ( BR2 + IC * BI2 - BR1 - IC * BR1 + & ! ref. (1) eq. (27) + EXP(- Z12) - EXP(- Z22) ) ! +! +! Computing B(q,0,inf) +! + XR1 = X * KF_SI / QT + XR2 = - XR1 + XI1 = ZERO +! + CALL WOFZ(XR1,XI1,BR1,BI1,FLAG) ! + CALL WOFZ(XR2,XI1,BR2,BI2,FLAG) ! +! + Z12 = (XR1 + IC * XI1) * (XR1 + IC * XI1) ! z1^2 + Z22 = (XR2 + IC * XI1) * (XR2 + IC * XI1) ! z2^2 +! +! w(z1) - w(z2) = W(z2) - W(z1) + exp(-z1^2) - exp(-z2^2) +! + BQ0I = - IC * PI * C * ( BR2 + IC * BI2 - BR1 - IC * BR1 + & ! ref. (1) eq. (27) + EXP(- Z12) - EXP(- Z22) ) ! +! + NUM = (ONE + IC / TOM) * BQOT ! + DEN = ONE + IC * BQOT / (TOM * BQ0I) ! +! + EPS = ONE + NUM / DEN ! ref. (1) eq. (21) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE HEAP_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE HAFO_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! Hartree-Fock dielectric function +! +! References: (1) V. D. Gorobchenko, V. N. Kohn and E. G. Maksimov, +! in "Modern Problems in Condensed Matter" Vol. 24, +! L. V. Keldysh, D. A. Kirzhnitz and A. A. Maradudin ed. +! pp. 87-219 (North-Holland, 1989) +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Note: in ref. (1), omega is in unit of E_F/h_bar and q in unit of k_F +! +! Therefore: omega/q in ref. (1) is given in SI by 2 * omega / (q * v_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP) :: X,Y,Z,RS,Y2,U + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q0R,Q0I,ALPHA,Z1,Z2 + REAL (WP) :: COEF,LN1,LN2 +! + REAL (WP) :: DLOG,DABS,DREAL,DIMAG +! + COMPLEX (WP) :: EPS +! + ALPHA=ALFA('3D') ! +! + Y=X+X ! Y = q / k_F + Y2=Y*Y ! +! + U=X*Z ! omega / (q * v_F) +! + Z1=X+U ! + Z2=X-U ! + COEF=TWO*PI_INV*ALPHA*RS ! + LN1=DLOG(DABS(ONE+Z1)/(ONE-Z1)) ! + LN2=DLOG(DABS(ONE+Z2)/(ONE-Z2)) ! +! + Q0R=COEF*(ONE + HALF*(ONE-Z1*Z1)*LN1/Y + & ! ref. (1) eq. (3.2) + HALF*(ONE-Z2*Z2)*LN2/Y) ! +! + IF(U < (ONE-X)) THEN ! +! + Q0I=TWO*ALPHA*RS*U/Y2 ! ref. (1) eq. (3.3) +! + ELSE ! +! + IF( (U <= (ONE+U)) .AND. (U >= DABS(ONE-U)) ) THEN ! + Q0I=ALPHA*RS*(ONE - (X-U)**2)/(Y2*Y) ! ref. (1) eq. (3.3) + ELSE ! + Q0I=ZERO ! ref. (1) eq. (3.3) + END IF ! +! + END IF ! +! + EPS=ONE/(ONE-Q0R-IC*Q0I) ! ref. (1) eq. (3.1) +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE HAFO_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE HUCO_EPS_D_LG_3D(X,Z,EPSR,EPSI) +! +! This subroutine computes the Hu-O'Connell dielectric function that +! including damping effect through electron-electron and electron-impurity +! fluctuation, leading to a diffusion coefficient D, for 3D systems +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = hbar omega / E_F +! +! +! Output variables : +! +! * EPSR : real part of the dielectric function at q +! * EPSI : imaginary part of the dielectric function at q +! +! Reference : (1) G. Y. Hu and R. F. O'Connell, Phys. Rev. B 40, 3600-3604 (1989) +! +! +! Author : D. Sébilleau +! +! Last modified : 13 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,EIGHT, & + HALF,FOURTH,EIGHTH + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z + REAL (WP), INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: Q_SI,KTF_SI + REAL (WP) :: K2Q2 + REAL (WP) :: COEF,KOEF + REAL (WP) :: U,B,NUP,NUM + REAL (WP) :: NP2,NM2 + REAL (WP) :: BX,B2X2 + REAL (WP) :: OPNP,OMNP + REAL (WP) :: OPNM,OMNM + REAL (WP) :: OBXP,OBXM + REAL (WP) :: LOGP,LOGM + REAL (WP) :: TOPP,TOMP + REAL (WP) :: TOPM,TOMM +! + REAL (WP) :: LOG,ATAN +! + U = X * Z ! omega / (q * v_F) + Q_SI = TWO * KF_SI * X ! q in SI +! +! Computing the Thomas-Fermi vector +! + CALL THOMAS_FERMI_VECTOR('3D',KTF_SI) ! +! + K2Q2 = KTF_SI * KTF_SI / (Q_SI * Q_SI) ! +! + COEF = HALF * K2Q2 ! coeff. of real part + KOEF = K2Q2 / (EIGHT * X) ! coeff. of imag part +! +! Setting the Hu-O'Connell parameters +! + B = TWO * M_E * DIF / H_BAR ! \ + NUP = X + U ! > ref. (1) eq. (8) + NUM = X - U ! / +! + B = HALF + NP2 = NUP * NUP ! + NM2 = NUM * NUM ! +! + OPNP = ONE + NUP ! + OMNP = ONE - NUP ! + OPNM = ONE + NUM ! + OMNM = ONE - NUM ! +! + BX = B * X ! + B2X2 = BX * BX ! +! + LOGP = LOG( ABS( (OPNP**2 + B2X2) / (OMNP**2 + B2X2) ) ) ! + LOGM = LOG( ABS( (OPNM**2 + B2X2) / (OMNM**2 + B2X2) ) ) ! +! + OBXP = ONE + B2X2 - NP2 ! + OBXM = ONE + B2X2 - NM2 ! +! + TOPP = OPNP / BX ! \ + TOMP = OMNP / BX ! | arguments of + TOPM = OPNM / BX ! | arctan[ ] + TOMM = OMNM / BX ! / +! +! Real part of epsilon +! + EPSR = ONE + COEF * ( ONE + EIGHTH / X * ( & ! + OBXP * LOGP + OBXM * LOGM & ! + ) & ! + - HALF * B * ( & ! ref. (1) es. (7) + NUP * ( ATAN(TOMP) + ATAN(TOPP) ) & ! + + NUM * ( ATAN(TOMM) + ATAN(TOPM) ) & ! + ) & ! + ) ! +! +! Imaginary part of epsilon +! + EPSI= KOEF * ( & ! + OBXM * ( ATAN(TOMM) + ATAN(TOPM) ) & ! + - OBXP * ( ATAN(TOMP) + ATAN(TOPP) ) & ! + + BX * ( & ! ref. (1) es. (9) + NUM * LOGM - NUP * LOGP & ! + ) & ! + ) ! +! + END SUBROUTINE HUCO_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE HYDR_EPS_D_LG_3D(X,Z,RS,EPSR,EPSI) +! +! This subroutine computes the longitudinal hydrodynamic dynamical +! dielectric function in 3D +! +! References: (1) R. Esquivel-Sirvent and G. C. Schatz, +! J. Phys. Chem. C 116, 420-424 (2011) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THIRD + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PLASMON_ENE_SI + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,RS,U + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,O_SI + REAL (WP) :: O_PL,GAMMA +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EPS,BETA2,NUM,DEN +! + U = X * Z ! omega / (q * v_F) +! + Q_SI = TWO * X * KF_SI ! q in SI + O_SI = U * Q_SI * VF_SI ! omega in SI + O_PL = ENE_P_SI / H_BAR ! omega_p in SI +! + GAMMA = ONE / TAU ! +! + NUM = 0.20E0_WP * THIRD * O_SI + IC * THIRD * GAMMA ! + DEN = O_SI + IC * GAMMA ! + BETA2 = VF_SI * VF_SI * NUM / DEN ! +! + EPS = ONE - O_PL * O_PL / (O_SI * DEN - BETA2 * Q_SI * Q_SI) ! ref. (1) eq. (6) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE HYDR_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE KLEI_EPS_D_LG_3D(X,Z,EPSR,EPSI) +! +! This subroutine computes Kleinman longitudinal +! dielectric function EPS(q,omega,T) in 3D systems. +! +! References: (1) P. R. Antoniewicz and L. Kleinman, Phys. Rev. B2, +! 2808-2811 (1970) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Warning: there is an inhomogeneity in Kleinman's equation. His Delta (D) +! is an energy shift and should be proportional to an energy and it +! is in fact proportional to a momentum ... +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,EIGHT, & + HALF,THIRD + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI_INV + USE SCREENING_VEC2, ONLY : KLEINMAN_VECTOR +! + IMPLICIT NONE +! + REAL (WP) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: A,B,D,AL,KS_A,KS_B,Q_SI,Q2,OM + REAL (WP) :: NUM,DEN,DEN_A,DEN_B,KK,K2,K3,AA + REAL (WP) :: A1,A2,A3 + REAL (WP) :: CHI1P,CHI1M,CHI2P,CHI2M +! + REAL (WP) :: EXP,LOG,ABS +! + COMPLEX (WP) :: EPS,CHIP,CHIM,G1,G2,G3 +! + COMPLEX (WP) :: CONJG +! + Q_SI = TWO * X * KF_SI ! q in SI + OM = Z * H_BAR * Q_SI * Q_SI * HALF / M_E ! omega in SI +! + Q2 = Q_SI * Q_SI ! + K2 = KF_SI * KF_SI ! + K3 = K2 * KF_SI ! +! + AL = HALF * (ONE + EXP(-X)) ! ref. 1 eq. (21) +! +! Computation of the screening vectors KS +! + CALL KLEINMAN_VECTOR('3D',X,1,KS_A) ! for coef A + CALL KLEINMAN_VECTOR('3D',X,2,KS_B) ! for coef B +! + NUM = Q2 ! + DEN_A = TWO * AL * KF_SI * KF_SI + KS_A * KS_A ! + DEN_B = TWO * AL * KF_SI * KF_SI + KS_B * KS_B + Q2 ! + A = HALF * NUM / DEN_A ! ref. 1 eq. (2) + B = HALF * NUM / DEN_B ! ref. 1 eq. (3) + D = EIGHT * THIRD * PI_INV * K3 * (A - B) / Q2 ! ref. 1 eq. (7) +! + KK = TWO / (Q2 * Q_SI) ! +! +! Chi(q,+omega) +! + AA = Q2 + D + OM ! + NUM = AA + TWO * Q_SI * KF_SI ! + DEN = AA - TWO * Q_SI * KF_SI ! +! + CHI1P = KK * PI_INV * ( (K2 - (HALF * AA / Q_SI)**2) * & ! real part + LOG(ABS(NUM / DEN)) + & ! + KF_SI * AA / Q_SI & ! ref. 1 eq. (5) + ) ! +! + A1 = - (Q2 + TWO * Q_SI * KF_SI) ! + A2 = OM + D ! + A3 = TWO * Q_SI * KF_SI * Q2 ! +! + IF( (A1 < A2) .AND. (A2 < A3) ) THEN ! + CHI2P = KK * (K2 - (HALF * AA / Q_SI)**2) ! imaginary part + ELSE ! + CHI2P = ZERO ! ref. 1 eq. (5) + END IF ! +! +! Chi(q,-omega) +! + AA = Q2 + D - OM ! + NUM = AA + TWO * Q_SI * KF_SI ! + DEN = AA - TWO * Q_SI * KF_SI ! +! + CHI1M = KK * PI_INV *( (K2 - (HALF * AA / Q_SI)**2) * & ! real part + LOG(ABS(NUM / DEN)) + & ! + KF_SI * AA / Q_SI & ! ref. 1 eq. (5) + ) ! +! + A2 = - OM + D ! +! + IF( (A1 < A2) .AND. (A2 < A3) ) THEN ! + CHI2M = KK * (K2 - (HALF * AA / Q_SI)**2) ! imaginary part + ELSE ! + CHI2M = ZERO ! + END IF ! +! + CHIP = CHI1P - IC * CHI2P ! ref. 1 eq. (4) + CHIM = CHI1M - IC * CHI2M ! ref. 1 eq. (4) +! +! Computing the dielectric function +! + G1 = CHIP + CONJG(CHIM) ! + G2 = CHIP * CHIP + CONJG(CHIM) * CONJG(CHIM) ! + G3 = CHIP * CONJG(CHIM) ! +! + EPS = ONE + HALF * G1 / ( ONE - HALF * & ! + (A * G2 + TWO * B * G3) / G1 & ! ref. 1 eq. (1) + ) ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE KLEI_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE KLKD_EPS_D_LG_3D(X,Z,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal Klimontovich-Kraeft +! dynamical dielectric function in 3D +! +! This result is valid in the highly degenerate case +! +! References: (1) W.-D. Kraeft, D. Kremp, W. Ebeling and G. Röpke, +! "Quantum Statistics of Charged Particle Systems", +! (Plenum Press, 1986) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * T : temperature (SI) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Note: We rewrite m*omega/q +/- h_bar*q/2 as +! +! m*v_F * ( U +/- X) +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : EF_SI,KF_SI,VF_SI + USE PI_ETC, ONLY : PI,PI2 + USE COULOMB_K, ONLY : COULOMB_FF +! + USE UNITS, ONLY : UNIT +! + IMPLICIT NONE +! + REAL (WP) :: X,X2,Z,T,U,U2 + REAL (WP) :: EPSR,EPSI + REAL (WP) :: BETA,VC,Q_SI,TF,O_SI + REAL (WP) :: CR,CI,C2,PIR,PII + REAL (WP) :: A,BP,BM +! + REAL (WP) :: DLOG,DEXP +! + X2=X*X ! +! + U=X*Z ! omega / (q * v_F) + U2=U*U ! +! + BETA=ONE/(K_B*T) ! +! + Q_SI=TWO*X*KF_SI ! q in SI + O_SI=U*Q_SI*VF_SI ! omega in SI +! + CALL COULOMB_FF('3D',UNIT,Q_SI,ZERO,VC) ! Coulomb potential +! + TF=EF_SI/K_B ! Fermi temperature +! + CR=M_E*KF_SI/(FOUR*PI2*H_BAR*H_BAR*X) ! + CI=M_E*M_E/(TWO*PI*H_BAR*H_BAR*H_BAR*H_BAR*BETA*Q_SI) ! + C2=CI*O_SI*BETA ! +! + A=PI2 * (T/TF) /(BETA*12.0E0_WP) ! + BP=EF_SI*(U+X)*(U+X) - EF_SI ! + BM=EF_SI*(U-X)*(U-X) - EF_SI ! +! + PIR=CR * ( TWO*X - HALF*(ONE-X2-U2)* &! + DLOG(((ONE-X)**2 - U2)/((ONE+X)**2 - U2)) +&! + X*U*DLOG(((ONE-X)**2 - X2)/((ONE+X)**2 - X2)) +&! + HALF*PI* (T/TF)**2 * ( &! ref. (1) eq. (4.91) + HALF*DLOG(((ONE-X)**2 - U2)/((ONE+X)**2 - U2)) +&! + (ONE+X)/((ONE+X)**2 - U2) - &! + (ONE-X)/((ONE-X)**2 - U2) &! + ) &! + ) ! +! + IF(U > (ONE+X)) THEN ! + PII=CI*DEXP(-BETA*A)*( DEXP(-BETA*BP) - DEXP(-BETA*BM) ) ! ref. (1) eq. (4.92) + ELSE IF(U < (ONE-X)) THEN ! + PII=CI*DEXP(BETA*A)*( DEXP(BETA*BP) - DEXP(-BETA*BM) ) - C2 ! ref. (1) eq. (4.92) + ELSE ! + PII=CI*BETA*(BM+A) + CI* ( &! + DEXP(-BETA*(A+BP)) - DEXP(BETA*(A+BM)) &! ref. (1) eq. (4.92) + ) ! + END IF ! +! + EPSR=ONE-VC*PIR ! + EPSI=PII ! +! + END SUBROUTINE KLKD_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE KLKN_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal Klimontovich-Kraeft +! dynamical dielectric function in 3D +! +! This result is valid in the nondegenerate case +! +! References: (1) W.-D. Kraeft, D. Kremp, W. Ebeling and G. Röpke, +! "Quantum Statistics of Charged Particle Systems", +! (Plenum Press, 1986) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Note: we rewrite m*omega/q +/- h_bar*q/2 as +! +! m*v_F * ( U +/- X) +! +! +! Author : D. Sébilleau +! +! Last modified : 19 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO + USE COMPLEX_NUMBERS, ONLY : ONEC + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE EXT_FUNCTIONS, ONLY : CONHYP + USE COULOMB_K, ONLY : COULOMB_FF +! + USE UNITS, ONLY : UNIT +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,T,U + REAL (WP) :: EPSR,EPSI + REAL (WP) :: BETA,COEF,GAMMA,VC,Q_SI + REAL (WP) :: AP,AM,CR,CI + REAL (WP) :: ZZRP,ZZRM + REAL (WP) :: RS,N0 +! + REAL (WP) :: DSQRT,DREAL +! + COMPLEX (WP) :: A,B,ZZCP,ZZCM + COMPLEX (WP) :: PIR,PII +! + COMPLEX (WP) :: DCMPLX +! + U=X*Z ! omega / (q * v_F) +! + BETA=ONE/(K_B*T) ! + COEF=TWO*M_E*K_B*T ! + GAMMA=TWO*PI*H_BAR/DSQRT(PI*COEF) ! +! + Q_SI=TWO*X*KF_SI ! q in SI +! + N0=RS_TO_N0('3D',RS) ! +! + CALL COULOMB_FF('3D',UNIT,Q_SI,ZERO,VC) ! Coulomb potential +! + AP=M_E*VF_SI*( U + X ) ! + AM=M_E*VF_SI*( U - X ) ! +! + CR=N0*BETA/(H_BAR*Q_SI) ! coef. of real part + CI=N0*M_E*GAMMA/(TWO*H_BAR*H_BAR*Q_SI) ! coef. of imaginary +! + A=ONEC ! parameters of + B=(1.5E0_WP,0.0E0_WP) ! 1F1(a,b;z) +! + ZZRP=-AP*AP/COEF ! + ZZRM=-AM*AM/COEF ! arguments of + ZZCP=DCMPLX(ZZRP) ! 1F1(a,b;z) + ZZCM=DCMPLX(ZZRM) ! +! + PIR=CR*( AP*CONHYP(A,B,ZZCP,0,0) - & ! ref. (1) eq. (4.71) + AM*CONHYP(A,B,ZZCM,0,0) & ! + ) ! + PII=CI*( CDEXP(ZZCP) - CDEXP(ZZCM) ) ! ref. (1) eq. (4.72) +! + EPSR=ONE-VC*DREAL(PIR) ! + EPSI=DREAL(PII) ! +! + END SUBROUTINE KLKN_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE LAND_EPS_D_LG_3D(X,Z,XC,U0,W,D,RS,LANDAU,EPSR,EPSI) +! +! This subroutine computes the dielectric function EPS(q,omega) +! in 3D systems in terms of Landau's parameters. +! +! References: (1) E. Lipparini, "Modern Many-Particle Physics - Atomic Gases, +! Quantum Dots and Quantum Fluids", World Scientific (2003) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * XC : dimensionless cut-off --> XC = q_c / (2 * k_F) +! * U0 / A : bare interaction constant / hard sphere radius (in SI) +! * W : half bandwidth for bare particle +! * D : filling (dopant concentration) +! * RS : dimensionless factor +! * LANDAU : model chosen for the calculation of the parameters +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE, & + HALF,THIRD + USE COMPLEX_NUMBERS, ONLY : ONEC,IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,EPS_0 + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI,PI2 + USE LANDAU_PARAM +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: LANDAU +! + REAL (WP) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,XC,U0,W,D,RS + REAL (WP) :: U,NU0,TH,V_C + REAL (WP) :: F0S,F0A,F1S,F1A,F2S,F2A +! + REAL (WP) :: DLOG,DABS,DREAL,DIMAG +! + COMPLEX (WP) :: EPS,CHIS,OM00,OM20,OM22 + COMPLEX (WP) :: NUM,DEN,NU1,DE1 +! + COMPLEX (WP) :: DCMPLX +! + U=X*Z ! omega / (q * v_F) + Q_SI=TWO*X*KF_SI ! q in SI + NU0=M_E*KF_SI/(PI2*H_BAR*H_BAR) ! DoS at Fermi level +! +! Computing the Coulomb potential +! + V_C=E*E/(EPS_0*Q_SI*Q_SI) ! +! +! Computing Landau's parameters +! + CALL LANDAU_PARAMETERS_3D(X,XC,U0,W,D,RS,LANDAU, & ! + F0S,F0A,F1S,F1A,F2S,F2A) ! +! +! Computing the Omega_{l,l} parameters +! + IF(ONE.GT.U) THEN ! + TH=HALF*PI*U ! + ELSE ! + TH=ZERO ! + ENDIF ! + OM00=ONE + HALF*U*DLOG(DABS((U-ONE)/(U+ONE))) + IC*TH ! + OM20=HALF + HALF*(THREE*U*U-ONE)*OM00 ! ref. 1 eq. (8.14) + OM22=0.20E0_WP+HALF*(THREE*U*U-ONE)*OM20 ! +! +! Computation of the density-density response function +! + NU1=TWO*(ONE+THIRD*F1S)*(ONE+0.2E0_WP*F2S)*OM20 ! + DE1=THREE*(OM00+F2S*(OM22*OM00-OM20*OM20)) ! + NUM=DCMPLX(THIRD*NU0*(ONE+THIRD*F1S)) ! + DEN=U*U - THIRD*(ONE+THIRD*F1S)*(ONE+F0S) - NU1/DE1 ! + CHIS=NUM/DEN ! ref. 1 eq. (8.23) +! + EPS=ONE/(ONE+V_C*CHIS) ! +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE LAND_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE LVL1_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) +! +! This subroutine computes the longitudinal linearized Vlasov dynamical +! dielectric function in 3D for a weakly coupled plasma +! +! References: (1) S. Ichimaru, Rev. Mod. Phys. 54, 1017-1059 (1982) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * T : temperature (SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE CONSTANTS_P1, ONLY : M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE EXT_FUNCTIONS, ONLY : W +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,T,RS,U + REAL (WP) :: EPSR,EPSI + REAL (WP) :: ZZ,Q_SI + REAL (WP) :: KD_SI +! + REAL (WP) :: DSQRT,DREAL,DIMAG +! + U=X*Z ! omega / (q * v_F) + Q_SI=TWO*X*KF_SI ! q +! +! Computation of the Debye screening vector +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + ZZ=U*VF_SI/DSQRT(K_B*T/M_E) ! argument of PDF W(zz) +! + EPSR=ONE + (KD_SI/Q_SI)**2 * DREAL(W(ZZ)) ! ref. (1) eq. (2.112) + EPSI=(KD_SI/Q_SI)**2 * DIMAG(W(ZZ)) ! +! + END SUBROUTINE LVL1_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE LVL2_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) +! +! This subroutine computes the longitudinal linearized Vlasov dynamical +! dielectric function in 3D for a strongly coupled plasma +! +! References: (1) S. Ichimaru, Rev. Mod. Phys. 54, 1017-1059 (1982) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * T : temperature (SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE CONSTANTS_P1, ONLY : M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE LF_VALUES, ONLY : GQ_TYPE + USE SF_VALUES, ONLY : SQ_TYPE + USE EXT_FUNCTIONS, ONLY : W + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE LOCAL_FIELD_STATIC +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,T,RS,U + REAL (WP) :: EPSR,EPSI + REAL (WP) :: ZZ,Q_SI,FR + REAL (WP) :: GQ,KD_SI +! + REAL (WP) :: DSQRT,DREAL,DIMAG +! + COMPLEX (WP) :: NUM,DEN +! + U=X*Z ! omega / (q * v_F) + Q_SI=TWO*X*KF_SI ! q +! +! Computation of the Debye screening vector +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + ZZ=U*VF_SI/DSQRT(K_B*T/M_E) ! argument of PDF W(zz) + FR=(KD_SI/Q_SI)**2 ! (k_D/q)^2 +! +! Computing the static local-field correction +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ) ! +! + NUM=FR*W(ZZ) !ref. (1) eq. (2.114) + DEN=ONE-NUM*GQ ! +! + EPSR=ONE + DREAL(NUM/DEN) ! + EPSI=DIMAG(NUM/DEN) ! +! + END SUBROUTINE LVL2_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE MEM2_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the dielectric function following +! the Nevanlinna formula of the classical Hamburger theory of moments +! +! It makes use of the moments: +! +! Cn(q) = 1/pi int_{-inf}^{+inf} omega^n L(q,omega) d omega +! +! with the loss function given by +! +! L(q,omega) = -1/omega * Im[ 1/epsilon(q,omega) ] +! +! +! ---> This is the two-moment version +! +! +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 76, 026403 (2007) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Intermediate parameters: +! +! * C0 : 0-th order moment of the loss function +! * C2 : 2-th order moment of the loss function +! +! Output parameters: +! +! * EPS : value of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOUR + USE COMPLEX_NUMBERS, ONLY : ONEC,IC + USE PI_ETC, ONLY : PI + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE LOSS_MOMENTS + USE DF_VALUES, ONLY : MEM_TYPE,ALPHA,BETA + USE MEMORY_FUNCTIONS_F + USE DAMPING_SI + USE DAMPING_VALUES, ONLY : PCT +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: Q_SI,U,V + REAL (WP) :: OM,OM2,OMP + REAL (WP) :: C0,C2,C4 + REAL (WP) :: OM12 +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EEE,EPS + COMPLEX (WP) :: NUM,DEN + COMPLEX (WP) :: MEMO,MEM +! + Q_SI = TWO * X * KF_SI ! q in SI + U = X * Z ! omega / (q * v_F) + V = FOUR * U * X ! h_bar omega / E_F + OM = U * Q_SI * VF_SI ! omega in SI + OM2 = OM * OM ! +! +! Computing the moments of the loss function +! + CALL LOSS_MOMENTS_AN(X,C0,C2,C4) +! + OM12 = C2 / C0 ! +! +! Choice of the memory function MEM +! + MEMO = MEMORY_F(V,TAU,TAU2,PCT,ALPHA,BETA,MEM_TYPE) ! + MEM = TWO * PI * IC * MEMO ! +! +! Nevanlinna's formula +! + NUM = OM12 ! + DEN = OM2 - OM12 + OM * MEM ! +! + EEE = ONEC + NUM / DEN ! +! + EPS = ONEC / EEE ! ref. (1) eq. (5) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE MEM2_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE MEM3_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the dielectric function following +! the Nevanlinna formula of the classical Hamburger theory of moments +! +! It makes use of the moments: +! +! Cn(q) = 1/pi int_{-inf}^{+inf} omega^n L(q,omega) d omega +! +! with the loss function given by +! +! L(q,omega) = -1/omega * Im[ 1/epsilon(q,omega) ] +! +! +! ---> This is the three-moment version +! +! +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 76, 026403 (2007) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Intermediate parameters: +! +! * C0 : 0-th order moment of the loss function +! * C2 : 2-th order moment of the loss function +! * C4 : 4-th order moment of the loss function +! +! Output parameters: +! +! * EPS : value of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE DF_VALUES, ONLY : MEM_TYPE,ALPHA,BETA +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR + USE COMPLEX_NUMBERS, ONLY : ZEROC,IC + USE PI_ETC, ONLY : PI + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PLASMON_ENE_SI + USE LOSS_MOMENTS + USE DF_VALUES, ONLY : MEM_TYPE,ALPHA,BETA + USE MEMORY_FUNCTIONS_F + USE DAMPING_SI + USE DAMPING_VALUES, ONLY : PCT +! + IMPLICIT NONE +! + INTEGER :: EXPN,EXPD +! + INTEGER :: EXPONENT +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: Q_SI,U,V + REAL (WP) :: OM,OMP + REAL (WP) :: C0,C2,C4 + REAL (WP) :: OM12,OM22 + REAL (WP) :: REN,RED,IMN,IMD +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: OMB,OM2 + COMPLEX (WP) :: EPS + COMPLEX (WP) :: NUM,DEN + COMPLEX (WP) :: MEMO,MEM +! + Q_SI = TWO * X * KF_SI ! q in SI + U = X * Z ! omega / (q * v_F) + V = FOUR * U * X ! h_bar omega / E_F + OM = U * Q_SI * VF_SI ! omega in SI + OMB = OM + IC / TAU ! + OM2 = OMB * OMB ! + OMP = ENE_P_SI / H_BAR ! omega_p +! +! Computing the moments of the loss function +! + CALL LOSS_MOMENTS_AN(X,C0,C2,C4) +! + OM12 = C2 / C0 ! + OM22 = C4 / C2 ! +! +! Choice of the memory function MEM +! + MEMO = MEMORY_F(V,TAU,TAU2,PCT,ALPHA,BETA,MEM_TYPE) ! + MEM = TWO * PI * IC * MEMO ! +! +! Memory function formula +! + NUM = OMP * OMP * (OMB + MEM) ! + DEN = OMB * (OM2 - OM22) + MEM * (OM2 - OM12) ! +! +! Real and imaginary part of NUM and DEN +! + REN = REAL(NUM,KIND=WP) ! + RED = REAL(DEN,KIND=WP) ! + IMN = AIMAG(NUM) ! + IMD = AIMAG(DEN) ! +! +! Checking the real/imaginary parts when infinitesimal +! +! + EXPN = EXPONENT(IMN) ! + EXPD = EXPONENT(IMD) ! +! + IF(EXPN < -100) THEN ! + NUM = REN + ZEROC ! + END IF ! + IF(EXPD < -100) THEN ! + DEN = RED + ZEROC ! + END IF ! +! +! EPS = DEN / (NUM + DEN) +! + EPS = DEN / (NUM + DEN) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE MEM3_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE MER1_EPS_D_LG_3D(X,Z,EPSR,EPSI) +! +! This subroutine computes the longitudinal Mermin dynamical +! dielectric function in 3D +! +! References: (1) H. B. Nersiyan and A. K. Das, Phys. Rev. E 69, 046404 (2004) +! (2) H. B. Nersiyan , A. K. Das, and H. H. Matevosyan, +! Phys. Rev. E 66, 046415 (2002) +! +! Note: for TAU --> infinity, we recover the RPA values +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! * TAU : relaxation time (used for damping) in SI +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Note: in order to be more general, we use EPS_B (background +! dielectric constant) instead of 1 (vacuum case) +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Aug 2021 +! +! + USE MATERIAL_PROP, ONLY : EPS_B +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,EIGHT,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : BOHR,H_BAR + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI_INV +! + USE DFUNC_STATIC, ONLY : RPA1_EPS_S_LG + USE DAMPING_SI, ONLY : TAU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: U,X2,X3 + REAL (WP) :: CHI2,COEF + REAL (WP) :: REPSM1,IEPSM1 + REAL (WP) :: REPS00 + REAL (WP) :: EPS0R,EPS0I + REAL (WP) :: GAMMA,GAMMA2 + REAL (WP) :: UP,UM,UP2,UM2 + REAL (WP) :: NUM,DEN + REAL (WP) :: Y1P,Y2P,Y1M,Y2M + REAL (WP) :: F1,F2 +! + REAL (WP) :: LOG,ATAN,REAL,AIMAG +! + COMPLEX (WP) :: NUMI,DENI,EPS +! + X2 = X * X ! + X3 = X2 * X ! +! + U = X * Z ! omega / (q * v_F) + CHI2 = PI_INV / (KF_SI * BOHR) ! + GAMMA = H_BAR / (FOUR * EF_SI * TAU) ! + GAMMA2 = GAMMA * GAMMA ! +! + COEF = CHI2 / X2 ! +! + UP = U + X ! U_+ + UM = U - X ! U_- +! + UP2 = UP * UP ! + UM2 = UM * UM ! +! + NUM = X2 * (UP + ONE) * (UP + ONE) + GAMMA2 ! + DEN = X2 * (UP - ONE) * (UP - ONE) + GAMMA2 ! ref. (1) eq. (13) + Y1P = LOG(NUM / DEN) ! Y_1(z,U_+) +! + NUM = X2 * (UM + ONE) * (UM + ONE) + GAMMA2 ! + DEN = X2 * (UM - ONE) * (UM - ONE) + GAMMA2 ! ref. (1) eq. (13) + Y1M = LOG(NUM / DEN) ! Y_1(z,U_-) +! + Y2P = ATAN(X * (UP - ONE) / GAMMA) - & ! ref. (1) eq. (14) + ATAN(X * (UP + ONE) / GAMMA) ! Y_2(z,U_+) + Y2M = ATAN(X * (UM - ONE) / GAMMA) - & ! ref. (1) eq. (14) + ATAN(X * (UM + ONE) / GAMMA) ! Y_2(z,U_-) +! + F1 = HALF + ONE / (16.0E0_WP * X3) * ( &! + ( X2 * (UM2 - ONE) - GAMMA2 &! + ) * Y1M - &! + ( X2 * (UP2 - ONE) - GAMMA2 &! ref. (1) eq. (11) + ) * Y1P + &! + FOUR * GAMMA * X * &! + (UP * Y2P - UM * Y2M) &! + ) ! +! + F2 = ONE / (EIGHT * X3) * ( &! + GAMMA * X * (UM * Y1M - UP * Y1P) + &! + X2 * ((UM2 - ONE) - GAMMA2) * Y2M - &! ref. (1) eq. (12) + X2 * ((UP2 - ONE) - GAMMA2) * Y2P &! + ) ! +! +! Computation of EPS_{RPA}(x,u,Gamma) - 1 +! + REPSM1 = COEF * F1 ! ref. (1) eq. (10) + IEPSM1 = COEF * F2 ! +! +! Computation of EPS_{RPA}(x,0) - EPS_B +! + CALL RPA1_EPS_S_LG(X,'3D',EPS0R,EPS0I) ! +! + REPS00 = EPS0R - EPS_B ! +! + NUMI = (X * U + IC * GAMMA) * (REPSM1 + IC * IEPSM1) ! + DENI = X * U + IC * GAMMA * (REPSM1 + IC * IEPSM1) / REPS00 ! +! + EPS = EPS_B + NUMI / DENI ! ref. (1) eq. (9) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE MER1_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE MER2_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal Lindhard-Mermin dynamical +! dielectric function in 3D +! +! References: (1) P.-O. Chapuis et al, Phys. Rev. B 77, 035441 (2008) +! +! Note: for TAU --> infinity, we should recover the RPA values +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * TAU : relaxation time (used for damping) in SI +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Aug 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,EIGHT, & + HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE MATERIAL_PROP, ONLY : EPS_B + USE PLASMON_ENE_SI + USE DAMPING_SI, ONLY : TAU +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,U,RS,T + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,O_SI +! + REAL (WP) :: ABS,REAL,AIMAG +! + COMPLEX (WP) :: UU,FL_U,FL_0 + COMPLEX (WP) :: ZPU,ZMU + COMPLEX (WP) :: OB,COEF + COMPLEX (WP) :: NUM,DEN,EPS +! + U = X * Z ! omega / (q * v_F) + Q_SI = TWO * X * KF_SI ! q in SI + O_SI = U * Q_SI * VF_SI ! omega in SI + OB = O_SI + IC / TAU ! +! + COEF = THREE * ENE_P_SI * ENE_P_SI / (H_BAR * H_BAR * OB) ! +! + UU = OB / (Q_SI * VF_SI) ! u + ZPU = X + UU ! z + u + ZMU = X - UU ! z - u +! + FL_0 = HALF + (ONE - X * X) * LOG( ABS((X + ONE) / & ! + (X - ONE)) & ! ref (1) eq. (13) + ) / (FOUR * X) ! + FL_U = HALF + (ONE - ZMU * ZMU) * LOG( (ZMU + ONE) / & ! + (ZMU - ONE) & ! + ) / (EIGHT * X) + & ! ref (1) eq. (11) + (ONE - ZPU * ZPU) * LOG( (ZPU + ONE) / & ! + (ZPU - ONE) & ! + ) / (EIGHT * X) ! +! + NUM = UU * UU * FL_U + DEN = O_SI + IC * FL_U / (TAU * FL_0) ! + EPS = EPS_B + COEF * NUM / DEN ! +! + EPSR = REAL(EPS,KIND=WP) ! ref (1) eq. (9) + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE MER2_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE MERP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal Mermin dynamical +! dielectric function in 3D, with local field corrections +! +! References: (1) H. B. Nersiyan and A. K. Das, Phys. Rev. E 69, 046404 (2004) +! +! Note: for TAU --> infinity, we recover the RPA values +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * TAU : relaxation time (used for damping) in SI +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! --> This version uses RPA + LFC instead of RPA +! +! +! Note: in order to be more general, we use EPS_B (background +! dielectric constant) instead of 1 (vacuum case) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Aug 2021 +! +! + USE MATERIAL_PROP, ONLY : EPS_B +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,EIGHT,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : BOHR,H_BAR + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI_INV +! + USE LF_VALUES, ONLY : GQ_TYPE +! + USE DFUNC_STATIC, ONLY : RPA1_EPS_S_LG + USE LOCAL_FIELD_STATIC + USE DAMPING_SI, ONLY : TAU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: EPSR,EPSI + REAL (WP) :: U,X2,X3 + REAL (WP) :: CHI2,COEF + REAL (WP) :: REPSM1,IEPSM1 + REAL (WP) :: REPS00 + REAL (WP) :: EPS0R,EPS0I + REAL (WP) :: GAMMA,GAMMA2 + REAL (WP) :: UP,UM,UP2,UM2 + REAL (WP) :: NUM,DEN + REAL (WP) :: Y1P,Y2P,Y1M,Y2M + REAL (WP) :: F1,F2 + REAL (WP) :: GQ +! + REAL (WP) :: LOG,ATAN,REAL,AIMAG +! + COMPLEX (WP) :: ERL,NUML,DENL,NUMI,DENI,EPS +! + X2 = X * X ! + X3 = X2 * X ! + +! + U = X * Z ! omega / (q * v_F) + CHI2 = PI_INV / (KF_SI * BOHR) ! + GAMMA = H_BAR / (FOUR * EF_SI * TAU) ! + GAMMA2 = GAMMA * GAMMA ! +! + COEF = CHI2 / X2 ! +! + UP = U + X ! U_+ + UM = U - X ! U_- +! +! Computing the static local field correction GQ +! + CALL LFIELD_STATIC(X,RS,T,GQ_TYPE,GQ) ! +! +! Computation of EPS_{RPA+LFC}(x,0) - EPS_B +! + CALL RPA1_EPS_S_LG(X,'3D',EPS0R,EPS0I) ! EPS_{RPA}(x,0) + REPS00 = (EPS0R - EPS_B) / (ONE - GQ * (EPS0R - ONE)) ! EPS_{RPA+LFC}(x,0) - EPS_B +! +! Computation of F1 and F2 +! + UP2 = UP * UP ! + UM2 = UM * UM ! +! + NUM = X2 * (UP + ONE) * (UP + ONE) + GAMMA2 ! + DEN = X2 * (UP - ONE) * (UP - ONE) + GAMMA2 ! ref. (1) eq. (13) + Y1P = LOG(NUM / DEN) ! Y_1(z,U_+) +! + NUM = X2 * (UM + ONE) * (UM + ONE) + GAMMA2 ! + DEN = X2 * (UM - ONE) * (UM - ONE) + GAMMA2 ! ref. (1) eq. (13) + Y1M = LOG(NUM / DEN) ! Y_1(z,U_-) +! + Y2P = ATAN(X * (UP - ONE) / GAMMA) - & ! ref. (1) eq. (14) + ATAN(X * (UP + ONE) / GAMMA) ! Y_2(z,U_+) + Y2M = ATAN(X * (UM - ONE) / GAMMA) - & ! ref. (1) eq. (14) + ATAN(X * (UM + ONE) / GAMMA) ! Y_2(z,U_-) +! + F1 = HALF + ONE / (16.0E0_WP * X3) * ( &! + ( X2 * (UM2 - ONE) - GAMMA2 &! + ) * Y1M - &! + ( X2 * (UP2 - ONE) - GAMMA2 &! ref. (1) eq. (11) + ) * Y1P + &! + FOUR * GAMMA * X * &! + (UP * Y2P - UM * Y2M) &! + ) ! +! + F2 = ONE / (EIGHT * X3) * ( &! + GAMMA * X * (UM * Y1M - UP * Y1P) + &! + X2 * ((UM2 - ONE) - GAMMA2) * Y2M - &! ref. (1) eq. (12) + X2 * ((UP2 - ONE) - GAMMA2) * Y2P &! + ) ! +! + REPSM1 = COEF * F1 ! ref. (1) eq. (10) + IEPSM1 = COEF * F2 ! +! +! Computation of EPS_{RPA+LFC}(x,u,Gamma) - 1 = ERL +! + NUML = (REPSM1 + IC * IEPSM1) ! + DENL = ONE - GQ * NUML ! + ERL = NUML / DENL ! +! + NUMI = (X * U + IC * GAMMA) * ERL ! + DENI = X * U + IC * GAMMA * ERL / REPS00 ! +! + EPS = EPS_B + NUMI / DENI ! ref. (1) eq. (9) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE MERP_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE MSAP_EPS_D_LG_3D(X,Y,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! mean spherical approximation dielectric function +! +! References: (1) N. Iwamoto, E. Krotscheck and D. Pines, +! Phys. Rev. B 29, 3936-3951 (1984) +! (2) B. Tanatar and N. Mutulay, Eur. Phys. J. B 1, +! 409-417 (1998) +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Y : dimensionless factor --> Y = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,SIX + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE STRUCTURE_FACTOR_STATIC, ONLY : HFA_SF +! + IMPLICIT NONE +! + REAL (WP) :: X,Y + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,A0Q,S0 +! + Q_SI=TWO*KF_SI ! q in SI + A0Q=BOHR*Q_SI ! a_0 * q (dimensionless) + S0=HFA_SF(X) ! HF structure factor +! + EPSR=ONE - ( ONE/(SIX*PI) * ONE/(X*X*X) * ONE/A0Q * & ! + ONE/(Y*Y - ONE/(S0*S0)) & ! + ) ! + EPSI=ZERO ! +! + END SUBROUTINE MSAP_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE NEV2_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the dielectric function following +! the Nevanlinna formula of the classical Hamburger theory of moments +! +! It makes use of the moments: +! +! Cn(q) = 1/pi int_{-inf}^{+inf} omega^n L(q,omega) d omega +! +! with the loss function given by +! +! L(q,omega) = -1/omega * Im[ 1/epsilon(q,omega) ] +! +! +! ---> This is the two-moment version +! +! +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 76, 026403 (2007) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Intermediate parameters: +! +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! * SQ_TYPE : static structure factor approximation (3D) +! * PL_TYPE : type of plasma considered +! PL_TYPE = 'OCP' --> one-component plasma (~ electron gas) +! PL_TYPE = 'DCP' --> two-component plasma +! * NEV_TYPE : type of Nevalinna function used +! NEV_TYPE = 'NONE' --> no function +! NEV_TYPE = 'STA2' --> static value h(q) +! +! Intermediate parameters: +! +! * C0 : 0-th order moment of the loss function +! * C2 : 2-th order moment of the loss function +! +! Output parameters: +! +! * EPS : value of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE COMPLEX_NUMBERS, ONLY : ONEC + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE LOSS_MOMENTS + USE DF_VALUES, ONLY : NEV_TYPE + USE NEVALINNA_FUNCTIONS + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: Q_SI,U,OM,OM2,OMP + REAL (WP) :: C0,C2,C4 + REAL (WP) :: OM12 +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EEE,EPS + COMPLEX (WP) :: QN,NUM,DEN +! + Q_SI = TWO * X * KF_SI ! q in SI + U = X * Z ! omega / (q * v_F) + OM = U * Q_SI * VF_SI ! omega in SI + OM2 = OM * OM ! +! +! Computing the moments of the loss function +! + CALL LOSS_MOMENTS_AN(X,C0,C2,C4) +! + OM12 = C2 / C0 ! +! +! Choice of the Nevanlinna function Q(X,V) = QN +! + QN = NEVAN2(X,Z,RS,T,TAU,NEV_TYPE) ! +! +! Nevanlinna's formula +! + NUM = OM12 ! + DEN = OM2 - OM12 + OM * QN ! +! + EEE = ONEC + NUM / DEN ! +! + EPS = ONEC / EEE ! ref. (1) eq. (5) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE NEV2_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE NEV3_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the dielectric function following +! the Nevanlinna formula of the classical Hamburger theory of moments +! +! It makes use of the moments: +! +! Cn(q) = 1/pi int_{-inf}^{+inf} omega^n L(q,omega) d omega +! +! with the loss function given by +! +! L(q,omega) = -1/omega * Im[ 1/epsilon(q,omega) ] +! +! +! ---> This is the three-moment version +! +! +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 76, 026403 (2007) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Intermediate parameters: +! +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! * SQ_TYPE : static structure factor approximation (3D) +! * PL_TYPE : type of plasma considered +! PL_TYPE = 'OCP' --> one-component plasma (~ electron gas) +! PL_TYPE = 'DCP' --> two-component plasma +! * NEV_TYPE : type of Nevalinna function used +! NEV_TYPE = 'NONE' --> no function +! NEV_TYPE = 'STA1' --> static value h(q) +! NEV_TYPE = 'STA2' --> static value h(q) +! NEV_TYPE = 'CLCO' --> Classical Coulomb OCP +! NEV_TYPE = 'AMTA' --> +! NEV_TYPE = 'PEEL' --> Perel'-Eliashberg function +! NEV_TYPE = 'PE76' --> +! +! Intermediate parameters: +! +! * C0 : 0-th order moment of the loss function +! * C2 : 2-th order moment of the loss function +! * C4 : 4-th order moment of the loss function +! +! Output parameters: +! +! * EPS : value of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE COMPLEX_NUMBERS, ONLY : ONEC + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PLASMON_ENE_SI + USE LOSS_MOMENTS + USE DF_VALUES, ONLY : NEV_TYPE + USE NEVALINNA_FUNCTIONS + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: Q_SI,U,OM,OM2,OMP + REAL (WP) :: C0,C2,C4 + REAL (WP) :: OM12,OM22 +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EEE,EPS + COMPLEX (WP) :: QN,NUM,DEN +! + Q_SI = TWO * X * KF_SI ! q in SI + U = X * Z ! omega / (q * v_F) + OM = U * Q_SI * VF_SI ! omega in SI + OM2 = OM * OM ! + OMP = ENE_P_SI / H_BAR ! omega_p +! +! Computing the moments of the loss function +! + CALL LOSS_MOMENTS_AN(X,C0,C2,C4) +! + OM12 = C2 / C0 ! + OM22 = C4 / C2 ! +! +! Choice of the Nevanlinna function Q(X,V) = QN +! + QN = NEVAN2(X,Z,RS,T,TAU,NEV_TYPE) ! +! +! Nevanlinna's formula +! + NUM = OMP * OMP * (OM + QN) ! + DEN = OM * (OM2 - OM22) + QN * (OM2 - OM12) ! +! + EEE = ONEC + NUM / DEN ! +! + EPS = ONEC / EEE ! ref. (1) eq. (5) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE NEV3_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE PLPO_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic plasmon pole +! dielectric function for 3D systems +! +! References: (1) L. Hedin, J. Michiels and J. Inglesfield, +! Phys. Rev. B 8, 15565-582 (1998) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Intermediate parameters: +! +! * PL_DISP : type of analytical plasmon dispersion +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOUR + USE COMPLEX_NUMBERS, ONLY : ONEC + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PLASMON_DISP_REAL + USE PLASMON_ENE_SI + USE PLASMON_DISPERSION +! + IMPLICIT NONE +! + REAL (WP),INTENT(IN) :: X,Z,RS,T + REAL (WP),INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: ENE_SI,ENE_QR,ENE_P_Q +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: NUM,DEN + COMPLEX (WP) :: EPS,ENE_Q_SI +! + COMPLEX (WP) :: CMPLX +! + ENE_SI = FOUR * X * X * Z * EF_SI ! +! +! Calculation of the analytical plasmon dispersion +! + CALL PLASMON_DISP_3D(X,RS,T,PL_DISP,ENE_P_Q) ! +! + ENE_Q_SI = CMPLX(ENE_P_Q) ! +! + NUM = ENE_P_SI * ENE_P_SI ! + DEN = ENE_SI * ENE_SI + NUM - ENE_Q_SI * ENE_Q_SI ! +! + EPS = ONEC - NUM / DEN ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE PLPO_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE RDF1_EPS_D_LG_3D(X,Z,EPSR,EPSI) +! +! This subroutine computes random delta-function electron-impurity +! interaction form of the dielectric function for disordered 3D +! conductors +! +! Reference: (1) B. L. Altshuler, A. G. Aronov, D.E. Khmelnitskii and +! A. I. Larkin, in "Quantum Theory of Solids", +! I. M. Lifschits editor, MIR (1982), pp. 129-236 +! (2) D. V. Livanov, M. Yu. Reizer and A. V. Sergeev, +! Sov. Phys. JETP 72, 760-764 (1991) --> for sign +! correction +! +! Note: this version valid for omega*tau << 1 and q*l << 1 +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,E,M_E + USE PI_ETC, ONLY : PI_INV + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE UTILITIES_1, ONLY : D + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z + REAL (WP), INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: U,Q,Q2,OM,DC,K3 + REAL (WP) :: NUM +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EPS,DEN +! + U = X * Z ! omega / q v_F + Q = TWO * X * KF_SI ! q in SI + Q2 = Q * Q ! + OM = U * Q * VF_SI ! omega in SI +! + DC = VF_SI * VF_SI * LFT / D('3D') ! diffusion coefficient +! + K3 = FOUR * PI_INV * KF_SI / BOHR ! +! + NUM = K3 * DC ! ref. 1 eq. (3.4.18) + DEN = DC * Q2 - IC * OM ! +! + EPS = ONE - NUM / DEN ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE RDF1_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE RDF2_EPS_D_LG_3D(X,Z,EPSR,EPSI) +! +! This subroutine computes random delta-function electron-impurity +! interaction form of the dielectric function for disordered 3D +! conductors +! +! Reference: (1) B. L. Altshuler, A. G. Aronov, D.E. Khmelnitskii and +! A. I. Larkin, in "Quantum Theory of Solids", +! I. M. Lifschits editor, MIR (1982), pp. 129-236 +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE UTILITIES_1, ONLY : D,DOS_EF + USE COULOMB_K, ONLY : COULOMB_FF + USE DAMPING_SI +! + USE UNITS, ONLY : UNIT +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,VC + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q,OM,DC,N0,L,QL +! + REAL (WP) :: SQRT,REAL,AIMAG +! + COMPLEX (WP) :: EPS,ZETA,PI0 + COMPLEX (WP) :: NUM,DEN +! + Q = TWO * X * KF_SI ! q in SI + OM = Z * H_BAR * Q * Q * HALF / M_E ! omega in SI +! + CALL COULOMB_FF('3D',UNIT,Q,ZERO,VC) ! Coulomb potential +! + DC = VF_SI * VF_SI * LFT / D('3D') ! diffusion coefficient + L = SQRT(DC * LFT * D('3D')) ! elastic MFP + QL = Q * L ! +! +! Computing the density of states at Fermi level +! + N0=DOS_EF('3D') ! +! + NUM = ONE - IC * (OM * LFT + QL) ! + DEN = ONE - IC * (OM * LFT - QL) ! + ZETA = IC * HALF * CDLOG(NUM / DEN) / QL ! ref. (1), above +! + PI0 = N0 * (ONE + IC * OM * LFT * (ZETA / (ONE - ZETA))) ! +! + EPS = ONE - VC * PI0 ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE RDF2_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE RPA1_EPS_D_LG_3D(X,Z,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! RPA dielectric function for 3D systems +! +! References: (1) J. Solyom, "Fundamental of the Physics of Solids", +! Vol3, Chap. 29, p. 61-138, Springer +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! In the RPA case, we have +! +! EPS(RPA) = 1 - V_C * Pi_0 Pi_0 : RPA polarisability +! +! which we will write as +! +! EPS(RPA) = 1 + ZZ * L ZZ : (q_{TF}/q)^2 +! L : Lindhard function +! +! where q_{TF} is the Thomas-Fermi screening vector, and EPS(TF) = 1 + ZZ +! is the Thomas-Fermi dieclectric function. +! +! +! Author : D. Sébilleau +! +! Last modified : 18 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE LINDHARD_FUNCTION, ONLY : LINDHARD_D +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z + REAL (WP), INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: LR,LI + REAL (WP) :: Q_SI,ZZ +! + Q_SI = TWO * X * KF_SI ! +! +! Coefficient Z: (q_{TF}/q)^2 --> dimension-dependent +! +! + ZZ = FOUR * KF_SI / (PI * BOHR * Q_SI * Q_SI) ! +! +! Calling the dynamic Lindhard function +! + CALL LINDHARD_D(X,Z,'3D',LR,LI) ! +! +! Calculation of the RPA dielectric function +! + EPSR = ONE + ZZ * LR ! + EPSI = ZZ * LI ! EPS(RPA) = 1 + ZZ * L +! + END SUBROUTINE RPA1_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE RPA2_EPS_D_LG_3D(X,Z,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal temperature-dependent +! RPA dielectric function EPS(q,omega,T) for 3D systems. +! +! References: (1) M. Barriga-Carrasco, Phys. Rev. E 76, 016405 (2007) +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * T : temperature (SI) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,EIGHT, & + HALF,THIRD + USE CONSTANTS_P1, ONLY : BOHR,K_B + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI + USE CHEMICAL_POTENTIAL, ONLY : MU + USE EXT_FUNCTIONS, ONLY : PDF + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + INTEGER :: IY + INTEGER :: ID + INTEGER, PARAMETER :: N_Y = 100 +! + REAL (WP) :: X,Z,T,U + REAL (WP) :: EPSR,EPSI + REAL (WP) :: BETA,D,KFA0,COEFR,COEFI + REAL (WP) :: SMALL,LARGE,Z3 + REAL (WP) :: G1,G2,NUM,DEN + REAL (WP) :: X1,X2,X12,X22 + REAL (WP) :: BMU + REAL (WP) :: F1(N_Y),F2(N_Y) + REAL (WP) :: Y,Y_STEP +! + REAL (WP), PARAMETER :: Y_MAX = EIGHT +! + REAL (WP) :: LOG,ABS,SQRT,REAL,EXP +! + SMALL = 1.0E-1_WP ! + LARGE = 1.0E+1_WP ! +! + ID = 2 ! +! + U = X * Z ! omega / (q * v_F) + Z3 = Z * Z * Z ! +! + BETA = ONE / (K_B * T) ! + KFA0 = KF_SI * BOHR ! dimensionless parameter + D = EF_SI * BETA ! plasma degeneracy parameter + COEFR = ONE / (FOUR * PI * Z3 * KFA0) ! + COEFI = ONE / (EIGHT * Z3 * KFA0) ! +! + BMU = BETA * MU('3D',T) ! +! + X1 = U + Z ! + X2 = U - Z ! + X12 = X1 * X1 ! + X22 = X2 * X2 ! +! +! Calculation of G1 = g(u+z) and G2 = g(u-z) +! + IF(D <= SMALL) THEN ! ref. (1) eq. (8) + G1 = X1 + HALF * (ONE - X12) * & ! g(u+z) + LOG(ABS((ONE + X1) / (ONE - X1))) ! + G2 = X2 + HALF * (ONE - X22) * & ! g(u-z) + LOG(ABS((ONE + X2) / (ONE - X2))) ! + ELSE IF(D >= LARGE) THEN ! + G1 = TWO * THIRD * SQRT(D) * REAL(PDF(SQRT(D)*X1),KIND=WP) ! ref. (1) eq. (9) + G2 = TWO * THIRD * SQRT(D) * REAL(PDF(SQRT(D)*X2),KIND=WP) ! ref. (1) eq. (9) + ELSE ! + DO IY = 1, N_Y ! + Y_STEP = Y_MAX / FLOAT(N_Y - 1) ! + Y = FLOAT(IY - 1) * Y_STEP ! integration step + F1(IY) = Y * LOG(ABS((X1 + Y) / (X1 - Y))) / & ! + EXP(D * Y * Y - BMU) ! ref. (1) eq. (7) + F2(IY) = Y * LOG(ABS((X2 + Y) / (X2 - Y))) / & ! + EXP(D * Y * Y - BMU) ! + END DO ! + CALL INTEGR_L(F1,Y_STEP,N_Y,N_Y,G1,ID) ! g(u+z) + CALL INTEGR_L(F2,Y_STEP,N_Y,N_Y,G2,ID) ! g(u-z) + END IF ! +! + NUM = ONE + EXP(BMU - D * X22) ! + DEN = ONE + EXP(BMU - D * X12) ! +! + EPSR = ONE + COEFR * (G1 - G2) ! ref. (1) eq. (6) + EPSI = COEFI * LOG(NUM / DEN) / D ! ref. (1) eq. (11) +! + END SUBROUTINE RPA2_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE RPAP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! RPA dielectric function + STATIC local field corrections +! for 3D systems +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Apr 2021 +! +! + USE LF_VALUES +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR + USE COMPLEX_NUMBERS, ONLY : ONEC,IC + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE LINDHARD_FUNCTION, ONLY : LINDHARD_D + USE LOCAL_FIELD_STATIC +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI + REAL (WP) :: LR,LI + REAL (WP) :: Q_SI,ZZ + REAL (WP) :: GR +! + COMPLEX (WP) :: GQ + COMPLEX (WP) :: NUM,DEN + COMPLEX (WP) :: EPS,EPS0 +! + Q_SI = TWO * X * KF_SI ! +! +! Coefficient Z: (q_{TF}/q)^2 --> dimension-dependent +! +! + ZZ = FOUR * KF_SI / (PI * BOHR * Q_SI * Q_SI) ! +! +! Calling the dynamic Lindhard function +! + CALL LINDHARD_D(X,Z,'3D',LR,LI) ! +! +! Calling the local-field calculation +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GR) ! + GQ = CMPLX(GR) ! +! +! Calculation of the RPA dielectric function +! + EPSR = ONE + ZZ * LR ! + EPSI = ZZ * LI ! EPS(RPA) = 1 + ZZ * L +! + EPS0 = EPSR + IC * EPSI ! +! +! Computing the LFC dielectric function +! + NUM = ONEC - EPS0 ! V_C * Pi_{RPA} + DEN = ONEC + GQ * NUM ! 1 + V_C * G * Pi_{RPA} +! + EPS = ONEC - NUM / DEN ! +! + EPSR = REAL(EPS, KIND = WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE RPAP_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE UTIC_EPS_D_LG_3D(X,Z,T,RS,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in 3D in the Utsumi-Ichimaru approximation +! +! Reference: (1) K. Utsumi and S. Ichimaru, +! Phys. Rev. B 22, 1522-1533 (1980) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * T : temperature in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * SQ_TYPE : static structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! * IQ_TYPE : type of approximation for I(q) +! IQ_TYPE = 'IKP' Iwamoto-Krotscheck-Pines parametrization +! IQ_TYPE = 'KU1' +! IQ_TYPE = 'KU2' +! IQ_TYPE = 'TWA' +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR, & + HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : RS_TO_N0 + USE LF_VALUES, ONLY : GQ_TYPE + USE ENERGIES, ONLY : EC_TYPE + USE SF_VALUES, ONLY : SQ_TYPE + USE EXT_FUNCTIONS, ONLY : PDF + USE RELAXATION_TIME_STATIC, ONLY : UTIC_RT_3D + USE CALC_ENERGIES, ONLY : ENERGIES_3D + USE COULOMB_K, ONLY : COULOMB_FF + USE UTIC_PARAMETERS, ONLY : UTIC_PARAM + USE LOCAL_FIELD_STATIC + USE DFUNC_STATIC +! + USE UNITS, ONLY : UNIT +! + IMPLICIT NONE +! + REAL (WP) :: X,Y,T,Y2,Z,V,RS + REAL (WP) :: EPSR,EPSI,EPS0R,EPS0I + REAL (WP) :: OMEGA,Q_SI,OMG0,VC,N0,COEF + REAL (WP) :: GQ,TAU_Q,Q1,Q3,OM0,OMQ,OO + REAL (WP) :: E_0,E_X,E_X_HF,E_C,E_XC + REAL (WP) :: E_HF,E_GS,E_KIN,E_POT +! + REAL (WP) :: DSQRT,DREAL,DIMAG +! + COMPLEX (WP) :: EPS,OMB,OOB,NUM,DEN,QQO,QQ0 +! + Y=X+X ! Y = q / k_F + Y2=Y*Y ! + V=Z*Y2 ! omega / omega_{k_F} +! + OMEGA=V*HALF*H_BAR*KF_SI*KF_SI/M_E ! omega +! + Q_SI=Y*KF_SI ! + OMG0=HALF*H_BAR*Q_SI*Q_SI/M_E ! ref. 1 eq. (2.6) +! +! Computing the Coulomb potential +! + CALL COULOMB_FF('3D',UNIT,Q_SI,ZERO,VC) ! +! +! Computing electron density +! + N0=RS_TO_N0('3D',RS) ! +! +! Computing the local-field correction +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ) ! +! +! Computing the UTIC relaxation time +! + TAU_Q=UTIC_RT_3D(X,RS,T,SQ_TYPE,GQ_TYPE) ! +! +! Computing the UTIC parameters OMEGA(q) and OMEGA(0) +! + CALL UTIC_PARAM(X,RS,T,OMQ,OM0) ! +! + OO=OMEGA/OMQ ! +! +! Coefficient \bar{omega} +! + OMB=OMEGA+DSQRT(TWO*PI_INV)*(PDF(OO)-ONE) /(OO*TAU_Q) ! ref. 1 eq. (3.13) +! + OOB=OMB/OMEGA ! +! +! Computing the averaged kinetic energy per electron +! + CALL ENERGIES_3D(X,EC_TYPE,RS,T,0,ZERO,E_0,E_X,E_X_HF,E_C, & ! + E_XC,E_HF,E_GS,E_KIN,E_POT) ! +! +! Coefficients Q1 and Q3 +! + Q1=N0*Q_SI*Q_SI/M_E ! + Q3=Q1*(FOUR*E_KIN*OMG0/H_BAR + OMG0*OMG0) ! +! +! Susceptibility function Q(q,omega) +! + QQO=Q1/(OMB*OMB) + Q3/(OMB*OMB*OMB*OMB) ! ref. 1 eq. (3.17) +! +! Computing the RPA susceptibility Q(q,0) +! + CALL DFUNCL_STATIC(X,'LRPA',EPS0R,EPS0I) ! + QQ0=ONE-(EPS0R+IC*EPS0I)/VC ! ref. 1 eq. (3.15) +! +! Computing eps(q,omega) +! + NUM=VC*OOB*QQO ! + DEN=ONE + (VC*OOB*GQ + (OOB-ONE)/QQ0)*QQO ! + EPS=ONE - NUM/DEN ! ref. 1 eq. (3.12) +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE UTIC_EPS_D_LG_3D +! +!======================================================================= +! + SUBROUTINE VLFP_EPS_D_LG_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the longitudinal Vlasov-Fokker-Planck +! dynamical dielectric function in 3D +! +! References: (1) A. Selchow and K. Morawetz, Phys. Rev. E 59, 1015-1023 (1999) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! Alternatively, the diffusion coefficient D can be used, with the +! relation: +! TAU * D = K_B * T / M_E +! +! Note: lambda = 1 / tau ! ref. (1) eq. (7) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE COMPLEX_NUMBERS, ONLY : ONEC,IC + USE CONSTANTS_P1, ONLY : M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE EXT_FUNCTIONS, ONLY : CONHYP + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: U + REAL (WP) :: Q_SI,OMG + REAL (WP) :: KD_SI + REAL (WP) :: AA,BB,Q2,RAT +! + REAL (WP) :: REAL,IMAG +! + COMPLEX (WP) :: EPS + COMPLEX (WP) :: A,B,ZZ,COEF +! + COMPLEX (WP) :: CMPLX +! + U = X * Z ! omega / (q * v_F) + Q_SI = TWO * X * KF_SI ! q in SI + OMG = U * Q_SI * VF_SI ! omega in SI +! + Q2 = Q_SI * Q_SI ! +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + RAT = KD_SI * KD_SI / Q2 + AA = K_B * T * TAU / M_E ! k_B * T / (m * lambda) + BB = AA * Q2 ! + COEF = IC * OMG / (BB - IC * OMG) ! +! +! Parameters/arguments of 1F1 +! + A = ONEC ! + B = ONEC + CMPLX( (BB - IC * OMG) * TAU) ! + ZZ = CMPLX(BB * TAU) ! +! + EPS = ONEC + RAT * (ONEC + COEF * CONHYP(A,B,ZZ,0,10)) ! ref. (1) eq. (27) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE VLFP_EPS_D_LG_3D +! +!======================================================================= +! +! 2) BL case (bilayer) +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC_BL(X,Z,RS,T,D_FUNCL,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in a bilayer +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * D_FUNCL : type of longitudinal dielectric function (2D) +! +! +! Intermediate parameters: +! +! * DL : distance between the two layers (SI) +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,TWO + USE FERMI_SI, ONLY : KF_SI + USE MULTILAYER, ONLY : DL + USE UTILITIES_3, ONLY : EPS_TO_PI + USE COULOMB_K, ONLY : COULOMB_FF +! + USE UNITS, ONLY : UNIT +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,RS,T,D + REAL (WP) :: EPSR,EPSI + REAL (WP) :: REPS,IEPS + REAL (WP) :: PIR,PII + REAL (WP) :: Q_SI,VC +! + Q_SI = TWO * X * KF_SI ! q +! +! Computing the single layer dielectric function +! + CALL DFUNCL_DYNAMIC_2D(X,Z,RS,T,D_FUNCL,REPS,IEPS) ! +! +! Computing the single layer polarisability +! + CALL COULOMB_FF('2D',UNIT,Q_SI,ZERO,VC) ! + CALL EPS_TO_PI(EPSR,EPSI,VC,PIR,PII) ! +! +! Computing the bilayer dielectric function +! + CALL BILA_EPS_D_LG_2D(X,DL,PIR,PII,EPSR,EPSI) ! +! + END SUBROUTINE DFUNCL_DYNAMIC_BL +! +!======================================================================= +! + SUBROUTINE BILA_EPS_D_LG_2D(X,DL,PIR,PII,EPSR,EPSI) +! +! This subroutine computes the dielectric function of a bilayer system +! It assumes that the two layers are identical +! +! Reference: (1) S. Das Sarma and A. Madhukar, Phys. Rev. B 23, +! 805-815 (1981) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * DL : distance between the two layers (SI) +! * PIR : real part of polarization of one layer +! * PII : imaginary part of polarization of one layer +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 19 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : E + USE FERMI_SI, ONLY : KF_SI + USE MULTILAYER, ONLY : EPS_1 + USE CONFINEMENT_FF +! + IMPLICIT NONE +! + REAL (WP) :: X,DL,VC,PIR,PII + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI +! + REAL (WP) :: DEXP,DREAL,DIMAG +! + COMPLEX (WP) :: PI,EPS +! + Q_SI=TWO*X*KF_SI ! q +! +! Computing the intralayer Coulomb potential +! + VC=E*E*CONFIN_FF(X)/(Q_SI*EPS_1) ! +! + PI=PIR+IC*PII ! +! + EPS=ONE - TWO*VC*PI + VC*PI*VC*PI*(ONE-DEXP(-TWO*Q_SI*DL)) ! ref. (1) eq. (12) +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE BILA_EPS_D_LG_2D +! +!======================================================================= +! +! 3) ML case (multilayers) +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC_ML(X,Z,RS,T,D_FUNCL,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in an infinite stacking of +! (identical) layers +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * D_FUNCL : type of longitudinal dielectric function (2D) +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE CONSTANTS_P1, ONLY : E + USE FERMI_SI, ONLY : KF_SI + USE MULTILAYER, ONLY : H_TYPE,D1,EPS_1 + USE UTILITIES_3, ONLY : EPS_TO_PI + USE CONFINEMENT_FF +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,RS,T + REAL (WP) :: EPSR,EPSI + REAL (WP) :: REPS,IEPS + REAL (WP) :: PIR,PII + REAL (WP) :: Q_SI,VC +! + Q_SI=TWO*X*KF_SI ! q +! +! Computing the single layer dielectric function +! + CALL DFUNCL_DYNAMIC_2D(X,Z,RS,T,D_FUNCL,REPS,IEPS) ! +! +! Computing the intralayer Coulomb potential +! + VC=E*E*CONFIN_FF(X)/(Q_SI*EPS_1) ! +! +! Computing the single layer polarisability +! + CALL EPS_TO_PI(EPSR,EPSI,VC,PIR,PII) ! +! +! Computing the multilayer dielectric function +! + IF(H_TYPE == 'MLA1') THEN ! + CALL MLA1_EPS_D_LG_2D(X,PIR,PII,EPSR,EPSI) ! + ELSE IF (H_TYPE == 'MLA2') THEN ! + CALL MLA2_EPS_D_LG_2D(X,PIR,PII,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCL_DYNAMIC_ML +! +!======================================================================= +! + SUBROUTINE MLA1_EPS_D_LG_2D(X,PIR,PII,EPSR,EPSI) +! +! This subroutine computes the dielectric function of a infinite +! stacking of layers with one layer per unit cell. +! It assumes that all layers are identical +! +! Reference: (1) A. C. Sharma, Solid State Comm. 70, 1171-1174 (1989) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * PIR : real part of polarization of one layer +! * PII : imaginary part of polarization of one layer +! +! Intermediate parameters: +! +! * DL : size of stacking unit cell +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : E + USE FERMI_SI, ONLY : KF_SI + USE MULTILAYER, ONLY : DL,EPS_1 + USE CONFINEMENT_FF +! + IMPLICIT NONE +! + REAL (WP) :: X,VC,PIR,PII + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,SGN +! + REAL (WP) :: DSINH,DCOSH,DREAL,DIMAG +! + COMPLEX (WP) :: PI,EPS,AQ +! + Q_SI=TWO*X*KF_SI ! q in SI +! +! Computing the intralayer Coulomb potential +! + VC=E*E*CONFIN_FF(X)/(Q_SI*EPS_1) ! +! + PI=PIR+IC*PII ! +! + AQ=VC*PI*DSINH(Q_SI*DL) - DCOSH(Q_SI*DL) ! ref. 1 eq. (12) +! + IF(DREAL(AQ) >= ZERO) THEN ! + SGN=ONE ! + ELSE ! sign of Re [ AQ ] + SGN=-ONE ! + END IF ! +! + EPS=CDSQRT(AQ*AQ-ONE) / (SGN*DSINH(Q_SI*DL)) ! ref. 1 eq. (11) +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE MLA1_EPS_D_LG_2D +! +!======================================================================= +! + SUBROUTINE MLA2_EPS_D_LG_2D(X,PIR,PII,EPSR,EPSI) +! +! This subroutine computes the dielectric function of a infinite +! stacking of layers with two layers per unit cell. +! It assumes that all layers are identical +! +! Reference: (1) A. C. Sharma, N. Chatuverdi and Y. M. Gupta, +! Physica C 209, 507-512 (1993) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * PIR : real part of polarization of one layer +! * PII : imaginary part of polarization of one layer +! +! Intermediate parameters: +! +! * DL : size of stacking unit cell +! * D1 : distance between the two layers in the unit cell (SI) +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : E + USE FERMI_SI, ONLY : KF_SI + USE MULTILAYER, ONLY : DL,D1,EPS_1 + USE CONFINEMENT_FF +! + IMPLICIT NONE +! + REAL (WP) :: X,VC,PIR,PII + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q,DPR,FQ,SGN +! + REAL (WP) :: DSINH,DCOSH,DREAL,DIMAG +! + COMPLEX (WP) :: PI,EPS,HQ +! + Q=TWO*X*KF_SI ! q in SI +! +! Computing the intralayer Coulomb potential +! + VC=E*E*CONFIN_FF(X)/(Q*EPS_1) ! +! + DPR=TWO*D1-DL ! d' + FQ=(DCOSH(Q*DL)-DCOSH(Q*DPR)) / DSINH(Q*DL) ! ref. (1) eq. (10) +! + PI=PIR+IC*PII ! +! + HQ=DCOSH(Q*DL) - DSINH(Q*DL)*(TWO-VC*PI*FQ)*VC*PI ! ref. (1) eq. (14) +! + IF(DREAL(HQ) >= ZERO) THEN ! + SGN=ONE ! + ELSE ! sign of Re [ HQ ] + SGN=-ONE ! + END IF ! +! + EPS=CDSQRT(HQ*HQ-ONE) / (SGN*DSINH(Q*DL)*(ONE-VC*PI*FQ)) ! ref. 1 eq. (12) +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END +! +!======================================================================= +! +! 4) 2D case +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC_2D(X,Z,RS,T,D_FUNCL,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in 2D +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * D_FUNCL : type of longitudinal dielectric function (2D) +! D_FUNCL = 'LAND' Landau parameter formulation +! D_FUNCL = 'PLPO' plasmon pole approximation +! D_FUNCL = 'RPA1' random phase approximation +! D_FUNCL = 'MER1' Mermin 1 <-- damping +! D_FUNCL = 'HUCO' Hu-O'Connell <-- with loss +! D_FUNCL = 'NEVA' Nevalinna <-- with loss +! D_FUNCL = 'RDF1' Altshuler et al <-- with loss +! D_FUNCL = 'RDF2' Sharma-Ashraf <-- with loss +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Aug 2021 +! +! + USE LF_VALUES, ONLY : LANDAU + USE PLASMON_DISPERSION +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,RS,T + REAL (WP) :: EPSR,EPSI +! + IF(D_FUNCL == 'LAND') THEN ! + CALL LAND_EPS_D_LG_2D(X,Z,RS,LANDAU,EPSR,EPSI) ! + ELSE IF(D_FUNCL == 'PLPO') THEN ! + CALL PLPO_EPS_D_LG_2D(X,Z,RS,T,PL_DISP,EPSR,EPSI) ! + ELSE IF(D_FUNCL == 'RPA1') THEN ! + CALL RPA1_EPS_D_LG_2D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL == 'MER1') THEN ! + CALL MER1_EPS_D_LG_2D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL == 'HUCO') THEN ! + CALL HUCO_EPS_D_LG_2D(X,Z,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCL == 'NEVA') THEN ! + CONTINUE ! + ELSE IF(D_FUNCL == 'RDF1') THEN ! + CALL RDF1_EPS_D_LG_2D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL == 'RDF2') THEN ! + CALL RDF2_EPS_D_LG_2D(X,Z,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCL_DYNAMIC_2D +! +!======================================================================= +! + SUBROUTINE LAND_EPS_D_LG_2D(X,Z,RS,LANDAU,EPSR,EPSI) +! +! This subroutine computes the dielectric function EPS(q,omega) +! in 2D systems in terms of Landau's parameters. +! +! References: (1) E. Lipparini, "Modern Many-Particle Physics - Atomic Gases, +! Quantum Dots and Quantum Fluids", World Scientific (2003) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : dimensionless factor +! * LANDAU : model chosen for the calculation of the parameters +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! +! Last modified : 17 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF,THIRD,FOURTH + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : E,EPS_0 + USE FERMI_SI, ONLY : KF_SI + USE UTILITIES_1, ONLY : DOS_EF + USE CHEMICAL_POTENTIAL, ONLY : MU_RS + USE ENERGIES, ONLY : EC_TYPE + USE LANDAU_PARAM +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: LANDAU +! + REAL (WP) :: X,Z,RS + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI + REAL (WP) :: U,NU0,MU,V_C + REAL (WP) :: F0S,F0A,F1S,F1A,F2S,F2A +! + REAL (WP) :: DSQRT,DREAL,DIMAG +! + COMPLEX (WP) :: EPS,CHIS,G00,G20,G22 + COMPLEX (WP) :: NUM,DEN,NU1,DE1 +! + U=X*Z ! omega / (q * v_F) + Q_SI=TWO*X*KF_SI ! q in SI + NU0=DOS_EF('2D') ! DoS at Fermi level +! +! Computing the Coulomb potential +! + V_C=HALF*E*E/(EPS_0*Q_SI) ! +! +! Computing the chemical potential +! + MU=MU_RS(RS,EC_TYPE) ! +! +! Computing the Landau parameters using chemical potential +! + CALL LANDAU_PARAMETERS_2D(RS,LANDAU,MU,1, & ! + F0S,F0A,F1S,F1A,F2S,F2A) ! +! +! Calculation of the coefficients Gamma_{l,l'} +! + IF(U <= ONE) THEN ! + G00=ONE + IC*U/DSQRT(ONE-U*U) ! + ELSE ! ref. 1 eq. (8.53) + G00=ONE - U/DSQRT(U*U-ONE) ! + END IF ! +! + G20=ONE + (TWO*U*U-ONE)*G00 ! + G22=HALF+ (TWO*U*U-ONE)*G20 ! ref. 1 eq. (8.54) +! + NU1=(ONE+HALF*F1S)*(ONE+FOURTH*F2S)*G20 ! + DE1=TWO*(G00 + HALF*F2S*(G22*G00-G20*G20)) ! + NUM=HALF*NU0*(ONE+HALF*F1S) ! + DEN=U*U - HALF*(ONE+HALF*F1S)*(ONE+F0S) - NU1/DE1 ! +! + CHIS=NUM/DEN ! ref. 1 eq. (8.60) +! + EPS=ONE/(ONE+V_C*CHIS) ! +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE LAND_EPS_D_LG_2D +! +!======================================================================= +! + SUBROUTINE PLPO_EPS_D_LG_2D(X,Z,RS,T,PL_DISP,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic plasmon pole +! dielectric function for 2D systems +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * PL_DISP : type of analytical plasmon dispersion +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PLASMON_DISP_REAL + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: PL_DISP +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: ENE_SI,ENE_P_Q + REAL (WP) :: Q_SI + REAL (WP) :: NUM,DEN,EPS +! + ENE_SI = FOUR * X * X * Z * EF_SI ! hbar omega +! + Q_SI = TWO * X * KF_SI ! q in SI +! +! Calculation of the analytical plasmon dispersion +! + CALL PLASMON_DISP_2D(X,RS,T,PL_DISP,ENE_P_Q) ! hbar omega(q) +! + NUM = ENE_P_SI * ENE_P_SI * Q_SI ! + DEN = ENE_SI * ENE_SI + NUM - ENE_P_Q * ENE_P_Q ! +! + EPS = ONE - NUM / DEN ! +! + EPSR = EPS ! + EPSI = ZERO ! +! + END SUBROUTINE PLPO_EPS_D_LG_2D +! +!======================================================================= +! + SUBROUTINE RPA1_EPS_D_LG_2D(X,Z,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! RPA dielectric function for 2D systems +! +! References: (1) J. Solyom, "Fundamental of the Physics of Solids", +! Vol3, Chap. 29, p. 61-138, Springer +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! In the RPA case, we have +! +! EPS(RPA) = 1 - V_C * Pi_0 Pi_0 : RPA polarisability +! +! which we will write as +! +! EPS(RPA) = 1 + ZZ * L ZZ: q_{TF} / q +! L : Lindhard function +! +! where q_{TF} is the Thomas-Fermi screening vector, and EPS(TF) = 1 + ZZ +! is the Thomas-Fermi dieclectric function. +! +! +! Note: There is a misprint in eq. (29.5.2) of ref. (1) : +! +! 4 pi e^2 / q^2 should be replaced by 2 pi e^2 / q +! +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,EIGHT + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE LINDHARD_FUNCTION, ONLY : LINDHARD_D +! + IMPLICIT NONE +! + REAL (WP) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: LR,LI + REAL (WP) :: Q_SI,K_TF_SI,ZZ +! + Q_SI = TWO * X * KF_SI ! +! +! Coefficient ZZ: (q_{TF}/q)^2 --> dimension-dependent +! + CALL THOMAS_FERMI_VECTOR('2D',K_TF_SI) ! + ZZ = K_TF_SI / Q_SI ! +! +! Calling the dynamic Lindhard function +! + CALL LINDHARD_D(X,Z,'2D',LR,LI) ! +! +! Calculation of the RPA dielectric function +! + EPSR = ONE + ZZ * LR ! + EPSI = ZZ * LI ! EPS(RPA) = 1 + ZZ * L +! + END SUBROUTINE RPA1_EPS_D_LG_2D +! +!======================================================================= +! + SUBROUTINE MER1_EPS_D_LG_2D(X,Z,EPSR,EPSI) +! +! This subroutine computes the longitudinal Mermin dynamical +! dielectric function in 2D +! +! References: (1) H. B. Nersiyan and A. K. Das, Phys. Rev. E 80, 016402 (2009) +! +! Note: for TAU --> infinity, we recover the RPA values +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! * TAU : relaxation time (used for damping) in SI +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Note: in order to be more general, we use EPS_B (background +! dielectric constant) instead of 1 (vacuum case) +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Aug 2021 +! +! + USE MATERIAL_PROP, ONLY : EPS_B +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE SQUARE_ROOTS, ONLY : SQR2 + USE CONSTANTS_P1, ONLY : BOHR,H_BAR + USE FERMI_SI, ONLY : EF_SI,KF_SI +! + USE DFUNC_STATIC, ONLY : RPA1_EPS_S_LG + USE DAMPING_SI, ONLY : TAU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: U,X2 + REAL (WP) :: CHI2,COEF,KOEF + REAL (WP) :: REPSM1,IEPSM1 + REAL (WP) :: REPS00 + REAL (WP) :: EPS0R,EPS0I + REAL (WP) :: GAMMA,GAMMA2 + REAL (WP) :: UP,UM,UP2,UM2 + REAL (WP) :: NU1,NU2,DEN + REAL (WP) :: YPP,YPM,YMP,YMM + REAL (WP) :: F1,F2 +! + REAL (WP) :: SQRT,REAL,AIMAG +! + COMPLEX (WP) :: NUMI,DENI,EPS +! + X2 = X * X ! +! + U = X * Z ! omega / (q * v_F) + CHI2 = ONE / (KF_SI * BOHR) ! + GAMMA = H_BAR / (FOUR * EF_SI * TAU) ! + GAMMA2 = GAMMA * GAMMA ! +! + COEF = HALF * CHI2 / X2 ! + KOEF = HALF * SQR2 ! 1 / sqrt(2) +! + UP = U + X ! U_+ + UM = U - X ! U_- +! + UP2 = UP * UP ! + UM2 = UM * UM ! +! + NU1 = X2 * (UP + ONE) * (UP + ONE) + GAMMA2 ! + NU2 = X2 * (UP2 - ONE) + GAMMA2 ! ref. (1) eq. (5) + DEN = X2 * (UP - ONE) * (UP - ONE) + GAMMA2 ! +! + YPP = KOEF * SQRT( SQRT(NU1 / DEN) + NU2 / DEN ) ! Y_+(z,U_+) + YMP = KOEF * SQRT( SQRT(NU1 / DEN) - NU2 / DEN ) ! Y_-(z,U_+) +! + NU1 = X2 * (UM + ONE) * (UM + ONE) + GAMMA2 ! + NU2 = X2 * (UM2 - ONE) + GAMMA2 ! ref. (1) eq. (5) + DEN = X2 * (UM - ONE) * (UM - ONE) + GAMMA2 ! +! + YPM = KOEF * SQRT( SQRT(NU1 / DEN) + NU2 / DEN ) ! Y_+(z,U_-) + YMM = KOEF * SQRT( SQRT(NU1 / DEN) - NU2 / DEN ) ! Y_-(z,U_-) +! + F1 = TWO * X + GAMMA * (YMM - YMP) / X + & ! ref. (1) eq. (3) + (UM - ONE) * YPM - & ! + (UP - ONE) * YPP ! +! + F2 = GAMMA * (YPM - YPP) / X + & ! ref. (1) eq. (4) + (UP - ONE) * YMP - & ! + (UM - ONE) * YMM ! +! +! Computation of EPS_{RPA}(x,u,Gamma) - 1 +! + REPSM1 = COEF * F1 ! ref. (1) eq. (2) + IEPSM1 = COEF * F2 ! +! +! Computation of EPS_{RPA}(x,0) - EPS_B +! + CALL RPA1_EPS_S_LG(X,'2D',EPS0R,EPS0I) ! EPS_{RPA}(x,0) +! + REPS00 = EPS0R - EPS_B ! EPS_{RPA}(x,0) - EPS_B +! + NUMI = (X * U + IC * GAMMA) * (REPSM1 + IC * IEPSM1) ! + DENI = X * U + IC * GAMMA * (REPSM1 + IC * IEPSM1) / REPS00 ! +! + EPS = EPS_B + NUMI / DENI ! ref. (1) eq. (1) +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE MER1_EPS_D_LG_2D +! +!======================================================================= +! + SUBROUTINE HUCO_EPS_D_LG_2D(X,Z,RS,EPSR,EPSI) +! +! This subroutine computes the Hu-O'Connell dielectric function that +! including damping effect through electron-electron and electron-impurity +! fluctuation, leading to a diffusion coefficient D, for 2D systems +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = hbar omega / E_F +! * RS : Wigner-Seitz radius (in units of a_0) +! * D : diffusion coefficient (in SI) +! +! +! Output variables : +! +! * EPSR : real part of the dielectric function at q +! * EPSI : imaginary part of the dielectric function at q +! +! Reference : (1) G. Y. Hu and R. F. O'Connell, +! J. Phys. C: Solid State Phys. 21, 4325-4331 (1988) +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,FOURTH + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE SQUARE_ROOTS, ONLY : SQR2 + USE FERMI_SI, ONLY : KF_SI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: U + REAL (WP) :: Q_SI,KTF_SI + REAL (WP) :: FF + REAL (WP) :: KOQ + REAL (WP) :: COEF,KOEF + REAL (WP) :: B,NUP,NUM + REAL (WP) :: NP2,NM2 + REAL (WP) :: SIP,SIM + REAL (WP) :: SP2,SM2 + REAL (WP) :: BX,B2X2 + REAL (WP) :: OBXP,OBXM + REAL (WP) :: FBNP,FBNM + REAL (WP) :: SQP1,SQM1 + REAL (WP) :: SQP2,SQM2 +! + REAL (WP) :: SIGN,SQRT +! + U = X * Z ! omega / (q * v_F) + Q_SI = TWO * KF_SI * X ! q in SI +! + FF = ONE ! +! +! Computing the Thomas-Fermi vector +! + CALL THOMAS_FERMI_VECTOR('3D',KTF_SI) ! +! + KOQ = KTF_SI / Q_SI ! +! + COEF = FF * KOQ ! + KOEF = FF * KOQ / (TWO * SQR2 * X) ! +! +! Setting the Hu-O'Connell parameters +! + B = TWO * M_E * DIF / H_BAR ! \ + NUP = X + U ! > ref. (1) eq. (8) + NUM = X - U ! / +! + NP2 = NUP * NUP ! + NM2 = NUM * NUM ! +! + SIP = SIGN(ONE,NUP) ! + SIM = SIGN(ONE,NUM) ! +! + SP2 = SIP / (TWO * SQR2 * X) ! + SM2 = SIM / (TWO * SQR2 * X) ! +! + BX = B * X ! + B2X2 = BX * BX ! +! + OBXP = ONE + B2X2 - NP2 ! + OBXM = ONE + B2X2 - NM2 ! +! + FBNP = FOUR * B2X2 * NP2 ! + FBNM = FOUR * B2X2 * NM2 ! +! + SQP1 = SQRT( SQRT(OBXP**2 + FBNP) - OBXP ) ! + SQM1 = SQRT( SQRT(OBXM**2 + FBNM) - OBXM ) ! + SQP2 = SQRT( SQRT(OBXP**2 + FBNP) + OBXP ) ! + SQM2 = SQRT( SQRT(OBXM**2 + FBNM) + OBXM ) ! +! +! Real part of epsilon +! + EPSR = ONE + COEF * ( ONE - SM2 * SQM1 - SP2 * SQP1 ) ! +! +! Imaginary part of epsilon +! +! + EPSI = KOEF * ( SQM2 - SQP2 ) ! +! + END SUBROUTINE HUCO_EPS_D_LG_2D +! +!======================================================================= +! + SUBROUTINE RDF1_EPS_D_LG_2D(X,Z,EPSR,EPSI) +! +! This subroutine computes random delta-function electron-impurity +! interaction form of the dielectric function for disordered 2D +! conductors +! +! Reference: (1) B. L. Altshuler, A. G. Aronov, D.E. Khmelnitskii and +! A. I. Larkin, in "Quantum Theory of Solids", +! I. M. Lifschits editor, MIR (1982), pp. 129-236 +! (2) D. V. Livanov, M. Yu. Reizer and A. V. Sergeev, +! Sov. Phys. JETP 72, 760-764 (1991) --> for sign +! correction +! +! Note: this version valid for omega*tau << 1 and q*l << 1 +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE UTILITIES_1, ONLY : D + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q,Q2,OM,DC + REAL (WP) :: K_TF,NUM +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EPS,DEN +! + Q = TWO * X * KF_SI ! q in SI + Q2 = Q * Q ! + OM = Z * H_BAR * Q * Q * HALF / M_E ! omega in SI +! + DC = VF_SI * VF_SI * LFT / D('2D') ! diffusion coefficient +! +! Computing the Thomas-Fermi screening vector ! +! + CALL THOMAS_FERMI_VECTOR('2D',K_TF) ! +! + NUM = DC * Q * K_TF ! ref. 1 eq. (3.4.19) + DEN = DC * Q2 - IC * OM ! +! + EPS = ONE + NUM / DEN ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE RDF1_EPS_D_LG_2D +! +!======================================================================= +! + SUBROUTINE RDF2_EPS_D_LG_2D(X,Z,EPSR,EPSI) +! +! This subroutine computes random delta-function electron-impurity +! interaction form of the dielectric function for disordered 2D +! conductors +! +! Reference: (1) A. C. Sharma and S. S. Z. Ashraf, +! J. Phys.: Condens. Matter 16, 3117 (2004) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE UTILITIES_1, ONLY : D,DOS_EF + USE COULOMB_K, ONLY : COULOMB_FF +! + USE UNITS, ONLY : UNIT + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,VC + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q,OM,DC,N0,L,QL +! + REAL (WP) :: SQRT,REAL,AIMAG +! + COMPLEX (WP) :: EPS,ZETA,PI0 +! + COMPLEX (WP) :: CDSQRT +! + Q = TWO * X * KF_SI ! q in SI + OM = Z * H_BAR * Q * Q * HALF / M_E ! omega in SI +! + CALL COULOMB_FF('2D',UNIT,Q,ZERO,VC) ! +! + DC = VF_SI * VF_SI * LFT / D('2D') ! diffusion coefficient + L = SQRT(DC * LFT * D('2D')) ! elastic MFP + QL = Q * L ! +! +! Computing the density of states at Fermi level +! + N0 = DOS_EF('2D') ! +! + ZETA = ONE / CDSQRT((ONE - IC * OM * LFT)**2 + QL * QL) ! eq. (3.4.11a) +! + PI0 = N0 * (ONE + IC * OM * LFT * (ZETA / (ONE - ZETA))) ! +! + EPS = ONE - VC * PI0 ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE RDF2_EPS_D_LG_2D +! +!======================================================================= +! +! 5) Q1D case +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC_Q1(X,Z,D_FUNCL,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in Q1D +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * D_FUNCL : type of longitudinal dielectric function (1D) +! D_FUNCL = 'HUCO' Hu-O'Connell +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE PLASMON_DISPERSION +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,RS,T + REAL (WP) :: EPSR,EPSI +! + IF(D_FUNCL.EQ.'HUCO') THEN ! + CALL HUCO_EPS_D_LG_Q1(X,Z,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCL_DYNAMIC_Q1 +! +!======================================================================= +! + SUBROUTINE HUCO_EPS_D_LG_Q1(X,Z,EPSR,EPSI) +! +! This subroutine computes the Hu-O'Connell dielectric function that +! including damping effect through electron-electron and electron-impurity +! fluctuation, leading to a diffusion coefficient D, for Q1D systems +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = hbar omega / E_F +! * D : diffusion coefficient (in SI) +! +! +! Output variables : +! +! * EPSR : real part of the dielectric function at q +! * EPSI : imaginary part of the dielectric function at q +! +! Reference : (1) G. Y. Hu and R. F. O'Connell, J. Phys. C: Condens. +! Matter 2, 9381-9397 (1990) +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE MATERIAL_PROP, ONLY : MSOM + USE CONFIN_VAL, ONLY : OM0,CONFIN + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI + USE COULOMB_K +! + USE UNITS, ONLY : UNIT + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: A,B,XX,Y,B1,B2 + REAL (WP) :: NU_P(0:1),NU_M(0:1) + REAL (WP) :: Q_SI,MS + REAL (WP) :: COEF,V_C +! + REAL (WP) :: DSQRT,DREAL,DIMAG +! + COMPLEX (WP) :: IC + COMPLEX (WP) :: NUM,DEN,CHI,EPS +! + Q_SI = TWO * X * KF_SI ! q in SI + MS = MSOM * M_E ! m* +! + COEF = - MS / (PI * Q_SI) ! +! +! Computing the Coulomb potential +! + CALL COULOMB_FF('Q1',UNIT,Q_SI,ZERO,V_C) ! +! +! Setting the Hu-O'Connell parameters +! + B = SQRT( H_BAR / (MS * OM0) ) ! + A = TWO * MSOM * MS * DIF / H_BAR ! ref. (1) eq. (3.3) + XX = B * Q_SI ! \ ref. (1) eq. (3.4) + Y = Z * EF_SI / H_BAR ! / +! + NU_P(0) = Y / XX + HALF * X ! \ + NU_P(1) = (Y - ONE) / XX + HALF * X ! \ + NU_M(0) = Y/ XX - HALF * X ! / ref. (1) eq. (3.4) + NU_M(1) = (Y - ONE) / XX - HALF * X ! / +! + B1 = B * SQRT(TWO * MS * (EF_SI - H_BAR * OM0)) / H_BAR ! \ ref. (1) eq. (3.3) + B2 = B * SQRT(TWO * MS * (EF_SI - ONE * H_BAR * OM0)) / H_BAR ! / +! + IF(CONFIN == 'HC-1111') THEN ! + NUM = (B1 - NU_M(0) - IC * HALF * A * XX) * & ! + (B1 + NU_P(0) + IC * HALF * A * XX) ! + DEN = (B1 + NU_M(0) + IC * HALF * A *XX) * & ! + (B1 - NU_P(0) - IC * HALF * A * XX) ! + CHI = COEF * CDLOG(NUM / DEN) ! + EPS = ONE - CHI * V_C ! + ELSE IF(CONFIN == 'HC-1122') THEN ! + NUM = (B1 - NU_M(0) - IC * HALF * A * XX) * & ! + (B1 + NU_P(0) + IC * HALF * A * XX) ! + DEN = (B1 + NU_M(0) + IC * HALF * A * XX) * & ! + (B1 - NU_P(0) - IC * HALF * A * XX) ! + CHI = COEF * CDLOG(NUM / DEN) ! + EPS = - CHI * V_C ! + ELSE IF(CONFIN == 'HC-1221') THEN ! + NUM = (B1 - NU_M(1) - IC * HALF * A * XX) * & ! + (B2 + NU_P(1) + IC * HALF * A * XX) ! + DEN = (B1 + NU_M(1) + IC * HALF * A * XX) * & ! + (B2 - NU_P(1) - IC * HALF * A * XX) ! + CHI = COEF * CDLOG(NUM / DEN) ! + EPS = -CHI * V_C ! + ELSE IF(CONFIN == 'HC-2222') THEN ! + NUM = (B2 - NU_M(0) - IC * HALF * A * XX) * & ! + (B2 + NU_P(0) + IC * HALF * A * XX) ! + DEN = (B2 + NU_M(0) + IC * HALF * A * XX) * & ! + (B2 - NU_P(0) - IC * HALF * A * XX) ! + CHI = COEF * CDLOG(NUM / DEN) ! + EPS = ONE - CHI * V_C ! + END IF ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE HUCO_EPS_D_LG_Q1 +! +!======================================================================= +! +! 6) 1D case +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC_1D(X,Z,RS,T,D_FUNCL,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in 1D +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * D_FUNCL : type of longitudinal dielectric function (1D) +! D_FUNCL = 'RPA1' random phase approximation +! D_FUNCL = 'PLPO' plamson pole approximation +! D_FUNCL = 'RDF1' Altshuler et al model +! D_FUNCL = 'RDF2' Sharma-Ashraf model +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE PLASMON_DISPERSION +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,Z,RS,T + REAL (WP) :: EPSR,EPSI +! + IF(D_FUNCL == 'RPA1') THEN ! + CALL RPA1_EPS_D_LG_1D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL == 'PLPO') THEN ! + CALL PLPO_EPS_D_LG_1D(X,Z,RS,T,PL_DISP,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'RDF1') THEN ! + CALL RDF1_EPS_D_LG_1D(X,Z,EPSR,EPSI) ! + ELSE IF(D_FUNCL.EQ.'RDF2') THEN ! + CALL RDF2_EPS_D_LG_1D(X,Z,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCL_DYNAMIC_1D +! +!======================================================================= +! + SUBROUTINE RPA1_EPS_D_LG_1D(X,Z,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! RPA dielectric function for 1D systems +! +! References: (1) J. Solyom, "Fundamental of the Physics of Solids", +! Vol3, Chap. 29, p. 61-138, Springer +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! In the RPA case, we have +! +! EPS(RPA) = 1 - V_C * Pi_0 Pi_0 : RPA polarisability +! +! which we will write as +! +! EPS(RPA) = 1 + ZZ * L ZZ: (q_{TF}/q)^2 +! L : Lindhard function +! +! where q_{TF} is the Thomas-Fermi screening vector, and EPS(TF) = 1 + ZZ +! is the Thomas-Fermi dieclectric function. +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,EIGHT + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE LINDHARD_FUNCTION, ONLY : LINDHARD_D +! + IMPLICIT NONE +! + REAL (WP) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: LR,LI + REAL (WP) :: Q_SI,K_TF_SI,ZZ +! + Q_SI = TWO * X * KF_SI ! +! +! Coefficient ZZ: (q_{TF}/q)^2 --> dimension-dependent +! + CALL THOMAS_FERMI_VECTOR('1D',K_TF_SI) ! + ZZ = (K_TF_SI/Q_SI)**2 ! +! +! Calling the dynamic Lindhard function +! + CALL LINDHARD_D(X,Z,'1D',LR,LI) ! +! +! Calculation of the RPA dielectric function +! + EPSR = ONE + ZZ * LR ! + EPSI = ZZ * LI ! EPS(RPA) = 1 + ZZ * L +! + END SUBROUTINE RPA1_EPS_D_LG_1D +! +!======================================================================= +! + SUBROUTINE PLPO_EPS_D_LG_1D(X,Z,RS,T,PL_DISP,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic plasmon pole +! dielectric function for 1D systems +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * PL_DISP : type of analytical plasmon dispersion +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 22 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PLASMON_DISP_REAL, ONLY : PLASMON_DISP_1D + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: PL_DISP +! + REAL (WP) :: X,Z,RS,T + REAL (WP) :: EPSR,EPSI + REAL (WP) :: ENE_SI,ENE_P_Q,EPS +! + ENE_SI=FOUR*X*X*Z*EF_SI ! hbar omega +! +! Calculation of the analytical plasmon dispersion +! + CALL PLASMON_DISP_1D(X,RS,T,PL_DISP,ENE_P_Q) ! hbar omega(q) +! + EPS=ONE-ENE_P_SI*ENE_P_SI/(ENE_SI*ENE_SI+ENE_P_SI*ENE_P_SI - &! + ENE_P_Q*ENE_P_Q) ! +! + EPSR=EPS ! + EPSI=ZERO ! +! + END SUBROUTINE PLPO_EPS_D_LG_1D +! +!======================================================================= +! + SUBROUTINE RDF1_EPS_D_LG_1D(X,Z,EPSR,EPSI) +! +! This subroutine computes random delta-function electron-impurity +! interaction form of the dielectric function for disordered 1D +! conductors +! +! Reference: (1) B. L. Altshuler, A. G. Aronov, D.E. Khmelnitskii and +! A. I. Larkin, in "Quantum Theory of Solids", +! I. M. Lifschits editor, MIR (1982), pp. 129-236 +! (2) D. V. Livanov, M. Yu. Reizer and A. V. Sergeev, +! Sov. Phys. JETP 72, 760-764 (1991) --> for sign +! correction +! +! Note: this version valid for omega*tau << 1 and q*l << 1 +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,COULOMB + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE UTILITIES_1, ONLY : D,DOS_EF + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE CONFIN_VAL, ONLY : R0 + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q,Q2,OM,DC,N0 + REAL (WP) :: K_TF,NUM +! + REAL (WP) :: LOG,REAL,AIMAG +! + COMPLEX (WP) :: EPS,DEN +! + Q = TWO * X * KF_SI ! q in SI + Q2 = Q * Q ! + OM = Z * H_BAR * Q2 * HALF / M_E ! omega in SI +! + DC = VF_SI * VF_SI * LFT / D('3D') ! diffusion coefficient +! +! Computing the density of states at Fermi level +! + N0 = DOS_EF('3D') ! +! +! Computing the Thomas-Fermi screening vector ! +! + CALL THOMAS_FERMI_VECTOR('3D',K_TF) ! +! + NUM = DC * Q2 * N0 * E * E * COULOMB * LOG(ONE / (Q2 * R0*R0))! ref. 2 eq. (26) + DEN = DC * Q2 - IC * OM ! +! + EPS = ONE + NUM / DEN ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE RDF1_EPS_D_LG_1D +! +!======================================================================= +! + SUBROUTINE RDF2_EPS_D_LG_1D(X,Z,EPSR,EPSI) +! +! This subroutine computes random delta-function electron-impurity +! interaction form of the dielectric function for disordered 1D +! conductors +! +! Reference: (1) A. C. Sharma and S. S. Z. Ashraf, +! J. Phys.: Condens. Matter 16, 3117 (2004) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE UTILITIES_1, ONLY : DOS_EF + USE COULOMB_K, ONLY : COULOMB_FF +! + USE UNITS, ONLY : UNIT + USE DAMPING_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,VC + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q,OM,N0 +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EPS,ZETA,PI0 + COMPLEX (WP) :: NUM,DEN,PHI,PSI +! + Q = TWO * X *KF_SI ! q in SI + OM = Z * H_BAR * Q * Q * HALF / M_E ! omega in SI +! + CALL COULOMB_FF('1D',UNIT,Q,ZERO,VC) ! +! +! Computing the density of states at Fermi level +! + N0 = DOS_EF('1D') ! +! + PHI = CDSQRT(ONE + IC * HALF / (LFT * EF_SI)) ! ref. 1 eq. (27) + PSI = CDSQRT(ONE - (OM + IC * HALF / LFT) / EF_SI) ! ref. 1 eq. (28) + NUM = IC * (PHI - PSI) ! + DEN = LFT * EF_SI * ( PHI*PSI *( (PHI-PSI)**2 - FOUR*X*X ) ) ! + ZETA = NUM / DEN ! ref. 1 eq. (26) +! + PI0 = N0 * (ONE + IC * OM * LFT * (ZETA / (ONE - ZETA))) ! +! + EPS = ONE - VC * PI0 ! +! + EPSR = REAL(EPS,KIND=WP) ! + EPSI = AIMAG(EPS) ! +! + END SUBROUTINE RDF2_EPS_D_LG_1D +! +END MODULE DFUNCL_STAN_DYNAMIC diff --git a/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_stan_dynamic_2.f90 b/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_stan_dynamic_2.f90 new file mode 100644 index 0000000..c2324c4 --- /dev/null +++ b/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_stan_dynamic_2.f90 @@ -0,0 +1,88 @@ +! +!======================================================================= +! +MODULE DFUNCL_STAN_DYNAMIC_2 +! + USE ACCURACY_REAL +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE DFUNCL_DYNAMIC_FROM_SQO(X,V,Z,RS,T,FLAG,EPSR,EPSI) +! +! This subroutine computes the longitudinal dynamic +! dielectric functions in 3D from the dynamical structure factor +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * V : dimensionless factor --> V = hbar * omega / E_F +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * FLAG : current index of the omega loop calling this subroutine +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,FOURTH +! + USE E_GRID +! + USE SF_VALUES + USE STRUCTURE_FACTOR_DYNAMIC + USE UTILITIES_3, ONLY : SQO_TO_EPSI + USE TRANSFORMS, ONLY : KK +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: FLAG +! + INTEGER :: IE +! + REAL (WP), INTENT(IN) :: X,V,Z,RS,T + REAL (WP), INTENT(OUT) :: EPSR,EPSI +! + REAL (WP) :: E,ZZ,SQO,IEPS + REAL (WP) :: EN(N_E),U_INP(N_E),U_OUT(N_E) +! + DO IE = 1, N_E ! +! + E = E_MIN + FLOAT(IE - 1) * E_STEP ! + ZZ = FOURTH * E / (X * X) ! ZZ = omega / omega_q +! +! Computing the dynamic structure factor +! + CALL STFACT_DYNAMIC(X,ZZ,RS,T,SQO_TYPE,SQ_TYPE,SQO) ! +! +! Computing the imaginary part of epsilon +! + CALL SQO_TO_EPSI(X,Z,T,RS,SQO,IEPS) ! +! + U_INP(IE) = IEPS ! + EN(IE) = E ! +! + END DO ! +! +! Computing the real part of epsilon through Kramers-Kronig +! + CALL KK('I2R',N_E,EN,U_INP,ONE,U_OUT) ! +! + EPSR = U_OUT(FLAG) ! + EPSI = U_INP(FLAG) ! +! + END SUBROUTINE DFUNCL_DYNAMIC_FROM_SQO +! +END MODULE DFUNCL_STAN_DYNAMIC_2 diff --git a/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_static.f90 b/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_static.f90 new file mode 100644 index 0000000..c7b5bf9 --- /dev/null +++ b/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_static.f90 @@ -0,0 +1,307 @@ +! +!======================================================================= +! +MODULE DFUNC_STATIC +! + USE ACCURACY_REAL +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE DFUNCL_STATIC(X,D_FUNCL,EPSR,EPSI) +! +! This subroutine computes the longitudinal static +! dielectric functions +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * D_FUNCL : type of longitudinal dielectric function +! D_FUNCL = 'LRPA' random phase approximation +! D_FUNCL = 'THFE' Thomas-Fermi +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Jun 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X + REAL (WP) :: EPSR,EPSI +! + IF(D_FUNCL == 'LRPA') THEN ! + CALL RPA1_EPS_S_LG(X,DMN,EPSR,EPSI) ! + ELSE IF(D_FUNCL == 'THFE') THEN ! + CALL THFE_EPS_S_LG(X,DMN,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCL_STATIC +! +!======================================================================= +! + SUBROUTINE RPA1_EPS_S_LG(X,DMN,EPSR,EPSI) +! +! This subroutine computes the longitudinal static RPA dielectric function +! +! References: (1) J. Solyom, "Fundamental of the Physics of Solids", Vol3, Chap. 29 +! p. 61-138, Springer +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * DMN : problem dimension +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! In the RPA case, we have +! +! EPS(RPA) = 1 - V_C * Pi_0 Pi_0 : RPA polarisability +! +! which we will write as +! +! EPS(RPA) = 1 + Z * L Z : (q_{TF}/q)^2 +! L : Lindhard function +! +! where q_{TF} is the Thomas-Fermi screening vector, and EPS(TF) = 1 + Z +! is the Thomas-Fermi dielectric function. +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,EIGHT + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE LINDHARD_FUNCTION, ONLY : LINDHARD_S +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP) :: X + REAL (WP) :: EPSR,EPSI + REAL (WP) :: LR,LI,Q_SI,Z +! + Q_SI=TWO*X*KF_SI ! +! +! Coefficient Z: (q_{TF}/q)^2 --> dimension-dependent +! + IF(DMN == '3D') THEN ! 3D case +! + Z=FOUR*KF_SI/(PI*BOHR*Q_SI*Q_SI) ! +! + ELSEIF(DMN == '2D') THEN ! 2D case +! + Z=FOUR/(BOHR*Q_SI*Q_SI) ! +! + ELSEIF(DMN == '1D') THEN ! 1D case +! + Z=EIGHT/(BOHR*KF_SI*Q_SI*Q_SI) ! +! + END IF ! +! +! Calling the static Lindhard function +! + CALL LINDHARD_S(X,DMN,LR,LI) ! +! +! Calculation of the RPA dielectric function +! ! + EPSR=ONE+Z*LR ! + EPSI=Z*LI ! EPS(RPA) = 1 + Z * L +! + END SUBROUTINE RPA1_EPS_S_LG +! +!======================================================================= +! + SUBROUTINE THFE_EPS_S_LG(X,DMN,EPSR,EPSI) +! +! This subroutine computes the longitudinal static RPA dielectric function +! +! References: (1) J. Solyom, "Fundamental of the Physics of Solids", Vol3, Chap. 29 +! p. 61-138, Springer +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * DMN : problem dimension +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,EIGHT + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP) :: X + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,Z +! + Q_SI=TWO*X*KF_SI ! +! +! Coefficient Z: (q_{TF}/q)^2 --> dimension-dependent +! + IF(DMN == '3D') THEN ! 3D case +! + Z=FOUR*KF_SI/(PI*BOHR*Q_SI*Q_SI) ! +! + ELSEIF(DMN == '2D') THEN ! 2D case +! + Z=FOUR/(BOHR*Q_SI*Q_SI) ! +! + ELSEIF(DMN == '1D') THEN ! 1D case +! + Z=EIGHT/(BOHR*KF_SI*Q_SI*Q_SI) ! +! + ENDIF ! +! +! Calculation of the TF dielectric function +! + EPSR=ONE+Z ! + EPSI=ZERO ! EPS = 1 + Z +! + END SUBROUTINE THFE_EPS_S_LG +! +!======================================================================= +! + SUBROUTINE DFUNCL_STATIC_2D_M(X,KS,A,D_FUNCL,EPSR,EPSI) +! +! This subroutine computes the longitudinal static +! dielectric functions in 2D in the presence of an external +! magnetic field +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * KS : screening wave vector in SI +! * A : sqrt(mu_B * B) : magnitude of the magnetic field in SI +! * D_FUNCL : type of longitudinal dielectric function +! D_FUNCL = 'LRPA' random phase approximation +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Feb 2020 +! +! +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL +! + REAL (WP) :: X,KS,A + REAL (WP) :: EPSR,EPSI +! + IF(D_FUNCL == 'LRPA') THEN ! + CALL RPA2_EPS_S_LG_2D(X,KS,A,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCL_STATIC_2D_M +! +!======================================================================= +! + SUBROUTINE RPA2_EPS_S_LG_2D(X,KS,A,EPSR,EPSI) +! +! This subroutine computes the longitudinal static 2D RPA +! dielectric function in the presence of a magnetic field +! for an integer filling factor of 1 +! +! References: (1) G. F. Giuliani and G. Vignale, "Quantum Theory of +! the Electron Liquid", (Cambridge, 2005) p. 579 +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * KS : screening wave vector in SI +! * A : sqrt(mu_B * B) : magnitude of the magnetic field in SI +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,EPS_0 + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI_INV + USE SQUARE_ROOTS, ONLY : SQR2 + USE EULER_CONST, ONLY : EUMAS + USE EXT_FUNCTIONS, ONLY : DEI +! + IMPLICIT NONE +! + REAL (WP) :: X,KS,A + REAL (WP) :: Q_SI,Q2,KS2,COEF,V_C + REAL (WP) :: HOC,QL2,L2O + REAL (WP) :: EPSR,EPSI +! + REAL (WP) :: DSQRT,DLOG,DEXP +! + COEF=E*E/EPS_0 ! +! + Q_SI=TWO*X*KF_SI ! + Q2=Q_SI*Q_SI ! + KS2=KS*KS ! +! + HOC=SQR2*A ! hbar * omega_c + QL2=HALF*H_BAR*H_BAR*Q_SI*Q_SI/(M_E*HOC) ! q^2 l^2 / 2 + L2O=H_BAR*H_BAR/M_E ! l^2 hbar omega_c + V_C=HALF*COEF/DSQRT(Q2+KS2) ! 2D Coulomb pot. +! + EPSR=ONE+V_C*PI_INV*(DEI(QL2)-DLOG(QL2)-EUMAS)*DEXP(-QL2)/L2O ! + EPSI=ZERO ! +! + END SUBROUTINE RPA2_EPS_S_LG_2D +! +END MODULE DFUNC_STATIC diff --git a/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfunct_dynamic.f90 b/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfunct_dynamic.f90 new file mode 100644 index 0000000..6f449e9 --- /dev/null +++ b/New_libraries/DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfunct_dynamic.f90 @@ -0,0 +1,628 @@ +! +!======================================================================= +! +MODULE DFUNCT_STAN_DYNAMIC +! + USE ACCURACY_REAL +! +! +CONTAINS +! +! +!======================================================================= +! +! Transverse Dielectric Functions +! +!======================================================================= +! + SUBROUTINE DFUNCT_DYNAMIC(X,Z,D_FUNCT,EPSR,EPSI) +! +! This subroutine computes the transverse dynamic +! dielectric functions +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * D_FUNCT : type of transverse dielectric function +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 19 Jun 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCT +! + REAL (WP) :: X,Z,RS,T,TAU + REAL (WP) :: EPSR,EPSI +! + IF(DMN == '3D') THEN ! + CALL DFUNCT_DYNAMIC_3D(X,Z,D_FUNCT,EPSR,EPSI) ! + ELSE IF(DMN == '2D') THEN ! + CALL DFUNCT_DYNAMIC_2D(X,Z,D_FUNCT,EPSR,EPSI) ! + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! + END IF ! +! + END SUBROUTINE DFUNCT_DYNAMIC +! +!======================================================================= +! +! 1) 3D case +! +!======================================================================= +! + SUBROUTINE DFUNCT_DYNAMIC_3D(X,Z,D_FUNCT,EPSR,EPSI) +! +! This subroutine computes the transverse dynamic +! dielectric functions in 3D +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * D_FUNCT : type of transverse dielectric function (3D) +! D_FUNCT = 'RPA1' random phase approximation +! D_FUNCT = 'RPA2' random phase approximation +! D_FUNCT = 'LVLA' linearized Vlasov +! D_FUNCT = 'MER1' Mermin +! D_FUNCT = 'BLTZ' Boltzmann +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Jun 2020 +! +! +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCT +! + REAL (WP) :: X,Z,RS,T,TAU + REAL (WP) :: EPSR,EPSI +! + IF(D_FUNCT == 'RPA1') THEN ! + CALL RPA1_EPS_D_TR_3D(X,Z,RS,EPSR,EPSI) ! + ELSE IF(D_FUNCT == 'RPA2') THEN ! + CALL RPA2_EPS_D_TR_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCT == 'LVLA') THEN ! + CALL LVLA_EPS_D_TR_3D(X,Z,RS,T,EPSR,EPSI) ! + ELSE IF(D_FUNCT == 'MER1') THEN ! + CALL MER1_EPS_D_TR_3D(X,Z,RS,TAU,EPSR,EPSI) ! + ELSE IF(D_FUNCT == 'BLTZ') THEN ! + CALL BLTZ_EPS_D_TR_3D(X,Z,RS,TAU,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCT_DYNAMIC_3D +! +!======================================================================= +! + SUBROUTINE RPA1_EPS_D_TR_3D(X,Z,RS,EPSR,EPSI) +! +! This subroutine computes the transvere +! RPA dielectric function EPS(q,omega) for 3D systems. +! +! References: (1) Z. H. Levine and E. Cockayne, +! J. Res. Natl. Inst. Stand. Technol. 113, 299-304 (2008) +! (2) J. Solyom, "Fundamental of the Physics of Solids", +! Vol3, Chap. 29, p. 117, Springer +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Note: +! +! The connection between the two reference is obtained through the relation: +! +! ( k_{TF}/q )^2 = 3 U^2 ( omega_p/omega )^2 +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Jun 2020 +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,EIGHT + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,U,RS + REAL (WP) :: EPSR,EPSI + REAL (WP) :: X1,X2 + REAL (WP) :: Q_SI,O_SI,COEF +! + U=X*Z ! omega / (q * v_F) +! + X1=X-U ! + X2=X+U ! +! + Q_SI=TWO*X*KF_SI ! q in SI + O_SI=U*Q_SI*VF_SI ! omega in SI +! + COEF=ENE_P_SI*ENE_P_SI/(H_BAR*H_BAR*O_SI*O_SI) ! +! +! Real part +! + EPSR=ONE - COEF * ( & ! + THREE*(X*X + THREE*U*U + ONE)/EIGHT - & ! + THREE*( & ! + (ONE-X2*X2)**2 * & ! + DLOG(DABS((X2+ONE)/(X2-ONE))) + & ! eq. (7) ref. 1 + (ONE-X1*X1)**2 * & ! eq. (29.6.87) ref. 2 + DLOG(DABS((X1+ONE)/(X1-ONE))) & ! + ) / (32.0E0_WP*X) & ! + ) ! +! +! Imaginary part +! + IF( U < DABS(ONE-X) ) THEN ! +! + IF(X <= ONE) THEN ! + EPSI=0.75E0_WP*PI*COEF*U*(ONE-U*U-X*X) ! eq. (6) ref. 1 + ELSE ! + EPSI=ZERO ! eq. (29.6.89) ref. 2 + END IF ! +! + ELSE IF( (DABS(ONE-X) <= U) .AND. (U <= (ONE+X)) ) THEN ! +! + EPSI=THREE*PI*COEF * (ONE - (U-X)**2 )**2 / (32.0E0_WP*X) ! eq. (6) ref. 1 +! + ELSE IF( (ONE+X) <= U ) THEN ! +! + EPSI=ZERO ! +! + END IF ! +! + END SUBROUTINE RPA1_EPS_D_TR_3D +! +!======================================================================= +! + SUBROUTINE RPA2_EPS_D_TR_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the transverse temperature-dependent +! RPA dielectric function EPS(q,omega,T) for 3D systems. +! +! References: (1) H. Reinholz et al, Contrib. Plasma Phys. 43, 3-10 (2003) +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Jun 2020 +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE EXT_FUNCTIONS, ONLY : DAWSON + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,U,RS,T + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,O_SI,XX +! + U=X*Z ! omega / (q * v_F) +! + Q_SI=TWO*X*KF_SI ! q in SI + O_SI=U*Q_SI*VF_SI ! omega in SI +! + XX=O_SI*DSQRT(M_E/(TWO*K_B*T))/Q_SI ! +! + EPSR=ONE+ENE_P_SI*ENE_P_SI*DAWSON(XX)/(H_BAR*H_BAR*O_SI*O_SI) ! ref. (1) eq. (10) + EPSI=ZERO ! +! + END SUBROUTINE RPA2_EPS_D_TR_3D +! +!======================================================================= +! + SUBROUTINE LVLA_EPS_D_TR_3D(X,Z,RS,T,EPSR,EPSI) +! +! This subroutine computes the transverse linearized Vlasov dynamical +! dielectric function in 3D +! +! References: (1) S. Ichimaru, "Statistical Plasma Physics - Vol1", +! CRC Press (2004) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * T : temperature (SI) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE EXT_FUNCTIONS, ONLY : W + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,RS,T,U,Y,Y2,V + REAL (WP) :: EPSR,EPSI + REAL (WP) :: ZZ,Q_SI,OM + REAL (WP) :: FR +! + Y=X+X ! Y = q / k_F + Y2=Y*Y ! + U=X*Z ! omega / (q * v_F) + V=Z*Y2 ! omega / omega_{k_F} + Q_SI=TWO*X*KF_SI ! q + OM=V*HALF*H_BAR*KF_SI*KF_SI/M_E ! omega +! + ZZ=U*VF_SI/DSQRT(K_B*T/M_E) ! argument of PDF W(zz) + FR=(ENE_P_SI/(H_BAR*OM))**2 ! (omega_p/omega)^2 +! + EPSR=ONE - FR * (ONE - DREAL(W(ZZ))) ! ref. (2) eq. (4.76) + EPSI=FR * (ONE - DIMAG(W(ZZ))) ! +! + END SUBROUTINE LVLA_EPS_D_TR_3D +! +!======================================================================= +! + SUBROUTINE MER1_EPS_D_TR_3D(X,Z,RS,TAU,EPSR,EPSI) +! +! This subroutine computes the transverse Mermin dynamical +! dielectric function in 3D +! +! References: (1) P.-O. Chapuis et al, Phys. Rev. B 77, 035441 (2008) +! +! Note: for TAU --> infinity, we should recover the RPA values +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Y = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * TAU : relaxation time (used for damping) in SI +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,EIGHT, & + HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE MULTILAYER, ONLY : EPS_1 + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,U,RS,TAU + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,O_SI +! + REAL*8 EPS_INF +! + COMPLEX (WP) :: UU,FT_U,FT_0,FL_U,FL_0 + COMPLEX (WP) :: ZPU,ZMU + COMPLEX (WP) :: COEF,EPS +! + U=X*Z ! omega / (q * v_F) + Q_SI=TWO*X*KF_SI ! q in SI + O_SI=U*Q_SI*VF_SI ! omega in SI +! + COEF=ENE_P_SI*ENE_P_SI/(H_BAR*H_BAR*(O_SI+IC/TAU)) ! +! + UU=(O_SI+IC/TAU)/(Q_SI*VF_SI) ! + ZPU=X+UU ! + ZMU=X-UU ! +! + FL_0=HALF + (ONE-X*X)*DLOG(DABS((X+ONE)/(X-ONE)))/(FOUR*X) ! ref (1) eq. (13) + FL_U=HALF + (ONE-ZMU*ZMU)*CDLOG((ZMU+ONE)/(ZMU-ONE)) / & ! + (EIGHT*X) + & ! + (ONE-ZPU*ZPU)*CDLOG((ZPU+ONE)/(ZPU-ONE)) / & ! + (EIGHT*X) ! ref (1) eq. (11) +! + FT_0=0.375E0_WP*(X*X+ONE) - 0.1875E0_WP*(ONE-X*X)*(ONE-X*X)* &! ref (1) eq. (14) + DLOG(DABS((X+ONE)/(X-ONE)))/X ! + FT_U=0.375E0_WP*(X*X+THREE*UU*UU+ONE) - & ! + 0.09375E0_WP*(ONE-ZMU*ZMU)*(ONE-ZMU*ZMU)* & ! ref (1) eq. (12) + CDLOG((ZMU+ONE)/(ZMU-ONE))/X - & ! + 0.09375E0_WP*(ONE-ZPU*ZPU)*(ONE-ZPU*ZMU)* & ! + CDLOG((ZPU+ONE)/(ZPU-ONE))/X ! +! + EPS=EPS_1 - COEF*( O_SI*(FT_U-THREE*X*X*FL_U) + & ! + IC*(FT_0-THREE*X*X*FL_0)/TAU & ! ref (1) eq. (11) + ) ! +! + EPSR=DREAL(EPS) ! + EPSI=DIMAG(EPS) ! +! + END SUBROUTINE MER1_EPS_D_TR_3D +! +!======================================================================= +! + SUBROUTINE BLTZ_EPS_D_TR_3D(X,Z,RS,TAU,EPSR,EPSI) +! +! This subroutine computes the transverse Boltzmann dynamical +! dielectric function in 3D +! +! References: (1) R. Esquivel and V. B. Stetovoy, Phys. Rev. A 69, 062102 (2004) +! +! Notation: hbar omega_q = hbar q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * TAU : relaxation time (used for damping) in SI +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,U,RS,TAU + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,O_SI +! + COMPLEX (WP) :: UU,U3,COEF + COMPLEX (WP) :: LLOG,FT +! + U=X*Z ! omega / (q * v_F) +! + Q_SI=TWO*X*KF_SI ! q in SI + O_SI=U*Q_SI*VF_SI ! omega in SI +! + UU=Q_SI*VF_SI/(O_SI + IC/TAU) ! ref. (1) eq. (16) + U3=UU*UU*UU ! + COEF=ENE_P_SI*ENE_P_SI/(H_BAR*H_BAR) * & ! + ONE/(O_SI*O_SI + IC*O_SI/TAU) ! + LLOG=CDLOG((ONE+UU)/(ONE-UU)) ! +! + FT=THREE*HALF/U3 * ( UU - HALF*(ONE-UU*UU)*LLOG ) ! ref. (1) eq. (14) +! + EPSR=ONE - DREAL(COEF*FT) ! + EPSI=DIMAG(COEF*FT) ! +! + END SUBROUTINE BLTZ_EPS_D_TR_3D +! +!======================================================================= +! +! 1) 2D case +! +!======================================================================= +! + SUBROUTINE DFUNCT_DYNAMIC_2D(X,Z,D_FUNCT,EPSR,EPSI) +! +! This subroutine computes the transverse dynamic +! dielectric functions in 2D +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * D_FUNCT : type of transverse dielectric function (2D) +! D_FUNCT = 'TRPA' random phase approximation +! +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Jun 2020 +! +! +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCT +! + REAL (WP) :: X,Z,RS + REAL (WP) :: EPSR,EPSI +! + IF(D_FUNCT == 'RPA1') THEN ! + CALL RPA1_EPS_D_TR_2D(X,Z,RS,EPSR,EPSI) ! + END IF ! +! + END SUBROUTINE DFUNCT_DYNAMIC_2D +! +!======================================================================= +! + SUBROUTINE RPA1_EPS_D_TR_2D(X,Z,RS,EPSR,EPSI) +! +! This subroutine computes the transverse +! RPA dielectric function EPS(q,omega,T) for 2D systems. +! +! References: (1) R. Nifosi, S. Conti and M. P. Tosi, +! Phys. Rev. B 58, 12758 (1998) +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / q v_F +! +! Output parameters: +! +! * EPSR : real part of the dielectric function +! * EPSI : imaginary part of the dielectric function +! +! Note: +! +! The dielectric function is obtained from the current-current susceptibility by +! +! eps = 1 - ( omega_p/omega )^2 * [ 1 + m/n * chi ] +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,SIX,THIRD + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,Z,U,RS + REAL (WP) :: EPSR,EPSI + REAL (WP) :: XP,XM,EP,EM,BP,BM + REAL (WP) :: Q_SI,O_SI,COEF +! + U=X*Z ! omega / (q * v_F) +! + XP=X+U ! + XM=X-U ! +! + Q_SI=TWO*X*KF_SI ! q in SI + O_SI=U*Q_SI*VF_SI ! omega in SI +! + COEF=ENE_P_SI*ENE_P_SI/(H_BAR*H_BAR*O_SI*O_SI) ! +! + IF(XP.GE.ONE) THEN ! + EP=SIGN(XP,(XP*XP-ONE)**1.5E0_WP) ! eq. (A7) ref. 1 + BP=ZERO ! + ELSE ! + EP=ZERO ! + BP=(ONE-XP*XP)**1.5E0_WP ! eq. (A4) ref. 1 + ENDIF ! +! + IF(XM.GE.ONE) THEN ! + EM=SIGN(XM,(XM*XM-ONE)**1.5E0_WP) ! eq. (A7) ref. 1 + BM=ZERO ! + ELSE ! + EM=ZERO ! + BM=(ONE-XM*XM)**1.5E0_WP ! eq. (A4) ref. 1 + ENDIF ! +! +! Real part +! + EPSR=ONE-COEF*THIRD* ( & ! + TWO*X*X*X + SIX*U*U*X - EP - EM & ! eq. (A7) ref. 1 + ) / X ! +! +! Imaginary part +! + EPSI=-COEF*THIRD*(BP-BM)/X ! eq. (A4) ref. 1 +! + END SUBROUTINE RPA1_EPS_D_TR_2D +! +END MODULE DFUNCT_STAN_DYNAMIC diff --git a/New_libraries/DFM_library/DIMENSIONS_LIBRARY/dimensions.f90 b/New_libraries/DFM_library/DIMENSIONS_LIBRARY/dimensions.f90 new file mode 100644 index 0000000..f6a7f54 --- /dev/null +++ b/New_libraries/DFM_library/DIMENSIONS_LIBRARY/dimensions.f90 @@ -0,0 +1,37 @@ +! +!======================================================================= +! +MODULE DIMENSION_CODE +! +! This module contains the dimensioning of the epsilon.f90 code +! +! + IMPLICIT NONE +! +! + INTEGER :: NSIZE ! max. number +! ! of energy/momentum/r + PARAMETER (NSIZE=5000) ! points +! + INTEGER :: NZ_MAX ! max. number +! ! of z/r/k + PARAMETER (NZ_MAX=2500) ! integration points +! + INTEGER :: ND_MAX ! max. number +! ! of derivation + PARAMETER (ND_MAX=2500) ! points +! + INTEGER :: MAXITER ! max. number +! ! of + PARAMETER(MAXITER = 30) ! iterations +! + INTEGER :: NOFFN ! max. number +! ! of + PARAMETER(NOFFN = 92) ! output fortran files +! ! of + INTEGER :: L_MAX ! +! ! max. number + PARAMETER (L_MAX=50) ! of +! ! ang. momentum l +END MODULE DIMENSION_CODE + diff --git a/New_libraries/DFM_library/ENERGIES_LIBRARY/PhysRevB.11.113.pdf b/New_libraries/DFM_library/ENERGIES_LIBRARY/PhysRevB.11.113.pdf new file mode 100644 index 0000000..3c7d03c Binary files /dev/null and b/New_libraries/DFM_library/ENERGIES_LIBRARY/PhysRevB.11.113.pdf differ diff --git a/New_libraries/DFM_library/ENERGIES_LIBRARY/correlation_energies.f90 b/New_libraries/DFM_library/ENERGIES_LIBRARY/correlation_energies.f90 new file mode 100644 index 0000000..b9c3d89 --- /dev/null +++ b/New_libraries/DFM_library/ENERGIES_LIBRARY/correlation_energies.f90 @@ -0,0 +1,2278 @@ +! +!======================================================================= +! +MODULE CORRELATION_ENERGIES +! + USE ACCURACY_REAL +! +CONTAINS +! +!------ 1) 3D case -------------------------------------------- +! +!======================================================================= +! + FUNCTION EC_3D(EC_TYPE,IMODE,RS,T) +! +! This subroutine computes the 3D correlation energy EC +! at a given value RS +! +! +! Input parameters: +! +! * EC_TYPE : type of correlation energy functional +! EC_TYPE = 'GEBR_W' --> Gell-Mann and Brueckner +! EC_TYPE = 'CAMA_W' --> Carr and Maradudin +! EC_TYPE = 'EHTY_W' --> Endo-Horiuchi-Takada-Yasuhara +! EC_TYPE = 'HELU_W' --> Hedin and Lundqvist +! EC_TYPE = 'VBHE_W' --> von Barth and Hedin +! EC_TYPE = 'PEZU_W' --> Perdew and Zunger +! EC_TYPE = 'WIGN_S' --> Wigner +! EC_TYPE = 'NOPI_S' --> Nozières and Pines +! EC_TYPE = 'LIRO_S' --> Lindgren and Rosen +! EC_TYPE = 'PEZU_S' --> Perdew and Zunger +! EC_TYPE = 'REHI_S' --> Rebei and Hitchon +! EC_TYPE = 'GGSB_G' --> Gori-Giorgi-Sacchetti-Bachelet +! EC_TYPE = 'PRKO_G' --> Proynov and Kong +! EC_TYPE = 'VWNU_G' --> Vosko, Wilk and Nusair +! EC_TYPE = 'PEWA_G' --> Perdew and Wang +! EC_TYPE = 'HUBB_G' --> Hubbard +! EC_TYPE = 'CHAC_G' --> Chachiyo +! EC_TYPE = 'ISKO_T' --> Isihara and Kojima +! * IMODE : choice of parameters +! IMODE = 1 : no spin polarization +! IMODE = 2 : fully spin-polarized +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * EC_3D : value at RS +! +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Sep 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP) :: EC_3D,RS,T + REAL (WP) :: XI +! + INTEGER :: IMODE +! + XI = 0.0E0_WP ! temporary value +! + IF(EC_TYPE == 'GEBR_W') THEN ! + EC_3D = EC_GB_W(RS) ! + ELSE IF(EC_TYPE == 'CAMA_W') THEN ! + EC_3D = EC_CM_W(RS) ! + ELSE IF(EC_TYPE == 'EHTY_W') THEN ! + EC_3D = EC_EH_W(RS) ! + ELSE IF(EC_TYPE == 'HELU_W') THEN ! + EC_3D = EC_HL_W(RS) ! + ELSE IF(EC_TYPE == 'VBHE_W') THEN ! + EC_3D = EC_BH_W(RS,IMODE) ! + ELSE IF(EC_TYPE == 'PEZU_W') THEN ! + EC_3D = EC_PZ_W(RS,IMODE) ! + ELSE IF(EC_TYPE == 'WIGN_S') THEN ! + EC_3D = EC_W_S(RS) ! + ELSE IF(EC_TYPE == 'NOPI_S') THEN ! + EC_3D = EC_NP_S(RS) ! + ELSE IF(EC_TYPE == 'LIRO_S') THEN ! + EC_3D = EC_LR_S(RS) ! + ELSE IF(EC_TYPE == 'PEZU_S') THEN ! + EC_3D = EC_PZ_S(RS,IMODE) ! + ELSE IF(EC_TYPE == 'REHI_S') THEN ! + EC_3D = EC_RH_S(RS) ! + ELSE IF(EC_TYPE == 'GGSB_G') THEN ! + EC_3D = EC_GG_G(RS) ! + ELSE IF(EC_TYPE == 'PRKO_G') THEN ! + EC_3D = EC_PK_G(RS,IMODE,XI) ! + ELSE IF(EC_TYPE == 'VWNU_G') THEN ! + EC_3D = EC_VWN_G(RS,IMODE) ! + ELSE IF(EC_TYPE == 'PEWA_G') THEN ! + EC_3D = EC_PW_G(RS,IMODE) ! + ELSE IF(EC_TYPE == 'HUBB_G') THEN ! + EC_3D = EC_HU_G(RS) ! + ELSE IF(EC_TYPE == 'CHAC_G') THEN ! + EC_3D = EC_CH_G(RS,IMODE) ! + ELSE IF(EC_TYPE == 'ISKO_T') THEN ! + EC_3D = EC_IK_T(RS,T) ! + END IF ! +! + END FUNCTION EC_3D +! +!======================================================================= +! + SUBROUTINE DERIVE_EC_3D(EC_TYPE,IMODE,IDERIV,RS,T, & + D_EC_1,D_EC_2) +! +! This subroutine computes the first and second derivative +! of the correlation energy E_c with repect to r_s +! at a given value RS +! +! +! Input parameters: +! +! * EC_TYPE : type of correlation energy functional +! EC_TYPE = 'GEBR_W' --> Gell-Mann and Brueckner +! EC_TYPE = 'CAMA_W' --> Carr and Maradudin +! EC_TYPE = 'EHTY_W' --> Endo-Horiuchi-Takada-Yasuhara +! EC_TYPE = 'HELU_W' --> Hedin and Lundqvist +! EC_TYPE = 'VBHE_W' --> von Barth and Hedin +! EC_TYPE = 'PEZU_W' --> Perdew and Zunger +! EC_TYPE = 'WIGN_S' --> Wigner +! EC_TYPE = 'NOPI_S' --> Nozières and Pines +! EC_TYPE = 'LIRO_S' --> Lindgren and Rosen +! EC_TYPE = 'PEZU_S' --> Perdew and Zunger +! EC_TYPE = 'REHI_S' --> Rebei and Hitchon +! EC_TYPE = 'GGSB_G' --> Gori-Giorgi-Sacchetti-Bachelet +! EC_TYPE = 'PRKO_G' --> Proynov and Kong +! EC_TYPE = 'VWNU_G' --> Vosko, Wilk and Nusair +! EC_TYPE = 'PEWA_G' --> Perdew and Wang +! EC_TYPE = 'HUBB_G' --> Hubbard +! EC_TYPE = 'CHAC_G' --> Chachiyo +! EC_TYPE = 'ISKO_T' --> Isihara and Kojima +! * IMODE : choice of parameters +! IMODE = 1 : no spin polarization +! IMODE = 2 : fully spin-polarized +! * IDERIV : type of n_point formula used for derivation (n = IDERIV) +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * D_EC_1 : first derivative at RS +! * D_EC_2 : second derivative at RS +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : ND_MAX + USE DERIVATION + USE INTERPOLATION, ONLY : INTERP_NR,SPLINE,SPLINT +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + INTEGER :: IMODE,IDERIV,I,LOGF +! + REAL (WP) :: RS,RI,T + REAL (WP) :: D_EC_1,D_EC_2 +! + REAL (WP) :: R(ND_MAX),EC(ND_MAX) + REAL (WP) :: D_EC(ND_MAX),DD_EC(ND_MAX) + REAL (WP) :: R_MIN,R_MAX,STEP + REAL (WP) :: XI +! + REAL (WP) :: FLOAT +! + XI = 0.0E0_WP ! temporary value +! + R_MIN = 0.01E0_WP ! + R_MAX = 50.01E0_WP ! + STEP = (R_MAX - R_MIN) / FLOAT(ND_MAX-1) ! +! + LOGF=6 ! +! +! Storing the correlation energy EC as a function of RS +! + DO I=1,ND_MAX ! +! + R(I)=R_MIN+FLOAT(I-1)*STEP ! + RI=R(I) ! +! + IF(EC_TYPE == 'GEBR_W') THEN ! + EC(I) = EC_GB_W(RI) ! + ELSE IF(EC_TYPE == 'CAMA_W') THEN ! + EC(I) = EC_CM_W(RI) ! + ELSE IF(EC_TYPE == 'EHTY_W') THEN ! + EC(I) = EC_EH_W(RI) ! + ELSE IF(EC_TYPE == 'HELU_W') THEN ! + EC(I) = EC_HL_W(RI) ! + ELSE IF(EC_TYPE == 'VBHE_W') THEN ! + EC(I) = EC_BH_W(RS,IMODE) ! + ELSE IF(EC_TYPE == 'PEZU_W') THEN ! + EC(I) = EC_PZ_W(RI,IMODE) ! + ELSE IF(EC_TYPE == 'WIGN_S') THEN ! + EC(I) = EC_W_S(RI) ! + ELSE IF(EC_TYPE == 'NOPI_S') THEN ! + EC(I) = EC_NP_S(RI) ! + ELSE IF(EC_TYPE == 'LIRO_S') THEN ! + EC(I) = EC_LR_S(RI) ! + ELSE IF(EC_TYPE == 'PEZU_S') THEN ! + EC(I) = EC_PZ_S(RI,IMODE) ! + ELSE IF(EC_TYPE == 'REHI_S') THEN ! + EC(I) = EC_RH_S(RI) ! + ELSE IF(EC_TYPE == 'GGSB_G') THEN ! + EC(I) = EC_RH_S(RI) ! + ELSE IF(EC_TYPE == 'PRKO_G') THEN ! + EC(I) = EC_PK_G(RI,IMODE,XI) ! + ELSE IF(EC_TYPE == 'VWNU_G') THEN ! + EC(I) = EC_VWN_G(RI,IMODE) ! + ELSE IF(EC_TYPE == 'PEWA_G') THEN ! + EC(I) = EC_PW_G(RI,IMODE) ! + ELSE IF(EC_TYPE == 'HUBB_G') THEN ! + EC(I) = EC_HU_G(RS) ! + ELSE IF(EC_TYPE == 'CHAC_G') THEN ! + EC(I) = EC_CH_G(RS,IMODE) ! + ELSE IF(EC_TYPE == 'ISKO_T') THEN ! + EC(I) = EC_IK_T(RI,T) ! + END IF ! +! + END DO ! +! +! Computing the first and second derivatives +! with a IDERIV-point formula +! + CALL DERIV_1(EC,ND_MAX,IDERIV,STEP,D_EC) ! + CALL DERIV_1(D_EC,ND_MAX,IDERIV,STEP,DD_EC) ! +! +! Interpolation of derivatives at RS +! + CALL INTERP_NR(LOGF,R,D_EC,ND_MAX,RS,D_EC_1) ! + CALL INTERP_NR(LOGF,R,DD_EC,ND_MAX,RS,D_EC_2) ! +! + END SUBROUTINE DERIVE_EC_3D +! +!======================================================================= +! +! Correlation energy functionals (in Ryd) +! +! Different regimes: * weak coupling : r_s << 1 +! * metallic state : 2 <= r_s <= 6 +! * Wigner crystallization : r_s >= 100 +! +! +!======================================================================= +! +! +! (1) Weak coupling regime: _W +! +! +!======================================================================= +! + FUNCTION EC_GB_W(RS) +! +! Gell-Mann and Brueckner correlation energy +! +! +! Reference: M. Gell-Mann and K. A. Brueckner, Phys. Rev. 106, +! 364-368 (1957) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! Output parameters: +! +! * EC_GB_W : correlation energy (in Ry) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE + USE PI_ETC, ONLY : PI2 + USE ZETA_RIEMANN +! + IMPLICIT NONE +! + REAL (WP) :: RS + REAL (WP) :: EC_GB_W + REAL (WP) :: A,B +! + REAL (WP) :: LOG +! + A = TWO * (ONE - LOG(TWO)) / PI2 ! + B = TWO * LOG(TWO) / THREE - THREE * ZETA(3) / PI2 ! +! + EC_GB_W = A * LOG(RS) - B ! ref. 1 eq. (28) +! + END FUNCTION EC_GB_W +! +!======================================================================= +! + FUNCTION EC_CM_W(RS) +! +! Carr and Maradudin correlation energy +! +! +! Reference: W. J. Carr and A. A. Maradudin, Phys. Rev. 133, +! A371-A374 (1964) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! Output parameters: +! +! * EC_GB_W : correlation energy (in Ry) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE + USE PI_ETC, ONLY : PI2 + USE ZETA_RIEMANN +! + IMPLICIT NONE +! + REAL (WP) :: RS + REAL (WP) :: EC_CM_W + REAL (WP) :: A,B,C,D,E +! + REAL (WP) :: LOG +! + A = TWO * (ONE - LOG(TWO)) / PI2 ! + B = TWO * LOG(TWO) / THREE - THREE * ZETA(3) / PI2 ! + C = 0.018E0_WP ! + D = 0.036E0_WP ! + E = 0.0013E0_WP ! +! + EC_CM_W = A * LOG(RS) - B + RS * (C * LOG(RS) + E - D) ! ref. 1 eq. (27) +! + END FUNCTION EC_CM_W +! +!======================================================================= +! + FUNCTION EC_EH_W(RS) +! +! Endo-Horiuchi-Takada-Yasuhara correlation energy +! +! +! Reference: T. Endo, M. Horiuchi, Y. Takada and H. Yasuhara, +! Phys. Rev. B 59, 7367-7372 (1999) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! Output parameters: +! +! * EC_EH_W : correlation energy (in Ry) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE PI_ETC, ONLY : PI2 +! + IMPLICIT NONE +! + REAL (WP) :: RS + REAL (WP) :: EC_EH_W + REAL (WP) :: AA,BB,CC,DD +! + REAL (WP), PARAMETER :: A = 1.13E0_WP + REAL (WP), PARAMETER :: B = 0.202E0_WP +! + REAL (WP) :: LOG +! + AA = TWO * (ONE - LOG(TWO)) / PI2 ! + BB = 0.0184E0_WP ! + CC = - 0.0938E0_WP ! + DD = 0.020E0_WP ! +! + EC_EH_W = ( AA + (BB * RS)/(ONE + B * RS) ) * & ! + LOG( RS / (ONE + A * RS) ) + & ! ref. 1 eq. (10) + CC / ( ONE + (ONE / CC) * (DD - AA * A) * RS ) ! +! + END FUNCTION EC_EH_W +! +!======================================================================= +! + FUNCTION EC_HL_W(RS) +! +! Hedin and Lundqvist correlation energy +! +! +! Reference: L. Hedin and B. I. Lundqvist, +! J. Phys. C : Solid St. Phys. 4, 2065-2084 (1971) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! Output parameters: +! +! * EC_HL_W : correlation energy (in Ry) +! +! +! +! Author : D. Sébilleau +! +! +! Last modified : 14 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,FOUR,HALF,THIRD + USE PI_ETC, ONLY : PI,PI_INV +! + IMPLICIT NONE +! + REAL (WP) :: RS + REAL (WP) :: EC_HL_W + REAL (WP) :: A,C,X,X2,X3,X_INV +! + REAL (WP) :: LOG +! + A = 21.0E0_WP ! + C = 0.045E0_WP ! +! + X = RS / A ! ref. 1 eq. (3.5) + X2 = X * X ! + X3 = X2 * X ! + X_INV = ONE / X ! +! + EC_HL_W = - C * ( (ONE + X3) * LOG(ONE + X_INV) + & ! ref. 1 eq. (3.8) + HALF * X - X2 - THIRD & ! + ) ! +! + END FUNCTION EC_HL_W +! +!======================================================================= +! + FUNCTION EC_BH_W(RS,IMODE) +! +! von Barth and Hedin correlation energy +! +! +! Reference: U. von Barth and L. Hedin, J. Phys. C: Solid State Phys. 5, +! 1629-1642 (1972) +! +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * IMODE : Choice of parameters +! IMODE = 1 : paramagnetic state +! IMODE = 2 : ferromagnetic state +! +! +! Output parameters: +! +! * EC_BH_W : correlation energy (in Ry) +! +! +! +! Author : D. Sébilleau +! +! +! Last modified : 11 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOUR,HALF,THIRD + USE CUBE_ROOTS, ONLY : CUB2 +! + IMPLICIT NONE +! + INTEGER :: IMODE +! + REAL (WP) :: RS + REAL (WP) :: EC_BH_W + REAL (WP) :: ECP,ECF,NUC + REAL (WP) :: X,XP,XF + REAL (WP) :: FP,FF,FX +! + REAL (WP), PARAMETER :: CP = 0.0504E0_WP + REAL (WP), PARAMETER :: CF = 0.0254E0_WP + REAL (WP), PARAMETER :: RP = 30.0E0_WP + REAL (WP), PARAMETER :: RF = 75.0E0_WP + REAL (WP), PARAMETER :: A = ONE / CUB2 + REAL (WP), PARAMETER :: GAMMA = FOUR * THIRD * A / (ONE - A) +! + REAL (WP) :: LOG +! + IF(IMODE == 1) THEN ! + X = HALF ! + ELSE IF(IMODE == 2) THEN ! + X = ZERO ! + END IF ! +! + FX = ONE / (ONE - A) * ( X**(FOUR*THIRD) + & ! + (ONE - X)**(FOUR*THIRD) - A & ! ref. 1 eq. (5.3) + ) ! +! + XP = RS / RP ! + XF = RS / RF ! +! + FP = (ONE + XP * XP * XP) * LOG(ONE + ONE / XP) + & ! + HALF * XP - XP * XP - THIRD ! ref. 1 eq. (5.11) + FF = (ONE + XF * XF * XF) * LOG(ONE + ONE / XF) + & ! + HALF * XF - XF * XF - THIRD ! +! + ECP = - CP * FP ! ref. 1 eq. (5.10) + ECF = - CF * FF ! +! + NUC = GAMMA * (ECF - ECP) ! ref. 1 eq. (5.6) +! + EC_BH_W = ECP + NUC * FX / GAMMA ! ref. 1 eq. (5.5) +! + END FUNCTION EC_BH_W +! +!======================================================================= +! + FUNCTION EC_PZ_W(RS,IMODE) +! +! Perdew and Zunger correlation energy +! +! +! Reference: J. P. Perdew and A. Zunger, Phys. Rev. B 23, +! 5048- 5079 (1981) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * IMODE : Choice of parameters +! IMODE = 1 : no spin polarization +! IMODE = 2 : fully spin-polarized +! +! +! Output parameters: +! +! * EC_PZ_W : correlation energy (in Ry) +! +! +! Note : final result multiplied by two as the energy values +! are given in Hartree +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! + USE REAL_NUMBERS, ONLY : TWO,THIRD + USE CONSTANTS_P1, ONLY : BOHR +! + IMPLICIT NONE +! + INTEGER :: IMODE +! + REAL (WP) :: RS + REAL (WP) :: EC_PZ_W + REAL (WP) :: A,B,C,D + REAL (WP) :: BB,CC,DD +! + REAL (WP) :: LOG +! + IF(IMODE == 1) THEN ! + A = 0.0311E0_WP ! + B = - 0.0480E0_WP ! + C = 0.0020E0_WP ! ref. 1 table XII + D = - 0.0116E0_WP ! + ELSE IF(IMODE == 2) THEN ! + A = 0.01555E0_WP ! + B = - 0.0269E0_WP ! + C = 0.0007E0_WP ! ref. 1 table XII + D = - 0.0048E0_WP ! + END IF ! +! + BB = B - THIRD * A ! + CC = TWO * THIRD * C ! + DD = THIRD * (TWO * D - C) ! +! + EC_PZ_W = TWO * (A * LOG(RS) + BB + CC * RS * LOG(RS) + & ! ref. 1 eq. (C5) + DD * RS) ! +! + END FUNCTION EC_PZ_W +! +!======================================================================= +! +! (2) Strong coupling regime (r_s small): _S +! +!======================================================================= +! + FUNCTION EC_W_S(RS) +! +! Wigner correlation energy +! +! +! Reference: E. P. Wigner, Phys. Rev. 46, 1002-1011 (1934) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! Output parameters: +! +! * EC_W_S : correlation energy (in Ry) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Sep 2020 +! + IMPLICIT NONE +! + REAL (WP) :: RS + REAL (WP) :: EC_W_S + REAL (WP) :: A,B +! + A = - 0.88E0_WP ! + B = 7.8E0_WP ! +! + EC_W_S = A / (RS + B) ! +! + END FUNCTION EC_W_S +! +!======================================================================= +! + FUNCTION EC_NP_S(RS) +! +! Nozières and Pines correlation energy +! +! +! Reference: G. D. Mahan, "Many-Particle Physics", 2nd edition, +! Plenum Press 1990 +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! + IMPLICIT NONE +! + REAL (WP) :: RS + REAL (WP) :: EC_NP_S + REAL (WP) :: A,B +! + REAL (WP) :: LOG +! + A = - 0.115E0_WP ! + B = 0.031E0_WP ! +! + EC_NP_S = A + B * LOG(RS) ! ref. 1 p. 409 +! + END FUNCTION EC_NP_S +! +!======================================================================= +! + FUNCTION EC_LR_S(RS) +! +! Lindgren and Rosen correlation energy +! +! +! Reference: G. D. Mahan, "Many-Particle Physics", 2nd edition, +! Plenum Press 1990 +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THREE,FOUR +! + IMPLICIT NONE +! + REAL (WP) :: RS + REAL (WP) :: EC_LR_S + REAL (WP) :: A,B,C,D +! + REAL (WP) :: SQRT +! + A = ONE ! + B = THREE ! + C = FOUR ! + D = - 0.08E0_WP ! +! + EC_LR_S = - ONE / (A * RS + B + C * SQRT(RS) + D / SQRT(RS)) ! ref. 1 p. 410 +! + END FUNCTION EC_LR_S +! +!======================================================================= +! + FUNCTION EC_PZ_S(RS,IMODE) +! +! Perdew and Zunger correlation energy +! +! +! Reference: J. P. Perdew and A. Zunger, Phys. Rev. B 23, +! 5048- 5079 (1981) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * IMODE : Choice of parameters +! IMODE = 1 : no spin polarization +! IMODE = 2 : fully spin-polarized +! IMODE = 3 : Emfietzoglou et al values +! +! +! Output parameters: +! +! * EC_PZ_S : correlation energy (in Ry) +! +! +! Note : final result multiplied by two as the energy values +! are given in Hartree +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO +! + IMPLICIT NONE +! + INTEGER :: IMODE +! + REAL (WP) :: RS + REAL (WP) :: EC_PZ_S + REAL (WP) :: A,B,C,D +! + REAL (WP) :: SQRT +! + IF(IMODE == 1) THEN ! + A = - 0.1423E0_WP ! + B = ONE ! + C = 1.0529E0_WP ! + D = 0.3334E0_WP ! + ELSE IF(IMODE == 2) THEN ! + A = - 0.0843E0_WP ! + B = ONE ! + C = 1.3981E0_WP ! + D = 0.2611E0_WP ! + ELSE IF(IMODE == 3) THEN ! + A = - 0.103756E0_WP ! + B = ONE ! + C = 0.56371E0_WP ! + D = 0.27358E0_WP ! + END IF ! +! + EC_PZ_S = TWO * ( A / (B + C * SQRT(RS) + D * RS) ) ! +! + END FUNCTION EC_PZ_S +! +!======================================================================= +! + FUNCTION EC_RH_S(RS) +! +! Rebei and Hitchon correlation energy +! +! +! Reference: A. Rebei and W. N. G. Hitchon, Phys. Lett. A 196, +! 295-299 (1994) +! +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! The formula is: +! +! +! / 1 +! 3 | 2 ( 4 g(x) ) +! Ec = - ------ | x * Log ( 1 + ------------- ) dx +! 4 pi | ( alpha * r_s ) +! / 0 +! +! +! with : +! 1/3 +! ( 4 ) +! * alpha = ( ------ ) +! ( 9 pi ) +! +! 2 +! 1 - x ( 1 + x ) +! * g(x) = 1 + ------- * Log ( ------- ) +! x ( 1 - x ) +! +! +! Note : * for x = 1, we have (1 - x) * Log(1 - x) = 0 so that +! +! g(1) = 1 +! +! * for x = 0, we have g(0) = 3 +! +! +! Warning : we have added a factor a_0 in the final result as eq. (16) +! does not give the results of table 1 ... +! +! Author : D. Sébilleau +! +! Last modified : 10 Sep 2020 +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,THREE,FOUR,HALF + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : ALFA + USE INTEGRATION, ONLY : INTEGR_L + USE ENE_CHANGE, ONLY : BOHR2A +! + IMPLICIT NONE +! + INTEGER :: J +! + INTEGER, PARAMETER :: N_GRID = 100 +! + REAL (WP) :: RS + REAL (WP) :: EC_RH_S + REAL (WP) :: ALPHA,COEF + REAL (WP) :: X,H,A + REAL (WP) :: F(N_GRID),G(N_GRID) +! + REAL (WP) :: FLOAT,LOG +! + ALPHA = ALFA('3D') ! + COEF = - THREE / (FOUR * PI) ! + H = ONE / FLOAT(N_GRID - 1) ! step +! +! Defining the fonction to integrate over a grid +! + DO J = 1,N_GRID ! +! + X = FLOAT(J-1) * H ! +! + IF(J == 1) THEN ! + G(J) = THREE ! + ELSE IF(J > 1 .AND. J < N_GRID) THEN ! + G(J) = ONE + (ONE - X * X) * & ! + LOG((ONE + X) / (ONE - X)) / X ! + ELSE IF(J == N_GRID) THEN ! + G(J) = ONE ! + END IF ! +! + F(J) = X * X * LOG(ONE + (FOUR * G(J)) / (ALPHA * RS)) ! +! + END DO ! +! + CALL INTEGR_L(F,H,N_GRID,N_GRID,A,1) ! +! + EC_RH_S = COEF * A * BOHR2A ! +! + END FUNCTION EC_RH_S +! +!======================================================================= +! +! (3) General coupling regime: _G +! +!======================================================================= +! + FUNCTION EC_GG_G(RS) +! +! Gori-Giorgi, Sacchetti and Bachelet correlation energy +! +! Reference : P. Gori-Giorgi, F. Sacchetti and G. B. Bachelet, +! Phys. Rev. B 61, 7353-7363 (2000) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! Note: the extra factor 2 in the definition comes from the fact +! that the energies here are expressed in Hartree +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FIVE,EIGHT,HALF + USE PI_ETC, ONLY : PI2 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS + REAL (WP) :: EC_GG_G + REAL (WP) :: A1,A2 + REAL (WP) :: B1,B2,B3,B4,B5,B6 + REAL (WP) :: XS,RS2 + REAL (WP) :: NUM,DEN +! + REAL (WP) :: LOG,SQRT,EXP +! + REAL (WP), PARAMETER :: A = (ONE - LOG(TWO)) / PI2 + REAL (WP), PARAMETER :: B = - 0.0469205E0_WP + REAL (WP), PARAMETER :: C = 0.0092292E0_WP + REAL (WP), PARAMETER :: D = - 0.01E0_WP +! + XS = SQRT(RS) ! + RS2 = RS * RS ! +! + A1 = C / A ! + A2 = FIVE ! +! + B1 = HALF * EXP(HALF * B / A) / A ! + B2 = TWO * A * B1 * B1 ! + B3 = HALF * B1 * ( EIGHT * B1 * B1 * A * A * A * A - & ! + C * B + D * A ) / (A * A) ! + B4 = 45.0E0_WP ! + B5 = 32.0E0_WP ! + B6 = 12.7E0_WP ! +! + NUM = - TWO * A * (ONE + A1 * RS + A2 * RS2) ! + DEN = TWO * A * ( B1 * XS + B2 * RS + B3 * RS * XS + & ! + B4 * RS2 + B5 * RS2 * XS + & ! + B6 * RS2 * RS ) ! +! + EC_GG_G = TWO * NUM * LOG(ONE + ONE / DEN) ! ref. (1) eq. (B1) +! + END FUNCTION EC_GG_G +! +!======================================================================= +! + FUNCTION EC_PK_G(RS,IMODE,XI) +! +! Proynov and Kong correlation energy +! +! +! Reference: (1) E. Proynov and J. Kong, Phys. Rev. A 79, 014103 (2009) +! (2) E. Proynov and J. Kong, Phys. Rev. A 95, 059904(E) (2017) +! (3) E. Proynov, J. Mol. Struc.: THEOCHEM 139–145 (2006) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * IMODE : Choice of parameters +! IMODE = 1 : no spin polarization +! IMODE = 2 : fully spin-polarized +! * XI : spin polarization +! +! +! Warning : Only non-polarized case implemented at present, +! i.e. XI = 0 so that NP = NM = N0/2 +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,HALF,THIRD + USE PI_ETC, ONLY : PI,PI2 +! + IMPLICIT NONE +! + INTEGER :: IMODE +! + REAL (WP), INTENT(IN) :: RS,XI + REAL (WP) :: EC_PK_G + REAL (WP) :: XS + REAL (WP) :: N0,NP,NM + REAL (WP) :: ALPHA_N,ALPHA_XI,ALPHA_EFF + REAL (WP) :: FR,FS,P1,P2,P3,P4,SRX + REAL (WP) :: KF,KS + REAL (WP) :: D1,D2,D3,D4,D5,D6,D7,D8 + REAL (WP) :: Q1,Q2,Q3 + REAL (WP) :: S1 + REAL (WP) :: ECP,ECM +! + REAL (WP), PARAMETER :: AX = (THREE * PI2)**THIRD ! ref. 2 (ii) +! + REAL (WP) :: A(18),C(29),ETA(10) + REAL (WP) :: AA(0:5),BB(0:4),CC(0:4),DD(0:3) +! + REAL (WP) :: EXP,SQRT,ATAN,LOG +! + DATA A / 0.184630439485191E0_WP, & ! a_1 + 5.939656549519008E0_WP, & ! a_2 + 2.369580128666418E0_WP, & ! a_3 + 0.051188865525959E0_WP, & ! a_4 + 0.095768925320043E0_WP, & ! a_5 + 0.028359261614488E0_WP, & ! a_6 + 0.022627416997970E0_WP, & ! a_7 + 0.005317361552717E0_WP, & ! a_8 + 0.191537850640085E0_WP, & ! a_9 ref. 1 table III + 0.147313777119493E0_WP, & ! a_10 + 0.152825093835090E0_WP, & ! a_11 + 1.015083075438391E0_WP, & ! a_12 + 0.076412546917545E0_WP, & ! a_13 + 0.898537460263473E0_WP, & ! a_14 + 0.017956673497508E0_WP, & ! a_15 + 0.034618207403477E0_WP, & ! a_16 + 0.035913346995016E0_WP, & ! a_17 + 0.222017353476156E0_WP/ ! a_17 +! + DATA C / 132.479090287794E0_WP , & ! c_1 + 32.4014708516771E0_WP , & ! c_2 + 22.5664453162504E0_WP , & ! c_3 + 11.2832226581252E0_WP , & ! c_4 + 0.40106052394096E0_WP , & ! c_5 + 0.32000000000000E0_WP , & ! c_6 + 0.07519884823893E0_WP , & ! c_7 + 116.935042647481E0_WP , & ! c_8 + 29.6240023046901E0_WP , & ! c_9 + 0.48225718199447E0_WP , & ! c_10 + 0.24690398117910E0_WP , & ! c_11 + 0.50000000000000E0_WP , & ! c_12 + 0.41070969677819E0_WP , & ! c_13 + 0.10532352447677E0_WP , & ! c_14 + 14.5650971711660E0_WP , & ! c_15 ref. 1 table III + 0.78125000000000E0_WP , & ! c_16 + 0.62334731312724E0_WP , & ! c_17 + 0.14648437500000E0_WP , & ! c_18 + 111.8115481057978E0_WP , & ! c_19 + 0.160041105570901E0_WP, & ! c_20 + 0.781250000000000E0_WP, & ! c_21 + 0.320866950607957E0_WP, & ! c_22 + 13.28444950729984E0_WP , & ! c_23 + 0.268418671319107E0_WP, & ! c_24 + 0.471060597934992E0_WP, & ! c_25 + 0.250000000000000E0_WP, & ! c_26 + 0.252882919616990E0_WP, & ! c_27 + 0.072048583112715E0_WP, & ! c_28 + 42.64905448910311E0_WP / ! c_29 +! + DATA ETA / 0.538074483500437E0_WP, & ! eta_1 + -2.226094990985190E0_WP, & ! eta_2 + 0.837303782322808E0_WP, & ! eta_3 + 2.619709858963178E0_WP, & ! eta_4 + 1.036657594643520E0_WP, & ! eta_5 in text of appendix + 0.41081146652128E0_WP , & ! eta_6 + 0.599343256903515E0_WP, & ! eta_7 + 1.70939476802168E0_WP , & ! eta_8 + 0.077123208419481E0_WP, & ! eta_9 + 0.46958449007619E0_WP / ! eta_10 +! + DATA AA /-113.693369789727190E0_WP , & ! a_0 + 24.00502151278711440E0_WP, & ! a_1 + 49.34131295839670750E0_WP, & ! a_2 in text of appendix + -23.8242372168379302E0_WP , & ! a_3 for eq. (24)-(25) + 0.944080741695104794E0_WP, & ! a_4 + 0.000293039144178338E0_WP/ ! a_5 +! + DATA BB /-109.74263493216910E0_WP , & ! b_0 + 16.2663129444242415E0_WP , & ! b_1 in text of appendix + 54.4034331373908366E0_WP , & ! b_2 for eq. (24)-(25) + -25.154009904187990E0_WP , & ! b_3 + 1.0000000000000000E0_WP / ! b_4 +! + DATA CC / -0.32481568604919886E0_WP , & ! c_0 + 1.180131465463191050E0_WP, & ! c_1 in text of appendix + -1.42693041498421640E0_WP , & ! c_2 for eq. (24)-(25) + 0.580344063812247980E0_WP, & ! c_3 + -0.01099122367291440E0_WP / ! c_4 +! + DATA DD / -0.57786103193239430E0_WP , & ! d_0 + 2.09708505883490736E0_WP , & ! d_1 in text of appendix + -2.52188183586948180E0_WP , & ! d_2 for eq. (24)-(25) + 1.00000000000000000E0_WP / ! D_3 +! + XS = RS**THIRD ! +! + S1 = 1.28E0_WP ! +! +! Spin-polarized densities +! + N0 = FOUR * PI * THIRD * RS * RS * RS ! N0 in a. u. + NP = HALF * N0 * (ONE + XI) ! ref. 1 eq. (16) + NM = HALF * N0 * (ONE - XI) ! +! +! Screened Fermi wave vector calculation (eq. (17)) +! + P1 = AA(0) + AA(1) * RS + AA(2) * RS * RS + & ! + AA(3) * RS * RS * RS + AA(4) * RS * RS * RS * RS + & ! ref. 1 eq. (24) + AA(5) * RS * RS * RS * RS * RS ! + P2 = BB(0) + BB(1) * RS + BB(2) * RS * RS + & ! ref. 1 eq. (24) + BB(3) * RS * RS * RS + BB(4) * RS * RS * RS * RS ! + P3 = CC(0) + CC(1) * XI + CC(2) * XI * XI + & ! ref. 1 eq. (25) + CC(3) * XI * XI * XI + CC(4) * XI * XI * XI * XI ! + P4 = DD(0) + DD(1) * XI + DD(2) * XI * XI + & ! ref. 1 eq. (25) + DD(3) * XI * XI * XI ! +! + FR = P1 / P2 ! ref. 1 eq. (24) + FS = P3 / P4 ! ref. 1 eq. (25) +! + SRX = S1 * FR * FS ! ref. 2 eq. (23) +! + ALPHA_XI = TWO / ( (ONE + XI)**SRX + (ONE - XI)**SRX ) ! ref. 1 eq. (22) +! + ALPHA_N = ETA(6) + ETA(7) * EXP(- ETA(8) * XS) * XS * XS + & ! + ETA(9) * EXP(- ETA(10) * XS) * XS ! ref. 1 eq. (21) +! + ALPHA_EFF = ALPHA_N * ALPHA_XI ! ref. 1 eq. (20) +! + KF = AX * (N0 * (ONE + XI))**THIRD ! ref. 1 eq. (15) +! + KS = ALPHA_EFF * KF ! ref. 1 eq. (17) +! +! Calculation of the Dn polynomials +! + D1 = A(6) * KS * KS + A(7) * KS + A(8) ! + D2 = A(1) * KS * KS + A(10) * KS + A(16) ! + D3 = A(5) * KS * KS + A(13) * KS + A(15) ! + D4 = A(9) * KS * KS + A(11) * KS + A(17) ! + D5 = C(5) * KS * KS + C(6) * KS + C(7) ! + D6 = C(12) * KS * KS + C(13) * KS + C(14) ! + D7 = C(16) * KS * KS + C(17) * KS + C(18) ! + D8 = SQRT( C(26) * KS * KS + C(27) * KS + C(28) ) ! +! +! Computation of the Qn functions +! + Q1 = ( - ATAN( A(2) * KS + A(3) ) * D2 / KS - & ! + D3 * LOG(D1) / KS + D4 * LOG(KS) / KS - & ! ref. 1 eq. (8) + A(4) * KS + A(12) + A(14) / KS + A(18) / (KS * KS) & ! + ) / D1 ! +! + Q2 = - C(1) / KS - C(2) / (KS * KS) - C(3) * LOG(KS) / KS + & ! + C(4) * LOG(D5) / KS + & ! + C(8) * ATAN( A(2) * KS + A(3) ) / KS + & ! ref. 1 eq. (9) + C(9) * LOG( KS + C(10) ) / KS - & ! + C(11) * LOG(D6) / KS ! +! + Q3 = C(19) * ATAN( C(20) / ( C(21) * KS + C(22) ) ) / KS - & ! + C(23) * ATAN( (C(24) + C(25) * KS) / D8 ) / KS - & ! ref. 1 eq. (10) + C(15) * LOG(D7) / KS - C(29) * D8 / (KS * KS) ! +! + ECP = HALF * NP * NP * (Q1 + Q2 + Q3) / N0 ! ref. 1 eq. (14) + ECM = HALF * NM * NM * (Q1 + Q2 + Q3) / N0 ! +! +! Correlation energy (Ry) +! + EC_PK_G = TWO * (ECP + ECM) ! ref. 1 eq. (13) +! + END FUNCTION EC_PK_G +! +!======================================================================= +! +! + FUNCTION EC_VWN_G(RS,IMODE) +! +! Vosko, Wilk and Nusair correlation energy +! +! +! Reference: S. H. Vosko, L. Wilk and M. Nusair, +! Can J . Phys. 58, 1200-1211 (1980) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * IMODE : Choice of parameters +! IMODE = 1 : no spin polarization +! IMODE = 2 : fully spin-polarized +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOUR +! + IMPLICIT NONE +! + INTEGER :: IMODE +! + REAL (WP) :: RS + REAL (WP) :: EC_VWN_G + REAL (WP) :: X,X0,XX,XX0,Q + REAL (WP) :: Q2XB + REAL (WP) :: A,B,C +! + REAL (WP) :: SQRT,LOG,ATAN +! + IF(IMODE == 1) THEN ! + X0 = - 0.409286E0_WP ! + A = 0.0621814E0_WP / 1.32139E0_WP ! +! A = 0.0621814E0_WP ! + B = 13.0720E0_WP ! + C = 42.7198E0_WP ! + ELSE IF(IMODE == 2) THEN ! + X0 = - 0.743294E0_WP ! + A = 0.0310907E0_WP ! + B = 20.1231E0_WP ! + C = 101.578E0_WP ! + END IF ! +! + X = SQRT(RS) ! +! + XX = X * X + B * X + C ! + XX0 = X0 * X0 + B * X0 + C ! + Q = SQRT(FOUR * C - B * B) ! +! + Q2XB = Q / (TWO * X + B ) ! +! + EC_VWN_G = A * ( LOG(RS / XX) + TWO * B * ATAN(Q2XB) / Q - & ! + B * X0 * ( LOG((X - X0)**2 / XX) + & ! + TWO * (B + TWO * X0) * & ! ref. 1 eq. (4.4) + ATAN(Q2XB) / Q & ! + ) / XX0 & ! + ) ! +! + END FUNCTION EC_VWN_G +! +!======================================================================= +! + FUNCTION EC_PW_G(RS,IMODE) +! +! Perdew and Wang correlation energy +! +! +! Reference: J. P. Perdew and Y. Wang, Phys. Rev. B 45, +! 13244-13249 (1992) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * IMODE : Choice of parameters +! IMODE = 1 : no spin polarization +! IMODE = 2 : fully spin-polarized +! +! +! Note: the extra factor 2 in the definition comes from the fact +! that the energies here are expressed in Hartree +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR +! + IMPLICIT NONE +! + INTEGER :: IMODE +! + REAL (WP) :: RS + REAL (WP) :: EC_PW_G + REAL (WP) :: A,A1,B1,B2,B3,B4 + REAL (WP) :: U,Z +! + REAL (WP) :: SQRT,LOG +! + IF(IMODE == 1) THEN ! + A = 0.0310907E0_WP ! + A1 = 0.21370E0_WP ! + B1 = 7.5957E0_WP ! + B2 = 3.5876E0_WP ! ref. 1 table I + B3 = 1.6382E0_WP ! + B4 = 0.49294E0_WP ! + ELSE IF(IMODE == 2) THEN ! + A = 0.015545E0_WP ! + A1 = 0.20548E0_WP ! + B1 = 14.1189E0_WP ! + B2 = 6.1977E0_WP ! + B3 = 3.3662E0_WP ! + B4 = 0.62517E0_WP ! + END IF ! +! + U = SQRT(RS) ! + Z = TWO * A * (B1 * U + B2 * RS + B3 * RS * U + B4 * RS * RS) ! +! + EC_PW_G = - FOUR * A * (ONE + A1 * RS) * LOG(ONE + ONE / Z) ! ref. 1 eq. (10) +! + END FUNCTION EC_PW_G +! +!======================================================================= +! + FUNCTION EC_HU_G(RS) +! +! Hubbard correlation energy +! +! Reference : J. Hubbard, Proc. Roy. Soc. A 243, 336-352 (1958) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Sep 2020 +! +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,HALF,FOURTH + USE PI_ETC, ONLY : PI,PI_INV + USE FERMI_AU, ONLY : EF_AU + USE UTILITIES_1, ONLY : ALFA + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + INTEGER :: IX,IY +! + REAL (WP) :: RS + REAL (WP) :: EC_HU_G + REAL (WP) :: XI,HX,HY + REAL (WP) :: X,X3,Y + REAL (WP) :: A(NZ_MAX,NZ_MAX) + REAL (WP) :: SIGMA(NZ_MAX,NZ_MAX) + REAL (WP) :: F1(NZ_MAX),F2(NZ_MAX) + REAL (WP) :: INT_1,INT_2 + REAL (WP) :: NUM1,NUM2,DEN1,DEN2,Z1,Z2 +! + REAL (WP), PARAMETER :: MX = 5.0E0_WP ! upper integration + REAL (WP), PARAMETER :: MY = 5.0E0_WP ! bounds in x and y +! + REAL (WP), PARAMETER :: SM = 1.0E-8_WP ! starting grid value +! + REAL (WP) :: FLOAT,LOG,ABS +! + XI = TWO * ALFA('3D') * PI_INV * RS ! ref. 1 eq. (28) +! + HX = MX / FLOAT(NZ_MAX - 1) ! x-step + HY = MY / FLOAT(NZ_MAX - 1) ! y-step +! +! Construction the functions A and Sigma +! + DO IX = 1, NZ_MAX ! +! + X = SM + FLOAT(IX - 1) * HX ! + X3 = X * X * X ! +! + DO IY = 1, NZ_MAX ! +! + Y = SM + FLOAT(IY - 1) * HY ! +! +! Calculation of Sigma(x,y) ! ref. 1 eq. (26) +! + IF(Y > X * (X + TWO)) THEN ! + SIGMA(IX,IY) = ZERO ! + ELSE IF(X > TWO .AND. Y < X * (X - TWO)) THEN ! + SIGMA(IX,IY) = ZERO ! + ELSE IF( X > TWO .AND. X * (X - TWO) < Y .AND. & ! + Y < X * (X + TWO) & ! + .OR. & ! + X < TWO .AND. X * (TWO - X) < Y .AND. & ! + Y < X * (X + TWO) & ! + ) THEN ! + SIGMA(IX,IY) = - PI * XI * HALF * ( ONE - FOURTH * & ! + (Y / X - X)**2 & ! + ) / X3 ! + ELSE IF(X < TWO .AND. ZERO < Y .AND. & ! + Y < X * (TWO - X)) THEN ! + SIGMA(IX,IY) = - PI * XI * Y * HALF / X3 ! + END IF ! +! +! Calculation of A(x,y) ! ref. 1 eq. (27) +! + NUM1 = Y - X * (X + TWO) ! + NUM2 = Y + X * (X + TWO) ! + DEN1 = Y - X * (X - TWO) ! + DEN2 = Y + X * (X - TWO) ! +! + Z1 = (Y / X - X)**2 ! + Z2 = (Y / X + X)**2 ! +! + A(IX,IY) = - XI * ( X + & ! + HALF * (ONE - FOURTH * Z1) * & ! + LOG(ABS(NUM1 / DEN1)) + & ! + HALF * (ONE - FOURTH * Z2) * & ! + LOG(ABS(NUM2 / DEN2)) & ! + ) / X3 ! +! +! y-integrand +! + F2(IY) = ATAN( SIGMA(IX,IY) / (ONE - A(IX,IY)) ) - & ! + SIGMA(IX,IY) ! +! + END DO ! +! +! Computing the integral over y +! + CALL INTEGR_L(F2,HY,NZ_MAX,NZ_MAX,INT_2,1) ! +! +! x-integrand +! + F1(IX) = X * X * INT_2 ! +! + + END DO ! +! +! Computing the integral over x +! + CALL INTEGR_L(F1,HX,NZ_MAX,NZ_MAX,INT_1,1) ! +! + EC_HU_G = - THREE * FOURTH * PI_INV * EF_AU * INT_1 ! +! + END FUNCTION EC_HU_G +! +!======================================================================= +! + FUNCTION EC_CH_G(RS,IMODE) +! +! Chachiyo correlation energy +! +! Reference : T. Chachiyo, J. Chem. Phys. 145, 021101 (2016) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * IMODE : Choice of parameters +! IMODE = 1 : no spin polarization +! IMODE = 2 : fully spin-polarized +! +! Note: the extra factor 2 in the definition comes from the fact +! that the energies here are expressed in Hartree +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR + USE PI_ETC, ONLY : PI2 +! + IMPLICIT NONE +! + INTEGER :: IMODE +! + REAL (WP) :: RS + REAL (WP) :: EC_CH_G + REAL (WP) :: A,B +! + REAL (WP) :: LOG +! + IF(IMODE == 1) THEN ! + A = (LOG(TWO) - ONE) / (TWO * PI2) ! + B = 20.4562557E0_WP ! + ELSE IF(IMODE == 2) THEN ! + A = (LOG(TWO) - ONE) / (FOUR * PI2) ! + B = 27.4203609E0_WP ! + END IF ! +! + EC_CH_G = TWO * A * LOG( ONE + B / RS + B / (RS * RS) ) ! ref. 1 eq. (1) +! + END FUNCTION EC_CH_G +! +!======================================================================= +! + FUNCTION EC_IK_T(RS,T) +! +! Temperature-dependent correlation energy for 3D systems +! +! References: A. Isihara and D. Y. Kojima, Z. Physik B 21, +! 33-45 (1975) +! +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI2 + USE ENE_CHANGE, ONLY : EV,RYD + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP) :: RS,T + REAL (WP) :: EC_IK_T + REAL (WP) :: EC_0,EC_T + REAL (WP) :: A0,B0,AT,BT,CT,DT + REAL (WP) :: ETA_0,P02,ALPHA,BETA + REAL (WP) :: KF2 +! + REAL (WP) :: LOG +! + ALPHA = ALFA('3D') ! + T = 0.0001E0_WP +! + BETA = ONE / (K_B * T) ! in SI + P02 = EF_SI ! in SI + ETA_0 = BETA * P02 ! dimensionless +! +! + A0 = - 0.08140E0_WP ! + B0 = 0.06218E0_WP ! ref. (1) eq. (3.7) +! + AT = 1.42728E0_WP ! + BT = - 0.15198E0_WP ! ref. (1) eq. (3.7) + CT = - 0.61594E0_WP ! + DT = - 0.30396E0_WP ! +! + EC_0 = A0 + B0 * LOG(RS) ! + EC_T = PI2 * ( AT + BT * LOG(RS) + CT * LOG(ETA_0) + & ! + DT * LOG(ETA_0) * LOG(ETA_0) & ! ref. (1) eq. (3.7) + ) / (12.0E0_WP * ETA_0**2) ! +! + EC_IK_T = EC_0 - EC_T ! ref. (1) eq. (3.7) +! + END FUNCTION EC_IK_T +! +!------ 2) 2D case -------------------------------------------- +! +! +!======================================================================= +! + FUNCTION EC_2D(EC_TYPE,RS,T) +! +! This subroutine computes the 2D correlation energy EC +! at a given value RS +! +! +! Input parameters: +! +! * EC_TYPE : type of correlation energy functional +! EC_TYPE = 'TACE_G' --> Tanatar-Ceperley +! EC_TYPE = 'CPPA_G' --> Seidl-Perdew_Levy +! EC_TYPE = 'AMGB_G' --> Attaccalite-Moroni-Gori-Giorgi-Bachelet +! EC_TYPE = 'SEID_G' --> Seidl +! EC_TYPE = 'LOOS_W' --> Loos +! EC_TYPE = 'WIGN_S' --> Wigner +! EC_TYPE = 'ISTO_T' --> Isihara-Toyoda +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * EC_2D : value at RS +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP) :: EC_2D,RS,T +! + IF(EC_TYPE == 'TACE_G') THEN ! + EC_2D = EC_TC_G(RS) ! + ELSE IF(EC_TYPE == 'CPPA_G') THEN ! + EC_2D = EC_SP_G(RS) ! + ELSE IF(EC_TYPE == 'AMGB_G') THEN ! + EC_2D = EC_MG_G(RS) ! + ELSE IF(EC_TYPE == 'SEID_G') THEN ! + EC_2D = EC_SE_G(RS) ! + ELSE IF(EC_TYPE == 'LOOS_W') THEN ! + EC_2D = EC_L2_W(RS) ! + ELSE IF(EC_TYPE == 'WIGN_S') THEN ! + EC_2D = EC_W2_S(RS) ! + ELSE IF(EC_TYPE == 'ISTO_T') THEN ! + EC_2D = EC_IT_T(RS,T) ! + END IF ! +! + END FUNCTION EC_2D +! +!======================================================================= +! + SUBROUTINE DERIVE_EC_2D(EC_TYPE,IDERIV,RS,T,D_EC_1,D_EC_2) +! +! This subroutine computes the first and second derivative +! of the correlation energy E_c with repect to r_s +! at a given value RS +! +! +! Input parameters: +! +! * EC_TYPE : type of correlation energy functional +! EC_TYPE = 'TACE_G' --> Tanatar-Ceperley +! EC_TYPE = 'CPPA_G' --> Seidl-Perdew_Levy +! EC_TYPE = 'AMGB_G' --> Attaccalite-Moroni-Gori-Giorgi-Bachelet +! EC_TYPE = 'SEID_G' --> Seidl +! EC_TYPE = 'LOOS_W' --> Loos +! EC_TYPE = 'WIGN_S' --> Wigner +! EC_TYPE = 'ISTO_T' --> Isihara-Toyoda +! * IDERIV : type of n_point formula used for derivation (n = IDERIV) +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * D_EC_1 : first derivative at RS +! * D_EC_2 : second derivative at RS +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : ND_MAX + USE DERIVATION + USE INTERPOLATION, ONLY : INTERP_NR,SPLINE,SPLINT +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + INTEGER :: IDERIV,I,LOGF +! + REAL (WP) :: RS,RI,T + REAL (WP) :: D_EC_1,D_EC_2 +! + REAL (WP) :: R(ND_MAX),EC(ND_MAX) + REAL (WP) :: D_EC(ND_MAX),DD_EC(ND_MAX) + REAL (WP) :: R_MIN,R_MAX,STEP +! + REAL (WP) :: FLOAT +! + R_MIN = 0.01E0_WP ! + R_MAX = 50.01E0_WP ! + STEP = (R_MAX - R_MIN) / FLOAT(ND_MAX - 1) ! +! + LOGF = 6 ! +! +! Storing the correlation energy EC as a function of RS +! + DO I = 1,ND_MAX ! +! + R(I) = R_MIN + FLOAT(I - 1) * STEP ! + RI = R(I) ! +! + IF(EC_TYPE == 'TACE_G') THEN ! + EC(I) = EC_TC_G(RI) ! + ELSE IF(EC_TYPE == 'CPPA_G') THEN ! + EC(I) = EC_SP_G(RI) ! + ELSE IF(EC_TYPE == 'AMGB_G') THEN ! + EC(I) = EC_MG_G(RI) ! + ELSE IF(EC_TYPE == 'SEID_G') THEN ! + EC(I) = EC_SE_G(RI) ! + ELSE IF(EC_TYPE == 'LOOS_W') THEN ! + EC(I) = EC_L2_W(RI) ! + ELSE IF(EC_TYPE == 'WIGN_S') THEN ! + EC(I) = EC_W2_S(RI) ! + ELSE IF(EC_TYPE == 'ISTO_T') THEN ! + EC(I) = EC_IT_T(RI,T) ! + END IF ! +! + END DO ! +! +! Computing the first and second derivatives +! with a IDERIV-point formula +! + CALL DERIV_1(EC,ND_MAX,IDERIV,STEP,D_EC) ! + CALL DERIV_1(D_EC,ND_MAX,IDERIV,STEP,DD_EC) ! +! +! Interpolation of derivatives at RS +! + CALL INTERP_NR(LOGF,R,D_EC,ND_MAX,RS,D_EC_1) ! + CALL INTERP_NR(LOGF,R,DD_EC,ND_MAX,RS,D_EC_2) ! +! + END SUBROUTINE DERIVE_EC_2D +! +!======================================================================= +! +! Exchange/Correlation energy functionals (in Ryd) +! +! Different regimes: * weak coupling : r_s << 1 +! * metallic state : 2 <= r_s <= 6 +! * Wigner crystallization : r_s >= 100 +! +! +! (1) General coupling regime: _G +! +!======================================================================= +! + FUNCTION EC_TC_G(RS) +! +! Tanatar-Ceperley correlation energy for 2D systems +! +! References: (1) B. Tanatar and D. M. Ceperley, Phys. Rev. B 39, +! 5005-5016 (1989) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE +! + IMPLICIT NONE +! + REAL (WP) :: RS,X + REAL (WP) :: A0,A1,A2,A3 + REAL (WP) :: NUM,DEN + REAL (WP) :: EC_TC_G +! + REAL (WP) :: SQRT +! + A0 =- 0.3568E0_WP ! + A1 = 1.1300E0_WP ! ref. (1) table IV + A2 = 0.9052E0_WP ! + A3 = 0.4165E0_WP ! +! + X = SQRT(RS) ! +! + NUM = ONE + A1 * X ! + DEN = ONE + A1 * X + A2 * X * X + A3 * X * X * X ! +! + EC_TC_G = A0 * NUM / DEN ! ref. (1) eq. (14) +! + END FUNCTION EC_TC_G +! +!======================================================================= +! + FUNCTION EC_SP_G(RS) +! +! Seidl-Perdew-Levy correlation energy for 2D systems +! +! References: (1) L. A. Constantin, J. P. Perdew and J. M. Pitarke, +! Phys. Rev. Lett. 101, 269902 (2008) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE +! + IMPLICIT NONE +! + REAL (WP) :: RS + REAL (WP) :: A0,A1,A2 + REAL (WP) :: EC_SP_G +! + REAL (WP) :: SQRT +! + A0 = 0.5058E0_WP ! + A1 = 1.3311E0_WP ! + A2 = 1.5026E0_WP ! +! + EC_SP_G = A0 * (A1 / (RS * RS) * (SQRT(ONE + A2 * RS) - ONE) - & ! + ONE / (RS * RS)) ! ref. (1) eq. (9) +! + END FUNCTION EC_SP_G +! +!======================================================================= +! + FUNCTION EC_MG_G(RS) +! +! Attaccalite-Moroni-Gori-Giorgi-Bachelet correlation energy for 2D systems +! +! References: (1) C. Attaccalite, S. Moroni, P. Gori-Giorgi and +! G. B. Bachelet, Phys. Rev. Lett. 88, 256601 (2002) +! (2) Erratum: Phys. Rev. Lett. 91, 109902 (2003) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE +! + IMPLICIT NONE +! + REAL (WP) :: RS,R1,R2,R3,X3 + REAL (WP) :: A0,B0,C0,D0,E0,F0,G0,H0 + REAL (WP) :: EC_MG_G +! + REAL (WP) :: SQRT,LOG +! + X3 = SQRT(RS) * RS ! + R1 = RS ! + R2 = RS * RS ! + R3 = R2 * RS ! +! + A0 = - 0.1925E0_WP ! + B0 = 0.0863136E0_WP ! + C0 = 0.0572384E0_WP ! ref. (1) + E0 = 1.0022E0_WP ! and + F0 = - 0.02069E0_WP ! ref. (2) + G0 = 0.33997E0_WP ! table II + H0 = 1.747E-02_WP ! +! + D0 = - A0 * H0 ! +! + EC_MG_G = A0 + (B0 * R1 + C0 * R2 + D0 * R3) * & ! ref. (1) eq. (3) + LOG(ONE + ONE / ( E0 * R1 + F0 * X3 + & ! + G0 * R2 + H0 * R3 )) ! and eq. (4) +! + END FUNCTION EC_MG_G +! +!======================================================================= +! + FUNCTION EC_SE_G(RS) +! +! Seidl correlation energy for 2D systems, based on the +! interaction-strength interpolation (ISI) +! +! References: (1) M. Seidl, Phys. Rev. B 70, 073101 (2004) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,EIGHT,THIRD + USE PI_ETC, ONLY : PI_INV + USE DIRICHLET +! + IMPLICIT NONE +! + REAL (WP) :: RS + REAL (WP) :: B0,CX,AI,X,Y,Z + REAL (WP) :: EC_SE_G +! + REAL (WP) :: SQRT,LOG +! + B0 = LOG(TWO) + DB(2) - EIGHT * DB(4) * PI_INV * PI_INV ! + CX = - FOUR * SQRT(TWO) * THIRD * PI_INV ! + AI = - 1.1061E0_WP ! +! + X = - B0 / (CX - AI)**2 * ONE / RS ! + Y = FOUR * B0 * B0 / (CX - AI)**4 * RS ! ref. (1) eq. (20) + Z = - B0 / (CX - AI)**3 - ONE ! +! + EC_SE_G = AI / RS + TWO * X / Y * ( &! + SQRT(ONE + Y) - ONE - &! ref. (1) eq. (19) + Z * LOG(( SQRT(ONE + Y) &! + + Z) / ( ONE + Z)) &! + ) ! +! + END FUNCTION EC_SE_G +! +! (2) Weak coupling regime: _W +! +!======================================================================= +! + FUNCTION EC_L2_W(RS) +! +! Weak coupling correlation energy for 2D systems +! +! References: (1) P.-F. Loos, J. Chem. Phys. 138, 064108 (2013) + +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,EIGHT,TEN,THIRD + USE PI_ETC, ONLY : PI_INV + USE DIRICHLET +! + IMPLICIT NONE +! + REAL (WP) :: RS + REAL (WP) :: LAMBDA_0,LAMBDA_1,E_0 + REAL (WP) :: EC_L2_W +! + REAL (WP) :: SQRT,LOG +! + LAMBDA_0 = ZERO ! + LAMBDA_1 = - SQRT(TWO) * (TEN * THIRD * PI_INV - ONE) ! ref. (1) table I + E_0 = LOG(TWO) + DB(2) - EIGHT * DB(4) * PI_INV * PI_INV ! +! + EC_L2_W = LAMBDA_0 * LOG(RS) + E_0 + LAMBDA_1 * RS* LOG(RS) ! ref. (1) eq. (1) +! + END FUNCTION EC_L2_W +! +! (3) Weak coupling regime (r_s small): _S +! +! +!======================================================================= +! + FUNCTION EC_W2_S(RS) +! +! Wigner correlation energy +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! References: (1) P.-F. Loos and P. M. W. Gill, WIREs Comput. Mol. Sci. 6, +! 410-419 (2016) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Aug 2019 +! + IMPLICIT NONE +! + REAL (WP) :: RS,EC_W2_S + REAL (WP) :: ETA_0,ETA_1 + REAL (WP) :: X1 +! + REAL (WP) :: SQRT +! + X1 = SQRT(RS) ! +! + ETA_0 = - 1.106103E0_WP ! ref. (1) table 2 + ETA_1 = 0.795E0_WP ! +! + EC_W2_S = ETA_0 / RS + ETA_1 / (RS * X1) ! ref. (1) eq. (48) +! + END FUNCTION EC_W2_S +! +!======================================================================= +! + FUNCTION EC_IT_T(RS,T) +! +! Temperature-dependent correlation energy for 2D systems +! +! References: A. Isihara and T. Toyoda, Phys. Rev. B 21, +! 3358-3365 (1980) + +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOUR + USE CONSTANTS_P1, ONLY : K_B + USE PI_ETC, ONLY : PI,PI_INV + USE ENE_CHANGE, ONLY : EV,RYD +! + IMPLICIT NONE +! + REAL (WP) :: RS,T + REAL (WP) :: EC_IT_T + REAL (WP) :: EC_0,EC_T + REAL (WP) :: A0,B0,C0,AT,BT,CT + REAL (WP) :: ETA_0,P02,BETA +! + REAL (WP) :: LOG +! + BETA = EV / (K_B * T * RYD) ! in 1/Ryd + P02 = TWO / (RS * RS) ! 2 pi n + ETA_0 = BETA * P02 ! +! + A0 = - 0.3946E0_WP ! + B0 = 0.865E0_WP ! ref. (1) eq. (8.6) + C0 = - 0.173E0_WP ! +! + AT = - 0.1824E0_WP ! + BT = - 0.02968E0_WP ! ref. (1) eq. (8.6) + CT = PI_INV / 24.0E0_WP ! +! + EC_0 = A0 + B0 * RS + C0 * RS * LOG(RS) ! + EC_T = FOUR * PI * ( AT + BT * LOG(ETA_0) + & ! + CT * LOG(ETA_0) * LOG(ETA_0) & ! ref. (1) eq. (8.6) + ) / ETA_0**2 ! +! + EC_IT_T = EC_0 + EC_T ! ref. (1) eq. (8.5) +! + END FUNCTION EC_IT_T +! +!------ 3) 1D case -------------------------------------------- +! +! +!======================================================================= +! + FUNCTION EC_1D(EC_TYPE,RS,T) +! +! This subroutine computes the 1D correlation energy EC +! at a given value RS +! +! +! Input parameters: +! +! * EC_TYPE : type of correlation energy functional +! EC_TYPE = 'LOOS_W' --> Loos +! EC_TYPE = 'WIGN_S' --> Wigner +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * EC : value at RS +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER*6 EC_TYPE +! + REAL (WP) :: EC_1D,RS,T +! + IF(EC_TYPE == 'LOOS_W') THEN ! + EC_1D = EC_L1_W(RS) ! + ELSE IF(EC_TYPE == 'WIGN_S') THEN ! + EC_1D = EC_W1_S(RS) ! + END IF ! +! + END FUNCTION EC_1D +! +!======================================================================= +! + SUBROUTINE DERIVE_EC_1D(EC_TYPE,IDERIV,RS,T,D_EC_1,D_EC_2) +! +! This subroutine computes the first and second derivative +! of the correlation energy E_c with repect to r_s +! at a given value RS +! +! +! Input parameters: +! +! * EC_TYPE : type of correlation energy functional +! EC_TYPE = 'LOOS_W' --> Loos +! EC_TYPE = 'WIGN_S' --> Wigner +! * IDERIV : type of n_point formula used for derivation (n = IDERIV) +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * D_EC_1 : first derivative at RS +! * D_EC_2 : second derivative at RS +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : ND_MAX + USE DERIVATION + USE INTERPOLATION, ONLY : INTERP_NR,SPLINE,SPLINT +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + INTEGER :: IDERIV,I,LOGF +! + REAL (WP) :: RS,RI,T + REAL (WP) :: D_EC_1,D_EC_2 +! + REAL (WP) :: R(ND_MAX),EC(ND_MAX) + REAL (WP) :: D_EC(ND_MAX),DD_EC(ND_MAX) + REAL (WP) :: R_MIN,R_MAX,STEP +! + REAL (WP) :: FLOAT +! + R_MIN = 0.01E0_WP ! + R_MAX = 50.01E0_WP ! + STEP = (R_MAX - R_MIN) / FLOAT(ND_MAX - 1) ! +! + LOGF=6 ! +! +! Storing the correlation energy EC as a function of RS +! + DO I = 1,ND_MAX ! +! + R(I) = R_MIN + FLOAT(I - 1) * STEP ! + RI = R(I) ! +! + IF(EC_TYPE == 'LOOS_W') THEN ! + EC(I) = EC_L1_W(RS) ! + ELSE IF(EC_TYPE == 'WIGN_S') THEN ! + EC(I) = EC_W1_S(RS) ! + END IF ! +! + END DO ! +! +! Computing the first and second derivatives +! with a IDERIV-point formula +! + CALL DERIV_1(EC,ND_MAX,IDERIV,STEP,D_EC) ! + CALL DERIV_1(D_EC,ND_MAX,IDERIV,STEP,DD_EC) ! +! +! Interpolation of derivatives at RS +! + CALL INTERP_NR(LOGF,R,D_EC,ND_MAX,RS,D_EC_1) ! + CALL INTERP_NR(LOGF,R,DD_EC,ND_MAX,RS,D_EC_2) ! +! + END SUBROUTINE DERIVE_EC_1D +! +!======================================================================= +! +! Exchange/Correlation energy functionals (in Ryd) +! +! Different regimes: * weak coupling : r_s << 1 +! * metallic state : 2 <= r_s <= 6 +! * Wigner crystallization : r_s >= 100 +! +! +! +! (1) Weak coupling regime: _W +! +!======================================================================= +! + FUNCTION EC_L1_W(RS) +! +! Weak coupling correlation energy for 1D systems +! +! References: (1) P.-F. Loos, J. Chem. Phys. 138, 064108 (2013) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,THIRD + USE PI_ETC, ONLY : PI2 +! + IMPLICIT NONE +! + REAL (WP) :: RS + REAL (WP) :: LAMBDA_0,LAMBDA_1,E_0,E_1 + REAL (WP) :: EC_L1_W +! + REAL (WP) :: LOG +! + LAMBDA_0 = ZERO ! + LAMBDA_1 = ZERO ! ref. (1) table I + E_0 = - PI2 / 360.0E0_WP ! + E_1 = 0.00845E0_WP ! +! + EC_L1_W = LAMBDA_0 * LOG(RS) + & ! + E_0 + LAMBDA_1 * RS * LOG(RS) + E_1 * RS ! ref. (1) eq. (1) +! + END FUNCTION EC_L1_W +! +! (2) Weak coupling regime (r_s small): _S +! +! +!======================================================================= +! + FUNCTION EC_W1_S(RS) +! +! Wigner correlation energy +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! References: (1) P.-F. Loos and P. M. W. Gill, WIREs Comput. Mol. Sci. 6, +! 410-419 (2016) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,HALF + USE EULER_CONST, ONLY : EUMAS +! + IMPLICIT NONE +! + REAL (WP) :: RS,EC_W1_S + REAL (WP) :: ETA_0,ETA_1 + REAL (WP) :: X1 +! + REAL (WP) :: SQRT,LOG +! + X1 = SQRT(RS) ! +! + ETA_0 = HALF * (EUMAS - LOG(TWO)) ! ref. (1) table 2 + ETA_1 = 0.359933E0_WP ! +! + EC_W1_S = ETA_0 / RS + ETA_1 / (RS * X1) ! ref. (1) eq. (48) +! + END FUNCTION EC_W1_S +! +END MODULE CORRELATION_ENERGIES diff --git a/New_libraries/DFM_library/ENERGIES_LIBRARY/delta_t.f90 b/New_libraries/DFM_library/ENERGIES_LIBRARY/delta_t.f90 new file mode 100644 index 0000000..4cde7b9 --- /dev/null +++ b/New_libraries/DFM_library/ENERGIES_LIBRARY/delta_t.f90 @@ -0,0 +1,122 @@ +! +!======================================================================= +! +MODULE DELTA_KIN +! + USE ACCURACY_REAL +! +CONTAINS +! +!------ 1) 3D case -------------------------------------------- +! +!======================================================================= +! + SUBROUTINE DELTA_KIN_3D(EC_TYPE,IMODE,IDERIV,RS,T,I_DE,DT,DT2) +! +! This subroutine computes delta_t and delta_t2 values for 3D systems +! +! +! References: (1) J. Toulouse, Phys. Rev. B 72, 035117 (2005) +! +! They are defined, in terms of the kinetic energy, as +! +! < t > - < t > +! 0 +! delta_t = ---------------- +! +! < t > +! 0 +! +! +! 2 2 +! < t > - < t > +! 0 +! delta_t2 = ---------------- +! 2 +! < t > +! 0 +! +! +! Input parameters: +! +! * EC_TYPE : type of correlation energy functional +! * IMODE : choice of parameters +! IMODE = 1 : no spin polarization +! IMODE = 2 : fully spin-polarized +! * IDERIV : type of n_point formula used for derivation (n = IDERIV) +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! * I_DE : type of parametrization of delta_t2 +! I_DE = 1 : RPA +! I_DE = 2 : GW +! I_DE = 3 : Gori-Giorgi and Ziesche +! +! +! Output parameters: +! +! * DT : delta_t +! * DT2 : delta_t2 +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Oct 2020 +! +! +! + USE REAL_NUMBERS, ONLY : TWO,FIVE,THIRD + USE FERMI_AU, ONLY : EF_AU +! + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + INTEGER, INTENT(IN) :: IMODE,IDERIV,I_DE +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP), INTENT(OUT) :: DT,DT2 +! + REAL (WP) :: EC,D_EC_1,D_EC_2 + REAL (WP) :: EF + REAL (WP) :: D1(3:6),D2(3:6),D3(3:6) + REAL (WP) :: U,U3,U4,U5,U6 +! + REAL (WP) :: SQRT +! + DATA D1 / 0.093623E0_WP, 0.194288E0_WP, 0.051445E0_WP, 0.005449E0_WP / ! RPA + DATA D2 / 0.126362E0_WP, 0.001428E0_WP, 0.014278E0_WP, -0.004522E0_WP / ! GW + DATA D3 / 0.271191E0_WP, -0.009998E0_WP, -0.036383E0_WP, 0.006706E0_WP / ! GZ +! + U = SQRT(RS) ! + U3 = U * U * U ! + U4 = U3 * U ! + U5 = U4 * U ! + U6 = U5 * U ! +! +! Correlation energy and its derivatives +! + EC = EC_3D(EC_TYPE,1,RS,T) ! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! +! E_F in Rydberg +! + EF = TWO * EF_AU ! EF_AU in Hartree +! + DT = - FIVE * THIRD * (EC + RS * D_EC_1) / EF ! +! +! Parametrization of delta_t2 +! + IF(I_DE == 1) THEN ! + DT2 = D1(3) * U3 + D1(4) * U4 + D1(5) * U5 + D1(6) * U6 ! + ELSE IF(I_DE == 2) THEN ! + DT2 = D2(3) * U3 + D2(4) * U4 + D2(5) * U5 + D2(6) * U6 ! ref. (1) eq. (B1) + ELSE IF(I_DE == 3) THEN ! + DT2 = D3(3) * U3 + D3(4) * U4 + D3(5) * U5 + D3(6) * U6 ! + END IF ! +! + END SUBROUTINE DELTA_KIN_3D +! +END MODULE DELTA_KIN diff --git a/New_libraries/DFM_library/ENERGIES_LIBRARY/exchange_energies.f90 b/New_libraries/DFM_library/ENERGIES_LIBRARY/exchange_energies.f90 new file mode 100644 index 0000000..dd9a579 --- /dev/null +++ b/New_libraries/DFM_library/ENERGIES_LIBRARY/exchange_energies.f90 @@ -0,0 +1,113 @@ +! +!======================================================================= +! +MODULE EXCHANGE_ENERGIES +! + USE ACCURACY_REAL +! +CONTAINS +! +!------ 1) 3D case -------------------------------------------- +! +!======================================================================= +! + FUNCTION EX_3D(EX_TYPE,IMODE,RS,T,XI) +! +! This subroutine computes the 3D exchange energy EX +! at a given value RS +! +! +! Input parameters: +! +! * EX_TYPE : type of kinetic energy functional +! EX_TYPE = 'HEG' --> homogeneous electron gas +! * IMODE : choice of parameters +! IMODE = 1 : no spin polarization +! IMODE = 2 : fully spin-polarized +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! * XI : spin polarization : (n+ - n-) / n +! +! Output parameters: +! +! * EX_3D : value at RS +! +! +! +! Author : D. Sébilleau +! +! Last modified : 15 Sep 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: EX_TYPE +! + REAL (WP), INTENT(IN) :: RS,T,XI + REAL (WP) :: EX_3D +! + INTEGER :: IMODE +! + IF(EX_TYPE == 'HEG') THEN ! + EX_3D = EX_HEG_3D(RS,XI) ! + END IF ! +! + END FUNCTION EX_3D +! +!======================================================================= +! + FUNCTION EX_HEG_3D(RS,XI) +! +! This function computes the exchange energy in the 3D homegeneous +! electron gas model +! +! Reference: (1) U. von Barth and L. Hedin, +! J. Phys. C : Solid State Phys. 5, 1629-1642 (1972) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * XI : spin polarization : (n+ - n-) / n +! +! Output parameters: +! +! * EX_HEG : value at RS (in Ry) +! +! +! Note: in reference (1), equations are expressend in terms of +! x = n+ / n. The relation with XI is +! +! XI = 2x - 1 +! +! +! Author : D. Sébilleau +! +! Last modified : 15 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,HALF,THIRD + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS,XI + REAL (WP) :: EX_HEG_3D + REAL (WP) :: X,A,E,FX,G + REAL (WP) :: ALPHA,COEF,EX_P,MUX_P +! + X = HALF * (XI - ONE) ! + A = HALF**THIRD ! + E = FOUR * THIRD ! + FX = ( X**E + (ONE - X)**E - A ) / (ONE - A) ! ref. 1 eq. (5.3) + G = E * A / (ONE - A) ! +! + ALPHA = ALFA('3D') ! + COEF = THREE / (TWO * PI * ALPHA) ! + EX_P = - COEF / RS ! ref. 1 eq. (5.7) + MUX_P = E * EX_P ! ref. 1 eq. (5.8) +! + EX_HEG_3D = EX_P + MUX_P * FX / G ! ref. 1 eq. (5.4) +! + END FUNCTION EX_HEG_3D +! +END MODULE EXCHANGE_ENERGIES diff --git a/New_libraries/DFM_library/ENERGIES_LIBRARY/kinetic_energies.f90 b/New_libraries/DFM_library/ENERGIES_LIBRARY/kinetic_energies.f90 new file mode 100644 index 0000000..f7408ab --- /dev/null +++ b/New_libraries/DFM_library/ENERGIES_LIBRARY/kinetic_energies.f90 @@ -0,0 +1,110 @@ +! +!======================================================================= +! +MODULE KINETIC_ENERGIES +! + USE ACCURACY_REAL +! +CONTAINS +! +!------ 1) 3D case -------------------------------------------- +! +!======================================================================= +! + FUNCTION EK_3D(EK_TYPE,RS,T,XI) +! +! This subroutine computes the 3D kinetic energy EK +! at a given value RS +! +! +! Input parameters: +! +! * EK_TYPE : type of exchange energy functional +! EK_TYPE = 'HEG' --> homogeneous electron gas +! * IMODE : choice of parameters +! IMODE = 1 : no spin polarization +! IMODE = 2 : fully spin-polarized +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! * XI : spin polarization : (n+ - n-) / n +! +! Output parameters: +! +! * EK_3D : value at RS +! +! +! +! Author : D. Sébilleau +! +! Last modified : 15 Sep 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: EK_TYPE +! + REAL (WP), INTENT(IN) :: RS,T,XI + REAL (WP) :: EK_3D +! + INTEGER :: IMODE +! + IF(EK_TYPE == 'HEG') THEN ! + EK_3D = EK_HEG_3D(RS,XI) ! + END IF ! +! + END FUNCTION EK_3D +! +!======================================================================= +! + FUNCTION EK_HEG_3D(RS,XI) +! +! This function computes the kinetic energy in the 3D homegeneous +! electron gas model +! +! Reference: (1) A. Sarkar, S. Haldar, D. Roy and D. Sen, +! Acta Phys. Polonica A 106, 497-514 (2004) +! (2) H. T. Tran and J. P. Perdew, Am. J. Phys. 71, +! 1048-1061 (2003) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * XI : spin polarization : (n+ - n-) / n +! +! Output parameters: +! +! * EX_HEG : value at RS (in Ry) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 15 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FIVE,THIRD + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS,XI + REAL (WP) :: EK_HEG_3D + REAL (WP) :: ALPHA,COEF + REAL (WP) :: A,E,FK + REAL (WP) :: EK_P,EK_F +! + A = TWO**(TWO * THIRD) ! + E = FIVE * THIRD ! + FK = ( (ONE + XI)**E + (ONE - XI)**E - TWO ) / & ! + (TWO * (A - ONE) ) ! +! + ALPHA = ALFA('3D') ! + COEF = THREE / (FIVE * ALPHA * ALPHA) ! ref. 2 eq. (4) + EK_P = COEF / (RS * RS) ! + EK_F = A * EK_P ! +! + EK_HEG_3D = EK_P + (EK_F - EK_P) * FK ! ref. 1 eq. (11) +! + END FUNCTION EK_HEG_3D +! +END MODULE KINETIC_ENERGIES + diff --git a/New_libraries/DFM_library/ENERGIES_LIBRARY/xc_energies.f90 b/New_libraries/DFM_library/ENERGIES_LIBRARY/xc_energies.f90 new file mode 100644 index 0000000..0a79b8a --- /dev/null +++ b/New_libraries/DFM_library/ENERGIES_LIBRARY/xc_energies.f90 @@ -0,0 +1,978 @@ +! +!======================================================================= +! +MODULE XC_ENERGIES +! + USE ACCURACY_REAL +! +CONTAINS +! +!------ 1) 3D case -------------------------------------------- +! +!======================================================================= +! + FUNCTION EXC_3D(EXC_TYPE,RS,T) +! +! This subroutine computes the exchange and correlation energy EXC +! at a given value RS +! +! +! Input parameters: +! +! * EXC_TYPE : type of correlation energy functional +! EXC_TYPE = 'GT' --> Goedeker-Tetter-Hutter +! EXC_TYPE = 'ST' --> +! EXC_TYPE = 'BD' --> Brown-DuBois-Holzmann-Ceperley +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * EXC : value at RS +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: EXC_TYPE +! + REAL (WP) :: EXC_3D,RS,T +! + INTEGER :: IMODE +! + IF(EXC_TYPE == 'GT') THEN ! + EXC_3D=EXC_GT_W(RS) ! + ELSE IF(EXC_TYPE == 'ST') THEN ! + EXC_3D=EXC_ST_S(RS) ! + ELSE IF(EXC_TYPE == 'BD') THEN ! + EXC_3D=EXC_BD_T(RS,T) ! + END IF +! + END FUNCTION EXC_3D +! +!======================================================================= +! +! Exchange and Correlation energy functionals (in Ryd) +! +! Different regimes: * weak coupling : r_s << 1 +! * metallic state : 2 <= r_s <= 6 +! * Wigner crystallization : r_s >= 100 +! +! +! (1) Weak coupling regime: _W +! +!======================================================================= +! + FUNCTION EXC_GT_W(RS) +! +! Exchange and correlation energy for 3D systems +! as derived by Goedeker-Tetter-Hutter +! +! +! Reference: S. Goedeker, M. Teter and J. Hutter, Phys. Rev. B 54, +! 1704-1710 (1996) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Sep 2020 +! +! + IMPLICIT NONE +! + REAL (WP) :: RS,RS2,RS3,RS4 + REAL (WP) :: EXC_GT_W + REAL (WP) :: A(0:3),B(1:4) + REAL (WP) :: NUM,DEN +! + DATA A / 0.4581652932831429E0_WP , & + 2.217058676663745E0_WP , & + 0.7405551735357053E0_WP , & + 0.01968227878617998E0_WP / +! + DATA B / 1.0000000000000000E0_WP , & + 4.504130959426697E0_WP , & + 1.110667363742916E0_WP , & + 0.02359291751427506E0_WP / +! + RS2 = RS * RS ! + RS3 = RS2 * RS ! + RS4 = RS3 * RS ! +! + NUM = A(0) + A(1)*RS + A(2)*RS2 + A(3)*RS3 ! + DEN = B(1)*RS + B(2)*RS2 + B(3)*RS3 + B(4)*RS4 ! +! + EXC_GT_W = NUM / DEN ! Ref. 1, Appendix +! + END FUNCTION EXC_GT_W +! +!======================================================================= +! +! (2) Strong coupling regime (r_s small): _S +! +!======================================================================= +! + FUNCTION EXC_ST_S(RS) +! +! Exchange and correlation energy for 3D systems in the standard model +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS + REAL (WP) :: EXC_ST_S + REAL (WP) :: RS2,XS + REAL (WP) :: A1,A2,A3,A4 +! + A1 = - 1.79186E0_WP ! + A2 = 2.65E0_WP ! + A3 = - 0.73E0_WP ! + A4 = - 0.8E0_WP ! +! + EXC_ST_S=A1/RS + A2/(RS*XS) + A3/RS2 + A4/(RS2*XS) ! +! + END FUNCTION EXC_ST_S +! +!======================================================================= +! +! (4) Temperature dependence: _T +! +!======================================================================= +! + FUNCTION EXC_BD_T(RS,T) +! +! Temperature-dependent exchange and correlation energy for 3D systems +! as derived by Brown-DuBois-Holzmann-Ceperley +! +! Validity: RS < 40 and T/T_F > 0.0625 +! +! References: (1) E. W. Brown, J. L. DuBois, M. Holzmann and D. M. Ceperley, +! Phys. Rev. B 88, 081102 (2013) +! (2) E. W. Brown, J. L. DuBois, M. Holzmann and D. M. Ceperley, +! Phys. Rev. B 88, 199901 (2013) --> erratum +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,SIX +! + IMPLICIT NONE +! + REAL (WP) :: RS,T,T2 + REAL (WP) :: EXC_BD_T + REAL (WP) :: E_XC_0 + REAL (WP) :: A_1(3),B_1(3),C_1(3),D_1(3) + REAL (WP) :: A_2(3),B_2(3),C_2(3),D_2(3) + REAL (WP) :: A1,A2,A3,P1,P2,U1,U2 +! + DATA A_1 / 6.94759E0_WP, 7.70107E0_WP, 12.68820E0_WP / ! + DATA B_1 / -0.34608E0_WP, -0.95154E0_WP, -1.59703E0_WP / ! case r_s < 10 + DATA C_1 / -1.97251E0_WP, -1.80401E0_WP, -4.74435E0_WP / ! + DATA D_1 / 0.53700E0_WP, 0.49086E0_WP, 1.23569E0_WP / ! +! + DATA A_2 / 1.54712E0_WP, 2.65068E0_WP, 3.07192E0_WP / ! + DATA B_2 / -1.97814E0_WP, -2.45160E0_WP, -4.65269E0_WP / ! case r_s > 10 + DATA C_2 / 1.42976E0_WP, 1.36907E0_WP, 1.36324E0_WP / ! + DATA D_2 / -0.32967E0_WP, -0.31701E0_WP, -0.32247E0_WP / +! + T2=T*T ! +! + IF(RS <= 10.0E0_WP) THEN ! +! + A1=DEXP(A_1(1)*DLOG(RS)+B_1(1)+C_1(1)*RS+D_1(1)*RS*DLOG(RS))! + A2=DEXP(A_1(2)*DLOG(RS)+B_1(2)+C_1(2)*RS+D_1(2)*RS*DLOG(RS))! ref. (2) eq. (6) + A3=DEXP(A_1(3)*DLOG(RS)+B_1(3)+C_1(3)*RS+D_1(3)*RS*DLOG(RS))! +! + ELSE ! +! + A1=DEXP(A_2(1)*DLOG(RS)+B_2(1)+C_2(1)*RS+D_2(1)*RS*DLOG(RS))! + A2=DEXP(A_2(2)*DLOG(RS)+B_2(2)+C_2(2)*RS+D_2(2)*RS*DLOG(RS))! ref. (2) eq. (6) + A3=DEXP(A_2(3)*DLOG(RS)+B_2(3)+C_2(3)*RS+D_2(3)*RS*DLOG(RS))! +! + END IF ! +! + U1=1.5E0_WP/(RS*RS*RS) ! ref. (2) eq. (4) + U2=DSQRT(SIX/RS)/RS ! ref. (2) eq. (5) +! + P1=(A2*U1+A3*U2)*T2 + A2*U2*T2*DSQRT(T) ! ref. (2) eq. (2) + P2=ONE + A1*T2 + A3*T2*DSQRT(T) +A2*T2*T ! ref. (2) eq. (3) +! + EXC_BD_T=(E_XC_0 - P1)/P2 ! ref. (2) eq. (1) +! + END FUNCTION EXC_BD_T +! +!------> FXC-Based functionals +! +!======================================================================= +! + FUNCTION FXC_3D(FXC_TYPE,RS,T) +! +! This subroutine computes the XC free energy FXC +! at a given value RS +! +! +! Input parameters: +! +! * FXC_TYPE : type of XC free energy functional +! FXC_TYPE = 'EB' --> Ebeling et al +! FXC_TYPE = 'IC' --> Ichimaru et al +! FXC_TYPE = 'KS' --> Karasiev et al +! FXC_TYPE = 'VS' --> Vashishta and Singwi +! FXC_TYPE = 'PD' --> Perrot and Dharma-Wardana +! FXC_TYPE = 'EK' --> Ebeling-Kraeft-Kremp-Röpke +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * FXC_3D : value at RS +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER*2 FXC_TYPE +! + REAL (WP) :: FXC_3D,RS,T +! + IF(FXC_TYPE == 'EB') THEN ! + FXC_3D=FXC_EB_T(RS,T) ! + ELSE IF(FXC_TYPE == 'IC') THEN ! + FXC_3D=FXC_IC_T(RS,T) ! + ELSE IF(FXC_TYPE == 'VS') THEN ! + FXC_3D=FXC_VS_T(RS,T) ! + ELSE IF(FXC_TYPE == 'PD') THEN ! + FXC_3D=FXC_PD_T(RS,T) ! + ELSE IF(FXC_TYPE == 'KS') THEN ! + FXC_3D=FXC_KS_T(RS,T) ! + ELSE IF(FXC_TYPE == 'EK') THEN ! + FXC_3D=FXC_EK_T(RS,T) ! + END IF ! +! + END FUNCTION FXC_3D +! +!======================================================================= +! + SUBROUTINE DERIVE_FXC_3D(FXC_TYPE,IDERIV,RS,TE,D_FXC) +! +! This subroutine computes the first derivative of the +! exchange and correlation free energy F_xc with repect to Theta +! +! Input parameters: +! +! * FXC_TYPE : type of XC free energy functional +! FXC_TYPE = 'EB' --> Ebeling et al +! FXC_TYPE = 'IC' --> Ichimaru et al +! FXC_TYPE = 'KS' --> Karasiev et al +! FXC_TYPE = 'VS' --> Vashishta and Singwi +! FXC_TYPE = 'PD' --> Perrot and Dharma-Wardana +! FXC_TYPE = 'EK' --> Ebeling-Kraeft-Kremp-Röpke +! * IDERIV : type of n_point formula used for derivation (n = IDERIV) +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * TE : temperature (SI) +! +! Output parameters: +! +! * D_FXC : first derivative at TH +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : ND_MAX + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI + USE DERIVATION + USE INTERPOLATION, ONLY : INTERP_NR,SPLINE,SPLINT +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: FXC_TYPE +! + INTEGER :: IDERIV,I,LOGF +! + REAL (WP) :: RS,TI,TE,TH + REAL (WP) :: D_FXC +! + REAL (WP) :: T(ND_MAX),FXC(ND_MAX) + REAL (WP) :: D_FXC_1(ND_MAX) + REAL (WP) :: R_MIN,R_MAX,T_MIN,T_MAX,STEP +! + TH=K_B*TE/EF_SI ! +! + R_MIN=0.01E0_WP ! min value of TH + R_MAX=50.01E0_WP ! max value of TH +! + T_MIN=EF_SI*R_MIN/K_B ! min value of T + T_MAX=EF_SI*R_MAX/K_B ! max value of T + STEP=(T_MAX-T_MIN)/DFLOAT(ND_MAX-1) ! step in T +! + LOGF=6 ! +! +! Storing the exchange and correlation free energy FXC as a function of RS +! + DO I=1,ND_MAX ! +! + T(I)=T_MIN+DFLOAT(I-1)*STEP ! + TI=T(I) ! +! + IF(FXC_TYPE.EQ.'EB') THEN ! + FXC(I)=FXC_EB_T(RS,TI) ! + ELSEIF(FXC_TYPE.EQ.'IC') THEN ! + FXC(I)=FXC_IC_T(RS,TI) ! + ELSEIF(FXC_TYPE.EQ.'VS') THEN ! + FXC(I)=FXC_VS_T(RS,TI) ! + ELSEIF(FXC_TYPE.EQ.'PD') THEN ! + FXC(I)=FXC_PD_T(RS,TI) ! + ELSEIF(FXC_TYPE.EQ.'KS') THEN ! + FXC(I)=FXC_KS_T(RS,TI) ! + ELSEIF(FXC_TYPE.EQ.'EK') THEN ! + FXC(I)=FXC_EK_T(RS,TI) ! + ENDIF ! +! + ENDDO ! +! +! Computing the first derivatives with respect to T +! with a IDERIV-point formula +! + CALL DERIV_1(FXC,ND_MAX,IDERIV,STEP,D_FXC_1) ! +! +! Interpolation of derivative at TH +! + CALL INTERP_NR(LOGF,T,D_FXC_1,ND_MAX,TE,D_FXC) ! +! +! Transforming d FXC / dt into d FXC / dTH +! + D_FXC=D_FXC*K_B/EF_SI ! +! + END SUBROUTINE DERIVE_FXC_3D +! +!======================================================================= +! + SUBROUTINE FXC_TO_EXC_3D(FXC_TYPE,RS,T,EXC) +! +! This subroutine transforms a XC free energy into an XC energy +! +! References: (1) S. Groth, T. Dornheim and M. Bonitz, +! Contrib. Plasma Phys. 57, 137-146 (2017) +! +! Input parameters: +! +! * FXC_TYPE : type of XC free energy functional +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * EXC : exchange and correlation energy (in Ryd) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: FXC_TYPE +! + REAL (WP) :: RS,T + REAL (WP) :: TH,FXC_3D_T,FXC,D_FXC,EXC +! + TH=K_B*T/EF_SI ! +! +! Computing the XC free energy functional +! + FXC=FXC_3D(FXC_TYPE,RS,T) ! +! +! Calling the derivative of FXC with respect to theta +! + CALL DERIVE_FXC_3D(FXC_TYPE,5,RS,T,D_FXC) ! +! + EXC=FXC - TH*D_FXC ! ref. (1) eq. (20) +! + END SUBROUTINE FXC_TO_EXC_3D +! +!======================================================================= +! + FUNCTION FXC_EB_T(RS,T) +! +! Temperature-dependent exchange and correlation free energy +! for 3D systems as derived by Ebeling et al. +! +! References: (1) S. Groth, T. Dornheim and M. Bonitz, +! Contrib. Plasma Phys. 57, 137-146 (2017) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * FXC_EB_T : exchange and correlation free energy (in Ryd) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,EIGHT, & + HALF,THIRD,FOURTH + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI_INV,SQR_PI + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP) :: RS,T + REAL (WP) :: FXC_EB_T + REAL (WP) :: TH,ALPHA + REAL (WP) :: TH1,TH3,XS + REAL (WP) :: EXC + REAL (WP) :: A,B,C,D + REAL (WP) :: NUM,DEN +! + ALPHA=ALFA('3D') ! +! + TH=K_B*T/EF_SI ! + TH1=ONE/TH ! 1 / TH + TH3=TH1*TH1*TH1 ! 1 / TH^3 + XS=DSQRT(RS) ! +! +! Ground-state parametrization of the XC energy +! + EXC=0.9163E0_WP/RS + 0.1244E0_WP*DLOG( &! + ONE + (2.117E0_WP/XS)/&! ref. (1) eq. (4) + (ONE + 0.3008E0_WP*XS) &! + ) ! +! + A=TWO*THIRD/SQR_PI * DSQRT(EIGHT*THIRD) / (ALPHA*ALPHA) ! ref. (1) eq. (6) + B=TWO*THIRD*PI_INV/ALPHA ! ref. (1) eq. (6) + C=64.0E0_WP*THIRD*PI_INV ! ref. (1) eq. (6) + D=FOURTH*(ONE+DLOG(TWO))*DSQRT(THREE)*ALPHA*ALPHA ! ref. (1) eq. (6) +! + NUM=A*DSQRT(TH1)/XS + B*TH1/RS + C*TH3*EXC ! ref. (1) eq. (5) + DEN=ONE + D*TH1*XS + C*TH3 ! ref. (1) eq. (5) +! + FXC_EB_T=-HALF*NUM/DEN ! ref. (1) eq. (5) +! + END FUNCTION FXC_EB_T +! +!======================================================================= +! + FUNCTION FXC_IC_T(RS,T) +! +! Temperature-dependent exchange and correlation free energy +! for 3D systems as derived by Ichimaru et al. +! +! References: (1) S. Groth, T. Dornheim and M. Bonitz, +! Contrib. Plasma Phys. 57, 137-146 (2017) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * FXC_IC_T : exchange and correlation free energy (in Ryd) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF,THIRD + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP) :: RS,T + REAL (WP) :: FXC_IC_T + REAL (WP) :: SQ2 + REAL (WP) :: TH1,TH2,TH3,TH4,XH1,XH2 + REAL (WP) :: RS2,XS + REAL (WP) :: A,B,C,D,E,L,L2 + REAL (WP) :: BB,CC,DD,EE + REAL (WP) :: NUM,DEN + REAL (WP) :: X(17) + REAL (WP) :: BCDE,ACE,SQED +! + DATA X / 3.4130800E-1_WP, 1.2070873E+1_WP, 1.148889E0_WP, & ! + 1.0495346E+1_WP, 1.3266230E0_WP, 8.72496E-1_WP, & ! + 2.5248E-2_WP, 6.14925E-1_WP, 1.6996055E+1_WP, & ! + 1.489056E0_WP, 1.010935E+1_WP, 1.22184E0_WP, & ! ref. (1) table 1 + 5.39409E-1_WP, 2.522206E0_WP, 1.78484E-1_WP, & ! + 2.555501E0_WP, 1.46319E-1_WP / ! +! + SQ2=DSQRT(TWO) ! +! + L=ALFA('3D') ! + L2=L*L ! +! + RS2=RS*RS ! + XS=DSQRT(RS) ! +! + TH1=K_B*T/EF_SI ! + TH2=TH1*TH1 ! + TH3=TH2*TH1 ! + TH4=TH3*TH1 ! + XH1=DSQRT(TH1) ! + XH2=ONE/XH1 ! +! + NUM=0.75E0_WP + 3.4363E0_WP*TH2 - 0.09227E0_WP*TH3 + & ! + 1.7035E0_WP*TH4 ! + DEN=ONE + 8.31051E0_WP*TH2 + 5.1105E0_WP*TH4 ! ref. (1) eq. (11) + A=0.610887E0_WP*TANH(ONE/TH1)*NUM/DEN ! +! + NUM=X(1) + X(2)*TH2 + X(3)*TH4 ! + DEN=ONE + X(4)*TH2 + X(5)*TH4 ! ref. (1) eq. (12) + B=NUM/DEN ! +! + C=X(6) + X(7)*DEXP(-ONE/TH1) ! ref. (1) eq. (12) +! + NUM=X(8) + X(9)*TH2 + X(10)*TH4 ! + DEN=ONE + X(11)*TH2 + X(12)*TH4 ! ref. (1) eq. (13) + D=NUM/DEN ! +! + NUM=X(13) + X(14)*TH2 + X(15)*TH4 ! + DEN=ONE + X(16)*TH2 + X(17)*TH4 ! ref. (1) eq. (13) + E=NUM/DEN ! +! + BB=XH1*TANH(XH2)*B ! + DD=XH1*TANH(XH2)*D ! ref. (1) eq. (17) + EE=TH1*TANH(ONE/TH1)*E ! + CC=EE*C ! +! + ACE = A - CC/EE ! + BCDE=BB - CC*DD/EE ! + SQED=DSQRT(FOUR*EE-DD*DD) ! +! + FXC_IC_T=-CC/(RS*EE) &! + -HALF*TH1/(EE*RS2*L2) * (ACE - DD*BCDE/EE) &! + *DLOG(DABS(TWO*EE*L2*RS/TH1 + SQ2*DD*L*XS*XH2+ONE)) &! + -SQ2*BCDE*XH1/(EE*XS*L) &! + +TH1*(DD*ACE+(TWO-DD*DD/EE)*BCDE)/(RS2*L2*EE*SQED) &! + *( DATAN((TWO**1.5E0_WP * EE*L*XS*XH2 + DD)/SQED) - &! + DATAN(DD/SQED) &! + ) ! +! + END FUNCTION FXC_IC_T +! +!======================================================================= +! + FUNCTION FXC_VS_T(RS,T) +! +! Temperature-dependent exchange and correlation free energy +! for 3D systems as derived by Vashishta-Singwi. +! +! References: (1) S. Groth, T. Dornheim and M. Bonitz, +! Contrib. Plasma Phys. 57, 137-146 (2017) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * FXC_VS_T : exchange and correlation free energy (in Ryd) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF,THIRD + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI + USE SQUARE_ROOTS, ONLY : SQR2 + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP) :: RS,T + REAL (WP) :: FXC_VS_T + REAL (WP) :: Q2 + REAL (WP) :: TH1,TH2,TH3,TH4,XH1,XH2 + REAL (WP) :: RS2,XS + REAL (WP) :: A,B,C,D,E,L,L2 + REAL (WP) :: BB,CC,DD,EE + REAL (WP) :: NUM,DEN + REAL (WP) :: X(17) + REAL (WP) :: BCDE,ACE,SQED +! + DATA X / 1.8871493E-1_WP, 1.0684788E+1_WP, 1.1088191E+2_WP, &! + 1.8015380E+1_WP, 1.2803540E+2_WP, 8.3331352E-1_WP, &! + -1.1179213E-1_WP, 6.1492503E-1_WP, 1.6428929E+1_WP, &! ref. (1) table 2 + 2.5963096E+1_WP, 1.0905162E+1_WP, 2.9942171E+1_WP, &! + 5.3940898E-1_WP, 5.8869626E+4_WP, 3.1165052E+3_WP, &! + 3.8887108E+4_WP, 2.1774472E+3_WP / ! +! + L=ALFA('3D') ! + L2=L*L ! +! + RS2=RS*RS ! + XS=DSQRT(RS) ! +! + TH1=K_B*T/EF_SI ! + TH2=TH1*TH1 ! + TH3=TH2*TH1 ! + TH4=TH3*TH1 ! + XH1=DSQRT(TH1) ! + XH2=ONE/XH1 ! +! + NUM=0.75E0_WP + 3.4363E0_WP*TH2 - 0.09227E0_WP*TH3 + & ! + 1.7035E0_WP*TH4 ! + DEN=ONE + 8.31051E0_WP*TH2 + 5.1105E0_WP*TH4 ! ref. (1) eq. (11) + A=0.610887E0_WP*TANH(ONE/TH1)*NUM/DEN ! +! + NUM=X(1) + X(2)*TH2 + X(3)*TH4 ! + DEN=ONE + X(4)*TH2 + X(5)*TH4 ! ref. (1) eq. (12) + B=NUM/DEN ! +! + C=X(6) + X(7)*DEXP(-ONE/TH1) ! ref. (1) eq. (12) +! + NUM=X(8) + X(9)*TH2 + X(10)*TH4 ! + DEN=ONE + X(11)*TH2 + X(12)*TH4 ! ref. (1) eq. (13) + D=NUM/DEN ! +! + NUM=X(13) + X(14)*TH2 + X(15)*TH4 ! + DEN=ONE + X(16)*TH2 + X(17)*TH4 ! ref. (1) eq. (13) + E=NUM/DEN ! +! + BB=XH1*TANH(XH2)*B ! + DD=XH1*TANH(XH2)*D ! ref. (1) eq. (17) + EE=TH1*TANH(ONE/TH1)*E ! + CC=EE*C ! +! + ACE = A - CC/EE ! + BCDE=BB - CC*DD/EE ! + SQED=DSQRT(FOUR*EE-DD*DD) ! +! + FXC_VS_T=-CC/(RS*EE) &! + -HALF*TH1/(EE*RS2*L2) * (ACE - DD*BCDE/EE) &! + *DLOG(DABS(TWO*EE*L2*RS/TH1 + SQR2*DD*L*XS*XH2+ONE))&! + -SQR2*BCDE*XH1/(EE*XS*L) &! + +TH1*(DD*ACE+(TWO-DD*DD/EE)*BCDE)/(RS2*L2*EE*SQED) &! + *( DATAN((TWO**1.5E0_WP * EE*L*XS*XH2 + DD)/SQED) - &! + DATAN(DD/SQED) &! + ) ! +! + END FUNCTION FXC_VS_T +! +!======================================================================= +! + FUNCTION FXC_PD_T(RS,T) +! +! Temperature-dependent exchange and correlation free energy +! for 3D systems as derived by Perrot and Dharma-Wardana. +! +! References: (1) S. Groth, T. Dornheim and M. Bonitz, +! Contrib. Plasma Phys. 57, 137-146 (2017) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * FXC_PD_T : exchange and correlation free energy (in Ryd) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,FIVE,HALF,THIRD + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP) :: RS,RS2,T,XS + REAL (WP) :: FXC_PD_T + REAL (WP) :: A1(3),B1(3),C1(3),A2(3),B2(3),C2(3) + REAL (WP) :: V(3),R(3) + REAL (WP) :: Y(3),Z(3),A(3),B(3) + REAL (WP) :: TH1,TH2,TH3,XH1 + REAL (WP) :: Q1,Q2,Q3,XQ + REAL (WP) :: N0,U1,U2,L,L2 + REAL (WP) :: NUM,DEN + REAL (WP) :: P1,P2,EXC +! + INTEGER I +! + DATA A1 / 5.6304E0_WP, 5.2901E0_WP, 3.6854E0_WP / ! + DATA B1 / -2.2308E0_WP, -2.0512E0_WP, -1.5385E0_WP / ! + DATA C1 / 1.7624E0_WP, 1.6185E0_WP, 1.2629E0_WP / ! + DATA A2 / 2.6083E0_WP, -15.076E0_WP, 2.4071E0_WP / ! ref. (1) table 3 + DATA B2 / 1.2782E0_WP, 24.929E0_WP, 0.78293E0_WP / ! + DATA C2 / 0.16625E0_WP, 2.0261E0_WP, 0.095869E0_WP / ! + DATA V / 1.5E0_WP, 3.0E0_WP, 3.0E0_WP / ! + DATA R / 4.4467E0_WP, 4.5581E0_WP, 4.3909E0_WP / ! +! + L=ALFA('3D') ! + L2=L*L ! +! + RS2=RS*RS ! + XS=DSQRT(RS) ! +! + TH1=K_B*T/EF_SI ! + TH2=TH1*TH1 ! + TH3=TH2*TH1 ! + XH1=DSQRT(TH1) ! +! + Q1=HALF/(RS2*L2) ! + Q2=Q1*Q1 ! + Q3=Q2*Q1 ! + XQ=DSQRT(Q1) ! +! + N0=THREE/(FOUR*PI*RS*RS2) ! electron density + U1=HALF*PI*N0 ! + U2=TWO*THIRD*DSQRT(PI*N0) ! +! +! Ground-state parametrization of the XC energy +! + EXC=0.9163E0_WP/RS + 0.1244E0_WP*DLOG( &! + ONE + (2.117E0_WP/XS)/&! ref. (1) eq. (4) + (ONE + 0.3008E0_WP*XS) &! + ) ! +! + DO I=1,3 + B(I)=DEXP(FIVE*(RS-R(I))) ! + NUM=A1(I) + B1(I)*RS + C1(I)*RS2 ! + DEN=ONE + RS2/FIVE ! + Y(I)=V(I)*DLOG(RS) + NUM/DEN ! + NUM=A2(I) + B2(I)*RS ! + DEN=ONE + C2(I)*RS2 ! + Z(I)=RS*NUM/DEN ! + NUM=Y(I) + B(I)*Z(I) ! + DEN=ONE + B(I) ! + A(I)=DEXP(NUM/DEN) ! + ENDDO +! + P1=(A(2)*U1 + A(3)*U2)*TH2*Q2 + A(2)*U2*TH2*XH1*Q2*XQ ! + P2=ONE + A(1)*TH2*Q2 + A(3)*TH2*XH1*Q2*XQ + A(2)*TH3*Q3 ! +! + FXC_PD_T=(EXC-P1)/P2 ! ref. (1) eq. (18) +! + END FUNCTION FXC_PD_T +! +!======================================================================= +! + FUNCTION FXC_KS_T(RS,T) +! +! Temperature-dependent exchange and correlation free energy +! for 3D systems as derived by Karasiev et al. +! +! References: (1) S. Groth, T. Dornheim and M. Bonitz, +! Contrib. Plasma Phys. 57, 137-146 (2017) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * FXC_KS_T : exchange and correlation free energy (in Ryd) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP) :: RS,T + REAL (WP) :: FXC_KS_T + REAL (WP) :: TH1,TH2,TH3,TH4,XH1,XH2,XS,L + REAL (WP) :: B(4),C(3),D(5),E(5) + REAL (WP) :: AA,BB,CC,DD,EE + REAL (WP) :: NUM,DEN +! + DATA B / 0.283997E0_WP,48.932154E0_WP, & ! + 0.370919E0_WP,61.095357E0_WP/ ! + DATA C / 0.870089E0_WP, 0.193077E0_WP, 2.414644E0_WP / ! + DATA D / 0.579824E0_WP,94.537454E0_WP,97.839603E0_WP, & ! + 59.939999E0_WP,24.388037E0_WP / ! + DATA E / 0.212036E0_WP,16.731249E0_WP,28.485792E0_WP, & ! + 34.028876E0_WP,17.235515E0_WP / ! +! + XS=DSQRT(RS) ! +! + TH1=K_B*T/EF_SI ! + TH2=TH1*TH1 ! + TH3=TH2*TH1 ! + TH4=TH3*TH1 ! + XH1=DSQRT(TH1) ! + XH2=ONE/XH1 ! +! + L=ALFA('3D') ! +! + NUM=0.75E0_WP + 3.4363E0_WP*TH2 - 0.09227E0_WP*TH3 + & ! + 1.7035E0_WP*TH4 ! + DEN=ONE + 8.31051E0_WP*TH2 + 5.1105E0_WP*TH4 ! ref. (1) eq. (11) + AA=0.610887E0_WP*TANH(ONE/TH1)*NUM/DEN ! +! + NUM=B(1) + B(2)*TH2 + B(3)*TH4 ! + DEN=ONE + B(4)*TH2 + B(3)*TH4*DSQRT(1.5E0_WP)/L ! + BB=TANH(XH2)*NUM/DEN ! +! + NUM=D(1) + D(2)*TH2 + D(3)*TH4 ! + DEN=ONE + D(4)*TH2 + D(5)*TH4 ! + DD=TANH(XH2)*NUM/DEN ! +! + NUM=E(1) + E(2)*TH2 + E(3)*TH4 ! + DEN=ONE + E(4)*TH2 + E(5)*TH4 ! + EE=TANH(ONE/TH1)*NUM/DEN ! +! + CC=(C(1) + C(2)*DEXP(-C(3)/TH1))*EE ! +! + NUM=AA + BB*XS + CC*RS ! + DEN=ONE+ DD*XS + EE*RS ! +! + FXC_KS_T=-NUM/(DEN*RS) ! ref. (1) eq. (19) +! + END FUNCTION FXC_KS_T +! +!======================================================================= +! + FUNCTION FXC_EK_T(RS,T) +! +! Temperature-dependent exchange and correlation free energy +! for 3D systems as derived by Ebeling et al. +! +! References: (1) W. Ebeling, W. D. Kraeft, D. Kremp and G. Röpke, +! Physica 140A, 160-168 (1986) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius of electron (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * FXC_EB_T : exchange and correlation free energy (in Ryd) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,SIX,HALF,THIRD + USE CONSTANTS_P1, ONLY : K_B + USE CONSTANTS_P2, ONLY : HARTREE +! + IMPLICIT NONE +! + REAL*8 RS,T + REAL*8 FXC_EK_T + REAL*8 RS2,RS3,RS4,RS5,RS6,RS7,XS + REAL*8 SQ6 + REAL*8 TAU,TA2,TA3,XTA + REAL*8 D0,D1,DH,AH,AW,B0,B1,C1,C2 + REAL*8 AWR,NUM,DEN +! + SQ6=DSQRT(SIX) ! +! + RS2=RS*RS ! + RS3=RS2*RS ! + RS4=RS3*RS ! powers of RS + RS5=RS4*RS ! + RS6=RS5*RS ! + RS7=RS6*RS ! + XS=DSQRT(RS) ! +! + TAU=HALF*K_B*T/HARTREE ! ref. (1) eq. (21) + TA2=TAU*TAU ! + TA3=TA2*TAU ! + XTA=DSQRT(TAU) ! +! + D0=THIRD ! + D1= 0.3979E0_WP ! + DH= 0.0625E0_WP ! + AH=0.91633E0_WP ! ref. (1) table I + AW=0.87553E0_WP ! + B0=0.06218E0_WP ! + B1= 0.0933E0_WP ! +! + C1=50.0E0_WP + RS3 ! + C2= 2.3E0_WP ! +! + AWR=TWO*B0*RS*DLOG( ONE + ONE/( XS*DEXP(-HALF*B1/B0) + & ! + TWO*B0*RS/AW & ! ref. (1) eq. (26) + ) & ! + ) ! +! + NUM=C1*(AH+AWR) + TWO*SQ6*D0*RS5*XS*TA2*XTA + & ! + 24.0E0_WP*DH*RS4*TA2 ! + DEN=C1*RS + C2*RS4*TA2 + TWO*SQ6*D1*RS5*XS*TA2 + RS7*TA3 ! +! + FXC_EK_T=-NUM/DEN ! ref. (1) eq. (25) +! + END FUNCTION FXC_EK_T +! +END MODULE XC_ENERGIES diff --git a/New_libraries/DFM_library/ERROR_HANDLING_LIBRARY/error_caltech.f90 b/New_libraries/DFM_library/ERROR_HANDLING_LIBRARY/error_caltech.f90 new file mode 100644 index 0000000..c774087 --- /dev/null +++ b/New_libraries/DFM_library/ERROR_HANDLING_LIBRARY/error_caltech.f90 @@ -0,0 +1,412 @@ +! +!======================================================================= +! +MODULE M77ERR +! +! This module stores the IDELTA and IALPHA values +! +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! +! + INTEGER :: IDELTA,IALPHA +! +END MODULE M77ERR +! +!======================================================================= +! +MODULE ERROR_CALTECH +! +! This module provides the Caltech error library routines +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE DERM1(SUBNAM,INDIC,LEVEL,MSG,LABEL,VALUE,FLAG) +! +! Copyright (c) 1996 California Institute of Technology, Pasadena, CA. +! ALL RIGHTS RESERVED. +! Based on Government Sponsored Research NAS7-03001. +!>> 1994-10-20 DERM1 Krogh Changes to use M77CON +!>> 1994-04-20 DERM1 CLL Edited to make DP & SP files similar. +!>> 1985-08-02 DERM1 Lawson Initial code. +!--D replaces "?": ?ERM1, ?ERV1 +! + IMPLICIT NONE +! + INTEGER :: INDIC,LEVEL +! + REAL (WP) :: VALUE +! + CHARACTER (LEN = *) :: SUBNAM,MSG,LABEL + CHARACTER (LEN = 1) :: FLAG +! + CALL ERMSG(SUBNAM,INDIC,LEVEL,MSG,',') ! + CALL DERV1(LABEL,VALUE,FLAG) ! +! + RETURN ! +! + END SUBROUTINE DERM1 +! +!======================================================================= +! + SUBROUTINE ERMSG(SUBNAM,INDIC,LEVEL,MSG,FLAG) +! +! Copyright (c) 1996 California Institute of Technology, Pasadena, CA. +! ALL RIGHTS RESERVED. +! Based on Government Sponsored Research NAS7-03001. +!>> 1995-11-22 ERMSG Krogh Got rid of multiple entries. +!>> 1995-09-15 ERMSG Krogh Remove '0' in format. +!>> 1994-11-11 ERMSG Krogh Declared all vars. +!>> 1992-10-20 ERMSG WV Snyder added ERLSET, ERLGET +!>> 1985-09-25 ERMSG Lawson Initial code. +! +! -------------------------------------------------------------- +! +! Four entries: ERMSG, ERMSET, ERLGET, ERLSET +! ERMSG initiates an error message. This subr also manages the +! saved value IDELOC and the saved COMMON block M77ERR to +! control the level of action. This is intended to be the +! only subr that assigns a value to IALPHA in COMMON. +! ERMSET resets IDELOC & IDELTA. ERLGET returns the last value +! of LEVEL passed to ERMSG. ERLSET sets the last value of LEVEL. +! ERLSET and ERLGET may be used together to determine the level +! of error that occurs during execution of a routine that uses +! ERMSG. +! +! -------------------------------------------------------------- +! SUBROUTINE ARGUMENTS +! -------------------- +! SUBNAM A name that identifies the subprogram in which +! the error occurs. +! +! INDIC An integer printed as part of the mininal error +! message. It together with SUBNAM can be used to +! uniquely identify an error. +! +! LEVEL The user sets LEVEL=2,0,or -2 to specify the +! nominal action to be taken by ERMSG. The +! subroutine ERMSG contains an internal variable +! IDELTA, whose nominal value is zero. The +! subroutine will compute IALPHA = LEVEL + IDELTA +! and proceed as follows: +! If (IALPHA.GE.2) Print message and STOP. +! If (IALPHA=-1,0,1) Print message and return. +! If (IALPHA.LE.-2) Just RETURN. +! +! MSG Message to be printed as part of the diagnostic. +! +! FLAG A single character,which when set to '.' will +! call the subroutine ERFIN and will just RETURN +! when set to any other character. +! +! -------------------------------------------------------------- +! +! C.Lawson & S.Chan, JPL, 1983 Nov +! +! ------------------------------------------------------------------ +! +! + USE M77ERR +! + IMPLICIT NONE +! + INTEGER :: INDIC,LEVEL + INTEGER :: IDELOC +! + CHARACTER (LEN = *) :: SUBNAM,MSG + CHARACTER (LEN = 1) :: FLAG +! + IDELOC = 0 ! +! + IF(LEVEL < -1000) THEN ! +! +! Setting a new IDELOC. +! + IDELTA = LEVEL + 10000 ! + IDELOC = IDELTA ! + RETURN ! + END IF ! +! + IDELTA = IDELOC ! + IALPHA = LEVEL + IDELTA ! + IF (IALPHA >= -1) THEN ! +! +! Setting FILE = 'CON' works for MS/DOS systems. +! +! + WRITE (6,10) SUBNAM,INDIC ! + WRITE (6,*) MSG ! + IF (FLAG == '.') CALL ERFIN ! + END IF ! +! + RETURN ! +! +! Format: +! + 10 FORMAT(1X/' ',72('$')/' SUBPROGRAM ',A,' REPORTS ERROR NO. ',I4) +! + END SUBROUTINE ERMSG +! +!======================================================================= +! + SUBROUTINE ERFIN +! Copyright (c) 1996 California Institute of Technology, Pasadena, CA. +! ALL RIGHTS RESERVED. +! Based on Government Sponsored Research NAS7-03001. +!>> 1994-11-11 CLL Typing all variables. +!>> 1985-09-23 ERFIN Lawson Initial code. +! +! + USE M77ERR +! + IMPLICIT NONE +! + PRINT 10 ! + IF(IALPHA >= 2) STOP ! +! + RETURN ! +! +! Format: +! + 10 FORMAT(1X,72('$')/' ')!! +! + END +! +!======================================================================= +! + SUBROUTINE ERMSET(IDEL) +! + IMPLICIT NONE +! + INTEGER :: IDEL +! +! Call ERMSG to set IDELTA and IDELOC +! + CALL ERMSG(' ', 0,IDEL-10000,' ',' ') +! + RETURN +! + END SUBROUTINE ERMSET +! +!======================================================================= +! + SUBROUTINE ERMOR(MSG,FLAG) +! +! Copyright (c) 1996 California Institute of Technology, Pasadena, CA. +! ALL RIGHTS RESERVED. +! Based on Government Sponsored Research NAS7-03001. +!>> 1985-09-20 ERMOR Lawson Initial code. +! +! -------------------------------------------------------------- +! SUBROUTINE ARGUMENTS +! -------------------- +! MSG Message to be printed as part of the diagnostic. +! +! FLAG A single character,which when set to '.' will +! call the subroutine ERFIN and will just RETURN +! when set to any other character. +! +! -------------------------------------------------------------- +! + USE M77ERR +! + IMPLICIT NONE +! + CHARACTER (LEN = *) :: MSG + CHARACTER (LEN = 1) :: FLAG +! + IF (IALPHA >= -1) THEN ! + WRITE (6,*) MSG ! + IF (FLAG .EQ. '.') CALL ERFIN ! + END IF ! +! + RETURN ! +! + END SUBROUTINE ERMOR +! +!======================================================================= +! + SUBROUTINE DERV1(LABEL,VALUE,FLAG) +! +! Copyright (c) 1996 California Institute of Technology, Pasadena, CA. +! ALL RIGHTS RESERVED. +! Based on Government Sponsored Research NAS7-03001. +!>> 1994-10-20 DERV1 Krogh Changes to use M77CON +!>> 1994-04-20 DERV1 CLL Edited to make DP & SP files similar. +!>> 1985-09-20 DERV1 Lawson Initial code. +!--D replaces "?": ?ERV1 +! +! ------------------------------------------------------------ +! SUBROUTINE ARGUMENTS +! -------------------- +! LABEL An identifing name to be printed with VALUE. +! +! VALUE A floating point number to be printed. +! +! FLAG See write up for FLAG in ERMSG. +! +! ------------------------------------------------------------ +! +! + USE M77ERR +! + IMPLICIT NONE +! + REAL (WP) :: VALUE +! + CHARACTER (LEN = *) :: LABEL + CHARACTER (LEN = 1) :: FLAG +! + IF (IALPHA.GE.-1) THEN + WRITE (*,*) ' ',LABEL,' = ',VALUE + IF (FLAG.EQ.'.') CALL ERFIN + ENDIF + RETURN +! + END SUBROUTINE DERV1 +! +!======================================================================= +! + SUBROUTINE IERM1(SUBNAM,INDIC,LEVEL,MSG,LABEL,VALUE,FLAG) +! +! Copyright (c) 1996 California Institute of Technology, Pasadena, CA. +! ALL RIGHTS RESERVED. +! Based on Government Sponsored Research NAS7-03001. +!>> 1990-01-18 CLL Added Integer stmt for VALUE. Typed all variables. +!>> 1985-08-02 IERM1 Lawson Initial code. +! + IMPLICIT NONE +! + INTEGER :: INDIC,LEVEL,VALUE +! + CHARACTER (LEN = *) :: SUBNAM,MSG,LABEL + CHARACTER (LEN = 1) :: FLAG +! + CALL ERMSG(SUBNAM,INDIC,LEVEL,MSG,',') ! + CALL IERV1(LABEL,VALUE,FLAG) ! +! + RETURN +! + END SUBROUTINE IERM1 +! +!======================================================================= +! + SUBROUTINE IERV1(LABEL,VALUE,FLAG) +! +! Copyright (c) 1996 California Institute of Technology, Pasadena, CA. +! ALL RIGHTS RESERVED. +! Based on Government Sponsored Research NAS7-03001. +!>> 1995-11-15 IERV1 Krogh Moved format up for C conversion. +!>> 1985-09-20 IERV1 Lawson Initial code. +! +! ------------------------------------------------------------ +! SUBROUTINE ARGUMENTS +! -------------------- +! LABEL An identifing name to be printed with VALUE. +! +! VALUE A integer to be printed. +! +! FLAG See write up for FLAG in ERMSG. +! +! ------------------------------------------------------------ +! + USE M77ERR +! + IMPLICIT NONE +! + INTEGER :: VALUE +! + CHARACTER (LEN = *) :: LABEL + CHARACTER (LEN = 1) :: FLAG +! + IF (IALPHA >= -1) THEN ! + WRITE (6,10) LABEL,VALUE ! + IF(FLAG .EQ. '.') CALL ERFIN ! + END IF ! +! + RETURN ! +! +! Format: +! + 10 FORMAT(3X,A,' = ',I5) +! + END +! +!======================================================================= +! + SUBROUTINE SERM1(SUBNAM,INDIC,LEVEL,MSG,LABEL,VALUE,FLAG) +! +! Copyright (c) 1996 California Institute of Technology, Pasadena, CA. +! ALL RIGHTS RESERVED. +! Based on Government Sponsored Research NAS7-03001. +!>> 1994-10-20 SERM1 Krogh Changes to use M77CON +!>> 1994-04-20 SERM1 CLL Edited to make DP & SP files similar. +!>> 1985-08-02 SERM1 Lawson Initial code. +!--S replaces "?": ?ERM1, ?ERV1 +! +! + IMPLICIT NONE +! + INTEGER :: INDIC,LEVEL +! + REAL (WP) :: VALUE +! + CHARACTER (LEN = *) :: SUBNAM,MSG,LABEL + CHARACTER (LEN = 1) :: FLAG +! + CALL ERMSG(SUBNAM,INDIC,LEVEL,MSG,',') ! + CALL SERV1(LABEL,VALUE,FLAG) ! +! + RETURN +! + END SUBROUTINE SERM1 +! +!======================================================================= +! + SUBROUTINE SERV1(LABEL,VALUE,FLAG) +! +! Copyright (c) 1996 California Institute of Technology, Pasadena, CA. +! ALL RIGHTS RESERVED. +! Based on Government Sponsored Research NAS7-03001. +!>> 1994-10-20 SERV1 Krogh Changes to use M77CON +!>> 1994-04-20 SERV1 CLL Edited to make DP & SP files similar. +!>> 1985-09-20 SERV1 Lawson Initial code. +!--S replaces "?": ?ERV1 +! +! ------------------------------------------------------------ +! SUBROUTINE ARGUMENTS +! -------------------- +! LABEL An identifing name to be printed with VALUE. +! +! VALUE A floating point number to be printed. +! +! FLAG See write up for FLAG in ERMSG. +! +! ------------------------------------------------------------ +! + USE M77ERR +! + IMPLICIT NONE +! + REAL (WP) :: VALUE +! + CHARACTER (LEN = *) :: LABEL + CHARACTER (LEN = 1) :: FLAG +! + IF(IALPHA >= -1) THEN ! + WRITE(6,*) ' ',LABEL,' = ',VALUE ! + IF(FLAG == '.') CALL ERFIN ! + END IF ! +! + RETURN ! +! + END SUBROUTINE SERV1 +! +END MODULE ERROR_CALTECH diff --git a/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/change_filenames.f90 b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/change_filenames.f90 new file mode 100644 index 0000000..e57a14d --- /dev/null +++ b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/change_filenames.f90 @@ -0,0 +1,306 @@ +! +!======================================================================= +! +MODULE CHANGE_FILENAMES +! +! This module changes all the output filenames by +! incorporating into them a string characteristic of +! the calculation performed +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE LOGFILE_NAMES(N_IF,LOGFILE) +! +! This subroutine constructs the name of the logfiles when +! several input data file are read in +! +! +! Input parameters: +! +! * N_IF : number of input data file +! +! +! Uutput parameters: +! +! * LOGFILE : array containing the names of the log files +! +! +! Author : D. Sébilleau +! +! Last modified : 8 Sep 2020 +! +! + IMPLICIT NONE +! + INTEGER :: N_IF,JF +! + CHARACTER (LEN = 100) :: LOGFILE(999) + CHARACTER (LEN = 7) :: BASENAME + CHARACTER (LEN = 4) :: EXTENSION + CHARACTER (LEN = 1) :: UNDSC +! + BASENAME = 'epsilon' ! + EXTENSION = '.lis' ! + UNDSC = '_' ! +! + IF(N_IF == 1) THEN ! + LOGFILE(1) = BASENAME//EXTENSION ! + ELSE + DO JF = 1,N_IF ! + LOGFILE(JF) = BASENAME//UNDSC//NUM2STRING(JF)//EXTENSION ! + END DO ! + END IF +! + END SUBROUTINE LOGFILE_NAMES +! +!======================================================================= +! + FUNCTION NUM2STRING(NUM) +! +! This function converts an integer into the corresponding +! character string, including the zeros (e. g. 3 --> 003) +! +! This version: limited to 999 +! +! +! Input parameter: +! +! * NUM : number to be transformed into a string +! +! +! +! Author : D. Sébilleau +! +! Last modified : 8 Sep 2020 +! +! + IMPLICIT NONE +! + INTEGER, PARAMETER :: N_LE = 3 ! max. number of digits + INTEGER, PARAMETER :: N_IF = 999 ! max. number of input files +! + CHARACTER (LEN = N_LE) :: NUM2STRING +! + INTEGER :: NUM + INTEGER :: JF + INTEGER :: I_D1,I_D2,I_D3 + INTEGER :: NNUM +! +! Initialisation of the digits to 0 +! + I_D1 = 48 + I_D2 = 48 + I_D3 = 48 +! + DO JF = 1,N_IF ! start loop on files +! + I_D1 = I_D1 + 1 ! incrementation of 1st digit + IF(I_D1 == 58) THEN + I_D1 = 48 + I_D2 = I_D2 + 1 ! incrementation of 2nd digit + IF(I_D2 == 58) THEN + I_D2 = 48 + I_D3 = I_D3 + 1 ! incrementation of 3rd digit + END IF + END IF +! + NNUM = (I_D3 - 48) * 100 + (I_D2 - 48) * 10 + (I_D1 - 48) ! number generated +! + IF(NUM == NNUM) GO TO 10 +! + END DO +! + 10 NUM2STRING = CHAR(I_D3)//CHAR(I_D2)//CHAR(I_D1) +! + END FUNCTION NUM2STRING +! +!======================================================================= +! + SUBROUTINE NEW_FILENAMES(N_IF,JF,FLIST) +! +! This subroutine changes all the output filenames by +! incorporating into them a string characteristic of +! the calculation performed +! +! +! Input parameters: +! +! * N_IF : number of input data file +! * J F : current input data file +! +! +! Input/output parameters: +! +! * FLIST : array containing the names of the output files +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Sep 2020 +! +! + USE DIMENSION_CODE, ONLY : NOFFN + USE OUT_VALUES_10 + USE OUTFILES +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: N_IF + INTEGER, INTENT(IN) :: JF +! + INTEGER :: FILE +! + CHARACTER (LEN = 100), INTENT(INOUT) :: FLIST(NOFFN) +! + CHARACTER (LEN = 100) :: CLIST(NOFFN) + CHARACTER (LEN = 100) :: INFILE + CHARACTER (LEN = 100) :: OUTFILE + CHARACTER (LEN = 100) :: STRING + CHARACTER (LEN = 1) :: UNDSC +! + UNDSC = '_' ! +! + IF(N_IF == 1) THEN ! +! +! Only the type of calculation can be appended +! + IF(I_FN == 1) THEN ! +! + CALL CALC_TYPE(CLIST) ! + CALL OUT_FILES(FLIST) ! +! + DO FILE = 7,NOFFN ! +! + INFILE = FLIST(FILE) ! + STRING = CLIST(FILE) ! +! + CALL CHG_FILENAME(INFILE,STRING,OUTFILE) ! +! + FLIST(FILE) = OUTFILE ! +! + END DO ! +! + ELSE ! +! + CALL OUT_FILES(FLIST) ! +! + END IF ! +! + ELSE ! +! + IF(I_FN == 1) THEN ! +! +! Type of calculation appended + input data file number appended +! + CALL CALC_TYPE(CLIST) ! + CALL OUT_FILES(FLIST) ! +! + DO FILE = 7,NOFFN ! +! + INFILE = FLIST(FILE) ! +! +! Checking if input data file number must ne appended +! + IF(INDEX_FILE(FILE) == 0) THEN ! + STRING = CLIST(FILE)//UNDSC//NUM2STRING(JF) ! + ELSE ! + STRING = CLIST(FILE) ! + END IF ! +! + CALL CHG_FILENAME(INFILE,STRING,OUTFILE) ! +! + FLIST(FILE) = OUTFILE ! +! + END DO ! +! + ELSE +! +! Only input data file number appended +! + CALL OUT_FILES(FLIST) ! +! + DO FILE = 7,NOFFN ! +! + INFILE = FLIST(FILE) ! +! +! Checking if input data file number must ne appended +! + IF(INDEX_FILE(FILE) == 0) THEN ! + STRING = NUM2STRING(JF) ! + CALL CHG_FILENAME(INFILE,STRING,OUTFILE) ! + FLIST(FILE) = OUTFILE ! + END IF ! +! + END DO ! +! + END IF ! +! + END IF ! +! + END SUBROUTINE NEW_FILENAMES +! +!======================================================================= +! + SUBROUTINE CHG_FILENAME(INFILE,STRING,OUTFILE) +! +! This subroutine incorporates a given string +! into a filename +! +! +! Input parameters: +! +! * INFILE : name of input file +! * STRING : string to be appended +! +! +! Input/output parameters: +! +! * OUTFILE : name of output file +! +! +! Author : D. Sébilleau +! +! Last modified : 7 Sep 2020 +! +! + IMPLICIT NONE +! + INTEGER, PARAMETER :: N_LENGTH = 100 +! + CHARACTER (LEN = 100), INTENT(IN) :: INFILE + CHARACTER (LEN = 100), INTENT(OUT) :: OUTFILE +! + CHARACTER (LEN = 100) :: STRING +! + INTEGER :: J_CHAR + INTEGER :: N_DOT,N_CHAR +! +! Finding the real size of the file name +! and the position of the dot +! + N_DOT = 1 ! + DO J_CHAR = 1,N_LENGTH ! + IF(INFILE(J_CHAR:J_CHAR).EQ.'.') GO TO 10 ! + N_DOT = N_DOT + 1 ! + END DO ! +! + 10 CONTINUE ! +! + N_CHAR = 0 ! + DO J_CHAR = 1,N_LENGTH ! + IF(INFILE(J_CHAR:J_CHAR).EQ.' ') GO TO 20 ! + N_CHAR = N_CHAR + 1 ! + END DO ! +! + 20 CONTINUE ! +! +! Incorporation of the string +! + OUTFILE = INFILE(1:N_DOT-1)//'_'//TRIM(STRING)// & ! + INFILE(N_DOT:N_CHAR) ! +! + END SUBROUTINE CHG_FILENAME +! +END MODULE CHANGE_FILENAMES diff --git a/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/close_files.f90 b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/close_files.f90 new file mode 100644 index 0000000..4afc725 --- /dev/null +++ b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/close_files.f90 @@ -0,0 +1,321 @@ +! +!======================================================================= +! +MODULE CLOSE_OUTFILES +! +! This module contains the subroutine that opens the output files +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE CLOSE_OUTPUT_FILES(IND) +! +! This subroutine open the output files for printing +! +! +! Input parameter: +! +! * IND : integer specifying which files have to be closed +! IND = 0 files indexed with input data file +! IND = 1 files not indexed with input data file +! +! (see FUNCTION INDEX_FILE(I_UNIT) in outfiles.f90 for more details) +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Jan 2021 +! +! + USE OUT_VALUES_1 + USE OUT_VALUES_2 + USE OUT_VALUES_3 + USE OUT_VALUES_4 + USE OUT_VALUES_5 + USE OUT_VALUES_6 + USE OUT_VALUES_7 + USE OUT_VALUES_8 + USE OUT_VALUES_9 + USE OUT_VALUES_P +! + USE OUTFILES +! + USE PRINT_FILES +! + IMPLICIT NONE +! + INTEGER :: IND +! + IF(I_DF == 1) THEN ! + IF(IND == INDEX_FILE(IO_DF)) CLOSE(IO_DF) ! dielectric function file + END IF ! + IF(I_PZ == 1) THEN ! + IF(IND == INDEX_FILE(IO_PZ)) CLOSE(IO_PZ) ! polarization function + END IF ! + IF(I_SU == 1) THEN ! + IF(IND == INDEX_FILE(IO_SU)) CLOSE(IO_SU) ! susceptibility function + END IF ! + IF(I_CD == 1) THEN ! + IF(IND == INDEX_FILE(IO_CD)) CLOSE(IO_CD) ! electrical conductivity + END IF ! +! + IF(I_PD == 1) THEN ! + IF(IND == INDEX_FILE(IO_PD)) CLOSE(IO_PD) ! plasmon dispersion file + END IF ! + IF(I_EH == 1) THEN ! + IF(IND == INDEX_FILE(IO_EH)) CLOSE(IO_EH) ! electron-hole dispersion file + END IF ! + IF(I_E2 == 1) THEN ! + IF(IND == INDEX_FILE(IO_E2)) CLOSE(IO_E2) ! two electron-hole dispersion + END IF ! + IF(I_CF == 1) THEN ! + IF(IND == INDEX_FILE(IO_CK)) CLOSE(IO_CK) ! screened Coulomb (k-space) + END IF ! + IF(I_CR == 1) THEN ! + IF(IND == INDEX_FILE(IO_CR)) CLOSE(IO_CR) ! screened Coulomb (real space) + END IF ! + IF(I_PK == 1) THEN ! + IF(IND == INDEX_FILE(IO_PK)) CLOSE(IO_PK) ! plasmon kinetic energy + END IF ! +! + IF(I_LF == 1) THEN ! + IF(IND == INDEX_FILE(IO_LF)) CLOSE(IO_LF) ! local-field correction file G(q,om) + END IF ! + IF(I_IQ == 1) THEN ! + IF(IND == INDEX_FILE(IO_IQ)) CLOSE(IO_IQ) ! G(q,inf) file + END IF ! + IF(I_SF == 1) THEN ! + IF(IND == INDEX_FILE(IO_SF)) CLOSE(IO_SF) ! structure factor file S(q,om) + END IF ! + IF(I_PC == 1) THEN ! + IF(IND == INDEX_FILE(IO_PC)) CLOSE(IO_PC) ! pair correlation function file + END IF ! + IF(I_P2 == 1) THEN ! + IF(IND == INDEX_FILE(IO_P2)) CLOSE(IO_P2) ! pair distribution function file + END IF ! + IF(I_VX == 1) THEN ! + IF(IND == INDEX_FILE(IO_VX)) CLOSE(IO_VX) ! vertex function Gamma(q,om) + END IF ! + IF(I_DC == 1) THEN ! + IF(IND == INDEX_FILE(IO_DC)) CLOSE(IO_DC) ! plasmon damping coefficient Im[eps]/q^2 + END IF ! + IF(I_MD == 1) THEN ! + IF(IND == INDEX_FILE(IO_MD)) CLOSE(IO_MD) ! momentum distribution + END IF ! + IF(I_LD == 1) THEN ! + IF(IND == INDEX_FILE(IO_LD)) CLOSE(IO_LD) ! Landau parameters + END IF ! + IF(I_DP == 1) THEN ! + IF(IND == INDEX_FILE(IO_DP)) CLOSE(IO_DP) ! damping file + END IF ! + IF(I_LT == 1) THEN ! + IF(IND == INDEX_FILE(IO_LT)) CLOSE(IO_LT) ! plasmon lifetime file + END IF ! + IF(I_BR == 1) THEN ! + IF(IND == INDEX_FILE(IO_BR)) CLOSE(IO_BR) ! plasmon broadening + END IF ! + IF(I_PE == 1) THEN ! + IF(IND == INDEX_FILE(IO_PE)) CLOSE(IO_PE) ! plasmon energy + END IF ! + IF(I_QC == 1) THEN ! + IF(IND == INDEX_FILE(IO_QC)) CLOSE(IO_QC) ! plasmon q-bounds + END IF ! + IF(I_RL == 1) THEN ! + IF(IND == INDEX_FILE(IO_RL)) CLOSE(IO_RL) ! relaxation time + END IF ! + IF(I_KS == 1) THEN ! + IF(IND == INDEX_FILE(IO_KS)) CLOSE(IO_KS) ! screening wave vector + END IF ! + IF(I_OQ == 1) THEN ! + IF(IND == INDEX_FILE(IO_OQ)) CLOSE(IO_OQ) ! omega = q * v_F + END IF ! + IF(I_ME == 1) THEN ! + IF(IND == INDEX_FILE(IO_ME)) CLOSE(IO_ME) ! moments of epsilon + END IF ! + IF(I_MS == 1) THEN ! + IF(IND == INDEX_FILE(IO_MS)) CLOSE(IO_MS) ! moments of S(q,omega) + END IF ! + IF(I_ML == 1) THEN ! + IF(IND == INDEX_FILE(IO_ML)) CLOSE(IO_ML) ! moments of loss function + END IF ! + IF(I_MC == 1) THEN ! + IF(IND == INDEX_FILE(IO_MC)) CLOSE(IO_MC) ! moments of conductivity + END IF ! + IF(I_DE == 1) THEN ! + IF(IND == INDEX_FILE(IO_DE)) CLOSE(IO_DE) ! derivative of Re[ dielectric function ] + END IF ! + IF(I_ZE == 1) THEN ! + IF(IND == INDEX_FILE(IO_ZE)) CLOSE(IO_ZE) ! Re[ dielectric function ] = 0 + END IF ! + IF(I_SR == 1) THEN ! + IF(IND == INDEX_FILE(IO_SR)) CLOSE(IO_SR) ! sum rules for epsilon + END IF ! + IF(I_CW == 1) THEN ! + IF(IND == INDEX_FILE(IO_CW)) CLOSE(IO_CW) ! confinement wave function + END IF ! + IF(I_CF == 1) THEN ! + IF(IND == INDEX_FILE(IO_CF)) CLOSE(IO_CF) ! confinement potential + END IF ! + IF(I_EM == 1) THEN ! + IF(IND == INDEX_FILE(IO_EM)) CLOSE(IO_EM) ! effective mass + END IF ! + IF(I_MF == 1) THEN ! + IF(IND == INDEX_FILE(IO_MF)) CLOSE(IO_MF) ! mean free path + END IF ! + IF(I_SP == 1) THEN ! + IF(IND == INDEX_FILE(IO_SP)) CLOSE(IO_SP) ! spectral function + END IF ! + IF(I_SE == 1) THEN ! + IF(IND == INDEX_FILE(IO_SE)) CLOSE(IO_SE) ! self-energy + END IF ! + IF(I_SB == 1) THEN ! + IF(IND == INDEX_FILE(IO_SB)) CLOSE(IO_SB) ! subband energies + END IF ! + IF(I_ES == 1) THEN ! + IF(IND == INDEX_FILE(IO_ES)) CLOSE(IO_ES) ! Eliashberg function + END IF ! + IF(I_GR == 1) THEN ! + IF(IND == INDEX_FILE(IO_GR)) CLOSE(IO_GR) ! Grüneisen parameter + END IF ! + IF(I_FD == 1) THEN ! + IF(IND == INDEX_FILE(IO_FD)) CLOSE(IO_FD) ! Fermi-Dirac distribution + END IF ! + IF(I_BE == 1) THEN ! + IF(IND == INDEX_FILE(IO_BE)) CLOSE(IO_BE) ! Bose-Einstein distribution + END IF ! + IF(I_MX == 1) THEN ! + IF(IND == INDEX_FILE(IO_MX)) CLOSE(IO_MX) ! Maxwell distribution + END IF ! + IF(I_SC == 1) THEN ! + IF(IND == INDEX_FILE(IO_SC)) CLOSE(IO_SC) ! scale parameters + END IF ! + IF(I_DS == 1) THEN ! + IF(IND == INDEX_FILE(IO_DS)) CLOSE(IO_DS) ! density of states + END IF ! + IF(I_NV == 1) THEN ! + IF(IND == INDEX_FILE(IO_NV)) CLOSE(IO_NV) ! Nevanlinaa function + END IF ! + IF(I_MT == 1) THEN ! + IF(IND == INDEX_FILE(IO_MT)) CLOSE(IO_MT) ! time domain memory function + END IF ! +! + IF(I_GP == 1) THEN ! + IF(IND == INDEX_FILE(IO_GP)) CLOSE(IO_GP) ! grand partition function + END IF ! + IF(I_PR == 1) THEN ! + IF(IND == INDEX_FILE(IO_PR)) CLOSE(IO_PR) ! electronic pressure + END IF ! + IF(I_CO == 1) THEN ! + IF(IND == INDEX_FILE(IO_CO)) CLOSE(IO_CO) ! compressibility + END IF ! + IF(I_CP == 1) THEN ! + IF(IND == INDEX_FILE(IO_CP)) CLOSE(IO_CP) ! chemical potential + END IF ! + IF(I_BM == 1) THEN ! + IF(IND == INDEX_FILE(IO_BM)) CLOSE(IO_BM) ! bulk modulus + END IF ! + IF(I_SH == 1) THEN ! + IF(IND == INDEX_FILE(IO_SH)) CLOSE(IO_SH) ! shear modulus + END IF ! + IF(I_S0 == 1) THEN ! + IF(IND == INDEX_FILE(IO_S0)) CLOSE(IO_S0) ! zero sound velocity + END IF ! + IF(I_S1 == 1) THEN ! + IF(IND == INDEX_FILE(IO_S1)) CLOSE(IO_S1) ! first sound velocity + END IF ! + IF(I_DT == 1) THEN ! + IF(IND == INDEX_FILE(IO_DT)) CLOSE(IO_DT) ! Debye temperature + END IF ! + IF(I_PS == 1) THEN ! + IF(IND == INDEX_FILE(IO_PS)) CLOSE(IO_PS) ! Pauli paramagnetic susceptibility + END IF ! + IF(I_IE == 1) THEN ! + IF(IND == INDEX_FILE(IO_IE)) CLOSE(IO_IE) ! internal energy + END IF ! + IF(I_EI == 1) THEN ! + IF(IND == INDEX_FILE(IO_EI)) CLOSE(IO_EI) ! excess internal energy + END IF ! + IF(I_FH == 1) THEN ! + IF(IND == INDEX_FILE(IO_FH)) CLOSE(IO_FH) ! Helmholtz free energy + END IF ! + IF(I_EY == 1) THEN ! + IF(IND == INDEX_FILE(IO_EY)) CLOSE(IO_EY) ! entropy + END IF ! +! + IF(I_EF == 1) THEN ! + IF(IND == INDEX_FILE(IO_EF)) CLOSE(IO_EF) ! Fermi energy + END IF ! + IF(I_KF == 1) THEN ! + IF(IND == INDEX_FILE(IO_KF)) CLOSE(IO_KF) ! Fermi momentum + END IF ! + IF(I_VF == 1) THEN ! + IF(IND == INDEX_FILE(IO_VF)) CLOSE(IO_VF) ! Fermi velocity + END IF ! + IF(I_TE == 1) THEN ! + IF(IND == INDEX_FILE(IO_TE)) CLOSE(IO_TE) ! Fermi temperature + END IF ! + IF(I_DL == 1) THEN ! + IF(IND == INDEX_FILE(IO_DL)) CLOSE(IO_DL) ! Fermi density of states + END IF ! +! + IF(I_TW == 1) THEN ! + IF(IND == INDEX_FILE(IO_TW)) CLOSE(IO_TW) ! thermal De Broglie wavelength + END IF ! + IF(I_VT == 1) THEN ! + IF(IND == INDEX_FILE(IO_VT)) CLOSE(IO_VT) ! thermal velocity + END IF ! + IF(I_TC == 1) THEN ! + IF(IND == INDEX_FILE(IO_TC)) CLOSE(IO_TC) ! thermal conductivity + END IF ! +! + IF(I_EG == 1) THEN ! + IF(IND == INDEX_FILE(IO_EG)) CLOSE(IO_EG) ! ground state energy + END IF ! + IF(I_EX == 1) THEN ! + IF(IND == INDEX_FILE(IO_EX)) CLOSE(IO_EX) ! exchange energy + END IF ! + IF(I_XC == 1) THEN ! + IF(IND == INDEX_FILE(IO_XC)) CLOSE(IO_XC) ! exchange correlation energy + END IF ! + IF(I_EC == 1) THEN ! + IF(IND == INDEX_FILE(IO_EC)) CLOSE(IO_EC) ! correlation energy + END IF ! + IF(I_HF == 1) THEN ! + IF(IND == INDEX_FILE(IO_HF)) CLOSE(IO_HF) ! Hartree-Fock energy + END IF ! + IF(I_EK == 1) THEN ! + IF(IND == INDEX_FILE(IO_EK)) CLOSE(IO_EK) ! kinetic energy + END IF ! + IF(I_EP == 1) THEN ! + IF(IND == INDEX_FILE(IO_EP)) CLOSE(IO_EP) ! potential energy + END IF ! +! + IF(I_VI == 1) THEN ! + IF(IND == INDEX_FILE(IO_VI)) CLOSE(IO_VI) ! shear viscosity + END IF ! + IF(I_DI == 1) THEN ! + IF(IND == INDEX_FILE(IO_DI)) CLOSE(IO_DI) ! diffusion coefficient + END IF ! +! + IF(I_FP == 1) THEN ! + IF(IND == INDEX_FILE(IO_FP)) CLOSE(IO_FP) ! fluctuation potential file + END IF ! + IF(I_EL == 1) THEN ! + IF(IND == INDEX_FILE(IO_EL)) CLOSE(IO_EL) ! energy loss function + END IF ! + IF(I_PO == 1) THEN ! + IF(IND == INDEX_FILE(IO_PO)) CLOSE(IO_PO) ! stopping power + END IF ! + IF(I_RF == 1) THEN ! + IF(IND == INDEX_FILE(IO_RF)) CLOSE(IO_RF) ! refractive index + END IF ! + IF(I_VC == 1) THEN ! + IF(IND == INDEX_FILE(IO_VC)) CLOSE(IO_VC) ! dynamic screened Coulomb potential V(q,omega) + END IF ! +! + END SUBROUTINE CLOSE_OUTPUT_FILES +! +END MODULE CLOSE_OUTFILES + diff --git a/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/diel_func.txt b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/diel_func.txt new file mode 100644 index 0000000..97d9d77 --- /dev/null +++ b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/diel_func.txt @@ -0,0 +1,41 @@ + Dielectric functions: + + + --> Schrödinger materials + +1) static: + + * Thomas-Fermi + * RPA longitudinal 2D + magnetic field + * RPA longitudinal 1D, 2D, 3D + +2) dynamic: + + * Vlasov longitudinal 3D + * VFP longitudinal 3D + relaxation time + * RPA longitudinal 1D, 2D, 3D + * RPA longitudinal 3D + temperature + * RPA longitudinal 2D + magnetic field + * plasmon pole longitudinal 1D, 2D, 3D + * Nevanlinna + * mean spherical longitudinal 3D + * Mermin longitudinal 3D + temperature + * Klimontovich-Kraeft longitudinal 3D (non degenerate/highly degenerate) + * hydrodynamic longitudinal 3D + relaxation time + * Hu-O'Connell 1D, 2D, 3D + diffusion coefficient + * Hartree-Fock longitudinal 3D + * Hertel-Appel longitudinal 3D + * Arista-Brandt longitudinal 3D + temperature (Dandrea-Ashcroft-Carlsson par.) + * Boltzmann longitudinal 3D + * Boltzmann longitudinal 3D+ relaxation time + * Boltzmann transverse 3D+ relaxation time + + Waiting to be coded: + * Atwal-Ashcroft 3D + * Utsumi-Ichimaru longitudinal 3D + * Kleinman longitudinal 3D + + + --> Dirac materials + + diff --git a/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/filenames.f90 b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/filenames.f90 new file mode 100644 index 0000000..272de51 --- /dev/null +++ b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/filenames.f90 @@ -0,0 +1,37 @@ +! +!======================================================================= +! +MODULE FILENAMES +! +! + IMPLICIT NONE +! + CHARACTER (LEN = 100) :: DFFILE,PZFILE,SUFILE,CDFILE +! + CHARACTER (LEN = 100) :: PDFILE,EHFILE,E2FILE,CKFILE,CRFILE,PKFILE +! + CHARACTER (LEN = 100) :: LFFILE,IQFILE,SFFILE,PCFILE,VXFILE,DCFILE + CHARACTER (LEN = 100) :: P2FILE + CHARACTER (LEN = 100) :: MDFILE,LDFILE,DPFILE,LTFILE,BRFILE,PEFILE + CHARACTER (LEN = 100) :: QCFILE,RLFILE,KSFILE,OQFILE,MEFILE,MSFILE + CHARACTER (LEN = 100) :: MLFILE,MCFILE,DEFILE,ZEFILE,SRFILE,CWFILE + CHARACTER (LEN = 100) :: CFFILE,EMFILE,MFFILE,SPFILE,SEFILE,SBFILE + CHARACTER (LEN = 100) :: ESFILE,GRFILE,FDFILE,BEFILE,MXFILE,SCFILE + CHARACTER (LEN = 100) :: DSFILE,NVFILE,MTFILE +! + CHARACTER (LEN = 100) :: GPFILE,PRFILE,COFILE,CPFILE,BMFILE,SHFILE + CHARACTER (LEN = 100) :: S0FILE,S1FILE,DTFILE,PSFILE,IEFILE,EIFILE + CHARACTER (LEN = 100) :: FHFILE,EYFILE +! + CHARACTER (LEN = 100) :: EFFILE,KFFILE,VFFILE,TEFILE,DLFILE +! + CHARACTER (LEN = 100) :: TWFILE,VTFILE,TCFILE +! + CHARACTER (LEN = 100) :: EGFILE,EXFILE,XCFILE,ECFILE,HFFILE,EKFILE + CHARACTER (LEN = 100) :: EPFILE +! + CHARACTER (LEN = 100) :: VIFILE,DIFILE +! + CHARACTER (LEN = 100) :: FPFILE,ELFILE,POFILE,RFFILE,VCFILE +! +END MODULE FILENAMES diff --git a/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/input_values.f90 b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/input_values.f90 new file mode 100644 index 0000000..21e2f3b --- /dev/null +++ b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/input_values.f90 @@ -0,0 +1,617 @@ +! +!======================================================================= +! +MODULE MATERIAL_PROP +! +! This module contains input values for the material's properties +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: RS,MSOM,EPS_B +! + CHARACTER (LEN = 5) :: MAT_TYP + CHARACTER (LEN = 2) :: DMN +! +END MODULE MATERIAL_PROP +! +!======================================================================= +! +MODULE EXT_FIELDS +! +! This module contains input values for the external fields +! (temperature, electric, magnetic) +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: T,E,H +! + CHARACTER (LEN = 2) :: FLD +! +END MODULE EXT_FIELDS +! +!======================================================================= +! +MODULE Q_GRID +! +! This module contains input values for q-grid +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + INTEGER :: N_Q +! + REAL (WP) :: Q_MIN,Q_MAX,Q_STEP +! + END MODULE Q_GRID +! +!======================================================================= +! +MODULE E_GRID +! +! This module contains input values for energy grid +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + INTEGER :: N_E +! + REAL (WP) :: E_MIN,E_MAX,E_STEP +! + END MODULE E_GRID +! +!======================================================================= +! +MODULE R_GRID +! +! This module contains input values for radial grid +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + INTEGER :: N_R +! + REAL (WP) :: R_MIN,R_MAX,R_STEP +! + END MODULE R_GRID +! +!======================================================================= +! +MODULE CONFIN_VAL +! +! This module contains the input values for the confinement +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: R0,L,OM0 +! + CHARACTER (LEN = 7) :: CONFIN +! +END MODULE CONFIN_VAL +! +!======================================================================= +! +MODULE MULTILAYER +! +! This module contains the input values for multilayer systems +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: DL,D1 + REAL (WP) :: EPS_1,EPS_2 + REAL (WP) :: N_DEP,N_INV +! + CHARACTER (LEN = 4) :: H_TYPE +! +END MODULE MULTILAYER +! +!======================================================================= +! +MODULE UNITS +! +! This module contains the input values for the units used +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: UNIT + CHARACTER (LEN = 2) :: UNIK +! +END MODULE UNITS +! +!======================================================================= +! +MODULE SCREENING_TYPE +! +! This module contains the input values for the screening type +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: SC_TYPE +! +END MODULE SCREENING_TYPE +! +!======================================================================= +! +MODULE PLASMA +! +! This module contains the input values for the plasma type +! +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: PL_TYPE +! + REAL (WP) :: ZION,ZION2 +! +END MODULE PLASMA +! +!======================================================================= +! +MODULE CALCTYPE +! +! This module contains the input values for the calculation type +! +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: CAL_TYPE +! +END MODULE CALCTYPE +! +!======================================================================= +! +MODULE DF_VALUES +! +! This module contains the input values for the dielectric +! function calculation +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: ESTDY + CHARACTER (LEN = 4) :: EPS_T,D_FUNC,NEV_TYPE,MEM_TYPE +! + REAL (WP) :: ALPHA,BETA +! + INTEGER :: I_T +! +END MODULE DF_VALUES +! +!======================================================================= +! +MODULE PLASMON_DISPERSION +! +! This module contains the input values for the analytical +! plasmon dispersion calculation +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: PL_DISP +! +END MODULE PLASMON_DISPERSION +! +!======================================================================= +! +MODULE LF_VALUES +! +! This module contains the input values for the local field +! corrections calculation +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: GSTDY + CHARACTER (LEN = 4) :: GQ_TYPE,GQO_TYPE,LANDAU + CHARACTER (LEN = 3) :: IQ_TYPE + CHARACTER (LEN = 2) :: G0_TYPE,GI_TYPE +! +END MODULE LF_VALUES +! +!======================================================================= +! +MODULE DAMPING_VALUES +! +! This module contains the input values for the plasmon damping calculation +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + CHARACTER (LEN = 5) :: POWER_1,POWER_2 + CHARACTER (LEN = 4) :: DAMPING,LT_TYPE,DR_TYPE,DC_TYPE,VI_TYPE + CHARACTER (LEN = 4) :: EE_TYPE,EP_TYPE,EI_TYPE,IP_TYPE,PD_TYPE + CHARACTER (LEN = 4) :: QD_TYPE + CHARACTER (LEN = 3) :: RT_TYPE +! + REAL (WP) :: ZETA,D_VALUE_1,D_VALUE_2,EK,PCT +! +END MODULE DAMPING_VALUES +! +!======================================================================= +! +MODULE EL_ELE_INTER +! +! This module contains the input values for the electron-electron +! interaction calculation +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + CHARACTER (LEN = 5) :: INT_POT +! + INTEGER :: M,N +! + REAL (WP) :: S,EPS,DELTA + REAL (WP) :: RC,ALF + REAL (WP) :: A1,A2,A3,A4 +! +END MODULE EL_ELE_INTER +! +!======================================================================= +! +MODULE EL_PHO_INTER +! +! This module contains the input values for the electron-phonon +! interaction calculation +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: EP_C,DEBYE_T + REAL (WP) :: NA,MA,RA +! +END MODULE EL_PHO_INTER +! +!======================================================================= +! +MODULE EL_IMP_INTER +! +! This module contains the input values for the electron-impurity +! interaction calculation +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: NI,EI_C +! +END MODULE EL_IMP_INTER +! +!======================================================================= +! +MODULE CLASSICAL_FLUID_VALUES +! +! This module contains the input values for the classical +! fluid parameters +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: CF_TYPE,PF_TYPE,SL_TYPE +! +END MODULE CLASSICAL_FLUID_VALUES +! +!======================================================================= +! +MODULE SF_VALUES +! +! This module contains the input values for the structure +! factor calculation +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: SSTDY + CHARACTER (LEN = 3) :: SQ_TYPE,SQO_TYPE +! +END MODULE SF_VALUES +! +!======================================================================= +! +MODULE PC_VALUES +! +! This module contains the input values for the pair correlation +! function calculation +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GR0_MODE + CHARACTER (LEN = 3) :: GR_TYPE +! +END MODULE PC_VALUES +! +!======================================================================= +! +MODULE PD_VALUES +! +! This module contains the input values for the pair distribution +! function calculation +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: RH_TYPE +! +END MODULE PD_VALUES +! +!======================================================================= +! +MODULE SPF_VALUES +! +! This module contains the input values for the spectral +! function calculation +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: SPF_TYPE +! +END MODULE SPF_VALUES +! +!======================================================================= +! +MODULE ENERGIES +! +! This module contains the input values for the calculation +! of the different energies +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE + CHARACTER (LEN = 3) :: EX_TYPE,EK_TYPE + CHARACTER (LEN = 2) :: FXC_TYPE,EXC_TYPE +! +END MODULE ENERGIES +! +!======================================================================= +! +MODULE SPIN_POLARIZATION +! +! This module contains the input values for the spin polarization +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + INTEGER :: IMODE +! + REAL (WP) :: XI +! +END MODULE SPIN_POLARIZATION +! +!======================================================================= +! +MODULE THERMO_PROPERTIES +! +! This module contains the input values for the thermodynamic +! properties calculation +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: TH_PROP + CHARACTER (LEN = 3) :: GP_TYPE +! +END MODULE THERMO_PROPERTIES +! +!======================================================================= +! +MODULE ELECTRON_MEAN_FREE_PATH +! +! This module contains the input values for the inelastic +! electron mean free path calculation +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: EK_INI,EK_FIN +! +END MODULE ELECTRON_MEAN_FREE_PATH +! +!======================================================================= +! +MODULE MOMENTS +! +! This module contains the input values for the calculation +! of the moments +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: M_TYPE +! + INTEGER :: N_M +! +END MODULE MOMENTS +! +!======================================================================= +! +MODULE ION_BEAM +! +! This module contains the input values for the incoming ion beam +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: Z_BEAM,EK_BEAM +! +! +END MODULE ION_BEAM +! +!======================================================================= +! +MODULE OUT_VALUES_1 +! +! This module contains input values for print switches +! + IMPLICIT NONE +! + INTEGER :: I_DF,I_PZ,I_SU,I_CD +! +END MODULE OUT_VALUES_1 +! +!======================================================================= +! +MODULE OUT_VALUES_2 +! +! This module contains input values for print switches +! + IMPLICIT NONE +! + INTEGER :: I_PD,I_EH,I_E2,I_CK + INTEGER :: I_CR,I_PK +! +END MODULE OUT_VALUES_2 +! +!======================================================================= +! +MODULE OUT_VALUES_3 +! +! This module contains input values for print switches +! + IMPLICIT NONE +! + INTEGER :: I_LF,I_IQ,I_SF,I_PC + INTEGER :: I_P2 + INTEGER :: I_VX,I_DC,I_MD,I_LD + INTEGER :: I_DP,I_LT,I_BR,I_PE + INTEGER :: I_QC,I_RL,I_KS,I_OQ + INTEGER :: I_ME,I_MS,I_ML,I_MC + INTEGER :: I_DE,I_ZE,I_SR,I_CW + INTEGER :: I_CF,I_EM,I_MF,I_SP + INTEGER :: I_SE,I_SB,I_ES,I_GR + INTEGER :: I_FD,I_BE,I_MX + INTEGER :: I_SC,I_DS,I_NV,I_MT +! +END MODULE OUT_VALUES_3 +! +!======================================================================= +! +MODULE OUT_VALUES_4 +! +! This module contains input values for print switches +! + IMPLICIT NONE +! + INTEGER :: I_GP,I_PR,I_CO,I_CP + INTEGER :: I_BM,I_SH,I_S0,I_S1 + INTEGER :: I_DT,I_PS,I_IE,I_EI + INTEGER :: I_FH,I_EY +! +END MODULE OUT_VALUES_4 +! +!======================================================================= +! +MODULE OUT_VALUES_5 +! +! This module contains input values for print switches +! + IMPLICIT NONE +! + INTEGER :: I_EF,I_KF,I_VF,I_TE,I_DL +! +END MODULE OUT_VALUES_5 +! +!======================================================================= +! +MODULE OUT_VALUES_6 +! +! This module contains input values for print switches +! + IMPLICIT NONE +! + INTEGER :: I_TW,I_VT,I_TC +! +END MODULE OUT_VALUES_6 +! +!======================================================================= +! +MODULE OUT_VALUES_7 +! +! This module contains input values for print switches +! + IMPLICIT NONE +! + INTEGER :: I_EG,I_EX,I_XC,I_EC + INTEGER :: I_HF,I_EK,I_EP +! +END MODULE OUT_VALUES_7 +! +!======================================================================= +! +MODULE OUT_VALUES_8 +! +! This module contains input values for print switches +! + IMPLICIT NONE +! + INTEGER :: I_VI,I_DI +! +END MODULE OUT_VALUES_8 +! +!======================================================================= +! +MODULE OUT_VALUES_9 +! +! This module contains input values for print switches +! + IMPLICIT NONE +! + INTEGER :: I_EL,I_PO,I_RF + INTEGER :: I_VC +! +END MODULE OUT_VALUES_9 +! +!======================================================================= +! +MODULE OUT_VALUES_10 +! +! This module contains input values for print switches +! + IMPLICIT NONE +! + INTEGER :: I_FN,I_WR,I_TI +! +END MODULE OUT_VALUES_10 +! +!======================================================================= +! +MODULE OUT_VALUES_P +! +! This module contains input values for print switches +! + IMPLICIT NONE +! + INTEGER :: I_FP +! +END MODULE OUT_VALUES_P +! +!======================================================================= +! +MODULE OUT_CALC +! +! This module contains input values for the calculators +! + IMPLICIT NONE +! + INTEGER :: I_C1,I_C2,I_C3,I_C4,I_C5 + INTEGER :: I_C6,I_C7,I_C8,I_C9,I_PP +! +END MODULE OUT_CALC +! +!======================================================================= +! diff --git a/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/missing.txt b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/missing.txt new file mode 100644 index 0000000..b4f5b74 --- /dev/null +++ b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/missing.txt @@ -0,0 +1,4 @@ +DFUNCL_MAGN_DYNAMIC : + +! * NU : dimensionless filling factor + diff --git a/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/nomenclature.txt b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/nomenclature.txt new file mode 100644 index 0000000..677b697 --- /dev/null +++ b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/nomenclature.txt @@ -0,0 +1,13 @@ + + +Name of dielectric function subroutines: + + XXX_EPS_A_BB_CC.f + + + XXXX: identifier of method + A : S for static + D for dynamic + BB : LG for longitudinal + TR for transverse + CC : 3D, 2D, 1D or nothing diff --git a/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/open_files.f90 b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/open_files.f90 new file mode 100644 index 0000000..94bb90d --- /dev/null +++ b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/open_files.f90 @@ -0,0 +1,613 @@ +! +!======================================================================= +! +MODULE OPEN_OUTFILES +! +! This module contains the subroutine that opens the output files +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE OPEN_OUTPUT_FILES(N_IF,JF) +! +! This subroutine open the output files for printing. These files +! are open: +! +! 1) at the first input data file iteration (JF = 1) +! 2) for the other iteration: if file is indexed +! on the input data files (INDEX_FILE(IO_DF) = 0) +! +! +! Input parameter: +! +! * N_IF : number of input data files +! * JF : index of current input data file +! +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Jan 2021 +! +! +! + USE DIMENSION_CODE, ONLY : NOFFN +! + USE OUT_VALUES_1 + USE OUT_VALUES_2 + USE OUT_VALUES_3 + USE OUT_VALUES_4 + USE OUT_VALUES_5 + USE OUT_VALUES_6 + USE OUT_VALUES_7 + USE OUT_VALUES_8 + USE OUT_VALUES_9 + USE OUT_VALUES_10 + USE OUT_VALUES_P +! + USE FILENAMES + USE OUTFILES + USE CHANGE_FILENAMES +! + USE PRINT_FILES +! + IMPLICIT NONE +! + INTEGER :: N_IF + INTEGER :: JF + INTEGER :: J +! + CHARACTER (LEN = 100) :: FLIST(NOFFN) +! +! Changing the output filenames if required +! + CALL NEW_FILENAMES(N_IF,JF,FLIST) ! +! +! Files for calculator 1 +! + IF(I_DF == 1) THEN ! + IO_DF=FN(DFFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_DF) == 0) THEN ! + OPEN(UNIT=IO_DF,FILE=FLIST(IO_DF),STATUS='unknown') ! dielectric function file + END IF ! + END IF ! + IF(I_PZ == 1) THEN ! + IO_PZ=FN(PZFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_PZ) == 0) THEN ! + OPEN(UNIT=IO_PZ,FILE=FLIST(IO_PZ),STATUS='unknown') ! polarization function + END IF ! + END IF ! + IF(I_SU == 1) THEN ! + IO_SU=FN(SUFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_SU) == 0) THEN ! + OPEN(UNIT=IO_SU,FILE=FLIST(IO_SU),STATUS='unknown') ! susceptibility function + END IF ! + END IF ! + IF(I_CD == 1) THEN ! + IO_CD=FN(CDFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_CD) == 0) THEN ! + OPEN(UNIT=IO_CD,FILE=FLIST(IO_CD),STATUS='unknown') ! electrical conductivity + END IF ! + END IF ! +! +! Files for calculator 2 +! + IF(I_PD == 1) THEN ! + IO_PD=FN(PDFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_PD) == 0) THEN ! + OPEN(UNIT=IO_PD,FILE=FLIST(IO_PD),STATUS='unknown') ! plasmon dispersion file + END IF ! + END IF ! + IF(I_EH == 1) THEN ! + IO_EH=FN(EHFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_EH) == 0) THEN ! + OPEN(UNIT=IO_EH,FILE=FLIST(IO_EH),STATUS='unknown') ! electron-hole dispersion file + END IF ! + END IF ! + IF(I_E2 == 1) THEN ! + IO_E2=FN(E2FILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_E2) == 0) THEN ! + OPEN(UNIT=IO_E2,FILE=FLIST(IO_E2),STATUS='unknown') ! two electron-hole dispersion + END IF ! + END IF ! + IF(I_CF == 1) THEN ! + IO_CK=FN(CKFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_CK) == 0) THEN ! + OPEN(UNIT=IO_CK,FILE=FLIST(IO_CK),STATUS='unknown') ! screened Coulomb (k-space) + END IF ! + END IF ! + IF(I_CR == 1) THEN ! + IO_CR=FN(CRFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_CR) == 0) THEN ! + OPEN(UNIT=IO_CR,FILE=FLIST(IO_CR),STATUS='unknown') ! screened Coulomb (real space) + END IF ! + END IF ! + IF(I_PK == 1) THEN ! + IO_PK=FN(PKFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_PK) == 0) THEN ! + OPEN(UNIT=IO_PK,FILE=FLIST(IO_PK),STATUS='unknown') ! plasmon kinetic energy + END IF ! + END IF ! +! +! Files for calculator 3 +! + IF(I_LF == 1) THEN ! + IO_LF=FN(LFFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_LF) == 0) THEN ! + OPEN(UNIT=IO_LF,FILE=FLIST(IO_LF),STATUS='unknown') ! local-field correction file G(q,om) + END IF ! + END IF ! + IF(I_IQ == 1) THEN ! + IO_IQ=FN(IQFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_IQ) == 0) THEN ! + OPEN(UNIT=IO_IQ,FILE=FLIST(IO_IQ),STATUS='unknown') ! G(q,inf) file + END IF ! + END IF ! + IF(I_SF == 1) THEN ! + IO_SF=FN(SFFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_SF) == 0) THEN ! + OPEN(UNIT=IO_SF,FILE=FLIST(IO_SF),STATUS='unknown') ! structure factor file S(q,om) + END IF ! + END IF ! + IF(I_PC == 1) THEN ! + IO_PC=FN(PCFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_PC) == 0) THEN ! + OPEN(UNIT=IO_PC,FILE=FLIST(IO_PC),STATUS='unknown') ! pair correlation function file + END IF ! + END IF ! + IF(I_P2 == 1) THEN ! + IO_P2=FN(P2FILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_P2) == 0) THEN ! + OPEN(UNIT=IO_P2,FILE=FLIST(IO_P2),STATUS='unknown') ! pair distribution function file + END IF ! + END IF ! + IF(I_VX == 1) THEN ! + IO_VX=FN(VXFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_VX) == 0) THEN ! + OPEN(UNIT=IO_VX,FILE=FLIST(IO_VX),STATUS='unknown') ! vertex function Gamma(q,om) + END IF ! + END IF ! + IF(I_DC == 1) THEN ! + IO_DC=FN(DCFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_DC) == 0) THEN ! + OPEN(UNIT=IO_DC,FILE=FLIST(IO_DC),STATUS='unknown') ! plasmon damping coefficient Im[eps]/q^2 + END IF ! + END IF ! + IF(I_MD == 1) THEN ! + IO_MD=FN(MDFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_MD) == 0) THEN ! + OPEN(UNIT=IO_MD,FILE=FLIST(IO_MD),STATUS='unknown') ! momentum distribution + END IF ! + END IF ! + IF(I_LD == 1) THEN ! + IO_LD=FN(LDFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_LD) == 0) THEN ! + OPEN(UNIT=IO_LD,FILE=FLIST(IO_LD),STATUS='unknown') ! Landau parameters + END IF ! + END IF ! + IF(I_DP == 1) THEN ! + IO_DP=FN(DPFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_DP) == 0) THEN ! + OPEN(UNIT=IO_DP,FILE=FLIST(IO_DP),STATUS='unknown') ! damping file + END IF ! + END IF ! + IF(I_LT == 1) THEN ! + IO_LT=FN(LTFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_LT) == 0) THEN ! + OPEN(UNIT=IO_LT,FILE=FLIST(IO_LT),STATUS='unknown') ! plasmon lifetime file + END IF ! + END IF ! + IF(I_BR == 1) THEN ! + IO_BR=FN(BRFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_BR) == 0) THEN ! + OPEN(UNIT=IO_BR,FILE=FLIST(IO_BR),STATUS='unknown') ! plasmon broadening + END IF ! + END IF ! + IF(I_PE == 1) THEN ! + IO_PE=FN(PEFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_PE) == 0) THEN ! + OPEN(UNIT=IO_PE,FILE=FLIST(IO_PE),STATUS='unknown') ! plasmon energy + END IF ! + END IF ! + IF(I_QC == 1) THEN ! + IO_QC=FN(QCFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_QC) == 0) THEN ! + OPEN(UNIT=IO_QC,FILE=FLIST(IO_QC),STATUS='unknown') ! plasmon q-bounds + END IF ! + END IF ! + IF(I_RL == 1) THEN ! + IO_RL=FN(RLFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_RL) == 0) THEN ! + OPEN(UNIT=IO_RL,FILE=FLIST(IO_RL),STATUS='unknown') ! relaxation time + END IF ! + END IF ! + IF(I_KS == 1) THEN ! + IO_KS=FN(KSFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_KS) == 0) THEN ! + OPEN(UNIT=IO_KS,FILE=FLIST(IO_KS),STATUS='unknown') ! screening wave vector + END IF ! + END IF ! + IF(I_OQ == 1) THEN ! + IO_OQ=FN(OQFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_OQ) == 0) THEN ! + OPEN(UNIT=IO_OQ,FILE=FLIST(IO_OQ),STATUS='unknown') ! omega = q * v_F + END IF ! + END IF ! + IF(I_ME == 1) THEN ! + IO_ME=FN(MEFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_ME) == 0) THEN ! + OPEN(UNIT=IO_ME,FILE=FLIST(IO_ME),STATUS='unknown') ! moments of epsilon + END IF ! + END IF ! + IF(I_MS == 1) THEN ! + IO_MS=FN(MSFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_MS) == 0) THEN ! + OPEN(UNIT=IO_MS,FILE=FLIST(IO_MS),STATUS='unknown') ! moments of S(q,omega) + END IF ! + END IF ! + IF(I_ML == 1) THEN ! + IO_ML=FN(MLFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_ML) == 0) THEN ! + OPEN(UNIT=IO_ML,FILE=FLIST(IO_ML),STATUS='unknown') ! moments of loss function + END IF ! + END IF ! + IF(I_MC == 1) THEN ! + IO_MC=FN(MCFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_MC) == 0) THEN ! + OPEN(UNIT=IO_MC,FILE=FLIST(IO_MC),STATUS='unknown') ! moments of conductivity + END IF ! + END IF ! + IF(I_DE == 1) THEN ! + IO_DE=FN(DEFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_DE) == 0) THEN ! + OPEN(UNIT=IO_DE,FILE=FLIST(IO_DE),STATUS='unknown') ! derivative of Re[ dielectric function ] + END IF ! + END IF ! + IF(I_ZE == 1) THEN ! + IO_ZE=FN(ZEFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_ZE) == 0) THEN ! + OPEN(UNIT=IO_ZE,FILE=FLIST(IO_ZE),STATUS='unknown') ! Re[ dielectric function ] = 0 + END IF ! + END IF ! + IF(I_SR == 1) THEN ! + IO_SR=FN(SRFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_SR) == 0) THEN ! + OPEN(UNIT=IO_SR,FILE=FLIST(IO_SR),STATUS='unknown') ! sum rules for epsilon + END IF ! + END IF ! + IF(I_CW == 1) THEN ! + IO_CW=FN(CWFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_CW) == 0) THEN ! + OPEN(UNIT=IO_CW,FILE=FLIST(IO_CW),STATUS='unknown') ! confinement wave function + END IF ! + END IF ! + IF(I_CF == 1) THEN ! + IO_CF=FN(CFFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_CF) == 0) THEN ! + OPEN(UNIT=IO_CF,FILE=FLIST(IO_CF),STATUS='unknown') ! confinement potential + END IF ! + END IF ! + IF(I_EM == 1) THEN ! + IO_EM=FN(EMFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_EM) == 0) THEN ! + OPEN(UNIT=IO_EM,FILE=FLIST(IO_EM),STATUS='unknown') ! effective mass + END IF ! + END IF ! + IF(I_MF == 1) THEN ! + IO_MF=FN(MFFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_MF) == 0) THEN ! + OPEN(UNIT=IO_MF,FILE=FLIST(IO_MF),STATUS='unknown') ! mean free path + END IF ! + END IF ! + IF(I_SP == 1) THEN ! + IO_SP=FN(SPFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_SP) == 0) THEN ! + OPEN(UNIT=IO_SP,FILE=FLIST(IO_SP),STATUS='unknown') ! spectral function + END IF ! + END IF ! + IF(I_SE == 1) THEN ! + IO_SE=FN(SEFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_SE) == 0) THEN ! + OPEN(UNIT=IO_SE,FILE=FLIST(IO_SE),STATUS='unknown') ! self-energy + END IF ! + END IF ! + IF(I_SB == 1) THEN ! + IO_SB=FN(SBFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_SB) == 0) THEN ! + OPEN(UNIT=IO_SB,FILE=FLIST(IO_SB),STATUS='unknown') ! subband energies + END IF ! + END IF ! + IF(I_ES == 1) THEN ! + IO_ES=FN(ESFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_ES) == 0) THEN ! + OPEN(UNIT=IO_ES,FILE=FLIST(IO_ES),STATUS='unknown') ! Eliashberg function + END IF ! + END IF ! + IF(I_GR == 1) THEN ! + IO_GR=FN(GRFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_GR) == 0) THEN ! + OPEN(UNIT=IO_GR,FILE=FLIST(IO_GR),STATUS='unknown') ! Grüneisen parameter + END IF ! + END IF ! + IF(I_FD == 1) THEN ! + IO_FD=FN(FDFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_FD) == 0) THEN ! + OPEN(UNIT=IO_FD,FILE=FLIST(IO_FD),STATUS='unknown') ! Fermi-Dirac distribution + END IF ! + END IF ! + IF(I_BE == 1) THEN ! + IO_BE=FN(BEFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_BE) == 0) THEN ! + OPEN(UNIT=IO_BE,FILE=FLIST(IO_BE),STATUS='unknown') ! Bose-Einstein distribution + END IF ! + END IF ! + IF(I_MX == 1) THEN ! + IO_MX=FN(MXFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_MX) == 0) THEN ! + OPEN(UNIT=IO_MX,FILE=FLIST(IO_MX),STATUS='unknown') ! Maxwell distribution + END IF ! + END IF ! + IF(I_SC == 1) THEN ! + IO_SC=FN(SCFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_SC) == 0) THEN ! + OPEN(UNIT=IO_SC,FILE=FLIST(IO_SC),STATUS='unknown') ! scale parameters + END IF ! + END IF ! + IF(I_DS == 1) THEN ! + IO_DS=FN(DSFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_DS) == 0) THEN ! + OPEN(UNIT=IO_DS,FILE=FLIST(IO_DS),STATUS='unknown') ! density of states + END IF ! + END IF ! + IF(I_NV == 1) THEN ! + IO_NV=FN(NVFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_NV) == 0) THEN ! + OPEN(UNIT=IO_NV,FILE=FLIST(IO_NV),STATUS='unknown') ! Nevanlinaa function + END IF ! + END IF ! + IF(I_MT == 1) THEN ! + IO_MT=FN(MTFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_MT) == 0) THEN ! + OPEN(UNIT=IO_MT,FILE=FLIST(IO_MT),STATUS='unknown') ! time domain memory function + END IF ! + END IF ! +! +! Files for calculator 4 +! + IF(I_GP == 1) THEN ! + IO_GP=FN(GPFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_GP) == 0) THEN ! + OPEN(UNIT=IO_GP,FILE=FLIST(IO_GP),STATUS='unknown') ! grand partition function + END IF ! + END IF ! + IF(I_PR == 1) THEN ! + IO_PR=FN(PRFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_PR) == 0) THEN ! + OPEN(UNIT=IO_PR,FILE=FLIST(IO_PR),STATUS='unknown') ! electronic pressure + END IF ! + END IF ! + IF(I_CO == 1) THEN ! + IO_CO=FN(COFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_CO) == 0) THEN ! + OPEN(UNIT=IO_CO,FILE=FLIST(IO_CO),STATUS='unknown') ! compressibility + END IF ! + END IF ! + IF(I_CP == 1) THEN ! + IO_CP=FN(CPFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_CP) == 0) THEN ! + OPEN(UNIT=IO_CP,FILE=FLIST(IO_CP),STATUS='unknown') ! chemical potential + END IF ! + END IF ! + IF(I_BM == 1) THEN ! + IO_BM=FN(BMFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_BM) == 0) THEN ! + OPEN(UNIT=IO_BM,FILE=FLIST(IO_BM),STATUS='unknown') ! bulk modulus + END IF ! + END IF ! + IF(I_SH == 1) THEN ! + IO_SH=FN(SHFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_SH) == 0) THEN ! + OPEN(UNIT=IO_SH,FILE=FLIST(IO_SH),STATUS='unknown') ! shear modulus + END IF ! + END IF ! + IF(I_S0 == 1) THEN ! + IO_S0=FN(S0FILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_S0) == 0) THEN ! + OPEN(UNIT=IO_S0,FILE=FLIST(IO_S0),STATUS='unknown') ! zero sound velocity + END IF ! + END IF ! + IF(I_S1 == 1) THEN ! + IO_S1=FN(S1FILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_S1) == 0) THEN ! + OPEN(UNIT=IO_S1,FILE=FLIST(IO_S1),STATUS='unknown') ! first sound velocity + END IF ! + END IF ! + IF(I_DT == 1) THEN ! + IO_DT=FN(DTFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_DT) == 0) THEN ! + OPEN(UNIT=IO_DT,FILE=FLIST(IO_DT),STATUS='unknown') ! Debye temperature + END IF ! + END IF ! + IF(I_PS == 1) THEN ! + IO_PS=FN(PSFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_PS) == 0) THEN ! + OPEN(UNIT=IO_PS,FILE=FLIST(IO_PS),STATUS='unknown') ! Pauli paramagnetic susceptibility + END IF ! + END IF ! + IF(I_IE == 1) THEN ! + IO_IE=FN(IEFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_IE) == 0) THEN ! + OPEN(UNIT=IO_IE,FILE=FLIST(IO_IE),STATUS='unknown') ! internal energy + END IF ! + END IF ! + IF(I_EI == 1) THEN ! + IO_EI=FN(EIFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_EI) == 0) THEN ! + OPEN(UNIT=IO_EI,FILE=FLIST(IO_EI),STATUS='unknown') ! excess internal energy + END IF ! + END IF ! + IF(I_FH == 1) THEN ! + IO_FH=FN(FHFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_FH) == 0) THEN ! + OPEN(UNIT=IO_FH,FILE=FLIST(IO_FH),STATUS='unknown') ! Helmholtz free energy + END IF ! + END IF ! + IF(I_EY == 1) THEN ! + IO_EY=FN(EYFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_EY) == 0) THEN ! + OPEN(UNIT=IO_EY,FILE=FLIST(IO_EY),STATUS='unknown') ! entropy + END IF ! + END IF ! +! +! Files for calculator 5 +! + IF(I_EF == 1) THEN ! + IO_EF=FN(EFFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_EF) == 0) THEN ! + OPEN(UNIT=IO_EF,FILE=FLIST(IO_EF),STATUS='unknown') ! Fermi energy + END IF ! + END IF ! + IF(I_KF == 1) THEN ! + IO_KF=FN(KFFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_KF) == 0) THEN ! + OPEN(UNIT=IO_KF,FILE=FLIST(IO_KF),STATUS='unknown') ! Fermi momentum + END IF ! + END IF ! + IF(I_VF == 1) THEN ! + IO_VF=FN(VFFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_VF) == 0) THEN ! + OPEN(UNIT=IO_VF,FILE=FLIST(IO_VF),STATUS='unknown') ! Fermi velocity + END IF ! + END IF ! + IF(I_TE == 1) THEN ! + IO_TE=FN(TEFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_TE) == 0) THEN ! + OPEN(UNIT=IO_TE,FILE=FLIST(IO_TE),STATUS='unknown') ! Fermi temperature + END IF ! + END IF ! + IF(I_DL == 1) THEN ! + IO_DL=FN(DLFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_DL) == 0) THEN ! + OPEN(UNIT=IO_DL,FILE=FLIST(IO_DL),STATUS='unknown') ! Fermi density of states + END IF ! + END IF ! +! +! Files for calculator 6 +! + IF(I_TW == 1) THEN ! + IO_TW=FN(TWFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_TW) == 0) THEN ! + OPEN(UNIT=IO_TW,FILE=FLIST(IO_TW),STATUS='unknown') ! thermal De Broglie wavelength + END IF ! + END IF ! + IF(I_VT == 1) THEN ! + IO_VT=FN(VTFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_VT) == 0) THEN ! + OPEN(UNIT=IO_VT,FILE=FLIST(IO_VT),STATUS='unknown') ! thermal velocity + END IF ! + END IF ! + IF(I_TC == 1) THEN ! + IO_TC=FN(TCFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_TC) == 0) THEN ! + OPEN(UNIT=IO_TC,FILE=FLIST(IO_TC),STATUS='unknown') ! thermal conductivity + END IF ! + END IF ! +! +! Files for calculator 7 +! + IF(I_EG == 1) THEN ! + IO_EG=FN(EGFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_EG) == 0) THEN ! + OPEN(UNIT=IO_EG,FILE=FLIST(IO_EG),STATUS='unknown') ! ground state energy + END IF ! + END IF ! + IF(I_EX == 1) THEN ! + IO_EX=FN(EXFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_EX) == 0) THEN ! + OPEN(UNIT=IO_EX,FILE=FLIST(IO_EX),STATUS='unknown') ! exchange energy + END IF ! + END IF ! + IF(I_XC == 1) THEN ! + IO_XC=FN(XCFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_XC) == 0) THEN ! + OPEN(UNIT=IO_XC,FILE=FLIST(IO_XC),STATUS='unknown') ! exchange correlation energy + END IF ! + END IF ! + IF(I_EC == 1) THEN ! + IO_EC=FN(ECFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_EC) == 0) THEN ! + OPEN(UNIT=IO_EC,FILE=FLIST(IO_EC),STATUS='unknown') ! correlation energy + END IF ! + END IF ! + IF(I_HF == 1) THEN ! + IO_HF=FN(HFFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_HF) == 0) THEN ! + OPEN(UNIT=IO_HF,FILE=FLIST(IO_HF),STATUS='unknown') ! Hartree-Fock energy + END IF ! + END IF ! + IF(I_EK == 1) THEN ! + IO_EK=FN(EKFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_EK) == 0) THEN ! + OPEN(UNIT=IO_EK,FILE=FLIST(IO_EK),STATUS='unknown') ! kinetic energy + END IF ! + END IF ! + IF(I_EP == 1) THEN ! + IO_EP=FN(EPFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_EP) == 0) THEN ! + OPEN(UNIT=IO_EP,FILE=FLIST(IO_EP),STATUS='unknown') ! potential energy + END IF ! + END IF ! +! +! Files for calculator 8 +! + IF(I_VI == 1) THEN ! + IO_VI=FN(VIFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_VI) == 0) THEN ! + OPEN(UNIT=IO_VI,FILE=FLIST(IO_VI),STATUS='unknown') ! shear viscosity + END IF ! + END IF ! + IF(I_DI == 1) THEN ! + IO_DI=FN(DIFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_DI) == 0) THEN ! + OPEN(UNIT=IO_DI,FILE=FLIST(IO_DI),STATUS='unknown') ! diffusion coefficient + END IF ! + END IF ! +! +! Files for calculator 9 +! + IF(I_FP == 1) THEN ! + IO_FP=FN(FPFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_FP) == 0) THEN ! + OPEN(UNIT=IO_FP,FILE=FLIST(IO_FP),STATUS='unknown') ! fluctuation potential file + END IF ! + END IF ! + IF(I_EL == 1) THEN ! + IO_EL=FN(ELFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_EL) == 0) THEN ! + OPEN(UNIT=IO_EL,FILE=FLIST(IO_EL),STATUS='unknown') ! energy loss function + END IF ! + END IF ! + IF(I_PO == 1) THEN ! + IO_PO=FN(POFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_PO) == 0) THEN ! + OPEN(UNIT=IO_PO,FILE=FLIST(IO_PO),STATUS='unknown') ! stopping power + END IF ! + END IF ! + IF(I_RF == 1) THEN ! + IO_RF=FN(RFFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_RF) == 0) THEN ! + OPEN(UNIT=IO_RF,FILE=FLIST(IO_RF),STATUS='unknown') ! refractive index + END IF ! + END IF ! + IF(I_VC == 1) THEN ! + IO_VC=FN(VCFILE) ! + IF(JF == 1 .OR. INDEX_FILE(IO_VC) == 0) THEN ! + OPEN(UNIT=IO_VC,FILE=FLIST(IO_VC),STATUS='unknown') ! dynamic screened Coulomb potential V(q,omega) + END IF ! + END IF ! +! + END SUBROUTINE OPEN_OUTPUT_FILES +! +END MODULE OPEN_OUTFILES diff --git a/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/outfiles.f90 b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/outfiles.f90 new file mode 100644 index 0000000..063f149 --- /dev/null +++ b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/outfiles.f90 @@ -0,0 +1,549 @@ +! +!======================================================================= +! +MODULE OUTFILES +! +! This module contains functions/subroutines for working with +! the output files +! +CONTAINS +! +! +!======================================================================= +! + FUNCTION FN(NAFILE) +! +! This function returns the Fortran unit corresponding to file NAFILE +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : NOFFN +! + IMPLICIT NONE +! + CHARACTER (LEN = 100) :: NAFILE + CHARACTER (LEN = 100) :: FLIST(NOFFN) +! + INTEGER :: FN,J +! + CALL OUT_FILES(FLIST) ! +! + DO J=7,NOFFN ! + IF(FLIST(J) == NAFILE) THEN ! + FN=J ! + RETURN ! + END IF ! + END DO ! +! + END FUNCTION FN +! +!======================================================================= +! + SUBROUTINE OUT_FILES(FLIST) +! +! This subroutine stores all the output files and their Fortran +! unit number in the FLIST array +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Jan 2021 +! +! + USE DIMENSION_CODE, ONLY : NOFFN + USE FILENAMES +! + IMPLICIT NONE +! + CHARACTER (LEN = 100) :: FLIST(NOFFN) +! +! Filenames: +! + DFFILE='Results/diel_func.dat' ! dielectric function file + PZFILE='Results/pola_func.dat' ! polarization function + SUFILE='Results/susc_func.dat' ! susceptibility function + CDFILE='Results/cond_func.dat' ! electrical conductivity +! + PDFILE='Results/plas_disp.dat' ! plasmon dispersion file + EHFILE='Results/elec_hole.dat' ! electron-hole dispersion file + E2FILE='Results/elec_hol2.dat' ! two electron-hole dispersion + CKFILE='Results/int_pot_k.dat' ! interaction potential (k-space) + CRFILE='Results/int_pot_r.dat' ! interaction potential (real space) + PKFILE='Results/plas_kine.dat' ! plasmon kinetic energy file +! + LFFILE='Results/loca_fiel.dat' ! local-field correction file G(q,om) + IQFILE='Results/ginf_fiel.dat' ! G(q,inf) file + SFFILE='Results/stru_fact.dat' ! structure factor file S(q,om) + PCFILE='Results/pair_corr.dat' ! pair correlation function file + P2FILE='Results/pair_dist.dat' ! pair distribution function file + VXFILE='Results/vertex_fu.dat' ! vertex function Gamma(q,om) + DCFILE='Results/plas_damp.dat' ! plasmon damping coefficient Im[eps]/q^2 + MDFILE='Results/mome_dist.dat' ! momentum distribution + LDFILE='Results/landau_pa.dat' ! Landau parameters + DPFILE='Results/damp_file.dat' ! damping file + LTFILE='Results/life_time.dat' ! plasmon lifetime file + BRFILE='Results/broadenin.dat' ! plasmon broadening + PEFILE='Results/plas_ener.dat' ! plasmon energy + QCFILE='Results/qc_bounds.dat' ! plasmon q-bounds + RLFILE='Results/rela_time.dat' ! relaxation time + KSFILE='Results/screen_wv.dat' ! screening wave vector + OQFILE='Results/omega_qvf.dat' ! omega = q * v_F file + MEFILE='Results/moments_e.dat' ! moments of epsilon + MSFILE='Results/moments_s.dat' ! moments of S(q,omega) + MLFILE='Results/moments_l.dat' ! moments of loss function + MCFILE='Results/moments_c.dat' ! moments of conductivity + DEFILE='Results/deri_epsi.dat' ! derivative of Re[ dielectric function ] + ZEFILE='Results/ree0_file.dat' ! Re[ dielectric function ] = 0 + SRFILE='Results/sum_rules.dat' ! sum rules for epsilon + CWFILE='Results/confin_wf.dat' ! confinement wave function + CFFILE='Results/confin_pt.dat' ! confinement potential + EMFILE='Results/effe_mass.dat' ! effective mass + MFFILE='Results/mean_path.dat' ! mean free path + SPFILE='Results/spec_func.dat' ! spectral function + SEFILE='Results/self_ener.dat' ! self-energy + SBFILE='Results/subb_ener.dat' ! subband energies + ESFILE='Results/elia_func.dat' ! Eliashberg function + GRFILE='Results/grune_par.dat' ! Grüneisen parameter + FDFILE='Results/fermi_dir.dat' ! Fermi-Dirac distribution + BEFILE='Results/bose_eins.dat' ! Bose-Einstein distribution + MXFILE='Results/maxwell_d.dat' ! Maxwell distribution + SCFILE='Results/scale_par.dat' ! scale parameters + DSFILE='Results/dens_stat.dat' ! density of states + NVFILE='Results/neva_four.dat' ! Nevanlinaa/memory function + MTFILE='Results/memo_time.dat' ! time domain memory function +! + GPFILE='Results/gran_part.dat' ! grand partition function + PRFILE='Results/epressure.dat' ! electronic pressure + COFILE='Results/comp_file.dat' ! compressibility + CPFILE='Results/chem_pote.dat' ! chemical potential + BMFILE='Results/bulk_modu.dat' ! bulk modulus + SHFILE='Results/shear_mod.dat' ! shear modulus + S0FILE='Results/zero_soun.dat' ! zero sound velocity + S1FILE='Results/firs_soun.dat' ! first sound velocity + DTFILE='Results/Debye_tmp.dat' ! Debye temperature + PSFILE='Results/para_susc.dat' ! Pauli paramagnetic susceptibility + IEFILE='Results/inter_ene.dat' ! internal energy + EIFILE='Results/exces_ene.dat' ! excess internal energy + FHFILE='Results/helm_free.dat' ! Helmholtz free energy + EYFILE='Results/entropy_f.dat' ! entropy +! + EFFILE='Results/fermi_ene.dat' ! Fermi energy + KFFILE='Results/fermi_vec.dat' ! Fermi momentum + VFFILE='Results/fermi_vel.dat' ! Fermi velocity + TEFILE='Results/fermi_tmp.dat' ! Fermi temperature + DLFILE='Results/fermi_dos.dat' ! Fermi density of states +! + TWFILE='Results/thermal_w.dat' ! thermal De Broglie wavelength + VTFILE='Results/thermal_v.dat' ! thermal velocity + TCFILE='Results/thermal_c.dat' ! thermal conductivity +! + EGFILE='Results/ground_st.dat' ! ground state energy + EXFILE='Results/ex_energy.dat' ! exchange energy + XCFILE='Results/xc_energy.dat' ! exchange correlation energy + ECFILE='Results/corr_ener.dat' ! correlation energy + HFFILE='Results/hf_energy.dat' ! Hartree-Fock energy + EKFILE='Results/kine_ener.dat' ! kinetic energy + EPFILE='Results/pote_ener.dat' ! potential energy +! + VIFILE='Results/visc_coef.dat' ! shear viscosity + DIFILE='Results/diff_coef.dat' ! diffusion coefficient +! + FPFILE='Results/fluct_pot.dat' ! fluctuation potential file + ELFILE='Results/ener_loss.dat' ! energy loss function + POFILE='Results/stop_powe.dat' ! stopping power + RFFILE='Results/refrac_in.dat' ! refractive index + VCFILE='Results/dyna_coul.dat' ! dynamic screened Coulomb potential V(q,omega) +! +! Corresponding fortran units +! + FLIST(7)=DFFILE ! + FLIST(8)=PZFILE ! + FLIST(9)=SUFILE ! + FLIST(10)=CDFILE ! +! + FLIST(11)=PDFILE ! + FLIST(12)=EHFILE ! + FLIST(13)=E2FILE ! + FLIST(14)=CKFILE ! + FLIST(15)=CRFILE ! + FLIST(16)=PKFILE ! +! + FLIST(17)=LFFILE ! + FLIST(18)=IQFILE ! + FLIST(19)=SFFILE ! + FLIST(20)=PCFILE ! + FLIST(21)=P2FILE ! + FLIST(22)=VXFILE ! + FLIST(23)=DCFILE ! + FLIST(24)=MDFILE ! + FLIST(25)=LDFILE ! + FLIST(26)=DPFILE ! + FLIST(27)=LTFILE ! + FLIST(28)=BRFILE ! + FLIST(29)=PEFILE ! + FLIST(30)=QCFILE ! + FLIST(31)=RLFILE ! + FLIST(32)=KSFILE ! + FLIST(33)=OQFILE ! + FLIST(34)=MEFILE ! + FLIST(35)=MSFILE ! + FLIST(36)=MLFILE ! + FLIST(37)=MCFILE ! + FLIST(38)=DEFILE ! + FLIST(39)=ZEFILE ! + FLIST(40)=SRFILE ! + FLIST(41)=CWFILE ! + FLIST(42)=CFFILE ! + FLIST(43)=EMFILE ! + FLIST(44)=MFFILE ! + FLIST(45)=SPFILE ! + FLIST(46)=SEFILE ! + FLIST(47)=SBFILE ! + FLIST(48)=ESFILE ! + FLIST(49)=GRFILE ! + FLIST(50)=FDFILE ! + FLIST(51)=BEFILE ! + FLIST(52)=MXFILE ! + FLIST(53)=SCFILE ! + FLIST(54)=DSFILE ! + FLIST(55)=NVFILE ! + FLIST(56)=MTFILE ! +! + FLIST(57)=GPFILE ! + FLIST(58)=PRFILE ! + FLIST(59)=COFILE ! + FLIST(60)=CPFILE ! + FLIST(61)=BMFILE ! + FLIST(62)=SHFILE ! + FLIST(63)=S0FILE ! + FLIST(64)=S1FILE ! + FLIST(65)=DTFILE ! + FLIST(66)=PSFILE ! + FLIST(67)=IEFILE ! + FLIST(68)=EIFILE ! + FLIST(69)=FHFILE ! + FLIST(70)=EYFILE ! +! + FLIST(71)=EFFILE ! + FLIST(72)=KFFILE ! + FLIST(73)=VFFILE ! + FLIST(74)=TEFILE ! + FLIST(75)=DLFILE ! +! + FLIST(76)=TWFILE ! + FLIST(77)=VTFILE ! + FLIST(78)=TCFILE ! +! + FLIST(79)=EGFILE ! + FLIST(80)=EXFILE ! + FLIST(81)=XCFILE ! + FLIST(82)=ECFILE ! + FLIST(83)=HFFILE ! + FLIST(84)=EKFILE ! + FLIST(85)=EPFILE ! +! + FLIST(86)=VIFILE ! + FLIST(87)=DIFILE ! +! + FLIST(88)=FPFILE ! + FLIST(89)=ELFILE ! + FLIST(90)=POFILE ! + FLIST(91)=RFFILE ! + FLIST(92)=VCFILE ! +! + END SUBROUTINE OUT_FILES +! +!======================================================================= +! + SUBROUTINE CALC_TYPE(CLIST) +! +! This subroutine stores the calculation approximations +! into the CLIST array +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Jan 2021 +! +! + USE DIMENSION_CODE, ONLY : NOFFN +! + USE MATERIAL_PROP + USE EXT_FIELDS + USE CONFIN_VAL + USE MULTILAYER + USE SCREENING_TYPE + USE PLASMA + USE DF_VALUES + USE PLASMON_DISPERSION + USE LF_VALUES + USE DAMPING_VALUES + USE EL_ELE_INTER + USE EL_PHO_INTER + USE EL_IMP_INTER + USE CLASSICAL_FLUID_VALUES + USE SF_VALUES + USE PC_VALUES + USE PD_VALUES + USE ENERGIES + USE THERMO_PROPERTIES + USE ION_BEAM +! + IMPLICIT NONE +! + CHARACTER (LEN = 100) :: CLIST(NOFFN) + CHARACTER (LEN = 100) :: NONE + CHARACTER (LEN = 100) :: LFTYPE + CHARACTER (LEN = 100) :: SFTYPE +! + IF(GSTDY == ' STATIC') THEN ! + LFTYPE = GQ_TYPE ! + ELSE ! + LFTYPE = GQO_TYPE ! + END IF ! + IF(SSTDY == ' STATIC') THEN ! + SFTYPE = SQ_TYPE ! + ELSE ! + SFTYPE = SQO_TYPE ! + END IF ! +! + NONE = '' ! +! + CLIST(7) = D_FUNC ! + CLIST(8) = D_FUNC ! + CLIST(9) = D_FUNC ! + CLIST(10) = D_FUNC ! +! + CLIST(11) = PL_DISP ! + CLIST(12) = NONE ! + CLIST(13) = NONE ! + CLIST(14) = SC_TYPE ! + CLIST(15) = NONE ! + CLIST(16) = NONE ! +! + CLIST(17) = LFTYPE ! + CLIST(18) = IQ_TYPE ! + CLIST(19) = SFTYPE ! + CLIST(20) = GR_TYPE ! + CLIST(21) = RH_TYPE ! + CLIST(22) = D_FUNC ! + CLIST(23) = D_FUNC ! + CLIST(24) = NONE ! + CLIST(25) = LANDAU ! + CLIST(26) = DAMPING ! + CLIST(27) = LT_TYPE ! + CLIST(28) = NONE ! + CLIST(29) = D_FUNC ! + CLIST(30) = D_FUNC ! + CLIST(31) = RT_TYPE ! + CLIST(32) = SC_TYPE ! + CLIST(33) = NONE ! + CLIST(34) = D_FUNC ! + CLIST(35) = SFTYPE ! + CLIST(36) = D_FUNC ! + CLIST(37) = D_FUNC ! + CLIST(38) = D_FUNC ! + CLIST(39) = D_FUNC ! + CLIST(40) = D_FUNC ! + CLIST(41) = CONFIN ! + CLIST(42) = CONFIN ! + CLIST(43) = NONE ! + CLIST(44) = NONE ! + CLIST(45) = D_FUNC ! + CLIST(46) = D_FUNC ! + CLIST(47) = CONFIN ! + CLIST(48) = NONE ! + CLIST(49) = NONE ! + CLIST(50) = NONE ! + CLIST(51) = NONE ! + CLIST(52) = NONE ! + CLIST(53) = NONE ! + CLIST(54) = NONE ! + CLIST(55) = NEV_TYPE ! + CLIST(56) = MEM_TYPE ! +! + CLIST(57) = GP_TYPE ! + CLIST(58) = TH_PROP ! + CLIST(59) = TH_PROP ! + CLIST(60) = TH_PROP ! + CLIST(61) = TH_PROP ! + CLIST(62) = TH_PROP ! + CLIST(63) = TH_PROP ! + CLIST(64) = TH_PROP ! + CLIST(65) = TH_PROP ! + CLIST(66) = TH_PROP ! + CLIST(67) = TH_PROP ! + CLIST(68) = TH_PROP ! + CLIST(60) = TH_PROP ! + CLIST(70) = TH_PROP ! +! + CLIST(71) = NONE ! + CLIST(72) = NONE ! + CLIST(73) = NONE ! + CLIST(74) = NONE ! + CLIST(75) = NONE ! +! + CLIST(76) = NONE ! + CLIST(77) = NONE ! + CLIST(78) = NONE ! +! + CLIST(79) = NONE ! + CLIST(80) = NONE ! + CLIST(81) = EXC_TYPE ! + CLIST(82) = EC_TYPE ! + CLIST(83) = NONE ! + CLIST(84) = NONE ! + CLIST(85) = NONE ! +! + CLIST(86) = VI_TYPE ! + CLIST(87) = DC_TYPE ! +! + CLIST(88) = D_FUNC ! + CLIST(89) = D_FUNC ! + CLIST(90) = D_FUNC ! + CLIST(91) = D_FUNC ! + CLIST(92) = D_FUNC ! +! + END SUBROUTINE CALC_TYPE +! +!======================================================================= +! + FUNCTION INDEX_FILE(I_UNIT) +! +! This function associates each Fortran unit to an index (0/1) +! which determines whether the file has to indexed by the +! input data file number (0) or not (1), when looping +! over these input data files. In practice: +! +! * Files depending on q, omega, r have to be indexed +! * files depending on r_s, T must not be indexed +! +! For instance, if we want to compute the correlation energy +! as a function of r_s, we will loop on the input data files +! with different r_s, but all results have to be written +! into the same output file 'Results/corr_ener.dat' +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Jan 2021 +! +! + USE DIMENSION_CODE, ONLY : NOFFN +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: I_UNIT + INTEGER :: INDEX_FILE + INTEGER :: ID(NOFFN) +! + DATA ID( 1) / 0 / ! \ + DATA ID( 2) / 0 / ! \ + DATA ID( 3) / 0 / ! \>> Fortran units not used + DATA ID( 4) / 0 / ! />> for output files + DATA ID( 5) / 0 / ! / + DATA ID( 6) / 0 / ! / + DATA ID( 7) / 0 / ! dielectric function file + DATA ID( 8) / 0 / ! polarization function + DATA ID( 9) / 0 / ! susceptibility function + DATA ID(10) / 0 / ! electrical conductivity +! + DATA ID(11) / 0 / ! plasmon dispersion file + DATA ID(12) / 0 / ! electron-hole dispersion file + DATA ID(13) / 0 / ! two electron-hole dispersion + DATA ID(14) / 0 / ! screened Coulomb (k-space) + DATA ID(15) / 0 / ! screened Coulomb (real space) + DATA ID(16) / 0 / ! plasmon kinetic energy +! + DATA ID(17) / 0 / ! local-field correction file G(q,om) + DATA ID(18) / 0 / ! G(q,inf) file + DATA ID(19) / 0 / ! structure factor file S(q,om) + DATA ID(20) / 0 / ! pair correlation function file + DATA ID(21) / 0 / ! pair distribution function file + DATA ID(22) / 0 / ! vertex function Gamma(q,om) + DATA ID(23) / 0 / ! plasmon damping coefficient Im[eps]/q^2 + DATA ID(24) / 0 / ! momentum distribution + DATA ID(25) / 0 / ! Landau parameters + DATA ID(26) / 0 / ! damping file + DATA ID(27) / 0 / ! plasmon lifetime file + DATA ID(28) / 0 / ! plasmon broadening + DATA ID(29) / 0 / ! plasmon energy + DATA ID(30) / 0 / ! plasmon q-bounds + DATA ID(31) / 0 / ! relaxation time + DATA ID(32) / 0 / ! screening wave vector + DATA ID(33) / 0 / ! Debye wave vector + DATA ID(34) / 0 / ! moments of epsilon + DATA ID(35) / 0 / ! moments of S(q,omega) + DATA ID(36) / 0 / ! moments of loss function + DATA ID(37) / 0 / ! moments of conductivity + DATA ID(38) / 0 / ! derivative of Re[ dielectric function ] + DATA ID(39) / 0 / ! Re[ dielectric function ] = 0 + DATA ID(40) / 0 / ! sum rules for epsilon + DATA ID(41) / 0 / ! confinement wave function + DATA ID(42) / 0 / ! confinement potential + DATA ID(43) / 0 / ! effective mass + DATA ID(44) / 0 / ! mean free path + DATA ID(45) / 0 / ! spectral function + DATA ID(46) / 0 / ! self-energy + DATA ID(47) / 1 / ! subband energies + DATA ID(48) / 0 / ! Eliashberg function + DATA ID(49) / 0 / ! Grüneisen parameter + DATA ID(50) / 0 / ! Fermi-Dirac distribution + DATA ID(51) / 0 / ! Bose-Einstein distribution + DATA ID(52) / 0 / ! Maxwell distribution + DATA ID(53) / 1 / ! scale parameters + DATA ID(54) / 0 / ! density of states + DATA ID(55) / 0 / ! Nevanlinaa function + DATA ID(56) / 0 / ! memory function +! + DATA ID(57) / 1 / ! grand partition function + DATA ID(58) / 1 / ! electronic pressure + DATA ID(59) / 1 / ! compressibility + DATA ID(60) / 1 / ! chemical potential + DATA ID(61) / 1 / ! bulk modulus + DATA ID(62) / 1 / ! shear modulus + DATA ID(63) / 1 / ! zero sound velocity + DATA ID(64) / 1 / ! first sound velocity + DATA ID(65) / 1 / ! Debye temperature + DATA ID(66) / 1 / ! Pauli paramagnetic susceptibility + DATA ID(67) / 1 / ! internal energy + DATA ID(68) / 1 / ! excess internal energy + DATA ID(69) / 1 / ! Helmholtz free energy + DATA ID(70) / 1 / ! entropy +! + DATA ID(71) / 1 / ! Fermi energy + DATA ID(72) / 1 / ! Fermi momentum + DATA ID(73) / 1 / ! Fermi velocity + DATA ID(74) / 1 / ! Fermi temperature + DATA ID(75) / 1 / ! Fermi density of states +! + DATA ID(76) / 1 / ! thermal De Broglie wavelength + DATA ID(77) / 1 / ! thermal velocity + DATA ID(78) / 1 / ! thermal conductivity +! + DATA ID(79) / 1 / ! ground state energy + DATA ID(80) / 1 / ! exchange energy + DATA ID(81) / 1 / ! exchange correlation energy + DATA ID(82) / 1 / ! correlation energy + DATA ID(83) / 1 / ! Hartree-Fock energy + DATA ID(84) / 1 / ! kinetic energy + DATA ID(85) / 1 / ! potential energy +! + DATA ID(86) / 1 / ! shear viscosity + DATA ID(87) / 1 / ! diffusion coefficient +! + DATA ID(88) / 0 / ! fluctuation potential file + DATA ID(89) / 0 / ! energy loss function + DATA ID(90) / 0 / ! stopping power + DATA ID(91) / 0 / ! refractive index + DATA ID(92) / 0 / ! dynamic screened Coulomb potential V(q,omega) +! + INDEX_FILE = ID(I_UNIT) ! +! + END FUNCTION INDEX_FILE +! +END MODULE OUTFILES diff --git a/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/read_data.f90 b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/read_data.f90 new file mode 100644 index 0000000..af6fd29 --- /dev/null +++ b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/read_data.f90 @@ -0,0 +1,859 @@ +! +!======================================================================= +! +MODULE INPUT_DATA +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE READ_DATA +! +! This subroutine reads the input data file of the epsilon.f90 code, +! and either stores them into modules or pass them as arguments +! +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Aug 2021 +! +! Modules storing the data +! + USE MATERIAL_PROP + USE EXT_FIELDS + USE Q_GRID + USE E_GRID + USE R_GRID + USE CONFIN_VAL + USE MULTILAYER + USE UNITS + USE SCREENING_TYPE + USE PLASMA + USE CALCTYPE + USE DF_VALUES + USE PLASMON_DISPERSION + USE LF_VALUES + USE DAMPING_VALUES + USE EL_ELE_INTER + USE EL_PHO_INTER + USE EL_IMP_INTER + USE CLASSICAL_FLUID_VALUES + USE SF_VALUES + USE PC_VALUES + USE PD_VALUES + USE SPF_VALUES + USE ENERGIES + USE SPIN_POLARIZATION + USE THERMO_PROPERTIES + USE ELECTRON_MEAN_FREE_PATH + USE MOMENTS + USE ION_BEAM +! + USE OUT_VALUES_1 + USE OUT_VALUES_2 + USE OUT_VALUES_3 + USE OUT_VALUES_4 + USE OUT_VALUES_5 + USE OUT_VALUES_6 + USE OUT_VALUES_7 + USE OUT_VALUES_8 + USE OUT_VALUES_9 + USE OUT_VALUES_10 + USE OUT_VALUES_P +! + USE OUT_CALC +! + IMPLICIT NONE +! + INTEGER :: N_HEAD,N_SEP,N_INT + INTEGER :: I +! + CHARACTER (LEN = 8) :: DUMMY +! +! Separation blocks to skip when reading +! + N_HEAD=8 ! + N_SEP=3 ! + N_INT=1 ! +! +! Reading the input data file +! + DO I=1,N_HEAD ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,10) Q_MIN,Q_MAX,N_Q ! + READ(5,11) E_MIN,E_MAX,N_E ! + READ(5,12) R_MIN,R_MAX,N_R ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,13) RS,MSOM,MAT_TYP,EPS_B ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,14) T,E,H,FLD ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,15) DMN ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,16) R0,L,OM0,CONFIN ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,17) DL,D1,N_DEP,N_INV ! + READ(5,18) H_TYPE,EPS_1,EPS_2 ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,19) UNIT,UNIK ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,20) SC_TYPE ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,21) PL_TYPE,ZION,ZION2 ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,22) CAL_TYPE ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,23) ESTDY,EPS_T,D_FUNC,I_T ! + READ(5,24) NEV_TYPE,MEM_TYPE,ALPHA,BETA ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,25) PL_DISP ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,26) GSTDY,GQ_TYPE,IQ_TYPE ! + READ(5,27) LANDAU,GQO_TYPE,G0_TYPE,GI_TYPE ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,28) DAMPING,LT_TYPE,RT_TYPE ! + READ(5,29) DR_TYPE,DC_TYPE,VI_TYPE ! + READ(5,30) EE_TYPE,EP_TYPE,EI_TYPE ! + READ(5,31) IP_TYPE,PD_TYPE,QD_TYPE,ZETA ! + READ(5,32) D_VALUE_1,POWER_1,EK ! + READ(5,33) D_VALUE_2,POWER_2,PCT ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,34) INT_POT,S,EPS,DELTA ! + READ(5,35) RC,ALF,M,N ! + READ(5,36) A1,A2,A3,A4 ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,37) EP_C,DEBYE_T ! + READ(5,38) NA,MA,RA ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,39) NI,EI_C ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,40) CF_TYPE,PF_TYPE,SL_TYPE ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,41) SSTDY,SQ_TYPE,SQO_TYPE ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,42) GR_TYPE,GR0_MODE ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,43) RH_TYPE ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,44) SPF_TYPE ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,45) EC_TYPE,FXC_TYPE,EXC_TYPE ! + READ(5,46) EX_TYPE,EK_TYPE +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,47) IMODE,XI +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,48) TH_PROP,GP_TYPE ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,49) EK_INI,EK_FIN ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,50) N_M,M_TYPE ! +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,51) Z_BEAM,EK_BEAM ! +! +! Reading the print switches I_XX +! + DO I=1,N_SEP ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,201) I_DF,I_PZ,I_SU,I_CD ! +! + DO I=1,N_INT ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,202) I_PD,I_EH,I_E2,I_CK ! + READ(5,204) I_CR,I_PK ! +! + DO I=1,N_INT ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,205) I_LF,I_IQ,I_SF,I_PC ! + READ(5,206) I_P2,I_VX,I_DC,I_MD ! + READ(5,207) I_LD,I_DP,I_LT,I_BR ! + READ(5,208) I_PE,I_QC,I_RL,I_KS ! + READ(5,209) I_OQ,I_ME,I_MS,I_ML ! + READ(5,210) I_MC,I_DE,I_ZE,I_SR ! + READ(5,211) I_CW,I_CF,I_EM,I_MF ! + READ(5,212) I_SP,I_SE,I_SB,I_ES ! + READ(5,213) I_GR,I_FD,I_BE,I_MX ! + READ(5,214) I_SC,I_DS,I_NV,I_MT ! +! + DO I=1,N_INT ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,215) I_GP,I_PR,I_CO,I_CP ! + READ(5,216) I_BM,I_SH,I_S0,I_S1 ! + READ(5,217) I_DT,I_PS,I_IE,I_EI ! + READ(5,218) I_FH,I_EY ! +! + DO I=1,N_INT ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,219) I_EF,I_KF,I_VF,I_TE ! + READ(5,220) I_DL ! +! + DO I=1,N_INT ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,221) I_TW,I_VT,I_TC ! +! + DO I=1,N_INT ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,222) I_EG,I_EX,I_XC,I_EC ! + READ(5,223) I_HF,I_EK,I_EP ! +! + DO I=1,N_INT ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,224) I_VI,I_DI ! +! + DO I=1,N_INT ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,225) I_FP,I_EL,I_PO,I_RF ! + READ(5,226) I_VC ! +! + DO I=1,N_INT ! + READ(5,5) DUMMY ! + END DO ! +! + READ(5,227) I_FN,I_WR,I_TI ! +! +! Switches to call specific calculators +! + I_C1 = I_DF + I_PZ + I_SU + I_CD ! + I_C2 = I_PD + I_EH + I_E2 + I_CK + I_CR + I_PK ! + I_C3 = I_LF + I_IQ + I_SF + I_PC + I_P2 + I_VX + I_DC + & ! + I_MD + I_LD + I_DP + I_LT + I_BR + I_PE + I_QC + & ! + I_RL + I_KS + I_OQ + I_ME + I_MS + I_ML + I_MC + & ! + I_DE + I_ZE + I_SR + I_CW + I_CF + I_EM + I_MF + & ! + I_SP + I_SE + I_SB + I_ES + I_GR + I_FD + I_BE + & ! + I_MX + I_SC + I_DS + I_NV + I_MT ! + I_C4 = I_GP + I_PR + I_CO + I_CP + I_BM + I_SH + I_S0 + & ! + I_S1 + I_DT + I_PS + I_IE + I_EI + I_FH + I_EY ! + I_C5 = I_EF + I_KF + I_VF + I_TE + I_DL ! + I_C6 = I_TW + I_VT + I_TC ! + I_C7 = I_EG + I_EX + I_XC + I_EC + I_HF + I_EK + I_EP ! + I_C8 = I_VI + I_DI ! + I_C9 = I_EL + I_PO + I_RF + I_VC ! + I_PP = I_FP + I_PD ! +! +! Steps in q/k_F , (h_bar omega)/E_F and k_F*r +! + IF(N_Q == 1) THEN ! + Q_STEP = 1 ! + ELSE ! step in Q + Q_STEP = (Q_MAX - Q_MIN) / (FLOAT(N_Q-1)) ! + END IF ! +! + IF(N_E == 1) THEN ! + E_STEP = 1 ! + ELSE ! step in E + E_STEP = (E_MAX - E_MIN) / (FLOAT(N_E-1)) ! + END IF ! +! + IF(N_R == 1) THEN ! + R_STEP = 1 ! + ELSE ! step in R + R_STEP = (R_MAX - R_MIN) /(FLOAT(N_R-1)) ! + END IF ! +! +! Writing into the log file +! +! + WRITE(6,401) ! + WRITE(6,402) ! + WRITE(6,403) ! + WRITE(6,404) ! + WRITE(6,405) ! + WRITE(6,406) ! + WRITE(6,407) ! +! + WRITE(6,601) ! + WRITE(6,702) ! + WRITE(6,601) ! + WRITE(6,801) ! + WRITE(6,602) ! +! + WRITE(6,110) Q_MIN,Q_MAX,N_Q ! + WRITE(6,111) E_MIN,E_MAX,N_E ! + WRITE(6,112) R_MIN,R_MAX,N_R ! +! + WRITE(6,602) ! + WRITE(6,802) ! + WRITE(6,602) ! +! + WRITE(6,113) RS,MSOM,MAT_TYP,EPS_B ! +! + WRITE(6,602) ! + WRITE(6,803) ! + WRITE(6,602) ! +! + WRITE(6,114) T,E,H,FLD ! +! + WRITE(6,602) ! + WRITE(6,804) ! +! + WRITE(6,115) DMN ! +! + WRITE(6,602) ! + WRITE(6,805) ! + WRITE(6,602) ! +! + WRITE(6,116) R0,L,OM0,CONFIN ! +! + WRITE(6,602) ! + WRITE(6,806) ! + WRITE(6,602) ! +! + WRITE(6,117) DL,D1,N_DEP,N_INV ! + WRITE(6,118) H_TYPE,EPS_1,EPS_2 ! +! + WRITE(6,602) ! + WRITE(6,807) ! + WRITE(6,602) ! +! + WRITE(6,119) UNIT,UNIK ! +! + WRITE(6,602) ! + WRITE(6,808) ! + WRITE(6,602) ! +! + WRITE(6,120) SC_TYPE ! +! + WRITE(6,602) ! + WRITE(6,809) ! + WRITE(6,602) ! +! + WRITE(6,121) PL_TYPE,ZION,ZION2 ! +! + WRITE(6,602) ! + WRITE(6,810) ! + WRITE(6,602) ! +! + WRITE(6,122) CAL_TYPE +! + WRITE(6,601) ! + WRITE(6,703) ! + WRITE(6,601) ! +! + WRITE(6,123) ESTDY,EPS_T,D_FUNC,I_T ! +! + WRITE(6,124) NEV_TYPE,MEM_TYPE,ALPHA,BETA ! +! + WRITE(6,602) ! + WRITE(6,811) ! + WRITE(6,602) ! +! + WRITE(6,125) PL_DISP ! +! + WRITE(6,602) ! + WRITE(6,812) ! + WRITE(6,602) ! +! + WRITE(6,126) GSTDY,GQ_TYPE,IQ_TYPE ! + WRITE(6,127) LANDAU,GQO_TYPE,G0_TYPE,GI_TYPE ! +! + WRITE(6,602) ! + WRITE(6,813) ! + WRITE(6,602) ! +! + WRITE(6,128) DAMPING,LT_TYPE,RT_TYPE ! + WRITE(6,129) DR_TYPE,DC_TYPE,VI_TYPE ! + WRITE(6,130) EE_TYPE,EP_TYPE,EI_TYPE ! + WRITE(6,131) IP_TYPE,PD_TYPE,QD_TYPE,ZETA ! + WRITE(6,132) D_VALUE_1,POWER_1,EK ! + WRITE(6,133) D_VALUE_2,POWER_2,PCT ! +! + WRITE(6,602) ! + WRITE(6,814) ! + WRITE(6,602) ! +! + WRITE(6,134) INT_POT,S,EPS,DELTA ! + WRITE(6,135) RC,ALF,M,N ! + WRITE(6,136) A1,A2,A3,A4 ! +! + WRITE(6,602) ! + WRITE(6,815) ! + WRITE(6,602) ! +! + WRITE(6,137) EP_C,DEBYE_T ! + WRITE(6,138) NA,MA,RA ! +! + WRITE(6,602) ! + WRITE(6,816) ! + WRITE(6,602) ! +! + WRITE(6,139) NI,EI_C ! +! + WRITE(6,602) ! + WRITE(6,817) ! + WRITE(6,602) ! +! + WRITE(6,140) CF_TYPE,PF_TYPE,SL_TYPE ! +! + WRITE(6,601) ! + WRITE(6,704) ! + WRITE(6,601) ! +! + WRITE(6,141) SSTDY,SQ_TYPE,SQO_TYPE ! +! + WRITE(6,601) ! + WRITE(6,705) ! + WRITE(6,601) ! +! + WRITE(6,142) GR_TYPE,GR0_MODE ! +! + WRITE(6,601) ! + WRITE(6,706) ! + WRITE(6,601) ! +! + WRITE(6,143) RH_TYPE ! +! + WRITE(6,601) ! + WRITE(6,707) ! + WRITE(6,601) ! +! + WRITE(6,144) SPF_TYPE ! +! + WRITE(6,601) ! + WRITE(6,708) ! + WRITE(6,601) ! +! +! + WRITE(6,145) EC_TYPE,FXC_TYPE,EXC_TYPE ! + WRITE(6,146) EX_TYPE,EK_TYPE ! +! + WRITE(6,601) ! + WRITE(6,709) ! + WRITE(6,601) ! +! + WRITE(6,147) IMODE,XI +! + WRITE(6,601) ! + WRITE(6,710) ! + WRITE(6,601) ! +! + WRITE(6,148) TH_PROP,GP_TYPE ! +! + WRITE(6,601) ! + WRITE(6,711) ! + WRITE(6,601) ! +! + WRITE(6,149) EK_INI,EK_FIN ! +! + WRITE(6,601) ! + WRITE(6,712) ! + WRITE(6,601) ! +! + WRITE(6,150) N_M,M_TYPE ! +! + WRITE(6,601) ! + WRITE(6,713) ! + WRITE(6,601) ! +! + WRITE(6,151) Z_BEAM,EK_BEAM ! +! +! Writing the print switches +! + WRITE(6,601) ! + WRITE(6,714) ! + WRITE(6,601) ! +! + WRITE(6,301) I_DF,I_PZ,I_SU,I_CD ! +! + WRITE(6,602) ! +! + WRITE(6,302) I_PD,I_EH,I_E2,I_CK ! + WRITE(6,304) I_CR,I_PK ! +! + WRITE(6,602) ! +! + WRITE(6,305) I_LF,I_IQ,I_SF,I_PC ! + WRITE(6,306) I_P2,I_VX,I_DC,I_MD ! + WRITE(6,307) I_LD,I_DP,I_LT,I_BR ! + WRITE(6,308) I_PE,I_QC,I_RL,I_KS ! + WRITE(6,309) I_OQ,I_ME,I_MS,I_ML ! + WRITE(6,310) I_MC,I_DE,I_ZE,I_SR ! + WRITE(6,311) I_CW,I_CF,I_EM,I_MF ! + WRITE(6,312) I_SP,I_SE,I_SB,I_ES ! + WRITE(6,313) I_GR,I_FD,I_BE,I_MX ! + WRITE(6,314) I_SC,I_DS,I_NV,I_MT ! +! + WRITE(6,602) ! +! + WRITE(6,315) I_GP,I_PR,I_CO,I_CP ! + WRITE(6,316) I_BM,I_SH,I_S0,I_S1 ! + WRITE(6,317) I_DT,I_PS,I_IE,I_EI ! + WRITE(6,318) I_FH,I_EY ! +! + WRITE(6,602) ! +! + WRITE(6,319) I_EF,I_KF,I_VF,I_TE ! + WRITE(6,320) I_DL ! +! +! + WRITE(6,321) I_TW,I_VT,I_TC ! +! + WRITE(6,602) ! +! + WRITE(6,322) I_EG,I_EX,I_XC,I_EC ! + WRITE(6,323) I_HF,I_EK,I_EP ! +! + WRITE(6,602) ! +! + WRITE(6,324) I_VI,I_DI ! +! + WRITE(6,602) ! +! + WRITE(6,325) I_FP,I_EL,I_PO,I_RF ! + WRITE(6,326) I_VC ! +! + WRITE(6,602) ! +! + WRITE(6,327) I_FN,I_WR,I_TI ! +! + WRITE(6,601) ! +! + WRITE(6,500) ! + WRITE(6,500) ! + WRITE(6,407) ! +! +! Formats: Reading standard input data +! + 5 FORMAT(A8) +! + 10 FORMAT(6X,F7.3,3X,F7.3,2X,I5) + 11 FORMAT(6X,F7.3,3X,F7.3,2X,I5) + 12 FORMAT(6X,F7.3,3X,F7.3,2X,I5) + 13 FORMAT(6X,F7.3,3X,F7.3,2X,A5,4X,F9.3) + 14 FORMAT(3X,F10.3,3X,F7.3,3X,F7.3,5X,A2) + 15 FORMAT(8X,A2) + 16 FORMAT(6X,F7.3,3X,F7.3,3X,F6.2,1X,A7) + 17 FORMAT(6X,F7.3,3X,F7.3,3X,F7.3,3X,F7.3) + 18 FORMAT(6X,A4,4X,F9.3,1X,F9.3) + 19 FORMAT(7X,A3,8X,A2) + 20 FORMAT(8X,A2) + 21 FORMAT(7X,A3,6X,F7.3,3X,F7.3) + 22 FORMAT(3X,A7) + 23 FORMAT(3X,A7,6X,A4,6X,A4,9X,I1) + 24 FORMAT(6X,A4,6X,A4,8X,F5.3,5X,F5.3) + 25 FORMAT(3X,A7) + 26 FORMAT(3X,A7,6X,A4,7X,A3) + 27 FORMAT(6X,A4,6X,A4,8X,A2,8X,A2) + 28 FORMAT(6X,A4,6X,A4,7X,A3) + 29 FORMAT(6X,A4,6X,A4,6X,A4) + 30 FORMAT(6X,A4,6X,A4,6X,A4) + 31 FORMAT(6X,A4,6X,A4,6X,A4,4X,F9.3) + 32 FORMAT(6X,F7.3,2X,A5,4X,F9.3) + 33 FORMAT(6X,F7.3,2X,A5,8X,F4.2) + 34 FORMAT(5X,A5,6X,F7.3,2X,F8.3,3X,F7.3) + 35 FORMAT(6X,F7.3,3X,F7.3,5X,I2,8X,I2) + 36 FORMAT(6X,F7.3,3X,F7.3,3X,F7.3,3X,F7.3) + 37 FORMAT(5X,F8.3,2X,F8.3) + 38 FORMAT(5X,F8.3,2X,F8.3,2X,F8.3) + 39 FORMAT(5X,F8.3,2X,F8.3) + 40 FORMAT(7X,A3,7X,A3,7X,A3) + 41 FORMAT(3X,A7,7X,A3,7X,A3) + 42 FORMAT(7X,A3,6X,A4) + 43 FORMAT(7X,A3) + 44 FORMAT(6X,A4) + 45 FORMAT(4X,A6,8X,A2,8X,A2) + 46 FORMAT(7X,A3,7X,A3) + 47 FORMAT(9X,I1,6X,F7.3) + 48 FORMAT(6X,A4,7X,A3) + 49 FORMAT(5X,F9.3,1X,F9.3) + 50 FORMAT(8X,I2,7X,A3) + 51 FORMAT(6X,F6.2,1X,F9.2) +! +! Formats: Writing standard input data +! + 110 FORMAT(6X,F7.3,3X,F7.3,2X,I5,19X,'Q_MIN,Q_MAX,N_Q') + 111 FORMAT(6X,F7.3,3X,F7.3,2X,I5,19X,'E_MIN,E_MAX,N_E') + 112 FORMAT(6X,F7.3,3X,F7.3,2X,I5,19X,'R_MIN,R_MAX,N_R') + 113 FORMAT(6X,F7.3,3X,F7.3,2X,A5,4X,F9.3,6X,'RS,MSOM,MAT_TYP,EPS_B') + 114 FORMAT(3X,F10.3,3X,F7.3,3X,F7.3,5X,A2,9X,'T,E,H,FLD') + 115 FORMAT(8X,A2,39X,'DIM') + 116 FORMAT(6X,F7.3,3X,F7.3,3X,F6.2,1X,A7,9X,'R0,L,OM0,CONFIN') + 117 FORMAT(6X,F7.3,3X,F7.3,3X,F7.3,3X,F7.3,6X,'DL,D1,N_DEP,N_INV') + 118 FORMAT(6X,A4,4X,F9.3,1X,F9.3,16X,'H_TYPE,EPS_1,EPS_2') + 119 FORMAT(7X,A3,8X,A2,29X,'UNIT,UNIK') + 120 FORMAT(8X,A2,39X,'SC_TYPE') + 121 FORMAT(7X,A3,6X,F7.3,3X,F7.3,16X,'PL_TYPE,ZION,ZION2') + 122 FORMAT(3X,A7,39X,'CAL_TYPE') + 123 FORMAT(3X,A7,6X,A4,6X,A4,9X,I1,9X,'ESTDY,EPS_T,D_FUNC,', & + 'I_T') + 124 FORMAT(6X,A4,6X,A4,8X,F5.3,5X,F5.3,6X,'NEV_TYPE,MEM_TYPE,ALPHA,BETA') + 125 FORMAT(3X,A7,39X,'PL_DISP') + 126 FORMAT(3X,A7,6X,A4,7X,A3,19X,'GSTDY,GQ_TYPE,IQ_TYPE') + 127 FORMAT(6X,A4,6X,A4,8X,A2,8X,A2,9X,'LANDAU,GQO_TYPE,G0_TYPE,GI_TYPE') + 128 FORMAT(6X,A4,6X,A4,7X,A3,19X,'DAMPING,LT_TYPE,RT_TYPE') + 129 FORMAT(6X,A4,6X,A4,6X,A4,19X,'DR_TYPE,DC_TYPE,VI_TYPE') + 130 FORMAT(6X,A4,6X,A4,6X,A4,19X,'EE_TYPE,EP_TYPE,EI_TYPE') + 131 FORMAT(6X,A4,6X,A4,6X,A4,4X,F9.3,6X,'IP_TYPE,PD_TYPE,QD_TYPE,ZETA') + 132 FORMAT(6X,F7.3,2X,A5,4X,F9.3,16X,'D_VALUE_1,POWER_1,EK') + 133 FORMAT(6X,F7.3,2X,A5,8X,F4.2,17X,'D_VALUE_2,POWER_2,PCT') + 134 FORMAT(5X,A5,6X,F7.3,2X,F8.3,3X,F7.3,6X,'INT_POT,S,EPS,DELTA') + 135 FORMAT(6X,F7.3,3X,F7.3,5X,I2,8X,I2,9X,'RC,ALF,M,N') + 136 FORMAT(6X,F7.3,3X,F7.3,3X,F7.3,3X,F7.3,6X,'A1,A2,A3,A4') + 137 FORMAT(5X,F8.3,2X,F8.3,26X,'EP_C,DEBYE_T') + 138 FORMAT(5X,F8.3,2X,F8.3,2X,F8.3,16X,'NA,MA,RA') + 139 FORMAT(5X,F8.3,2X,F8.3,26X,'NI,EI_C') + 140 FORMAT(7X,A3,7X,A3,7X,A3,19X,'CF_TYPE,PF_TYPE,SL_TYPE') + 141 FORMAT(3X,A7,7X,A3,7X,A3,19X,'SSTDY,SQ_TYPE,SQO_TYPE') + 142 FORMAT(7X,A3,6X,A4,29X,'GR_TYPE,GR0_MODE') + 143 FORMAT(7X,A3,39X,'RH_TYPE') + 144 FORMAT(6X,A4,39X,'SPF_TYPE') + 145 FORMAT(4X,A6,8X,A2,8X,A2,19X,'EC_TYPE,FXC_TYPE,EXC_TYPE') + 146 FORMAT(7X,A3,7X,A3,29X,'EX_TYPE,EK_TYPE') + 147 FORMAT(9X,I1,6X,F7.3,26X,'IMODE,XI') + 148 FORMAT(6X,A4,7X,A3,29X,'TH_PROP,GP_TYPE') + 149 FORMAT(4X,F9.3,1X,F9.3,26X,'EK_INI,EK_FIN') + 150 FORMAT(8X,I2,7X,A3,29X,'N_M,M_TYPE') + 151 FORMAT(6X,F6.2,1X,F9.2,27X,'Z_BEAM,EK_BEAM') +! +! Formats: Reading print switches +! + 201 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) +!--------------------------------------------------- + 202 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 204 FORMAT( 9X,I1,9X,I1) +!--------------------------------------------------- + 205 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 206 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 207 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 208 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 209 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 210 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 211 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 212 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 213 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 214 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) +!--------------------------------------------------- + 215 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 216 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 217 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 218 FORMAT( 9X,I1,9X,I1) +!--------------------------------------------------- + 219 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 220 FORMAT( 9X,I1) +!--------------------------------------------------- + 221 FORMAT( 9X,I1,9X,I1,9X,I1) +!--------------------------------------------------- + 222 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 223 FORMAT( 9X,I1,9X,I1,9X,I1) +!--------------------------------------------------- + 224 FORMAT( 9X,I1,9X,I1) +!--------------------------------------------------- + 225 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1) + 226 FORMAT( 9X,I1) +!--------------------------------------------------- + 227 FORMAT( 9X,I1,9X,I1,8X,I2) +!--------------------------------------------------- +! +! Formats: Writing print switches +! + 301 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_DF,I_PZ,I_SU,I_CD') +!--------------------------------------------------- + 302 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_PD,I_EH,I_E2,I_CK') + 304 FORMAT( 9X,I1,9X,I1,29X,'I_CR,I_PK') +!--------------------------------------------------- + 305 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_LF,I_IQ,I_SF,I_PC') + 306 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_P2,I_VX,I_DC,I_MD') + 307 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_LD,I_DP,I_LT,I_BR') + 308 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_PE,I_QC,I_RL,I_KS') + 309 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_OQ,I_ME,I_MS,I_ML') + 310 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_MC,I_DE,I_ZE,I_SR') + 311 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_CW,I_CF,I_EM,I_MF') + 312 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_SP,I_SE,I_SB,I_ES') + 313 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_GR,I_FD,I_BE,I_MX') + 314 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_SC,I_DS,I_NV,I_MT') +!--------------------------------------------------- + 315 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_GP,I_PR,I_CO,I_CP') + 316 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_BM,I_SH,I_S0,I_S1') + 317 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_DT,I_PS,I_IE,I_EI') + 318 FORMAT( 9X,I1,9X,I1,29X,'I_FH,I_EY') +!--------------------------------------------------- + 319 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_EF,I_KF,I_VF,I_TE') + 320 FORMAT( 9X,I1,39X,'I_DL') +!--------------------------------------------------- + 321 FORMAT( 9X,I1,9X,I1,9X,I1,19X,'I_TW,I_VT,I_TC') +!--------------------------------------------------- + 322 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_EG,I_EX,I_XC,I_EC') + 323 FORMAT( 9X,I1,9X,I1,9X,I1,19X,'I_HF,I_EK,I_EP') +!--------------------------------------------------- + 324 FORMAT( 9X,I1,9X,I1,29X,'I_VI,I_DI') +!--------------------------------------------------- + 325 FORMAT( 9X,I1,9X,I1,9X,I1,9X,I1,9X,'I_FP,I_EL,I_PO,I_RF') + 326 FORMAT( 9X,I1,39X,'I_VC') +!--------------------------------------------------- + 327 FORMAT( 9X,I1,9X,I1,8X,I2,19X,'I_FN,I_WR,I_TI') +! + 401 FORMAT('**********************************************************************************') + 402 FORMAT('********************* *********************') + 403 FORMAT('********************* Fermi Liquid *********************') + 404 FORMAT('********************* Dielectric Function *********************') + 405 FORMAT('********************* Input Datafile *********************') + 406 FORMAT('********************* *********************') + 407 FORMAT('**********************************************************************************',//) +! + 500 FORMAT(' ') +! + 601 FORMAT(' =======+=========+=========+=========+=========+============================') + 602 FORMAT(' -------+---------+---------+---------+---------+----------------------------') +! + 702 FORMAT(' GENERAL PARAMETERS : ') + 703 FORMAT(' DIELECTRIC FUNCTION : ') + 704 FORMAT(' STRUCTURE FACTOR : ') + 705 FORMAT(' PAIR CORRELATION FUNCTION : ') + 706 FORMAT(' PAIR DISTRIBUTION FUNCTION : ') + 707 FORMAT(' SPECTRAL FUNCTION : ') + 708 FORMAT(' ENERGY CALCULATIONS : ') + 709 FORMAT(' SPIN POLARIZATION : ') + 710 FORMAT(' THERMODYNAMIC PROPERTIES : ') + 711 FORMAT(' ELECTRON MEAN FREE PATH : ') + 712 FORMAT(' CALCULATION OF MOMENTS: ') + 713 FORMAT(' INCOMING ION BEAM : ') + 714 FORMAT(' OUTPUT CALCULATIONS/PRINTING : ') +! + 801 FORMAT(' (q,omega,r) : ') + 802 FORMAT(' Material''s properties : ') + 803 FORMAT(' External fields : ') + 804 FORMAT(' System''s dimension : ') + 805 FORMAT(' Confinement : ') + 806 FORMAT(' Multilayer structure : ') + 807 FORMAT(' Units : ') + 808 FORMAT(' Screening : ') + 809 FORMAT(' Plasma type : ') + 810 FORMAT(' Calculation type : ') + 811 FORMAT(' Analytical plasmon dispersion : ') + 812 FORMAT(' Local-field corrections ') + 813 FORMAT(' Damping : ') + 814 FORMAT(' Electron-electron interaction : ') + 815 FORMAT(' Electron-phonon interaction : ') + 816 FORMAT(' Electron-impurity interaction : ') + 817 FORMAT(' Classical fluid parameters : ') +! + END SUBROUTINE READ_DATA +! +END MODULE INPUT_DATA diff --git a/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/store_coef.f90 b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/store_coef.f90 new file mode 100644 index 0000000..acc7cf3 --- /dev/null +++ b/New_libraries/DFM_library/INPUT_OUTPUT_LIBRARY/store_coef.f90 @@ -0,0 +1,37 @@ +! +!======================================================================= +! +MODULE DISP_COEF_EH +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: AE(0:6) +! +END MODULE DISP_COEF_EH + ! +!======================================================================= +! +MODULE DISP_COEF_REAL +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: AR(0:6) +! +END MODULE DISP_COEF_REAL +! +!======================================================================= +! +MODULE DISP_COEF_COMP +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + COMPLEX (WP) :: AC(0:6) +! +END MODULE DISP_COEF_COMP + diff --git a/New_libraries/DFM_library/INTERACTION_POTENTIALS_LIBRARY/interaction_potentials_k.f90 b/New_libraries/DFM_library/INTERACTION_POTENTIALS_LIBRARY/interaction_potentials_k.f90 new file mode 100644 index 0000000..bef7e30 --- /dev/null +++ b/New_libraries/DFM_library/INTERACTION_POTENTIALS_LIBRARY/interaction_potentials_k.f90 @@ -0,0 +1,431 @@ +! +!======================================================================= +! +MODULE INTERACTION_POTENTIALS_K +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE INTERACT_POT_K_3D(INT_POT,UNIT,UNIK,Q1,Q2,C1,C2, & + K,KS,VQ) +! +! This subroutine computes interaction potentials in the +! K-space in 3D. +! +! +! Input parameters: +! +! * INT_POT : type of interaction potential (3D) +! INT_POT = 'COULO' Coulomb interaction +! INT_POT= 'YUKAW' Yukawa interaction +! INT_POT= 'RPAPO' RPA interaction +! INT_POT = 'OVER1' Overhauser interaction +! INT_POT = 'OVER2' modified Overhauser interaction +! INT_POT = 'DEUTS' Deutsch interaction +! INT_POT = 'PHOLE' particle-hole interaction +! INT_POT = 'KELBG' Kelbg interaction +! INT_POT = 'ASHPS' Ashcroft empty-core pseudopotential +! * UNIT : system unit +! UNIT = 'SIU' international system +! UNIT = 'CGS' CGS system +! * UNIK : K unit +! UNIK = 'SI' international system +! UNIK = 'AU' atomic units +! * Q1 : charge of particle 1 +! * Q2 : charge of particle 2 +! * C1 : concentration of particles 1 +! * C2 : concentration of particles 2 +! * K : momentum (unit indifferent) +! * KS : screening momentum (unit indifferent) +! +! +! Output parameters: +! +! * VQ : interaction potential (energy) +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Sep 2020 +! +! +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: UNIK + CHARACTER (LEN = 3) :: UNIT + CHARACTER (LEN = 5) :: INT_POT +! + REAL (WP) :: Q1,Q2,C1,C2,KS,K + REAL (WP) :: VQ +! + IF(INT_POT == 'COULO') THEN ! +! + VQ=V_COUL_K(UNIT,Q1,Q2,K) ! +! + ELSE IF(INT_POT == 'YUKAW') THEN ! +! + VQ=V_YUKA_K(UNIT,Q1,Q2,KS,K) ! +! + ELSE IF(INT_POT == 'RPAPO') THEN ! +! + VQ=V_RPAP_K(UNIT,Q1,Q2,KS,K) ! +! + ELSE IF(INT_POT == 'OVER1') THEN ! +! + CONTINUE ! +! + ELSE IF(INT_POT == 'OVER2') THEN ! +! + VQ=V_OVE2_K(UNIT,UNIK,Q1,Q2,K) ! +! + ELSE IF(INT_POT == 'DEUTS') THEN ! +! + VQ=V_DEUT_K(UNIT,Q1,Q2,C1,C2,KS,K) ! +! + ELSE IF(INT_POT == 'PHOLE') THEN ! +! + CONTINUE ! +! + ELSE IF(INT_POT == 'KELBG') THEN ! +! + VQ=V_KELB_K(UNIT,Q1,Q2,KS,K) ! +! + END IF ! +! + END SUBROUTINE INTERACT_POT_K_3D +! +!======================================================================= +! + FUNCTION V_COUL_K(UNIT,Q1,Q2,K) +! +! This function computes the Coulomb interaction energy +! between to particles in the K-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * UNIT : system unit +! UNIT = 'SIU' international system +! UNIT = 'CGS' CGS system +! * Q1 : charge of particle 1 +! * Q2 : charge of particle 2 +! * K : momentum (unit indifferent) +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : FOUR + USE CONSTANTS_P1, ONLY : EPS_0 + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: UNIT +! + REAL (WP) :: Q1,Q2,K + REAL (WP) :: V_COUL_K + REAL (WP) :: COEF +! + IF(UNIT == 'SIU') THEN ! + COEF=Q1*Q2/EPS_0 ! + ELSE IF(UNIT == 'CGS') THEN ! + COEF=FOUR*PI*Q1*Q2 ! + END IF ! +! + V_COUL_K=COEF/(K*K) ! +! + END FUNCTION V_COUL_K +! +!======================================================================= +! + FUNCTION V_DEUT_K(UNIT,Q1,Q2,C1,C2,KS,K) +! +! This function computes the Deutsch interaction energy +! between to particles in the K-space in a given unit system (SI or CGS) +! +! Warning: Two-component plasma only +! +! +! References: (3) C. Deutsch, Phys. Lett. A 60, 317-318 (1977) +! +! +! Input parameters: +! +! * UNIT : system unit +! UNIT = 'SIU' international system +! UNIT = 'CGS' CGS system +! * Q1 : charge of particle 1 +! * Q2 : charge of particle 2 +! * C1 : concentration of particles 1 +! * C2 : concentration of particles 2 +! * KS : screening momentum (unit indifferent) +! * K : momentum (unit indifferent) +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,FOUR + USE CONSTANTS_P1, ONLY : EPS_0 + USE PI_ETC, ONLY : PI + USE SQUARE_ROOTS, ONLY : SQR2 +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: UNIT +! + REAL (WP) :: Q1,Q2,C1,C2,KS,K + REAL (WP) :: V_DEUT_K + REAL (WP) :: COEF,AL1,AL2 +! + IF(UNIT == 'SIU') THEN ! + COEF=Q1*Q2/EPS_0 ! + ELSE IF(UNIT == 'CGS') THEN ! + COEF=FOUR*PI*Q1*Q2 ! + END IF ! +! + AL1=C1/SQR2 * SQRT( ONE - SQRT(ONE-FOUR*KS*KS/(C1*C1)) ) ! + AL2=C2/SQR2 * SQRT( ONE + SQRT(ONE-FOUR*KS*KS/(C2*C2)) ) ! +! + V_DEUT_K=COEF*(ONE/(K*K+AL1*AL1) - ONE/(K*K+AL2*AL2)) ! ref. (3) eq. (2) +! + END FUNCTION V_DEUT_K +! +!======================================================================= +! + FUNCTION V_KELB_K(UNIT,Q1,Q2,KS,K) +! +! This function computes the Kelbg interaction energy +! between to particles in the K-space in a given unit system (SI or CGS) +! +! +! References: (5) W. Ebeling, V. E. Fortov and V. Filinov, +! "Quantum Statistics of Dense Gases and Nonideal Plasmas", +! Springer Series in Plasma Science and Technology, +! (Springer, 2017) p. 150 +! +! +! Input parameters: +! +! * UNIT : system unit +! UNIT = 'SIU' international system +! UNIT = 'CGS' CGS system +! * Q1 : charge of particle 1 +! * Q2 : charge of particle 2 +! * KS : screening momentum (unit indifferent) +! * K : momentum (unit indifferent) +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : FOUR,HALF,FOURTH + USE CONSTANTS_P1, ONLY : EPS_0 + USE PI_ETC, ONLY : PI + USE EXT_FUNCTIONS, ONLY : CONHYP ! Confluent hypergeometric +! ! function 1F1(a,b;z) +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: UNIT +! + REAL (WP) :: Q1,Q2,KS,K + REAL (WP) :: V_KELB_K + REAL (WP) :: COEF,ZZ +! + COMPLEX (WP) :: A,B,Z +! + IF(UNIT == 'SIU') THEN ! + COEF=Q1*Q2/EPS_0 ! + ELSE IF(UNIT == 'CGS') THEN ! + COEF=FOUR*PI*Q1*Q2 ! + END IF ! +! + ZZ=-FOURTH*K*K/(KS*KS) ! +! +! Parameters/arguments of confluent hypergeometric function +! + A=CMPLX(HALF,KIND=WP) ! + B=CMPLX(1.5E0_WP,KIND=WP) ! + Z=CMPLX(ZZ,KIND=WP) ! +! + V_KELB_K=COEF * EXP(ZZ) * REAL(CONHYP(A,B,Z,0,0),KIND=WP) ! ref. (5) eq. (3.119) +! + END FUNCTION V_KELB_K +! +!======================================================================= +! + FUNCTION V_OVE2_K(UNIT,UNIK,Q1,Q2,K) +! +! This function computes the Overhauser interaction energy +! between to particles in the K-space in a given unit system (SI or CGS) +! +! +! References: (2b) I. Nagy and P. M. Echenique, Phys. Rev. B 85, 115131 (2012) +! +! +! Input parameters: +! +! * UNIT : system unit +! UNIT = 'SIU' international system +! UNIT = 'CGS' CGS system +! * UNIK : K unit +! UNIK = 'SI' international system +! UNIK = 'AU' atomic units +! * Q1 : charge of particle 1 +! * Q2 : charge of particle 2 +! * K : momentum (unit indifferent) +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,FOUR,HALF,THIRD + USE CONSTANTS_P1, ONLY : EPS_0 + USE FERMI_SI, ONLY : KF_SI + USE FERMI_AU, ONLY : KF_AU + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: UNIK + CHARACTER (LEN = 3) :: UNIT +! + REAL (WP) :: Q1,Q2,K + REAL (WP) :: V_OVE2_K + REAL (WP) :: COEF,X +! + IF(UNIT == 'SIU') THEN ! + COEF=Q1*Q2/EPS_0 ! + ELSE IF(UNIT == 'CGS') THEN ! + COEF=FOUR*PI*Q1*Q2 ! + END IF ! +! + IF(UNIK == 'SI') THEN ! + X=HALF*K/KF_SI ! + ELSE IF(UNIK == 'AU') THEN ! + X=HALF*K/KF_AU ! + END IF ! +! + IF(X <= ONE) THEN ! + V_OVE2_K=COEF*1.5E0_WP*X*(ONE-THIRD*X*X) ! ref. (2b) eq. (6) + ELSE ! + V_OVE2_K=COEF/(K*K) ! + END IF ! +! + END FUNCTION V_OVE2_K +! +!======================================================================= +! + FUNCTION V_RPAP_K(UNIT,Q1,Q2,KS,K) +! +! This function computes the RPA interaction energy +! between to particles in the K-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * UNIT : system unit +! UNIT = 'SIU' international system +! UNIT = 'CGS' CGS system +! * Q1 : charge of particle 1 +! * Q2 : charge of particle 2 +! * KS : screening momentum (unit indifferent) +! * K : momentum (unit indifferent) +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF,FOURTH + USE CONSTANTS_P1, ONLY : EPS_0 + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: UNIT +! + REAL (WP) :: Q1,Q2,KS,K + REAL (WP) :: V_RPAP_K + REAL (WP) :: COEF,X,GX +! + IF(UNIT == 'SIU') THEN ! + COEF=Q1*Q2/EPS_0 ! + ELSE IF(UNIT == 'CGS') THEN ! + COEF=FOUR*PI*Q1*Q2 ! + END IF ! +! + X=K/KS ! +! +! Computing Lindhard function g(x) +! + GX=HALF - HALF * (ONE+FOURTH*X*X) * & ! + LOG(ABS((TWO+X)/(TWO-X))) / X ! +! + V_RPAP_K=COEF*(K*K + KS*KS*GX) ! +! + END FUNCTION V_RPAP_K +! +!======================================================================= +! + FUNCTION V_YUKA_K(UNIT,Q1,Q2,KS,K) +! +! This function computes the Yukawa interaction energy +! between to particles in the K-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * UNIT : system unit +! UNIT = 'SIU' international system +! UNIT = 'CGS' CGS system +! * Q1 : charge of particle 1 +! * Q2 : charge of particle 2 +! * KS : screening momentum (unit indifferent) +! * K : momentum (unit indifferent) +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : FOUR + USE CONSTANTS_P1, ONLY : EPS_0 + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: UNIT +! + REAL (WP) :: Q1,Q2,KS,K + REAL (WP) :: V_YUKA_K + REAL (WP) :: COEF +! + IF(UNIT == 'SIU') THEN ! + COEF=Q1*Q2/EPS_0 ! + ELSE IF(UNIT == 'CGS') THEN ! + COEF=FOUR*PI*Q1*Q2 ! + END IF ! +! + V_YUKA_K=COEF/(K*K + KS*KS) ! +! + END FUNCTION V_YUKA_K +! +END MODULE INTERACTION_POTENTIALS_K diff --git a/New_libraries/DFM_library/INTERACTION_POTENTIALS_LIBRARY/interaction_potentials_r.f90 b/New_libraries/DFM_library/INTERACTION_POTENTIALS_LIBRARY/interaction_potentials_r.f90 new file mode 100644 index 0000000..60f9b0f --- /dev/null +++ b/New_libraries/DFM_library/INTERACTION_POTENTIALS_LIBRARY/interaction_potentials_r.f90 @@ -0,0 +1,813 @@ +! +!======================================================================= +! +MODULE INTERACTION_POTENTIALS_R +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE INTERACT_POT_R_3D(UNIT,R,Q1,Q2,KS,VR) +! +! This subroutine computes interaction potentials in the +! r-space in 3D. +! +! +! Input parameters: +! +! * UNIT : system unit +! UNIT = 'SIU' international system +! UNIT = 'CGS' CGS system +! * R : point at which the potential is computed +! * Q1 : charge of particle 1 +! * Q2 : charge of particle 2 +! * KS : screening momentum (unit indifferent) +! +! +! Intermediate INT_POT parameter: +! +! INT_POT = 'COULO' Coulomb interaction +! INT_POT= 'YUKAW' Yukawa interaction +! INT_POT= 'SOFTS' soft sphere +! INT_POT= 'LNJNS' Lennard-Jones +! INT_POT= 'HCLNJ' hard-core Lennard-Jones +! INT_POT= 'KIHAR' Kihara +! INT_POT= 'MIE_P' Mie +! INT_POT= 'VANDW' Van der Waals +! INT_POT= 'MORSE' Morse +! INT_POT= 'G_EXP' generalised exponential +! INT_POT= 'EXP_6' exp-6 +! INT_POT= 'MBUCK' modified Buckingham +! INT_POT= 'N_COU' neutralised Coulomb +! INT_POT= 'H_COR' hard-core +! INT_POT= 'P_SPH' penetrable sphere +! INT_POT= 'ST-JO' Starkloff-Joannopoulos soft-core +! INT_POT= 'LR_OS' long-range oscillatory +! INT_POT= 'STOCK' Stockmayer +! +! +! Output parameters: +! +! * VR : interaction potential (energy) +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Apr 2021 +! +! + USE EL_ELE_INTER +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: UNIT +! + REAL (WP), INTENT(IN) :: Q1,Q2,KS,R + REAL (WP), INTENT(OUT) :: VR +! + IF(INT_POT == 'COULO') THEN ! + VR = V_COUL_R(UNIT,Q1,Q2,R) ! + ELSE IF(INT_POT == 'YUKAW') THEN ! + VR = V_YUKA_R(UNIT,Q1,Q2,KS,R) ! + ELSE IF(INT_POT == 'SOFTS') THEN ! + VR = V_SOFT_R(S,EPS,R) ! + ELSE IF(INT_POT == 'LNJNS') THEN ! + VR = V_LEJO_R(S,EPS,R) ! + ELSE IF(INT_POT == 'HCLNJ') THEN ! + VR = V_HCLJ_R(S,EPS,RC,R) ! + ELSE IF(INT_POT == 'KIHAR') THEN ! + VR = V_KIHA_R(S,EPS,M,N,R) ! + ELSE IF(INT_POT == 'MIE_P') THEN ! + VR = V_MIEP_R(S,EPS,M,N,R) ! + ELSE IF(INT_POT == 'VANDW') THEN ! + VR = V_VDWP_R(S,EPS,R) ! + ELSE IF(INT_POT == 'MORSE') THEN ! + VR = V_MORS_R(S,EPS,ALF,R) ! + ELSE IF(INT_POT == 'G_EXP') THEN ! + VR = V_GEXP_R(S,EPS,ALF,R) ! + ELSE IF(INT_POT == 'EXP_6') THEN ! + VR = V_EXP6_R(S,EPS,ALF,R) ! + ELSE IF(INT_POT == 'MBUCK') THEN ! + VR = V_MBUC_R(S,EPS,ALF,R) ! + ELSE IF(INT_POT == 'N_COU') THEN ! + VR = V_NCOU_R(UNIT,Q1,Q2,S,R) ! + ELSE IF(INT_POT == 'H_COR') THEN ! + VR = V_HACO_R(RC,R) ! + ELSE IF(INT_POT == 'P_SPH') THEN ! + VR = V_PSPH_R(EPS,RC,R) ! + ELSE IF(INT_POT == 'ST-JO') THEN ! + VR = V_STJO_R(S,EPS,ALF,A1,R) ! + ELSE IF(INT_POT == 'LR_OS') THEN ! + VR = V_LROS_R(S,EPS,DELTA,A1,A2,A3,A4,R) ! + ELSE IF(INT_POT == 'STOCK') THEN ! + VR = V_STOC_R(S,EPS,DELTA,R) ! + END IF ! +! + END SUBROUTINE INTERACT_POT_R_3D +! +!======================================================================= +! + FUNCTION V_COUL_R(UNIT,Q1,Q2,R) +! +! This function computes the Coulomb interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * UNIT : system unit +! UNIT = 'SIU' international system +! UNIT = 'CGS' CGS system +! * Q1 : charge of particle 1 +! * Q2 : charge of particle 2 +! * R : point +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : FOUR + USE CONSTANTS_P1, ONLY : EPS_0 + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: UNIT +! + REAL (WP) :: Q1,Q2,R + REAL (WP) :: V_COUL_R + REAL (WP) :: COEF +! + IF(UNIT == 'SIU') THEN ! + COEF = Q1 * Q2 / (FOUR * PI * EPS_0) ! + ELSE IF(UNIT == 'CGS') THEN ! + COEF = Q1 * Q2 ! + END IF ! +! + V_COUL_R = COEF / R ! +! + END FUNCTION V_COUL_R +! +!======================================================================= +! + FUNCTION V_YUKA_R(UNIT,Q1,Q2,KS,R) +! +! This function computes the Yukawa interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * UNIT : system unit +! UNIT = 'SIU' international system +! UNIT = 'CGS' CGS system +! * Q1 : charge of particle 1 +! * Q2 : charge of particle 2 +! * KS : screening wave vector +! * R : point +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : FOUR + USE CONSTANTS_P1, ONLY : EPS_0 + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: UNIT +! + REAL (WP) :: Q1,Q2,KS,R + REAL (WP) :: V_YUKA_R + REAL (WP) :: COEF +! + REAL (WP) :: EXP +! + IF(UNIT == 'SIU') THEN ! + COEF = Q1 * Q2 / (FOUR * PI * EPS_0) ! + ELSE IF(UNIT == 'CGS') THEN ! + COEF = Q1 * Q2 ! + END IF ! +! + V_YUKA_R = COEF * EXP(- KS * R) / R ! +! + END FUNCTION V_YUKA_R +! +!======================================================================= +! + FUNCTION V_SOFT_R(S,EPS,R) +! +! This function computes the soft-sphere interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * R : point +! * S : \ +! * EPS : / parameters of the soft-sphere potential +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Sep 2020 +! + IMPLICIT NONE +! + REAL (WP) :: S,EPS,R + REAL (WP) :: V_SOFT_R +! + V_SOFT_R = EPS * (S / R)**12.0E0_WP ! +! + END FUNCTION V_SOFT_R +! +!======================================================================= +! + FUNCTION V_LEJO_R(S,EPS,R) +! +! This function computes the Lennard-Jones interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * R : point +! * S : \ +! * EPS : / parameters of the Lennard-Jones potential +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : FOUR,SIX +! + IMPLICIT NONE +! + REAL (WP),INTENT(IN) :: S,EPS,R + REAL (WP) :: V_LEJO_R +! + V_LEJO_R = FOUR * EPS * ( (S / R)**12.0E0_WP - (S / R)**SIX ) ! +! + END FUNCTION V_LEJO_R +! +!======================================================================= +! + FUNCTION V_HCLJ_R(S,EPS,RC,R) +! +! This function computes the hard-core Lennard-Jones interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * R : point +! * S : \ +! * EPS : / parameters of the Lennard-Jones potential +! * RC : hard-core radius +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOUR,SIX +! + IMPLICIT NONE +! + REAL (WP),INTENT(IN) :: S,EPS,RC,R + REAL (WP) :: V_HCLJ_R +! + REAL (WP) :: NUM,DEN +! + NUM = S - TWO * RC + DEN = R - TWO * RC +! + V_HCLJ_R = FOUR * EPS * ( & ! + (NUM / DEN)**12.0E0_WP - (NUM / DEN)**SIX & ! + ) ! +! + END FUNCTION V_HCLJ_R +! +!======================================================================= +! + FUNCTION V_KIHA_R(S,EPS,M,N,R) +! +! This function computes the Kihara interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * R : point +! * S : \ +! * EPS : / parameters of the Lennard-Jones potential +! * M : \ exponents +! * N : / +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Apr 2021 +! +! +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: M,N +! + REAL (WP),INTENT(IN) :: S,EPS,R + REAL (WP) :: V_KIHA_R +! + REAL (WP) :: FLOAT +! + V_KIHA_R = EPS * ( & ! + FLOAT(M) * (S / R)**N - FLOAT(N) * (S / R)**M & ! + ) / FLOAT(N - M) ! +! + END FUNCTION V_KIHA_R +! +!======================================================================= +! + FUNCTION V_MIEP_R(S,EPS,M,N,R) +! +! This function computes the Mie interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * R : point +! * S : \ +! * EPS : / parameters of the Lennard-Jones potential +! * M : \ exponents +! * N : / +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Apr 2021 +! +! +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: M,N +! + REAL (WP),INTENT(IN) :: S,EPS,R + REAL (WP) :: V_MIEP_R +! + REAL (WP) :: K1,K2,K3,COEF +! + REAL (WP) :: FLOAT +! + K1 = FLOAT(N) / FLOAT(N - M) ! + K2 = FLOAT(N) / FLOAT(M) ! + K3 = FLOAT(M) / FLOAT(N - M) ! + COEF = K1 * K2**K3 ! +! + V_MIEP_R = COEF * EPS * ( (S / R)**N - (S / R)**M ) ! +! + END FUNCTION V_MIEP_R +! +!======================================================================= +! + FUNCTION V_VDWP_R(S,EPS,R) +! +! This function computes the Van der Waals interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * R : point +! * S : \ +! * EPS : / parameters of the Lennard-Jones potential +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,SIX +! + IMPLICIT NONE +! + REAL (WP),INTENT(IN) :: S,EPS,R + REAL (WP) :: V_VDWP_R +! + REAL (WP) :: SR2 +! + REAL (WP) :: LOG +! + SR2 = (S / R)**2 ! +! + V_VDWP_R = - EPS * ( & ! + TWO * SR2 / (ONE - FOUR * SR2) + TWO * SR2 + & ! + LOG( ONE - FOUR * SR2 ) & ! + ) / SIX ! +! + END FUNCTION V_VDWP_R +! +!======================================================================= +! + FUNCTION V_MORS_R(S,EPS,ALF,R) +! +! This function computes the Morse interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * R : point +! * S : \ +! * EPS : / parameters of the Lennard-Jones potential +! * ALF : potential stiffness +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE +! + IMPLICIT NONE +! + REAL (WP),INTENT(IN) :: S,EPS,ALF,R + REAL (WP) :: V_MORS_R +! + REAL (WP) :: EXP +! + V_MORS_R = EPS * ( ONE - EXP( ALF * (R - S) ) ) ! +! + END FUNCTION V_MORS_R +! +!======================================================================= +! + FUNCTION V_GEXP_R(S,EPS,ALF,R) +! +! This function computes the generalised exponential interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * R : point +! * S : \ +! * EPS : / parameters of the Lennard-Jones potential +! * ALF : potential stiffness +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Apr 2021 +! +! + IMPLICIT NONE +! + REAL (WP),INTENT(IN) :: S,EPS,ALF,R + REAL (WP) :: V_GEXP_R +! + REAL (WP) :: EXP +! + V_GEXP_R = EPS * EXP( - ALF * (R / S) ) ! +! + END FUNCTION V_GEXP_R +! +!======================================================================= +! + FUNCTION V_EXP6_R(S,EPS,ALF,R) +! +! This function computes the exp-6 interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * R : point +! * S : \ +! * EPS : / parameters of the Lennard-Jones potential +! * ALF : potential stiffness +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,SIX +! + IMPLICIT NONE +! + REAL (WP),INTENT(IN) :: S,EPS,ALF,R + REAL (WP) :: V_EXP6_R +! + REAL (WP) :: EXP +! + V_EXP6_R = EPS * ( & ! + SIX * EXP( ALF * (ONE - R / S) ) - & ! + ALF * (S / R)**SIX & ! + ) / (ALF - SIX) ! +! + END FUNCTION V_EXP6_R +! +!======================================================================= +! + FUNCTION V_MBUC_R(S,EPS,ALF,R) +! +! This function computes the modified Buckingham interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * R : point +! * S : \ +! * EPS : / parameters of the Lennard-Jones potential +! * ALF : potential stiffness +! +! +! Author : D. Sébilleau +! +! Last modified : 14 SeAprp 2021 +! +! + USE REAL_NUMBERS, ONLY : LARGE +! + IMPLICIT NONE +! + REAL (WP),INTENT(IN) :: S,EPS,ALF,R + REAL (WP) :: V_MBUC_R +! + REAL (WP) :: EXP +! + IF(R <= S) THEN + V_MBUC_R = V_EXP6_R(S,EPS,ALF,R) / ALF ! + ELSE ! + V_MBUC_R = LARGE ! + END IF ! +! + END FUNCTION V_MBUC_R +! +!======================================================================= +! + FUNCTION V_NCOU_R(UNIT,Q1,Q2,S,R) +! +! This function computes the neutralised Coulomb interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * UNIT : system unit +! UNIT = 'SIU' international system +! UNIT = 'CGS' CGS system +! * Q1 : charge of particle 1 +! * Q2 : charge of particle 2 +! * S : cut-off value +! * R : point +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : FOUR + USE CONSTANTS_P1, ONLY : EPS_0 + USE PI_ETC, ONLY : PI +! + USE EXT_FUNCTIONS, ONLY : ERF,ERFC +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: UNIT +! + REAL (WP), INTENT(IN) :: Q1,Q2,S,R + REAL (WP) :: V_NCOU_R + REAL (WP) :: COEF +! + IF(UNIT == 'SIU') THEN ! + COEF = Q1 * Q2 / (FOUR * PI * EPS_0) ! + ELSE IF(UNIT == 'CGS') THEN ! + COEF = Q1 * Q2 ! + END IF ! +! + V_NCOU_R = COEF * ( ERFC(R/S) + ERFC(R/S) ) / R ! +! + END FUNCTION V_NCOU_R +! +!======================================================================= +! + FUNCTION V_HACO_R(RC,R) +! +! This function computes the hard-core interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * RC : hard-core radius +! * R : point +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,LARGE +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RC,R + REAL (WP) :: V_HACO_R +! + IF(R <= RC) THEN + V_HACO_R = LARGE ! + ELSE ! + V_HACO_R = ZERO ! + END IF ! +! + END FUNCTION V_HACO_R +! +!======================================================================= +! + FUNCTION V_PSPH_R(EPS,RC,R) +! +! This function computes the hard-core interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * EPS : value of the hard-core potential +! * RC : hard-core radius +! * R : point +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EPS,RC,R + REAL (WP) :: V_PSPH_R +! + IF(R <= RC) THEN + V_PSPH_R = EPS ! + ELSE ! + V_PSPH_R = ZERO ! + END IF ! +! + END FUNCTION V_PSPH_R +! +!======================================================================= +! + FUNCTION V_STJO_R(S,EPS,ALF,A1,R) +! +! This function computes the Starkloff-Joannopoulos soft-core interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * R : point +! * S : \ +! * EPS : / parameters of the Lennard-Jones potential +! * ALF : potential stiffness +! * A1 : magnitude of first term +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Apr 2021 +! + USE REAL_NUMBERS, ONLY : ZERO,ONE +! + IMPLICIT NONE +! + REAL (WP),INTENT(IN) :: S,EPS,ALF,A1,R + REAL (WP) :: V_STJO_R +! + REAL (WP) :: V1,V2 + REAL (WP) :: NUM,DEN +! + REAL (WP) :: EXP +! + NUM = - A1 * ( ONE - EXP( - ALF * R ) ) ! + DEN = R * ( ONE + EXP( ALF * (S - R) ) ) ! + V1 = NUM / DEN ! +! + IF(R <= S) THEN ! + V2 = ZERO ! + ELSE ! + V2 = EPS * ( EXP( ALF * (S - R) ) - ONE ) ! + END IF ! +! + V_STJO_R = V1 + V2 ! +! + END FUNCTION V_STJO_R +! +!======================================================================= +! + FUNCTION V_LROS_R(S,EPS,DELTA,A1,A2,A3,A4,R) +! +! This function computes the long-range oscillatory interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! This potential of of the form +! +! V(r) = EPS * EXP(A1 - A2 * R / S) - DELTA * (S/R)^3 * COS(A3 * [R/S + A4]) +! +! Input parameters: +! +! * R : point +! * S : \ +! * EPS : / parameters of the Lennard-Jones potential +! * A1 : \ +! * A2 : \ +! * A3 : / +! * A4 : / +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Apr 2021 +! + USE REAL_NUMBERS, ONLY : THREE +! + IMPLICIT NONE +! + REAL (WP),INTENT(IN) :: S,EPS,DELTA,R + REAL (WP),INTENT(IN) :: A1,A2,A3,A4 + REAL (WP) :: V_LROS_R +! + REAL (WP) :: RT,TR,V1,V2 +! + REAL (WP) :: EXP,COS +! + RT = R / S ! + TR = S / R ! +! + V1 = EPS * EXP( A1 - A2 * RT) ! + V2 = - DELTA * TR**THREE * COS( A3 * (RT + A4) ) ! +! + V_LROS_R = V1 + V2 ! +! + END FUNCTION V_LROS_R +! +!======================================================================= +! + FUNCTION V_STOC_R(S,EPS,DELTA,R) +! +! This function computes the Stockmayer interaction energy +! between to particles in the r-space in a given unit system (SI or CGS) +! +! +! Input parameters: +! +! * R : point +! * S : \ +! * EPS : > parameters of the Stockmayer potential +! * DELTA : / +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : THREE,FOUR,SIX +! + IMPLICIT NONE +! + REAL (WP),INTENT(IN) :: S,EPS,DELTA,R + REAL (WP) :: V_STOC_R +! + REAL (WP) :: RT +! + RT = S / R ! +! + V_STOC_R = FOUR * EPS * ( RT**12.0E0_WP - RT**SIX - & ! + DELTA * RT**THREE ) ! +! + END FUNCTION V_STOC_R +! +END MODULE INTERACTION_POTENTIALS_R diff --git a/New_libraries/DFM_library/LANDAU_PARAMETERS_LIBRARY/landau.f90 b/New_libraries/DFM_library/LANDAU_PARAMETERS_LIBRARY/landau.f90 new file mode 100644 index 0000000..56b0401 --- /dev/null +++ b/New_libraries/DFM_library/LANDAU_PARAMETERS_LIBRARY/landau.f90 @@ -0,0 +1,937 @@ +! +!======================================================================= +! +MODULE LANDAU_PARAM +! +! This module provides the standard dimensionless Landau parameters +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE LANDAU_PARAMETERS_3D(X,XC,U0,W,D,RS,LANDAU, & + F0S,F0A,F1S,F1A,F2S,F2A) +! +! This subroutine computes the standard dimensionless Landau parameters +! as a function of the Hubbard-like bare coupling constant, or the +! hard-sphere radius, in the 3D case +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * XC : dimensionless cut-off --> XC = q_c / (2 * k_F) +! * U0 / A : bare interaction constant / hard sphere radius (in SI) +! * W : half bandwidth for bare particle (ref. 7) +! * D : filling (dopant concentration) in ref. 7 +! * RS : Wigner-Seitz radius (in units of a_0) +! * LANDAU : model chosen for the calculation of the parameters +! LANDAU = 'ANBR' Anderson-Brinkman model +! LANDAU = 'CHEN' Chen's approach +! LANDAU = 'GUTZ' Gutzwiller model +! LANDAU = 'GVYO' Giuliani-Vignale parametrization of +! LANDAU = 'IWPI' Iwamoto-Pines model (hard-sphere) +! Yasuhara-Ousaka approach +! LANDAU = 'RASC' Rayleigh-Schrödinger expansion +! LANDAU = 'SBOH' slave-boson one-band Hubbard model +! +! +! Output parameters: +! +! * F0S,F0A,F1S,F1A,F2S,F2A +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: LANDAU +! + REAL (WP) :: X,XC,U0,A,W,D,RS + REAL (WP) :: F0S,F0A,F1S,F1A,F2S,F2A +! + IF(LANDAU == 'ANBR') THEN ! +! + CALL ANBR_LP_3D(U0,F0S,F0A,F1S,F1A,F2S,F2A) ! +! + ELSE IF(LANDAU == 'CHEN') THEN ! +! + CALL CHEN_LP_3D(U0,F0S,F0A,F1S,F1A,F2S,F2A) ! +! + ELSE IF(LANDAU == 'GUTZ') THEN ! +! + CALL GUTZ_LP_3D(U0,F0S,F0A,F1S,F1A,F2S,F2A) ! +! + ELSE IF(LANDAU == 'GVYO') THEN ! +! + CALL GVYO_LP_3D(RS,F0S,F0A,F1S,F1A,F2S,F2A) ! +! + ELSE IF(LANDAU == 'IWPI') THEN ! +! + A=U0 ! + CALL IPWI_LP_3D(A,F0S,F0A,F1S,F1A,F2S,F2A) ! +! + ELSE IF(LANDAU == 'RASC') THEN ! +! + CALL RASC_LP_3D(X,XC,U0,F0S,F0A,F1S,F1A,F2S,F2A) ! +! + ELSE IF(LANDAU == 'SBOH') THEN ! +! + CALL SBOH_LP_3D(U0,W,D,F0S,F0A,F1S,F1A,F2S,F2A) ! +! + END IF ! +! + END SUBROUTINE LANDAU_PARAMETERS_3D +! +!======================================================================= +! + SUBROUTINE LANDAU_PARAMETERS_2D(RS,LANDAU,X,IX, & + F0S,F0A,F1S,F1A,F2S,F2A) +! +! This subroutine computes the standard dimensionless Landau parameters +! in the 2D case. +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * LANDAU : model chosen for the calculation of the parameters +! LANDAU = 'ERZA' Engelbrecht-Randeria-Zhang approach +! LANDAU = 'GVYO' Giuliani-Vignale parametrization of +! Yasuhara-Ousaka approach +! LANDAU = 'KCMP' Kwoon-Ceperley-Martin parametrization +! * X : either MU or EG (for 'ERZA' only) +! * IX : switch for input value X (for 'ERZA' only) +! IX = 1 --> X = chemical potential MU in SI +! IX = 2 --> X = ground state energy EG in SI +! +! +! Output parameters: +! +! * F0S,F0A,F1S,F1A,F2S,F2A +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: LANDAU +! + REAL (WP) :: RS,X,G + REAL (WP) :: F0S,F0A,F1S,F1A,F2S,F2A +! + INTEGER :: IX +! + IF(LANDAU == 'ERZA') THEN ! +! + CALL ERZA_LP_2D(X,IX,F0S,F0A,F1S,F1A,F2S,F2A) ! +! + ELSE IF(LANDAU == 'GVYO') THEN ! +! + CALL GVYO_LP_2D(RS,F0S,F0A,F1S,F1A,F2S,F2A) ! +! + ELSE IF(LANDAU == 'KCMP') THEN ! +! + CALL KCMP_LP_2D(RS,F0S,F0A,F1S,F1A,F2S,F2A) ! +! + END IF ! +! + END SUBROUTINE LANDAU_PARAMETERS_2D +! +!======================================================================= +! + SUBROUTINE ANBR_LP_3D(U0,F0S,F0A,F1S,F1A,F2S,F2A) +! +! This subroutine computes the standard dimensionless Landau parameters +! for the Anderson-Brinkman model in the 3D case +! +! References: (1) D. Volhardt, Rev. Mod. Phys. 58, 99-120 (1984) +! +! +! Input parameters: +! +! * U0 : bare interaction constant +! +! +! Output parameters: +! +! * F0S,F0A,F1S,F1A,F2S,F2A +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,EIGHT,FOURTH + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI2 +! + IMPLICIT NONE +! + REAL (WP) :: U0,UC,XU + REAL (WP) :: NF_SI + REAL (WP) :: F0S,F0A,F1S,F1A,F2S,F2A +! +! Initialization +! + F0S=ZERO ! + F0A=ZERO ! + F1S=ZERO ! + F1A=ZERO ! + F2S=ZERO ! + F2A=ZERO ! +! + NF_SI=M_E*KF_SI/(PI2*H_BAR*H_BAR) ! n(E_F) in SI +! +! Cut-off interaction +! + UC=EIGHT*EF_SI ! + XU=U0/UC ! +! + F1S=THREE*(ONE/(ONE-XU*XU)) - ONE ! ref. (1) eq. (24) + F0A=-FOURTH*NF_SI*U0*(TWO+XU)/((ONE*XU)*(ONE*XU)) ! ref. (41) eq. (25) +! + END SUBROUTINE ANBR_LP_3D +! +!======================================================================= +! + SUBROUTINE CHEN_LP_3D(U0,F0S,F0A,F1S,F1A,F2S,F2A) +! +! This subroutine computes the standard dimensionless Landau parameters +! in Chen's approach, in the 3D case +! +! References: (1) V. A. Belyakov, Soviet Phys. JETP 13, 850-851 (1961) +! (2) J.-S. Chen, J. Stat. Mech. L08002 (2009) +! +! +! +! Input parameters: +! +! * U0 : bare interaction constant +! +! +! Output parameters: +! +! * F0S,F0A,F1S,F1A,F2S,F2A +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,EIGHT, & + NINE,THIRD,FOURTH + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI,PI_INV +! + IMPLICIT NONE +! + REAL (WP) :: U0 + REAL (WP) :: A,AKF,P2AKF + REAL (WP) :: F0S,F0A,F1S,F1A,F2S,F2A +! +! Initialization +! + F0S=ZERO ! + F0A=ZERO ! + F1S=ZERO ! + F1A=ZERO ! + F2S=ZERO ! + F2A=ZERO ! +! +! Scattering amplitude from Fermi pseudopotential +! + A= FOURTH*PI_INV*U0 * (M_E/(H_BAR*H_BAR)) ! ref. 1 eq. (3) +! + AKF=A*KF_SI ! + P2AKF=PI-TWO * AKF ! +! + F1S=FOUR*AKF*AKF/(THREE * P2AKF**2) ! ref. (2) eq. (28) + F0S=(ONE+THIRD*F1S)*(ONE + TWO*AKF/P2AKF + & ! + 20.0E0_WP*AKF*AKF/(NINE*P2AKF*P2AKF) + & ! ref. (2) eq. (25) + EIGHT*AKF*AKF*AKF/(NINE*(P2AKF**3))) ! +! + END SUBROUTINE CHEN_LP_3D +! +!======================================================================= +! + SUBROUTINE ERZA_LP_2D(X,IX,F0S,F0A,F1S,F1A,F2S,F2A) +! +! This subroutine computes the standard dimensionless Landau parameters +! in the 2D case. +! +! References: (1) J. R. Engelbrecht, M. Randeria and L. Zhang, +! Phys. Rev. B 45, 10135-10138 (1992) +! +! +! Input parameters: +! +! * X : either MU or EG +! * IX : switch for input value X +! IX = 1 --> X = chemical potential MU in SI +! IX = 2 --> X = ground state energy EG in SI +! +! Intermediate parameters: +! +! * G : low-density expansion parameter (ref. 1) +! +! +! Output parameters: +! +! * F0S,F0A,F1S,F1A,F2S,F2A +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,TWO,FOUR +! + IMPLICIT NONE +! + INTEGER :: IX +! + REAL (WP) :: X,G + REAL (WP) :: LN2 + REAL (WP) :: F0S,F0A,F1S,F1A,F2S,F2A +! + LN2=DLOG(TWO) ! +! +! Initialization +! + F0S=ZERO ! + F0A=ZERO ! + F1S=ZERO ! + F1A=ZERO ! + F2S=ZERO ! + F2A=ZERO ! +! +! Computing the expansion parameter G +! + CALL MU_EG_TO_G(X,IX,G) ! +! + F0S=TWO*G+FOUR*G*G*(TWO-LN2) ! + F0A=-FOUR*G*G*LN2 ! + F1S= TWO*G*G ! + F1A=- TWO*G*G ! +! + END SUBROUTINE ERZA_LP_2D +! +!======================================================================= +! + SUBROUTINE MU_EG_TO_G(X,IX,G) +! +! This subroutine computes the low-density expansion parameter g +! from the knowledge of either the chemical potential mu or +! from the ground state energy EG +! +! References: (1) J. R. Engelbrecht, M. Randeria and L. Zhang, +! Phys. Rev. B 45, 10135-10138 (1992) +! +! +! Input parameters: +! +! * X : either MU or EG +! * IX : switch for input value X +! IX = 1 --> X = chemical potential MU in SI +! IX = 2 --> X = ground state energy EG in SI +! +! +! Output parameters: +! +! * G : low-density expansion parameter (ref. 1) +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR + USE FERMI_SI, ONLY : EF_SI + USE POLYNOMIAL_EQ, ONLY : QUADRATIC_EQUATION,CHECK_ROOTS2 +! + IMPLICIT NONE +! + INTEGER :: IX +! + REAL (WP) :: X,G + REAL (WP) :: MU,EG + REAL (WP) :: LN2 +! + COMPLEX (WP) :: AA,BB,CC + COMPLEX (WP) :: X1,X2 +! + LN2=DLOG(TWO) ! +! + IF(IX == 1) THEN ! +! + MU=X ! +! + AA=DCMPLX(FOUR*(ONE-LN2)) ! + BB=DCMPLX(TWO) ! + CC=DCMPLX(ONE-MU/EF_SI) ! +! + CALL QUADRATIC_EQUATION(AA,BB,CC,X1,X2) ! +! + CALL CHECK_ROOTS2(X1,X2,G) ! +! + ELSE IF(IX == 2) THEN ! +! + EG=X ! +! + AA=DCMPLX(THREE-FOUR*LN2) ! + BB=DCMPLX(TWO) ! + CC=DCMPLX(ONE-TWO*EG/EF_SI) ! +! + CALL QUADRATIC_EQUATION(AA,BB,CC,X1,X2) ! +! + CALL CHECK_ROOTS2(X1,X2,G) ! +! + END IF ! +! + END SUBROUTINE MU_EG_TO_G +! +!======================================================================= +! + SUBROUTINE GUTZ_LP_3D(U0,F0S,F0A,F1S,F1A,F2S,F2A) +! +! This subroutine computes the standard dimensionless Landau parameters +! for the Gutzwiller approach, in the 3D case +! +! References: (1) D. Volhardt, Rev. Mod. Phys. 58, 99-120 (1984) +! +! +! +! Input parameters: +! +! * U0 : bare interaction constant +! +! +! Output parameters: +! +! * F0S,F0A,F1S,F1A,F2S,F2A +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,EIGHT, & + THIRD,FOURTH + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI2 +! + IMPLICIT NONE +! + REAL (WP) :: U0,UC,XU + REAL (WP) :: NF_SI,P,I,AA,BB + REAL (WP) :: NUM,DEN + REAL (WP) :: F0S,F0A,F1S,F1A,F2S,F2A +! +! Initialization +! + F0S=ZERO ! + F0A=ZERO ! + F1S=ZERO ! + F1A=ZERO ! + F2S=ZERO ! + F2A=ZERO ! +! + NF_SI=M_E*KF_SI/(PI2*H_BAR*H_BAR) ! n(E_F) in SI +! +! Cut-off interaction +! + UC=EIGHT*EF_SI ! + XU=U0/UC ! +! + P=FOURTH*UC*NF_SI ! + I=XU ! + AA=-ONE + (FOUR - I*I)*(ONE - P) ! + BB=( ONE + I*I*(ONE-P) )**2 ! + NUM=BB + TWO*THIRD*P*AA ! + DEN=BB*(ONE+I*I) + TWO*THIRD*P*AA ! +! + F0A=-P*(ONE - ONE/((ONE+I)*(ONE+I))) ! ref. (1) eq. (50) + F0S= P*(ONE/((ONE+I)*(ONE+I) - ONE) ) ! ref. (1) eq. (54) + F1A=-THREE*I*I * NUM/DEN ! ref. (1) eq. (71) +! + END SUBROUTINE GUTZ_LP_3D +! +!======================================================================= +! + SUBROUTINE GVYO_LP_3D(RS,F0S,F0A,F1S,F1A,F2S,F2A) +! +! This subroutine computes the Yasuhara-Ousaka +! parametrization of Landau parameters F0s,F0a, +! F1s,F1a,F2s,F2a. +! +! We use a 4-degree polynomial to fit the data of +! table 8.1 and table 8.6 of reference (1) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Output parameters: +! +! * F0S,F0A,F1S,F1A,F2S,F2A +! +! +! Reference: (1) G. F. Giuliani and G. Vignale, +! "Quantum Theory of the Electron Liquid", +! (Cambridge University Press 2005) +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! +! + IMPLICIT NONE +! + REAL (WP) :: RS,F0S,F0A,F1S,F1A,F2S,F2A + REAL (WP) :: Y,Y2,Y3,Y4 + REAL (WP) :: A1(0:4),A2(0:4),A3(0:4),A4(0:4),A5(0:4),A6(0:4) +! + DATA A1 / -0.066667E0_WP , -0.13392E0_WP , -0.0094444E0_WP ,&! F0s + 0.00018519E0_WP, 6.8305E-18_WP / ! + DATA A2 / -0.10833E0_WP , -0.039854E0_WP , -0.029514E0_WP ,&! F0a + 0.008287E0_WP , -0.000625E0_WP / ! + DATA A3 / -0.07E0_WP , 0.049167E0_WP , -0.024583E0_WP ,&! F1s + 0.0058333E0_WP , -0.00041667E0_WP / ! + DATA A4 / -0.0242E0_WP , 0.0066333E0_WP, -0.00068333E0_WP,&! F1a + 0.00016667E0_WP, -1.6667E-05_WP / ! + DATA A5 / -0.0221E0_WP , -0.00265E0_WP , 0.00395E0_WP ,&! F2s + -0.00075E0_WP , 5.0E-05_WP / ! + DATA A6 / -0.0242E0_WP , 0.0066333E0_WP, -0.00068333E0_WP,&! F2a + 0.00016667E0_WP, -1.6667E-05_WP / ! +! +! Powers of RS +! + Y = RS ! + Y2 = Y*Y ! + Y3 = Y2*Y ! + Y4 = Y3*Y ! +! +! Computing the Landau parameters +! + F0S=A1(0) + A1(1)*Y + A1(2)*Y2 + A1(3)*Y3 + A1(4)*Y4 ! F0s + F0A=A2(0) + A2(1)*Y + A2(2)*Y2 + A2(3)*Y3 + A2(4)*Y4 ! F0a + F1S=A3(0) + A3(1)*Y + A3(2)*Y2 + A3(3)*Y3 + A3(4)*Y4 ! F1s + F1A=A4(0) + A4(1)*Y + A4(2)*Y2 + A4(3)*Y3 + A4(4)*Y4 ! F1a + F2S=A5(0) + A5(1)*Y + A5(2)*Y2 + A5(3)*Y3 + A5(4)*Y4 ! F2s + F2A=A6(0) + A6(1)*Y + A6(2)*Y2 + A6(3)*Y3 + A6(4)*Y4 ! F2a +! + END SUBROUTINE GVYO_LP_3D +! +!======================================================================= +! + SUBROUTINE GVYO_LP_2D(RS,F0S,F0A,F1S,F1A,F2S,F2A) +! +! This subroutine computes the Yasuhara-Ousaka +! parametrization of Landau parameters F0s,F0a, +! F1s. +! +! We use a 4-degree polynomial to fit the data of +! table 8.5 of reference (1) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Output parameters: +! +! * F0S,F0A,F1S,F1A,F2S,F2A +! +! +! Reference: (1) G. F. Giuliani and G. Vignale, +! "Quantum Theory of the Electron Liquid", +! (Cambridge University Press 2005) +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + REAL (WP) :: RS,F0S,F0A,F1S,F1A,F2S,F2A + REAL (WP) :: Y,Y2,Y3,Y4 + REAL (WP) :: A1(0:4),A2(0:4),A3(0:4) +! + DATA A1 / -0.13E0_WP , -0.19917E0_WP , -0.12958E0_WP ,& ! F0s + 0.0091667E0_WP, -0.00041667E0_WP / ! + DATA A2 / -0.1019E0_WP , -0.24296E0_WP , 0.063813E0_WP,& ! F0a + -0.0094683E0_WP, 0.00051984E0_WP / ! + DATA A3 / -0.087143E0_WP , 0.10986E0_WP , 0.010738E0_WP,& ! F1s + -0.0037143E0_WP, 0.0002619E0_WP / ! +! +! Initialization +! + F0S=ZERO ! + F0A=ZERO ! + F1S=ZERO ! + F1A=ZERO ! + F2S=ZERO ! + F2A=ZERO ! +! +! Powers of RS +! + Y = RS ! + Y2 = Y*Y ! + Y3 = Y2*Y ! + Y4 = Y3*Y ! +! +! Computing the Landau parameters +! + F0S=A1(0) + A1(1)*Y + A1(2)*Y2 + A1(3)*Y3 + A1(4)*Y4 ! F0s + F0A=A2(0) + A2(1)*Y + A2(2)*Y2 + A2(3)*Y3 + A2(4)*Y4 ! F0a + F1S=A3(0) + A3(1)*Y + A3(2)*Y2 + A3(3)*Y3 + A3(4)*Y4 ! F1s +! + END SUBROUTINE GVYO_LP_2D +! +!======================================================================= +! + SUBROUTINE IPWI_LP_3D(A,F0S,F0A,F1S,F1A,F2S,F2A) +! +! This subroutine computes the standard dimensionless Landau parameters +! for the Iwamoto-Pines hard-sphere model, in the 3D case +! +! References: (1) N. Iwamoto and D. Pines, Phys. Rev. B 29, 3924 (1984) +! +! +! +! Input parameters: +! +! * A : hard sphere radius (in SI) +! +! +! Output parameters: +! +! * F0S,F0A,F1S,F1A,F2S,F2A +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,SEVEN,THIRD + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL*8 A,AKF + REAL*8 LN2 + REAL*8 F0S,F0A,F1S,F1A,F2S,F2A +! + LN2=DLOG(TWO) ! +! +! Initialization +! + F0S=ZERO ! + F0A=ZERO ! + F1S=ZERO ! + F1A=ZERO ! + F2S=ZERO ! + F2A=ZERO ! +! + AKF=A*KF_SI ! +! + F0S= TWO*PI_INV*AKF*( & ! + ONE+FOUR*THIRD*PI_INV* & ! + (TWO+LN2)*AKF & ! + ) ! ref. (1) eq. (B1) + F0A=-TWO*PI_INV*AKF*( & ! + ONE+FOUR*THIRD*PI_INV* & ! + (ONE-LN2)*AKF & ! + ) ! ref. (1) eq. (B2) + F1A= 1.6E0_WP*PI_INV*PI_INV*(SEVEN*LN2-ONE)*AKF*AKF ! ref. (1) eq. (B3) + F1S=-1.6E0_WP*PI_INV*PI_INV*(TWO+LN2)*AKF*AKF ! ref. (1) eq. (B4) +! + END SUBROUTINE IPWI_LP_3D +! +!======================================================================= +! + SUBROUTINE KCMP_LP_2D(RS,F0S,F0A,F1S,F1A,F2S,F2A) +! +! This subroutine computes the Kwoon-Ceperley-Martin +! parametrization of Landau parameters F0s,F0a, +! F1s,F1a,F2s and F2a. +! +! We use a 4-point Lagrange interpolation to fit the data of +! table VIII of reference (1) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Output parameters: +! +! * F0S,F0A,F1S,F1A,F2S,F2A +! +! Reference: (1) Y. Kwoon, D. M. Ceperley and R. M. Martin, +! Phys. Rev. B 50, 1684-1694 (1994) +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FIVE + USE INTERPOLATION, ONLY : LAG_4P_INTERP +! + IMPLICIT NONE +! + REAL (WP) :: RS,F0S,F0A,F1S,F1A,F2S,F2A + REAL (WP) :: A1(4),A2(4),A3(4),A4(4),A5(4),A6(4) + REAL (WP) :: X(4) +! +! Data of table VIII +! + DATA A1 / -0.60E0_WP, -0.99E0_WP, -1.63E0_WP, -3.70E0_WP / ! F0s + DATA A2 / -0.34E0_WP, -0.41E0_WP, -0.49E0_WP, -0.51E0_WP / ! F0a + DATA A3 / -0.14E0_WP, -0.10E0_WP, -0.03E0_WP, 0.12E0_WP / ! F1s + DATA A4 / -0.19E0_WP, -0.24E0_WP, -0.26E0_WP, -0.27E0_WP / ! F1a + DATA A5 / -0.07E0_WP, -0.16E0_WP, -0.27E0_WP, -0.50E0_WP/ ! F2s + DATA A6 / 0.01E0_WP, 0.07E0_WP, 0.14E0_WP, 0.32E0_WP/ ! F2a +! +! RS values un table VIII +! + X(1)=ONE ! + X(2)=TWO ! + X(3)=THREE ! + X(4)=FIVE ! +! +! F0s --> A1 data +! + F0S=LAG_4P_INTERP(X,A1,RS) ! +! +! F0a --> A2 data +! + F0A=LAG_4P_INTERP(X,A2,RS) ! +! +! F1s --> A3 data +! + F1S=LAG_4P_INTERP(X,A3,RS) ! +! +! F1a --> A4 data +! + F1A=LAG_4P_INTERP(X,A4,RS) ! +! +! F2s --> A5 data +! + F2S=LAG_4P_INTERP(X,A5,RS) ! +! +! F2a --> A6 data +! + F2A=LAG_4P_INTERP(X,A6,RS) ! +! + END SUBROUTINE KCMP_LP_2D +! +!======================================================================= +! + SUBROUTINE RASC_LP_3D(X,XC,U0,F0S,F0A,F1S,F1A,F2S,F2A) +! +! This subroutine computes the standard dimensionless Landau parameters +! using a Rayleigh-Schrödinger expansion in the 3D case +! +! References: (1) Slides +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * XC : dimensionless cut-off --> XC = q_c / (2 * k_F) +! * U0 : bare interaction constant +! +! +! Output parameters: +! +! * F0S,F0A,F1S,F1A,F2S,F2A +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,SEVEN, & + HALF,THIRD,FOURTH + USE CONSTANTS_P1, ONLY : M_E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI2 +! + IMPLICIT NONE +! + REAL (WP) :: X,XC,U0,UB + REAL (WP) :: Q_SI,Q_CO + REAL (WP) :: LN2 + REAL (WP) :: F0S,F0A,F1S,F1A,F2S,F2A +! + LN2=DLOG(TWO) ! +! +! Initialization +! + F0S=ZERO ! + F0A=ZERO ! + F1S=ZERO ! + F1A=ZERO ! + F2S=ZERO ! + F2A=ZERO ! +! + Q_SI=TWO*X*KF_SI ! q in SI + Q_CO=TWO*XC*KF_SI ! q_c in SI +! +! Screened interaction +! + UB=U0*(ONE - U0*FOURTH*M_E/PI2 * HALF*( Q_CO + &! + (Q_SI*Q_SI-Q_CO*Q_CO)* &! ref. 1 p. + DLOG(DABS(Q_CO-Q_SI)/(Q_CO+Q_SI))/ &! + Q_SI)) ! +! + F0S= UB * (ONE + UB*(ONE+HALF*THIRD*(TWO+LN2))) ! + F0A=-UB * (ONE + UB*(ONE-TWO*THIRD*(ONE-LN2))) ! ref. (1) p. 22 + F1S= UB*UB * TWO*(SEVEN*LN2-ONE)/15.0E0_WP ! +! + END SUBROUTINE RASC_LP_3D +! +!======================================================================= +! + SUBROUTINE SBOH_LP_3D(U0,W,D,F0S,F0A,F1S,F1A,F2S,F2A) +! +! This subroutine computes the standard dimensionless Landau parameters +! of the slave-boson one-band Hubbard model in the 3D case +! +! References: (1) T. Li and P. Bénard, Phys. Rev. B 50, 17837 (1994) +! (2) Slides +! +! +! +! Input parameters: +! +! * U0 : bare interaction constant +! * W : half bandwidth for bare particle (ref. 7) +! * D : filling (dopant concentration) in ref. 7 +! +! +! Output parameters: +! +! * F0S,F0A,F1S,F1A,F2S,F2A +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,FIVE, & + SIX,EIGHT,NINE,TEN + USE COMPLEX_NUMBERS, ONLY : ZEROC,ONEC + USE CONSTANTS_P1, ONLY : M_E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI2 + USE POLYNOMIAL_EQ, ONLY : CUBIC_EQUATION,CHECK_ROOTS3 +! + IMPLICIT NONE +! + REAL*8 U0 + REAL*8 W,D,U + REAL*8 D2,D4,D6 + REAL*8 Y,Y2,Y3,Y4,Y5,Y6,Y7 + REAL*8 NUM,DEN + REAL*8 F0S,F0A,F1S,F1A,F2S,F2A +! + COMPLEX*16 AC,BC,CC,DC + COMPLEX*16 X1,X2,X3 +! +! Initialization +! + F0S=ZERO ! + F0A=ZERO ! + F1S=ZERO ! + F1A=ZERO ! + F2S=ZERO ! + F2A=ZERO ! +! +! Scaled interaction +! + U=U0/(FOUR*W) ! ref. 7 eq. (59c) +! +! +! Computing Y, solution of: +! +! (1-Y)*Y^2 +! --------- = U ref. (3) eq. (11) +! Y^2-D2 +! + AC=ONEC ! + BC=DCMPLX(U-ONE) ! + CC=ZEROC ! + DC=DCMPLX(-U*D*D) ! +! + CALL CUBIC_EQUATION(AC,BC,CC,DC,X1,X2,X3) ! +! +! Looking for a real and positive solution Y = x^2 +! + CALL CHECK_ROOTS3(X1,X2,X3,Y) ! +! + D2=D*D ! + D4=D2*D2 ! + D6=D4*D2 ! + Y2=Y*Y ! + Y3=Y2*Y ! + Y4=Y3*Y ! + Y5=Y4*Y ! + Y6=Y5*Y ! + Y7=Y6*Y ! +! + NUM=(ONE-Y)*(TWO*D2-FIVE*D2*Y+TWO*Y2+D2*Y2+Y3-Y4) ! + DEN=(D2-TWO*Y+Y2)*(-TWO*D2+THREE*D2*Y-Y3) ! + F0S=NUM/DEN ! ref. (1) eq. (61) +! + NUM=(ONE-D2)*(Y2-D2) ! + DEN=(TWO*Y-Y2-D2)**2 ! + F0A=-ONE + NUM/DEN ! ref. (1) eq. (60) +! + NUM=THREE*(Y-ONE)**2 * ( -TEN*D4 + 19.0E0_WP*D4*Y - &! + EIGHT*D2*Y2 - &! + TWO*D2*Y3+TWO*Y4-Y5 &! + ) ! + DEN=( 16.0E0_WP*D4 - SIX*D6 - 48.0E0_WP*D4*Y + &! + NINE*D6*Y + EIGHT*D2*Y2 + 48.0E0_WP*D4*Y2 - &! + EIGHT*D2*Y3 - 25.0E0_WP*D4*Y3 - EIGHT*Y4 + &! + TEN*D2*Y4 + EIGHT*Y5-D2*Y5 - FOUR*Y6 + &! + Y7 &! + ) ! + F1A=NUM/DEN ! ref. (1) eq. (65) +! + NUM=THREE*(ONE-Y2)**2 ! + DEN=(TWO*Y-Y2-D2) ! + F1S=NUM/DEN ! ref. (1) eq. (23) +! + END SUBROUTINE SBOH_LP_3D +! +END MODULE LANDAU_PARAM diff --git a/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/101.pdf b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/101.pdf new file mode 100644 index 0000000..4c4026f Binary files /dev/null and b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/101.pdf differ diff --git a/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/Multipair_excitations_and_sum_rules_in_i.pdf b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/Multipair_excitations_and_sum_rules_in_i.pdf new file mode 100644 index 0000000..1799054 Binary files /dev/null and b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/Multipair_excitations_and_sum_rules_in_i.pdf differ diff --git a/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/PhysRevB.10.3052.pdf b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/PhysRevB.10.3052.pdf new file mode 100644 index 0000000..85d5f1d Binary files /dev/null and b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/PhysRevB.10.3052.pdf differ diff --git a/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/PhysRevB.17.4512.pdf b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/PhysRevB.17.4512.pdf new file mode 100644 index 0000000..6f4d76a Binary files /dev/null and b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/PhysRevB.17.4512.pdf differ diff --git a/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/iq_functions_1.f90 b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/iq_functions_1.f90 new file mode 100644 index 0000000..76d410a --- /dev/null +++ b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/iq_functions_1.f90 @@ -0,0 +1,187 @@ +! +!======================================================================= +! +MODULE IQ_FUNCTIONS_1 +! +! This modules provides subroutines/functions to compute +! static local-field factors I(q) = G(q,inf) +! +! These I(q) DOES NOT DEPEND of the static structure factor S(q) +! +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE IQ_3D(X,RS,IQ_TYPE,IQ) +! +! This function computes the function I(q) = G(q,infinity) +! for 3D systems +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * IQ_TYPE : type of approximation for I(q) +! IQ_TYPE = 'NON' set to zero +! IQ_TYPE = 'IKP' Iwamoto-Krotscheck-Pines parametrization +! IQ_TYPE = 'KU1' Kugler 1 +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: IQ_TYPE +! + REAL (WP) :: X,RS + REAL (WP) :: IQ +! + IF(IQ_TYPE == 'NON') THEN ! + IQ = ZERO ! + ELSE IF(IQ_TYPE == 'IKP') THEN ! + IQ=IQ_IKP_3D(X,RS) ! + ELSE IF(IQ_TYPE == 'KU1') THEN ! + IQ=IQ_KU1_3D(X) ! + END IF ! +! + END SUBROUTINE IQ_3D +! +!======================================================================= +! + FUNCTION IQ_IKP_3D(X,RS) +! +! This function computes the Iwamoto-Krotscheck-Pines +! parametrization for the calculation of the I(q) function +! +! We use a fourth-degree polynomial to fit the data of +! table II reference (1): r_s = 1 --> A1 +! r_s = 2 --> A2 +! r_s = 5 --> A5 +! +! For a given value of (q / k_F), this gives 3 values of I(q / k_F). +! Then, we use Lagrange interpolation to find I(q / k_F) for the +! input value r_s +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Reference: (1) N. Iwamoto, E. Krotscheck and D. Pines, +! Phys. Rev. B 28, 3936-3951 (1984) +! (2) https://en.wikipedia.org/wiki/Lagrange_polynomial +! +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FIVE,THIRD,FOURTH +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS + REAL (WP) :: IQ_IKP_3D + REAL (WP) :: Y,Y2,Y3,Y4 + REAL (WP) :: A1(0:4),A2(0:4),A5(0:4) + REAL (WP) :: I1,I2,I5,L1,L2,L5 +! + DATA A1 / 0.0039314E0_WP, - 0.03844E0_WP , 0.29126E0_WP, & ! coefficients of + - 0.13488E0_WP, 0.018838E0_WP / ! the 4th-degree + DATA A2 / 0.005127E0_WP , - 0.048227E0_WP, 0.32508E0_WP, & ! polynomials + - 0.14552E0_WP , 0.019639E0_WP / ! used to fit + DATA A5 / 0.0077247E0_WP, - 0.068004E0_WP, 0.3837E0_WP , & ! table II + - 0.15996E0_WP , 0.019756E0_WP / ! data +! + Y = X + X ! q / k_F + Y2 = Y * Y ! + Y3 = Y2 * Y ! powers of Y + Y4 = Y3 * Y ! +! +! Computing I(q) for r_s = 1,2 and 5 +! + I1 = A1(0) + A1(1) * Y + A1(2) * Y2 + A1(3) * Y3 + A1(4) * Y4 ! + I2 = A2(0) + A2(1) * Y + A2(2) * Y2 + A2(3) * Y3 + A2(4) * Y4 ! + I5 = A5(0) + A5(1) * Y + A5(2) * Y2 + A5(3) * Y3 + A5(4) * Y4 ! +! +! Performing Lagrange interpolation between I1, I2 and I5: +! +! I(r_s) = I1 * L1(r_s) + I2 * L2(r_s) + I5 * L5(r_s) +! + L1 = FOURTH * (RS - TWO) * (RS - FIVE) ! + L2 = - THIRD * (RS - ONE) * (RS - FIVE) ! + L5 = FOURTH * THIRD * (RS - ONE) * (RS - TWO) ! +! + IQ_IKP_3D = I1 * L1 + I2 * L2 + I5 * L5 ! +! + END FUNCTION IQ_IKP_3D +! +!======================================================================= +! + FUNCTION IQ_KU1_3D(X) +! +! This function computes G(q,infinity), the value of the dynamic +! local-field correction for omega = infinity, for 3D systems +! in the Kugler approximation +! +! References: (1) A. Kugler, J. Stat. Phys. 12, 35-87 (1975) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Warning note: Here, we use the variable Y = q / k_F = 2 * X +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,FIVE,SIX +! + IMPLICIT NONE +! + REAL (WP) :: X + REAL (WP) :: IQ_KU1_3D + REAL (WP) :: Y,Y2,Y4,YM1,YM2 +! + REAL (WP) :: LOG,ABS +! + Y = X + X ! Y = q / k_F = eta + Y2 = Y * Y ! Y^2 = eta^2 + Y4 = Y2 * Y2 ! Y^4 = eta^4 + YM1 = ONE / Y ! 1 / Y = 1/eta + YM2 = ONE / Y2 ! 1 / Y^2 = 1/eta^2 +! + IQ_KU1_3D = - THREE / 16.0E0_WP * ( & ! + 32.0E0_WP * YM2 / 63.0E0_WP - & ! + 608.0E0_WP / 945.0E0_WP - & ! + 142.0E0_WP * Y2 / 315.0E0_WP - & ! + TWO * Y4 / 315.0E0_WP + & ! + Y4 * (TWO - Y2 / 18.0E0_WP) * & ! + LOG(ABS(ONE - FOUR * YM2)) / 35.0E0_WP + & ! ref. (1) eq. (D6) + ( -32.0E0_WP * YM2 / 63.0E0_WP + & ! + 24.0E0_WP / 35.0E0_WP - & ! + TWO * Y2 / FIVE + & ! + Y4 / SIX & ! + ) * YM1 * LOG(ABS((Y + TWO) / (Y - TWO))) & ! + ) ! +! + END FUNCTION IQ_KU1_3D +! +END MODULE IQ_FUNCTIONS_1 diff --git a/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/iq_functions_2.f90 b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/iq_functions_2.f90 new file mode 100644 index 0000000..6751a98 --- /dev/null +++ b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/iq_functions_2.f90 @@ -0,0 +1,379 @@ +! +!======================================================================= +! +MODULE IQ_FUNCTIONS_2 +! +! This modules provides subroutines/functions to compute +! static local-field factors I(q) = G(q,inf) +! +! These I(q) DEPEND of the static structure factor S(q) +! through the function J(q): +! +! _ _ +! h_bar omega_q | | 3 m pi +! I(q) = 4 ------------------- | < E_kin> - < E_kin> | - --------- ------ J(q) +! (h_bar omega_p)^2 |_ 0 _| 4 k_F^3 e^2 +! +! +! d(r_s E_c) +! Note: < E_kin> - < E_kin> = ----------- +! 0 d r_s +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE IQ_3D_2(X,RS,T,IQ) +! +! This function computes the function I(q) = G(q,infinity) +! for 3D systems +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * IQ_TYPE : type of approximation for I(q) +! IQ_TYPE = 'GKM' Gorobchenko-Kohn-Maksimov +! IQ_TYPE = 'HKA' Hong-Kim +! IQ_TYPE = 'KU2' Kugler +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,THREE,FOUR,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE ENERGIES, ONLY : EC_TYPE + USE CORRELATION_ENERGIES + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: IQ_TYPE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: IQ + REAL (WP) :: JQ + REAL (WP) :: Q_SI,E_Q,D_KIN + REAL (WP) :: EC,D_EC_1,D_EC_2 + REAL (WP) :: COEF1,COEF2 + REAL (WP) :: KF3,E2 +! + Q_SI = TWO * KF_SI * X ! + E_Q = HALF * H_BAR * H_BAR * Q_SI * Q_SI / M_E ! +! + KF3 = KF_SI * KF_SI * KF_SI ! + E2 = E * E ! +! +! Computing the correlation energy and its derivatives +! + EC = EC_3D(EC_TYPE,1,RS,T) ! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! + D_KIN = EC + RS * D_EC_1 ! +! + IF(IQ_TYPE == 'HKA') THEN ! + JQ = JQ_HKA_3D(X,RS,T) ! + ELSE IF(IQ_TYPE == 'GKM') THEN ! + JQ = JQ_GKM_3D(X,RS,T) ! + ELSE IF(IQ_TYPE == 'KU2') THEN ! + JQ = JQ_KU2_3D(X,RS,T) ! + END IF ! +! + COEF1 = FOUR * E_Q / (ENE_P_SI * ENE_P_SI) ! + COEF2 = THREE * M_E * PI / (FOUR * KF3 * E2) ! +! + IQ = COEF1 * D_KIN - COEF2 * JQ ! +! + END SUBROUTINE IQ_3D_2 +! +!======================================================================= +! + FUNCTION JQ_HKA_3D(X,RS,T) +! +! This function computes the Hong-Kim J(q) function +! +! Reference: J. Hong and C. Kim, Phys. Rev. 43, 1965-1971 (1991) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Sep 2020 +! +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOUR,FIVE,SIX, & + HALF,THIRD + USE PI_ETC, ONLY : PI_INV + USE SF_VALUES, ONLY : SQ_TYPE + USE INTEGRATION, ONLY : INTEGR_L + USE STRUCTURE_FACTOR_STATIC, ONLY : STFACT_STATIC +! + IMPLICIT NONE +! + INTEGER :: IP + INTEGER, PARAMETER :: N_I = 100 ! number of integration points + INTEGER :: ID +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: JQ_HKA_3D + REAL (WP) :: INTG(NZ_MAX) + REAL (WP) :: I_STEP + REAL (WP) :: K,P,K2,P2 + REAL (WP) :: PPK,PMK + REAL (WP) :: SQ + REAL (WP) :: INTGR +! + REAL (WP) :: FLOAT,LOG,ABS +! + REAL (WP), PARAMETER :: UP = SIX ! upper bound for integration +! + ID = 1 ! +! + K = X + X ! q / k_F + K2 = K * K ! +! +! Initialization of integrand +! + DO IP = 1, NZ_MAX ! + INTG(IP) = ZERO ! + END DO ! +! + I_STEP = UP / FLOAT(N_I -1) ! integration step +! +! Calculation of integrand +! + DO IP = 1, N_I ! +! + P = FLOAT(IP - 1) * I_STEP ! + P2 = P * P ! +! + PPK = P + K ! + PMK = P - K ! +! + CALL STFACT_STATIC(X,RS,T,SQ_TYPE,SQ) ! +! + INTG(IP) = P2 * (ONE - SQ) * ( & ! + FIVE / SIX - HALF * P2 / K2 + & ! + (PMK * PPK)**2 * LOG(ABS(PPK / PMK)) / & ! ref. (1) eq. (26) + (FOUR * P * K * K2) & ! + ) ! +! + END DO ! +! +! Computing the integral +! + CALL INTEGR_L(INTG,I_STEP,NZ_MAX,N_I,INTGR,ID) ! +! + JQ_HKA_3D = THIRD * PI_INV * INTGR ! ref. (1) eq. (26) +! + END FUNCTION JQ_HKA_3D +! +!======================================================================= +! + FUNCTION JQ_GKM_3D(X,RS,T) +! +! This function computes the Gorobchenko-Kohn-Maksimov J(q) function +! +! +! Reference : V. D. Gorobchenko, V. N. Kohn and E. G. Maksimov, +! in "The Dielectric Function of Condensed Systems", +! ed. by L. V. Keldysh, D. A. Kirzhnitz and +! A. A. Maradudin (Elsevier, 1989), pp. 87-219 +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 19 Sep 2020 +! +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ZERO,ONE,THREE,FOUR,FIVE,SIX,EIGHT + USE SF_VALUES, ONLY : SQ_TYPE + USE INTEGRATION, ONLY : INTEGR_L + USE STRUCTURE_FACTOR_STATIC, ONLY : STFACT_STATIC +! + IMPLICIT NONE +! + INTEGER :: IP + INTEGER, PARAMETER :: N_I = 100 ! number of integration points + INTEGER :: ID +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: JQ_GKM_3D + REAL (WP) :: INTG(NZ_MAX) + REAL (WP) :: I_STEP + REAL (WP) :: K,P,K2,P2 + REAL (WP) :: PPK,PMK + REAL (WP) :: SQ + REAL (WP) :: INTGR + REAL (WP) :: KF3 +! + REAL (WP) :: FLOAT,LOG,ABS +! + REAL (WP), PARAMETER :: UP = SIX ! upper bound for integration +! + ID = 1 ! +! + KF3 = ONE ! +! + K = X + X ! q / k_F + K2 = K * K ! +! +! Initialization of integrand +! + DO IP = 1, NZ_MAX ! + INTG(IP) = ZERO ! + END DO ! +! + I_STEP = UP / FLOAT(N_I -1) ! integration step +! +! Calculation of integrand +! + DO IP = 1, N_I ! +! + P = FLOAT(IP - 1) * I_STEP ! + P2 = P * P ! +! + PPK = P + K ! + PMK = P - K ! +! + CALL STFACT_STATIC(X,RS,T,SQ_TYPE,SQ) ! +! + INTG(IP) = P2 * (ONE - SQ) * ( & ! + FIVE / EIGHT - THREE * P2 / (EIGHT * K2) + & ! + THREE* PMK * PPK * LOG(ABS(PPK / PMK)) / & ! ref. (1) eq. (2.75) + (FOUR * FOUR * P * K * K2) & ! + ) ! +! + END DO ! +! +! Computing the integral +! + CALL INTEGR_L(INTG,I_STEP,NZ_MAX,N_I,INTGR,ID) ! +! + JQ_GKM_3D = INTGR / KF3 ! +! + END FUNCTION JQ_GKM_3D +! +!======================================================================= +! + FUNCTION JQ_KU2_3D(X,RS,T) +! +! This function computes the Kugler J(q) function +! +! Reference: (1) A. A. Kugler, Phys. Rev. A 1, 1688-1696 (1970) +! (2) A. A. Kugler, J. Stat. Phys. 12, 35-87 (1975) +! +! Note: A misprint in the expression of J(q,k) in ref. (1) +! has been corrected in ref. (2) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 19 Sep 2020 +! +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOUR,FIVE,SIX, & + HALF + USE PI_ETC, ONLY : PI_INV + USE CONSTANTS_P1, ONLY : M_E,E + USE SF_VALUES, ONLY : SQ_TYPE + USE INTEGRATION, ONLY : INTEGR_L + USE STRUCTURE_FACTOR_STATIC, ONLY : STFACT_STATIC +! + IMPLICIT NONE +! + INTEGER :: IP + INTEGER, PARAMETER :: N_I = 100 ! number of integration points + INTEGER :: ID +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: JQ_KU2_3D + REAL (WP) :: INTG(NZ_MAX) + REAL (WP) :: I_STEP + REAL (WP) :: K,P,K2,P2,R,R2 + REAL (WP) :: PPK,PMK + REAL (WP) :: SQ + REAL (WP) :: INTGR +! + REAL (WP) :: FLOAT,LOG,ABS +! + REAL (WP), PARAMETER :: UP = SIX ! upper bound for integration +! + ID = 1 ! +! + K = X + X ! q / k_F + K2 = K * K ! +! +! Initialization of integrand +! + DO IP = 1, NZ_MAX ! + INTG(IP) = ZERO ! + END DO ! +! + I_STEP = UP / FLOAT(N_I -1) ! integration step +! +! Calculation of integrand +! + DO IP = 1, N_I ! +! + P = FLOAT(IP - 1) * I_STEP ! + P2 = P * P ! + R = P / K ! + R2 = P2 / K2 ! +! + PPK = P + K ! + PMK = P - K ! +! + CALL STFACT_STATIC(X,RS,T,SQ_TYPE,SQ) ! +! + INTG(IP) = P2 * (SQ - ONE) * ( & ! + FIVE / SIX - HALF * R2 + & ! ref. (1) eq. (5.6) + (R2 - ONE)**2 * LOG(ABS(PPK / PMK)) / & ! corrected by ref. (2) + (FOUR * R) & ! + ) ! +! + END DO ! +! +! Computing the integral +! + CALL INTEGR_L(INTG,I_STEP,NZ_MAX,N_I,INTGR,ID) ! +! + JQ_KU2_3D = E * E * PI_INV * INTGR / M_E ! ref. (1) eq. (5.5) +! + END FUNCTION JQ_KU2_3D +! +END MODULE IQ_FUNCTIONS_2 diff --git a/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/local_field_dynamic.f90 b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/local_field_dynamic.f90 new file mode 100644 index 0000000..ccef364 --- /dev/null +++ b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/local_field_dynamic.f90 @@ -0,0 +1,2303 @@ +! +!======================================================================= +! +MODULE LOCAL_FIELD_DYNAMIC +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE LFIELD_DYNAMIC(X,RS,OM0,OM1,N_OM,T,ETA, & + GQO_TYPE,OM,GR,GI) +! +! This subroutine compute the dynamic local-field correction function +! G(omega) -- for a given value of q -- from the the knwoledge +! of the imaginary par of this function +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * OM0 : starting value of h_bar*omega / E_F +! * OM1 : final value of h_bar*omega / E_F +! * N_OM : number of values of h_bar*omega / E_F +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * ETA : viscosity in SI +! * GQO_TYPE : dynamic local-field correction type +! GQO_TYPE = 'NONE' no local field correction +! GQO_TYPE = 'ALFL' Alvarellos-Flores correction +! GQO_TYPE = 'BACA' Barriga-Carrasco correction +! GQO_TYPE = 'BBSA' Bachlechner-Böhm-Schinner +! GQO_TYPE = 'COPI' Constantin-Pitarke +! GQO_TYPE = 'DABR' Dabrowski +! GQO_TYPE = 'FWRA' Forstmann-Wierling-Röpke +! GQO_TYPE = 'HOK1' Hong-Kim correction +! GQO_TYPE = 'HOK2' Hong-Kim correction +! GQO_TYPE = 'JEWS' Jewsbury approximation +! GQO_TYPE = 'KUG1' Kugler q --> 0 approximation +! GQO_TYPE = 'KUG2' Kugler approximation +! GQO_TYPE = 'MDGA' Mithen-Daligault-Gregori +! GQO_TYPE = 'NEV2' Nevanlinna three-moment approximation +! GQO_TYPE = 'NLGA' Nagy-Laszlo-Giber approximation +! GQO_TYPE = 'RIA1' Richardson-Ashcroft G_s +! GQO_TYPE = 'RIA2' Richardson-Ashcroft G_n +! GQO_TYPE = 'RIA3' Richardson-Ashcroft G_a +! GQO_TYPE = 'SHMU' Shah-Mukhopadhyay +! GQO_TYPE = 'STGU' Sturm-Gusarov +! GQO_TYPE = 'TOWO' Toigo-Woodruff +! GQO_TYPE = 'UTI2' Utsumi-Ichimaru approximation +! GQO_TYPE = 'VISC' viscosity approximation +! +! +! Output parameters: +! +! * OM : array containing omega +! * GR : array containing Re[G(omega)] +! * GI : array containing Im[G(omega)] +! +! Author : D. Sébilleau +! +! Last modified : 19 Jun 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQO_TYPE +! + INTEGER :: N_OM +! + REAL (WP) :: X,Z,OM0,OM1,RS,T,ETA + REAL (WP) :: OM(N_OM),GR(N_OM),GI(N_OM) +! + IF(DMN == '3D') THEN ! + CALL LOCAL_FIELD_DYNAMIC_3D(X,RS,OM0,OM1,N_OM,T,ETA, & ! + GQO_TYPE,OM,GR,GI) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! + END IF ! +! + END SUBROUTINE LFIELD_DYNAMIC +! +!------ 1) 3D case -------------------------------------------- +! +! +!======================================================================= +! + SUBROUTINE LOCAL_FIELD_DYNAMIC_3D(X,RS,OM0,OM1,N_OM,T,ETA, & + GQO_TYPE,OM,GR,GI) +! +! This subroutine compute the dynamic local-field correction function +! G(omega) -- for a given value of q -- from the the knwoledge +! of the imaginary par of this function +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * OM0 : starting value of h_bar*omega / E_F +! * OM1 : final value of h_bar*omega / E_F +! * N_OM : number of values of h_bar*omega / E_F +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * ETA : viscosity in SI +! * GQO_TYPE : dynamic local-field correction type +! GQO_TYPE = 'NONE' no local field correction +! GQO_TYPE = 'ALFL' Alvarellos-Flores correction +! GQO_TYPE = 'BACA' Barriga-Carrasco correction +! GQO_TYPE = 'BBSA' Bachlechner-Böhm-Schinner +! GQO_TYPE = 'COPI' Constantin-Pitarke +! GQO_TYPE = 'DABR' Dabrowski +! GQO_TYPE = 'FWRA' Forstmann-Wierling-Röpke +! GQO_TYPE = 'HOK1' Hong-Kim correction +! GQO_TYPE = 'HOK2' Hong-Kim correction +! GQO_TYPE = 'JEWS' Jewsbury approximation +! GQO_TYPE = 'KUG1' Kugler q --> 0 approximation +! GQO_TYPE = 'KUG2' Kugler approximation +! GQO_TYPE = 'MDGA' Mithen-Daligault-Gregori +! GQO_TYPE = 'NEV2' Nevanlinna three-moment approximation +! GQO_TYPE = 'NLGA' Nagy-Laszlo-Giber approximation +! GQO_TYPE = 'RIA1' Richardson-Ashcroft G_s +! GQO_TYPE = 'RIA2' Richardson-Ashcroft G_n +! GQO_TYPE = 'RIA3' Richardson-Ashcroft G_a +! GQO_TYPE = 'SHMU' Shah-Mukhopadhyay +! GQO_TYPE = 'STGU' Sturm-Gusarov +! GQO_TYPE = 'TOWO' Toigo-Woodruff +! GQO_TYPE = 'UTI2' Utsumi-Ichimaru approximation +! GQO_TYPE = 'VISC' viscosity approximation +! +! +! Internal parameters: +! +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! * SQ_TYPE : structure factor approximation (3D) +! +! +! Output parameters: +! +! * OM : array containing omega +! * GR : array containing Re[G(omega)] +! * GI : array containing Im[G(omega)] +! +! Author : D. Sébilleau +! +! Last modified : 27 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR + USE COMPLEX_NUMBERS, ONLY : ZEROC,ONEC,IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,EPS_0 + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI,PI3 + USE COULOMB_K, ONLY : COULOMB_FF + USE SF_VALUES, ONLY : SQ_TYPE + USE LF_VALUES, ONLY : GQ_TYPE + USE ENERGIES, ONLY : EC_TYPE + USE UTILITIES_1, ONLY : RS_TO_N0 + USE UTILITIES_2, ONLY : IMAG_TO_REAL + USE UTILITIES_3, ONLY : EPS_TO_PI + USE CONFINEMENT_FF, ONLY : CONFIN_FF + USE DFUNCL_STAN_DYNAMIC, ONLY : RPA1_EPS_D_LG_3D +! + USE UNITS, ONLY : UNIT +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQO_TYPE +! + INTEGER :: N_OM,K,IM +! + REAL (WP) :: X,OM0,OM1,RS,T,ETA,Z + REAL (WP) :: OM(N_OM),GR(N_OM),GI(N_OM) + REAL (WP) :: N0,Q_SI,Q2 + REAL (WP) :: KOEF,K1,VC + REAL (WP) :: EPSR,EPSI,PIR,PII +! + REAL (WP) :: FLOAT,REAL,AIMAG +! + COMPLEX (WP) :: GQO + COMPLEX (WP) :: K0,K2 +! + Q_SI = TWO * X* KF_SI ! q in SI + Q2 = Q_SI * Q_SI ! q^2 + KOEF = TWO * M_E * EF_SI / (H_BAR * H_BAR * Q2) ! E_F / h_bar*omega_q + N0 = RS_TO_N0('3D',RS) ! +! + CALL COULOMB_FF('3D',UNIT,Q_SI,ZERO,VC) ! Coulomb potential +! +! Checking for need to compute Re[G(omega)] +! through Kramers-Kronig (IM = 1) or not (IM = 0) Re[G(omega)] +! needed: + IF(GQO_TYPE == 'NONE') THEN ! + IM = 0 ! + ELSE IF(GQO_TYPE == 'ALFL') THEN ! + IM = 1 ! <-- + ELSE IF(GQO_TYPE == 'BACA') THEN ! + IM = 0 ! + ELSE IF(GQO_TYPE == 'BBSA') THEN ! + IM = 1 ! <-- + ELSE IF(GQO_TYPE == 'COPI') THEN ! + IM = 0 ! + ELSE IF(GQO_TYPE == 'DABR') THEN ! + IM = 1 ! <-- + ELSE IF(GQO_TYPE == 'FWRA') THEN ! + IM = 0 ! + ELSE IF(GQO_TYPE == 'HOK1') THEN ! + IM = 0 ! + ELSE IF(GQO_TYPE == 'HOK2') THEN ! + IM = 0 ! + ELSE IF(GQO_TYPE == 'JEWS') THEN ! + IM = 0 ! + ELSE IF(GQO_TYPE == 'KUG1') THEN ! + IM = 0 ! + ELSE IF(GQO_TYPE == 'KUG2') THEN ! + IM = 1 ! <-- + ELSE IF(GQO_TYPE == 'MDGA') THEN ! + IM = 0 ! + ELSE IF(GQO_TYPE == 'NEV2') THEN ! + IM = 0 ! + ELSE IF(GQO_TYPE == 'NLGA') THEN ! + IM = 0 ! + ELSE IF(GQO_TYPE == 'SHMU') THEN ! + IM = 1 ! <-- + ELSE IF(GQO_TYPE == 'STGU') THEN ! + IM = 1 ! <-- + ELSE IF(GQO_TYPE == 'TOWO') THEN ! + IM = 1 ! <-- Re[P(omega)] + ELSE IF(GQO_TYPE == 'UTI2') THEN ! + IM = 0 ! + ELSE IF(GQO_TYPE == 'VISC') THEN ! + IM = 0 ! + END IF ! +! + IF(IM == 1) THEN ! +! +! Loop on omega for IM = 1 +! + DO K=1,N_OM ! +! + OM(K) = OM0 + FLOAT(K - 1) * (OM1 - OM0) / FLOAT(N_OM - 1)! + Z = OM(K) * KOEF ! omega / omega_q +! +! Calculation of Im[G(omega)] +! + IF(GQO_TYPE == 'ALFL') THEN ! +! + GI(K) = ALFL_LFC(X,Z) ! +! + ELSE IF(GQO_TYPE == 'BBSA') THEN ! +! + GI(K) = BBSA_LFC(X,Z,RS,T) ! +! + ELSE IF(GQO_TYPE == 'DABR') THEN ! +! + GI(K) = DABR_LFC(X,Z,RS,T) ! +! + ELSE IF(GQO_TYPE == 'KUG2') THEN ! +! + GI(K) = KUG2_LFC(X,Z) ! +! + ELSE IF(GQO_TYPE == 'SHMU') THEN ! +! + GI(K) = SHMU_LFC(X,Z,RS) ! +! + ELSE IF(GQO_TYPE == 'STGU') THEN ! +! + GI(K) = STGU_LFC(X,Z,RS,T) ! +! + ELSE IF(GQO_TYPE == 'TOWO') THEN ! +! + GI(K) = TOWO_LFC(X,Z,RS) ! +! + END IF ! +! + END DO ! +! +! Computing the real part +! + CALL IMAG_TO_REAL(GI,OM,N_OM,GR) ! +! + END IF ! +! +! Loop on omega for all cases +! + DO K= 1, N_OM ! +! + OM(K) =OM0 + FLOAT(K - 1) * (OM1 - OM0)/FLOAT(N_OM - 1) ! + Z = OM(K) * KOEF ! omega / omega_q +! +! Computing the RPA dielectric function, the Coulomb potential, +! the polarization function, and the electron density +! + CALL RPA1_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + CALL EPS_TO_PI(EPSR,EPSI,VC,PIR,PII) ! RPA polarizability +! + K0 =(EPSR - ONE + IC * EPSI) / VC ! Chi_0 + K1 = - Q2 * KF_SI * KF_SI * KF_SI / & ! + (8.0E0_WP * PI3 * N0 * N0) ! 'ALFL' eq. (2) + K2 = - Q2 / (FOUR * PI * N0 * K0) ! 'ALFL' eq. (2) +! +! --> direct calculation of G(omega) +! + IF(GQO_TYPE == 'NONE') THEN ! + GQO = ZEROC ! + ELSE IF(GQO_TYPE == 'ALFL') THEN ! + GQO = K1 + K2 * (GR(K) + IC * GI(K)) ! 'ALFL' eq. (2) + ELSE IF(GQO_TYPE == 'BACA') THEN ! + GQO = BACA_LFC(X,Z,RS,T) ! + ELSE IF(GQO_TYPE == 'BBSA') THEN ! + GQO = GR(K) + IC * GI(K) ! + ELSE IF(GQO_TYPE == 'COPI') THEN ! + GQO = COPI_LFC(X,Z,RS,T,EC_TYPE) ! + ELSE IF(GQO_TYPE == 'DABR') THEN ! + GQO = GR(K) + IC * GI(K) ! + ELSE IF(GQO_TYPE == 'FWRA') THEN ! + GQO = FWRA_LFC(X,Z,RS,T,GQ_TYPE) ! + ELSE IF(GQO_TYPE == 'HOK1') THEN ! + GQO = HOK1_LFC(X,Z,RS,T) ! + ELSE IF(GQO_TYPE == 'HOK2') THEN ! + GQO = HOK2_LFC(X,Z,RS,T) ! + ELSE IF(GQO_TYPE == 'JEWS') THEN ! + GQO = JEWS_LFC(X,Z,RS,T,GQ_TYPE) ! + ELSE IF(GQO_TYPE == 'KUG1') THEN ! + GQO = KUG1_LFC(X,Z) ! + ELSE IF(GQO_TYPE == 'KUG2') THEN ! + GQO = (GR(K) + IC * GI(K)) / K0 ! 'KUG2' eq. (92) + ELSE IF(GQO_TYPE == 'MDGA') THEN ! + GQO = MDGA_LFC(X,Z,RS,T,EC_TYPE) ! + ELSE IF(GQO_TYPE == 'NEV2') THEN ! + GQO = NEV2_LFC(X,Z,RS,T) ! + ELSE IF(GQO_TYPE == 'NLGA') THEN ! + GQO = NLGA_LFC(X,Z,RS,T) ! + ELSE IF(GQO_TYPE == 'SHMU') THEN ! + GQO = GR(K) + IC * GI(K) ! + ELSE IF(GQO_TYPE == 'STGU') THEN ! + GQO = GR(K) + IC * GI(K) ! + ELSE IF(GQO_TYPE == 'TOWO') THEN ! + GQO = (GR(K) + IC * GI(K)) / (VC * K0) ! 'TOWO' eq. (4.20) + ELSE IF(GQO_TYPE == 'UTI2') THEN ! + GQO = UTI2_LFC(X,Z,RS,T,GQ_TYPE,SQ_TYPE) ! + ELSE IF(GQO_TYPE == 'VISC') THEN ! + GQO = VISC_LFC(X,Z,RS,T,ETA,EC_TYPE) ! + END IF ! +! + GR(K) = REAL(GQO,KIND=WP) ! + GI(K) = AIMAG(GQO) ! +! + END DO ! +! + END SUBROUTINE LOCAL_FIELD_DYNAMIC_3D +! +!======================================================================= +! + FUNCTION ALFL_LFC(X,Z) +! +! This function computes imaginary part of the Alvarellos-Flores +! K+ part of the dynamic local-field correction in 3D +! +! References: (1) J. E. Alvarellos and F. Flores, +! J. Phys. F: Met. Phys. 15, 1929-1939 (1985) +! +! +! Warning : only the imagainary part is computed +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! +! +! Output parameters: +! +! * ALFL_LFC : Im[K+] for a given X (--> q) and Z (--> omega) +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,FOURTH + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI2 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z + REAL (WP) :: Y,Y2 + REAL (WP) :: ALFL_LFC + REAL (WP) :: U,V + REAL (WP) :: Q_SI + REAL (WP) :: COEF1,OMEGA_P,OMEGA_M + REAL (WP) :: KP1,KP2,KP + REAL (WP) :: UMX,UPX,UMX2,UPX2 +! + REAL (WP) :: ABS,SQRT +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + U = X * Z ! omega / (q * v_F) + V = Z * Y2 ! omega / omega_{k_F} +! + UPX = ABS(U + X) ! + UMX = ABS(U - X) ! + UPX2 = UPX * UPX ! + UMX2 = UMX * UMX ! +! + Q_SI = Y * KF_SI ! +! + COEF1 = - FOURTH / (PI2 * Q_SI) ! +! + OMEGA_P = ONE / Z + ONE / U ! omega+ / omega + OMEGA_M = ABS(ONE / Z - ONE / U) ! omega- / omega +! + KP1 = F_AF(ONE) - F_AF(UMX) + SQRT(F_AF(ONE + V)) - & ! + SQRT(F_AF(UMX2 + V)) ! +! ! ref. (1) eq. (8) + KP2 = F_AF(ONE) - F_AF(UPX) + SQRT(F_AF(ONE + V)) - & ! + SQRT(F_AF(UPX2 + V)) ! +! + IF((OMEGA_M <= ONE) .AND. (OMEGA_P > ONE)) THEN ! + KP = COEF1 * KP1 ! + ELSE ! + KP = COEF1 * (KP1 - KP2) ! + END IF ! +! + ALFL_LFC = KP ! +! + END FUNCTION ALFL_LFC +! +!======================================================================= +! + FUNCTION F_AF(X) +! +! This function computes the Alvarellos-Flores function F(x). +! +! +! References: (1) J. E. Alvarellos and F. Flores, +! J. Phys. F: Met. Phys. 15, 1929-1939 (1985) +! +! +! Input parameters: +! +! * X : dimensionless factor +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,HALF,THIRD +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: X2,X3 + REAL (WP) :: F_AF +! + REAL (WP) :: LOG,ABS +! + X2 = X * X ! + X3 = X * X2 ! +! + F_AF = HALF * X2 + & ! + HALF * ( (X + ONE) * LOG(ABS(X + ONE)) - & ! + (X - ONE) * LOG(ABS(X - ONE)) & ! + ) & ! ref. (1) eq. (6) + - HALF * THIRD *( (X3 + ONE) * LOG(ABS(X + ONE)) - & ! + (X3 - ONE) * LOG(ABS(X - ONE)) + & ! + X2 & ! + ) +! + END FUNCTION F_AF +! +!======================================================================= +! + FUNCTION BACA_LFC(X,Z,RS,T) +! +! This function computes the Barriga-Carrasco dynamic +! local-field correction in 3D +! +! References: (1) M. D. Barriga-Carrasco, Laser Part. Beams 26, +! 389-395 (2008) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * EC_TYPE : type of correlation energy functional +! * SQ_TYPE : structure factor approximation (3D) +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE PLASMON_ENE_SI + USE LOCAL_FIELD_STATIC, ONLY : LOCAL_FIELD_STATIC_3D,PVHF_LFC,ICUT_LFC +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: Q_SI,EQ_SI,EP_SI + REAL (WP) :: GQ1,GQ2 + REAL (WP) :: W +! + REAL (WP) :: SQRT +! + COMPLEX (WP) :: BACA_LFC +! + Q_SI = TWO * X * KF_SI ! +! + EQ_SI = HALF * H_BAR * H_BAR * Q_SI * Q_SI / M_E ! h_bar omega_q in SI +! + W = ENE_P_SI / (Z * EQ_SI) ! omega_p / omega +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,'PVHF',GQ1) ! G_PV(q) + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,'ICUT',GQ2) ! G_IU(q) +! + BACA_LFC = (GQ1 + IC * W * GQ2) / (ONE + IC * W ) ! ref. (1) eq. (20) +! + END FUNCTION BACA_LFC +! +!======================================================================= +! + FUNCTION BBSA_LFC(X,Z,RS,T) +! +! This function computes the Bachlechner-Böhm-Schinner dynamic +! local-field correction in 3D +! +! References: (1) M. E. Bachlechner, H. M. Böhm and A. Schinner, +! Physica B 183, 293-302 (1993) +! +! Warning : only the imaginary part is computed +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! --------> + check if q is Q_SI or Y +! + USE REAL_NUMBERS, ONLY : ONE,FOUR,HALF,THIRD + USE GAMMA_FUNC, ONLY : GAM_1_4TH + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : ALFA + USE GAMMA_ASYMPT, ONLY : GAMMA_0_3D,GAMMA_I_3D +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: Y,Y2,V + REAL (WP) :: G0,G1 + REAL (WP) :: C,D,ALPHA,BETA,OMEGA,Q_SI + REAL (WP) :: GR,GI + REAL (WP) :: BBSA_LFC +! + REAL (WP) :: SQRT +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + V = Z * Y2 ! omega / omega_{k_F} +! + ALPHA = ALFA('3D') ! +! + OMEGA = V * HALF * H_BAR * KF_SI * KF_SI / M_E ! omega + Q_SI = Y * KF_SI ! q in SI +! +! Computing the asymtotic parameters gamma_0 and gamma_inf +! + G0 = GAMMA_0_3D(RS,T) ! + G1 = GAMMA_I_3D(RS,T) ! +! + C = 23.0E0_WP * ALPHA / 60.0E0_WP ! + D = SQRT(32.0E0_WP * PI) / GAM_1_4TH ! ref. (1) eq. (B3b) + BETA = ( (G0 - G1) / (C * D * RS) )**(FOUR * THIRD) ! ref. (1) eq. (B3b) +! + GI= C * RS * OMEGA * Q_SI * Q_SI * & ! + ( BETA / (ONE + BETA * OMEGA * OMEGA) )**1.25E0_WP ! ref. (1) eq. (B3a) +! + BBSA_LFC = GI ! +! + END FUNCTION BBSA_LFC +! +!======================================================================= +! + FUNCTION COPI_LFC(X,Z,RS,T,EC_TYPE) +! +! This function computes the Constantin-Pitarke dynamic +! local-field correction in 3D +! +! References: (1) L. A. Constantin and J. M. Pitarke, +! Phys. Rev. B 75, 245127 (2007) +! (2) M. Corradini, R. Del SOle, G. Onida and M. Palummo, +! Phys. Rev. B 57, 14569-14571 (1998) +! +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * EC_TYPE : type of correlation energy functional +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THREE,FOUR,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE PI_ETC, ONLY : PI,PI2 + USE FERMI_AU, ONLY : KF_AU + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: Y,Y2,Q_AU,Q2,OM + REAL (WP) :: BB,CC,AN,CN + REAL (WP) :: A1,A2,B1,B2 + REAL (WP) :: XR,X3 + REAL (WP) :: AL,BE,N,F00 + REAL (WP) :: EC,D_EC_1,D_EC_2 +! + REAL (WP) :: SQRT +! + COMPLEX (WP) :: COPI_LFC + COMPLEX (WP) :: U,KN + COMPLEX (WP) :: NUM,DEN +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + Q_AU = Y * KF_AU ! q in a.u. + Q2 = Q_AU * Q_AU ! q^2 in a.u. + OM = HALF * Z * Q2 ! omega in a.u. +! +! Computing the correlation energy and its derivatives +! + EC = EC_3D(EC_TYPE,1,RS,T) ! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! + AN = EXP(10.5E0_WP / (ONE + RS)**6.5E0_WP) + HALF ! ref. (1) eq. (A4) + CN = AN * AN / 36.0E0_WP ! ref. (1) eq. (11) +! + U = - IC * OM ! +! + A1 = 2.15E0_WP ! \ + A2 = 0.435E0_WP ! | + B1 = 1.57E0_WP ! > ref. (2) + B2 = 0.409E0_WP ! | + XR = SQRT(RS) ! / +! + X3 = XR * XR * XR ! +! + AL = -0.0255184916E0_WP ! + BE = -0.691590707E0_WP ! + N = KF_AU * KF_AU * KF_AU / (THREE * PI2) ! electron density in a.u. + F00 = FOUR * PI * AL * N**BE ! ref. (1) eq. (6) +! + BB = (ONE + A1 * XR + A2 * X3) / (THREE + B1 * XR + B2 * X3) ! ref. (2) eq. (7) + CC = - PI * HALF * (EC + RS * D_EC_1) / KF_AU ! ref. (1) eq. (A2) +! + NUM = F00 * (ONE + AN * U + CN * U * U) ! \ + DEN = FOUR * PI * BB * (ONE + U * U) ! > ref. (1) eq. (A3) + KN = NUM / DEN ! / + print *,'EC,D_EC_1=',EC,D_EC_1 + print *,'BB,KN,Q2 =',BB,KN,Q2 + print *,'KF_AU',KF_AU + print *,'Y2',Y2 + print *,'CC',CC + print *,' ' +! + COPI_LFC = BB * (ONE - EXP(- KN * Q2)) + & ! ref. (1) eq. (12) + Y2 * CC / (ONE + ONE / Q2) ! +! + END FUNCTION COPI_LFC +! +!======================================================================= +! + FUNCTION DABR_LFC(X,Z,RS,T) +! +! This function computes the Dabrowski dynamic +! local-field correction in 3D +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! References: (1) B. Dabrowski, Phys. Rev. B 34, 4989-4995 (1986) +! +! Warning : only the imaginary part is computed +! +! +! Note: In ref. (1), q is in unit of k_F and h_bar omega in units of 2 E_F +! +! +! Author : D. Sébilleau +! +! Last modified : 8 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,FIVE, & + HALF,THIRD + USE GAMMA_FUNC, ONLY : GAM_1_4TH,GAM_3_4TH + USE PI_ETC, ONLY : SQR_PI + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE UTILITIES_1, ONLY : ALFA + USE LOCAL_FIELD_STATIC +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: DABR_LFC + REAL (WP) :: GQ1,GQ2 + REAL (WP) :: AQ,BQ + REAL (WP) :: C + REAL (WP) :: Y,Y2 + REAL (WP) :: Q_SI,Q2,EQ_SI,OM + REAL (WP) :: NUM,DEN +! + REAL (WP), PARAMETER :: D = FOUR * GAM_3_4TH / (SQR_PI * GAM_1_4TH) +! + Y = X + X ! q / k_F + Y2 = Y * Y ! q^2 in reduced units + Q_SI = TWO * X * KF_SI ! q in SI + Q2 = Q_SI * Q_SI ! q^2 in SI + EQ_SI = HALF * H_BAR * H_BAR * Q2 / M_E ! h_bar omega_q in SI +! + OM = Z * EQ_SI * HALF * EF_SI / H_BAR ! omega in reduced units +! + C = 23.0E0_WP * ALFA('3D') * RS / 60.0E0_WP ! +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,'PVHF',GQ1) ! Pathak-Vashishta LFC + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,'VASI',GQ2) ! Vashishta-Singwi LFC +! + NUM = GQ2 - GQ1 ! + DEN = C * D * Y2 ! +! + AQ = C * Y2 * (NUM / DEN)**(FIVE * THIRD) ! ref. (1) eq. (8) + BQ = (NUM / DEN)**(FOUR * THIRD) ! ref. (1) eq. (9) +! + DABR_LFC = AQ * OM / (ONE + BQ * OM * OM)**(FIVE / FOUR) ! ref. (1) eq. (6) +! + END FUNCTION DABR_LFC +! +!======================================================================= +! + FUNCTION FWRA_LFC(X,Z,RS,T,GQ_TYPE) +! +! This function computes the Forstmann-Wierling-Röpke dynamic +! local-field correction in 3D +! +! References: (1) C. Forstmann, A. Wierling and G. Röpke, +! Phys. Rev. E 81, 026405 (2010) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * GQ_TYPE : local-field correction type (3D) +! +! +! Note: in the notations of ref. (1), we have: +! +! * u = Z / X +! * z = X +! +! and +! +! LINDHARD_S(x) +! g(x) = --------------- +! 2 * x +! +! Author : D. Sébilleau +! +! Last modified : 17 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FIVE + USE COMPLEX_NUMBERS, ONLY : IC + USE PI_ETC, ONLY : PI_INV + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE IQ_FUNCTIONS_1, ONLY : IQ_KU1_3D + USE PLASMON_ENE_SI + USE UTILITIES_1, ONLY : ALFA + USE COULOMB_K, ONLY : COULOMB_FF + USE DFUNC_STATIC, ONLY : RPA1_EPS_S_LG + USE DFUNCL_STAN_DYNAMIC, ONLY : RPA1_EPS_D_LG_3D + USE LOCAL_FIELD_STATIC +! + USE UNITS, ONLY : UNIT +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: Y,Y2,Y4 + REAL (WP) :: EPSR0,EPSI0 + REAL (WP) :: EPSR1,EPSI1 + REAL (WP) :: Q_SI,COEF1,GQ1,GQ2 + REAL (WP) :: GQ_INF_3D + REAL (WP) :: EP_SI,V_C + REAL (WP) :: UPZ,UMZ + REAL (WP) :: OP2,CHI_02,ALPHA +! + COMPLEX (WP) :: FWRA_LFC + COMPLEX (WP) :: CHI0,CHI1 + COMPLEX (WP) :: D10,D20,C20 +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! Y^2 + Y4 = Y2 * Y2 ! Y^4 +! + Q_SI = TWO * X * KF_SI ! +! + ALPHA = ALFA('3D') ! +! + OP2 = (ENE_P_SI / H_BAR)**2 ! omega_p^2 +! + UPZ = Z / X + X ! u + z + UMZ = Z / X - X ! u - z +! +! Computing chi_o(q) and chi_0(q, omega) +! + CALL RPA1_EPS_S_LG(X,'3D',EPSR0,EPSI0) ! + CALL RPA1_EPS_D_LG_3D(X,Z,EPSR1,EPSI1) ! + CALL COULOMB_FF('3D',UNIT,Q_SI,ZERO,V_C) ! +! + CHI0 = (ONE - EPSR0 - IC * EPSI0) / V_C ! + CHI1 = (ONE - EPSR1 - IC * EPSI1) / V_C ! +! + CHI_02 = PI_INV * ALPHA * RS ! a_0 * k_F = 1/ (alpha * rs) +! + D10 = OP2 / (EPSR0 - ONE + IC * EPSI0) ! ref. (1) eq. (25) + D20 = ( 12.0E0_WP * Y2 / FIVE + Y4) * & ! + (EF_SI / H_BAR)**2 - D10 ! ref. (1) eq. (25) + C20 = D10 * (CHI0 / CHI1 - ONE) / D20 + X * X / D20 ! ref. (1) eq. (24) +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ1) ! G(q,0) + GQ2 = IQ_KU1_3D(X) ! G(q,inf) +! + FWRA_LFC = GQ1 + (GQ2 - GQ1) * C20 ! ref. (1) eq. (23) +! + END FUNCTION FWRA_LFC +! +!======================================================================= +! + FUNCTION HOK1_LFC(X,Z,RS,T) +! +! This function computes the Hong-Kim dynamic +! local-field correction in 3D +! +! References: (1) J. Hong and C. Kim, Phys. Rev. A 43, 1965-1971 (1991) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Note: q in units of 1/a0 and omega in units of omega_p +! +! +! Author : D. Sébilleau +! +! Last modified : 7 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,HALF,THIRD + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,E,M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE LOCAL_FIELD_STATIC, ONLY : LOCAL_FIELD_STATIC_3D,ICUT_LFC + USE STRUCTURE_FACTOR_STATIC, ONLY : STFACT_STATIC_3D + USE IQ_FUNCTIONS_1, ONLY : IQ_KU1_3D + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: GAMMA,XX,SQ,GQ1,ETA2 + REAL (WP) :: Q_SI,Q1,Q2,EQ,OM +! + REAL (WP) :: SQRT +! + COMPLEX (WP) :: HOK1_LFC +! + Q_SI = TWO * X * KF_SI ! q in SI + Q1 = Q_SI * BOHR ! q in units of 1/a0 + Q2 = Q1 * Q1 ! q^2 in units of 1/a0 +! + EQ = HALF * H_BAR * H_BAR * Q_SI * Q_SI / M_E ! h_bar omega_q in SI + OM = Z * EQ / ENE_P_SI ! omega in units of omega_p +! + GAMMA = E * E / (RS * BOHR * K_B * T) ! plasma coupling strength + XX = SQRT(THREE * GAMMA) * OM / Q1 ! +! + CALL STFACT_STATIC_3D(X,RS,T,'TWA','ICUT',SQ) ! +! + GQ1 = ONE + (ONE - ONE / SQ) * Q2 * THIRD / GAMMA ! + ETA2 = 1.5E0_WP * GAMMA * (ONE - IQ_KU1_3D(X)) / Q2 + & ! ref. (1) eq. (28) + HALF * (ONE - ONE / SQ) ! +! + HOK1_LFC = GQ1 - ETA2 * THIRD * Q2 * Q(XX) / GAMMA ! ref. (1) eq. (29) +! + END FUNCTION HOK1_LFC +! +!======================================================================= +! + FUNCTION Q(X) +! +! This function computes Q(x) as given by Hong and Kim for +! the calculation of their dynamical 3D local-field corrections +! +! References: (1) J. Hong and C. Kim, Phys. Rev. A 43, 1965-1971 (1991) +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE EXT_FUNCTIONS, ONLY : W ! Vlasov function W(x) +! + IMPLICIT NONE +! + REAL (WP) :: X +! + COMPLEX (WP) :: Q +! + Q = X * X - ONE + ONE / W(X) ! +! + END FUNCTION Q +! +!======================================================================= +! + FUNCTION HOK2_LFC(X,Z,RS,T) +! +! This function computes the Hong-Kim dynamic +! local-field correction in 3D +! +! References: (1) J. Hong and C. Kim, Phys. Rev. A 43, 1965-1971 (1991) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,HALF,THIRD + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,E,M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI + USE STRUCTURE_FACTOR_STATIC, ONLY : STFACT_STATIC_3D + USE IQ_FUNCTIONS_1, ONLY : IQ_KU1_3D + USE EXT_FUNCTIONS, ONLY : DAWSON ! Dawson function D(x) + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: XX,GQ1,GQ2,SQ + REAL (WP) :: Q_SI,Q1,Q2,GAMMA + REAL (WP) :: EQ,OM +! + REAL (WP) :: SQRT,EXP +! + COMPLEX (WP) :: HOK2_LFC,Q,ZZ,QQ +! + COMPLEX (WP) :: CMPLX +! + Q_SI = TWO * X * KF_SI ! + Q1 = Q_SI * BOHR ! q in units of 1/a0 + Q2 = Q1 * Q1 ! q^2 in units of 1/a0 +! + EQ = HALF * H_BAR * H_BAR * Q_SI * Q_SI / M_E ! h_bar omega_q in SI + OM = Z * EQ / ENE_P_SI ! omega in units of omega_p +! + GAMMA = E * E / (RS * BOHR * K_B * T) ! plasma coupling strength + XX = SQRT(THREE * GAMMA) * OM / Q1 ! + ZZ = ONE - TWO * XX * DAWSON(XX) + IC * SQRT(PI) * XX & ! + * EXP(XX * XX) ! + QQ = ONE / ZZ + TWO * XX - ONE ! +! + CALL STFACT_STATIC_3D(X,RS,T,'TWA','ICUT',SQ) ! +! + GQ1 = ONE + (ONE - ONE / SQ) * Q2 * THIRD / GAMMA ! + GQ2 = IQ_KU1_3D(X) ! +! + HOK2_LFC=CMPLX(GQ1 - HALF * (GQ1 - GQ2) * QQ,KIND=WP) ! ref. (1) eq. (29) +! + END FUNCTION HOK2_LFC +! +!======================================================================= +! + FUNCTION JEWS_LFC(X,Z,RS,T,GQ_TYPE) +! +! This function computes the Jewsbury dynamic +! local-field correction in 3D +! +! References: (1) P. Jewsbury, Aust. J. Phys. 32, 361-368 (1979) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! * SQ_TYPE : structure factor approximation (3D) +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : FOUR,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE PLASMON_ENE_SI + USE LOCAL_FIELD_STATIC +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: Y,Y2 + REAL (WP) :: GAM0,GAM1,GQ1,GQ2 + REAL (WP) :: Q_SI,EQ_SI,EP_SI,W +! + REAL (WP) :: SQRT +! + COMPLEX (WP) :: JEWS_LFC +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + Q_SI = Y * KF_SI ! +! + EQ_SI = HALF * H_BAR * H_BAR * Q_SI * Q_SI / M_E ! h_bar omega_q in SI +! + W = (Z * EQ_SI) / ENE_P_SI ! omega / omega_p +! + GAM0 = 0.033E0_WP * RS ! + GAM1 = 0.15E0_WP * SQRT(RS) ! +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ1) ! +! + GQ2 = GAM0 + GAM1 * Y2 ! ref. (1) eq. (23) +! + JEWS_LFC = GQ1 + IC * GQ2 * W ! ref. (1) eq. (20) +! + END FUNCTION JEWS_LFC +! +!======================================================================= +! + FUNCTION KUG1_LFC(X,Z) +! +! This function computes the Kugler dynamic +! local-field correction in 3D +! +! References: (1) A. Kugler, J. Stat. Phys. 12, 35-87 (1975) +! +! Note: Here, we have used the fact that +! +! eps = 1 - V_C * chi_0 = 1 + (q_TF / q)^2 * LINDHARD_FUNCTION +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,THREE,FOUR + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI,PI2 + USE LINDHARD_FUNCTION, ONLY : LINDHARD_D +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z + REAL (WP) :: Y,Y2 + REAL (WP) :: U,U2 + REAL (WP) :: Q_SI + REAL (WP) :: COEF1,COEF2,COEF3 + REAL (WP) :: PPR,PPI,LR0,LI0 +! + REAL (WP) :: LOG +! + COMPLEX (WP) :: KUG1_LFC +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! Y^2 +! + U = X * Z ! omega / (q * v_F) + U2 = U * U ! +! + Q_SI = Y * KF_SI ! +! + COEF1 = M_E * KF_SI / (FOUR * PI2 * H_BAR * H_BAR) * Y2 ! ref. (1) eq. (108) + COEF2 = THREE * M_E * M_E * VF_SI * U * Y2 / & ! + (16.0E0_WP * PI * H_BAR * H_BAR * H_BAR) ! +! + PPR = COEF1 * ( & ! + ONE - 1.5E0_WP * U2 - 0.75E0_WP * U * (ONE - U2) * & ! ref. (1) eq. (108) + LOG( ABS((U + ONE) / (U - ONE)) ) & ! + ) ! + PPI = COEF2 * (ONE - U2) ! ref. (1) eq. (106) +! + IF(U >= ONE) PPI = ZERO ! +! + CALL LINDHARD_D(X,Z,'3D',LR0,LI0) ! +! + COEF3 = - PI2 * H_BAR / (M_E * KF_SI) ! - (q_TF / q)^2 / V_C +! + KUG1_LFC = COEF3 * (PPR + IC * PPI) / (LR0 + IC * LI0) ! ref. (1) eq. (92) +! + END FUNCTION KUG1_LFC +! +!======================================================================= +! + FUNCTION KUG2_LFC(X,Z) +! +! This function computes the Kugler dynamic +! local-field correction in 3D +! +! Warning : only the imaginary part is computed +! +! References: (1) A. Kugler, J. Stat. Phys. 12, 35-87 (1975) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! --> UNFINISHED: real part missing !!! +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,EIGHT, & + HALF,THIRD + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI,PI2 + USE LINDHARD_FUNCTION, ONLY : LINDHARD_D +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z + REAL (WP) :: Y,Y2 + REAL (WP) :: U,V,V2 + REAL (WP) :: COEF1,COEF2,COEF3,COEF4 + REAL (WP) :: UMX,UPX,OMV,OPV + REAL (WP) :: PP1,PP2,PPI + REAL (WP) :: LR0,LI0 + REAL (WP) :: KUG2_LFC +! + REAL (WP) :: LOG,ABS,SQRT +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + U = X * Z ! omega / (q * v_F) + V = Z * Y2 ! omega / omega_{k_F} + V2 = V * V ! +! + COEF1 = M_E * KF_SI / (64.0E0_WP * PI * H_BAR * H_BAR) * Y ! + COEF2 = M_E * KF_SI / (32.0E0_WP * PI * H_BAR * H_BAR) ! + COEF3 = COEF2 * U ! +! + UMX = U - X ! + UPX = U + X ! + OMV = ONE - V ! + OPV = ONE + V ! +! + PP1 = COEF1 * ( & ! + TWO * V + OPV**(-HALF) * & ! + (FOUR + TWO * V - HALF * V * V) * & ! + LOG(ABS((ONE + SQRT(V) + ONE) / & ! + (ONE + SQRT(V) - ONE))) - & ! + OMV**(-HALF) * & ! + (FOUR - TWO * V - HALF * V * V) * & ! + LOG(ABS((ONE - SQRT(V) + ONE) / & ! + (ONE - SQRT(V) - ONE))) & ! + ) + & ! ref. (1) eq. (104a) + COEF3 * ( & ! + EIGHT * LOG(V) - 16.0E0_WP * LOG(TWO) + & ! + OPV**(-HALF) * & ! + (FOUR + TWO * V - HALF * V * V) * & ! + LOG(ABS((ONE + SQRT(V) + ONE) / & ! + (ONE + SQRT(V) - ONE))) - & ! + OMV**(-HALF) * & ! + (FOUR - TWO * V - HALF * V * V) * & ! + LOG(ABS((ONE - SQRT(V) + ONE) / & ! + (ONE - SQRT(V) - ONE))) & ! + ) ! +! + PP2 = COEF2 * UMX * ( UMX**2 - ONE + & ! + FOUR * LOG(UMX**2 - ONE) & ! + ) - & ! + COEF2 * UPX * ( UPX**2 - ONE + & ! + FOUR * LOG(UPX**2 - ONE) & ! + ) + & ! + COEF2 * ( & ! + UPX * (V + FOUR * LOG(V)) - & ! + EIGHT * UMX * LOG(TWO) + & ! + UPX * (ONE + V)**1.5E0_WP * & ! + (FOUR + TWO * V - HALF * V2) * & ! + LOG((SQRT(ONE + V) + ONE) / & ! + (SQRT(ONE + V) - ONE)) + & ! + 1.5E0_WP * (ONE + TWO * UMX**2 - & ! + THIRD * UMX**4) * & ! + LOG(ABS((V - ONE + U) / (V - ONE - U))) - & ! + 1.5E0_WP * (ONE + TWO * UPX**2 - & ! + THIRD * UPX**4) * & ! + LOG(ABS((V + ONE + U) / (V + ONE - U))) & ! + ) ! +! + IF(U <= (ONE - U / Z)) THEN ! + IF(X <= ONE) THEN ! + PPI = PP1 ! + ELSE ! + PPI = ZERO ! + END IF ! + ELSE ! + IF(U <= (ONE + U / Z)) THEN ! + PPI = PP2 ! + ELSE ! + PPI = ZERO ! + END IF ! + END IF ! +! + CALL LINDHARD_D(X,Z,'3D',LR0,LI0) ! +! + COEF4 = - PI2 * H_BAR / (M_E * KF_SI) ! - (q_TF / q)^2 / V_C +! + KUG2_LFC = COEF4 * PPI / (LR0 + IC *LI0) ! ref. (1) eq. (92) +! + END FUNCTION KUG2_LFC +! +!======================================================================= +! + FUNCTION MDGA_LFC(X,Z,RS,T,EC_TYPE) +! +! This function computes the Mithen-Daligault-Gregori dynamic +! local-field correction in 3D +! +! References: (1) J. P. Mithen, J. Daligault and G. Gregori, +! Phys. Rev. E 85, 056407 (2012) +! (2) S. Ichimaru, "Statistical Plasma Physics", Vol1, +! p. 72, (CRC Press, 2018) +! +! Note: the coefficient in ref. (1) eq. (11) is misprinted. +! Ref. (2) eq. (3.77) gives the correct one +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * EC_TYPE : type of correlation energy functional +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,E,M_E,K_B + USE FERMI_SI, ONLY : KF_SI + USE STRUCTURE_FACTOR_STATIC, ONLY : STFACT_STATIC_3D + USE RELAXATION_TIME_STATIC, ONLY : TAIQ_RT_3D + USE IQ_FUNCTIONS_1, ONLY : IQ_KU1_3D +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: Y,Y2,V,R_S + REAL (WP) :: Q_SI,Q2,SQ,GQ1,GQ2 + REAL (WP) :: GAMMA,OMEGA,COEF + REAL (WP) :: TAU_M +! + COMPLEX (WP) :: MDGA_LFC +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + V = Z * Y2 ! omega / omega_{k_F} +! + Q_SI = TWO * X * KF_SI ! q in SI + Q2 = Q_SI * Q_SI ! q^2 +! + R_S = RS * BOHR ! r_s in SI +! + TAU_M = TAIQ_RT_3D(X,RS,T) ! +! + GAMMA = E * E / (R_S * K_B * T) ! plasma coupling parameter + OMEGA = V * HALF * H_BAR * KF_SI * KF_SI / M_E ! omega in SI + COEF = THREE * GAMMA / (R_S * R_S * Q2) ! n * V(q) / (k_b * T) +! + CALL STFACT_STATIC_3D(X,RS,T,'TWA','ICUT',SQ) ! +! + GQ1 = ONE + (ONE - ONE / SQ) * COEF ! ref. (1) eq. (11) + GQ2 = TWO * IQ_KU1_3D(X) ! ref. (1) eq. (12) +! + MDGA_LFC = (GQ1 - IC * OMEGA * TAU_M * GQ2) / & ! ref. (1) eq. (13) + (ONE - IC * OMEGA * TAU_M) ! +! + END FUNCTION MDGA_LFC +! +!======================================================================= +! + FUNCTION NEV2_LFC(X,Z,RS,T) +! +! This function computes the Nevalinna three-moment dynamic +! local-field correction in 3D +! +! +! References: (1) D. Yu. Dubovtsev, PhD Thesis, +! Universitat Politècnica de València (2019) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE COMPLEX_NUMBERS, ONLY : ONEC,IC + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PLASMON_ENE_SI + USE DFUNCL_STAN_DYNAMIC, ONLY : RPA1_EPS_D_LG_3D + USE LOSS_MOMENTS + USE DF_VALUES, ONLY : NEV_TYPE + USE DAMPING_SI + USE NEVALINNA_FUNCTIONS +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: U,Q_SI + REAL (WP) :: C0,C2,C4 + REAL (WP) :: OM12,OM22 + REAL (WP) :: EPSR,EPSI + REAL (WP) :: OM,OM2,OMP,OMP2 + REAL (WP) :: Q2 +! + COMPLEX (WP) :: NEV2_LFC + COMPLEX (WP) :: EPS,NUM,DEN +! + U = X * Z ! omega / (q * v_F) + OM = U * Q_SI * VF_SI ! omega in SI + OM2 = OM * OM ! + OMP = ENE_P_SI / H_BAR ! omega_p + OMP2 = OMP * OMP ! +! +! Computing the moments of the loss function +! + CALL LOSS_MOMENTS_AN(X,C0,C2,C4) ! +! + OM12 = C2 / C0 ! + OM22 = C4 / C2 ! +! +! Computing the RPA dielectric function +! + CALL RPA1_EPS_D_LG_3D(X,Z,EPSR,EPSI) ! + EPS = EPSR + IC * EPSI ! +! +! Computing the Nevanlinna function Q2 +! + Q2 = NEVAN2(X,Z,RS,T,TAU,NEV_TYPE) ! +! + NUM = OM * (OM2 - OM22) + Q2 * (OM2 - OM12) ! + DEN = OMP2 * (OM + Q2) ! +! + NEV2_LFC = ONEC + ONEC / (ONEC - EPS) + NUM / DEN ! ref. (1) eq. (4.13) +! + END FUNCTION NEV2_LFC +! +!======================================================================= +! + FUNCTION NLGA_LFC(X,Z,RS,T) +! +! This function computes the Nagy-Laszlo-Giber dynamic +! local-field correction in 3D +! +! +! References: (1) I. Nagy, J. Laszlo and J. Giber, +! Z. Phys. A - Atoms and Nuclei 321, 221-223 (1985) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : THREE,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE PI_ETC, ONLY : PI + USE LF_VALUES, ONLY : GQ_TYPE + USE LOCAL_FIELD_STATIC, ONLY : LOCAL_FIELD_STATIC_3D + USE LINDHARD_FUNCTION, ONLY : LINDHARD_S +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: U,X2 + REAL (WP) :: GQR,GQI,LR,LI +! + COMPLEX (WP) :: NLGA_LFC +! + U = X * Z ! omega / (q * v_F) + X2 = X * X ! +! +! Computing the static local field correction G(q) +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQR) ! G(q) +! +! Computing the static Lindhard function L(q) +! + CALL LINDHARD_S(X,'3D',LR,LI) ! L(X) +! + GQI = HALF * PI * U * X2 * (THREE * HALF - GQR / X2) / LR ! ref. (1) +! + NLGA_LFC = GQR + IC * GQI ! +! + END FUNCTION NLGA_LFC +! +!======================================================================= +! + FUNCTION RIA1_LFC(X,Z,RS,T,EC_TYPE) +! +! This function computes the Richardson-Ashcroft dynamic +! local-field correction in 3D +! +! +! --> COMPUTES G_s(q,i omega) <-- +! +! +! References: (1) C. F. Richardson and N. W. Ashcroft, Phys. Rev. B 50, +! 8170-8181 (1994) +! (2) S. H. Vosko, L. Wilk and M. Nusair, Can. J. Phys. 58 +! 1200-1211 (1980) +! (3) M. Lein, E. K. U. Gross and J. P. Perdew, Phys. Rev. B 61, +! 13431-13437 (2000) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * EC_TYPE : type of correlation energy functional +! +! +! Output parameters: +! +! * RIA1_LFC : G_s(q,i omega) + G_n(q, i omega) +! +! 2 +! d E_c +! Note 1: The function -------- in ref. (1) eq. (39) is the spin stiffness. +! d zeta^2 +! +! We calculate it using ref. (2) eq. (4.9) +! +! Note 2: Reference (3) contains corrections of misprints in ref. (1) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,EIGHT,NINE, & + HALF,THIRD,FOURTH,FIFTH,SIXTH + USE COMPLEX_NUMBERS, ONLY : + USE PI_ETC, ONLY : PI,PI2 + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE UTILITIES_1, ONLY : ALFA + USE PC_VALUES, ONLY : GR0_MODE + USE GR_0, ONLY : GR_0_3D + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: RIA1_LFC + REAL (WP) :: Y,Y2,Y4,Y6,Y8 + REAL (WP) :: Q_SI,Q2,EQ_SI,OM + REAL (WP) :: ALPHA,AL + REAL (WP) :: LS0,LSI,GR0,GS + REAL (WP) :: LN0,LNI + REAL (WP) :: EC,D_EC_1,D_EC_2 + REAL (WP) :: LPL,A,C,SSN + REAL (WP) :: AS,BS,CS + REAL (WP) :: NUM,DEN + REAL (WP) :: GN,AN,BN,CN + REAL (WP) :: G_S,G_N +! + REAL (WP) :: LOG,SQRT +! + ALPHA = ALFA('3D') ! + AL = 0.9E0_WP ! +! +! Computation of the spin stiffness alpha_c = SSN +! + A = - THIRD / PI2 ! + C = - A * ( LOG(16.0E0_WP * PI / ALPHA) - & ! ref. (2) eq. (4.10) + THREE + 0.531504E0_WP ) ! + SSN = A * LOG(RS) + C ! ref. (2) eq. (4.9) +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! + Y4 = Y2 * Y2 ! + Y6 = Y4 * Y2 ! + Y8 = Y6 * Y2 ! +! + Q_SI = TWO * X * KF_SI ! q in SI + Q2 = Q_SI * Q_SI ! q^2 in SI + EQ_SI = HALF * H_BAR * H_BAR * Q2 / M_E ! h_bar omega_q in SI +! + OM = Z * EQ_SI ! omega +! +! Computing the correlation energy and its derivatives +! + EC = EC_3D(EC_TYPE,1,RS,T) ! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! +! Computing the asymptotic lambda functions +! + LSI = THREE * FIFTH - TWO * PI * ALPHA * FIFTH * ( & ! + RS * RS * D_EC_1 + TWO * RS * EC & ! ref. (3) eq. (RA:40) + ) ! + LNI = THREE * PI * ALPHA * RS * (EC + RS * D_EC_1) ! ref. (1) eq. (43) +! + LPL = ONE - THREE * HALF * & ! + (TWO * THIRD * PI)**(TWO * THIRD) * RS * SSN ! ref. (3) eq. (RA:39) + LN0 = - LPL * 0.11E0_WP * RS / (ONE + 0.33E0_WP * RS) ! ref. (1) eq. (44) + LS0 = ONE + THIRD * PI * ALPHA * RS * RS * D_EC_1 - & ! + SIXTH * PI * ALPHA * RS * RS * RS * D_EC_2 - & ! ref. (1) eq. (38) + LN0 ! +! +! Computing the a_s, b_s and c_s coefficients +! + GR0 = GR_0_3D(RS,GR0_MODE) ! g(0) + GS = NINE / (16.0E0_WP * (ONE - GR0)) * LSI + FOURTH + & ! + THREE * FOURTH * (ONE - ONE / AL) ! +! + AS = LSI + (LS0 - LSI) / (ONE + GS * GS * OM * OM) ! ref. (1) eq. (56) + NUM = FOUR * THIRD - ONE / AL + THREE * FOURTH * LSI / & ! + (ONE - GR0) + DEN = ONE + GS * OM ! ref. (1) eq. (55) + CS = THREE * FOURTH * LSI / (ONE - GR0) - NUM / DEN ! + BS = AS / ( THREE * AS * (ONE + OM)**4 - & ! + EIGHT * THIRD * (ONE - GR0) * (ONE + OM)**3 - & ! ref. (1) eq. (54) + TWO * CS * (ONE - GR0) * (ONE + OM)**4 & ! + ) ! +! +! Computing G_s +! + NUM = AS * Y2 + BS * TWO * THIRD * (ONE - GR0) * Y8 ! + DEN = ONE + CS * Y2 + BS * Y8 ! +! + G_S = NUM / DEN ! ref. (1) eq. (53) +! +! Computing the a_n, b_n and c_n coefficients +! + GN = 0.68E0_WP ! + AN = LNI + (LN0 - LNI) / (ONE + GN * GN * OM * OM) ! ref. (1) eq. (65) + CN = THREE * GN / ( 1.18E0_WP * (ONE + GN * OM) ) - & ! + ONE / (ONE + GN * GN * OM * OM) * ( & ! + (LN0 + THIRD * LNI) / (LN0 + TWO * THIRD * LNI) + & ! ref. (1) eq. (64) + THREE * GN / ( 1.18E0_WP * (ONE + GN * OM) ) & ! + ) ! + BN = - THREE * ( AN + LNI + & ! + TWO * THIRD * LNI * CN * (ONE + GN * OM) + & ! + SQRT( AN + LNI + & ! + TWO * THIRD * LNI * CN * & ! + (ONE + GN * OM)**2 + & ! + FOUR * THIRD * AN * LNI & ! + ) & ! + ) / ( TWO * LNI * (ONE + GN * OM)**2 ) ! +! + NUM = AN * Y2 - THIRD * BN * LNI * Y6 ! + DEN = ONE + CN * Y2 + BN * Y4 ! +! + G_N = NUM / DEN ! ref. (1) eq. (62) +! + RIA1_LFC = G_S + G_N ! ref. (1) eq. (31) +! + END FUNCTION RIA1_LFC +! +!======================================================================= +! + FUNCTION SHMU_LFC(X,Z,RS) +! +! This function computes the Shah-Mukhopadhyay dynamic +! local-field correction in 3D +! +! +! References: (1) C. Shah and G. Mukhopadhyay, Pramana 26, +! 441-458 (1986) +! +! +! Warning : only the imaginary part is computed +! +! +! +! Intermediate parameters: +! +! * Y : dimensionless factor --> Y = X+X = q / k_F +! * U : dimensionless factor --> U = X*Z = omega / (q * v_F) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! +! r'' RPA +! Note: In order to compute Q (q,omega) = Im [ epsilon (q,omega) ], +! we use the fact that +! +! omega 1 omega +! ---------- = ---- ---------- +! (q * v_F) 4X omega_F +! +! +! omega_q +! ----------- = X +! (q * v_F) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,SIX,NINE, & + HALF,SMALL + USE PI_ETC, ONLY : PI + USE FERMI_SI, ONLY : KF_SI + USE FERMI_AU, ONLY : KF_AU,VF_AU + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE UTILITIES_1, ONLY : ALFA + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + INTEGER :: IQ,IT,IO ! indices for integration loops + INTEGER :: ID + INTEGER, PARAMETER :: N_MAX = 200 ! max. number of points for integrations +! + REAL (WP), INTENT(IN) :: X,Z,RS + REAL (WP) :: SHMU_LFC + REAL (WP) :: Y,Y2,U,OM + REAL (WP) :: K_TF_SI + REAL (WP) :: Q_SI,Q_AU,Q1,Q2,R2 + REAL (WP) :: QQO(N_MAX),QQT(N_MAX),QQQ(N_MAX) + REAL (WP) :: QR1,QR2 + REAL (WP) :: T2,U1,U2,XP,XS,TP,TS + REAL (WP) :: QP,QS,T,O1,OO + REAL (WP) :: Q_STEP,T_STEP,O_STEP + REAL (WP) :: AO,AT,AQ + REAL (WP) :: ALPHA +! + REAL (WP),PARAMETER :: Q_MAX = SIX +! + REAL (WP) :: FLOAT,SQRT +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + Q_SI = Y * KF_SI ! q in SI + Q_AU = Y * KF_AU ! q in a.u. + Q2 = Q_AU * Q_AU ! q^2 in a.u. + R2 = KF_AU * KF_AU / (KF_SI * KF_SI) ! for unit change +! + U = X * Z ! omega / (q * v_F) + OM = U * Q_AU * VF_AU ! omega +! + ALPHA = ALFA('3D') ! +! +! Computing the Thomas_Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR('3D',K_TF_SI) +! +! Loop on q' for q'-integration +! + Q_STEP = (Q_MAX - SMALL) / FLOAT(N_MAX-1) ! q-step + DO IQ = 1, N_MAX ! start of q' loop +! + QP = SMALL + FLOAT(IQ-1) * Q_STEP ! q' +! +! Loop on t for t-integration +! + T_STEP = TWO / FLOAT(N_MAX-1) ! + DO IT = 1, N_MAX ! start of t loop +! + T = - ONE + FLOAT(IT-1) * T_STEP ! t + QS = SQRT(Q2 + QP * QP - TWO * Q_AU * QP * T) ! q" +! +! Loop on omega1 for omega1-integration +! + O_STEP = OM / FLOAT(N_MAX-1) ! + DO IO = 1, N_MAX ! start of omega-1 loop +! + O1 = FLOAT(IO-1) * O_STEP ! omega_1 + OO = OM - O1 ! omega - omega_1 +! +! r'' r'' +! Computing Q (q',omega_1) and Q (q",omega - omega_1) +! + U1 = O1 / (Q_AU * VF_AU) ! + U2 = OO / (Q_AU * VF_AU) ! + XP = QP * HALF / KF_AU ! X for q' + XS = QS * HALF / KF_AU ! X for q" + TP = K_TF_SI * K_TF_SI * T2 / (QP * QP) ! (K_TF_SI / QP_SI)^2 + TS = K_TF_SI * K_TF_SI * T2 / (QS * QS) ! (K_TF_SI / QS_SI)^2 +! +! r'' +! 1) Q1 = Q (q',omega_1) +! + IF(U1 <= ONE - XP) THEN ! + Q1 = HALF * PI * U1 * TP ! + ELSE IF(ONE - XP > U1 .AND. U1 <= ONE + XP) THEN ! + Q1 = PI * ( ONE - (ONE - XP)**2 )* TP / (FOUR * XP) ! + ELSE ! + Q1 = ZERO ! + END IF ! +! +! r'' +! 2) Q2 = Q (q",omega - omega_1) +! + IF(U2 <= ONE - XS) THEN ! + Q2 = HALF * PI * U2 * TS ! + ELSE IF(ONE - XS > U2 .AND. U2 <= ONE + XS) THEN ! + Q2 = PI * ( ONE - (ONE - XS)**2 )* TS / (FOUR * XS) ! + ELSE ! + Q2 = ZERO ! + END IF ! +! +! Storing integrand function +! + QQO(IO) = Q1 * Q2 ! +! + END DO ! end of omega-1 loop +! +! Performing the omega-1 integration +! + ID = 2 ! + CALL INTEGR_L(QQO,Q_STEP,N_MAX,N_MAX,AO,ID) ! +! +! Storing integrand function +! + QQT(IT) = Q_AU * QS * T * AO ! +! + END DO ! end of t loop +! +! Performing the t integration +! + ID = 2 ! + CALL INTEGR_L(QQT,T_STEP,N_MAX,N_MAX,AT,ID) ! +! +! Storing integrand function +! + QQQ(IQ) = QP * QP * AT ! +! + END DO ! end of q' loop +! +! Performing the q' integration +! + ID = 2 ! + CALL INTEGR_L(QQQ,Q_STEP,N_MAX,N_MAX,AQ,ID) ! +! + SHMU_LFC = NINE * AQ / (32.0E0_WP * ALPHA * RS) ! ref. (1) eq. (41) +! + END FUNCTION SHMU_LFC +! +!======================================================================= +! + FUNCTION STGU_LFC(X,Z,RS,T) +! +! This function computes the Sturm-Gusarov dynamic +! local-field correction in 3D +! +! +! References: (1) K. Sturm and A. Gusarov, Phys. Rev. B 62, +! 16474-16491 (2000) +! +! +! Warning : only the imaginary part is computed +! +! +! Note: In ref. (1), q is in unit of k_F and h_bar omega in units of E_F +! +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Intermediate parameters: +! +! * Y : dimensionless factor --> Y = X + X = q / k_F +! * U : dimensionless factor --> U = X * Z = omega / (q * v_F) +! * V : dimensionless factor --> V = 2 * U * Y = h_bar omga / E_F +! +! +! Warning : only the imaginary part is computed +! +! +! Note: From ref. (1) eq. (3.22), we have +! +! Im [ epsilon (q,omega) ] +! ABC +! Im [ G(q,omega) ] = ------------------------------- +! 2 +! [ epsilon (q,omega) - 1 ] +! RPA +! +! We use then the HIGH FREQUENCY approximation eq. (3.4) +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,INF + USE SQUARE_ROOTS, ONLY : SQR2 + USE PI_ETC, ONLY : PI + USE FERMI_SI, ONLY : EF_SI + USE DF_VALUES, ONLY : D_FUNC + USE PLASMON_ENE_SI + USE DFUNCL_STAN_DYNAMIC +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: STGU_LFC + REAL (WP) :: Y,Y2,U,V + REAL (WP) :: OM,OP + REAL (WP) :: EPSR,EPSI + REAL (WP) :: NUM,DEN,EABC +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! q^2 in reduced input + U = X * Z ! omega / (q * v_F) + V = TWO * U * Y ! h_bar omega / E_F +! + OP = ENE_P_SI / EF_SI ! omega_p in reduced unit + OM = V ! omega in reduced unit +! +! Computing the dielectric function epsilon(q,E) +! + CALL DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNC,1,EPSR,EPSI) ! +! + NUM = 23.0E0_WP * PI * OP**6 * Y2 ! + DEN = 40.0E0_WP * SQR2 * OM**5.5E0_WP ! + EABC = NUM / DEN ! ref. (1) eq. (3.4) +! + DEN = ( (EPSR - ONE) * (EPSR - ONE) + EPSI * EPSI ) ! | epsilon - 1|^2 + STGU_LFC = EABC / DEN ! ref. 1 eq. (3.22) +! + END FUNCTION STGU_LFC +! +!======================================================================= +! + FUNCTION TOWO_LFC(X,Z,RS) +! +! This function computes the Toigo-Woodruff dynamic +! local-field correction in 3D +! +! +! References: (1) V. D. Gorobchenko, V. N. Kohn and E. G. Maksimov, +! in "Modern Problems in Condensed Matter" Vol. 24, +! L. V. Keldysh, D. A. Kirzhnitz and A. A. Maradudin ed. +! pp. 87-219 (North-Holland, 1989) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Notations: We have h_bar omega / E_F = 2 * U * Y = Z * Y2 +! +! Note: q in units of k_F and omega in units of E_F / h_bar +! +! Warning : >>> This subroutine computes Im[ P ] <<< +! >>> where P is related to G by <<< +! +! +! P(q,omega) +! G(q, omega) = -------------------------- eq. (4.20) +! V_C(q) * Chi_0(q,omega) +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,EIGHT,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS + REAL (WP) :: Y,Y2,U + REAL (WP) :: ZZ1,ZZ2,YY1,YY2 + REAL (WP) :: ALPHA,COEF + REAL (WP) :: OM + REAL (WP) :: PPI,PPR,EPSR,EPSI + REAL (WP) :: TOWO_LFC +! + REAL (WP) :: SQRT +! + ALPHA = ALFA('3D') ! +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + U = X * Z ! omega / (q * v_F) +! + OM = TWO * U * Y ! omega in reduced unit +! + ZZ1 = X + HALF * OM / Y ! ref. (1) eq. (3.4) + ZZ2 = X - HALF * OM / Y ! ref. (1) eq. (3.4) +! + YY1 = SQRT(ONE + OM) ! ref. (1) eq. (4.22) + YY2 = SQRT(ONE - OM) ! ref. (1) eq. (4.22) +! + COEF = THREE * ALPHA * RS / (EIGHT * Y2) ! +! + IF(U < (ONE - Y)) THEN ! + PPI = - COEF * ( ZZ1 * (F_TW(YY1) - F_TW(ONE)) + & ! ref. (1) eq. (4.21) + ZZ2 * (F_TW(ONE) - F_TW(YY2)) & ! + ) ! + ELSE ! + IF( ((ONE - Y) <= U) .AND. (U <= (ONE + Y)) ) THEN ! + PPI = - COEF * ( ZZ1 * (F_TW(YY1) - F_TW(ZZ1)) + & ! ref. (1) eq. (4.21) + ZZ2 * (F_TW(ONE) - F_TW(ZZ2)) & ! + ) ! + ELSE ! + PPI = ZERO ! ref. (1) eq. (4.21) + END IF ! + END IF ! +! + TOWO_LFC = PPI ! +! + END FUNCTION TOWO_LFC +! +!======================================================================= +! + FUNCTION F_TW(X) +! +! This function computes the Toigo-Woodruff function used for +! the calculation of the dynamic local-field correction +! +! References: (1) V. D. Gorobchenko, V. N. Kohn and E. G. Maksimov, +! in "Modern Problems in Condensed Matter" Vol. 24, +! L. V. Keldysh, D. A. Kirzhnitz and A. A. Maradudin ed. +! pp. 87-219 (North-Holland, 1989) +! +! +! Input parameters: +! +! * X : dimensionless parameter +! +! +! Author : D. Sébilleau +! +! Last modified : 18 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THREE,HALF,THIRD +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: F_TW + REAL (WP) :: OPX,OMX + REAL (WP) :: TPX,TMX +! + REAL (WP) :: LOG,ABS +! + OPX = ONE + X ! + OMX = ONE - X ! + TPX = THREE + X ! + TMX = THREE - X ! +! + F_TW = THIRD * ( X*X + & ! + HALF * TMX * OPX**THREE * & ! + LOG(ABS(OPX)) / X - & ! ref. (1) eq. (4.22) + HALF * TPX * OMX**THREE * & ! + LOG(ABS(OMX)) / X & ! + ) ! +! + END FUNCTION F_TW +! +!======================================================================= +! + FUNCTION UTI2_LFC(X,Z,RS,T,GQ_TYPE,SQ_TYPE) +! +! This function computes the Utsumi-Ichimaru dynamic +! local-field correction in 3D +! +! References: (1) K. Utsumi and S. Ichimaru, Phys. Rev. B 22, +! 1522-1533 (1980) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * GQ_TYPE : local-field correction type (3D) +! * SQ_TYPE : structure factor approximation (3D) +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,EIGHT, & + HALF,FOURTH + USE COMPLEX_NUMBERS, ONLY : ONEC,IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI,PI2 + USE LOCAL_FIELD_STATIC, ONLY : LOCAL_FIELD_STATIC_3D + USE IQ_FUNCTIONS_1, ONLY : IQ_KU1_3D + USE RELAXATION_TIME_STATIC, ONLY : UTIC_RT_3D + USE PLASMON_ENE_SI + USE LOCAL_FIELD_STATIC +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: Y,Y2,V + REAL (WP) :: OMEGA,FACT,ZETA1,ZETA2 + REAL (WP) :: Q_SI,TAU,GQ +! + COMPLEX (WP) :: UTI2_LFC +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! + V = Z * Y2 ! omega / omega_{k_F} +! + Q_SI = Y * KF_SI ! +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ) ! + TAU = UTIC_RT_3D(X,RS,T,SQ_TYPE,GQ_TYPE) ! +! + OMEGA = V * HALF * H_BAR * KF_SI * KF_SI / M_E ! omega in SI +! + FACT = THREE * ENE_P_SI * ENE_P_SI * TAU / (H_BAR * H_BAR) ! 3 * omega_p^2 * tau +! + ZETA1 = (PI2 / EIGHT - ONE) * TWO / FACT ! ref. (1) eq. (5.9) + ZETA2 = (FOURTH * PI2 + FOUR) * PI * Q_SI / (FACT * VF_SI) ! ref. (1) eq. (5.10) +! + UTI2_LFC = GQ + IC * ZETA1 * OMEGA + ZETA2 * (OMEGA / Q_SI)**2! ref. (1) eq. (5.8) +! + END FUNCTION UTI2_LFC +! +!======================================================================= +! + FUNCTION VISC_LFC(X,Z,RS,T,ETA,EC_TYPE) +! +! This function computes the viscosity dynamic +! local-field correction in 3D +! +! References: (1) S. Tanaka and S. Ichimaru, Phys. Rev. A 35, +! 4743-4754 (1987) +! (2) N. Iwamoto, Phys. Rev. A 30, 3289-3304 (1984) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * ETA : viscosity in SI +! * EC_TYPE : type of correlation energy functional +! +! +! Notes: (1) In order to solve dp / dn in eq. (17) of ref. (1), +! we make use of eq. (2.15a) of ref. (2) and express +! 1 / K_T acoording to (2.15c) of ref. (2) +! +! (2) From eq. (1), we have +! +! eta_l(q,omega) = eta_l(q) / [ 1 - i omega tau_m(q) ] +! +! etal_(q) +! ----------- = tau_m(q) [ G(q) - I(q) ] ( q_D / q )^2 eq. (21) +! n k_B T +! +! tau_m(q) = tau_m(q) * Y(q) eq. (26) +! +! | +! |-------------------------> eq. (27)-(28) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 18 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,SIX,HALF,THIRD + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : ALFA,RS_TO_N0 + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE LOCAL_FIELD_STATIC, ONLY : LOCAL_FIELD_STATIC_3D + USE IQ_FUNCTIONS_1, ONLY : IQ_KU1_3D + USE RELAXATION_TIME_STATIC, ONLY : TAIQ_RT_3D + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: ETA + REAL (WP) :: Q_SI,KD_SI,OMEGA + REAL (WP) :: ALPHA,N0,KBT + REAL (WP) :: DPDN,D_EC_1,D_EC_2 + REAL (WP) :: TAU_M,GQ1,GQ2 +! + REAL (WP) :: EXP +! + COMPLEX (WP) :: VISC_LFC + COMPLEX (WP) :: ENKT +! + ALPHA = ALFA('3D') ! + N0 = RS_TO_N0('3D',RS) ! +! + Q_SI = TWO * X * KF_SI ! q in SI + OMEGA = Z * HALF * H_BAR * Q_SI * Q_SI / M_E ! omega in SI +! + KBT = K_B * T ! +! + ETA = FOUR * THIRD * ETA ! +! +! Computing the Debye momentum +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! +! Computing the derivatives of the correlation energy +! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! +! Computing dp / dn +! + DPDN = THIRD * THIRD * RS * ( & ! + SIX / (ALPHA * ALPHA * RS * RS * RS) - & ! + SIX * PI_INV / (ALPHA * RS * RS) - & ! ref. (2) eq. (2.15c) + TWO * D_EC_1 + RS * D_EC_2 & ! + ) +! +! Computing the G(q) and I(q) +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,'ICUT',GQ1) ! G(q) + GQ2 = IQ_KU1_3D(X) ! I(q) +! +! Computing the static relaxation time tau(q) +! + TAU_M = TAIQ_RT_3D(X,RS,T) ! +! + ENKT = (KD_SI / Q_SI)**2 * (GQ1 - GQ2) * TAU_M / & ! + (ONE - IC * OMEGA * TAU_M) ! +! + VISC_LFC = (Q_SI / KD_SI)**2 * ( & ! + ONE - DPDN / KBT + & ! ref. (1) eq. (17) + IC * OMEGA * ETA / (N0 * KBT) & ! + ) ! +! + END FUNCTION VISC_LFC +! +END MODULE LOCAL_FIELD_DYNAMIC + diff --git a/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/local_field_static.f90 b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/local_field_static.f90 new file mode 100644 index 0000000..33562f4 --- /dev/null +++ b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/local_field_static.f90 @@ -0,0 +1,3708 @@ +! +!======================================================================= +! +MODULE LOCAL_FIELD_STATIC +! +! This modules provides subroutines/functions to compute +! static local-field factors G(q) +! +! These G(q) DOES NOT DEPEND of the static structure factor S(q) +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE LFIELD_STATIC(X,RS,T,GQ_TYPE,GQ) +! +! This subroutine computes static local-field factors G(q) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * GQ_TYPE : local-field correction type (3D) +! +! +! Output parameters: +! +! * GQ : static local field correction +! +! +! Author : D. Sébilleau +! +! Last modified : 19 Jun 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE +! + REAL (WP) :: X,RS,T + REAL (WP) :: GQ +! + IF(DMN == '3D') THEN ! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ) ! + ELSE IF(DMN == '2D') THEN ! + CALL LOCAL_FIELD_STATIC_2D(X,RS,GQ_TYPE,GQ) ! + ELSE IF(DMN == '1D') THEN ! + CALL LOCAL_FIELD_STATIC_1D(X,RS,GQ_TYPE,GQ) ! + END IF ! +! + END SUBROUTINE LFIELD_STATIC +! +!------ 1) 3D case -------------------------------------------- +! +!======================================================================= +! + SUBROUTINE LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ) +! +! This subroutine computes static local-field factors G(q) +! for 3D systems. +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * GQ_TYPE : local-field correction type (3D) +! GQ_TYPE = 'NONE' no local field correction +! GQ_TYPE = 'ALDA' adiabatic local density +! GQ_TYPE = 'ALFL' Alvarellos-Flores +! GQ_TYPE = 'BEBR' Bedell-Brown +! GQ_TYPE = 'CDOP' TDDFT Corradini et al correction +! GQ_TYPE = 'GEVO' Geldart-Vosko correction +! GQ_TYPE = 'GEV2' Geldart-Vosko 2 +! GQ_TYPE = 'GOCA' Gold-Calmels +! GQ_TYPE = 'HORA' Holas-Rahman +! GQ_TYPE = 'HUBB' Hubbard correction (only exchange) +! GQ_TYPE = 'ICUT' Ichimaru-Utsumi correction +! GQ_TYPE = 'IWA1' Iwamoto G_{-1} +! GQ_TYPE = 'IWA2' Iwamoto G_{3} approx. +! temperature-dep. --> GQ_TYPE = 'IWA3' Iwamoto G_{-1} +! GQ_TYPE = 'IWA4' Iwamoto G_{3} exact +! GQ_TYPE = 'JGDG' Jung-Garcia-Gonzalez-Dobson-Godby +! GQ_TYPE = 'KLLA' Kleinman-Langreth correction +! GQ_TYPE = 'KUGL' Kugler +! GQ_TYPE = 'LDAC' LDA correction +! GQ_TYPE = 'MCSC' Moroni-Ceperley-Senatore correction +! GQ_TYPE = 'NAGY' Nagy correction +! GQ_TYPE = 'NEV1' Nevalinna two-moment approximation +! GQ_TYPE = 'PGGA' Petersilka-Gossmann-Gross +! GQ_TYPE = 'PVHF' Pavas-Vashishta Hartree-Fock correction +! GQ_TYPE = 'RICE' Rice correction +! GQ_TYPE = 'SHAW' Shaw correction +! GQ_TYPE = 'SLAT' Slater correction +! GQ_TYPE = 'STLS' Singwi et al correction +! GQ_TYPE = 'UTI1' Utsumi-Ichimaru correction (only exchange) +! GQ_TYPE = 'TOUL' Toulouse parametrization of CDOP +! GQ_TYPE = 'TRMA' Tripathy-Mandal +! temperature-dep. --> GQ_TYPE = 'TKAC' Tkachenko correction +! GQ_TYPE = 'VASI' Vashishta-Singwi correction +! +! Intermediate parameters: +! +! * EC_TYPE : type of correlation energy functional +! EC_TYPE = 'GEBR_W' --> Gell-Mann and Brueckner +! EC_TYPE = 'CAMA_W' --> Carr and Maradudin +! EC_TYPE = 'HELU_W' --> Hedin and Lundqvist +! EC_TYPE = 'VBLU_W' --> von Barth and Lundqvist +! EC_TYPE = 'PEZU_W' --> Perdew and Zunger +! EC_TYPE = 'WIGN_S' --> Wigner +! EC_TYPE = 'NOPI_S' --> Nozières and Pines +! EC_TYPE = 'LIRO_S' --> Lindgren and Rosen +! EC_TYPE = 'PEZU_S' --> Perdew and Zunger +! EC_TYPE = 'VWNU_G' --> Vosko, Wilk and Nusair +! EC_TYPE = 'PEWA_G' --> Perdew and Wang +! * SQ_TYPE : structure factor approximation (3D) +! SQ_TYPE = 'HFA' Hartree-Fock approximation (only exchange) +! SQ_TYPE = 'RPA' RPA approximation +! SQ_TYPE = 'TWA' Toigo-Woodruff approximation +! SQ_TYPE = 'GOR' Gorobchenko approximation +! SQ_TYPE = 'SPA' Singh-Pathak +! SQ_TYPE = 'PKA' Pietiläinen-Kallio +! SQ_TYPE = 'MSA' mean spherical approximation +! SQ_TYPE = 'GEA' generalized approximation +! +! +! Output parameters: +! +! * GQ : static local field correction +! +! +! Author : D. Sébilleau +! +! Last modified : 22 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO + USE SF_VALUES, ONLY : SQ_TYPE + USE ENERGIES, ONLY : EC_TYPE +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE +! + REAL (WP) :: X,RS,T + REAL (WP) :: GQ +! + IF(GQ_TYPE == 'NONE') THEN ! + GQ=ZERO ! + ELSE IF(GQ_TYPE == 'SLAT') THEN ! + GQ=SLAT_LFC(X) ! + ELSE IF(GQ_TYPE == 'HUBB') THEN ! + GQ=HUBB_LFC(X) ! + ELSE IF(GQ_TYPE == 'UTI1') THEN ! + GQ=UTI1_LFC(X) ! + ELSE IF(GQ_TYPE == 'GEVO') THEN ! + GQ=GEVO_LFC(X) ! + ELSE IF(GQ_TYPE == 'RICE') THEN ! + GQ=RICE_LFC(X) ! + ELSE IF(GQ_TYPE == 'KLLA') THEN ! + GQ=KLLA_LFC(X) ! + ELSE IF(GQ_TYPE == 'LDAC') THEN ! + GQ=LDAC_LFC(X,RS,T,EC_TYPE ) ! + ELSE IF(GQ_TYPE == 'MCSC') THEN ! + GQ=MCSC_LFC(X,RS,T,EC_TYPE) ! + ELSE IF(GQ_TYPE == 'CDOP') THEN ! + GQ=CDOP_LFC(X,RS,T,EC_TYPE) ! + ELSE IF(GQ_TYPE == 'TOUL') THEN ! + GQ=TOUL_LFC(X,RS,T,EC_TYPE) ! + ELSE IF(GQ_TYPE == 'STLS') THEN ! + GQ=STLS_LFC(X) ! + ELSE IF(GQ_TYPE == 'PVHF') THEN ! + GQ=PVHF_LFC(X) ! + ELSE IF(GQ_TYPE == 'VASI') THEN ! + GQ=VASI_LFC(X,RS) ! + ELSE IF(GQ_TYPE == 'GOCA') THEN ! + GQ=GOCA_LFC(X,RS) ! + ELSE IF(GQ_TYPE == 'ICUT') THEN ! + GQ=ICUT_LFC(X,RS,T) ! + ELSE IF(GQ_TYPE == 'IWA1') THEN ! + GQ=IWA1_LFC(X,RS) ! + ELSE IF(GQ_TYPE == 'IWA2') THEN ! + GQ=IWA2_LFC(X,RS) ! + ELSE IF(GQ_TYPE == 'IWA4') THEN ! + GQ=IWA4_LFC(X,RS) ! + ELSE IF(GQ_TYPE == 'SHAW') THEN ! + GQ=SHAW_LFC(X) ! + ELSE IF(GQ_TYPE == 'NAGY') THEN ! + GQ=NAGY_LFC(X,RS) ! + ELSE IF(GQ_TYPE == 'NEV1') THEN ! + GQ=NEV1_LFC(X,RS) ! + ELSE IF(GQ_TYPE == 'ALFL') THEN ! + GQ=ALFL_LFC(X) ! + ELSE IF(GQ_TYPE == 'HORA') THEN ! + GQ=HORA_LFC(X,RS) ! + ELSE IF(GQ_TYPE == 'ALDA') THEN ! + GQ=ALDA_LFC(X,RS,T,EC_TYPE) ! + ELSE IF(GQ_TYPE == 'JGDG') THEN ! + GQ=JGDG_LFC(X,RS,T,EC_TYPE) ! + ELSE IF(GQ_TYPE == 'PGGA') THEN ! + GQ=PGGA_LFC(X) ! + ELSE IF(GQ_TYPE == 'TRMA') THEN ! + GQ=TRMA_LFC(X) ! + ELSE IF(GQ_TYPE == 'BEBR') THEN ! + GQ=BEBR_LFC(X,RS) ! + ELSE IF(GQ_TYPE == 'GEV2') THEN ! + GQ=GEV2_LFC(X,RS,T,EC_TYPE) ! + ELSE IF(GQ_TYPE == 'TKAC') THEN ! + GQ=TKAC_LFC(X,RS,T) ! + ELSE IF(GQ_TYPE == 'IWA3') THEN ! + GQ=IWA3_LFC(X,RS,T) ! + END IF ! +! + END SUBROUTINE LOCAL_FIELD_STATIC_3D +! +!======================================================================= +! + FUNCTION SLAT_LFC(X) +! +! This function computes the Slater local-field correction +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! +! + IMPLICIT NONE +! + REAL (WP),INTENT(IN) :: X + REAL (WP) :: SLAT_LFC + REAL (WP) :: Y +! + Y = X + X ! Y = q / k_F +! + SLAT_LFC = 0.3750E0_WP * Y * Y ! +! + END FUNCTION SLAT_LFC +! +!======================================================================= +! + FUNCTION HUBB_LFC(X) +! +! This function computes the Hubbard local-field correction +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,HALF +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: HUBB_LFC + REAL (WP) :: Y,Y2 +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + HUBB_LFC = HALF * Y2 / (ONE + Y2) ! +! + END FUNCTION HUBB_LFC +! +!======================================================================= +! + FUNCTION UTI1_LFC(X) +! +! This function computes the exchange Utsumi-Ichimaru local-field correction +! Input parameters: +! +! +! Reference: (1) K. Utsumi and S. Ichimaru, Phys. Rev. B 22, +! 5203-5212 (1980) +! +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,THREE,FOUR,FIVE,FOURTH +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: UTI1_LFC + REAL (WP) :: Y,Y2 + REAL (WP) :: NUM,DEN,LGA +! + REAL (WP) :: LOG +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + NUM = THREE * (FOUR - Y2) * (28.0E0_WP + FIVE * Y2) ! + DEN = 16.0E0_WP * Y ! + LGA = LOG(ABS((TWO + Y) / (TWO - Y))) ! +! + UTI1_LFC = Y2 / 128.0E0_WP * ( & ! + 11.0E0_WP + & ! + 15.0E0_WP * Y2 * FOURTH + & ! + NUM * LGA / DEN & ! + ) ! + +! + END FUNCTION UTI1_LFC +! +!======================================================================= +! + FUNCTION GEVO_LFC(X) +! +! This function computes the Geldart-Vosko local-field correction +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,HALF +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: GEVO_LFC + REAL (WP) :: Y,Y2 +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + GEVO_LFC = HALF * Y2 / (TWO + Y2) ! +! + END FUNCTION GEVO_LFC +! +!======================================================================= +! + FUNCTION RICE_LFC(X) +! +! This function computes the Rice local-field correction +! Input parameters: +! +! Reference: (1) L. Kleinman, Phys. Rev. 160, 585-590 (1967) +! +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,FOUR,HALF + USE FERMI_AU, ONLY : KF_AU + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: RICE_LFC + REAL (WP) :: Y,Y2,Z2 +! +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + Z2 = FOUR * PI_INV / KF_AU ! (k_TF/k_F)^2 +! + RICE_LFC = HALF * Y2 / (ONE + Y2 + Z2) ! ref. 1 eq. (3) +! + END FUNCTION RICE_LFC +! +!======================================================================= +! + FUNCTION KLLA_LFC(X) +! +! This function computes the Kleinman-Langreth local-field correction +! +! Reference: L. Kleinman, Phys. Rev. 160, 585-590 (1967) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,FOUR,FOURTH + USE FERMI_AU, ONLY : KF_AU + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: KLLA_LFC + REAL (WP) :: Y,Y2,Z2 +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + Z2 = FOUR * PI_INV / KF_AU ! (k_TF/k_F)^2 +! + KLLA_LFC = FOURTH * (Y2 / (ONE + Y2 + Z2) + Y2 / (ONE + Z2)) ! ref. 1 eq. (25) +! + END FUNCTION KLLA_LFC +! +!======================================================================= +! + FUNCTION LDAC_LFC(X,RS,T,EC_TYPE) +! +! This function computes the LDA local-field correction +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! * EC_TYPE : type of correlation energy functional +! +! +! Author : D. Sébilleau +! +! Last modified : 22 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOURTH + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : ALFA + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP) :: X,RS,T,LDAC_LFC + REAL (WP) :: Y,Y2,D_EC_1,D_EC_2 + REAL (WP) :: ALPHA,GAMMA_0 +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! Y^2 +! + ALPHA = ALFA('3D') ! +! +! Correlation energy and its derivatives +! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! +! Calculation of coefficient gamma_0 +! + GAMMA_0 = FOURTH - PI * ALPHA / 24.0E0_WP*( & ! + RS * RS * RS * D_EC_2 - TWO * RS * RS * D_EC_1) ! +! + LDAC_LFC = GAMMA_0 * Y2 ! +! + END FUNCTION LDAC_LFC +! +!======================================================================= +! + FUNCTION ALDA_LFC(X,RS,T,EC_TYPE) +! +! This function computes the adiabatic local density approximation (ALDA) +! local-field correction +! +! References: (1) K. Tatarczyk, A. Schindlmayr and M. Scheffler, +! Phys. Rev. B 63, 235106 (2001) +! +! Note: we have G(q) = - f_{xc} / Vc(q) +! +! In terms of derivatives with respect to r_s --> n = (3 / 4 pi) / r_s^3 +! we find +! +! f_{xc} = [ (4 / 9a^2) - 2 / 3a) *r_s^4 * d E_xc / d r_s + +! (1 / 9a^2) *r_s^5 * d^2 d E_xc / d r_s^2 ] +! +! 1/Vc(q) = q^2 = X*X * 4 * k_F^2 = 4*X*X * (1 / alpha r_s)^2 +! +! +! Note: Energies are calculated in Ry units: +! a_0 = 1 +! e^2 = 2 +! m = 1/2 +! h_bar = 1 +! +! +! We write E_xc = E_x + E_c and E_x(LDA) = - 3/4*pi * (3*pi^3*n)^{1/3} +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! * EC_TYPE : type of correlation energy functional +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,EIGHT,NINE,HALF,THIRD + USE PI_ETC, ONLY : PI,PI_INV + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP) :: X,RS,T + REAL (WP) :: ALDA_LFC + REAL (WP) :: A,R1,R2,R4,C1,C2,Q2 + REAL (WP) :: D_EC_1,D_EC_2 + REAL (WP) :: COR,EXC + REAL (WP) :: VC +! + A = 0.75E0_WP * PI_INV ! 3 / (4 pi) +! + R1 = RS ! + R2 = R1 * R1 ! powers of RS + R4 = R2 * R2 ! +! + Q2 = FOUR * X * X ! q^2 + VC = EIGHT * PI / Q2 ! e^2 = 2 in Ryd +! + C1 = - (TWO / (NINE * A)) * R4 ! + C2 = - HALF * C1 * R1 ! see notes.pdf +! +! Computing the exchange-correlation energy derivatives (in Ryd) +! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! +! Correlation contribution +! + COR = C1 * D_EC_1 + C2 * D_EC_2 ! see notes.pdf +! +! Exchange contribution +! + EXC = - (TWO / THIRD) * (ONE / (A + A))**THIRD * R2 ! see notes.pdf +! +! Computing the local-field correction +! + ALDA_LFC = - (COR + EXC) / VC ! +! + END FUNCTION ALDA_LFC +! +!======================================================================= +! + FUNCTION JGDG_LFC(X,RS,T,EC_TYPE) +! +! This function computes the Jung-Garcia-Gonzalez-Dobson-Godby +! local-field correction +! +! References: (1) J. Jung, P. García-González, J. F. Dobson and R. W. Godby, +! Phys. Rev. B 70, 205107, (2004) +! +! Note: we have G(q) = - f_{xc} / Vc(q) +! +! and +! K_{xc} +! f_{xc} = ------------------------------ eq. (6) +! ( 1 + alpha(rs) * (q/k_F)^2) +! +! with +! d^2 [ n * E_{xc}(n) ] +! K_{xc} = --------------------- +! d n^2 +! +! In terms of derivatives with respect to r_s --> n = (3 / 4 pi) / r_s^3 +! we find +! +! K_{xc} = [ (4 / 9a^2) - 2 / 3a) *r_s^4 * d E_xc / d r_s + +! (1 / 9a^2) *r_s^5 * d^2 d E_xc / d r_s^2 ] +! +! 1/Vc(q) = q^2 = X*X * 4 * k_F^2 = 4*X*X * (1 / alpha r_s)^2 +! +! +! We write E_xc = E_x + E_c and E_x(LDA) = - 3/4*pi * (3*pi^3*n)^{1/3} +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! * EC_TYPE : type of correlation energy functional +! +! +! Author : D. Sébilleau +! +! Last modified : 25 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,FIVE,NINE,HALF,THIRD + USE PI_ETC, ONLY : PI,PI_INV + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP) :: X,RS,T + REAL (WP) :: JGDG_LFC + REAL (WP) :: Y + REAL (WP) :: A,R1,R2,R4,C1,C2,Q2 + REAL (WP) :: D_EC_1,D_EC_2 + REAL (WP) :: COR,EXC + REAL (WP) :: KXC,EMF +! + Y = X + X ! Y = q / k_F +! +! Computation of the empirical function EMF = alpha(rs) +! + EMF = (8.26E0_WP + RS) / (100.0E0_WP + FIVE * RS) ! ref. (1) eq. (7) +! + A = 0.75E0_WP * PI_INV ! 3 / (4 pi) +! + R1 = RS ! + R2 = R1 * R1 ! powers of RS + R4 = R2 * R2 ! +! + Q2 = FOUR * X * X ! q^2 +! + C1 = - (TWO / (NINE * A)) * R4 ! + C2 = - HALF * C1 * R1 ! see notes.pdf +! +! Computing the exchange-correlation energy derivatives +! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! +! Correlation contribution +! + COR = C1 * D_EC_1 + C2 * D_EC_2 ! see notes.pdf +! +! Exchange contribution +! + EXC = - (TWO / THIRD) * (ONE / (A + A))**THIRD * R2 ! see notes.pdf +! +! Computing the local-field correction K_XC +! + KXC = - Q2 * (COR + EXC) / (FOUR * PI) ! +! + JGDG_LFC = KXC / (ONE + EMF * Y * Y) ! ref. (1) eq. (6) +! + END FUNCTION JGDG_LFC +! +!======================================================================= +! + FUNCTION ALFL_LFC(X) +! +! This function computes the Alvarellos-Flores +! local-field correction +! +! References: (1) J. E. Alvarellos and F. Flores, +! J. Phys. F: Met.Phys. 14, 1673-1683 (1984) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! Note: in order to fit with a polynomial the data provided in table 1, +! we have divided the q / k_F range into three intervals: +! +! [0.1,1.5], [1.5,3] and [3,inf[ +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : THREE +! + IMPLICIT NONE +! + REAL*8 X,Y,ALFL_LFC + REAL*8 Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12 +! + REAL*8 A(0:4),B(0:12),C(0:12) +! + DATA A / -0.00232814185814185791E0_WP, & ! + 0.02957060876859638210E0_WP, & ! Alvarellos-Flores + 0.26322613203360108073E0_WP, & ! parametrization q + 0.18806277528800747964E0_WP, & ! in [0.1,1.5] + -0.10804001854698448924E0_WP / ! +! + DATA B / 1602873.31450051144290982293E0_WP, & ! + -8878402.26517064151352730944E0_WP, & ! + 22368820.63709011917824002483E0_WP, & ! + -33895716.59478186008112667038E0_WP, & ! + 34405106.67965708984160299577E0_WP, & ! + -24644195.23964148249074776392E0_WP, & ! + 12773812.11115474100423665142E0_WP, & ! Alvarellos-Flores + -4827670.95479111073609401600E0_WP, & ! parametrization q + 1320409.84284274222863391708E0_WP, & ! in [1.5,3] + -254900.07720880570664342685E0_WP, & ! + 32969.67519994204849073546E0_WP, & ! + -2565.55962024807576633976E0_WP, & ! + 90.83704034662135794196E0_WP / ! +! + DATA C / 0.99589822749632385541E0_WP, & ! + -0.37069025316863586226E0_WP, & ! + 0.10927126349814184349E0_WP, & ! + -0.01842929651333115907E0_WP, & ! + 0.00196933466633664192E0_WP, & ! + -0.00014089343299951851E0_WP, & ! Alvarellos-Flores + 0.00000695535076739875E0_WP, & ! parametrization q + -0.00000023991362786543E0_WP, & ! in [3,50] + 0.00000000576407117368E0_WP, & ! + -0.00000000009442676563E0_WP, & ! + 0.00000000000100445750E0_WP, & ! + -0.00000000000000624700E0_WP, & ! + 0.00000000000000001722E0_WP / ! +! + Y=X+X ! Y = q / k_F +! + Y2=Y*Y ! + Y3=Y2*Y ! + Y4=Y3*Y ! + Y5=Y4*Y ! + Y6=Y5*Y ! powers of Y + Y7=Y6*Y ! + Y8=Y7*Y ! + Y9=Y8*Y ! + Y10=Y9*Y ! + Y11=Y10*Y ! + Y12=Y11*Y ! +! +! Fitted values: +! + IF(Y <= 1.5E0_WP) THEN ! + ALFL_LFC=A(0)+A(1)*Y+A(2)*Y2+A(3)*Y3+A(4)*Y4 ! 4th-degree polynomial + ELSE ! + IF(Y < THREE) THEN ! + ALFL_LFC=B(0)+B(1)*Y+B(2)*Y2+B(3)*Y3+B(4)*Y4+ & ! + B(5)*Y5+B(6)*Y6+B(7)*Y7+B(8)*Y8+ & ! 12th-degree polynomial + B(9)*Y9+B(10)*Y10+B(11)*Y11 +B(12)*Y12 ! + ELSE ! + ALFL_LFC=C(0)+C(1)*Y+C(2)*Y2+C(3)*Y3+C(4)*Y4+ & ! + C(5)*Y5+C(6)*Y6+C(7)*Y7+C(8)*Y8+ & ! 12th-degree polynomial + C(9)*Y9+C(10)*Y10+C(11)*Y11 +C(12)*Y12 ! + END IF ! + END IF ! +! + END FUNCTION ALFL_LFC +! +!======================================================================= +! + FUNCTION BEBR_LFC(X,RS) +! +! This subroutine computes the Gorobchenko-Kohn-Makismov +! parametrization of the Bedell-Brown static +! local-field correction G(q) +! +! We use a 10-degree polynomial to fit the data of +! table 13 p. 202 reference (1): r_s = 1 --> A1 +! r_s = 2 --> A2 +! r_s = 3 --> A3 +! r_s = 4 --> A4 +! r_s = 5 --> A5 +! +! For a given value of (q / k_F), this gives 5 values of G(q / k_F). +! Then, we use Lagrange interpolation to find G(q / k_F) for the +! input value r_s +! +! Reference: (1) V. D. Gorobchenko, V. N. Kohn and E. G. Maksimov, +! in "Modern Problems in Condensed Matter" Vol. 24, +! L. V. Keldysh, D. A. Kirzhnitz and A. A. Maradudin ed. +! pp. 87-219 (North-Holland, 1989) +! (2) K. Bedell and G. E. Brown, Phys. Rev. B 17, +! 4512-4526 (1978) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Sep 2020 +! +! + USE INTERPOLATION, ONLY : LAG_5P_INTERP +! + IMPLICIT NONE +! + INTEGER :: I +! + REAL (WP) :: X,BEBR_LFC + REAL (WP) :: Y,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10 + REAL (WP) :: A1(0:10),A2(0:10),A3(0:10),A4(0:10),A5(0:10) + REAL (WP) :: XX(5),G(5) + REAL (WP) :: GQ + REAL (WP) :: RS +! + REAL (WP) :: FLOAT +! + DATA A1 / 0.05665675302924973487E0_WP, - 0.98831786405830883053E0_WP, & ! + 5.71954869216605636168E0_WP, -11.66292418214004375562E0_WP, & ! + 14.39634044260440374493E0_WP, -11.11349419853768050130E0_WP, & ! r_s = 1 + 5.41506188302421610518E0_WP, - 1.66403119967215497295E0_WP, & ! + 0.31307098570298832050E0_WP, - 0.03296633943677430225E0_WP, & ! + 0.00148977432192336107E0_WP / ! +! + DATA A2 / 0.09615453465136963087E0_WP, - 1.68845504199024126849E0_WP, & ! + 9.58638897670232869993E0_WP, -20.14220993548459161920E0_WP, & ! + 24.84488446234967641433E0_WP, -19.08578084736209803670E0_WP, & ! r_s = 2 + 9.30607703069127278674E0_WP, - 2.87840456993250278340E0_WP, & ! + 0.54728271452439117930E0_WP, - 0.05837908431520891572E0_WP, & ! + 0.00267579536376397662E0_WP / ! +! + DATA A3 / 0.12489537639285344973E0_WP, - 2.19227250101889576367E0_WP, & ! + 12.31553072981137928772E0_WP, -26.10326007988353482451E0_WP, & ! + 32.21209258443127872400E0_WP, -24.74352965527718617954E0_WP, & ! r_s = 3 + 12.08871426471608460444E0_WP, - 3.75352185666137399318E0_WP, & ! + 0.71726641930779769185E0_WP, - 0.07694135948329880508E0_WP, & ! + 0.00354705841080042429E0_WP / ! +! + DATA A4 / 0.13845553558660167957E0_WP, - 2.40703111904318554141E0_WP, & ! + 13.25313366188360966866E0_WP, -27.12342892703660083282E0_WP, & ! + 32.07267146613116132363E0_WP, -23.65420157903910060017E0_WP, & ! r_s = 4 + 11.14339308619566914286E0_WP, - 3.34944213997448196331E0_WP, & ! + 0.62156353952937566618E0_WP, - 0.06491444468410050654E0_WP, & ! + 0.00291971543613746805E0_WP / ! +! + DATA A5 / 0.16492523750906023169E0_WP, - 2.89272457288247751551E0_WP, & ! + 16.13741748584924269111E0_WP, -34.56490422254182103290E0_WP, & ! + 42.80211125382114047548E0_WP, -32.95766092086370111126E0_WP, & ! r_s = 5 + 16.15651875212909104597E0_WP, - 5.03812068154871323281E0_WP, & ! + 0.96728844784358881200E0_WP, - 0.10425567298196395386E0_WP, & ! + 0.00482824566192623949E0_WP / ! +! +! Storing the r_s +! + DO I=1,5 ! + XX(I) = FLOAT(I) ! + END DO ! +! + Y = X + X ! q / k_F + Y2 = Y * Y ! + Y3 = Y2 * Y ! + Y4 = Y3 * Y ! + Y5 = Y4 * Y ! powers of Y + Y6 = Y5 * Y ! + Y7 = Y6 * Y ! + Y8 = Y7 * Y ! + Y9 = Y8 * Y ! + Y10= Y9 * Y ! +! +! Computing G(q) for r_s = 1,2,3,4 and 5 +! + G(1)=A1(0) + A1(1)*Y + A1(2)*Y2 + A1(3)*Y3 + A1(4)*Y4 + & ! + A1(5)*Y5 + A1(6)*Y6 + A1(7)*Y7 + A1(8)*Y8 + & ! + A1(9)*Y9 + A1(10)*Y10 ! + G(2)=A2(0) + A2(1)*Y + A2(2)*Y2 + A2(3)*Y3 + A2(4)*Y4 + & ! + A2(5)*Y5 + A2(6)*Y6 + A2(7)*Y7 + A2(8)*Y8 + & ! + A2(9)*Y9 + A2(10)*Y10 ! + G(3)=A3(0) + A3(1)*Y + A3(2)*Y2 + A3(3)*Y3 + A3(4)*Y4 + & ! + A3(5)*Y5 + A3(6)*Y6 + A3(7)*Y7 + A3(8)*Y8 + & ! + A3(9)*Y9 + A3(10)*Y10 ! + G(2)=A4(0) + A4(1)*Y + A4(2)*Y2 + A4(3)*Y3 + A4(4)*Y4 + & ! + A4(5)*Y5 + A4(6)*Y6 + A4(7)*Y7 + A4(8)*Y8 + & ! + A4(9)*Y9 + A4(10)*Y10 ! + G(5)=A5(0) + A5(1)*Y + A5(2)*Y2 + A5(3)*Y3 + A5(4)*Y4 + & ! + A5(5)*Y5 + A5(6)*Y6 + A5(7)*Y7 + A5(8)*Y8 + & ! + A5(9)*Y9 + A5(10)*Y10 ! +! +! Performing the Langrange interpolation +! + BEBR_LFC=LAG_5P_INTERP(XX,G,RS) ! +! + END FUNCTION BEBR_LFC +! +!======================================================================= +! + FUNCTION CDOP_LFC(X,RS,T,EC_TYPE) +! +! This function computes the Corradini-Del Sole-Onida-Palummo +! local-field correction +! +! References: (1) M. Corradini, R. Del Sole, G. Onida and M. Palummo, +! Phys. Rev. B 57, 14569-14571 (1998) +! (2) D. Emfietzoglou et al, Nucl. Instr. and Meth. B +! 267, 45-52 (2009) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! * EC_TYPE : type of correlation energy functional +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,NINE, & + HALF,THIRD,FOURTH,NINTH + USE FERMI_AU, ONLY : KF_AU + USE PI_ETC, ONLY : PI,PI2 + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: CDOP_LFC + REAL (WP) :: Y,Y2 + REAL (WP) :: U,U2,U3,U4,U5,U6 + REAL (WP) :: COEF + REAL (WP) :: A,B,C,G,AL,BE + REAL (WP) :: A1,A2,B1,B2 + REAL (WP) :: RS2,RS3 + REAL (WP) :: EC,D_EC_1,D_EC_2 +! + REAL (WP) :: SQRT,EXP +! +! COEF = (FOUR * PI2 / NINE)**THIRD / 24.0E0_WP ! in ref. (2) eq. (17a) + COEF = HALF * NINTH * (THREE * PI2 / TWO)**THIRD ! +! + Y = X + X ! Y = q / k_F = Q in ref. 1 + Y2 = Y*Y ! Q^2 in ref. 1 +! + U = SQRT(RS) ! x in ref. 1 + U2 = U * U ! x^2 in ref. 1 + U3 = U2 * U ! x^3 in ref. 1 + U4 = U3 * U ! x^4 in ref. 1 + U5 = U4 * U ! x^5 in ref. 1 + U6 = U5 * U ! x^6 in ref. 1 +! + RS2 = RS * RS ! + RS3 = RS2 * RS ! +! + A1 = 2.15E0_WP ! + A2 = 0.435E0_WP ! for CDOP + B1 = 1.57E0_WP ! coefficients (6)-(8) + B2 = 0.409E0_WP ! +! +! Correlation energy and its derivatives +! + EC = EC_3D(EC_TYPE,1,RS,T) ! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! +! CDOP coeffcients: +! + A = FOURTH - COEF * HALF * (RS3 * D_EC_2 - TWO * RS2 * D_EC_1)! eq.17a ref (2) + e^2 = 2 + B = (ONE + A1 * U + A2 * U3) / (THREE + B1 * U + B2 * U3) ! eq.19 ref (2) + C = - FOURTH * PI* (EC + RS * D_EC_1) / KF_AU ! eq.6 ref (1) + e^2 = 2 + G = B / (A - C) ! ref (1) + AL = 1.50E0_WP * A / (SQRT(U) * B * G) ! eq.9 ref (1) + BE = 1.20E0_WP / (B * G) ! eq.10 ref (1) +! +! Computation of the local-field formula ! (x 4 pi to be in SI) +! + CDOP_LFC = C * Y2 + B * Y2 / (G + Y2) + & ! + AL * Y2 * Y2 * EXP(- BE *Y2) ! ref. (2) eq. (15), (8) +! + END FUNCTION CDOP_LFC +! +!======================================================================= +! + FUNCTION TOUL_LFC(X,RS,T,EC_TYPE) +! +! This function computes the Toulouse fit of the +! Corradini-Del Sole-Onida-Palummo local-field correction +! +! References: (1) M. Corradini, R. Del Sole, G. Onida and M. Palummo, +! Phys. Rev. B 57, 14569-14571 (1998) +! (2) J. Toulouse, Phys. Rev. B 72, 035117 (2005) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! * EC_TYPE : type of correlation energy functional +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,NINE, & + HALF,THIRD,FOURTH + USE FERMI_AU, ONLY : KF_AU + USE PI_ETC, ONLY : PI,PI2 +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP) :: X,RS,T,Y,Y2 + REAL (WP) :: TOUL_LFC + REAL (WP) :: U,U2,U3,U4,U5,U6 + REAL (WP) :: COEF + REAL (WP) :: A,B,C,G,AL,BE + REAL (WP) :: EC,D_EC_1,D_EC_2 + REAL (WP) :: AT(0:6),BT(4) + REAL (WP) :: C1(6),C2(4) + REAL (WP) :: NUM,DEN +! + REAL (WP) :: SQRT,EXP +! + DATA AT / 0.250019E0_WP, -0.000162E0_WP, 0.013441E0_WP, & ! \ + -0.003591E0_WP, 0.000380E0_WP, -0.000002E0_WP, & ! \ + -0.000003E0_WP / ! \ +! ! \ + DATA BT / 0.721543E0_WP, 0.317320E0_WP, -0.133379E0_WP, & ! \ + 0.269494E0_WP / ! > ref. (2) appendix D +! ! / + DATA C1 / 0.002127E0_WP, 0.169597E0_WP, 0.450771E0_WP, & ! / + -0.023265E0_WP, 0.001855E0_WP, -0.000069E0_WP / ! / + DATA C2 / 7.062604E0_WP, 8.589773E0_WP, 2.747407E0_WP, & ! / + 0.648920E0_WP / ! / +! + COEF = (FOUR * PI2 / NINE)**THIRD / 24.0E0_WP ! in ref. (2) eq. (17a) +! + Y = X + X ! Y = q / k_F = Q in ref. 1 + Y2 = Y*Y ! Q^2 in ref. 1 +! + U = SQRT(RS) ! x in ref. 1 + U2 = U * U ! x^2 in ref. 1 + U3 = U2 * U ! x^3 in ref. 1 + U4 = U3 * U ! x^4 in ref. 1 + U5 = U4 * U ! x^5 in ref. 1 + U6 = U5 * U ! x^6 in ref. 1 +! +! CDOP coeffcients: +! + A = AT(0) + AT(1) * U + AT(2) * U2 + AT(3) * U3 + & ! ref. (2) eq. (D1) + AT(4) * U4 + AT(5) * U5 + AT(6) * U6 ! +! + B = ( ONE + BT(1) * U + BT(2) * U3 ) / & ! ref. (2) eq. (D2) + ( THREE + BT(3) * U + BT(4) * U3 ) ! +! + NUM = C1(1) * U + C1(2) * U2 + C1(3) * U3 + & ! + C1(4) * U4 + C1(5) * U5 + C1(6) * U6 ! + DEN = C2(1) * U + C2(2) * U2 + C2(3) * U3 + & ! + C2(4) * U4 + ONE ! + C = NUM / DEN ! ref. (2) eq. (D3) +! + G = B / (A - C) ! ref (1) + AL = 1.50E0_WP * A / (SQRT(U) * B * G) ! eq.9 ref (1) + BE = 1.20E0_WP / (B * G) ! eq.10 ref (1) +! +! Computation of the local-field formula ! +! + TOUL_LFC = C * Y2 + B * Y2 / (G + Y2) + & ! + AL * Y2 * Y2 * EXP(- BE * Y2) ! ref. (1) eq. (8) +! + END FUNCTION TOUL_LFC +! +!======================================================================= +! + FUNCTION GEV2_LFC(X,RS,T,EC_TYPE) +! +! This function computes the Geldart-Vosko local-field correction, +! as parametrized by Gorobchenko-Kohn-Makismov +! +! Reference: (1) V. D. Gorobchenko, V. N. Kohn and E. G. Maksimov, +! in "Modern Problems in Condensed Matter" Vol. 24, +! L. V. Keldysh, D. A. Kirzhnitz and A. A. Maradudin ed. +! pp. 87-219 (North-Holland, 1989) +! (2) N. Iwamoto, Phys. Rev. A 30, 3289-3304 (1984) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! * EC_TYPE : type of correlation energy functional +! +! Intermediate parameters: +! +! * XI : dimensionless factor +! +! Note: XI is given in reference (1) in terms of the ratio of compressibilities: +! +! RAT = (1 - K_0/K_T) +! +! We compute it using eq. (2.18) of ref. (2) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 22 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,HALF,THIRD + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : ALFA + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: GEV2_LFC + REAL (WP) :: Y,Y2 + REAL (WP) :: ALPHA,XI + REAL (WP) :: D_EC_1,D_EC_2 + REAL (WP) :: RAT +! + ALPHA=ALFA('3D') ! +! + Y=X+X ! Y = q / k_F + Y2=Y*Y +! +! Computing the exchange-correlation energy derivatives +! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! +! Computing Xi(r_s) +! + RAT=ALPHA*PI_INV*RS + THIRD*ALPHA*ALPHA*RS*RS*RS*D_EC_1 - & ! ref. (2) eq. (2.18) + HALF*THIRD*ALPHA*ALPHA*RS*RS*RS*RS*D_EC_2 ! +! + XI=TWO*PI_INV*ALPHA*RS/RAT ! ref. (1) eq. (4.70) +! + GEV2_LFC=HALF*Y2/(XI+Y2) ! ref. (1) eq. (4.69) +! + END FUNCTION GEV2_LFC +! +!======================================================================= +! + FUNCTION GOCA_LFC(X,RS) +! +! This function computes the Gold-Calmels +! local-field correction +! +! References: (1) A. Gold and L. Calmels, Phys. Rev. B 48, +! 11622-11637 (1993) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,SIX,NINE,TEN,THIRD,FOURTH + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + INTEGER :: IND +! + REAL (WP), INTENT(IN) :: X,RS + REAL (WP) :: GOCA_LFC + REAL (WP) :: Y + REAL (WP) :: NUM,KFOQ0,QQ0 + REAL (WP) :: A1GC(3),B1GC(3),A2GC(3),B2GC(3) + REAL (WP) :: C13,C23 +! + DATA A1GC /0.918E0_WP,0.916E0_WP,0.921E0_WP/ ! Gold-Calmels coefficients + DATA B1GC /0.190E0_WP,0.134E0_WP,0.129E0_WP/ ! for C13 and C23 + DATA A2GC /1.108E0_WP,1.076E0_WP,0.782E0_WP/ ! eq. (12)-(13) + DATA B2GC /0.580E0_WP,0.550E0_WP,0.725E0_WP/ ! +! + Y = X + X ! Y = q / k_F +! + IF(RS < ONE) THEN ! + IND = 1 ! + ELSE ! + IF(RS < TEN) THEN ! + IND = 2 ! + ELSE ! + IF(RS < 50.0E0_WP) THEN ! + IND = 3 ! + END IF ! + END IF ! + END IF ! +! + C13 = A1GC(IND) * (RS**B1GC(IND)) ! +! + IF(RS < ONE) THEN ! + IND = 1 ! + ELSE ! + IF(RS < SIX) THEN ! + IND = 2 ! + ELSE ! + IF(RS < 50.0E0_WP) THEN ! + IND = 3 ! + END IF ! + END IF ! + END IF ! +! + C23 = A2GC(IND) * (RS**B2GC(IND)) ! +! + NUM = (NINE * PI * FOURTH)**THIRD / 12.0E0_WP**FOURTH ! + KFOQ0 = NUM / (RS**FOURTH) ! k_F / q_0 + QQ0 = Y * KFOQ0 ! +! + GOCA_LFC = RS**0.75E0_WP * (0.846E0_WP * QQ0 * QQ0) / & ! + (2.188E0_WP * C13 + QQ0 * QQ0 * C23) ! +! + END FUNCTION GOCA_LFC +! +!======================================================================= +! + FUNCTION HORA_LFC(X,RS) +! +! This function computes the Holas-Rahman +! local-field correction +! +! References: (1) A. Holas and S. Rahman, Phys. Rev. B 35, +! 2720-2731 (1987) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Note: we make an polynomial interpolation of table I +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,EIGHT,HALF,THIRD + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS + REAL (WP) :: HORA_LFC + REAL (WP) :: Y + REAL (WP) :: A0,A2,A4,B2,B4,B6,B8 + REAL (WP) :: Q0,NUM,DEN,IAQ + REAL (WP) :: Y2,Y4,Y6,Y8 + REAL (WP) :: ALPHA +! + REAL (WP) :: LOG,ABS +! + ALPHA = ALFA('3D') ! +! + Y = X + X ! Y = q / k_F +! + Y2 = Y * Y ! + Y4 = Y2 * Y2 ! + Y6 = Y4 * Y2 ! + Y8 = Y6 * Y2 ! +! + CALL HR_PARAMETRIZATION_3D(RS,A0,A2,A4,B2,B4,B6,B8) ! interpolation +! + IF(Y /= TWO) THEN + Q0 = FOUR * ALPHA * RS * PI_INV * ( & ! + HALF + (FOUR - Y2) / (EIGHT * Y) * & ! eq. (47) + LOG(ABS((TWO + Y) / (TWO - Y))) & ! + ) / Y2 ! + ELSE ! + Q0 = TWO * ALPHA * RS * PI_INV / Y2 ! + END IF ! +! + NUM = A0 + A2 * Y2 + A4 * Y4 ! + DEN = ONE + B2 * Y2 + B4 * Y4 + B6 * Y6 + B8 * Y8 ! + IAQ = NUM / DEN ! eq. (48) +! + HORA_LFC = IAQ / Q0 ! eq. (46) +! + END FUNCTION HORA_LFC +! +!======================================================================= +! + SUBROUTINE HR_PARAMETRIZATION_3D(RS,AA0,AA2,AA4,BB2,BB4,BB6,BB8) +! +! This subroutine computes the Holas-Rahman parametrization for the +! calculation of the static 3D local-field correction G(q) +! +! References: (1) A. Holas and S. Rahman, Phys. Rev. B 35, 2720-2731 (1987) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Output parameters: +! +! * The Holas-Rahman parameters A0,A2,A4,B2,B4,B6 and B8 +! +! Table I of ref. (1) is used and the parameters are fitted with a +! 4-th order polynomial in r_s +! +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Jul 2019 +! +! +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS + REAL (WP), INTENT(OUT) :: AA0,AA2,AA4,BB2,BB4,BB6,BB8 + REAL (WP) :: A0(0:4),A2(0:4),A4(0:4) + REAL (WP) :: B2(0:4),B4(0:4),B6(0:4),B8(0:4) + REAL (WP) :: X1,X2,X3,X4 +! + DATA A0 /-0.00048E0_WP , 0.16727E0_WP, 0.0061571E0_WP, & ! + -0.00041917E0_WP, 1.7917E-5_WP / ! + DATA A2 /-0.002098E0_WP , 0.012257E0_WP,-0.013308E0_WP , & ! + 0.0023196E0_WP ,-0.00018303E0_WP / ! + DATA A4 /-0.002224E0_WP ,0.0077895E0_WP,-0.0030371E0_WP, & ! + 0.00054148E0_WP,-3.4888E-5_WP / ! +! + DATA B2 / 0.52865E0_WP ,-0.37039E0_WP , 0.11503E0_WP, & ! + -0.018194E0_WP , 0.0010798E0_WP / ! + DATA B4 / 0.04892E0_WP , 0.093157E0_WP ,-0.04843E0_WP, & ! + 0.0098533E0_WP ,-0.00069E0_WP / ! + DATA B6 / 1.4624E0_WP ,-2.6294E0_WP , 1.4481E0_WP , & ! + -0.31884E0_WP , 0.024511E0_WP / ! + DATA B8 / 0.0057882E0_WP,-0.0009743E0_WP,-0.00042365E0_WP,& ! + 0.0001619E0_WP ,-1.445E-5_WP / ! +! + X1 = RS ! + X2 = X1 * X1 ! + X3 = X2 * X1 ! + X4 = X3 * X1 ! +! + AA0 = A0(0) + A0(1) * X1 + A0(2) * X2 + A0(3) * X3 + A0(4) * X4 ! + AA2 = A2(0) + A2(1) * X1 + A2(2) * X2 + A2(3) * X3 + A2(4) * X4 ! + AA4 = A4(0) + A4(1) * X1 + A4(2) * X2 + A4(3) * X3 + A4(4) * X4 ! +! + BB2 = B2(0) + B2(1) * X1 + B2(2) * X2 + B2(3) * X3 + B2(4) * X4 ! + BB4 = B4(0) + B4(1) * X1 + B4(2) * X2 + B4(3) * X3 + B4(4) * X4 ! + BB6 = B6(0) + B6(1) * X1 + B6(2) * X2 + B6(3) * X3 + B6(4) * X4 ! + BB8 = B8(0) + B8(1) * X1 + B8(2) * X2 + B8(3) * X3 + B8(4) * X4 ! +! + END SUBROUTINE HR_PARAMETRIZATION_3D +! +!======================================================================= +! + FUNCTION UTIC_LFC(X,RS) +! +! This function computes the TABULATED Utsumi-Ichimaru +! local-field correction in the range: +! +! q = [0,150] +! r_s = [1,6] +! +! References: (1) K. Utsumi and S. Ichimaru, Phys. Rev. B 22, +! 5203-5212 (1980) +! +! +! Note: Uses a 6-point Lagrange interpolation for q and r_s +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Sep 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TEN,HALF,TENTH + USE INTERPOLATION, ONLY : LAG_6P_INTERP +! + IMPLICIT NONE +! + INTEGER :: I,J +! + INTEGER, PARAMETER :: N = 46 ! size of q-grid +! + REAL (WP), INTENT(IN) :: X,RS +! + REAL (WP) :: UTIC_LFC + REAL (WP) :: Y +! + REAL (WP) :: QQ(N) ! q-grid + REAL (WP) :: GQ1(N),GQ2(N),GQ3(N) ! G(q) for r_s = 1,2 3 + REAL (WP) :: GQ4(N),GQ5(N),GQ6(N) ! G(q) for r_s = 4,5,6 +! + REAL (WP) :: RR(6) ! r-grid + REAL (WP) :: R1(6),R2(6),R3(6) ! \ + REAL (WP) :: R4(6),R5(6),R6(6) ! / Lagrange 6-q-grid +! + REAL (WP) :: XL(6),AL(6) +! + + REAL (WP) :: STEP_1,STEP_2,STEP_3,STEP_4 ! various q-steps +! +! Tabulated values of r_s (r-grid) +! + DATA RR / 1.0E0_WP, 2.0E0_WP, 3.0E0_WP , & ! RS values + 4.0E0_WP, 5.0E0_WP, 6.0E0_WP / ! in table I +! +! GQn : Tabulated values of G(q) for r_s = n +! + DATA GQ1 / 0.0029_WP, 0.0117_WP, 0.0265_WP, 0.0476_WP, & ! r_s = 1 values + 0.0752_WP, 0.1096_WP, 0.1510_WP, 0.1996_WP, & ! + 0.2553_WP, 0.3180_WP, 0.3875_WP, 0.4633_WP, & ! + 0.5444_WP, 0.6295_WP, 0.7166_WP, 0.8023_WP, & ! + 0.8816_WP, 0.9461_WP, 0.9796_WP, 0.9217_WP, & ! + 0.8279_WP, 0.7897_WP, 0.7659_WP, 0.7494_WP, & ! + 0.7374_WP, 0.7283_WP, 0.7213_WP, 0.7159_WP, & ! + 0.7116_WP, 0.7081_WP, 0.6986_WP, 0.6956_WP, & ! + 0.6950_WP, 0.6955_WP, 0.6977_WP, 0.7001_WP, & ! + 0.7023_WP, 0.7042_WP, 0.7059_WP, 0.7147_WP, & ! + 0.7181_WP, 0.7198_WP, 0.7209_WP, 0.7221_WP, & ! + 0.7230_WP, 0.7237_WP / ! + +! + DATA GQ2 / 0.0031_WP, 0.0123_WP, 0.0280_WP, 0.0504_WP, & ! r_s = 2 values + 0.0797_WP, 0.1163_WP, 0.1603_WP, 0.2119_WP, & ! + 0.2710_WP, 0.3375_WP, 0.4110_WP, 0.4909_WP, & ! + 0.5761_WP, 0.6653_WP, 0.7562_WP, 0.8455_WP, & ! + 0.9282_WP, 0.9958_WP, 1.0321_WP, 0.9767_WP, & ! + 0.8853_WP, 0.8493_WP, 0.8275_WP, 0.8129_WP, & ! + 0.8027_WP, 0.7954_WP, 0.7900_WP, 0.7860_WP, & ! + 0.7831_WP, 0.7810_WP, 0.7774_WP, 0.7788_WP, & ! + 0.7817_WP, 0.7850_WP, 0.7911_WP, 0.7962_WP, & ! + 0.8003_WP, 0.8037_WP, 0.8065_WP, 0.8198_WP, & ! + 0.8243_WP, 0.8267_WP, 0.8280_WP, 0.8296_WP, & ! + 0.8308_WP, 0.8316_WP / ! + + DATA GQ3 / 0.0032_WP, 0.0128_WP, 0.0290_WP, 0.0521_WP, & ! r_s = 3 values + 0.0825_WP, 0.1203_WP, 0.1660_WP, 0.2195_WP, & ! + 0.2808_WP, 0.3497_WP, 0.4257_WP, 0.5083_WP, & ! + 0.5962_WP, 0.6881_WP, 0.7815_WP, 0.8732_WP, & ! + 0.9580_WP, 1.0276_WP, 1.0657_WP, 1.0119_WP, & ! + 0.9220_WP, 0.8873_WP, 0.8667_WP, 0.8533_WP, & ! + 0.8441_WP, 0.8377_WP, 0.8333_WP, 0.8302_WP, & ! + 0.8281_WP, 0.8268_WP, 0.8265_WP, 0.8304_WP, & ! + 0.8352_WP, 0.8399_WP, 0.8480_WP, 0.8543_WP, & ! + 0.8593_WP, 0.8632_WP, 0.8664_WP, 0.8809_WP, & ! + 0.8856_WP, 0.8880_WP, 0.8893_WP, 0.8909_WP, & ! + 0.8920_WP, 0.8928_WP / ! + +! + DATA GQ4 / 0.0032_WP, 0.0131_WP, 0.0296_WP, 0.0533_WP, & ! r_s = 4 values + 0.0844_WP, 0.1232_WP, 0.1700_WP, 0.2249_WP, & ! + 0.2877_WP, 0.3584_WP, 0.4363_WP, 0.5208_WP, & ! + 0.6107_WP, 0.7045_WP, 0.7997_WP, 0.8931_WP, & ! + 0.9795_WP, 1.0504_WP, 1.0897_WP, 1.0370_WP, & ! + 0.9480_WP, 0.9141_WP, 0.8943_WP, 0.8815_WP, & ! + 0.8730_WP, 0.8672_WP, 0.8633_WP, 0.8608_WP, & ! + 0.8592_WP, 0.8583_WP, 0.8599_WP, 0.8653_WP, & ! + 0.8711_WP, 0.8765_WP, 0.8855_WP, 0.8923_WP, & ! + 0.8976_WP, 0.9016_WP, 0.9049_WP, 0.9190_WP, & ! + 0.9234_WP, 0.9256_WP, 0.9268_WP, 0.9282_WP, & ! + 0.9291_WP, 0.9298_WP / ! +! + DATA GQ5 / 0.0033_WP, 0.0132_WP, 0.0301_WP, 0.0541_WP, & ! r_s = 5 values + 0.0857_WP, 0.1251_WP, 0.1726_WP, 0.2284_WP, & ! + 0.2923_WP, 0.3641_WP, 0.4433_WP, 0.5291_WP, & ! + 0.6204_WP, 0.7155_WP, 0.8120_WP, 0.9066_WP, & ! + 0.9941_WP, 1.0660_WP, 1.1061_WP, 1.0541_WP, & ! + 0.9657_WP, 0.9323_WP, 0.9130_WP, 0.9006_WP, & ! + 0.8925_WP, 0.8871_WP, 0.8835_WP, 0.8813_WP, & ! + 0.8800_WP, 0.8795_WP, 0.8823_WP, 0.8886_WP, & ! + 0.8951_WP, 0.9009_WP, 0.9105_WP, 0.9175_WP, & ! + 0.9228_WP, 0.9269_WP, 0.9301_WP, 0.9437_WP, & ! + 0.9477_WP, 0.9496_WP, 0.9507_WP, 0.9519_WP, & ! + 0.9528_WP, 0.9534_WP / ! +! + DATA GQ6 / 0.0033_WP, 0.0134_WP, 0.0305_WP, 0.0548_WP, & ! r_s = 6 values + 0.0868_WP, 0.1268_WP, 0.1750_WP, 0.2315_WP, & ! + 0.2964_WP, 0.3692_WP, 0.4495_WP, 0.5365_WP, & ! + 0.6290_WP, 0.7253_WP, 0.8290_WP, 0.9185_WP, & ! + 1.0068_WP, 1.0794_WP, 1.1201_WP, 1.0685_WP, & ! + 0.9805_WP, 0.9475_WP, 0.9284_WP, 0.9163_WP, & ! + 0.9084_WP, 0.9031_WP, 0.8998_WP, 0.8977_WP, & ! + 0.8966_WP, 0.8962_WP, 0.8997_WP, 0.9064_WP, & ! + 0.9132_WP, 0.9192_WP, 0.9289_WP, 0.9359_WP, & ! + 0.9410_WP, 0.9450_WP, 0.9480_WP, 0.9605_WP, & ! + 0.9640_WP, 0.9657_WP, 0.9666_WP, 0.9676_WP, & ! + 0.9683_WP, 0.9688_WP / ! +! + Y = X + X ! Y = q / k_F +! +! different q-steps +! + STEP_1 = TENTH ! between 0 and 3 + STEP_2 = HALF ! between 3 and 5 + STEP_3 = ONE ! between 5 and 10 + STEP_4 = TEN ! between 10 and 50 +! +! Generating the q-grid points +! + DO I = 1,30 ! + QQ(I) = FLOAT(I) * STEP_1 ! between 0 and 3 + END DO ! + DO I = 31,34 ! + QQ(I) = QQ(30) + FLOAT(I) * STEP_2 ! between 3 and 5 + END DO ! + DO I = 35,39 ! + QQ(I) = QQ(34) + FLOAT(I) * STEP_3 ! between 5 and 10 + END DO ! + DO I = 40,43 ! + QQ(I) = QQ(39) + FLOAT(I) * STEP_4 ! between 10 and 50 + END DO ! +! + QQ(44) = 70.0E0_WP ! + QQ(45) = 100.0E0_WP ! + QQ(46) = 150.0E0_WP ! +! +! Locating q/k_F within the UTIC q-grid --> Y = q/k_F near QQ(J) +! + CALL LOCATE(QQ,N,Y,J) ! +! +! 6-point Lagrange interpolation for each value of r_s: +! +! XL(I) : the 6 values of q/k_F used to find Y +! Rn(I) : the 6 corresponding values of GQn +! + IF(J == 1) THEN ! +! +! Y is near 1st point of q-grid +! + DO I = 1,6 ! + XL(I) = QQ(I) ! + R1(I) = GQ1(I) ! + R2(I) = GQ2(I) ! + R3(I) = GQ3(I) ! + R4(I) = GQ4(I) ! + R5(I) = GQ5(I) ! + R6(I) = GQ6(I) ! + END DO ! +! + ELSE IF(J == 2) THEN ! +! +! Y is near 2nd point of q-grid +! + DO I = 1,6 ! + XL(I) = QQ(I) ! + R1(I) = GQ1(I) ! + R2(I) = GQ2(I) ! + R3(I) = GQ3(I) ! + R4(I) = GQ4(I) ! + R5(I) = GQ5(I) ! + R6(I) = GQ6(I) ! + END DO ! +! + ELSE IF(J == N) THEN ! +! +! Y is near last point of q-grid (point N) +! + DO I = 6,1,-1 ! + XL(I) = QQ(N+I-6) ! + R1(I) = GQ1(N+I-6) ! + R2(I) = GQ2(N+I-6) ! + R3(I) = GQ3(N+I-6) ! + R4(I) = GQ4(N+I-6) ! + R5(I) = GQ5(N+I-6) ! + RR(I) = GQ6(N+I-6) ! + END DO ! +! + ELSE IF(J == N-1) THEN ! +! +! Y is near last but one point of q-grid (point N-1) +! + DO I = 6,1,-1 ! + XL(I) = QQ(N+I-6) ! + R1(I) = GQ1(N+I-6) ! + R2(I) = GQ2(N+I-6) ! + R3(I) = GQ3(N+I-6) ! + R4(I) = GQ4(N+I-6) ! + R5(I) = GQ5(N+I-6) ! + R6(I) = GQ6(N+I-6) ! + END DO ! +! + ELSE ! +! +! General case: 6 points used from J-2 to J+3 +! + DO I = 1,6 ! + XL(I) = QQ(J+I-3) ! + R1(I) = GQ1(J+I-3) ! + R2(I) = GQ2(J+I-3) ! + R3(I) = GQ3(J+I-3) ! + R4(I) = GQ4(J+I-3) ! + R5(I) = GQ5(J+I-3) ! + R6(I) = GQ6(J+I-3) ! + END DO ! +! + END IF ! +! +! for each r-grid point K: q-interpolation to obtain AL(K) = GQk(Y) +! + AL(1) = LAG_6P_INTERP(XL,R1,Y) ! GQ(Y) for rs = 1 set + AL(2) = LAG_6P_INTERP(XL,R2,Y) ! GQ(Y) for rs = 2 set + AL(3) = LAG_6P_INTERP(XL,R3,Y) ! GQ(Y) for rs = 3 set + AL(4) = LAG_6P_INTERP(XL,R4,Y) ! GQ(Y) for rs = 4 set + AL(5) = LAG_6P_INTERP(XL,R5,Y) ! GQ(Y) for rs = 5 set + AL(6) = LAG_6P_INTERP(XL,R6,Y) ! GQ(Y) for rs = 6 set +! +! Locating r_s within the UTIC rs-grid +! + UTIC_LFC = LAG_6P_INTERP(RR,AL,RS) ! +! +Contains +! +!----------------------------------------------------------------------- +! + SUBROUTINE LOCATE(XX,N,X,J) +! +! +! This subroutine is taken from the book : +! "Numerical Recipes : The Art of Scientific +! Computing" par W.H. PRESS, B.P. FLANNERY, +! S.A. TEUKOLSKY et W.T. VETTERLING +! (Cambridge University Press 1992) +! +! It performs a search in an ordered table using a bisection method. +! Given a monotonic array XX(1:N) and a value X, it returns J such +! that X is between XX(J) and XX(J+1). +! + INTEGER, INTENT(IN) :: N + INTEGER, INTENT(OUT) :: J +! + INTEGER :: JL,JM,JU +! + REAL (WP), INTENT(IN) :: XX(N),X +! + JL = 0 ! + JU = N + 1 ! +! + 10 IF(JU-JL > 1)THEN ! + JM = (JU+JL) / 2 ! + IF((XX(N) > XX(1)) .EQV. (X > XX(JM)))THEN ! + JL = JM ! + ELSE + JU = JM ! + END IF ! + GO TO 10 ! + END IF ! + J = JL ! +! + END SUBROUTINE LOCATE +! +!----------------------------------------------------------------------- +! + END FUNCTION UTIC_LFC +! +!======================================================================= +! + FUNCTION ICUT_LFC(X,RS,T) +! +! This function computes Ichimaru-Utsumi +! local-field correction +! +! References: (1) S. Ichimaru and K. Utsumi, Phys. Rev. B 24, 7 +! 385-7388 (1981) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,FIVE,EIGHT, & + NINE,THIRD,FOURTH + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : ALFA + USE ASYMPT, ONLY : G0 + USE BESSEL, ONLY : BESSI1 +! + IMPLICIT NONE +! + REAL (WP) :: X,RS,T,Y,Z,Y_INV,ICUT_LFC + REAL (WP) :: Y2,Y3,Y4 + REAL (WP) :: ALPHA,G_0,D_EC_1,D_EC_2 + REAL (WP) :: A,B,C +! + REAL (WP) :: SQRT,LOG,ABS +! + ALPHA=ALFA('3D') ! +! + Y=X+X ! Y = q / k_F + Y2=Y*Y ! + Y3=Y2*Y ! + Y4=Y3*Y ! +! + Y_INV=ONE/Y ! 1 / Y +! +! Calculation of g(0) +! + Z=FOUR*SQRT(ALPHA*RS/PI) ! + G_0=0.1250E0_WP*(Z/BESSI1(Z))**2 ! eq.7 ref (1 +! + A=0.029E0_WP ! eq.9 ref (1) + B=NINE*G0/16.0E0_WP - THREE*(ONE-G_0)/64.0E0_WP - & ! eq.10 ref (1) + 16.0E0_WP*A/15.0E0_WP ! + C=-0.750E0_WP*G0 + NINE*(ONE-G_0)/16.0E0_WP - & ! eq.11 ref (1) + 16.0E0_WP*A/FIVE ! +! + ICUT_LFC=A*Y4+B*Y2+C+(A*Y4+(B+EIGHT*A/THREE)*Y2-C)* & ! + (Y_INV-FOURTH*Y)*LOG(ABS((TWO+Y)/(TWO-Y))) ! +! + END FUNCTION ICUT_LFC +! +!======================================================================= +! + FUNCTION IWA1_LFC(X,RS) +! +! This function computes the Iwamoto G_{-1} +! local-field correction +! +! References: (1) N. Iwamoto, Phys. Rev. A 30, 3289-3304 (1984) +! +! +! Note: valid for (q/k_F) --> 0 +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THIRD,FOURTH + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS + REAL (WP) :: IWA1_LFC + REAL (WP) :: Y,Y2 + REAL (WP) :: ALPHA +! + REAL (WP) :: LOG +! + ALPHA=ALFA('3D') ! +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! Y^2 +! + IWA1_LFC=( FOURTH + FOURTH * PI_INV * & ! + (ONE - LOG(TWO)) * ALPHA * RS & ! ref. (1) eq. (3.8a) + ) * Y2 ! +! + END FUNCTION IWA1_LFC +! +!======================================================================= +! + FUNCTION IWA2_LFC(X,RS) +! +! This function computes the Iwamoto G_{3} +! local-field correction +! +! References: (1) N. Iwamoto, Phys. Rev. A 30, 3289-3304 (1984) +! +! +! Note: valid for (q/k_F) --> 0 +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,THIRD + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS + REAL (WP) :: IWA2_LFC + REAL (WP) :: Y,Y2 + REAL (WP) :: ALPHA +! + REAL (WP) :: LOG +! + ALPHA = ALFA('3D') ! +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + IWA2_LFC = (THREE + 22.0E0_WP * PI_INV * (ONE - LOG(TWO)) * & ! ref. (1) eq. (4.19a) + ALPHA * RS * LOG(RS)) * Y2 / 20.0E0_WP ! +! + END FUNCTION IWA2_LFC +! +!======================================================================= +! + FUNCTION IWA3_LFC(X,RS,T) +! +! This function computes the temperature-dependent Iwamoto G_{-1} +! local-field correction +! +! References: (1) N. Iwamoto, Phys. Rev. A 30, 3289-3304 (1984) +! +! +! Note: valid for (q/k_F) --> 0 +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 25 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : THREE,FOUR,FOURTH + USE SQUARE_ROOTS, ONLY : SQR3 + USE CONSTANTS_P1, ONLY : H_BAR,BOHR,E,M_E,EPS_0,K_B + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE EULER_CONST, ONLY : EUMAS + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE PLASMON_SCALE_P, ONLY : DEGEN +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: IWA3_LFC + REAL (WP) :: Y + REAL (WP) :: Q_D,Q_SI,R + REAL (WP) :: GAMMA +! + REAL (WP) :: SQRT,LOG +! + Y = X + X ! Y = q / k_F +! + Q_SI = Y * KF_SI ! q in SI + CALL DEBYE_VECTOR('3D',T,RS,Q_D) ! q_D in SI +! + R = Q_SI / Q_D ! +! + GAMMA = E * E / (K_B * T * RS * BOHR) ! ref. (1) eq. (6.6a) + GAMMA =DEGEN ! +! ! + IWA3_LFC = ( FOURTH * SQR3 * GAMMA**1.5E0_WP + & ! + GAMMA**THREE * ( & ! + 0.75E0_WP * LOG(THREE * GAMMA) + EUMAS - & ! eq. (6.17a) + 13.0E0_WP / 24.0E0_WP ) & ! + ) * R * R ! +! + END FUNCTION IWA3_LFC +! +!======================================================================= +! + FUNCTION IWA4_LFC(X,RS) +! +! This function computes the Iwamoto G_{3} +! local-field correction +! +! References: (1) N. Iwamoto, Phys. Rev. A 30, 3289-3304 (1984) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Note: The formula used is based on eq. (4.13) and reads +! +! G_{3} = I(q) + 4 * om_q / h_bar om_p^2) * (E_C + r_s * d Ec / d rs) +! \ / +! ---------------------- +! \ / +! COEF +! +! Warning: Ec is calculated in Ryd --> has to be converted into SI +! +! COnversion coefficient: RY2SI (or 1/2 HARTREE) +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,FOUR,HALF + USE FERMI_SI, ONLY : KF_SI + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE ENE_CHANGE, ONLY : RY2SI + USE PLASMON_ENE_SI + USE ENERGIES, ONLY : EC_TYPE + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS + REAL (WP) :: IWA4_LFC +! + REAL (WP) :: Y + REAL (WP) :: Q_SI,COEF + REAL (WP) :: OM_P,OM_Q + REAL (WP) :: I_Q + REAL (WP) :: E_C,D_EC_1,D_EC_2 +! + Y = X + X ! Y = q / k_F +! + Q_SI = Y * KF_SI ! q in SI +! + OM_P = ENE_P_SI / H_BAR ! omega_p + OM_Q = HALF * H_BAR * Q_SI * Q_SI / M_E ! omega_q +! + COEF = FOUR * OM_Q / (H_BAR * OM_P * OM_P) ! +! +! Calculation of I(q) +! + I_Q = IQ(X,RS) ! +! +! Calculation of Ec and d Ec / d rs +! + E_C = EC_3D(EC_TYPE,1,RS,ZERO) ! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,ZERO,D_EC_1,D_EC_2) ! +! + IWA4_LFC = I_Q + COEF * (E_C + RS * D_EC_1) * RY2SI ! ref. (1) eq. (4.13) +! ! and (4.16) +CONTAINS +! +!----------------------------------------------------------------------- +! + FUNCTION IQ(X,RS) +! +! This function computes the Iwamoto-Krotscheck-Pines +! parametrization for the calculation of the I(q) function +! +! We use a fourth-degree polynomial to fit the data of +! table II reference (1): r_s = 1 --> A1 +! r_s = 2 --> A2 +! r_s = 5 --> A5 +! +! For a given value of (q / k_F), this gives 3 values of I(q / k_F). +! Then, we use Lagrange interpolation to find I(q / k_F) for the +! input value r_s +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Reference: (1) N. Iwamoto, E. Krotscheck and D. Pines, +! Phys. Rev. B 28, 3936-3951 (1984) +! (2) https://en.wikipedia.org/wiki/Lagrange_polynomial +! +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FIVE,THIRD,FOURTH +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS + REAL (WP) :: IQ + REAL (WP) :: Y,Y2,Y3,Y4 + REAL (WP) :: A1(0:4),A2(0:4),A5(0:4) + REAL (WP) :: I1,I2,I5,L1,L2,L5 +! + DATA A1 / 0.0039314E0_WP, - 0.03844E0_WP , 0.29126E0_WP, & ! coefficients of + - 0.13488E0_WP, 0.018838E0_WP / ! the 4th-degree + DATA A2 / 0.005127E0_WP , - 0.048227E0_WP, 0.32508E0_WP, & ! polynomials + - 0.14552E0_WP , 0.019639E0_WP / ! used to fit + DATA A5 / 0.0077247E0_WP, - 0.068004E0_WP, 0.3837E0_WP , & ! table II + - 0.15996E0_WP , 0.019756E0_WP / ! data +! + Y = X + X ! q / k_F + Y2 = Y * Y ! + Y3 = Y2 * Y ! powers of Y + Y4 = Y3 * Y ! +! +! Computing I(q) for r_s = 1,2 and 5 +! + I1 = A1(0) + A1(1) * Y + A1(2) * Y2 + A1(3) * Y3 + A1(4) * Y4 ! + I2 = A2(0) + A2(1) * Y + A2(2) * Y2 + A2(3) * Y3 + A2(4) * Y4 ! + I5 = A5(0) + A5(1) * Y + A5(2) * Y2 + A5(3) * Y3 + A5(4) * Y4 ! +! +! Performing Lagrange interpolation between I1, I2 and I5: +! +! I(r_s) = I1 * L1(r_s) + I2 * L2(r_s) + I5 * L5(r_s) +! + L1 = FOURTH * (RS - TWO) * (RS - FIVE) ! + L2 = - THIRD * (RS - ONE) * (RS - FIVE) ! + L5 = FOURTH * THIRD * (RS - ONE) * (RS - TWO) ! +! + IQ = I1 * L1 + I2 * L2 + I5 * L5 ! +! + END FUNCTION IQ +! +!----------------------------------------------------------------------- +! + END FUNCTION IWA4_LFC +! +!======================================================================= +! + FUNCTION KUGL_LFC(X,RS,T) +! +! This function computes the Kugler local-field correction, +! +! +! Reference: (1) A. A. Kugler, J. Stat. Phys. 12, 35-87 (1975) +! +! +! Note: Here, we have used the fact that +! +! eps = 1 - V_C * chi_0 = 1 + (q_TF / q)^2 * LINDHARD_FUNCTION +! +! so that +! +! chi_0 = - (q_TF / q)^2 * LINDHARD_FUNCTION / V_C +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 19 Sep 2020 +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,FIVE,SIX, & + EIGHT,HALF,THIRD,FOURTH + USE PI_ETC, ONLY : PI2 + USE CONSTANTS_P1, ONLY : M_E,H_BAR + USE FERMI_SI, ONLY : KF_SI + USE LINDHARD_FUNCTION, ONLY : LINDHARD_S + USE COULOMB_K, ONLY : COULOMB_FF + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR +! + USE UNITS, ONLY : UNIT +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: KUGL_LFC + REAL (WP) :: Y,Y2,Y3,Y4 + REAL (WP) :: EP2,EM2,OM2 + REAL (WP) :: Q_SI,K_TF,VC + REAL (WP) :: CHI_0 + REAL (WP) :: LR,LI + REAL (WP) :: KOEF + REAL (WP) :: PM1 + REAL (WP) :: INTGR_1,INTGR_2 + REAL (WP) :: INTGR_3,INTGR_4 + REAL (WP) :: INTGR_5,INTGR_6 +! + REAL (WP) :: LOG,ABS +! + Y = X + X ! Y = q / k_F = eta + Y2 = Y * Y ! Y^2 = eta^2 + Y3 = Y2 * Y ! Y^3 = eta^3 + Y4 = Y2 * Y2 ! Y^4 = eta^4 +! + EP2 = Y + TWO ! + EM2 = Y - TWO ! + OM2 = ABS(ONE - Y) ! +! + Q_SI = TWO * X* KF_SI ! q in SI +! + CALL COULOMB_FF('3D',UNIT,Q_SI,ZERO,VC) ! Coulomb potential + CALL THOMAS_FERMI_VECTOR('3D',K_TF) ! k_TF + CALL LINDHARD_S(X,'3D',LR,LI) ! +! +! Computing chi_0 +! + CHI_0 = - (KF_SI / Q_SI)**2 * LR / VC ! +! + KOEF = M_E * KF_SI / (16.0E0_WP * PI2 * H_BAR * H_BAR) ! +! + IF(X < ONE) THEN ! + PM1 = - 24.0E0_WP / FIVE + 23.0E0_WP * Y2 / 30.0E0_WP + & ! + EIGHT * (ONE - HALF * Y) * LOG(ABS(ONE - TWO / Y)) & ! + + (- EIGHT + TWO * Y - TWO * Y2 + THIRD * Y4) * & ! + LOG(ABS(ONE - FOUR / Y2)) + & ! + ( FOUR * LOG(TWO) + FOUR * LOG(Y) + & ! + LOG(ABS(ONE - FOUR / Y2)) ) * Y * LOG(EP2 / EM2) & ! + + ( 12.0E0_WP / (FIVE * Y) + FOUR - SIX * Y + & ! + 0.75E0_WP * Y3 ) * LOG(EP2 / EM2) + & ! + ( 12.0E0_WP / (FIVE * Y) + EIGHT / FIVE + & ! + 41.0E0_WP * Y / 15.0E0_WP - & ! + 11.0E0_WP * Y2 / 15.0E0_WP - & ! + FOUR * Y3 / 15.0E0_WP ) * (ONE + Y) * & ! ref. (1) eq. (D11a) + LOG(ABS(ONE + TWO / Y)) - & ! + ( 12.0E0_WP / (FIVE * Y) - EIGHT / FIVE + & ! + 41.0E0_WP * Y / 15.0E0_WP + & ! + 11.0E0_WP * Y2 / 15.0E0_WP - & ! + FOUR * Y3 / 15.0E0_WP ) * ABS(ONE - Y) * & ! + LOG(ABS((ONE + OM2) / (ONE - OM2))) + & ! + Y * ( LOG(ABS((ONE + OM2) / (ONE - OM2))) * & ! + LOG(ABS((ONE + OM2) / (ONE - OM2))) - & ! + LOG(ABS(ONE + TWO / Y)) * & ! + LOG(ABS(ONE + TWO / Y)) ) - & ! + TWO * Y * (INTGR_1 + INTGR_2) + & ! + 1.5E0_WP * (ONE + HALF * Y2 - Y4 / 48.0E0_WP) * & ! + INTGR_3 - INTGR_4 ! + ELSE ! + PM1 = - 24.0E0_WP / FIVE + 23.0E0_WP * Y2 / 30.0E0_WP + & ! + Y4 * LOG(ABS(ONE - FOUR / Y2)) + & ! + (- FOURTH * Y2 + THIRD + 24.0E0_WP / (FIVE * Y2))* & ! + Y * LOG(EP2 / EM2) + & ! ref. (1) eq. (D11b) + FOUR * Y * (LOG(TWO) + LOG(Y)) * LOG(EP2 / EM2) - & ! + TWO * Y * INTGR_5 + & ! + 1.5E0_WP * (ONE + HALF * Y2 - Y4 / 48.0E0_WP) * & ! + INTGR_6 ! + + END IF ! +! + KUGL_LFC = PM1 / CHI_0 ! ref. (1) eq. (D.9) +! + END FUNCTION KUGL_LFC +! +!======================================================================= +! + FUNCTION MCSC_LFC(X,RS,T,EC_TYPE) +! +! This function computes the Corradini-Del Sole-Onida-Palummo +! local-field correction +! +! References: (1) S. Moroni, D. M. Ceperley and G. Senatore, Phys. Rev. Lett. 75, 689-692 (1995) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! * EC_TYPE : type of correlation energy functional +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,FIVE,EIGHT,NINE, & + HALF,THIRD,FOURTH + USE FERMI_AU, ONLY : KF_AU + USE PI_ETC, ONLY : PI,PI2 + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: MCSC_LFC + REAL (WP) :: Y,Y2 + REAL (WP) :: U,U3 + REAL (WP) :: A,B,C + REAL (WP) :: COEF + REAL (WP) :: RS2,RS3 + REAL (WP) :: A1,A2,B1,B2 + REAL (WP) :: EC,D_EC_1,D_EC_2 + REAL (WP) :: N,NN +! + REAL (WP) :: SQRT,FLOAT +! + COEF = (FOUR * PI2 / NINE)**THIRD / 24.0E0_WP ! +! + Y = X + X ! Y = q / k_F = Q in ref. 1 + Y2 = Y*Y ! Q^2 in ref. 1 + U = SQRT(RS) ! x in ref. 1 + U3 = U * U * U ! x^3 in ref. 1 +! + RS2 = RS * RS ! + RS3 = RS2 * RS ! +! + A1 = 2.15E0_WP ! + A2 = 0.435E0_WP ! for MCSC + B1 = 1.57E0_WP ! coefficients + B2 = 0.409E0_WP ! +! +! Correlation energy and its derivatives +! + EC = EC_3D(EC_TYPE,1,RS,T) ! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! + A = FOURTH - COEF * (RS3 * D_EC_2 - TWO * RS2 * D_EC_1) ! + B = (ONE + A1 * U + A2 * U3) / (THREE + B1 * U + B2 * U3) ! + C = - HALF * PI* (EC + RS * D_EC_1) / KF_AU ! +! +! value of the exponent n ! +! + IF(RS <= FIVE) THEN ! + N = EIGHT ! + ELSE ! + N = FOUR ! + END IF ! + NN = ONE / N ! +! + MCSC_LFC = (((A - C)**(-N) + (Y2 / B)**N)**(- NN) + C) * Y2 ! ref (1) eq. (7) +! + END FUNCTION MCSC_LFC +! +!======================================================================= +! + FUNCTION NAGY_LFC(X,RS) +! +! This function computes the NAGY +! local-field correction +! +! References: (1) I. Nagy, J. Phys. C: Solid State Phys. 19, +! L481-L484 (1986) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF,THIRD,FOURTH + USE FERMI_AU, ONLY : KF_AU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS + REAL (WP) :: NAGY_LFC + REAL (WP) :: Y,RS3 + REAL (WP) :: NUM,DEN,G0N + REAL (WP) :: AM,A,B,AN,BN,R,CM,BM + REAL (WP) :: Q_AU +! + REAL (WP) :: EXP,SQRT,ATAN +! + Y = X + X ! Y = q / k_F +! + RS3 = RS * RS * RS ! +! + Q_AU = Y * KF_AU ! q in atomic units +! + NUM = ONE + TWO * EXP(- 0.6E0_WP * RS) ! + DEN = NUM + TWO * RS ! + G0N = HALF * NUM / DEN ! ref. (1) eq. (7) +! + AM = G0N - ONE ! a + A = 24.0E0_WP * AM / RS3 ! A + B = 18.0E0_WP * G0N / RS3 ! B +! + AN = FOURTH * A ! A/4 + BN = THIRD * B ! B/3 + R = (AN**2 + SQRT(AN**4 - BN**3))**THIRD + & ! + (AN**2 - SQRT(AN**4 - BN**3))**THIRD ! R +! + CM = SQRT(HALF * R) * & ! + (ONE + SQRT(- ONE - TWO * A / ((TWO * R)**1.5E0_WP))) ! c + BM = G0N * (ONE + CM) - CM ! b +! + NAGY_LFC = ONE - G0N + CM * BM / (CM * CM + Q_AU * Q_AU) - & ! + G0N * ATAN(Q_AU / CM) / Q_AU ! +! + END FUNCTION NAGY_LFC +! +!======================================================================= +! + FUNCTION NEV1_LFC(X,RS) +! +! This function computes the Nevanlinna two-moment +! local-field correction +! +! References: (1) D. Yu. Dubovtsev, PhD Thesis, +! Universitat Politècnica de València (2019) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE CONSTANTS_P1, ONLY : H_BAR + USE LOSS_MOMENTS, ONLY : LOSS_MOMENTS_AN + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS +! + REAL (WP) :: NEV1_LFC + REAL (WP) :: C0,C2,C4 + REAL (WP) :: OM12 + REAL (WP) :: EPSR + REAL (WP) :: OMP,OMP2 +! +! Computing the moments of the loss function +! + CALL LOSS_MOMENTS_AN(X,C0,C2,C4) +! +! Computing eps_{RPA}(q) from the moment C0 +! + EPSR = ONE / (ONE - C0) ! +! + OM12 = C2 / C0 ! + OMP = ENE_P_SI / H_BAR ! omega_p + OMP2 = OMP * OMP +! + NEV1_LFC = ONE + ONE / (ONE - EPSR) - OM12 / OMP2 ! ref. (1) eq. (4.15) +! + END FUNCTION NEV1_LFC +! +!======================================================================= +! + FUNCTION PVHF_LFC(X) +! +! This function computes Pathak-Vashishta Hartree-Fock +! local-field correction +! +! References: (1) A. Holas, P.K. Aravind and K.S. Singwi, +! Phys. Rev. B 20, 4912 (1979) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,FIVE,SIX, & + HALF,THIRD,SMALL +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: PVHF_LFC + REAL (WP) :: Y,Y2,Y4,Y6,Y_INV,Y2_INV + REAL (WP) :: P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11 + REAL (WP) :: F4,F5 + REAL (WP) :: LN1,LN2 + REAL (WP) :: G2,DIFF +! + REAL (WP) :: LOG,ABS +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! Y^2 + Y4 = Y2 * Y2 ! Y^4 + Y6 = Y4 * Y2 ! Y^6 + Y_INV = ONE / Y ! 1 / Y + Y2_INV = ONE / Y2 ! 1 / Y^2 +! + DIFF = ABS(Y - TWO) ! +! + P1 = - THREE / 16.0E0_WP ! + P2 = - 32.0E0_WP / 63.0E0_WP ! + P3 = 24.0E0_WP / 35.0E0_WP ! + P4 = - TWO / FIVE ! + P5 = ONE / SIX ! Pathak and + P6 = TWO / 35.0E0_WP ! Vashishta + P7 = - ONE / 630.0E0_WP ! coefficients + P8 = - TWO / 21.0E0_WP ! + P9 = 38.0E0_WP / 315.0E0_WP ! + P10 = 71.0E0_WP / 840.0E0_WP ! + P11 = ONE / 840.0E0_WP ! +! + F4 = P2 + P3 * Y2 + P4 * Y4 + P5 * Y6 ! Pathak and + F5 = Y * Y6 *(P6 + P7 * Y2) ! Vashishta factors +! ! +! Pathological case: value of G for x=2 +! ! + G2 = (143.0E0_WP * THIRD - 32.0E0_WP * LOG(TWO) )/ 105.0E0_WP ! +! + IF(DIFF >= SMALL) THEN ! + LN1 = LOG(ABS((Y + TWO)/(Y - TWO))) ! + LN2 = LOG(ABS(ONE - FOUR * Y2_INV)) ! +! + PVHF_LFC = P1 * Y_INV *Y2_INV * (LN1 * F4 + LN2 * F5)+ & ! + P8 * Y2_INV + P9 + P10 * Y2 + P11 * Y4 ! + ELSE ! + PVHF_LFC = G2 ! + END IF ! +! + END FUNCTION PVHF_LFC +! +!======================================================================= +! + FUNCTION PGGA_LFC(X) +! +! This function computes the Petersilka-Gossmann-Gross local-field correction +! +! References: (1) K. Tatarczyk, A. Schindlmayr and M. Scheffler, +! Phys. Rev. B 63, 235106 (2001) +! +! Note: we have G(q) = - f_{xc} / Vc(q) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,TEN + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP) :: X,PGGA_LFC + REAL (WP) :: COEF,Q,Q2,Q4 +! + REAL (WP) :: LOG,ABS +! + Q = X ! q / (2 * k_F) + Q2 = Q * Q ! + Q4 = Q2 * Q2 ! +! 3 pi 1 + COEF = THREE * Q2 / TEN ! ---------- * ------- +! 10 k_F^2 Vc(q) +! +! Computation of the local-field formula +! + IF(Q == ONE) THEN ! + PGGA_LFC = COEF * ( 13.0E0_WP - 16.0E0_WP * LOG(TWO) ) ! pathological case + ELSE ! + PGGA_LFC = COEF * ( & ! + 11.0E0_WP + TWO * Q2 + & ! + (TWO / Q - TEN * Q) * & ! ref. (1) eq. (12) + LOG(ABS((ONE + Q) / (ONE - Q))) + & ! + (TWO * Q4 - TEN * Q2)*LOG(ABS(ONE - ONE / Q2)) & ! + ) ! + END IF ! +! + END FUNCTION PGGA_LFC +! +!======================================================================= +! + FUNCTION SHAW_LFC(X) +! +! This function computes the Shaw +! local-field correction +! +! References: (1) R. W. Shaw, J. Phys. C: Solid State Phys. 3, +! 1140-1158 (1970) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,HALF + USE UTILITIES_1, ONLY : ALFA + USE EXT_FUNCTIONS, ONLY : DAWSON ! Dawson function D(x) +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: SHAW_LFC + REAL (WP) :: Y + REAL (WP) :: ALPHA,U +! + ALPHA = ALFA('3D') ! +! + Y = X + X ! Y = q / k_F +! + U = HALF * Y / ALPHA ! U = q / (2 k_F * ALPHA) +! + SHAW_LFC = ONE - DAWSON(U) / U ! +! + END FUNCTION SHAW_LFC +! +!======================================================================= +! + FUNCTION STLS_LFC(X) +! +! This function computes the Singwi-Tosi-Land-Sjölander +! local-field correction +! +! References: (1) K.S. Singwi, M.P. Tosi, R.H. Land and A. Sjölander, +! Phys. Rev. 176, 589 (1968) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,SIX,EIGHT,NINE, & + HALF,SMALL +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: STLS_LFC + REAL (WP) :: Y,Y2,Y_INV,Y2_INV + REAL (WP) :: S1,S2,S3,S4,S5,S6 + REAL (WP) :: F1,F2,F3 + REAL (WP) :: LN1,LN2 + REAL (WP) :: G1,DIFF +! + REAL (WP) :: ABS,LOG +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! Y^2 + Y_INV = ONE / Y ! 1 / Y + Y2_INV = ONE / Y2 ! 1 / Y^2 +! + DIFF = ABS(Y - TWO) ! +! + S1 = NINE / 32.0E0_WP ! + S2 = TWO / 105.0E0_WP ! + S3 = EIGHT / 35.0E0_WP ! STLS + S4 = FOUR / 15.0E0_WP ! coefficients + S5 = ONE / 210.0E0_WP ! + S6 = HALF * S4 ! +! + F1 = 24.0E0_WP * Y2_INV + 44.0E0_WP + Y2 ! \ + F2 = S3 * Y2_INV - S4 + (Y2 / SIX) ! > STLS factors + F3 = S5 * Y2 - S6 ! / +! +! Pathological case: value of G for x = 2 +! + G1 = NINE * (4.50E0_WP - FOUR * LOG(TWO)) / 35.0E0_WP ! +! + IF(DIFF >= SMALL) THEN ! + LN1 = LOG(ABS((Y + TWO)/(Y - TWO))) ! + LN2 = LOG(ABS(ONE - FOUR * Y2_INV)) ! +! + STLS_LFC = S1 * Y2 * ( S2 * F1 - & ! + TWO * Y_INV * F2 * LN1 + & ! + Y2 * F3 * LN2 & ! + ) ! + ELSE ! + STLS_LFC = G1 ! + END IF ! +! + END FUNCTION STLS_LFC +! +!======================================================================= +! + FUNCTION TRMA_LFC(X) +! +! This function computes the Tripathy-Mandal local-field correction +! +! +! References: (1) D. N. Tripathy and S. S. Mandal, Phys. Rev. B 16, +! 231-243 (1977) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,HALF,FOURTH, & + SMALL,TTINY + USE DIMENSION_CODE, ONLY : NZ_MAX + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + INTEGER :: IQ1,IQ2,IX2 + INTEGER :: NK_STEP,NX_STEP + INTEGER :: ID +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: TRMA_LFC + REAL (WP) :: K,K2 + REAL (WP) :: G1,G2,G12 + REAL (WP) :: A1,B1,C1 + REAL (WP) :: X_STEP + REAL (WP) :: Q_INI,Q_MAX,Q_STEP + REAL (WP) :: R1(NZ_MAX),R2(NZ_MAX),R3(NZ_MAX) + REAL (WP) :: Q1,Q2,X2 + REAL (WP) :: Q12,Q22,CC1,CC2 + REAL (WP) :: NUM1,NUM2,NUM3,NUM4 + REAL (WP) :: DEN1,DEN2,DEN3,DEN4 + REAL (WP) :: I,A,B + REAL (WP) :: F + REAL (WP) :: SMALL_Q,SMALL_X +! +! Number of steps for K-integration +! + NK_STEP = 100 ! +! +! Number of steps for X-integration +! + NX_STEP = 100 ! +! + K = X + X ! K = q / k_F + K2 = K * K ! +! + IF(K <= TWO) THEN ! + Q_INI = ONE - HALF * K ! initial, + Q_MAX = ONE + HALF * K ! final values + ELSE ! for q-integrations + Q_INI = HALF * K - ONE ! ( see eq. (4.32) and + Q_MAX = HALF * K + ONE ! (4.33) ) + ENDIF ! +! + Q_STEP = (Q_MAX - Q_INI) / FLOAT(NK_STEP - 1) ! q-step + SMALL_Q = HALF * Q_STEP ! +! +! Starting loop over q2 +! + DO IQ2 = 1,NK_STEP ! + Q2 = Q_INI + FLOAT(IQ2 - 1) * Q_STEP ! q2 + Q22 = Q2 * Q2 ! q2^2 + G2 = (Q22 + FOURTH * K2 - ONE) / (Q2 * K) ! initial value for x-integration (4.31) +! + IF(ABS(G2 - ONE) > SMALL) GO TO 10 ! integral = 0 when G2 = 1 +! + X_STEP = (ONE - G2) / FLOAT(NX_STEP - 1) ! x-step + SMALL_X = HALF * X_STEP ! +! +! Starting loop over q1 +! + DO IQ1 = 1,NK_STEP ! + Q1 = Q_INI + FLOAT(IQ1 - 1) * Q_STEP ! q1 + Q12 = Q1 * Q1 ! q1^2 + G1 = (Q12 + FOURTH * K2 - ONE) / (Q1 * K) ! ref. (1) eq. (4.28) + G12 = G1 * G1 ! + A1 = FOUR * Q12 * Q22 ! a1 coefficient (4.27) +! +! Starting loop over x2 +! + DO IX2 = 1,NX_STEP ! + X2 = G2 + FLOAT(IX2 - 1) * X_STEP ! x2 array + B1 = - FOUR * Q1 * Q2 * X2 * (Q12 + Q22) ! b1 coefficient (4.27) + C1 = A1 * X2 * X2 + (Q12 - Q22) * (Q12 - Q22) ! c1 coefficient (4.27) +! +! Computing R(q2,q1,x2) +! + IF(ABS(Q2 - Q1) > SMALL_Q) THEN ! +! + IF(ABS(X2 - ONE) > SMALL_X) THEN ! case q1 /= q2, x2 /= 1 +! + CC1 = Q1 * Q2 / (X2 * SQRT(C1)) ! + CC2 = Q12 / (X2 * X2 * SQRT(A1)) ! +! + NUM1 = TWO * SQRT( C1 * (A1*G12 + B1*G1 + C1) ) + & ! + TWO * C1 + B1 * G1 ! + DEN1 = TWO * SQRT( C1 * (A1 + B1 + C1) ) + & ! + TWO * C1 + B1 ! + NUM2 = TWO * SQRT( C1 * (A1*G12 - B1*G1 + C1) ) + & ! + TWO * C1 - B1 * G1 ! + DEN2 = TWO * SQRT( C1 * (A1 - B1 + C1) ) + & ! + TWO * C1 - B1 ! + NUM3 = TWO * SQRT( A1 * (A1*G12 + B1*G1 + C1) ) + & ! + TWO * A1 * G1 + B1 ! + DEN3 = TWO * SQRT( A1 * (A1 + B1 + C1) ) + & ! + TWO * A1 + B1 ! + NUM4 = TWO * SQRT( A1 * (A1*G12 - B1*G1 + C1) ) + & ! + TWO * A1 * G1 - B1 ! + DEN4 = TWO * SQRT( A1 * (A1 - B1 + C1) ) + & ! + TWO * A1 - B1 ! +! +! Pathological cases +! + IF(NUM1 == ZERO) NUM1 = TTINY ! + IF(DEN1 == ZERO) DEN1 = TWO * TTINY ! + IF(NUM2 == ZERO) NUM2 = TTINY ! + IF(DEN2 == ZERO) DEN2 = TWO * TTINY ! + IF(NUM3 == ZERO) NUM3 = TTINY ! + IF(DEN3 == ZERO) DEN3 = TWO * TTINY ! + IF(NUM4 == ZERO) NUM4 = TTINY ! + IF(DEN4 == ZERO) DEN4 = TWO * TTINY ! + R1(IX2) = CC1 * ( LOG(ABS(NUM1 / DEN1)) + & ! + LOG(ABS(NUM2 / DEN2)) - & ! + TWO * LOG(DABS(G1)) & ! + ) + & ! ref. (1) eq. (4.34a) + CC2 * ( LOG(ABS(NUM3 / DEN3)) - & ! + LOG(ABS(NUM4 / DEN4)) & ! + ) ! +! + ELSE ! case q1 /= q2, x2 = 1 +! + CC1 = Q1 * Q2 / SQRT(C1) ! + CC2 = Q12 / SQRT(A1) ! +! + NUM1 = B1 * G1 + TWO * C1 ! + DEN1 = B1 + TWO * C1 ! + NUM2 = B1 * G1 - TWO * C1 ! + DEN2 = B1 - TWO * C1 ! + NUM3 = TWO * A1 * G1 + B1 ! + DEN3 = TWO * A1 + B1 ! + NUM4 = TWO * A1 * G1 - B1 ! + DEN4 = TWO * A1 - B1 ! +! +! Pathological cases +! + IF(NUM1 == ZERO) NUM1 = TTINY ! + IF(DEN1 == ZERO) DEN1 = TWO * TTINY ! + IF(NUM2 == ZERO) NUM2 = TTINY ! + IF(DEN2 == ZERO) DEN2 = TWO * TTINY ! + IF(NUM3 == ZERO) NUM3 = TTINY ! + IF(DEN3 == ZERO) DEN3 = TWO * TTINY ! + IF(NUM4 == ZERO) NUM4 = TTINY ! + IF(DEN4 == ZERO) DEN4 = TWO * TTINY ! +! + R1(IX2) = CC1 * ( LOG(ABS(NUM1 / DEN1)) + & ! + LOG(ABS(NUM2 / DEN2)) - & ! + TWO * LOG(ABS(G1)) & ! + ) - & ! ref. (1) eq. (4.34b) + CC2 * ( LOG(ABS(NUM3 / DEN3)) + & ! + LOG(ABS(NUM4 / DEN4)) & ! + ) ! +! + END IF ! +! + ELSE ! case q1 = q2 +! + IF(ABS(X2 - ONE) > SMALL_X) THEN ! case x2 /= 1 +! + R1(IX2) = LOG(ABS(X2/G1)) / (X2 * X2) ! ref. (1) eq. (4.34c) +! + ELSE ! case x2 = 1 +! + R1(IX2) = -LOG(ABS(G1)) ! ref. (1) eq. (4.34d) +! + END IF ! +! + END IF ! +! + END DO ! end of loop on X2 +! +! Performing the integration over X2 +! + A = G2 ! integration + B = ONE ! bounds + ID = 1 ! +! + CALL INTEGR_L(R1,X_STEP,NZ_MAX,NX_STEP,I,ID) ! +! + R2(IQ1) = I ! new function +! ! to integrate + END DO ! end of loop on Q1 +! ! +! Performing the integration over Q1 +! + A = Q_INI ! integration + B = Q_INI + ONE ! bounds + ID = 1 ! +! + CALL INTEGR_L(R2,Q_STEP,NZ_MAX,NK_STEP,I,ID) ! +! ! + R3(IQ2) = I ! new function +! ! to integrate + GO TO 20 ! +! + 10 R3(IQ2) = ZERO ! +! + 20 CONTINUE ! +! + + END DO ! end of loop on Q2 +! +! Performing the integration over Q2 +! + A = Q_INI ! integration + B = Q_INI + ONE ! bounds + ID = 1 ! +! + CALL INTEGR_L(R3,Q_STEP,NZ_MAX,NK_STEP,I,ID) ! +! +! Computing the F(k) function +! + IF(K < SMALL) THEN ! k = 0 + F = TWO ! + ELSEIF(ABS(K - TWO) < SMALL) THEN ! k = 2 + F = ONE ! + ELSE ! + F = ONE + (ONE - FOURTH * K2) * & ! ref. (1) eq. (4.23) + LOG(ABS((K + TWO) / (K - TWO))) / K ! + END IF ! +! + TRMA_LFC = I / (F * F) ! ref. (1) eq. (4.25) +! + END FUNCTION TRMA_LFC +! +!======================================================================= +! + FUNCTION TKAC_LFC(X,RS,T) +! +! This function computes the temperature-dependent Tkachenko +! local-field correction +! +! References: (1) I. M. Tkachenko, Europhys. Lett. 9, 351-354 (1989) +! +! +! Note: Valid in the domain 0 <= Gamma <= 1 +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THREE,FOUR,NINE,HALF,THIRD,FOURTH + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PLASMON_ENE_SI + USE PLASMON_SCALE_P, ONLY : DEGEN +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: TKAC_LFC + REAL (WP) :: Y + REAL (WP) :: GAMMA,Q_SI + REAL (WP) :: C1,C2,C3,C4 + REAL (WP) :: EQ,KBT + REAL (WP) :: A12,G14,AAA,R +! + Y = X + X ! Y = q / k_F +! + Q_SI = Y * KF_SI ! q in SI +! ! plasma + EQ = HALF * H_BAR * H_BAR * Q_SI * Q_SI / M_E ! E_q + KBT = K_B * T ! +! ! plasma + GAMMA = DEGEN ! non ideality +! ! parameter +! +! Tkachenko coefficients +! ! plasma + C1 = - 0.89752E0_WP ! + C2 = 0.94544E0_WP ! + C3 = 0.17954E0_WP ! + C4 = - 0.80049E0_WP ! +! ! + A12 = HALF * ENE_P_SI * ENE_P_SI / (EQ * KBT) ! + G14 = GAMMA**FOURTH ! + AAA = 13.0E0_WP * C2 * G14 + 11.0E0_WP * C3 / G14 ! +! ! + R = HALF / ( - FOUR * C1 * GAMMA / NINE - AAA / 36.0E0_WP - & ! + THIRD * (C4 + THREE) & ! + ) ! +! + TKAC_LFC = HALF * (ONE + R * A12) ! eq. (10) +! + END FUNCTION TKAC_LFC +! +!======================================================================= +! + FUNCTION VASI_LFC(X,RS) +! +! This function computes the Vashishta-Singwi +! local-field correction +! +! References: (1) P. Vashishta and K. S. Singwi, Phys. Rev. B 6, 875-887 (1972) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,SMALL + USE INTERPOLATION, ONLY : INTERP_NR,SPLINE,SPLINT +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS + REAL (WP) :: VASI_LFC + REAL (WP) :: Y,Y2 + REAL (WP) :: A,B +! + REAL (WP) :: XVS(6),AVS(6),BVS(6) +! + REAL (WP) :: ABS,EXP +! + INTEGER :: INTERP +! + INTEGER :: INT +! + DATA AVS /0.70853E0_WP, 0.85509E0_WP, 0.97805E0_WP, & ! Vashishta-Singwi + 1.08482E0_WP, 1.17987E0_WP, 1.26569E0_WP/ ! coefficients A and B + DATA BVS /0.36940E0_WP, 0.33117E0_WP, 0.30440E0_WP, & ! (see table V) + 0.28430E0_WP, 0.26850E0_WP, 0.25561E0_WP/ ! + DATA XVS /1.00000E0_WP, 2.00000E0_WP, 3.00000E0_WP, & ! + 4.00000E0_WP, 5.00000E0_WP, 6.00000E0_WP/ ! +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! +! Checking if interpolation of AVS and BVS is necessary for 'VASI' +! + INTERP = 0 ! + IF(ABS(RS - INT(RS)) < SMALL) INTERP = 1 ! +! + IF(INTERP == 0) THEN ! + A = AVS(INT(RS + SMALL)) ! + B = BVS(INT(RS + SMALL)) ! + ELSE ! + CALL INTERP_NR(6,XVS,AVS,6,RS,A) ! + CALL INTERP_NR(6,XVS,BVS,6,RS,B) ! + END IF ! +! + VASI_LFC = A * (ONE - EXP(- B * Y2)) ! +! + END FUNCTION VASI_LFC +! +!------ 1) 2D case -------------------------------------------- +! +!======================================================================= +! + SUBROUTINE LOCAL_FIELD_STATIC_2D(X,RS,GQ_TYPE,GQ) +! +! This subroutine computes static local-field factors G(q) +! for 2D systems. +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * GQ_TYPE : local-field correction type +! GQ_TYPE = 'NONE' no local field correction +! GQ_TYPE = 'HUBB' Hubbard correction (only exchange) +! GQ_TYPE = 'GOCA' Gold-Calmels +! GQ_TYPE = 'IWA1' Iwamoto G_{-1} +! GQ_TYPE = 'IWA2' Iwamoto G_{3} +! GQ_TYPE = 'DPGT' Davoudi-Giuliani-Giuliani-Tosi +! GQ_TYPE = 'BUTO' Bulutay-Tomak +! GQ_TYPE = 'SAIC' Sato-Ichimaru correction +! +! Output parameters: +! +! * GQ : value of local field correction +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE +! + REAL (WP) :: X,RS + REAL (WP) :: GQ +! + IF(GQ_TYPE == 'NONE') THEN ! + GQ=ZERO ! + ELSE IF(GQ_TYPE == 'HUBB') THEN ! + GQ=HUB2_LFC(X) ! + ELSE IF(GQ_TYPE == 'GOCA') THEN ! + GQ=GOC2_LFC(X,RS) ! + ELSE IF(GQ_TYPE == 'IWA1') THEN ! + GQ=IW21_LFC(X,RS) ! + ELSE IF(GQ_TYPE == 'IWA2') THEN ! + GQ=IW22_LFC(X,RS) ! + ELSE IF(GQ_TYPE == 'DPGT') THEN ! + GQ=DPGT_LFC(X,RS) ! + ELSE IF(GQ_TYPE == 'BUTO') THEN ! + GQ=BUTO_LFC(X,RS) ! + ELSE IF(GQ_TYPE == 'SAIC') THEN ! + GQ=SAIC_LFC(X) ! + END IF ! +! + END SUBROUTINE LOCAL_FIELD_STATIC_2D +! +!======================================================================= +! + FUNCTION BUTO_LFC(X,RS) +! +! This function computes the Bulutay-Tomak +! local-field correction for 2D systems +! +! References: (1) C. Bulutay and M. Tomak, Phys. Rev. B 53, 7317-7321 (1996) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,SMALL + USE INTERPOLATION, ONLY : INTERP_NR,SPLINE,SPLINT +! + IMPLICIT NONE +! + REAL (WP) :: X,RS,Y,BUTO_LFC + REAL (WP) :: A,B +! + REAL (WP) :: XBT(0:6),ABT(0:6),BBT(0:6) +! + REAL (WP) :: DABS,DEXP +! + INTEGER :: INTERP +! + INTEGER :: INT +! + DATA ABT /0.4999E0_WP,0.8128E0_WP,0.9214E0_WP,0.9752E0_WP,&! 0 value: result of 6th degree fit + 1.0004E0_WP,1.0165E0_WP,1.0296E0_WP/ ! on values of ref. (5) table II + DATA BBT /0.6195E0_WP,0.7322E0_WP,0.8075E0_WP,0.8585E0_WP,&! 0 value: result of 6th degree fit + 0.9121E0_WP,0.9444E0_WP,0.9583E0_WP/ ! on values of ref. (5) table II + DATA XBT /0.0000E0_WP,1.0000E0_WP,2.0000E0_WP,3.0000E0_WP,&! + 4.0000E0_WP,5.0000E0_WP,6.0000E0_WP/ ! +! + Y=X+X ! Y = q / k_F +! +! Checking if interpolation of ABT and BBT is necessary +! + INTERP=0 ! + IF(DABS(RS-INT(RS)).LT.SMALL) INTERP=1 ! +! + IF(INTERP == 0) THEN ! + A=ABT(INT(RS+SMALL)) ! + B=BBT(INT(RS+SMALL)) ! + ELSE + CALL INTERP_NR(7,XBT,ABT,7,RS,A) ! + CALL INTERP_NR(7,XBT,BBT,7,RS,B) ! + END IF ! +! + BUTO_LFC=A*(ONE-DEXP(-B*Y/A)) ! +! + END FUNCTION BUTO_LFC +! +!======================================================================= +! + FUNCTION DPGT_LFC(X,RS) +! +! This function computes the Davoudi-Polini-Giuliani-Tosi +! local-field correction for 2D systems +! +! References: (1) B. Davoudi, M. Polini, G. F. Giuliani and M. P. Tosi, +! Phys.Rev. B 64, 153101 (2001) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,TEN,HALF,FOURTH + USE SQUARE_ROOTS, ONLY : SQR2 + USE PI_ETC, ONLY : PI,PI_INV +! + IMPLICIT NONE +! + REAL (WP) :: X,RS,Y,Y2,Y4,Y6,Y8,DPGT_LFC + REAL (WP) :: R10,E + REAL (WP) :: G0,G2,G4,G6,G8 + REAL (WP) :: NUM,DEN,ALPH + REAL (WP) :: A,B,C,P +! + REAL (WP) :: DLOG,DSQRT,DEXP +! + Y=X+X ! Y = q / k_F + Y2=Y*Y ! + Y4=Y2*Y2 ! + Y6=Y4*Y2 ! + Y8=Y6*Y2 ! +! + R10=RS/TEN ! + E=DEXP(R10) ! +! + G0=HALF / (ONE + 1.372E0_WP*RS + 0.0830E0_WP*RS*RS) ! ref. (1) eq. (9) +! + G2= 0.5824E0_WP*R10*R10 - 0.4272E0_WP*R10 ! + G4= 0.2960E0_WP*R10-1.003E0_WP*(R10**2.5E0_WP)+ & ! + 0.9466E0_WP*R10*R10*R10 ! + G6=-0.0585E0_WP*R10*R10 ! ref. (1) eq. (11) + G8= 0.0131E0_WP*R10*R10 ! + NUM=0.1598E0_WP + 0.8931E0_WP*(R10**0.9218E0_WP) ! + DEN=ONE + 0.8793E0_WP*(R10**0.9218E0_WP) ! + ALPH=NUM/DEN ! +! +! For A, we use the value of (1 - K0/K) from eq. (3.8b) of ref. (1) +! and for C the value of Ec in eq. (3.7b) of ref. (1) +! + A=(ONE/(RS*SQR2) * PI_INV*( ONE - & ! ref. (1) eq. (5) + (TEN-THREE*PI)*RS*RS*DLOG(RS)/12.0E0_WP)) ! + B= ONE-G0 ! + C=0.17E0_WP*RS/SQR2 + PI_INV*RS*RS*(TEN/THREE -PI) * & ! ref. (1) eq. (8) + (TWO*DLOG(RS)+ONE) ! + P= G2*Y2 + G4*Y4 + G6*Y6 + G8*Y8 ! +! + DPGT_LFC=A*Y*( E/DSQRT(ONE+(A*E*Y/B)**2) + & ! + (ONE-E)*DEXP(-FOURTH*Y2) & ! + ) + C*Y*(ONE-DEXP(-Y2)) + P*DEXP(-ALPH*Y2) ! +! + END FUNCTION DPGT_LFC +! +!======================================================================= +! + FUNCTION GOC2_LFC(X,RS) +! +! This function computes the Gold-Calmels +! local-field correction for 2D systems +! +! References: (1) A. Gold and L. Calmels, Phys. Rev. B 48, +! 11622-11637 (1993) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TEN,THIRD + USE SQUARE_ROOTS, ONLY : SQR2 + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL (WP) :: X,RS,Y,GOC2_LFC + REAL (WP) :: NUM,DEN,KFOQ0,QQ0 +! + REAL (WP) :: A1GC(3),B1GC(3),A2GC(3),B2GC(3),C12,C22 +! + REAL (WP) :: DSQRT +! + INTEGER :: IND +! + DATA A1GC /1.135E0_WP,1.120E0_WP,1.127E0_WP/ ! Gold-Calmels coefficients + DATA B1GC /0.248E0_WP,0.216E0_WP,0.215E0_WP/ ! for C12 and C22 + DATA A2GC /1.687E0_WP,1.640E0_WP,1.314E0_WP/ ! eq. (26)-(27) + DATA B2GC /0.494E0_WP,0.530E0_WP,0.667E0_WP/ ! ref. (1) +! + Y=X+X ! Y = q / k_F +! + IF(RS < ONE) THEN ! + IND=1 ! + ELSE ! + IF(RS < TEN) THEN ! + IND=2 ! + ELSE ! + IF(RS < 100.0E0_WP) THEN ! + IND=3 ! + END IF ! + END IF ! + END IF ! +! + C12=A1GC(IND)*(RS**B1GC(IND)) ! +! + IF(RS < ONE) THEN ! + IND=1 ! + ELSE ! + IF(RS < TEN) THEN ! + IND=2 ! + ELSE ! + IF(RS < 1000.0E0_WP) THEN ! + IND=3 ! + END IF ! + END IF ! + END IF ! +! + C22=A2GC(IND)*(RS**B2GC(IND)) ! +! + KFOQ0=ONE / (SQR2* RS**THIRD) ! k_F / q_0 + QQ0=Y*KFOQ0 ! +! + NUM=RS**(THIRD+THIRD) * 1.402E0_WP* QQ0 ! + DEN=DSQRT(2.644E0_WP*C12*C12 + QQ0*QQ0*C22) ! +! + GOC2_LFC=NUM/DEN ! +! + END FUNCTION GOC2_LFC +! +!======================================================================= +! + FUNCTION HUB2_LFC(X) +! +! This function computes the Hubbard exchange-only +! local-field correction +! +! References: (1) A. Gold and L. Calmels, Phys. Rev. B 52, 10841-10857 (1995) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,HALF +! + IMPLICIT NONE +! + REAL (WP) :: X,Y,HUB2_LFC +! + REAL (WP) :: DSQRT +! + Y=X+X ! Y = q / k_F +! + HUB2_LFC=HALF*Y/DSQRT(ONE+Y*Y) ! +! + END FUNCTION HUB2_LFC +! +!======================================================================= +! + FUNCTION IW21_LFC(X,RS) +! +! This function computes the Iwamoto G_{-1} +! local-field correction for 2D systems +! +! References: (1) N. Iwamoto, Phys. Rev. A 30, 3289-3304 (1984) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THREE,TEN + USE PI_ETC, ONLY : PI,PI_INV +! + IMPLICIT NONE +! + REAL (WP) :: X,RS,Y,IW21_LFC +! + REAL (WP) :: DLOG +! + Y=X+X ! Y = q / k_F +! + IW21_LFC=PI_INV*(ONE-(TEN-THREE*PI)*RS*RS* & ! + DLOG(RS)/12.0E0_WP)*Y ! +! + END FUNCTION IW21_LFC +! +!======================================================================= +! + FUNCTION IW22_LFC(X,RS) +! +! This function computes the Iwamoto G_{3} +! local-field correction for 2D systems +! +! References: (1) N. Iwamoto, Phys. Rev. A 30, 3289-3304 (1984) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : THREE,FIVE,SIX,TEN + USE PI_ETC, ONLY : PI,PI_INV +! + IMPLICIT NONE +! + REAL (WP) :: X,RS,Y,IW22_LFC +! + REAL (WP) :: DLOG +! + Y=X+X ! Y = q / k_F +! + IW22_LFC=( FIVE*PI_INV/SIX - 0.240E0_WP*RS - & ! + 33.0E0_WP*PI_INV*(TEN-THREE*PI)*RS*RS* & ! + DLOG(RS)/24.0E0_WP & ! + )*Y ! +! + END FUNCTION IW22_LFC +! +!======================================================================= +! + FUNCTION SAIC_LFC(X) +! +! This function computes the Sato-Ichimaru +! local-field correction for 2D systems +! +! References: (1) H. K. Schweng and H. M. Böhm, Int. J. Quantum. Chem. 56, +! 791-799 (1995) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 25 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THREE,FOUR,HALF + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: SAIC_LFC + REAL (WP) :: Y,Y2,Y4,Y6 +! + REAL (WP), PARAMETER :: AA = 0.009E0_WP ! A + REAL (WP), PARAMETER :: BB = 0.00038E0_WP ! B + REAL (WP), PARAMETER :: CC = 0.965E0_WP ! C + REAL (WP), PARAMETER :: DD = 0.078E0_WP ! D + REAL (WP), PARAMETER :: A = 0.0475E0_WP ! a + REAL (WP), PARAMETER :: B = 1.66E0_WP ! b + REAL (WP), PARAMETER :: C = 0.09E0_WP ! c + REAL (WP), PARAMETER :: D = THREE ! d +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! + Y4 = Y2 * Y2 ! + Y6 = Y4 * Y2 ! +! + IF(X <= ONE) THEN ! + SAIC_LFC = (Y * PI_INV + AA * Y4 + BB * Y6) * ( CC + & ! + (ONE - CC) * TANH((FOUR - Y2) / DD) & ! + ) ! ref. (1) eq. (8b) + ELSE ! + SAIC_LFC = HALF + A / (Y - B) + C / (Y2 - D) ! + END IF ! +! + END FUNCTION SAIC_LFC +! +!------ 1) 1D case -------------------------------------------- +! +!======================================================================= +! + SUBROUTINE LOCAL_FIELD_STATIC_1D(X,RS,GQ_TYPE,GQ) +! +! This subroutine computes static local-field factors G(q) +! for 1D systems. +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * GQ_TYPE : local-field correction type +! GQ_TYPE = 'NONE' no local field correction +! GQ_TYPE = 'HUBB' Hubbard correction (only exchange) +! GQ_TYPE = 'GOCA' Gold-Calmels +! +! Output parameters: +! +! * GQ : value of local field correction +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + CHARACTER*4 GQ_TYPE +! + REAL*8 X,RS + REAL*8 GQ +! + IF(GQ_TYPE == 'NONE') THEN ! + GQ=ZERO ! + ELSE IF(GQ_TYPE == 'HUB1') THEN ! + GQ=HUBB_LFC(X) ! + ELSE IF(GQ_TYPE == 'GOCA') THEN ! + GQ=GOC1_LFC(X,RS) ! + END IF ! +! + END SUBROUTINE LOCAL_FIELD_STATIC_1D +! +! +!======================================================================= +! + FUNCTION HUB1_LFC(X) +! +! This function computes the Hubbard exchange-only +! local-field correction for 1D systems +! +! References: (1) A. Gold and L. Calmels, Phys. Rev. B 52, 10841-10857 (1995) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,HALF + USE FERMI_SI, ONLY : KF_SI + USE CONFINEMENT_FF +! + IMPLICIT NONE +! + REAL (WP) :: X,Y,HUB1_LFC + REAL (WP) :: Q_SI,Q,XX + REAL (WP) :: VC1,VC2 +! + REAL (WP) :: DSQRT +! + Y=X+X ! Y = q / k_F + Q_SI=Y*KF_SI ! q in SI +! + Q=DSQRT(Q_SI*Q_SI + KF_SI*KF_SI) ! + XX=HALF*Q/KF_SI ! +! + VC1=CONFIN_FF(XX) ! + VC2=CONFIN_FF(X) ! +! + HUB1_LFC=HALF*VC1/VC2 ! ref. (1) eq. (4) +! + END FUNCTION HUB1_LFC +! +!======================================================================= +! + FUNCTION GOC1_LFC(X,RS) +! +! This function computes the Gold-Calmels +! local-field correction for 1D systems +! +! References: (1) A. Gold and L. Calmels, Phys. Rev. B 52, +! 10841-10857 (1995) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : FOUR,HALF + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI_INV + USE CONFINEMENT_FF +! + IMPLICIT NONE +! + REAL (WP) :: X,RS,Y,GOC1_LFC + REAL (WP) :: Q_SI,KS,COEF,Q,XX + REAL (WP) :: VC1,VC2 + REAL (WP) :: C11,C21 +! + REAL (WP) :: DSQRT +! + Y=X+X ! Y = q / k_F + Q_SI=Y*KF_SI ! q + + CALL CG_PARAMETRIZATION_1D(RS,C11,C21) ! +! + COEF=RS*PI_INV/C21 +! + Q=DSQRT(Q_SI*Q_SI + FOUR/(RS*C11*C11)) ! unit of q0^2/C11^2 ? + XX=HALF*Q/KF_SI ! +! + VC1=CONFIN_FF(XX) ! + VC2=CONFIN_FF(X) ! +! + GOC1_LFC=COEF*VC1/VC2 ! +! + END FUNCTION GOC1_LFC +! +!======================================================================= +! + SUBROUTINE CG_PARAMETRIZATION_1D(RS,C11,C21) +! +! This subroutine computes the Calmels-Gold parametrization for the +! calculation of the static 1D local-field correction G(q) +! +! References: (1) L. Calmels and A. Gold, Phys. Rev. B 52, 10841-10857 (1995) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Internal parameters: +! +! * parameters C11 and C21 +! +! +! Output parameters: +! +! * RS : electron-electron distance in a.u. +! * R0 : 1D confinement parameter (= wire radius) in a.u. +! +! Table I, II and II of ref. (1) are used and the parameters +! are fitted with: +! +! 1) C11(rs) for different values of a* with a 10th-order polynomial +! 2) C21(rs) for different values of a* with a 6th-order polynomial +! +! Then, the coefficients of the polynomials as a function of R0=f(a*) are fitted +! +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! + USE CONFIN_VAL, ONLY : R0 +! + IMPLICIT NONE +! + REAL (WP) :: RS +! ! coefficients of the + REAL (WP) :: A11(0:10),A21(0:6) ! polynomials fitted to +! ! 5 values of R0 + REAL (WP) :: C11,C21 + REAL (WP) :: RS2,RS3,RS4,RS5,RS6,RS7,RS8,RS9,RS10 + REAL (WP) :: R02,R03,R04 +! + RS2=RS*RS ! + RS3=RS2*RS ! + RS4=RS3*RS ! + RS5=RS4*RS ! + RS6=RS5*RS ! + RS7=RS6*RS ! + RS8=RS7*RS ! + RS9=RS8*RS ! + RS10=RS9*RS ! +! + R02=R0*R0 ! + R03=R02*R0 ! + R04=R03*R0 ! +! + A11(0)=0.21684E0_WP + 0.09359E0_WP*R0 - 0.0087353E0_WP*R02 &! + - 0.0061566E0_WP*R03 +0.00090189E0_WP*R04 ! + A11(1)=6.159E0_WP + 0.34573E0_WP*R0 + 0.8188E0_WP*R02 &! + - 0.29423E0_WP*R03 + 0.027191E0_WP*R04 ! + A11(2)=-25.041E0_WP + 13.261E0_WP*R0 - 14.975E0_WP*R02 &! + + 4.5402E0_WP*R03 - 0.40242E0_WP*R04 ! + A11(3)= 51.186E0_WP - 42.4867E0_WP*R0 + 45.346E0_WP*R02 &! + - 13.703E0_WP*R03 + 1.2149E0_WP*R04 ! + A11(4)=-56.749E0_WP + 56.697E0_WP*R0 - 60.08E0_WP*R02 &! + + 18.259E0_WP*R03 - 1.6235E0_WP*R04 ! + A11(5)= 36.271E0_WP - 39.508E0_WP*R0 + 42.195E0_WP*R02 &! + - 12.888E0_WP*R03 + 1.1487E0_WP*R04 ! + A11(6)= 13.765E0_WP - 15.728E0_WP*R0 + 16.911E0_WP*R02 &! + - 5.1841E0_WP*R03 + 0.46284E0_WP*R04 ! + A11(7)= 3.1137E0_WP - 3.6605E0_WP*R0 + 3.9552E0_WP*R02 &! + - 1.2155E0_WP*R03 + 0.10865E0_WP*R04 ! + A11(8)=-0.40794E0_WP + 0.48829E0_WP*R0 - 0.52945E0_WP*R02 &! + + 0.16299E0_WP*R03 - 0.01458E0_WP*R04 ! + A11(9)=0.028331E0_WP - 0.034316E0_WP*R0 + 0.037301E0_WP*R02 &! + - 0.011497E0_WP*R03 + 0.001029E0_WP*R04 ! + A11(10)=-0.00080196E0_WP+0.0009793E0_WP*R0 - 0.0010663E0_WP*R02 &! + + 0.00032895E0_WP*R03 - 2.9453E-05_WP*R04 ! +! + A21(0)=0.091552E0_WP - 0.17832E0_WP*R0 + 0.11774E0_WP*R02 &! + - 0.030277E0_WP*R03 + 0.0024971E0_WP*R04 ! + A21(1)=4.0647E0_WP - 6.1695E0_WP*R0 + 3.9346E0_WP*R02 &! + - 1.0082E0_WP*R03 + 0.083221E0_WP*R04 ! + A21(2)=-1.4144E0_WP + 1.7798E0_WP*R0 - 1.0403E0_WP*R02 &! + + 0.25756E0_WP*R03 - 0.020951E0_WP*R04 ! + A21(3)=0.55871E0_WP - 0.73394E0_WP*R0 + 0.42973E0_WP*R02 &! + - 0.1062E0_WP*R03 + 0.0086274E0_WP*R04 ! + A21(4)=-0.10394E0_WP + 0.14008E0_WP*R0 - 0.082217E0_WP*R02 &! + + 0.020308E0_WP*R03 - 0.0016487E0_WP*R04 ! + A21(5)=0.0091324E0_WP- 0.012508E0_WP*R0 + 0.0073577E0_WP*R02 &! + - 0.0018173E0_WP*R03 + 0.0001475E0_WP*R04 ! + A21(6)=-0.00030448E0_WP+0.0004215E0_WP*R0 - 0.00024838E0_WP*R02 &! + + 6.1355E-05_WP*R03 - 4.9795E-06_WP*R04 ! +! + C11=A11(0) + A11(1)*RS + A11(2)*RS2 + A11(2)*RS2 + A11(3)*RS3 +&! + A11(4)*RS4 + A11(5)*RS5 + A11(6)*RS6 + A11(7)*RS7 +&! + A11(8)*RS8 + A11(9)*RS9 + A11(10)*RS10 ! +! + C21=A21(0) + A21(1)*RS + A21(2)*RS2 + A21(2)*RS2 + A21(3)*RS3 +&! + A21(4)*RS4 + A21(5)*RS5 + A21(6)*RS6 ! +! + END SUBROUTINE CG_PARAMETRIZATION_1D +! +END MODULE LOCAL_FIELD_STATIC diff --git a/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/local_field_static_2.f90 b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/local_field_static_2.f90 new file mode 100644 index 0000000..f7eb1c3 --- /dev/null +++ b/New_libraries/DFM_library/LOCAL_FIELD_LIBRARY/local_field_static_2.f90 @@ -0,0 +1,220 @@ +! +!======================================================================= +! +MODULE LOCAL_FIELD_STATIC_2 +! +! This modules provides subroutines/functions to compute +! static local-field factors G(q) +! +! These G(q) DEPEND of the static structure factor S(q) +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE LFIELD_STATIC_2(X,RS,T,GQ_TYPE,GQ) +! +! This subroutine computes static local-field factors G(q) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * GQ_TYPE : local-field correction type (3D) +! +! +! Output parameters: +! +! * GQ : static local field correction +! +! +! Author : D. Sébilleau +! +! Last modified : 19 Jun 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE +! + REAL (WP) :: X,RS,T + REAL (WP) :: GQ +! + IF(DMN == '3D') THEN ! + CALL LOCAL_FIELD_STATIC_3D_2(X,RS,T,GQ_TYPE,GQ) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! not implemented + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! not implemented + END IF ! +! + END SUBROUTINE LFIELD_STATIC_2 +! +!------ 1) 3D case -------------------------------------------- +! +!======================================================================= +! + SUBROUTINE LOCAL_FIELD_STATIC_3D_2(X,RS,T,GQ_TYPE,GQ) +! +! This subroutine computes static local-field factors G(q) +! depending on the structure factor S(q) for 3D systems. +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * GQ_TYPE : local-field correction type (3D) +! GQ_TYPE = 'IKPA' Iwamoto-Krotscheck-Pines +! temperature-dep. --> GQ_TYPE = 'HNCA' hypernetted chain +! +! +! Output parameters: +! +! * GQ : static local field correction +! +! +! Author : D. Sébilleau +! +! Last modified : 2 Dec 2020 +! +! + USE SF_VALUES, ONLY : SQ_TYPE +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE +! + REAL (WP) :: X,RS,T + REAL (WP) :: GQ +! + IF(GQ_TYPE == 'IKPA') THEN ! + GQ=IKPA_LFC(X,RS,T,SQ_TYPE) ! + ELSE IF(GQ_TYPE == 'HNCA') THEN ! + GQ=HNCA_LFC(X,RS,T,SQ_TYPE) ! + END IF ! +! + END SUBROUTINE LOCAL_FIELD_STATIC_3D_2 +! +!======================================================================= +! + FUNCTION HNCA_LFC(X,RS,T,SQ_TYPE) +! +! This function computes the hypernetted chain +! local-field correction +! +! References: (1) A. Isihara, "Electron Liquids", 2nd edition, +! Springer Series in Solid-STate Sciences 96, +! (Springer, 1998) p. 33 +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * SQ_TYPE : structure factor approximation (3D) +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Sep 2020 +! +! +! + USE REAL_NUMBERS, ONLY : ONE + USE FERMI_SI, ONLY : KF_SI + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE STRUCTURE_FACTOR_STATIC +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: SQ_TYPE +! +! + REAL (WP) :: X,RS,T,Y + REAL (WP) :: HNCA_LFC + REAL (WP) :: Q_SI,Q_D,R + REAL (WP) :: SQ +! + Y = X + X ! Y = q / k_F + Q_SI = Y * KF_SI ! q in SI +! +! Computing the Debye vector +! + CALL DEBYE_VECTOR('3D',T,RS,Q_D) ! q_D in SI +! + R = Q_SI / Q_D ! +! +! Computing the structure factor +! + CALL STFACT_STATIC(X,RS,T,SQ_TYPE,SQ) ! +! + HNCA_LFC = ONE + (ONE - ONE / SQ) * R * R ! ref. (1) eq. (2.2.33) +! + END FUNCTION HNCA_LFC +! +!======================================================================= +! + FUNCTION IKPA_LFC(X,RS,T,SQ_TYPE) +! +! This function computes the Iwamoto-Krotscheck-Pines +! local-field correction +! +! References: (1) N. Iwamoto, E. Krotscheck and D. Pines, +! Phys. Rev. B 29, 3936-3951 (1984) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * SQ_TYPE : structure factor approximation (3D) +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THREE,FOUR + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : ALFA + USE STRUCTURE_FACTOR_STATIC +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: SQ_TYPE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: IKPA_LFC + REAL (WP) :: Y,Y4,COEF + REAL (WP) :: SF,SQ + REAL (WP) :: SQ2,SF2 + REAL (WP) :: ALPHA +! + Y = X + X ! Y = q / k_F + Y4 = Y * Y * Y * Y ! Y^4 +! + ALPHA = ALFA('3D') ! + COEF = THREE * PI / (FOUR * FOUR * ALPHA * RS) ! +! + SF = HFA_SF(X) ! + CALL STFACT_STATIC(X,RS,T,SQ_TYPE,SQ) ! +! + SQ2 = SQ * SQ ! + SF2 = SF * SF ! +! + IKPA_LFC = ONE - COEF * ( ONE / SQ2 - ONE / SF2 ) * Y4 ! +! + END FUNCTION IKPA_LFC +! +END MODULE LOCAL_FIELD_STATIC_2 diff --git a/New_libraries/DFM_library/MEMORY_FUNCTIONS_LIBRARY/memory2_functions.f90 b/New_libraries/DFM_library/MEMORY_FUNCTIONS_LIBRARY/memory2_functions.f90 new file mode 100644 index 0000000..f8b5483 --- /dev/null +++ b/New_libraries/DFM_library/MEMORY_FUNCTIONS_LIBRARY/memory2_functions.f90 @@ -0,0 +1,162 @@ +! +!======================================================================= +! +MODULE MEMORY2_FUNCTIONS_F +! +! This modules provides memory functions in terms of the frequency +! and of the transfer momentum +! +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! +! +!======================================================================= +! + FUNCTION MEMORY2_F(X,Z,T,TAU,MEM_TYPE) +! +! This function computes the memory function K(q,omega) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * T : temperature in SI +! * TAU : relaxation time in SI +! * MEM_TYPE : type of memory function used +! MEM_TYPE = 'RAYI' --> Raganathan-Yip function +! MEM_TYPE = 'LIHY' --> linearized hydrodynamic function +! +! +! Remark: The memory function has the dimension of a frequency omega +! +! +! Author : D. Sébilleau +! +! Last modified : 29 Jan 2021 +! +! + USE CALCTYPE +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE CONSTANTS_P1, ONLY : M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: MEM_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,T,TAU +! + REAL (WP) :: U,V0,U0,U1 + REAL (WP) :: Q_SI + REAL (WP) :: OMG +! + REAL (WP) :: SQRT +! + COMPLEX (WP) :: MEMORY_F +! +! Computing the average velocity +! + IF(CAL_TYPE == 'QUANTUM') THEN ! + V0 = VF_SI ! + ELSE ! + V0 = SQRT(TWO * K_B * T / M_E) ! + END IF ! +! + Q_SI = Y * KF_SI ! q in SI + U = X * Z ! U = omega / (q v_F) + OMG = Q_SI * VF_SI * U ! omega in SI +! + U0 = U * VF_SI / V_0 ! omega / q v_0 + U1 = ONE / (TAU * Q_SI * V0) ! +! + IF(MEM_TYPE == 'NONE') THEN ! + MEMORY2_F = RAYI(OMG,U0) ! + ELSE IF(MEM_TYPE == 'DELT') THEN ! + MEMORY2_F = LINY(OMG,TAU,U1) ! + END IF ! +! + END FUNCTION MEMORY2_F +! +!======================================================================= +! + FUNCTION RAYI(OMG,U0) +! +! This function computes the frequency Ranganathan-Yip memory function +! +! +! Input parameters: +! +! * OMG : frequency in SI +! * U0 : dimensionless parameter omega / q v_0 +! +! +! Author : D. Sébilleau +! +! Last modified : 29 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR + USE COMPLEX_NUMBERS, ONLY : IC + USE PI_ETC, ONLY : PI_INV,SQR_PI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: OMG,U0 +! + REAL (WP) :: REM,IMM +! + COMPLEX (WP) :: RAYI +! + REM = ONE / SQR_PI - (FOUR * PI_INC - ONE) * U0 * U0 ! + IMM = (ONE - TWO * PI_INV) * U0 ! +! + RAYI = OMG * (REM + IC * IMM) / U0 ! +! + END FUNCTION RAYI +! +!======================================================================= +! + FUNCTION LIHY(OMG,TAU,U1) +! +! This function computes the frequency linearized hydrodynamic memory function +! +! +! Input parameters: +! +! * OMG : frequency in SI +! * TAU : relaxation time in SI +! * U1 : dimensionless parameter 1 / (tau q v_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 29 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : THREE,FIVE,HALF,THIRD,SIXTH,NINTH + USE COMPLEX_NUMBERS, ONLY : IC +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: OMG,TAU,U1 +! + COMPLEX (WP) :: LIHY +! + COMPLEX (WP) :: NUM,DEN +! + NUM = IC * OMG + FIVE * SIXTH / U1 ! + DEN = - OMG * OMG + IC * THREE * HALF / U1 + & ! + FIVE * NINTH / (U1 * U1) + THIRD ! +! + LIHY = HALF * NUM / (DEN * TAU * U1) ! +! + END FUNCTION LIHY +! +END MODULE MEMORY2_FUNCTIONS_F diff --git a/New_libraries/DFM_library/MEMORY_FUNCTIONS_LIBRARY/memory_functions.f90 b/New_libraries/DFM_library/MEMORY_FUNCTIONS_LIBRARY/memory_functions.f90 new file mode 100644 index 0000000..a61247d --- /dev/null +++ b/New_libraries/DFM_library/MEMORY_FUNCTIONS_LIBRARY/memory_functions.f90 @@ -0,0 +1,1211 @@ +! +!======================================================================= +! +MODULE MEMORY_FUNCTIONS_F +! +! This modules provides memory functions in terms of the frequency +! +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + FUNCTION MEMORY_F(V,TAU,TAU2,PCT,ALPHA,BETA,MEM_TYPE) +! +! This function computes the memory function K(tau,omega) +! +! +! +! Input parameters: +! +! * V : dimensionless factor --> V = h_bar omega / E_F +! * TAU : relaxation time in SI +! * TAU2 : second relaxation time in SI +! * PCT : weight of first function (0 < PCT <1) +! * MEM_TYPE : type of memory function used +! MEM_TYPE = 'NONE' --> no function +! MEM_TYPE = 'DELT' --> delta function +! MEM_TYPE = 'DGAU' --> double Gaussian functions +! MEM_TYPE = 'EXPO' --> exponential function +! MEM_TYPE = 'GAUS' --> Gaussian function +! MEM_TYPE = 'LORE' --> Lorentzian function +! MEM_TYPE = 'SINC' --> sinc function +! MEM_TYPE = 'BES0' --> J_0(t) function +! MEM_TYPE = 'BES1' --> J_1(t)/t function +! MEM_TYPE = 'SEC2' --> sech^2(t) function +! MEM_TYPE = 'COCO' --> Cole-Cole function +! MEM_TYPE = 'CODA' --> Cole-Davidson function +! MEM_TYPE = 'HANE' --> Habriliak-Negami function +! MEM_TYPE = 'RAYI' --> Raganathan-Yip function +! MEM_TYPE = 'LIHY' --> linearized hydrodynamic function +! * ALPHA : value of the Habriliak-Negami first parameter (in ]0,1]) +! * BETA : value of the Habriliak-Negami second parameter (in ]0,1]) +! +! +! Remark: The memory function has the dimension of a frequency omega +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO + USE FERMI_SI, ONLY : EF_SI + USE CONSTANTS_P1, ONLY : H_BAR +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: MEM_TYPE +! + REAL (WP), INTENT(IN) :: V,TAU,TAU2,PCT,ALPHA,BETA +! + REAL (WP) :: OMEGA +! + COMPLEX (WP) :: MEMORY_F +! + OMEGA = V * EF_SI / H_BAR ! omega in SI +! + IF(MEM_TYPE == 'NONE') THEN ! + MEMORY_F = ZERO ! + ELSE IF(MEM_TYPE == 'DELT') THEN ! + MEMORY_F = DELTA_F(TAU,OMEGA) ! + ELSE IF(MEM_TYPE == 'DGAU') THEN ! + MEMORY_F = DGAUS_F(TAU,TAU2,PCT,OMEGA) ! + ELSE IF(MEM_TYPE == 'EXPO') THEN ! + MEMORY_F = EXPON_F(TAU,OMEGA) ! + ELSE IF(MEM_TYPE == 'GAUS') THEN ! + MEMORY_F = GAUSS_F(TAU,OMEGA) ! + ELSE IF(MEM_TYPE == 'LORE') THEN ! + MEMORY_F = LOREN_F(TAU,OMEGA) ! + ELSE IF(MEM_TYPE == 'SINC') THEN ! + MEMORY_F = SINCF_F(TAU,OMEGA) ! + ELSE IF(MEM_TYPE == 'BES0') THEN ! + MEMORY_F = BES_0_F(TAU,OMEGA) ! + ELSE IF(MEM_TYPE == 'BES1') THEN ! + MEMORY_F = BES_1_F(TAU,OMEGA) ! + ELSE IF(MEM_TYPE == 'SEC2') THEN ! + MEMORY_F = SECH2_F(TAU,OMEGA) ! + ELSE IF(MEM_TYPE == 'COCO') THEN ! + MEMORY_F = CO_CO_F(TAU,OMEGA,ALPHA) ! + ELSE IF(MEM_TYPE == 'CODA') THEN ! + MEMORY_F = CO_DA_F(TAU,OMEGA,BETA) ! + ELSE IF(MEM_TYPE == 'HANE') THEN ! + MEMORY_F = HA_NE_F(TAU,OMEGA,ALPHA,BETA) ! + END IF ! +! + END FUNCTION MEMORY_F +! +!======================================================================= +! + FUNCTION DELTA_F(TAU,OMEGA) +! +! This function computes the frequency memory function when +! the time-dependent function is a delta function +! +! +! Input parameters: +! +! * TAU : relaxation time in SI +! * OMEGA : frequency in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,HALF + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: TAU,OMEGA +! + COMPLEX (WP) :: DELTA_F +! + COMPLEX (WP) :: CMPLX +! + DELTA_F = CMPLX(HALF * PI_INV / TAU) ! +! + END FUNCTION DELTA_F +! +!======================================================================= +! + FUNCTION DGAUS_F(TAU,TAU2,PCT,OMEGA) +! +! This function computes the frequency memory function when +! the time-dependent function is sum of 2 Gaussian functions +! +! +! Input parameters: +! +! * TAU : relaxation time in SI +! * TAU2 : second relaxation time in SI +! * PCT : seconf relaxation time in SI +! * OMEGA : frequency in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE MINMAX_VALUES +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOURTH + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: TAU,TAU2,PCT,OMEGA +! + REAL (WP) :: EXPO1,EXPO2 + REAL (WP) :: MAX_EXP,MIN_EXP + REAL (WP) :: NUM1,DEN1,NUM2,DEN2 +! + REAL (WP) :: EXP +! + COMPLEX (WP) :: DGAUS_F +! + COMPLEX (WP) :: CMPLX +! +! Computing the max and min value of the exponent of e^x +! + CALL MINMAX_EXP(MAX_EXP,MIN_EXP) ! +! + EXPO1 = FOURTH * TAU * TAU * OMEGA * OMEGA ! + EXPO2 = FOURTH * TAU2 * TAU2 * OMEGA * OMEGA ! +! + IF(- EXPO1 > MIN_EXP) THEN ! + NUM1 = EXP(- EXPO1) ! + DEN1 = PI * TAU ! + ELSE ! + NUM1 = ZERO ! + DEN1 = ONE ! + END IF ! +! + IF(- EXPO2 > MIN_EXP) THEN ! + NUM2 = EXP(- EXPO2) ! + DEN2 = PI * TAU2 ! + ELSE ! + NUM2 = ZERO ! + DEN2 = ONE ! + END IF ! +! + DGAUS_F = PCT * CMPLX(NUM1 / DEN1,KIND=WP) + & ! + (ONE - PCT) * CMPLX(NUM2 / DEN2,KIND=WP) ! +! + END FUNCTION DGAUS_F +! +!======================================================================= +! + FUNCTION EXPON_F(TAU,OMEGA) +! +! This function computes the frequency memory function when +! the time-dependent function is a exponential function +! +! +! Input parameters: +! +! * TAU : relaxation time in SI +! * OMEGA : frequency in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: TAU,OMEGA +! + REAL (WP) :: DENOM +! + COMPLEX (WP) :: EXPON_F +! + COMPLEX (WP) :: CMPLX +! + DENOM = TAU * (ONE + TAU * TAU * OMEGA * OMEGA) ! +! + EXPON_F = CMPLX(PI_INV / DENOM) ! +! + END FUNCTION EXPON_F +! +!======================================================================= +! + FUNCTION GAUSS_F(TAU,OMEGA) +! +! This function computes the frequency memory function when +! the time-dependent function is a Gaussian function +! +! +! Input parameters: +! +! * TAU : relaxation time in SI +! * OMEGA : frequency in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 21 Apr 2021 +! +! + USE MINMAX_VALUES +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOURTH + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: TAU,OMEGA +! + REAL (WP) :: EXPO + REAL (WP) :: MAX_EXP,MIN_EXP + REAL (WP) :: NUM,DEN +! + REAL (WP) :: EXP +! + COMPLEX (WP) :: GAUSS_F +! + COMPLEX (WP) :: CMPLX +! +! Computing the max and min value of the exponent of e^x +! + CALL MINMAX_EXP(MAX_EXP,MIN_EXP) ! +! + EXPO = FOURTH * TAU * TAU * OMEGA * OMEGA ! +! + IF(- EXPO > MIN_EXP) THEN ! + NUM = EXP(- EXPO) ! + DEN = PI * TAU ! + ELSE ! + NUM = ZERO ! + DEN = ONE ! + END IF ! +! + GAUSS_F = CMPLX(NUM / DEN,KIND=WP) ! +! + END FUNCTION GAUSS_F +! +!======================================================================= +! + FUNCTION LOREN_F(TAU,OMEGA) +! +! This function computes the frequency memory function when +! the time-dependent function is a Lorentzian function +! +! +! Input parameters: +! +! * TAU : relaxation time in SI +! * OMEGA : frequency in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 21 Apr 2021 +! +! + USE MINMAX_VALUES +! + USE REAL_NUMBERS, ONLY : ZERO,ONE + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: TAU,OMEGA +! + REAL (WP) :: EXPO + REAL (WP) :: MAX_EXP,MIN_EXP + REAL (WP) :: NUM,DEN +! + REAL (WP) :: EXP +! + COMPLEX (WP) :: LOREN_F +! + COMPLEX (WP) :: CMPLX +! +! Computing the max and min value of the exponent of e^x +! +! + CALL MINMAX_EXP(MAX_EXP,MIN_EXP) ! +! + EXPO = TAU * OMEGA ! +! + IF(- EXPO > MIN_EXP) THEN ! + NUM = EXP(- EXPO) ! + DEN = PI * TAU ! + ELSE ! + NUM = ZERO ! + DEN = ONE ! + END IF ! +! + LOREN_F = CMPLX(NUM / DEN,KIND=WP) ! +! + END FUNCTION LOREN_F +! +!======================================================================= +! + FUNCTION SINCF_F(TAU,OMEGA) +! +! This function computes the frequency memory function when +! the time-dependent function is a sinc function +! +! +! Input parameters: +! +! * TAU : relaxation time in SI +! * OMEGA : frequency in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE COMPLEX_NUMBERS, ONLY : ZEROC + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: TAU,OMEGA +! + COMPLEX (WP) :: SINCF_F +! + COMPLEX (WP) :: CMPLX +! + IF(OMEGA * TAU <= ONE) THEN ! + SINCF_F = CMPLX(PI_INV / TAU) ! + ELSE ! + SINCF_F = ZEROC ! + END IF ! +! + END FUNCTION SINCF_F +! +!======================================================================= +! + FUNCTION BES_0_F(TAU,OMEGA) +! +! This function computes the frequency memory function when +! the time-dependent function is a J_0 function +! +! +! Input parameters: +! +! * TAU : relaxation time in SI +! * OMEGA : frequency in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: TAU,OMEGA +! + REAL (WP) :: DENOM +! + REAL (WP) :: SQRT +! + COMPLEX (WP) :: BES_0_F +! + COMPLEX (WP) :: CMPLX +! + DENOM = TAU * SQRT(ONE - TAU * TAU * OMEGA * OMEGA) ! +! + BES_0_F = CMPLX(PI_INV / DENOM) ! +! + END FUNCTION BES_0_F +! +!======================================================================= +! + FUNCTION BES_1_F(TAU,OMEGA) +! +! This function computes the frequency memory function when +! the time-dependent function is a J_1(t)/t function +! +! +! Input parameters: +! +! * TAU : relaxation time in SI +! * OMEGA : frequency in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,HALF,FOURTH + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: TAU,OMEGA +! + REAL (WP) :: NUM +! + REAL (WP) :: SQRT +! + COMPLEX (WP) :: BES_1_F +! + COMPLEX (WP) :: CMPLX +! + NUM = SQRT(ONE - TAU * TAU * OMEGA * OMEGA * FOURTH) ! +! + BES_1_F = CMPLX(HALF * PI_INV * NUM / TAU) ! +! + END FUNCTION BES_1_F +! +!======================================================================= +! + FUNCTION SECH2_F(TAU,OMEGA) +! +! This function computes the frequency memory function when +! the time-dependent function is a sech^2(t) function +! +! +! Input parameters: +! +! * TAU : relaxation time in SI +! * OMEGA : frequency in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,HALF + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: TAU,OMEGA +! + REAL (WP) :: DENOM +! + REAL (WP) :: SINH +! + COMPLEX (WP) :: SECH2_F +! + COMPLEX (WP) :: CMPLX +! + DENOM = SINH(PI * HALF * OMEGA * TAU) ! +! + SECH2_F = CMPLX(HALF * OMEGA / DENOM) ! +! + END FUNCTION SECH2_F +! +!======================================================================= +! + FUNCTION CO_CO_F(TAU,OMEGA,ALPHA) +! +! This function computes the Cole-Cole memory function +! +! +! References: (1) A. A. Khamzin, R. R. Nigmatullin, and I. I. Popov, +! Theor. Math. Phys. 173, 1604–1619 (2012) +! +! +! Input parameters: +! +! * TAU : relaxation time in SI +! * OMEGA : frequency in SI +! * ALPHA : value of the Habriliak-Negami first parameter (in ]0,1]) +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,HALF + USE PI_ETC, ONLY : PI,PI_INV +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: TAU,OMEGA,ALPHA +! + REAL (WP) :: EXPO,NUM,DEN +! + REAL (WP) :: COS +! + COMPLEX (WP) :: CO_CO_F +! + COMPLEX (WP) :: CMPLX +! + EXPO = ONE - ALPHA ! + NUM = COS(HALF * EXPO * PI) * OMEGA**EXPO ! + DEN = TAU**ALPHA ! +! + CO_CO_F = CMPLX(NUM / DEN) ! +! + END FUNCTION CO_CO_F +! +!======================================================================= +! + FUNCTION CO_DA_F(TAU,OMEGA,BETA) +! +! This function computes the Cole-Davidson memory function +! +! +! References: (1) A. A. Khamzin, R. R. Nigmatullin, and I. I. Popov, +! Theor. Math. Phys. 173, 1604–1619 (2012) +! +! +! Input parameters: +! +! * TAU : relaxation time in SI +! * OMEGA : frequency in SI +! * BETA : value of the Habriliak-Negami second parameter (in ]0,1]) +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE COMPLEX_NUMBERS, ONLY : IC + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: TAU,OMEGA,BETA +! + REAL (WP) :: REAL +! + COMPLEX (WP) :: CO_DA_F + COMPLEX (WP) :: NUM,DEN +! + COMPLEX (WP) :: CMPLX +! + NUM = IC * OMEGA * PI_INV ! + DEN = (ONE + IC * OMEGA * TAU)**BETA - ONE ! +! + CO_DA_F = CMPLX( REAL(NUM / DEN,KIND=WP) ) ! +! + END FUNCTION CO_DA_F +! +!======================================================================= +! + FUNCTION HA_NE_F(TAU,OMEGA,ALPHA,BETA) +! +! This function computes the Havriliak-Negami memory function +! +! +! References: (1) A. A. Khamzin, R. R. Nigmatullin, and I. I. Popov, +! Theor. Math. Phys. 173, 1604–1619 (2012) +! +! +! Input parameters: +! +! * TAU : relaxation time in SI +! * OMEGA : frequency in SI +! * ALPHA : value of the Habriliak-Negami first parameter (in ]0,1]) +! * BETA : value of the Habriliak-Negami second parameter (in ]0,1]) +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE COMPLEX_NUMBERS, ONLY : IC + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: TAU,OMEGA,ALPHA,BETA +! + REAL (WP) :: REAL +! + COMPLEX (WP) :: HA_NE_F + COMPLEX (WP) :: NUM,DEN +! + COMPLEX (WP) :: CMPLX +! + NUM = IC * OMEGA * PI_INV ! + DEN = ( ONE + (IC * OMEGA * TAU)**ALPHA )**BETA - ONE ! +! + HA_NE_F = CMPLX( REAL(NUM / DEN,KIND=WP) ) ! +! + END FUNCTION HA_NE_F +! +!======================================================================= +! +END MODULE MEMORY_FUNCTIONS_F +! +!======================================================================= +! +MODULE MEMORY_FUNCTIONS_T +! +! This modules provides memory functions in terms of the time +! +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + FUNCTION MEMORY_T(T,TAU,TAU2,PCT,ALPHA,BETA,MEM_TYPE) +! +! This function computes the memory function K(t,tau) +! +! +! +! Input parameters: +! +! * T : time in SI +! * TAU : relaxation time in SI +! * TAU2 : second relaxation time in SI +! * PCT : weight of first function (0 < PCT <1) +! * MEM_TYPE : type of memory function used +! MEM_TYPE = 'NONE' --> no function +! MEM_TYPE = 'DELT' --> delta function +! MEM_TYPE = 'DGAU' --> double Gaussian functions +! MEM_TYPE = 'EXPO' --> exponential function +! MEM_TYPE = 'GAUS' --> Gaussian function +! MEM_TYPE = 'LORE' --> Lorentzian function +! MEM_TYPE = 'SINC' --> sinc function +! MEM_TYPE = 'BES0' --> J_0(t) function +! MEM_TYPE = 'BES1' --> J_1(t)/t function +! MEM_TYPE = 'SEC2' --> sech^2(t) function +! MEM_TYPE = 'COCO' --> Cole-Cole function +! MEM_TYPE = 'CODA' --> Cole-Davidson function +! MEM_TYPE = 'HANE' --> Habriliak-Negami function +! * ALPHA : value of the Habriliak-Negami first parameter (in ]0,1]) +! * BETA : value of the Habriliak-Negami second parameter (in ]0,1]) +! +! +! Remark: The memory function has the dimension of a frequency omega +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: MEM_TYPE +! + REAL (WP), INTENT(IN) :: T,TAU,TAU2,PCT,ALPHA,BETA + REAL (WP) :: MEMORY_T +! + IF(MEM_TYPE == 'NONE') THEN ! + MEMORY_T = ZERO ! + ELSE IF(MEM_TYPE == 'DELT') THEN ! + MEMORY_T = DELTA_T(T,TAU) ! + ELSE IF(MEM_TYPE == 'DGAU') THEN ! + MEMORY_T = DGAUS_T(T,TAU,TAU2,PCT) ! + ELSE IF(MEM_TYPE == 'EXPO') THEN ! + MEMORY_T = EXPON_T(T,TAU) ! + ELSE IF(MEM_TYPE == 'GAUS') THEN ! + MEMORY_T = GAUSS_T(T,TAU) ! + ELSE IF(MEM_TYPE == 'LORE') THEN ! + MEMORY_T = LOREN_T(T,TAU) ! + ELSE IF(MEM_TYPE == 'SINC') THEN ! + MEMORY_T = SINCF_T(T,TAU) ! + ELSE IF(MEM_TYPE == 'BES0') THEN ! + MEMORY_T = BES_0_T(T,TAU) ! + ELSE IF(MEM_TYPE == 'BES1') THEN ! + MEMORY_T = BES_1_T(T,TAU) ! + ELSE IF(MEM_TYPE == 'SEC2') THEN ! + MEMORY_T = SECH2_T(T,TAU) ! + ELSE IF(MEM_TYPE == 'COCO') THEN ! + MEMORY_T = CO_CO_T(T,TAU,ALPHA) ! + ELSE IF(MEM_TYPE == 'CODA') THEN ! + MEMORY_T = CO_DA_T(T,TAU,BETA) ! + ELSE IF(MEM_TYPE == 'HANE') THEN ! +! MEMORY_T = HA_NE_T(T,TAU,ALPHA,BETA) ! + END IF ! +! + END FUNCTION MEMORY_T +! +!======================================================================= +! + FUNCTION DELTA_T(T,TAU) +! +! This function computes the time-dependent memory function +! as a delta function +! +! +! Input parameters: +! +! * T : time in SI +! * TAU : relaxation time in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Jan 2021 +! +! + USE BASIC_FUNCTIONS, ONLY : DELTA +! + IMPLICIT NONE +! + INTEGER :: I_D +! + REAL (WP), INTENT(IN) :: T,TAU + REAL (WP) :: DELTA_T +! + REAL (WP) :: EPSI +! +! Parameters of the numerical delta function +! + EPSI = 1.0E-10_WP ! + I_D = 2 ! +! + DELTA_T = DELTA(T,I_D,EPSI) / TAU ! +! + END FUNCTION DELTA_T +! +!======================================================================= +! + FUNCTION DGAUS_T(T,TAU,TAU2,PCT) +! +! This function computes the time-dependent memory function +! as a sum of two Gaussian function1 +! +! +! Input parameters: +! +! * T : time in SI +! * TAU : relaxation time in SI +! * TAU2 : second relaxation time in SI +! * PCT : weight of first function (0 < PCT <1) +! +! +! Author : D. Sébilleau +! +! Last modified : 30 A 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE PI_ETC, ONLY : SQR_PI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: T,TAU,TAU2,PCT + REAL (WP) :: DGAUS_T +! + REAL (WP) :: EXPO1,DEN1 + REAL (WP) :: EXPO2,DEN2 +! + REAL (WP) :: EXP +! + EXPO1 = (T / TAU)**2 ! + DEN1 = TAU * TAU * SQR_PI ! +! + EXPO2 = (T / TAU2)**2 ! + DEN2 = TAU2 * TAU2 * SQR_PI ! +! + DGAUS_T = TWO * ( & ! + PCT * EXP(- EXPO1) / DEN1 + & ! + (ONE - PCT) * EXP(- EXPO2) / DEN2 & ! + ) ! +! + END FUNCTION DGAUS_T +! +!======================================================================= +! + FUNCTION EXPON_T(T,TAU) +! +! This function computes the time-dependent memory function +! as an exponential function +! +! +! Input parameters: +! +! * T : time in SI +! * TAU : relaxation time in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Jan 2021 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: T,TAU + REAL (WP) :: EXPON_T +! + REAL (WP) :: EXPO,DEN +! + REAL (WP) :: EXP +! + EXPO = T / TAU ! + DEN = TAU * TAU ! +! + EXPON_T = EXP(- EXPO) / DEN ! +! + END FUNCTION EXPON_T +! +!======================================================================= +! + FUNCTION GAUSS_T(T,TAU) +! +! This function computes the time-dependent memory function +! as a Gaussian function +! +! +! Input parameters: +! +! * T : time in SI +! * TAU : relaxation time in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE PI_ETC, ONLY : SQR_PI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: T,TAU + REAL (WP) :: GAUSS_T +! + REAL (WP) :: EXPO,DEN +! + REAL (WP) :: EXP +! + EXPO = (T / TAU)**2 ! + DEN = TAU * TAU * SQR_PI ! +! + GAUSS_T = TWO * EXP(- EXPO) / DEN ! +! + END FUNCTION GAUSS_T +! +!======================================================================= +! + FUNCTION LOREN_T(T,TAU) +! +! This function computes the time-dependent memory function +! as a Lorentzian function +! +! +! Input parameters: +! +! * T : time in SI +! * TAU : relaxation time in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: T,TAU + REAL (WP) :: LOREN_T +! + REAL (WP) :: EXPO,DEN +! + EXPO = (T / TAU)**2 ! + DEN = TAU * TAU * PI * (ONE + EXPO) ! +! + LOREN_T = TWO / DEN ! +! + END FUNCTION LOREN_T +! +!======================================================================= +! + FUNCTION SINCF_T(T,TAU) +! +! This function computes the time-dependent memory function +! as a sinc function +! +! +! Input parameters: +! +! * T : time in SI +! * TAU : relaxation time in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 28 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,TWO + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: T,TAU + REAL (WP) :: SINCF_T +! + REAL (WP) :: EXPO,NUM,DEN +! + REAL (WP) :: SIN +! + EXPO = T / TAU ! + NUM = TWO * SIN(EXPO) ! + DEN = TAU * TAU * PI * EXPO ! +! + IF(EXPO == ZERO) THEN ! + SINCF_T = TWO / (TAU * TAU * PI) ! + ELSE ! + SINCF_T = NUM / DEN ! + END IF ! +! + END FUNCTION SINCF_T +! +!======================================================================= +! + FUNCTION BES_0_T(T,TAU) +! +! This function computes the time-dependent memory function +! as a J_0(t) function +! +! +! Input parameters: +! +! * T : time in SI +! * TAU : relaxation time in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Jan 2021 +! +! + USE BESSEL, ONLY : BESSJ0 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: T,TAU + REAL (WP) :: BES_0_T +! + REAL (WP) :: EXPO,DEN +! + EXPO = T / TAU ! + DEN = TAU * TAU ! +! + BES_0_T = BESSJ0(EXPO) / DEN ! +! + END FUNCTION BES_0_T +! +!======================================================================= +! + FUNCTION BES_1_T(T,TAU) +! +! This function computes the time-dependent memory function +! as a J_1(t)/t function +! +! +! Input parameters: +! +! * T : time in SI +! * TAU : relaxation time in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO + USE BESSEL, ONLY : BESSJ1 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: T,TAU + REAL (WP) :: BES_1_T +! + REAL (WP) :: EXPO,DEN +! + EXPO = TWO * T / TAU ! + DEN = TAU * T ! +! + IF(EXPO == ZERO) THEN ! + BES_1_T = ONE / (TAU * TAU) ! + ELSE ! + BES_1_T = BESSJ1(EXPO) / DEN ! + END IF ! +! + END FUNCTION BES_1_T +! +!======================================================================= +! + FUNCTION SECH2_T(T,TAU) +! +! This function computes the time-dependent memory function +! as a sech^2(t) function +! +! +! Input parameters: +! +! * T : time in SI +! * TAU : relaxation time in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ONE +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: T,TAU + REAL (WP) :: SECH2_T +! + REAL (WP) :: EXPO,DEN +! + EXPO = T / TAU ! + DEN = TAU * TAU * COSH(EXPO) * COSH(EXPO) ! +! + SECH2_T = ONE / DEN ! +! + END FUNCTION SECH2_T +! +!======================================================================= +! + FUNCTION CO_CO_T(T,TAU,ALPHA) +! +! This function computes the time-dependent memory function +! as a Cole-Cole function +! +! +! References: (1) A. A. Khamzin, R. R. Nigmatullin, and I. I. Popov, +! Theor. Math. Phys. 173, 1604–1619 (2012) +! +! +! Input parameters: +! +! * T : time in SI +! * TAU : relaxation time in SI +! * ALPHA : value of the Habriliak-Negami first parameter (in ]0,1]) +! +! +! Author : D. Sébilleau +! +! Last modified : 28 Jan 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,SMALL + USE EXT_FUNCTIONS, ONLY : DLGAMA +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: T,TAU,ALPHA + REAL (WP) :: CO_CO_T +! + REAL (WP) :: NUM,DEN +! + REAL (WP) :: EXP +! + IF(T == ZERO) THEN ! + NUM = ONE / SMALL ! + ELSE ! + NUM = (T / TAU)**(ALPHA - TWO) ! + END IF ! + DEN = TAU**2 * EXP( DLGAMA(ALPHA - ONE) ) ! +! + CO_CO_T = NUM / DEN ! ref. (1) eq. (23) +! + END FUNCTION CO_CO_T +! +!======================================================================= +! + FUNCTION CO_DA_T(T,TAU,BETA) +! +! This function computes the time-dependent memory function +! as a Cole-Davidson function +! +! +! References: (1) A. A. Khamzin, R. R. Nigmatullin, and I. I. Popov, +! Theor. Math. Phys. 173, 1604–1619 (2012) +! +! +! Input parameters: +! +! * T : time in SI +! * TAU : relaxation time in SI +! * BETA : value of the Habriliak-Negami first parameter (in ]0,1]) +! +! +! Author : D. Sébilleau +! +! Last modified : 24 Feb 2021 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,SMALL +! USE EXT_FUNCTIONS, ONLY : MLFV,MLFVDERIV + USE MOD_MLF_GARRAPPA +! + IMPLICIT NONE +! + INTEGER :: P +! + REAL (WP), INTENT(IN) :: T,TAU,BETA + REAL (WP) :: CO_DA_T +! + REAL (WP) :: S,EXPO,COEF1,COEF2 + REAL (WP) :: NUM,DEN +! + REAL (WP) :: EXP +! + COMPLEX (WP) :: Z +! + COMPLEX (WP) :: CMPLX +! + P = 6 ! accuracy: 10^(-P) +! + S = T / TAU ! + EXPO = S**BETA ! + Z = CMPLX(EXPO) ! + IF(T /= ZERO) THEN ! + NUM = EXP(- S) * EXPO / (S * S) ! + END IF ! + DEN = TAU**2 ! + COEF1 = BETA - ONE - S ! + COEF2 = BETA * EXPO ! +! + IF(T == ZERO) THEN ! + CO_DA_T = ONE / (SMALL * DEN) ! + ELSE ! +! CO_DA_T = NUM * ( COEF1 * REAL(MLFV(BETA,BETA,Z,P)) + & ! +! COEF2 * REAL(MLFVDERIV(BETA,BETA,Z,P)) )& ! +! / DEN ! + CO_DA_T = NUM * ( COEF1 * REAL(GENMLF(BETA,BETA,ONE,Z)) + & ! + COEF2 * REAL(MLD_GARRAPPA(BETA,BETA,Z)) & ! + ) / DEN ! + END IF ! +! + END FUNCTION CO_DA_T +! +!======================================================================= +! +END MODULE MEMORY_FUNCTIONS_T diff --git a/New_libraries/DFM_library/MOMENTS_LIBRARY/loss_moments.f90 b/New_libraries/DFM_library/MOMENTS_LIBRARY/loss_moments.f90 new file mode 100644 index 0000000..87442cc --- /dev/null +++ b/New_libraries/DFM_library/MOMENTS_LIBRARY/loss_moments.f90 @@ -0,0 +1,119 @@ +! +!======================================================================= +! +MODULE LOSS_MOMENTS +! + USE ACCURACY_REAL +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE LOSS_MOMENTS_AN(X,C0,C2,C4) +! +! This subroutine computes "analytically" the first three moments +! of the loss function. +! +! +! References: (1) Yu. V. Arkhipov et al, EPL, 104, 35003 (2013) +! +! +! Warning: This subroutine makes us of the Arkhipov et al definition +! of the loss function +! +! / + INF _ _ +! 1 | n-1 | 1 | +! C_n = ---- | omega Im | - --------- | d omega +! pi | |_ epsilon _| +! / - INF +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Outpu parameters: +! +! * C0 : \ +! * C2 : > moments of the loss function +! * C4 : / +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Nov 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN,RS + USE LF_VALUES, ONLY : IQ_TYPE +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI,EF_SI + USE PLASMON_ENE_SI + USE DFUNC_STATIC, ONLY : RPA1_EPS_S_LG + USE UTILITIES_1, ONLY : D + USE IQ_FUNCTIONS_1 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP), INTENT(OUT) :: C0,C2,C4 +! + REAL (WP) :: Q_SI + REAL (WP) :: OMP,OMQ + REAL (WP) :: OMP2,OMQ2 + REAL (WP) :: EPSR,EPSI + REAL (WP) :: DIME,AV_KE,IQ +! +! Computing the plasmon frequency +! + OMP = ENE_P_SI / H_BAR ! omega_p +! +! Computing the plasmon kinetic frequency +! + Q_SI = TWO * X * KF_SI ! q in SI + OMQ = HALF * H_BAR * Q_SI * Q_SI / M_E ! omega_q in SI +! + OMP2 = OMP * OMP ! + OMQ2 = OMQ * OMQ ! +! +! Computing the dimensionality +! + DIME = D(DMN) ! +! +! Computing the static RPA dielectric function +! + CALL RPA1_EPS_S_LG(X,DMN,EPSR,EPSI) ! +! +! Computing I(q) +! + IF(DMN == '3D') THEN ! + CALL IQ_3D(X,RS,IQ_TYPE,IQ) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! not implemented yet + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! not implemented yet + END IF ! +! +! Computing the average ground state kinetic energy : +! +! d +! = --------- E_F +! 0 (d + 2) +! + AV_KE = DIME * EF_SI / (DIME + TWO) ! _0 in SI +! +! Getting the moments in SI +! + C0 = ONE - ONE / EPSR ! \ + C2 = OMP2 ! | + C4 = OMP2 * ( FOUR * AV_KE * OMQ / H_BAR + & ! |> ref. (1) eq. (3)-(4) + OMQ2 + OMP2 * (ONE - IQ) & ! | + ) ! / +! + END SUBROUTINE LOSS_MOMENTS_AN +! +END MODULE LOSS_MOMENTS diff --git a/New_libraries/DFM_library/MOMENTS_LIBRARY/moments.f90 b/New_libraries/DFM_library/MOMENTS_LIBRARY/moments.f90 new file mode 100644 index 0000000..408ca67 --- /dev/null +++ b/New_libraries/DFM_library/MOMENTS_LIBRARY/moments.f90 @@ -0,0 +1,247 @@ +! +!======================================================================= +! +MODULE MOMENTS_EXACT +! + USE ACCURACY_REAL +! +! It contains the following functions/subroutines: +! +! * +! +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE MOMENTS_POL_RPA_2D(X,RS,M1,M3) +! +! This subroutine computes the first moments of the polarization +! Pi(q,omega) in the RPA model +! +! +! References: (1) N. Iwamoto, Phys. Rev. A 30, 3289-3304 (1984) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Output parameter: +! +! * M1 : moment of order 1 +! * M3 : moment of order 3 +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,THREE,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE UTILITIES_1, ONLY : RS_TO_N0 +! + IMPLICIT NONE +! + REAL (WP) :: X + REAL (WP) :: M1,M3 + REAL (WP) :: Q_SI,OM_0 + REAL (WP) :: COEF + REAL (WP) :: RS,N0 +! + Q_SI=TWO*X*KF_SI ! q in SI + OM_0=HALF*H_BAR*Q_SI*Q_SI/M_E ! E_q / hbar +! + N0=RS_TO_N0('2D',RS) ! +! + COEF=N0*Q_SI*Q_SI/M_E ! +! + M1=COEF ! ref. (1) eq. (2.25a) + M3=COEF*( OM_0*OM_0 + THREE*EF_SI*OM_0/H_BAR ) ! ref. (1) eq. (2.25b) +! + END SUBROUTINE MOMENTS_POL_RPA_2D +! +!======================================================================= +! + SUBROUTINE MOMENTS_POL_3D(X,RS,T,SQ_TYPE,GQ_TYPE,EC_TYPE, & + IQ_TYPE,M1,M3) +! +! This subroutine computes the first moments of the polarization +! Pi(q,omega) +! +! +! References: (1) S. Ichimaru, Rev. Mod. Phys. 54, 1017-1059 (1982) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * SQ_TYPE : structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! * IQ_TYPE : type of approximation for I(q) +! +! +! Output parameter: +! +! * M1 : moment of order 1 +! * M3 : moment of order 3 +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FIVE,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE IQ_FUNCTIONS_1 + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE + CHARACTER (LEN = 4) :: GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE,IQ_TYPE +! + REAL (WP) :: X,RS,T + REAL (WP) :: M1,M3 + REAL (WP) :: Q_SI,OM_0 + REAL (WP) :: COEF + REAL (WP) :: IQ + REAL (WP) :: N0 +! + Q_SI=TWO*X*KF_SI ! q in SI + OM_0=HALF*H_BAR*Q_SI*Q_SI/M_E ! E_q / hbar +! + N0=RS_TO_N0('3D',RS) ! +! + COEF=N0*Q_SI*Q_SI/M_E ! +! +! Computing the IQ function +! + CALL IQ_3D(X,RS,IQ_TYPE,IQ) ! +! +! Computing the moments +! + M1=COEF ! ref. (1) eq. (3.34) + M3=COEF*( & ! + OM_0*OM_0 + 12.0E0_WP*EF_SI*OM_0/(FIVE*H_BAR) + & ! ref. (1) eq. (3.35) + ENE_P_SI*ENE_P_SI/(H_BAR*H_BAR) * (ONE-IQ) & ! + ) ! +! + END SUBROUTINE MOMENTS_POL_3D +! +!======================================================================= +! + SUBROUTINE MOMENTS_LOS_3D(X,RS,T,C0,C2,C4) +! +! This subroutine computes the first moments of the loss function: +! +! +! Cn(q) = 1/pi int_{-inf}^{+inf} omega^n L(q,omega) d omega +! +! with the loss function given by +! +! L(q,omega) = -1/omega * Im[ 1/epsilon(q,omega) ] +! +! +! References: (1) Yu. V. Arkhipov et al, Contrib. Plasma Phys. 55, 381-389 (2015) +! (2) Yu. V. Arkhipov et al, Contrib. Plasma Phys. 59, e201800171 (2019) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Output parameters: +! +! * C0 : 0-th order moment of the loss function +! * C2 : 2-th order moment of the loss function +! * C4 : 4-th order moment of the loss function +! +! +! Author : D. Sébilleau +! +! Last modified : 18 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,THREE,FOUR, & + HALF,THIRD + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE VELOCITIES, ONLY : VELOCITIES_3D + USE PLASMA_SCALE + USE PLASMA, ONLY : PL_TYPE,ZION + USE ENERGIES, ONLY : EC_TYPE + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE PLASMON_ENE_SI +! + REAL (WP) :: X,Y,RS,T + REAL (WP) :: C0,C2,C4 + REAL (WP) :: OP2 + REAL (WP) :: KQ4,KD2,K,U,H + REAL (WP) :: Q2,Q4 + REAL (WP) :: N0 + REAL (WP) :: NONID,DEGEN + REAL (WP) :: KD_SI + REAL (WP) :: BETA,COEF + REAL (WP) :: VE2,V_INT_2 +! + Y=X+X ! Y = q / k_F +! + N0=RS_TO_N0('3D',RS) ! +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! + CALL PLASMON_SCALE(RS,T,ZION,NONID,DEGEN) ! + CALL VELOCITIES_3D(RS,T,EC_TYPE,VE2,V_INT_2) ! +! + KD2=KD_SI*KD_SI ! + KQ4=16.0E0_WP*PI*N0*M_E*M_E/(H_BAR*H_BAR) ! +! + BETA=ONE/(K_B*T) ! + OP2=(ENE_P_SI/H_BAR)**2 ! omega_p^2 + Q2=Y*Y*KF_SI*KF_SI ! + Q4=Q2*Q2 ! +! +! Parameter the calculation of U +! + COEF=-FOUR*Q2*(NONID**1.5E0_WP)/(15.0E0_WP*BETA*M_E) ! +! + KD2=KD_SI*KD_SI ! + KQ4=16.0E0_WP*PI*N0*M_E*M_E/(H_BAR*H_BAR) ! +! + K=VE2*Q2/((ENE_P_SI/H_BAR)**2) + & ! ref. (2) eq. (12) + (HALF*H_BAR/M_E)**2 * Q4/OP2 ! + U=COEF*(-0.9052E0_WP/DSQRT(0.6322E0_WP+NONID) + & ! ref. (2) eq. (14) + 0.27243E0_WP/(ONE+NONID)) ! +! + IF(PL_TYPE == 'OCP') THEN ! no ion case + H=ZERO ! + ELSE IF(PL_TYPE == 'DCP') THEN ! + H=FOUR*THIRD*ZION*RS*DSQRT(NONID)/ & ! ref. (3) eq. (6) + DSQRT(THREE*ZION*NONID*NONID + FOUR*RS + & ! + FOUR*NONID*DSQRT(THREE*(ONE+ZION)*RS)) ! + END IF ! +! +! Moments of the loss function +! + C0=KD2*KQ4/(Q2*KQ4+Q4*KD2+KQ4*KD2) ! ref. (2) eq. (9) + C2=OP2 ! ref. (2) eq. (10) + C4=OP2*OP2 * (ONE + K + U + H) ! ref. (1) eq. (4) +! + END SUBROUTINE MOMENTS_LOS_3D +! +END MODULE MOMENTS_EXACT diff --git a/New_libraries/DFM_library/MOMENTS_LIBRARY/moments_loss.f90 b/New_libraries/DFM_library/MOMENTS_LIBRARY/moments_loss.f90 new file mode 100644 index 0000000..5c10663 --- /dev/null +++ b/New_libraries/DFM_library/MOMENTS_LIBRARY/moments_loss.f90 @@ -0,0 +1,366 @@ +! +!======================================================================= +! +MODULE MOMENTS_CALC +! + USE ACCURACY_REAL +! +! This module provides the functions/subroutines to compute +! the moments of different functions +! +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE MOMENTS_LOSS_FUNCTION(X,N,MLO) +! +! This module computes the moments of the loss function +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * N : moment order +! +! +! Output variables : +! +! * MLO : moment +! +! +! +! The moments are defined by +! _ _ +! / + INF | | +! | n | - 1 | +! < omega^n> = 2 | omega Im | ------------- | d omega +! | | eps(q,omega) | +! / 0 |_ _| +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE MATERIAL_PROP, ONLY : RS + USE EXT_FIELDS, ONLY : T +! + USE REAL_NUMBERS, ONLY : ZERO,TWO,FOURTH,TTINY,INF + USE FERMI_SI, ONLY : KF_SI +! + USE E_GRID +! + USE DF_VALUES, ONLY : D_FUNC +! + USE INTEGRATION, ONLY : INTEGR_L + USE DFUNCL_STAN_DYNAMIC +! + IMPLICIT NONE +! + INTEGER,INTENT(IN) :: N + INTEGER :: IE + INTEGER :: ID + INTEGER :: I_ZE +! + REAL (WP), INTENT(IN) :: X + REAL (WP), INTENT(OUT):: MLO + REAL (WP) :: E,V,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: ELF(NSIZE) + REAL (WP) :: A +! + IF(MOD(N,2) == 0 .AND. N /= 0) THEN ! + MLO = ZERO ! + RETURN ! + END IF ! +! + I_ZE = 0 ! switch for integrand = 0 +! +! Constructing the e-grid +! + DO IE = 1, N_E ! E_F +! + E = E_MIN + FLOAT(IE - 1) * E_STEP ! in units of + V = E ! hbar * omega / E_F + Z = FOURTH * V / (X * X) ! omega / omega_q +! +! Computing the dielectric function epsilon(q,E) +! + CALL DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNC,IE,EPSR,EPSI) ! +! +! Computing the loss function ELF = Im [ -1 / epsilon(q,E) ] +! + ELF(IE) = E**N * EPSI / ( (EPSR * EPSR + EPSI * EPSI) ) ! integrand function +! + IF(ABS(ELF(IE)) >= TTINY) I_ZE = IE ! +! + END DO ! +! + IF(I_ZE > 0) THEN ! +! +! Performing the e-integration with respect to E +! + ID = 1 ! + CALL INTEGR_L(ELF,E_STEP,NSIZE,N_E,A,ID) ! +! + MLO = TWO * A ! +! + ELSE ! IN always = 0 +! + MLO = ZERO ! +! + END IF ! +! + END SUBROUTINE MOMENTS_LOSS_FUNCTION +! +!======================================================================= +! + SUBROUTINE MOMENTS_STRUCT_FACTOR(X,N,MSF) +! +! This module computes the moments of the dynamical structure factor +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * N : moment order +! +! +! Output variables : +! +! * MLO : moment +! +! +! +! The moments are defined by +! +! / + INF +! | n +! < omega^n> = 2 | omega S(q,omega) d omega +! | +! / 0 +! +! +! Note: in the calculation of the moments of the loss function, q and omega +! are respectively in units of k_F and E_F +! +! --> we write the coefficient COEF in units of 1/ E_F +! +! +! Author : D. Sébilleau +! +! Last modified : 21 Oct 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE MATERIAL_PROP, ONLY : RS + USE EXT_FIELDS, ONLY : T +! + USE REAL_NUMBERS, ONLY : ZERO,TWO,HALF,FOURTH,TTINY,INF + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI_INV +! + USE E_GRID +! + USE PLASMON_ENE_SI + USE SF_VALUES + USE STRUCTURE_FACTOR_DYNAMIC + USE MOMENTS, ONLY : M_TYPE + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + INTEGER,INTENT(IN) :: N + INTEGER :: IE + INTEGER :: ID + INTEGER :: I_ZE + INTEGER :: LOGF +! + REAL (WP), INTENT(IN) :: X + REAL (WP), INTENT(OUT):: MSF +! + REAL (WP) :: Q_SI,EQ_SI + REAL (WP) :: COEF,MLO + REAL (WP) :: E,V,Z + REAL (WP) :: SQM(NSIZE) + REAL (WP) :: SQO,A +! + LOGF = 6 ! log file unit +! + IF(M_TYPE == 'EPS') THEN +! + Q_SI = TWO * KF_SI * X ! q in SI +! + EQ_SI = HALF * H_BAR * H_BAR * Q_SI * Q_SI / M_E ! h_bar omega_q in SI + COEF = TWO * PI_INV * (EQ_SI / ENE_P_SI) * EF_SI / ENE_P_SI! coefficient in units of 1/E_F +! +! Computing the moments of the loss function +! + CALL MOMENTS_LOSS_FUNCTION(X,N,MLO) ! +! + MSF = COEF * MLO ! +! + ELSE IF(M_TYPE == 'SQO') THEN ! +! + IF(SSTDY == ' STATIC') THEN ! pathological case + WRITE(LOGF,10) ! + STOP ! + END IF ! +! +! Constructing the e-grid +! + DO IE = 1, N_E ! +! + E = E_MIN + FLOAT(IE - 1) * E_STEP ! in units of + V = E ! hbar * omega / E_F + Z = FOURTH * V / (X * X) ! omega / omega_q +! +! Computing the dynamical structure factor +! + CALL STFACT_DYNAMIC(X,Z,RS,T,SQO_TYPE,SQ_TYPE,SQO) ! +! + SQM(IE) = E**N * SQO ! integrand function +! + IF(ABS(SQM(IE)) >= TTINY) I_ZE = IE ! +! + END DO ! +! + IF(I_ZE > 0) THEN ! +! +! Performing the e-integration with respect to E +! + ID = 1 ! + CALL INTEGR_L(SQM,E_STEP,NSIZE,N_E,A,ID) ! +! + MSF = TWO * A ! +! + ELSE ! IN always = 0 +! + MSF = ZERO ! +! + END IF ! +! + END IF ! +! +! Format: +! + 10 FORMAT(//,10X,'<<<<< SSTDY PARAMETER WRONG >>>>>',/ & + 10X,'<<<<< CHANGE IN INPUT FILE >>>>>',//) +! + END SUBROUTINE MOMENTS_STRUCT_FACTOR +! +!======================================================================= +! + SUBROUTINE MOMENTS_EPSILON(X,N,MEP) +! +! This module computes the moments of the dynamical structure factor +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * N : moment order +! +! +! Output variables : +! +! * MEP : moment +! +! +! +! The moments are defined by +! +! / + INF _ _ +! | n | | +! < omega^n> = 2 | omega Im | eps(q,omega) | d omega +! | |_ _| +! / 0 +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE MATERIAL_PROP, ONLY : RS + USE EXT_FIELDS, ONLY : T +! + USE REAL_NUMBERS, ONLY : ZERO,TWO,FOURTH,TTINY,INF + USE FERMI_SI, ONLY : KF_SI +! + USE E_GRID +! + USE DF_VALUES, ONLY : D_FUNC +! + USE INTEGRATION, ONLY : INTEGR_L + USE INTEGRATION4 + USE DFUNCL_STAN_DYNAMIC +! + IMPLICIT NONE +! + INTEGER,INTENT(IN) :: N + INTEGER :: IE + INTEGER :: ID + INTEGER :: I_ZE +! + REAL (WP), INTENT(IN) :: X + REAL (WP), INTENT(OUT):: MEP + REAL (WP) :: E,V,Z + REAL (WP) :: EPSR,EPSI + REAL (WP) :: ELF(NSIZE) + REAL (WP) :: A +! + IF(MOD(N,2) == 0 .AND. N /= 0) THEN ! + MEP = ZERO ! + RETURN ! + END IF ! +! + I_ZE = 0 ! switch for integrand = 0 +! +! Constructing the e-grid +! + DO IE = 1, N_E ! E_F +! + E = E_MIN + FLOAT(IE - 1) * E_STEP ! in units of + V = E ! hbar * omega / E_F + Z = FOURTH * V / (X * X) ! omega / omega_q +! +! Computing the dielectric function epsilon(q,E) +! + CALL DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNC,IE,EPSR,EPSI) ! +! +! Computing the loss function ELF = Im [ -1 / epsilon(q,E) ] +! + ELF(IE) = E**N * EPSI ! integrand function +! + IF(ABS(ELF(IE)) >= TTINY) I_ZE = IE ! +! + END DO ! +! + IF(I_ZE > 0) THEN ! +! +! Performing the e-integration with respect to E +! + ID = 1 ! + CALL INTEGR_L(ELF,E_STEP,NSIZE,N_E,A,ID) ! +! + MEP = TWO * A ! +! + ELSE ! IN always = 0 +! + MEP = ZERO ! +! + END IF ! +! + END SUBROUTINE MOMENTS_EPSILON +! +END MODULE MOMENTS_CALC diff --git a/New_libraries/DFM_library/NEVANLINNA_FUNCTIONS_LIBRARY/Nevanlinna_functions.f90 b/New_libraries/DFM_library/NEVANLINNA_FUNCTIONS_LIBRARY/Nevanlinna_functions.f90 new file mode 100644 index 0000000..fda80fc --- /dev/null +++ b/New_libraries/DFM_library/NEVANLINNA_FUNCTIONS_LIBRARY/Nevanlinna_functions.f90 @@ -0,0 +1,642 @@ +! +!======================================================================= +! +MODULE NEVALINNA_FUNCTIONS +! +! This modules provides Nevalinna functions +! +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + FUNCTION NEVAN2(X,Z,RS,T,TAU,NEV_TYPE) +! +! This function computes the Nevalinna function Q_2(x,omega) +! +! In an electron liquid, the Nevalinna function Q(x,z) plays the role +! of the dynamic local-field correction G(x,z). +! +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * TAU : relaxation time in SI +! * NEV_TYPE : type of Nevalinna function used +! NEV_TYPE = 'NONE' --> no function +! NEV_TYPE = 'RELA' --> static value h(q) = i / tau +! NEV_TYPE = 'STA1' --> static value h(q) +! NEV_TYPE = 'STA2' --> static value h(q) +! NEV_TYPE = 'STA3' --> static value h(q) +! NEV_TYPE = 'STA4' --> static value h(q) +! NEV_TYPE = 'PEEL' --> Perel'-Eliashberg function +! NEV_TYPE = 'PE76' --> Perel'-Eliashberg by V. Arkhipov et al +! NEV_TYPE = 'CPP1' --> +! NEV_TYPE = 'CPP2' --> +! NEV_TYPE = 'CPP3' --> +! NEV_TYPE = 'CPP4' --> +! NEV_TYPE = 'PST1' --> +! +! +! Remark: The Nevalinna function has the dimension of a frequency omega +! +! +! Author : D. Sébilleau +! +! Last modified : 18 Nov 2020 +! +! + USE COMPLEX_NUMBERS, ONLY : ZEROC,IC + USE LOSS_MOMENTS +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: NEV_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,T,RS,TAU + REAL (WP) :: C0,C2,C4 + REAL (WP) :: OM12,OM22 +! + COMPLEX (WP) :: NEVAN2 +! +! Computing the moments of the loss function +! + CALL LOSS_MOMENTS_AN(X,C0,C2,C4) ! +! + OM12 = C2 / C0 ! + OM22 = C4 / C2 ! +! + IF(NEV_TYPE == 'NONE') THEN ! + NEVAN2 = ZEROC ! + ELSE IF(NEV_TYPE == 'RELA') THEN ! + NEVAN2 = IC / TAU ! + ELSE IF(NEV_TYPE == 'STA1') THEN ! + NEVAN2 = STA1(OM12,OM22) ! + ELSE IF(NEV_TYPE == 'STA2') THEN ! + NEVAN2 = STA2(OM22,TAU) ! + ELSE IF(NEV_TYPE == 'STA3') THEN ! + NEVAN2 = STA3(X,OM12,OM22) ! + ELSE IF(NEV_TYPE == 'STA4') THEN ! + NEVAN2 = STA4(X,OM12,TAU) ! + ELSE IF(NEV_TYPE == 'CPP1') THEN ! + NEVAN2 = CPP1(X,Z,RS,OM12,OM22) ! + ELSE IF(NEV_TYPE == 'CPP2') THEN ! + NEVAN2 = CPP2(X,Z,RS,TAU,OM12,OM22) ! + ELSE IF(NEV_TYPE == 'CPP3') THEN ! + NEVAN2 = CPP3(X,Z,OM22,TAU) ! + ELSE IF(NEV_TYPE == 'CPP4') THEN ! + NEVAN2 = CPP4(X,Z,T,OM12,OM22) ! + ELSE IF(NEV_TYPE == 'PEEL') THEN ! + NEVAN2 = PEEL(X,Z,RS,OM12,OM22) ! + ELSE IF(NEV_TYPE == 'PE76') THEN ! + NEVAN2 = PE76(X,Z,RS,OM12,OM22) ! + ELSE IF(NEV_TYPE == 'PST1') THEN ! + NEVAN2 = PST1(X,Z,OM12,OM22) ! + END IF ! +! + END FUNCTION NEVAN2 +! +!======================================================================= +! + FUNCTION STA1(OM12,OM22) +! +! This function computes a static Nevalinna function +! +! +! References: (1) Yu. V. Arkhipov et al, Contrib. Plasma Phys. 58, +! 967–975 (2018) +! +! +! Input parameters: +! +! * OM12 : omega_1^2 \ characteristic squared +! * OM22 : omega_2^2 / frequencies +! +! +! Author : D. Sébilleau +! +! Last modified : 18 Nov 2020 +! + USE REAL_NUMBERS, ONLY : TWO + USE COMPLEX_NUMBERS, ONLY : IC +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: OM12,OM22 +! + REAL (WP) :: SQRT +! + COMPLEX (WP) :: STA1 +! + STA1 = IC * OM22 / SQRT(TWO * OM12) ! ref. (1) eq. (13) +! + END FUNCTION STA1 +! +!======================================================================= +! + FUNCTION STA2(OM22,TAU) +! +! This function computes a static Nevalinna function +! +! +! References: (1) Yu. V. Arkhipov et al, Contrib. Plasma Phys. 50, +! 165-176 (2010) +! +! +! Input parameters: +! +! * OM22 : omega_2^2 characteristic squared frequency +! * TAU : relaxation time (in SI) +! +! +! Author : D. Sébilleau +! +! Last modified : 18 Nov 2020 +! + USE REAL_NUMBERS, ONLY : TWO + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: OM22,TAU +! + REAL (WP) :: OMP,OM2 +! + COMPLEX (WP) :: STA2 +! + OMP = ENE_P_SI / H_BAR ! omega_p + OM2 = OM22 - OMP * OMP ! ref. (1) eq. (15) +! + STA2 = IC * OM2 * TAU ! ref. (1) eq. (29) +! + END FUNCTION STA2 +! +!======================================================================= +! + FUNCTION STA3(X,OM12,OM22) +! +! This function computes a static Nevalinna function +! +! +! References: (1) S. V. Adamjan, T. Meyer and I. M. Tkachenko, +! Contrib. Plasma Phys. 29, 373-375 (1989) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * OM12 : omega_1^2 \ characteristic squared +! * OM22 : omega_2^2 / frequencies +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Nov 2020 +! + USE MATERIAL_PROP, ONLY : DMN +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE PI_ETC, ONLY : PI + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE DFUNC_STATIC, ONLY : RPA1_EPS_S_LG +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,OM12,OM22 + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,OMQ + +! + COMPLEX (WP) :: STA3 +! + Q_SI = TWO * X * KF_SI ! q in SI +! + OMQ = HALF * H_BAR * Q_SI * Q_SI / M_E ! omega_q +! +! Computing the static RPA dielectric function +! + CALL RPA1_EPS_S_LG(X,DMN,EPSR,EPSI) ! +! + STA3 = IC * EPSR * (EPSR - ONE) * HALF * PI * OMQ * & ! + BOHR * Q_SI * (OM22 / OM12 - ONE) ! +! + END FUNCTION STA3 +! +!======================================================================= +! + FUNCTION STA4(X,OM12,TAU) +! +! This function computes a static Nevalinna function +! +! +! References: (1) V. M. Adamyan and I. M. Tkachenko, +! Contrib. Plasma Phys. 43, 252-257 (2003) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * OM12 : omega_1^2 characteristic squared frequency +! * TAU : relaxation time (in SI) +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Nov 2020 +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE PI_ETC, ONLY : PI + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI,EF_SI + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,OM12,TAU + REAL (WP) :: EPSR,EPSI + REAL (WP) :: Q_SI,OMQ + REAL (WP) :: OMP,OM220 + REAL (WP) :: OMP2,OMQ2 + REAL (WP) :: AV_KE +! + COMPLEX (WP) :: STA4 +! + Q_SI = TWO * X * KF_SI ! q in SI +! + OMP = ENE_P_SI / H_BAR ! omega_p + OMQ = HALF * H_BAR * Q_SI * Q_SI / M_E ! omega_q +! + OMP2 = OMP * OMP ! + OMQ2 = OMQ * OMQ ! +! +! Computing omega_2^2(0) = C_4(0) / C_2 --> with I(0) = 0 +! + OM220 = OMP2 * ( FOUR * AV_KE * OMQ / H_BAR + & ! + OMQ2 + OMP2 & ! + ) ! +! + STA4 = IC * TAU * OMP2 * (OM220 / OMP2 - ONE) ! ref. (1), before eq. (29) +! + END FUNCTION STA4 +! +!======================================================================= +! + FUNCTION PEEL(X,Z,RS,OM12,OM22) +! +! This function computes the Perel'-Eliashberg dynamic Nevalinna function +! +! +! References: (1) Yu. V. Arkhipov et al, Contrib. Plasma Phys. 55, +! 381-389 (2015) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * OM12 : omega_1^2 \ characteristic squared +! * OM22 : omega_2^2 / frequencies +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Nov 2020 +! + USE PLASMA, ONLY : ZION +! + USE REAL_NUMBERS, ONLY : TWO,THREE,FIVE + USE COMPLEX_NUMBERS, ONLY : ONEC,IC + USE PI_ETC, ONLY : PI + USE SQUARE_ROOTS, ONLY : SQR2 + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS + REAL (WP), INTENT(IN) :: OM12,OM22 +! + REAL (WP) :: U,Q_SI,OM,OMP + REAL (WP) :: A,NUM,DEN +! + REAL (WP) :: SQRT +! + COMPLEX (WP) :: PEEL +! + Q_SI = TWO * X * KF_SI ! q in SI + U = X * Z ! omega / (q * v_F) + OM = U * Q_SI * VF_SI ! omega in SI + OMP = ENE_P_SI / H_BAR ! omega_p +! + A = SQR2 * RS**0.75E0_WP * ZION / THREE**1.25E0_WP ! ref. (1) eq. (11) +! + NUM = A * OMP * OMP * SQRT(OMP * OM) ! + DEN = OM22 - OM12 ! +! + PEEL = NUM * (ONEC + IC) / DEN ! ref. (1) eq. (12) +! + END FUNCTION PEEL +! +!======================================================================= +! + FUNCTION PE76(X,Z,RS,OM12,OM22) +! +! This function computes the Perel'-Eliashberg dynamic Nevalinna function +! +! +! References: (1) Yu. V. Arkhipov et al, Phys. Rev. E 76, 026403 (2007) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * OM12 : omega_1^2 \ characteristic squared +! * OM22 : omega_2^2 / frequencies +! +! +! Author : D. Sébilleau +! +! Last modified : 18 Nov 2020 +! +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS + REAL (WP), INTENT(IN) :: OM12,OM22 +! + COMPLEX (WP) :: PE76 +! + PE76 = PEEL(X,Z,RS,OM12,OM22) + STA3(X,OM12,OM22) ! +! + END FUNCTION PE76 +! +!======================================================================= +! + FUNCTION CPP1(X,Z,RS,OM12,OM22) +! +! This function computes the Perel'-Eliashberg dynamic Nevalinna function +! +! +! References: (1) Yu. V. Arkhipov et al, Contrib. Plasma Phys. 53, +! 375-384 (2013) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * OM12 : omega_1^2 \ characteristic squared +! * OM22 : omega_2^2 / frequencies +! +! +! Author : D. Sébilleau +! +! Last modified : 24 Nov 2020 +! +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS + REAL (WP), INTENT(IN) :: OM12,OM22 +! + COMPLEX (WP) :: CPP1 +! + CPP1 = PEEL(X,Z,RS,OM12,OM22) + STA1(OM12,OM22) ! +! + END FUNCTION CPP1 +! +!======================================================================= +! + FUNCTION CPP2(X,Z,RS,TAU,OM12,OM22) +! +! This function computes the Perel'-Eliashberg dynamic Nevalinna function +! +! +! References: (1) Yu. V. Arkhipov et al, Contrib. Plasma Phys. 53, +! 375-384 (2013) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * TAU : relaxation time (in SI) +! * OM12 : omega_1^2 \ characteristic squared +! * OM22 : omega_2^2 / frequencies +! +! +! Author : D. Sébilleau +! +! Last modified : 18 Nov 2020 +! +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,TAU + REAL (WP), INTENT(IN) :: OM12,OM22 +! + COMPLEX (WP) :: CPP2 +! + CPP2 = PEEL(X,Z,RS,OM12,OM22) + STA2(OM22,TAU) ! +! + END FUNCTION CPP2 +! +!======================================================================= +! + FUNCTION CPP3(X,Z,OM22,TAU) +! +! This function computes a dynamic Nevalinna function +! +! +! References: (1) D. Ballester and I. M. Tkachenko, +! Contrib. Plasma Phys. 45, 293-299 (2005) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * OM22 : omega_2^2 characteristic squared frequency +! * TAU : relaxation time (in SI) +! +! +! Author : D. Sébilleau +! +! Last modified : 18 Nov 2020 +! + USE REAL_NUMBERS, ONLY : TWO + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,OM22,TAU +! + REAL (WP) :: U,Q_SI,OM + REAL (WP) :: OMP + REAL (WP) :: ZETA,NUM +! + COMPLEX (WP) :: CPP3 + COMPLEX (WP) :: DEN +! + ZETA = 0.27E0_WP ! +! + Q_SI = TWO * X * KF_SI ! q in SI + U = X * Z ! omega / (q * v_F) + OM = U * Q_SI * VF_SI ! omega in SI +! + OMP = ENE_P_SI / H_BAR ! omega_p +! + NUM = - ZETA * OMP * OM22 * TAU ! + DEN = OM + IC * ZETA * OMP ! +! + CPP3 = NUM / DEN ! ref. (1) eq. (16) +! + END FUNCTION CPP3 +! +!======================================================================= +! + FUNCTION CPP4(X,Z,T,OM12,OM22) +! +! This function computes a dynamic Nevalinna function +! +! +! References: (1) Yu. V. Arkhipov et al, Contrib. Plasma Phys. 58, +! 967–975 (2018) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * T : temperature in SI +! * OM12 : omega_1^2 \ characteristic squared +! * OM22 : omega_2^2 / frequencies +! +! +! Author : D. Sébilleau +! +! Last modified : 18 Nov 2020 +! + USE REAL_NUMBERS, ONLY : ONE + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI_INV +! + USE CHEMICAL_POTENTIAL, ONLY : MU_T + USE SPECIFIC_INT_9 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,T,OM12,OM22 +! + REAL (WP) :: U + REAL (WP) :: ALPHA + REAL (WP) :: KBT,D,ETA + REAL (WP) :: INTG,XI +! + COMPLEX (WP) :: CPP4 +! + U = X * Z ! omega / (q * v_F) +! + ALPHA = 0.99E0_WP ! +! + KBT = K_B * T ! +! + D = EF_SI / KBT ! degeneracy + ETA = MU_T('3D',T) / KBT ! +! +! Computing the integral Xi(U) +! + CALL INT_XIZ(U,D,ETA,INTG) ! + XI = PI_INV * INTG ! +! + CPP4 = STA1(OM12,OM22) / ( & ! + ALPHA + IC * (ALPHA - ONE) * XI & ! ref. (1) eq. (23) + ) ! +! + END FUNCTION CPP4 +! +!======================================================================= +! + FUNCTION PST1(X,Z,OM12,OM22) +! +! This function computes a dynamic Nevalinna function +! +! +! References: (1) I. M. Tkachenko, Phys. Sciences and Tech. 5, 16-35 (2016) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * OM12 : omega_1^2 \ characteristic squared +! * OM22 : omega_2^2 / frequencies +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Nov 2020 +! + USE REAL_NUMBERS, ONLY : TWO,TENTH,TTINY + USE COMPLEX_NUMBERS, ONLY : IC + USE PI_ETC, ONLY : SQR_PI,PI + USE CONSTANTS_P1, ONLY : H_BAR + USE EXT_FUNCTIONS, ONLY : DAWSON + USE MINMAX_VALUES +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,OM12,OM22 +! + REAL (WP) :: U,U2 + REAL (WP) :: MAX_EXP,MIN_EXP + REAL (WP) :: EXPO +! + REAL (WP) :: EXP +! + COMPLEX (WP) :: PST1 + COMPLEX (WP) :: ZF +! +! Computing the max and min value of the exponent of e^x +! + CALL MINMAX_EXP(MAX_EXP,MIN_EXP) ! +! + U = X * Z ! omega / (q * v_F) + U2 = U * U ! +! + IF(U2 > TENTH * MAX_EXP) THEN ! + EXPO = TTINY ! + ELSE ! + EXPO = EXP(- U2) ! + END IF ! +! + ZF = IC * SQR_PI * EXPO - TWO * DAWSON(U) ! +! + PST1 = OM22 * ZF / SQRT(TWO * PI * OM12) ! ref. (1) eq. (57a) +! + END FUNCTION PST1 +! +END MODULE NEVALINNA_FUNCTIONS diff --git a/New_libraries/DFM_library/PAIR_CORRELATION_LIBRARY/PhysRevB.64.155102.pdf b/New_libraries/DFM_library/PAIR_CORRELATION_LIBRARY/PhysRevB.64.155102.pdf new file mode 100644 index 0000000..c05ede5 Binary files /dev/null and b/New_libraries/DFM_library/PAIR_CORRELATION_LIBRARY/PhysRevB.64.155102.pdf differ diff --git a/New_libraries/DFM_library/PAIR_CORRELATION_LIBRARY/pair_correlation.f90 b/New_libraries/DFM_library/PAIR_CORRELATION_LIBRARY/pair_correlation.f90 new file mode 100644 index 0000000..dfef78b --- /dev/null +++ b/New_libraries/DFM_library/PAIR_CORRELATION_LIBRARY/pair_correlation.f90 @@ -0,0 +1,519 @@ +! +!======================================================================= +! +MODULE PAIR_CORRELATION +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE PAIR_CORRELATION_3D(R,RS,T,GR_TYPE,RH_TYPE,GR) +! +! This subroutine computes the pair correlation function g(r) +! for 3D systems. +! +! +! Input parameters: +! +! * R : grid point (in units of a_0) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * GR_TYPE : structure factor approximation (3D) +! GR_TYPE = 'CDF' from chain diagram formula of PDF (long distance) +! GR_TYPE = 'DHA' Debye-Hückel approximation +! GR_TYPE = 'DWA' DeWitt approximation +! GR_TYPE = 'FBA' Frieman-Book approximation +! GR_TYPE = 'HFA' Hartree-Fock approximation (only exchange) +! GR_TYPE = 'HUB' Hubbard approximation +! GR_TYPE = 'LLA' Lee-Long approximation +! GR_TYPE = 'ORB' Ortiz-Ballone approximation +! GR_TYPE = 'PDF' from pair distribution function +! GR_TYPE = 'SHA' Shaw approximation +! GR_TYPE = 'WIG' Wigner approximation +! * RH_TYPE : choice of pair distribution function rho_2(r) (3D) +! +! Output parameters: +! +! * GR : value of the pair correlation function +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE FERMI_AU, ONLY : KF_AU + USE PI_ETC, ONLY : PI2 + USE UTILITIES_1, ONLY : RS_TO_N0 + USE PAIR_DISTRIBUTION +! + IMPLICIT NONE +! + REAL (WP) :: R,RS,T,GR,R2,HFA,I2 + REAL (WP) :: N0 +! + CHARACTER (LEN = 3) :: GR_TYPE,RH_TYPE +! + N0=RS_TO_N0('3D',RS) ! +! + IF(GR_TYPE == 'DHA') THEN ! + GR = DHA_PCF(R,RS,T) ! + ELSE IF(GR_TYPE == 'DWA') THEN ! + GR = DWA_PCF(R,RS,T) ! + ELSE IF(GR_TYPE == 'FBA') THEN ! + GR = FBA_PCF(R,RS,T) ! + ELSE IF(GR_TYPE == 'HFA') THEN ! + GR = HFA_PCF(R) ! + ELSE IF(GR_TYPE == 'HUB') THEN ! + GR = HUB_PCF(R) ! + ELSE IF(GR_TYPE == 'LLA') THEN ! + GR = LLA_PCF(R) ! + ELSE IF(GR_TYPE == 'SHA') THEN ! + GR = SHA_PCF(R) ! + ELSE IF(GR_TYPE == 'ORB') THEN ! + GR = ORB_PCF(R) ! + ELSE IF(GR_TYPE == 'PDF') THEN ! + CALL PAIR_DISTRIBUTION_3D(R,RS,T,RH_TYPE,R2) ! + GR = R2 / (N0 * N0) ! + ELSE IF(GR_TYPE == 'CDF') THEN ! + CALL PAIR_DISTRIBUTION_3D(R,RS,T,RH_TYPE,R2) ! + HFA = HFA_PCF(R) ! + I2 = (ONE-HFA)*KF_AU*KF_AU*KF_AU/(18.0E0_WP*PI2*PI2) ! ref. (1) RH_TYPE + GR = (R2-N0*N0+I2)/(N0*N0) ! eq. (4.1.1) + ELSE IF(GR_TYPE == 'WIG') THEN ! + GR = WIG_PCF(R) ! + END IF ! +! + END SUBROUTINE PAIR_CORRELATION_3D +! +!======================================================================= +! + FUNCTION DHA_PCF(R,RS,T) +! +! This function computes Debye-Hückel pair correlation function g(r) +! for 3D systems +! +! References: (1) H. E. DeWitt, Phys. Rev. 140, A466-A470 (1965) +! +! Input parameters: +! +! * R : grid point in unit of a_0 +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE CONSTANTS_P1, ONLY : BOHR,E,COULOMB,K_B + USE SCREENING_VEC, ONLY : DEBYE_VECTOR +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: R,RS,T + REAL (WP) :: DHA_PCF + REAL (WP) :: BETA,KD_AU,X,US + REAL (WP) :: KD_SI +! + REAL (WP) :: EXP +! +! Computing the Debye momentum +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + BETA = ONE / K_B * T ! + KD_AU = KD_SI * BOHR ! + X = R * KD_AU ! + US = COULOMB * E * E * EXP(- X) / R ! +! + DHA_PCF = ONE - BETA * US ! ref. (1) eq. (1) +! + END FUNCTION DHA_PCF +! +!======================================================================= +! + FUNCTION DWA_PCF(R,RS,T) +! +! This function computes DeWitt pair correlation function g(r) +! for 3D systems +! +! References: (1) H. E. DeWitt, Phys. Rev. 140, A466-A470 (1965) +! +! Input parameters: +! +! * R : grid point in unit of a_0 +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 13 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,EIGHT, & + HALF,THIRD + USE CONSTANTS_P1, ONLY : BOHR,E,COULOMB,K_B + USE EULER_CONST, ONLY : EUMAS + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE EXT_FUNCTIONS, ONLY : DEI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: R,RS,T + REAL (WP) :: DWA_PCF + REAL (WP) :: BETA,KD_AU,X,US + REAL (WP) :: G2B,G22B,G22C,GAMMA,GAM + REAL (WP) :: KD_SI +! + REAL (WP) :: EXP,SINH,LOG +! +! Computing the Debye momentum +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + BETA = ONE / K_B * T ! + KD_AU = KD_SI * BOHR ! + X = R * KD_AU ! + US = COULOMB * E * E * DEXP(- X) / R ! + GAMMA = BETA * COULOMB * E * E * KD_SI ! + GAM = EUMAS +! + IF(X < ONE) THEN ! + G22B = - GAMMA * GAMMA * SINH(X) * LOG(THIRD / (GAM*X)) / X ! --> eq. (23) + G22C = HALF * GAMMA * GAMMA * (HALF * THIRD + & ! --> eq. (27) + X / (EIGHT * LOG(ONE / (THREE * GAM * X)))) ! + ELSE + G22B = - HALF * GAMMA * GAMMA * (LOG(THREE) * EXP(-X) / X & ! --> eq. (24) + - TWO * THIRD* EXP(- TWO * X) / (X * X)) ! + G22C = HALF * GAMMA * GAMMA / (FOUR * X) * ( & ! + (ONE + X) * EXP(- X) * LOG(THREE) - & ! + FOUR * THIRD * (EXP(- X) - EXP(- TWO * X)) + & ! --> eq. (26) + (ONE + X) * EXP(- X) * DEI(- X) - & ! + (ONE - X) * EXP(X) * DEI(- THREE * X) & ! + ) ! + ENDIF ! +! + G2B = G22B ! +! + DWA_PCF = EXP(- BETA * US) * (ONE + G2B + G22C) ! ref. (1) eq. (29) +! + END FUNCTION DWA_PCF +! +!======================================================================= +! + FUNCTION FBA_PCF(R,RS,T) +! +! This function computes Frieman-Book pair correlation function g(r) +! for 3D systems +! +! References: (1) H. E. DeWitt, Phys. Rev. 140, A466-A470 (1965) +! +! Input parameters: +! +! * R : grid point in unit of a_0 +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE CONSTANTS_P1, ONLY : BOHR,E,COULOMB,K_B + USE SCREENING_VEC, ONLY : DEBYE_VECTOR +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: R,RS,T + REAL (WP) :: FBA_PCF + REAL (WP) :: BETA,KD_AU,X,US + REAL (WP) :: KD_SI +! + REAL (WP) :: EXP +! +! Computing the Debye momentum +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + BETA = ONE / K_B * T ! + KD_AU = KD_SI * BOHR ! + X = R * KD_AU ! + US = COULOMB * E * E * EXP(- X) / R ! +! + FBA_PCF = EXP(- BETA * US) ! ref. (1) eq. (4) +! + END FUNCTION FBA_PCF +! +!======================================================================= +! + FUNCTION HFA_PCF(R) +! +! This function computes Hartree-Fock pair correlation function g(r) +! for 3D systems +! +! References: (1) F. Brouers, Phys. Stat. Sol. 19, 867-871 (1967) +! +! Input parameters: +! +! * R : grid point in unit of a_0 +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE FERMI_AU, ONLY : KF_AU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: R + REAL (WP) :: HFA_PCF + REAL (WP) :: KR1,KR3 +! + REAL (WP) :: SIN,COS +! + KR1 = KF_AU * R ! + KR3 = KR1 * KR1 * KR1 ! +! + HFA_PCF = ONE - 4.5E0_WP * ( (SIN(KR1) - KR1 * COS(KR1)) / & ! + KR3 )**2 ! ref. (1) eq. (5) +! + END FUNCTION HFA_PCF +! +!======================================================================= +! + FUNCTION HUB_PCF(R) +! +! This function computes Shaw pair correlation function g(r) +! for 3D systems +! +! References: (1) R. W. Shaw, J. Phys. C: Solid State Phys. 3, +! 1140-1158 (1970) +! +! Input parameters: +! +! * R : grid point in unit of a_0 +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,HALF + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: R + REAL (WP) :: HUB_PCF + REAL (WP) :: AL2,AL +! + REAL (WP) :: SQRT,EXP +! + AL2 = FOUR / SQRT(THREE * PI) ! + AL = SQRT(AL2) ! +! + HUB_PCF = ONE - HALF * (ONE + AL * R) * EXP(- AL * R) ! ref. (1) eq. (5.2) +! + END FUNCTION HUB_PCF +! +!======================================================================= +! + FUNCTION LLA_PCF(R) +! +! This function computes Lee-Long pair correlation function g(r) +! for 3D systems +! +! References: (1) H. Lee and M. Long, Phys. Rev. B 52, 189-195 (1995) +! +! Input parameters: +! +! * R : grid point in unit of a_0 +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THREE,HALF + USE FERMI_AU, ONLY : KF_AU +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: R + REAL (WP) :: LLA_PCF + REAL (WP) :: X,X2 + REAL (WP) :: J1 +! + REAL (WP) :: SQRT,SIN,COS +! + X = KF_AU * R ! + X2 = X * X ! +! +! Computation of the Bessel function: +! +! J_{3/2}(x) = sqrt(2x/pi} j_1(x) +! + J1 = SIN(X) / X2 - COS(X) / X ! j_1(x) +! + LLA_PCF = ONE - HALF * (THREE * J1 / X)**2 ! ref. 1 eq. (11) +! + END FUNCTION LLA_PCF +! +!======================================================================= +! + FUNCTION ORB_PCF(R) +! +! This function computes Ortiz-Ballone parametrization of the +! pair correlation function g(r) for 3D systems +! +! References: (1) G. Ortiz and P. Ballone, Phys. Rev. B 50, +! 1391-1405 (1994) +! +! Input parameters: +! +! * R : grid point in unit of a_0 +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Sep 2020 +! +! + USE MATERIAL_PROP, ONLY : RS + USE REAL_NUMBERS, ONLY : ONE + USE INTERPOLATION, ONLY : LAG_4P_INTERP +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: R + REAL (WP) :: ORB_PCF + REAL (WP) :: U,U2,U3,U4,U5 + REAL (WP) :: AA,BB,CC,DD,EE,FF + REAL (WP) :: NNU + REAL (WP) :: A(4),B(4),C(4),D(4),E(4),F(4) + REAL (WP) :: NU(4),X(4) +! + REAL (WP) :: EXP +! + DATA X / 1.0000E0_WP, 3.0000E0_WP, 5.0000E0_WP, 10.0000E0_WP / ! + DATA A / -1.0000E0_WP, -1.0000E0_WP, -1.0000E0_WP, -1.0000E0_WP / ! + DATA B / 0.0000E0_WP, 0.0000E0_WP, 0.0000E0_WP, 0.0000E0_WP / ! ref. (1) + DATA C / 1.0567E0_WP, 0.7512E0_WP, 0.6293E0_WP, 0.5442E0_WP / ! table IX: + DATA D / -0.8804E0_WP, -0.3827E0_WP, -0.2161E0_WP, -0.1142E0_WP / ! + DATA E / 0.3029E0_WP, 0.0711E0_WP, 0.0064E0_WP, -0.0313E0_WP / ! case ++ + DATA F / -0.0383E0_WP, -0.0047E0_WP, 0.0026E0_WP, 0.0068E0_WP / ! + DATA NU / 0.3808E0_WP, 0.2177E0_WP, 0.1587E0_WP, 0.1711E0_WP / ! +! + U = R / RS ! + U2 = U * U ! + U3 = U2 * U ! + U4 = U3 * U ! + U5 = U4 * U ! +! +! Calculation the coefficients for the excat RS +! + AA = LAG_4P_INTERP(X,A,RS) ! + BB = LAG_4P_INTERP(X,B,RS) ! + CC = LAG_4P_INTERP(X,C,RS) ! + DD = LAG_4P_INTERP(X,D,RS) ! + EE = LAG_4P_INTERP(X,E,RS) ! + FF = LAG_4P_INTERP(X,F,RS) ! + NNU = LAG_4P_INTERP(X,NU,RS) ! +! + ORB_PCF = ONE + ( AA + BB * U + CC * U2 + DD * U3 + & ! Ref. (1) eq. 36) + EE * U4 + FF * U5 ) * EXP(- NNU * U2) ! +! + END FUNCTION ORB_PCF +! +!======================================================================= +! + FUNCTION SHA_PCF(R) +! +! This function computes Shaw pair correlation function g(r) +! for 3D systems +! +! References: (1) R. W. Shaw, J. Phys. C: Solid State Phys. 3, +! 1140-1158 (1970) +! +! Input parameters: +! +! * R : grid point in unit of a_0 +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,NINE,THIRD + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: R + REAL (WP) :: SHA_PCF + REAL (WP) :: AL2,R2 +! + REAL (WP) :: EXP +! + R2 = R * R ! +! + AL2 = ONE / (NINE * PI)**THIRD ! +! + SHA_PCF = ONE - EXP(- AL2 * R2) ! ref. (1) eq. (5.5) +! + END FUNCTION SHA_PCF +! +!======================================================================= +! + FUNCTION WIG_PCF(R) +! +! This function computes Wigner pair correlation function g(r) +! for 3D systems +! +! References: (1) E. Wigner, Phys. Rev. 46, 1002-1011 (1934) +! +! Input parameters: +! +! * R : grid point in unit of a_0 +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Sep 2020 +! +! + USE MATERIAL_PROP, ONLY : RS + USE REAL_NUMBERS, ONLY : ONE + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: R + REAL (WP) :: WIG_PCF + REAL (WP) :: DD,ROD +! + REAL (WP) :: EXP +! + DD = ALFA('3D') * RS ! ref. (1) eq. (6) +! + ROD = R / DD ! +! + WIG_PCF = ONE - EXP(-1.6E0_WP * ROD) * & ! + ( ONE + 1.6E0_WP * ROD + 1.2E0_WP * ROD * ROD ) ! ref. (1) eq. (8) +! + END FUNCTION WIG_PCF +! +END MODULE PAIR_CORRELATION diff --git a/New_libraries/DFM_library/PAIR_DISTRIBUTION_FUNCTION/pair_distribution.f90 b/New_libraries/DFM_library/PAIR_DISTRIBUTION_FUNCTION/pair_distribution.f90 new file mode 100644 index 0000000..3c0e688 --- /dev/null +++ b/New_libraries/DFM_library/PAIR_DISTRIBUTION_FUNCTION/pair_distribution.f90 @@ -0,0 +1,392 @@ +! +!======================================================================= +! +MODULE PAIR_DISTRIBUTION +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE PAIR_DISTRIBUTION_3D(R,RS,T,RH_TYPE,R2) +! +! This subroutine computes the pair distribution function rho2(r) +! for 3D systems. +! +! +! Input parameters: +! +! * R : grid point (in units of a_0) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * RH_TYPE : pair distribution function approximation (3D) +! RH_TYPE = 'CDI' chain diagram improved +! RH_TYPE = 'CEG' classical electron gas +! RH_TYPE = 'DEB' Debye electron gas +! RH_TYPE = 'FUA' correct to order 2 in epsilon +! RH_TYPE = 'SDC' short-distance correlations +! RH_TYPE = 'WDA' watermelon diagrams summed +! +! Output parameters: +! +! * R2 : value of the pair correlation function +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: RH_TYPE +! + REAL (WP) :: R,RS,T,R2 +! + IF(RH_TYPE == 'CDI') THEN ! + R2=CDI_PDF(R,RS,T) ! + ELSE IF(RH_TYPE == 'CEG') THEN ! + R2=CEG_PDF(R,RS,T) ! + ELSE IF(RH_TYPE == 'DEB') THEN ! + R2=DEB_PDF(R,RS,T) ! + ELSE IF(RH_TYPE == 'FUA') THEN ! + R2=FUA_PDF(R,RS,T) ! + ELSE IF(RH_TYPE == 'SDC') THEN ! + R2=SDC_PDF(R,RS,T) ! + ELSE IF(RH_TYPE == 'WDA') THEN ! + R2=WDA_PDF(R,RS,T) ! + ENDIF ! +! + END SUBROUTINE PAIR_DISTRIBUTION_3D +! +!======================================================================= +! + FUNCTION CDI_PDF(R,RS,T) +! +! This function computes the electron gas pair distribution function +! rho2(r) for 3D systems, with a chain diagram improved +! +! References: (1) A. Isihara, "Electron Liquids", 2nd edition, +! Springer Series in Solid-State Sciences 96, +! (Springer, 1998) p. 33 +! +! Input parameters: +! +! * R : grid point in unit of a_0 +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 2 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE CONSTANTS_P1, ONLY : BOHR,E,K_B + USE SQUARE_ROOTS, ONLY : SQR2 + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE UTILITIES_1, ONLY : RS_TO_N0 + USE EXT_FUNCTIONS, ONLY : ERFC ! Error function +! + IMPLICIT NONE +! + REAL (WP) :: R,RS,T + REAL (WP) :: CDI_PDF + REAL (WP) :: X,EPS,ALP,BETA + REAL (WP) :: N0,KD_SI +! + REAL (WP) :: DSQRT,DEXP +! + N0=RS_TO_N0('3D',RS) ! +! +! Computing the Debye screening vector +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + X=KD_SI*R*BOHR ! + EPS=E*E*KD_SI/(K_B*T) ! ref. (1) eq. (1.1.2) + BETA=ONE/(K_B*T) ! + ALP=KD_SI*DSQRT(BETA) ! +! + CDI_PDF=N0*N0*( ONE -EPS*( & ! + DEXP(-X)/X - & ! + DEXP(-X/(TWO*ALP))/X + & ! ref. (1) eq. (3.3.14) + SQR2*ERFC(X/(SQR2*ALP))/ALP & ! + ) & ! + ) ! +! + END FUNCTION CDI_PDF +! +!======================================================================= +! + FUNCTION CEG_PDF(R,RS,T) +! +! This function computes very dilute classical electron gas +! pair distribution function rho2(r) for 3D systems +! +! References: (1) A. Isihara, "Electron Liquids", 2nd edition, +! Springer Series in Solid-State Sciences 96, +! (Springer, 1998) p. 33 +! +! Input parameters: +! +! * R : grid point in unit of a_0 +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Jul 2020 +! +! + USE CONSTANTS_P1, ONLY : BOHR,E,K_B + USE UTILITIES_1, ONLY : RS_TO_N0 +! + IMPLICIT NONE +! + REAL (WP) :: R,RS,T + REAL (WP) :: CEG_PDF + REAL (WP) :: N0 +! + REAL (WP) :: DEXP +! + N0=RS_TO_N0('3D',RS) ! +! + CEG_PDF=N0*N0*DEXP(-E*E/(R*BOHR*K_B*T)) ! ref. (1) eq. (3.1.1) +! + END FUNCTION CEG_PDF +! +!======================================================================= +! + FUNCTION DEB_PDF(R,RS,T) +! +! This function computes Debye electron gas +! pair distribution function rho2(r) for 3D systems +! +! References: (1) A. Isihara, "Electron Liquids", 2nd edition, +! Springer Series in Solid-State Sciences 96, +! (Springer, 1998) p. 33 +! +! Input parameters: +! +! * R : grid point in unit of a_0 +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : FOUR + USE CONSTANTS_P1, ONLY : BOHR + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE SCREENING_VEC, ONLY : DEBYE_VECTOR +! + IMPLICIT NONE +! + REAL (WP) :: R,RS,T + REAL (WP) :: DEB_PDF + REAL (WP) :: RA + REAL (WP) :: N0,KD_SI +! + REAL (WP) :: DEXP +! + N0=RS_TO_N0('3D',RS) ! +! +! Computing the Debye screening vector +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + RA=R*BOHR ! r in SI +! + DEB_PDF=N0*N0 - N0*KD_SI*KD_SI*DEXP(-KD_SI*RA)/(FOUR*PI*RA) ! ref. (1) eq. (3.1.4) +! + END FUNCTION DEB_PDF +! +!======================================================================= +! + FUNCTION FUA_PDF(R,RS,T) +! +! This function computes the electron gas pair distribution function +! rho2(r) for 3D systems, correct to order 2 in epsilon, the plasma +! parameter +! +! References: (1) A. Isihara, "Electron Liquids", 2nd edition, +!C (Springer, 1998) p. 33 +! +! Input parameters: +! +! * R : grid point in unit of a_0 +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 21 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,THREE,HALF,THIRD,FOURTH + USE CONSTANTS_P1, ONLY : BOHR,E,K_B + USE UTILITIES_1, ONLY : RS_TO_N0 + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE EXT_FUNCTIONS, ONLY : DEI +! + IMPLICIT NONE +! + REAL (WP) :: R,RS,T + REAL (WP) :: FUA_PDF + REAL (WP) :: ARG_E + REAL (WP) :: X,EPS,TX + REAL (WP) :: N0,KD_SI +! + REAL (WP) :: DEXP,DLOG +! + N0=RS_TO_N0('3D',RS) ! +! +! Computing the Debye screening vector +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + X=KD_SI*R*BOHR ! + EPS=E*E*KD_SI/(K_B*T) ! ref. (1) eq. (1.1.2) + TX=THREE*X ! +! + ARG_E=EPS*DEXP(-X)/X + HALF*EPS*EPS/X * ( & ! + DEXP(-X)*( -THREE*FOURTH*DLOG(THREE) + & ! + X*FOURTH*DLOG(THREE) - THIRD ) + & ! + FOURTH*DEXP(X)*(X*DEI(-TX)) + & ! ref. (1) eq. (3.1.13) + FOURTH*DEXP(-X)*(X*DEI(-X)) + & ! + THREE*FOURTH*DEXP(X)*DEI(-TX)- & ! + THREE*FOURTH*DEXP(-X)*DEI(-X)+ & ! + THIRD*DEXP(-TWO*X) ) ! +! + FUA_PDF=N0*N0*DEXP(-ARG_E) ! ref. (1) eq. (3.1.12) +! + END FUNCTION FUA_PDF +! +!======================================================================= +! + FUNCTION SDC_PDF(R,RS,T) +! +! This function computes the electron gas pair distribution function +! rho2(r) for 3D systems, for short-distance correlations +! +! +! --> Warning: valid if T >> k_B * (a_0 / 2)^2 +! +! +! References: (1) A. Isihara, "Electron Liquids", 2nd edition, +! Springer Series in Solid-State Sciences 96, +! (Springer, 1998) p. 33 +! +! Input parameters: +! +! * R : grid point (in units of a_0) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF,THIRD + USE CONSTANTS_P1, ONLY : BOHR,K_B + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE SCREENING_VEC, ONLY : DEBYE_VECTOR +! + IMPLICIT NONE +! + REAL (WP) :: R,RS,T + REAL (WP) :: R2,R3 + REAL (WP) :: SDC_PDF + REAL (WP) :: BETA,DELTA + REAL (WP) :: N0,KD_SI +! + REAL (WP) :: DSQRT +! + R2=R*R*BOHR*BOHR ! r^2 in SI + R3=R2*R*BOHR ! r^3 in SI +! + N0=RS_TO_N0('3D',RS) ! +! +! Computing the Debye screening vector +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + BETA=ONE/(K_B*T) ! + DELTA=TWO*DSQRT(BETA)/BOHR ! ref. (1) eq. (3.3.7) +! + SDC_PDF=HALF*N0*N0*( & ! + ONE - DSQRT(HALF*PI)*DELTA + & ! + HALF*R + HALF*R2/BETA - & ! + TWO*THIRD*DSQRT(HALF*PI)*R2 / ( & ! ref. (1) eq. (3.3.10) + BOHR*DSQRT(BETA) ) - & ! + HALF*R3/(BOHR*BETA) & ! + ) ! +! + END FUNCTION SDC_PDF +! +!======================================================================= +! + FUNCTION WDA_PDF(R,RS,T) +! +! This function computes watermelon diagrams-summed electron gas +! pair distribution function rho2(r) for 3D systems +! +! References: (1) A. Isihara, "Electron Liquids", 2nd edition, +! Springer Series in Solid-State Sciences 96, +! (Springer, 1998) p. 33 +! +! Input parameters: +! +! * R : grid point in unit of a_0 +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE CONSTANTS_P1, ONLY : BOHR,E,K_B + USE UTILITIES_1, ONLY : RS_TO_N0 + USE SCREENING_VEC, ONLY : DEBYE_VECTOR +! + IMPLICIT NONE +! + REAL (WP) :: R,RS,T + REAL (WP) :: WDA_PDF + REAL (WP) :: PHI_D,RA + REAL (WP) :: N0,KD_SI +! + REAL (WP) :: DSQRT +! + N0=RS_TO_N0('3D',RS) ! +! +! Computing the Debye screening vector +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + RA=R*BOHR ! r in SI +! + PHI_D=E*E*DEXP(-KD_SI*RA)/RA ! ref. (1) eq. (3.1.7) +! + WDA_PDF=N0*N0*DEXP(-PHI_D/(K_B*T)) ! ref. (1) eq. (3.1.5) +! + END FUNCTION WDA_PDF +! +END MODULE PAIR_DISTRIBUTION + diff --git a/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/Fermi_values.f90 b/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/Fermi_values.f90 new file mode 100644 index 0000000..7947c2d --- /dev/null +++ b/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/Fermi_values.f90 @@ -0,0 +1,70 @@ +! +!======================================================================= +! +MODULE FERMI_SI +! +! This module defines the Fermi level physical quantities +! +! +! --> SI version <-- +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: KF_SI,EF_SI,VF_SI,TF_SI,NF_SI +! +END MODULE FERMI_SI +! +!======================================================================= +! +MODULE FERMI_SI_M +! +! This module defines the Fermi level physical quantities +! in the presence of an external magnetic field +! +! +! --> SI version <-- +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: KF_SI_M,EF_SI_M,VF_SI_M,TF_SI_M +! +END MODULE FERMI_SI_M +! +!======================================================================= +! +MODULE FERMI_AU +! +! This module defines the Fermi level physical quantities +! +! +! --> AU version <-- +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: KF_AU,EF_AU,VF_AU +! +END MODULE FERMI_AU +! +!======================================================================= +! +MODULE FERMI_AU_M +! +! This module defines the Fermi level physical quantities +! in the presence of an external magnetic field +! +! +! --> AU version <-- +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: KF_AU_M,EF_AU_M,VF_AU_M +! +END MODULE FERMI_AU_M diff --git a/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/calc_Fermi.f90 b/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/calc_Fermi.f90 new file mode 100644 index 0000000..3eb8a59 --- /dev/null +++ b/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/calc_Fermi.f90 @@ -0,0 +1,345 @@ +! +!======================================================================= +! +MODULE FERMI_VALUES +! +! This module computes the Fermi level physical quantities +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_FERMI(DMN,RS) +! +! This subroutine computes Fermi level quantities +! +! +! * DMN : dimension +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Jul 2020 +! + USE REAL_NUMBERS, ONLY : ONE + USE ENE_CHANGE, ONLY : EV,RYD + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,M_E,K_B + USE REAL_NUMBERS, ONLY : TWO,HALF + USE PI_ETC, ONLY : PI,PI2 + USE UTILITIES_1, ONLY : ALFA +! + USE FERMI_SI + USE FERMI_AU +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP), INTENT(IN) :: RS + REAL (WP) :: KF,EF + REAL (WP) :: NUM,DEN +! + KF = ONE / (ALFA(DMN) * RS) ! a_0 * k_F + EF = KF * KF * RYD ! Fermi energy in eV +! + KF_SI = KF / BOHR ! Fermi momentum in 1/m + EF_SI = EF * EV ! Fermi energy in J + VF_SI = H_BAR * KF_SI / M_E ! Fermi velocity in m/s + TF_SI = EF_SI / K_B ! Fermi temperature in K +! +! Computation of n(E_F) +! + IF(DMN == '3D') THEN ! + NUM = M_E * KF_SI ! + DEN = H_BAR * H_BAR * PI2 ! + ELSE IF(DMN == '2D') THEN ! + NUM = M_E ! + DEN = H_BAR * H_BAR * PI ! + ELSE IF(DMN == '1D') THEN ! + NUM = TWO * M_E ! + DEN = H_BAR *H_BAR * PI * KF_SI ! + END IF ! + NF_SI = NUM / DEN ! +! + KF_AU = KF ! Fermi momentum in AU + EF_AU = HALF * KF * KF ! Fermi energy in AU + VF_AU = KF ! Fermi velocity in AU +! + END SUBROUTINE CALC_FERMI +! +!======================================================================= +! +END MODULE FERMI_VALUES +! +!======================================================================= +! +MODULE FERMI_VALUES_M +! +! This module computes the Fermi level physical quantities +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_FERMI_M(DMN,RS) +! +! This subroutine computes Fermi level quantities +! in the presence of an external magnetic field +! +! +! * DMN : dimension +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 22 Jun 2020 +! + USE EXT_FIELDS, ONLY : T,H + USE REAL_NUMBERS, ONLY : HALF + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,M_E,K_B + USE CONSTANTS_P3, ONLY : MU_B +! + USE FERMI_SI_M + USE FERMI_AU_M +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP) :: RS + REAL (WP) :: A +! + A=MU_B*H ! --> check B or H +! +! Computing k_F in AU +! + IF(DMN == '3D') THEN ! + KF_AU_M=KF_M_3D(RS,T,A) ! + ELSE IF(DMN == '2D') THEN ! + KF_AU_M=KF_M_2D(RS,T,A) ! + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! + END IF ! +! + EF_AU_M=HALF*KF_AU_M*KF_AU_M ! + VF_AU_M=KF_AU_M ! +! + KF_SI_M=KF_AU_M/BOHR ! + EF_SI_M=HALF*H_BAR*H_BAR*KF_SI_M*KF_SI_M/M_E ! + VF_SI_M=H_BAR*KF_SI_M/M_E ! + TF_SI_M=EF_SI_M/K_B ! +! + END SUBROUTINE CALC_FERMI_M +! +!======================================================================= +! + FUNCTION KF_M_3D(RS,T,A) +! +! This function computes the temperature-dependent Fermi wave vector +! in the presence of an external magnetic field for 3D systems +! +! References: (7) A. Isihara and D. Y. Kojima, Phys. Rev. B 10, +! 4925-4931 (1974) +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! * A : sqrt(mu_B * B) : magnitude of the magnetic field +! +! +! Output parameters: +! +! * KF_M_3D : Fermi wave number in AU +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,FIVE,THIRD,FOURTH,SMALL + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_AU, ONLY : KF_AU + USE PI_ETC, ONLY : PI2 + USE G_FACTORS, ONLY : G_E +! + IMPLICIT NONE +! + REAL (WP) :: RS,T,A + REAL (WP) :: KF_M_3D + REAL (WP) :: BETA,ETA0,LNE0,KFT,KFM,RS2,LRS + REAL (WP) :: A4 + REAL (WP) :: KG1,KG2,KG3 +! + A4=A*A*A*A ! +! + BETA=ONE/(K_B*T) ! + ETA0=BETA*KF_AU*KF_AU ! + LNE0=DLOG(ETA0) ! +! + RS2=RS*RS ! + LRS=DLOG(RS) ! +! + KG1=FOURTH*G_E*G_E ! + KG2=KG1 - THIRD ! + KG3=KG1 - FIVE/18.0E0_WP ! +! +! No magnetic field contribution +! + KFT=KF_AU*(ONE - 0.16586E0_WP*RS + RS2*( & ! + 0.0084411E0_WP*LRS - 0.027620E0_WP ) - & ! + PI2/(24.0E0_WP*ETA0*ETA0)* ( & ! + ONE - 0.16586E0_WP*RS + RS2*( & ! + 0.20808E0_WP + 0.022197E0_WP*LRS - & ! ref. (7) eq. (5.1) + 0.00072406E0_WP*LNE0 - 0.027510E0_WP*LNE0*LNE0 & ! + ) & ! + ) & ! + ) ! +! +! Magnetic field contribution +! + KFM=-A4/(8.0E0_WP*KF_AU*KF_AU*KF_AU) * ( & ! + KG2 + 0.16586E0_WP*RS*KG3 + RS2 * ( & ! + 0.054782E0_WP*KG1 - 0.018387E0_WP + & ! + (0.033135E0_WP - 0.072955E0_WP*KG1)*LRS) + & ! + PI2/(24.0E0_WP*ETA0*ETA0)* ( & ! + 7.0E0_WP*KG2 + 0.16586E0_WP*(1.6462E0_WP-KG1)*RS + & ! + RS2* ( 1.2783E0_WP - 4.9163E0_WP*KG1 + & ! ref. (7) eq. (5.3) + (1.25192E0_WP-0.40312E0_WP*KG1)*LRS + & ! + (0.0016895E0_WP-0.0050178E0_WP*KG1)*LNE0 + & ! + (0.064190E0_WP-0.19257E0_WP*KG1)*LNE0*LNE0 & ! + ) & ! + ) & ! + ) ! +! + IF(A > SMALL) THEN ! + KF_M_3D=KFT+KFM ! + ELSE ! + KF_M_3D=KFT ! + END IF ! +! + END FUNCTION KF_M_3D +! +!======================================================================= +! + FUNCTION KF_M_2D(RS,T,A) +! +! This function computes the temperature-dependent Fermi wave vector +! in the presence of an external magnetic field for 3D systems +! +! References: (2) A. Isihara and T. Toyoda, Phys. Rev. B 19, +! 831-845 (1979) +! (3) A. Isihara and D. Y. Kojima, Phys. Rev. B 19, +! 846-855 (1979) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! * A : sqrt(mu_B * B) : magnitude of the magnetic field +! * FLD : strength of the field +! FLD = 'WF' weak field --> ref. (2) +! FLD = 'IF' intermediate field --> ref. (3) +! +! +! Output parameters: +! +! * KF_M_2D : Fermi wave number in AU +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOUR,HALF,THIRD,SMALL + USE CONSTANTS_P1, ONLY : E,K_B + USE FERMI_AU, ONLY : KF_AU + USE PI_ETC, ONLY : PI,PI2 + USE G_FACTORS, ONLY : G_E + USE EXT_FIELDS, ONLY : FLD +! + IMPLICIT NONE +! + REAL (WP) :: RS,T,A + REAL (WP) :: KF_M_2D + REAL (WP) :: BETA,KFT,KFM,RS2,LRS + REAL (WP) :: S0,ETA0,GAM0 + REAL (WP) :: ALPHA + REAL (WP) :: A4,LS1,LS2 + REAL (WP) :: G2,XL,X1,X2,X3,SI,I +! + INTEGER :: L,LMAX +! + LMAX=100 ! max. value of l-sums +! + G2=G_E*G_E ! +! + RS2=RS*RS ! + LRS=DLOG(RS) ! +! + A4=A*A*A*A ! + ALPHA=A4/(RS2*RS2*KF_AU*KF_AU*KF_AU*KF_AU) ! +! + BETA=ONE/(K_B*T) ! + ETA0=BETA*KF_AU*KF_AU ! + S0=E*E/KF_AU ! + GAM0=A*A/(KF_AU*KF_AU ) ! +! + IF(FLD == 'WF') THEN ! +! +! No magnetic field contribution +! + KFT=KF_AU*(ONE - 0.4501E0_WP*RS - 0.1427E0_WP*RS2) ! ref. (2) eq. (7.4) +! +! Magnetic field contribution +! + KFM=KF_AU*ALPHA*RS2*RS2*( & ! + (1.407E-2_WP*G2 - 3.997E-3_WP)*RS - & ! + 4.689E-3_WP*RS*LRS + & ! + (3.372E-3_WP*G2 + 2.287E-2_WP)*RS2 - & ! + 6.333E-3_WP*RS*LRS & ! + ) ! +! + IF(A > SMALL) THEN ! + KF_M_2D=KFT+KFM ! + ELSE + KF_M_2D=KFT ! + END IF ! +! + ELSE IF(FLD == 'IF') THEN ! +! + I=0.8149E0_WP ! ref. (3) eq. (5.19) +! +! Calculation of l-sums +! + SI=-ONE ! init. of sign + LS1=ZERO ! + LS2=ZERO ! + DO L=1,LMAX ! + XL=DFLOAT(L) ! + X1=XL*PI/GAM0 ! + X2=HALF*G_E*XL*PI ! + X3=XL*PI2/ALPHA ! + SI=-SI ! (-1)^(l+1) + LS1=LS1+SI*DSIN(X1)*DCOS(X2)/DSINH(X3) ! + LS2=LS2+SI*DSIN(X1)*DCOS(X2)/DSIN(X3) ! + END DO ! +! + KF_M_2D=KF_AU*(ONE + PI*LS1/ETA0 - & ! + THIRD*I*(S0**(FOUR*THIRD))* & ! ref. (3) eq. (6.1) + (ONE-PI*LS2/ETA0) & ! + ) ! +! + END IF ! +! + END FUNCTION KF_M_2D +! +END MODULE FERMI_VALUES_M + diff --git a/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/calc_energies.f90 b/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/calc_energies.f90 new file mode 100644 index 0000000..29fe589 --- /dev/null +++ b/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/calc_energies.f90 @@ -0,0 +1,315 @@ +! +!======================================================================= +! +MODULE CALC_ENERGIES +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE ENERGIES_3D(X,EC_TYPE,RS,T,I_SCREEN,K_SC, & + E_0,E_X,E_X_HF,E_C,E_XC,E_HF, & + E_GS,E_KIN,E_POT) +! +! This subroutine computes the different energies (per electron) +! involved in the 3D system --> 3D +! +! References: (1) G. Giuliani and G. Vignale, "Quantum Theory of the +! Electron Liquid", Cambridge Uiversity Press (2005) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * EC_TYPE : type of correlation energy functional +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! * I_SCREEN : switch for screened (=1) or unscreened (=0) Coulomb +! * K_SC : screening momentum (in SI) +! +! +! Output parameters: +! +! * E_0 : energy of non-interacting electron in SI +! * E_X : exchange energy (1st order) in SI +! * E_X_HF : exchange energy (Hartree-Fock) in SI +! * E_C : correlation energy in SI +! * E_XC : exchange and correlation energy in SI +! * E_HF : Hartree-Fock energy in SI +! * E_GS : energy of the ground state in SI +! * E_KIN : kinetic energy in SI +! * E_POT : potential energy in SI +! +! +! Author : D. Sébilleau + +! Last modified : 12 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR, & + HALF,THIRD,FOURTH + USE CONSTANTS_P1, ONLY : BOHR,E,EPS_0 + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI,PI_INV + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP), INTENT(OUT) :: E_0,E_X,E_X_HF,E_C,E_XC + REAL (WP), INTENT(OUT) :: E_HF,E_GS,E_KIN,E_POT + REAL (WP) :: Y + REAL (WP) :: D_EC_1,D_EC_2,D_EX_1 + REAL (WP) :: K_SC,R1,R2,FK +! + REAL (WP) :: LOG,ABS,ATAN +! + INTEGER :: I_SCREEN +! + Y = X + X ! q / k_F +! + IF(I_SCREEN == 1) THEN ! + R1 = KF_SI / K_SC ! + R2 = ONE / R1 ! + END IF ! +! +! Computing the Hartree-Fock function FK +! + IF(Y == ONE) THEN ! + FK = HALF ! + ELSE IF(Y == ZERO) THEN ! + FK = ONE ! + ELSE ! + FK = HALF + FOURTH * (ONE - Y * Y) * & ! + LOG(ABS((ONE + Y) / (ONE - Y))) / Y ! ref. (1) eq. (2.52) + END IF ! +! +! Computing the correlation energy and its derivatives +! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! +! Changing to SI +! + D_EC_1 = D_EC_1 * HALF * HARTREE ! + D_EC_2 = D_EC_2 * HALF * HARTREE ! +! + E_0 = 0.6E0_WP *EF_SI ! ref. (1) eq. (1.83) + E_X = - 0.75E0_WP * E * E * PI_INV * KF_SI ! ref. (1) eq. (1.94) +! + IF(I_SCREEN == 1) THEN ! + E_X = E_X * ( FOUR + R2 * R2 * LOG(ONE + FOUR * R1 * R1) & ! + - FOUR * R2 * ATAN(TWO * R1) & ! ref. (1) ex. (1.12) + ) ! page 66 + END IF ! +! + E_X_HF = - HALF * E * E * PI_INV * PI_INV * KF_SI * FK / EPS_0! ref. (1) eq. (2.51) + E_C = EC_3D(EC_TYPE,1,RS,T) * HALF * HARTREE ! +! + E_XC = E_X + E_C ! + E_HF = E_0 + E_X_HF ! ref. (1) eq. (2.49) + E_GS = E_0 + E_XC ! +! +! Computing the derivative of the exchange energy +! + D_EX_1 = THREE * (E * E / (FOUR * PI * BOHR)) / (RS * RS) ! +! + E_KIN = E_0 - E_XC - RS * (D_EX_1 + D_EC_1) ! ref. (1) eq. (1.57) + E_POT = TWO * E_XC + RS * (D_EX_1 + D_EC_1) ! ref. (1) eq. (1.56) +! + END SUBROUTINE ENERGIES_3D +! +!======================================================================= +! + SUBROUTINE ENERGIES_2D(X,EC_TYPE,RS,T,E_0,E_X,E_X_HF,E_C, & + E_XC,E_HF,E_GS,E_KIN,E_POT) +! +! This subroutine computes the different energies (per electron) +! involved in the 2D system --> 2D +! +! References: (1) G. Giuliani and G. Vignale, "Quantum Theory of the +! Electron Liquid", Cambridge Uiversity Press (2005) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * EC_TYPE : type of correlation energy functional +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! Output parameters: +! +! * E_0 : energy of non-interacting electron in SI +! * E_X : exchange energy (1st order) in SI +! * E_X_HF : exchange energy (Hartree-Fock) in SI +! * E_C : correlation energy in SI +! * E_XC : exchange and correlation energy in SI +! * E_HF : Hartree-Fock energy in SI +! * E_GS : energy of the ground state in SI +! * E_KIN : kinetic energy in SI +! * E_POT : potential energy in SI +! +! +! Note: for the Hartree-Fock exchange energy, we make use +! of the fact that Gradshteyn-Ryzhik complete elliptic integrals +! K(k) and E(k) are related to Carlson's elliptic integrals through +! +! K(k) = RF(0,1-K^2,1) +! E(K) = RF(0,1-K^2,1) - 1/3 k^2 RD(0,1-K^2,1) +! +! as explained by W. H. Press and S. A. Tseukolsky, +! Comp. in Phys. Jan-Fev 1990, pp. 92-96 +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,EIGHT, & + HALF,THIRD,TTINY + USE CONSTANTS_P1, ONLY : BOHR,E,EPS_0 + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI,PI_INV + USE EXT_FUNCTIONS, ONLY : RF,RD ! Carlson's elliptic integrals + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP), INTENT(OUT) :: E_0,E_X,E_X_HF,E_C,E_XC + REAL (WP), INTENT(OUT) :: E_HF,E_GS,E_KIN,E_POT + REAL (WP) :: Y,Y2 + REAL (WP) :: D_EC_1,D_EC_2,D_EX_1,FK,F1 + REAL (WP) :: O,O2 +! +! + Y = X + X ! q / k_F + Y2 = Y * Y ! + IF(Y == ZERO) THEN ! + Y = TTINY ! + END IF ! + O = ONE / Y ! + O2 = O * O ! +! +! Computing the Hartree-Fock function FK +! + IF(Y <= ONE) THEN ! + FK = RF(ZERO,ONE-Y2,ONE) - THIRD * Y2 * RD(ZERO,ONE-Y2,ONE) ! ref. (1) eq. (2.54) + ELSE ! + F1 = RF(ZERO,ONE-O2,ONE) - THIRD * O2 * RD(ZERO,ONE-O2,ONE) ! + FK = Y * (F1 - (ONE - O2) * RF(ZERO,ONE-O2,ONE)) ! ref. (1) eq. (2.54) + END IF ! +! +! Computing the correlation energy and its derivatives +! + CALL DERIVE_EC_2D(EC_TYPE,5,RS,T,D_EC_1,D_EC_2) ! +! +! Changing to SI +! + D_EC_1 = D_EC_1 * HALF * HARTREE ! + D_EC_2 = D_EC_2 * HALF * HARTREE ! +! + E_0 = HALF * EF_SI ! ref. (1) eq. (1.83) + E_X = - FOUR * THIRD * E * E * PI_INV * KF_SI ! ref. (1) eq. (1.94) + E_X_HF = - HALF * E * E * PI_INV * PI_INV * KF_SI*FK / EPS_0 ! ref. (1) eq. (2.53) + E_C = EC_2D(EC_TYPE,RS,T) * HALF * HARTREE ! +! + E_XC = E_X + E_C ! + E_HF = E_0 + E_X_HF ! ref. (1) eq. (2.49) + E_GS = E_0 + E_XC ! +! +! Computing the derivative of the exchange energy +! + D_EX_1 = - EIGHT * THIRD * (E * E / (PI * BOHR)) ! +! + E_KIN = E_0 - E_XC - RS * (D_EX_1 + D_EC_1) ! ref. (1) eq. (1.57) + E_POT = TWO * E_XC + RS * (D_EX_1 + D_EC_1) ! ref. (1) eq. (1.56) +! + END SUBROUTINE ENERGIES_2D +! +!======================================================================= +! + SUBROUTINE ENERGIES_1D(EC_TYPE,FF,RS,T,E_0,E_X,E_C,E_XC,E_HF, & + E_GS,E_KIN,E_POT) +! +! This subroutine computes the different energies (per electron) +! involved in the 1D system --> 1D +! +! References: (1) G. Giuliani and G. Vignale, "Quantum Theory of the +! Electron Liquid", Cambridge Uiversity Press (2005) +! +! Input parameters: +! +! * EC_TYPE : type of correlation energy functional +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! * FF : form factor +! +! +! Output parameters: +! +! * E_0 : energy of non-interacting electron in SI +! * E_X : exchange energy in SI +! * E_C : correlation energy in SI +! * E_XC : exchange and correlation energy in SI +! * E_HF : Hartree-Fock energy in SI +! * E_GS : energy of the ground state in SI +! * E_KIN : kinetic energy in SI +! * E_POT : potential energy in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,HALF,THIRD,FOURTH + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_SI, ONLY : EF_SI + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP), INTENT(IN) :: RS,T,FF + REAL (WP), INTENT(OUT) :: E_0,E_X,E_C,E_XC,E_HF + REAL (WP), INTENT(OUT) :: E_GS,E_KIN,E_POT + REAL (WP) :: D_EC_1,D_EC_2,D_EX_1 +! +! Computing the correlation energy and its derivatives +! + CALL DERIVE_EC_1D(EC_TYPE,5,RS,T,D_EC_1,D_EC_2) ! +! +! Changing to SI +! + D_EC_1 = D_EC_1 * HALF * HARTREE ! + D_EC_2 = D_EC_2 * HALF * HARTREE ! +! + E_0 = THIRD * EF_SI ! ref. (1) eq. (1.83) + E_X = - FOURTH * FF / RS * HALF * HARTREE ! ref. (1) eq. (1.97) + E_C = EC_1D(EC_TYPE,RS,T) * HALF * HARTREE ! +! + E_XC = E_X + E_C ! + E_HF = E_0 + E_X ! ref. (1) eq. (2.49) + E_GS = E_0 + E_XC ! +! +! Computing the derivative of the exchange energy +! + D_EX_1 = FOURTH * FF / (RS * RS) * HALF * HARTREE ! +! + E_KIN = E_0 - E_XC - RS * (D_EX_1 + D_EC_1) ! ref. (1) eq. (1.57) + E_POT = TWO * E_XC + RS * (D_EX_1 + D_EC_1) ! ref. (1) eq. (1.56) +! + RETURN +! + END +! +END MODULE CALC_ENERGIES diff --git a/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/grand_partition.f90 b/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/grand_partition.f90 new file mode 100644 index 0000000..eb1ebaa --- /dev/null +++ b/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/grand_partition.f90 @@ -0,0 +1,755 @@ +! +!======================================================================= +! +MODULE GRAND_PARTITION +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE GRAND_PARTITION_FUNCTION_3D(RS,T,A,GP_TYPE,LXI) +! +! This subroutine computes the grand partition function +! for 3D systems. +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! * A : sqrt(mu_B * B) : magnitude of the magnetic field +! * GP_TYPE : grand partition function type (3D) +! GP_TYPE = 'IK0' Isihara-Kojima formulation +! GP_TYPE = 'RH0' Rebei-Hitchon formulation +! GP_TYPE = 'IKM' Isihara-Kojima with magnetic field +! +! +! Output parameters: +! +! * LXI : logarithm of grand partition function in SI +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: GP_TYPE +! + REAL (WP) :: RS,T,A + REAL (WP) :: LXI +! + IF(GP_TYPE == 'IK0') THEN ! + LXI=LXI_IK_3D(RS,T) ! + ELSE IF(GP_TYPE == 'RH0') THEN ! + LXI=LXI_RH_3D(RS,T) ! + ELSE IF(GP_TYPE == 'IKM') THEN ! + LXI=LXI_IK_M_3D(RS,T,A) ! + END IF ! +! + END SUBROUTINE GRAND_PARTITION_FUNCTION_3D +! +!======================================================================= +! + FUNCTION LXI_IK_3D(RS,T) +! +! This function computes the logarithm of the grand partition function +! (per electron) in 3D system in the Isihara-Kojima approach +! +! Note: This is the NO MAGNETIC FIELD result +! +! +! More precisely, +! +! LXI = 1/V * DLOG(XI) where V is the volume +! +! References: (1) A. Isihara and D. Y. Kojima, Z. Physik B 21, +! 33-45 (1975) +! (2) A. Isihara and D. Y. Kojima, Phys. Cond. Matter 18, +! 249-262 (1974) +! (3) D. Y. Kojima and A. Isihara, in +! "Physics of Condensed Matter", Vol. 17, G. Busch ed., +! 179-181 (1974) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! Output parameters: +! +! * LXI_IK_3D: logarithm of grand partition function in SI +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,FIVE,SIX, & + SEVEN,EIGHT,NINE,TEN, & + HALF,THIRD,FOURTH + USE CONSTANTS_P1, ONLY : E,K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI,PI2,PI3,PI_INV + USE EULER_CONST, ONLY : EUMAS + USE UTILITIES_1, ONLY : ALFA + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP) :: RS,T + REAL (WP) :: LXI_IK_3D + REAL (WP) :: LX00,LX1X,LX1R,LR2X,LA2X + REAL (WP) :: BETA,ETA,ET2,ET4,PF2,LNE,LNE2 + REAL (WP) :: E2,E4 + REAL (WP) :: A11,AP11,A12,A13,A14 + REAL (WP) :: A21,AP21,A22,A23,A24 + REAL (WP) :: A32,A31 + REAL (WP) :: XI,XI2,XI4 + REAL (WP) :: G,LNG,LNG0 + REAL (WP) :: COEF + REAL (WP) :: C1,C2 + REAL (WP) :: C + REAL (WP) :: I,J,I1,I2,I3,K0,K1 + REAL (WP) :: TH2,TH3,TH4,TH5 + REAL (WP) :: A,A0,A1,A2,AA,DD + REAL (WP) :: ZETA_3,LN2,ALPHA +! + ZETA_3=1.202056903159594285399738E0_WP ! Apéry's constant + LN2=DLOG(TWO) ! +! + ALPHA=ALFA('3D') ! +! + E2=E*E + E4=E2*E2 +! + BETA=ONE/(K_B*T) ! + PF2=MU('3D',T) ! chemical potential --> check units + ETA=BETA*PF2 ! + ET2=ETA*ETA ! + ET4=ET2*ET2 ! + LNE=DLOG(ETA) ! + LNE2=LNE*LNE ! + G=TWO*E*E*PI_INV/DSQRT(PF2) ! ref. (2) eq. (B4) + LNG=DLOG(G) ! + LNG0=DLOG(TWO*E*E*PI_INV/DSQRT(EF_SI)) ! --> check consitency of units +! +! Cut-off parameter +! + XI=TWO ! + XI2=XI*XI ! + XI4=XI2*XI2 ! +! +! Coefficients of ref. (2) Table 1 ! +! + A11=THIRD*PI*(ONE-LN2) ! + AP11=-0.1769447E0_WP ! + A12=-PI/96.0E0_WP ! + A13=-0.0006136E0_WP ! + A14=-0.0034088E0_WP + A21=FOURTH*PI*(ONE-DLOG(FOUR)) ! + AP21=0.0716913E0_WP ! + A22=A12 ! + A23=-A22 ! + A24=0.0009204E0_WP ! + A32=-0.0039884E0_WP ! + A31=0.0030680E0_WP ! +! + C1=HALF*A11 - AP11 + TWO*XI2*A12 + XI4*(A13+HALF*A14) + & ! ref. (2) eq. (B5) + TWO*A11*DLOG(XI) ! + C2=AP21 - TWO*A21*DLOG(XI) - XI2*(A22+A23) - & ! ref. (2) eq. (B6) + HALF*XI4*(A24+A32+A31) ! +! + C=EUMAS ! + I=THIRD*LN2 - 1.5E0_WP*ZETA_3/PI2 ! ref. (2) eq. (2.26) + I1=DLOG(HALF*PI)-C ! + I2=1.1268676E0_WP ! + I3=2.9418144E0_WP ! + K0=FOUR*LN2*LN2 - 1.5E0_WP - TWO*LN2*(ONE+TWO*I2)+I1+I3 ! + K1=FOUR*LN2-ONE+TWO*I2 ! +! + A=-0.50166E0_WP ! ref. (1) eq. (B2) +! + J=TWO*ET2*( ONE + THIRD*PI2/ET2 *(ONE + 1.5E0_WP*A/PI2 - & ! + HALF*LNE) + & ! + FIVE*PI3*PI/(144.0E0_WP*ET4) - & ! ref. (3) eq. (16) + PI2/(NINE*(ETA**3.5E0_WP)) * & ! + (ONE-THREE/(TEN*ETA)) & ! + ) ! +! + TH2=0.014858E0_WP - 0.20457E0_WP*LNG0 ! + TH3=7.93829E0_WP - LNG0 ! ref. (1) app. D table 2 + TH4=-4.05265E0_WP ! + TH5=-TWO ! + A2=1.5E0_WP*(TH5+TWO)/PI2 ! ref. (1) eq. (D3) + A1=TWO*( A2 - 0.75E0_WP*(FOUR*(ONE-HALF*K1)-TH4)/PI2 ) ! ref. (1) eq. (D3) + DD=TWO*PI_INV*(A11+THREE*C1 +TWO*C2 + & ! + (TWO*A21-THREE*A11)*LNG0) ! + AA=DD-TH3-SIX+(THREE*J-PI2*I)+THREE*(K1-K0) ! + A0=A1-1.5E0_WP*AA/PI2 ! ref. (1) eq. (D3) +! +! +! Different contributions to Ln(Xi): +! +! 1) free electron contribution +! + COEF=TWO*(ETA**2.5E0_WP) / (15.0E0_WP*PI2*(BETA**1.5E0_WP)) ! + LX00=COEF*( ONE + FIVE*PI2/(EIGHT*ET2) - & ! ref. (2) eq. (2.7) + SEVEN*PI2* PI2/(EIGHT*48.0E0_WP*ET4) ) ! +! +! 2) first-order exchange graphs +! + COEF=FOURTH*E2*ET2 / (PI3*BETA) ! + LX1X=COEF*( ONE + THIRD*PI2/ET2 *(ONE + 1.5E0_WP*A/PI2 - & ! + HALF*LNE) + & ! + FIVE*PI3*PI/(144.0E0_WP*ET4) - & ! ref. (2) eq. (2.13) + PI2/(NINE*(ETA**3.5E0_WP)) * & ! + (ONE-THREE/(TEN*ETA)) & ! + ) ! +! +! 3) ring diagrams contributions +! + COEF=HALF*E4*(ETA**1.5E0_WP) / (PI3*PI*DSQRT(BETA)) ! + LX1R=COEF*( C1*PI_INV - A11*LNG*PI_INV - PI/(12.0E0_WP*ET2)*& ! ref. (2) eq. (2.22) + (C2-A21*LNG) & ! + ) ! +! +! 4) regular second-order exchange graphs +! + COEF=FOURTH*THIRD*E4*(ETA**1.5E0_WP) / (PI2*DSQRT(BETA)) ! + LR2X=-COEF*( I + PI2/(12.0E0_WP*ET2) * (A0+A1*LNE+A2*LNE2) ) ! ref. (2) eq. (2.25) +! +! 5) anomalous second-order exchange graphs +! + COEF=FOURTH*E4*(ETA**1.5E0_WP) / (PI3*PI*DSQRT(BETA)) ! + LA2X=COEF*( ONE + PI2/(12.0E0_WP*ET2) * (K0+K1*LNE+LNE2) ) ! ref. (2) eq. (2.28) +! +! Summation of the results +! + LXI_IK_3D=LX00+LX1X+LX1R+LR2X+LA2X ! +! + END FUNCTION LXI_IK_3D +! +!======================================================================= +! + FUNCTION LXI_RH_3D(RS,T) +! +! This function computes the logarithm of the grand partition function +! (per electron) in 3D system in the Rebei-Hitchon approach +! +! More precisely, +! +! LXI = 1/V * DLOG(XI) where V is the volume +! +! References: (4) A. Rebei and W. N. G. Hitchon, Physics Letters A 224, +! 127-132 (1996) +! (5) A. Rebei and W. N. G. Hitchon, Int. J. Mod. Phys. B 13, +! 3357-3367 (1999) +! 179-181 (1974) +! (6) A. Rebei and W. N. G. Hitchon, +! https://arxiv.org/pdf/cond-mat/9907025.pdf +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! Output parameters: +! +! * LXI_RH_3D: logarithm of grand partition function in SI +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,FIVE, & + SEVEN,EIGHT, & + HALF,THIRD,FOURTH + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,M_E,E,K_B + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI,PI2,PI_INV + USE EULER_CONST, ONLY : EUMAS + USE UTILITIES_1, ONLY : ALFA + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP) :: RS,T + REAL (WP) :: LXI_RH_3D + REAL (WP) :: OM0,OME,R,G,LX00 + REAL (WP) :: ALPHA,BETA,MMU,ETA,ET2,ET4,LNE + REAL (WP) :: A1,A2,B1,B2,C1,BB,EE + REAL (WP) :: RT,NT + REAL (WP) :: COEF,K1,K2,K3 + REAL (WP) :: LN2 +! + LN2=DLOG(TWO) ! +! + ALPHA=ALFA('3D') ! +! + BETA=ONE/(K_B*T) ! + MMU=MU('3D',T) ! chemical potential --> check units + ETA=BETA*MMU ! + ET2=ETA*ETA ! + ET4=ET2*ET2 ! + LNE=DLOG(ETA) ! +! + K1=HALF*KF_SI*KF_SI*KF_SI/PI2 ! + K2=-TWO*E*E*KF_SI*PI_INV ! + K3=PI2/(12.0E0_WP*ET2) ! +! +! Constants for R +! + RT=M_E*E*E/(ALPHA*H_BAR*H_BAR*KF_SI) ! ref. (5) eq. (32) + NT=ONE/(FOUR*THIRD*PI*RT*RT*RT*BOHR*BOHR*BOHR) ! +! +! Constants for G --> note: g(1) = 1 (for BB) +! + A1=ONE-TWO*LN2 ! + C1=ONE-LN2-HALF*EUMAS+0.0616E0_WP+HALF ! + BB=TWO*KF_SI*PI_INV*(ONE + PI2/(24.0E0_WP*ET2)) ! + B2=(ONE+BB+BB)**2.5E0_WP ! + B1=-TWO/15.0E0_WP -TWO*THIRD*BB + TWO*B2/15.0E0_WP ! + A2=-HALF + HALF*(ONE-EUMAS) ! + EE=ZERO ! --> to be computed +! +! +! Different contributions to Omega: +! +! 1) free electron contribution +! + COEF=TWO*(ETA**2.5E0_WP) / (15.0E0_WP*PI2*(BETA**1.5E0_WP)) ! + LX00=COEF*( ONE + FIVE*PI2/(EIGHT*ET2) - & ! ref. (2) eq. (2.7) + SEVEN*PI2*PI2 /(EIGHT*48.0E0_WP*ET4) ) ! + OM0=-BETA*LX00 +! +! 2) first-order exchange graphs +! + OME=-HALF*E*E*M_E*M_E/PI2 * ( TWO*PI_INV*MMU*MMU - & ! + THIRD*PI/(BETA*BETA) * (ONE+DLOG(BETA*MMU)-EUMAS) & ! ref. (6) eq. (67) + ) ! +! +! 3) ring diagrams contributions +! + R=0.0622E0_WP*DLOG(RS) - 0.142E0_WP + & ! ref. (5) eq. (31) + 0.0181E0_WP*NT*MMU*(ALPHA*RT/ETA)**2 ! in Ryd +! +! 4) new contribution +! + G=K1*( K2*( HALF + K3*(HALF*(A1-LNE)+A2) - & ! + HALF*K3*(EUMAS+LNE) + K3*(ONE-LN2) - & ! + FOURTH*LN2*LN2/ET2 + (EE+PI2/24.0E0_WP)/ET2 & ! ref. (4) eq. (18) + ) + MMU*(B1+K3*(B2-ONE)) & ! + -K2*(HALF+K3*(C1-HALF*LNE)) & ! + ) ! +! +! Summation of the results +! + LXI_RH_3D=-(OM0+OME+R-G)/BETA ! ref. (4) eq. (8) +! + END FUNCTION LXI_RH_3D +! +!======================================================================= +! + FUNCTION LXI_IK_M_3D(RS,T,A) +! +! This function computes the logarithm of the grand partition function +! (per electron) in 3D system in the Isihara-Kojima approach, in the +! presence of an external magnetic field +! +! More precisely, +! +! LXI = 1/V * DLOG(XI) where V is the volume +! +! References: (7) A. Isihara and D. Y. Kojima, Phys. Rev. B 10, +! 4925-4931 (1974) +! (8) A. Isihara and D. Y. Kojima, Phys. Rev. B 11, +! 710-727 (1975) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! * A : sqrt(mu_B * B) : magnitude of the magnetic field +! +! +! Output parameters: +! +! * LXI_IK_M_3D: logarithm of grand partition function in AU +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,FIVE, & + SEVEN,EIGHT,NINE, & + THIRD,FOURTH + USE CONSTANTS_P1, ONLY : E,K_B + USE FERMI_VALUES_M, ONLY : KF_M_3D + USE PI_ETC, ONLY : PI,PI2,PI3 + USE G_FACTORS, ONLY : G_E +! + IMPLICIT NONE +! + REAL (WP) :: RS,T,A + REAL (WP) :: LXI_IK_M_3D + REAL (WP) :: LXI_IK_M + REAL (WP) :: LX00,LXA0,LXA1 + REAL (WP) :: BETA,ETA,ET2,ET4,KFAU + REAL (WP) :: EE,E4,A4,PIE,PIE2 + REAL (WP) :: G,LNG + REAL (WP) :: COEF + REAL (WP) :: KG,K1 + REAL (WP) :: C11,A21,C2(2),D1(2),D2,E1(2),E2(2) + REAL (WP) :: E3,F1,F2(2),F3 +! + INTEGER :: X +! + X=1 ! cut-off for q-integration (1 or 2) +! + BETA=ONE/(K_B*T) ! + KFAU=KF_M_3D(RS,T,A) ! (T,A)-dependent Fermi energy + ETA=BETA*KFAU*KFAU ! + ET2=ETA*ETA ! + ET4=ET2*ET2 ! +! + EE=E*E ! + E4=EE*EE ! + A4=A*A*A*A ! + PIE=PI/ETA ! + PIE2=PIE*PIE ! + KG=FOURTH*G_E*G_E - THIRD ! + G=TWO*EE/(PI*KFAU) ! + LNG=DLOG(G) ! +! +! Coefficients for correlations +! + C11 = 0.19635E0_WP ! + A21 =FOURTH*PI*(ONE-DLOG(FOUR)) ! + C2(1)= 0.07169E0_WP ! + C2(2)= 0.49229E0_WP ! + D1(1)= 0.04632E0_WP ! + D1(2)= 0.92605E0_WP ! + D2 = 0.82699E0_WP ! + E1(1)= 0.35282E0_WP ! + E1(2)= 0.92701E0_WP ! ref. (8) table I + E2(1)= 0.04336E0_WP ! + E2(2)=-0.00797E0_WP ! + E3 =-0.01023E0_WP ! + F1 =-0.14124E0_WP ! + F2(1)= 0.06124E0_WP ! + F2(2)= 0.15916E0_WP ! + F3 =-0.02250E0_WP ! +! +! No magnetic field contribution +! +! 1) free electron contribution +! + COEF=TWO*(ETA**2.5E0_WP) / (15.0E0_WP*PI2*(BETA**1.5E0_WP)) ! + LX00=COEF*( ONE + FIVE*PI2/(EIGHT*ET2) - & ! ref. (2) eq. (2.7) + SEVEN*PI2* PI2/(EIGHT*48.0E0_WP*ET4) ) ! +! +! Non interacting electrons + magnetic field +! + LXA0=KG*DSQRT(BETA/PI)*A4/(8.0E0_WP*PI) * ( & ! + TWO/(PIE**1.5E0_WP) - (PIE**1.5E0_WP)/12.0E0_WP - & ! ref. (7) eq. (4.1) + SEVEN*(PIE**3.5E0_WP)/192.0E0_WP & ! + ) ! +! +! Interacting electrons + magnetic field +! + K1=BETA*A4/PI2 ! + LXA1=K1*FOURTH*KFAU*KG *(ONE-PIE2/24.0E0_WP) + & ! + K1*FOURTH*EE/PI * (ONE-PIE2/12.0E0_WP) + & ! + K1*E4/(EIGHT*PI3*KFAU)*KG* ( & ! ref. (8) eq. (3.1) + -C2(X)-A21*LNG + PIE2/EIGHT * (D1(X)+D2*LNG) & ! + ) + & ! + K1*EE/(NINE*PI2) * (E1(X)-C11*LNG+G*(E2(X)+E3*LNG) + & ! + PIE2/EIGHT * (F1+G*(F2(X)+F3*LNG)) & ! + ) ! +! +! Summation of the results +! + LXI_IK_M_3D=LX00+LXA0+LXA1 ! ref. (8) eq. (2.12) +! + END FUNCTION LXI_IK_M_3D +! +!======================================================================= +! + SUBROUTINE GRAND_PARTITION_FUNCTION_2D(RS,T,A,FLD,LXI) +! +! This subroutine computes the grand partition function +! for 2D systems. +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! * A : sqrt(mu_B * B) : magnitude of the magnetic field +! * GP_TYPE : grand partition function type (2D) +! GP_TYPE = 'I20' Isihara-Kojima formulation +! GP_TYPE = 'I2M' Isihara-Kojima with magnetic field +! * FLD : strength of the field +! FLD = 'WF' weak field --> ref. (2) +! FLD = 'IF' intermediate field --> ref. (3) +! +! +! Output parameters: +! +! * LXI : logarithm of grand partition function in SI +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: GP_TYPE + CHARACTER (LEN = 2) :: FLD +! + REAL (WP) :: RS,T,A + REAL (WP) :: LXI +! + IF(GP_TYPE == 'I20') THEN ! + LXI=LXI_IK_2D(RS,T) ! + ELSE IF(GP_TYPE == 'I2M') THEN ! + LXI=LXI_IK_M_2D(RS,T,A,FLD) ! + END IF ! +! + END SUBROUTINE GRAND_PARTITION_FUNCTION_2D +! +!======================================================================= +! + FUNCTION LXI_IK_2D(RS,T) +! +! This function computes the grand partition function +! (per electron) in the 2D system according to the +! Isihara-Toyoda model +! +! References: (1) A. Isihara and T. Toyoda, Phys. Rev. B 21, +! 3358-3365 (1980) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF,THIRD,FOURTH + USE CONSTANTS_P1, ONLY : E,K_B + USE PI_ETC, ONLY : PI,PI2,PI3,PI_INV + USE EULER_CONST, ONLY : EUMAS + USE UTILITIES_1, ONLY : ALFA + USE CHEMICAL_POTENTIAL, ONLY : MU +! + IMPLICIT NONE +! + REAL (WP) :: RS,T + REAL (WP) :: LXI_IK_2D + REAL (WP) :: A,C,C1,C2,I,J,A0,A1,A2,K0,K1,A11,A21 + REAL (WP) :: I1,I2,I3,TH2,TH3,TH5,LNG,LNG0,ALPHA + REAL (WP) :: D1,D2,E0,EP1,ES1,EP2,ES2,ET2 + REAL (WP) :: BETA,PF2,PF3,PF4,ETA,X + REAL (WP) :: E2,E4,LNE,LNE2,DD,AA + REAL (WP) :: ZETA_3,LN2 +! + ZETA_3=1.202056903159594285399738E0_WP ! Apéry's constant + LN2=DLOG(TWO) ! +! + ALPHA=ALFA('2D') ! +! + E2=E*E + E4=E2*E2 +! + BETA=ONE/(K_B*T) ! + PF2=MU('2D',T) ! chemical potential + PF3=PF2*DSQRT(PF2) ! + PF4=PF2*PF2 ! + ETA=BETA*PF2 ! + ET2=ETA*ETA ! + LNE=DLOG(ETA) ! + LNE2=LNE*LNE ! +! + D1=TWO*THIRD/(PI2) ! + D2=FOURTH*(ONE-LN2)*PI_INV + ONE/PI3 - & ! + (27.3E0_WP + 1.3E0_WP)/(32.0E0_WP*PI*PI3) ! + E0=PI/12.0E0_WP ! + EP1=-0.02553E0_WP ! + ES1=-ONE/24.0E0_WP ! + EP2=-0.05508E0_WP ! + ES2=0.018316E0_WP ! + ET2=PI_INV/48.0E0_WP ! +! + LXI_IK_2D=BETA*( FOURTH*PF4*PI_INV + D1*E2*PF3 + D2*E4*PF2 +& ! + (E0*PF4 + (EP1+ES1*DLOG(ETA))*E2*PF3 + & ! + (EP2+ES2*DLOG(ETA)+ET2*DLOG(ETA)*DLOG(ETA))* & ! ref. (1) eq. (6.1) + E4*PF2 & ! + )/(ETA*ETA) & ! + ) ! +! + END FUNCTION LXI_IK_2D +! +!======================================================================= +! + FUNCTION LXI_IK_M_2D(RS,T,A,FLD) +! +! This function computes the logarithm of the grand partition function +! (per electron) in 2D system in the Isihara-Kojima approach, in the +! presence of an external magnetic field: +! +! (i) weak field --> ref. (2) +! (ii) intermediate field --> ref. (3) +! +! More precisely, +! +! LXI = 1/V * DLOG(XI) where V is the volume +! +! References: (2) A. Isihara and T. Toyoda, Phys. Rev. B 19, +! 831-845 (1979) +! (3) A. Isihara and D. Y. Kojima, Phys. Rev. B 19, +! 846-855 (1979) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! * A : sqrt(mu_B * B) : magnitude of the magnetic field +! * FLD : strength of the field +! FLD = 'WF' weak field --> ref. (2) +! FLD = 'IF' intermediate field --> ref. (3) +! +! +! Output parameters: +! +! * LXI_IK_M_2D: logarithm of grand partition function in AU +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,SEVEN, & + HALF,THIRD,FOURTH + USE CONSTANTS_P1, ONLY : E,K_B + USE FERMI_VALUES_M, ONLY : KF_M_2D + USE PI_ETC, ONLY : PI,PI2,PI_INV + USE G_FACTORS, ONLY : G_E +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: FLD +! + REAL (WP) :: RS,T,A + REAL (WP) :: LXI_IK_M_2D + REAL (WP) :: ALPHA,BETA,GAMMA,ETA,ET2 + REAL (WP) :: KFAU,G2,KG,I + REAL (WP) :: LN0,LNA + REAL (WP) :: E2,CC,A2,A4,SL1,SL2,SI + REAL (WP) :: XL,AL,BL,CL,ZZL +! + INTEGER :: L,LMAX +! + LMAX=100 ! max. value of l-sum +! + G2=G_E*G_E ! +! + BETA=ONE/(K_B*T) ! + ALPHA=BETA*A*A ! + KFAU=KF_M_2D(RS,T,A) ! (T,A)-dependent Fermi energy + ETA=BETA*KFAU*KFAU ! + ET2=ETA*ETA ! + GAMMA=A*A/(KFAU*KFAU) ! +! + E2=E*E ! + A2=A*A ! + A4=A2*A2 ! + CC=E2/KFAU ! + KG=0.75E0_WP*G2 - ONE ! +! + IF(FLD == 'WF') THEN ! +! +! No magnetic field contribution +! + ZZL=ONE + SL1=ZERO ! + DO L=1,LMAX ! + XL=DFLOAT(L) ! + ZZL=-ZZL*L ! + AL=XL*BETA*A2 ! + BL=HALF*G_E*AL ! + SL1=SL1+ZZL*COSH(AL)/(DSINH(BL)*XL) ! + END DO ! + LN0=-HALF*A2*SL1*PI_INV ! +! +! Magnetic field +! + LNA=BETA*A4*( PI_INV/12.0E0_WP * KG + CC*( &! + ONE/(12.0E0_WP*PI2) * KG + &! + ONE/(48.0E0_WP*PI2) * (26.0E0_WP/15.0E0_WP + &! + SEVEN*PI/16.0E0_WP) &! ref. (2) eq. (6.1) + ) - &! + ONE/(48.0E0_WP*PI2)*CC*DLOG(FOURTH*CC) + &! + ( -ONE/(96.0E0_WP*PI)*KG + &! + 11.0E0_WP/(2304.0E0_WP*PI) &! + ) * CC*CC &! + ) +! +! Summing up +! + LXI_IK_M_2D=LN0+LNA ! +! + ELSE IF(FLD == 'IF') THEN ! +! + I=0.8149E0_WP ! ref. (3) eq. (5.19) +! +! Calculation of l-sums +! + SI=-ONE ! init. of sign + SL1=ZERO ! + SL2=ZERO ! + DO L=1,LMAX ! + SI=-SI ! + XL=DFLOAT(L) ! + AL=XL*PI/GAMMA ! + BL=HALF*G_E-TWO*XL*PI ! + CL=XL*PI2/ALPHA ! + SL1=SL1+SI*DCOS(AL)*DCOS(BL)/(XL*DSINH(CL)) ! + SL2=SL2+SI*DSIN(AL)*DCOS(BL)/DSINH(CL) ! + END DO ! + LXI_IK_M_2D=FOURTH*BETA*KFAU*KFAU*KFAU*KFAU*PI_INV*( & ! + ONE + THIRD*PI2/ET2 + & ! + ((HALF*G2)**2 -THIRD)*GAMMA*GAMMA + & ! ref. (3) eq. (5.21) + FOUR*ALPHA/ET2 * SL1 + & ! + I*(CC**(FOUR*THIRD))* & ! + (ONE + TWO*PI/ETA *SL2 )**(FOUR*THIRD) & ! + ) ! +! + END IF ! +! + END FUNCTION LXI_IK_M_2D +! +END MODULE GRAND_PARTITION diff --git a/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/material_properties.f90 b/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/material_properties.f90 new file mode 100644 index 0000000..57b1501 --- /dev/null +++ b/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/material_properties.f90 @@ -0,0 +1,89 @@ +! +!======================================================================= +! +MODULE MATERIAL_CL +! +! This module defines the material characteristic lengths +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: EMFP,FWL,PCL,THL,ML,CR,DL,TFL +! +END MODULE MATERIAL_CL +! +!======================================================================= +! +MODULE MATERIAL_PROPERTIES +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE CHARACTERISTIC_LENGTHS(DMN,RS,T,B,DC,TP) +! +! This subroutine computes and prints out characteristic lengths +! in the input material +! +! References: (1) H. van Houten, B. J. van Wees and C.W.J. Beenakker +! in "Physics and Technology of Submicron Structures", +! H. Heinrich, G. Bauer and F. Kuchar eds., +! Springer Series in Solid State Science Vol. 83, +! pp. 198-207 (1988) +! +! +! Input parameters: +! +! * DMN : dimension +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! * B : magnetic field in SI +! * DC : diffusion coefficient +! * TP : phase-breaking relaxation time in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 24 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,TTINY + USE CONSTANTS_P1, ONLY : H_BAR,E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : D + USE SCREENING_VEC +! + USE MATERIAL_CL +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP) :: RS,T,B,DC,TP + REAL (WP) :: KD,K_TF +! + INTEGER :: LOGF +! + IF(B == ZERO) B = TTINY ! +! + EMFP=D(DMN)*DC/VF_SI ! elastic MFP + FWL=TWO*PI/KF_SI ! Fermi wavelength + PCL=DSQRT(DC*TP) ! phase coherence length + THL=DSQRT(H_BAR*DC/(K_B*T)) ! thermal length + ML=DSQRT(H_BAR/(E*B)) ! magnetic length + CR=H_BAR*KF_SI/(E*B) ! cyclotron radius +! + CALL DEBYE_VECTOR(DMN,T,RS,KD) ! + DL=ONE/KD ! Debye length +! + CALL THOMAS_FERMI_VECTOR(DMN,K_TF) ! + TFL=ONE/K_TF ! Thomas-Fermi length +! + END SUBROUTINE CHARACTERISTIC_LENGTHS +! +END MODULE MATERIAL_PROPERTIES diff --git a/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/thermodynamic_properties.f90 b/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/thermodynamic_properties.f90 new file mode 100644 index 0000000..1601b92 --- /dev/null +++ b/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/thermodynamic_properties.f90 @@ -0,0 +1,562 @@ +! +!======================================================================= +! +MODULE THERMODYNAMIC_PROPERTIES +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE SPECIFIC_HEAT(DMN,I_ORD,RS,T,CV) +! +! This subroutine computes the specific heat +! (per electron) in the 2D and 3D system +! +! References: (1) A. Isihara, "Electron Liquids", 2nd edition, +! Springer Series in Solid-State Sciences 96, +! +! Input parameters: +! +! * DMN : dimension +! * I_ORD : order of the truncation of the r_s series +! I_ORD = 1 : r_s only --> ref. 1 eq. (7.1.16) +! I_ORD = 2 : r_s^2 --> ref. 1 eq. (7.1.22) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! Output parameters: +! +! * CV : specific heat in SI +! * F_FR : Helmhotz free energy per electron in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,NINE, & + HALF,THIRD + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI,PI2,PI_INV + USE SQUARE_ROOTS, ONLY : SQR2 +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + INTEGER :: I_ORD +! + REAL (WP) :: RS,T + REAL (WP) :: CV + REAL (WP) :: C1,CV0,A,C,RAT,ETA_0 +! + REAL (WP) :: LOG,SQRT +! + C1 = (FOUR / (NINE * PI2 * PI2))**THIRD ! + A = -4.035E0_WP ! + C = 0.02553E0_WP ! + RAT = KF_SI / (K_B * T) ! + ETA_0 = KF_SI * RAT ! +! +! specific heat at T = 0 +! + IF(DMN == '3D') THEN ! + CV0 = HALF * THIRD * K_B* K_B * T * KF_SI ! ref. (1) eq. (7.1.17) + ELSE IF(DMN == '2D') THEN ! + CV0 = THIRD * PI2 * K_B * K_B * T / (KF_SI * KF_SI) ! ref. (1) eq. (7.1.27) + END IF ! +! +! r_s expansion +! + IF(DMN == '3D') THEN ! + IF(I_ORD == 1) THEN ! + CV = CV0 * ( ONE + C1 * RS * ( 2.5E0_WP + & ! + THREE * A / PI2 - & ! ref. (1) eq. (7.1.16) + LOG(RAT * RAT) & ! + ) & ! + ) ! + ELSE IF(I_ORD == 2) THEN ! + CV = CV0 * ( ONE + 0.162E0_WP * RS - & ! + 0.166E0_WP * RS * LOG(ETA_0) - & ! + 0.157E0_WP * RS * RS + & ! ref. (1) eq. (7.1.22) + 0.0138E0_WP * RS * RS * LOG(RS) + & ! + RS * RS * ( 0.0282E0_WP * LOG(ETA_0) + & ! + 0.0275E0_WP * LOG(ETA_0) * LOG(ETA_0) ) & ! + ) ! + END IF ! + ELSE IF(DMN == '2D') THEN ! + CV = CV0 * ( ONE + RS * ( 0.75E0_WP * SQR2 * PI_INV * & ! + (ONE - 16.0E0_WP * C) - & ! ref. (1) eq. (7.1.26) + LOG(ETA_0) / SQRT(TWO*PI) & ! + ) & ! + ) ! + END IF ! +! + END SUBROUTINE SPECIFIC_HEAT +! +!======================================================================= +! + FUNCTION PRESSURE_3D(RS) +! +! This function computes the electron pressure in a 3D system +! +! +! References: (1) G. Giuliani and G. Vignale, "Quantum Theory of the +! Electron Liquid", Cambridge Uiversity Press (2005) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Note: We write the ground-state energy E = E_0 + E_X + E_C as +! +! E = E_HF + E_C +! +! and use eq. (2.56) of ref. (1) to compute the derivatives of E_HF +! +! E_HF = Ad / rs^2 - Bd / rs +! D_EHF_1 = -2 * Ad / rs^3 + Bd / rs^2 +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,HALF,THIRD + USE CONSTANTS_P2, ONLY : HARTREE + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : ALFA + USE EXT_FIELDS, ONLY : T + USE ENERGIES, ONLY : EC_TYPE + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS + REAL (WP) :: PRESSURE_3D + REAL (WP) :: ALPHA + REAL (WP) :: A3,B3,RS2,RS3 + REAL (WP) :: D_EC_1,D_EC_2,D_EHF_1 +! + ALPHA = ALFA('3D') ! + A3 = 0.6E0_WP / ALPHA ! ref. (1) table (2.1) + B3 = 1.5E0_WP * PI_INV / ALPHA ! idem +! + RS2 = RS * RS ! + RS3 = RS2 * RS ! +! +! Computing the derivatives of the correlation energy +! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! +! Computation of the first derivative of E_HF +! + D_EHF_1 = - TWO * A3 / RS3 + B3 / RS2 ! +! + PRESSURE_3D = - THIRD * RS * (D_EHF_1 + D_EC_1) * & ! + HALF * HARTREE ! ref. (1) eq. (1.137) +! + END FUNCTION PRESSURE_3D +! +!======================================================================= +! + FUNCTION MU_3D(RS) +! +! This function computes the chemical potential in a 3D system +! +! +! References: (1) G. Giuliani and G. Vignale, "Quantum Theory of the +! Electron Liquid", Cambridge Uiversity Press (2005) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Note: We write the ground-state energy E = E_0 + E_X + E_C as +! +! E = E_HF + E_C +! +! and use eq. (2.56) of ref. (1) to compute the derivatives of E_HF +! +! E_HF = Ad / rs^2 - Bd / rs +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : HALF + USE PI_ETC, ONLY : PI_INV + USE CONSTANTS_P2, ONLY : HARTREE + USE UTILITIES_1, ONLY : ALFA + USE EXT_FIELDS, ONLY : T + USE ENERGIES, ONLY : EC_TYPE + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS + REAL (WP) :: MU_3D + REAL (WP) :: E_C,E_HF + REAL (WP) :: ALPHA + REAL (WP) :: A3,B3,RS2 + REAL (WP) :: P +! + ALPHA = ALFA('3D') ! + A3 = 0.6E0_WP / ALPHA ! ref. (1) table (2.1) + B3 = 1.5E0_WP * PI_INV / ALPHA ! idem +! + RS2 = RS * RS ! +! +! Computing the correlation energy +! + E_C = EC_3D(EC_TYPE,1,RS,T) * HALF * HARTREE ! +! +! Computation of E_HF +! + E_HF = A3 / RS2 - B3 / RS ! +! +! Computing the electronic pressure +! + P = PRESSURE_3D(RS) +! + MU_3D = E_HF + E_C + P ! ref. (1) eq. (1.138) +! + END FUNCTION MU_3D +! +!======================================================================= +! + FUNCTION KAPPA_0_3D(RS) +! +! This function computes the non-interacting compressibility +! in a 3D system +! +! +! References: (1) N. Iwamoto, Phys. Rev. A 30, 3289-3304 (1984) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS + REAL (WP) :: KAPPA_0_3D + REAL (WP) :: RS2 + REAL (WP) :: ALPHA +! + RS2 = RS * RS ! +! + ALPHA=ALFA('3D') ! +! + KAPPA_0_3D = 1.5E0_WP * ALPHA * ALPHA * RS2 ! ref. (1) eq. (2.17) +! + END FUNCTION KAPPA_0_3D +! +!======================================================================= +! + FUNCTION BULK_MOD_3D(RS) +! +! This function computes the bulk modulus in a 3D system +! +! +! References: (1) G. Giuliani and G. Vignale, "Quantum Theory of the +! Electron Liquid", Cambridge Uiversity Press (2005) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,SIX,HALF,THIRD + USE PI_ETC, ONLY : PI_INV + USE CONSTANTS_P2, ONLY : HARTREE + USE UTILITIES_1, ONLY : ALFA + USE EXT_FIELDS, ONLY : T + USE ENERGIES, ONLY : EC_TYPE + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS + REAL (WP) :: BULK_MOD_3D + REAL (WP) :: ALPHA + REAL (WP) :: A3,B3,RS2,RS3,RS4 + REAL (WP) :: D_EC_1,D_EC_2,D_EHF_1,D_EHF_2 +! + ALPHA = ALFA('3D') ! + A3 = 0.6E0_WP / ALPHA ! ref. (1) table (2.1) + B3 = 1.5E0_WP * PI_INV / ALPHA ! idem +! + RS2 = RS * RS ! + RS3 = RS2 * RS ! + RS4 = RS3 * RS ! +! +! Computing the derivatives of the correlation energy +! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! +! Computation of the derivatives of E_HF +! + D_EHF_1 = - TWO * A3 / RS3 + B3 / RS2 ! + D_EHF_2 = - SIX * A3 / RS4 - TWO * B3 / RS3 ! +! + BULK_MOD_3D = THIRD * RS * ( THIRD * RS * & ! + (D_EHF_2 + D_EC_2) - & ! + TWO * THIRD * RS * & ! + (D_EHF_1+D_EC_1) & ! ref. (1) eq. (1.139) + ) * HALF * HARTREE ! +! + END FUNCTION BULK_MOD_3D +! +!======================================================================= +! + FUNCTION KAPPA_3D(RS) +! +! This function computes the interacting compressibility +! in a 3D system +! +! References: (1) G. Giuliani and G. Vignale, "Quantum Theory of the +! Electron Liquid", Cambridge Uiversity Press (2005) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS + REAL (WP) :: KAPPA_3D +! + KAPPA_3D = ONE / BULK_MOD_3D(RS) ! ref. (1) eq. (1.140) +! + END FUNCTION KAPPA_3D +! +!======================================================================= +! + FUNCTION U_IN_3D(RS,T) +! +! This function computes the internal energy per electron +! in a 3D system +! +! References: (1) S. Ichimaru, Rev. Mod. Phys. 54, 1017-1059 (1982) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE CONSTANTS_P1, ONLY : K_B + USE PLASMON_SCALE_P, ONLY : NONID +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP) :: U_IN_3D + REAL (WP) :: A0,B0,C0,D0,G4 +! +! Slattery-Doolen-DeWitt parameters ! ref (1) eq. (2.12) +! + A0=-0.89752E0_WP ! + B0= 0.94544E0_WP ! 1 < NONID < 160 + C0= 0.17954E0_WP ! + D0=-0.80049E0_WP ! +! + U_IN_3D = K_B * T * (A0 * NONID + B0 * G4 + & ! ref. (1) eq. (2.8) + C0 / G4 + D0 + 1.5E0_WP) ! and (2.11) +! + END FUNCTION U_IN_3D +! +!======================================================================= +! + FUNCTION U_EX_3D(RS,T) +! +! This function computes the excess internal energy per electron +! in a 3D system +! +! References: (1) S. Ichimaru, Rev. Mod. Phys. 54, 1017-1059 (1982) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE CONSTANTS_P1, ONLY : K_B + USE PLASMON_SCALE_P, ONLY : NONID +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP) :: U_EX_3D + REAL (WP) :: A0,B0,C0,D0,G4 +! +! Slattery-Doolen-DeWitt parameters ! ref (1) eq. (2.12) +! + A0=-0.89752E0_WP ! + B0= 0.94544E0_WP ! 1 < NONID < 160 + C0= 0.17954E0_WP ! + D0=-0.80049E0_WP ! +! + U_EX_3D = A0 * NONID + B0 * G4 + C0 / G4 + D0 ! ref. (3) eq. (2.11) +! + END FUNCTION U_EX_3D +! +!======================================================================= +! + FUNCTION U_IT_3D(T) +! +! This function computes the total interaction energy per electron +! in a 3D system +! +! References: (1) K. Tago, K. Utsumi and S. Ichimaru, +! Prog. Theor. Phys. 65, 54-65 (1981) +! +! +! Input parameters: +! +! * T : system temperature in SI +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,HALF,FOURTH + USE SQUARE_ROOTS, ONLY : SQR3 + USE CONSTANTS_P1, ONLY : K_B + USE PLASMON_SCALE_P, ONLY : NONID +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: T + REAL (WP) :: U_IT_3D +! + REAL (WP) :: A1,A2,A3 + REAL (WP) :: B1,B2 +! +! TUI coefficients +! + A1 = - 0.89461E0_WP ! \ + A2 = 0.8165E0_WP ! | + A3 = - 0.5012E0_WP ! > ref. (1), eq. (32)-(33) + B1 = - 0.8899E0_WP ! | + B2 = 1.50E0_WP ! / +! + IF(NONID < ONE) THEN ! + U_IT_3D = - SQR3 * (NONID**1.5E0_WP) * HALF ! + ELSE IF(ONE <= NONID .AND. NONID <= 40.0E0_WP) THEN ! + U_IT_3D = A1 * NONID + A2 * (NONID**FOURTH) + A3 ! + ELSE ! + U_IT_3D = B1 * NONID + B2 + END IF ! +! + END FUNCTION U_IT_3D +! +!======================================================================= +! + FUNCTION F_FR_3D(RS,T) +! +! This function computes the Helmholtz free energy per electron +! in a 3D system +! +! References: (1) S. Ichimaru, Rev. Mod. Phys. 54, 1017-1059 (1982) +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : THREE,FOUR + USE CONSTANTS_P1, ONLY : K_B + USE PLASMON_SCALE_P, ONLY : NONID +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP) :: F_FR_3D + REAL (WP) :: A0,B0,C0,D0,G4 +! + REAL (WP) :: LOG +! +! Slattery-Doolen-DeWitt parameters ! ref (1) eq. (2.12) +! + A0=-0.89752E0_WP ! + B0= 0.94544E0_WP ! 1 < NONID < 160 + C0= 0.17954E0_WP ! + D0=-0.80049E0_WP ! +! + F_FR_3D = K_B * T * ( A0 * NONID + & ! + FOUR * (B0 * G4 - C0 / G4) + & ! + (D0 + THREE) * LOG(NONID) - & ! ref. (1) eq. (2.14) + ( A0 + FOUR * B0 - & ! + FOUR * C0 + 1.135E0_WP) & ! + ) ! +! + END FUNCTION F_FR_3D +! +END MODULE THERMODYNAMIC_PROPERTIES diff --git a/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/thermodynamic_quantities.f90 b/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/thermodynamic_quantities.f90 new file mode 100644 index 0000000..d8e687c --- /dev/null +++ b/New_libraries/DFM_library/PHYSICAL_PROPERTIES_LIBRARY/thermodynamic_quantities.f90 @@ -0,0 +1,329 @@ +! +!======================================================================= +! +MODULE THERMODYNAMIC_QUANTITIES +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE SPECIFIC_HEAT(DMN,I_ORD,RS,T,CV) +! +! This subroutine computes the specific heat +! (per electron) in the 2D and 3D system +! +! References: (1) A. Isihara, "Electron Liquids", 2nd edition, +! Springer Series in Solid-State Sciences 96, +! +! Input parameters: +! +! * DMN : dimension +! * I_ORD : order of the truncation of the r_s series +! I_ORD = 1 : r_s only --> ref. 1 eq. (7.1.16) +! I_ORD = 2 : r_s^2 --> ref. 1 eq. (7.1.22) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! Output parameters: +! +! * CV : specific heat in SI +! * F_FR : Helmhotz free energy per electron in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,NINE, & + HALF,THIRD + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI,PI2,PI_INV + USE SQUARE_ROOTS, ONLY : SQR2 +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP) :: RS,T + REAL (WP) :: CV + REAL (WP) :: C1,CV0,A,C,RAT,ETA_0 +! + INTEGER :: I_ORD +! + C1=(FOUR/(NINE*PI2*PI2))**THIRD ! + A=-4.035E0_WP ! + C=0.02553E0_WP ! + RAT=KF_SI/(K_B*T) ! + ETA_0=KF_SI*RAT ! +! +! specific heat at T = 0 +! + IF(DMN == '3D') THEN ! + CV0=HALF*THIRD*K_B*K_B*T*KF_SI ! ref. (1) eq. (7.1.17) + ELSE IF(DMN == '2D') THEN ! + CV0=THIRD*PI2*K_B*K_B*T/(KF_SI*KF_SI) ! ref. (1) eq. (7.1.27) + END IF ! +! +! r_s expansion +! + IF(DMN == '3D') THEN ! + IF(I_ORD == 1) THEN ! + CV=CV0*(ONE + C1*RS*(2.5E0_WP + THREE*A/PI2 - &! ref. (1) eq. (7.1.16) + DLOG(RAT*RAT)) ) ! + ELSE IF(I_ORD == 2) THEN ! + CV=CV0*(ONE + 0.162E0_WP*RS - 0.166E0_WP*RS*DLOG(ETA_0) -&! + 0.157E0_WP*RS*RS + 0.0138E0_WP*RS*RS*DLOG(RS) + &! + RS*RS*( 0.0282E0_WP*DLOG(ETA_0) + &! ref. (1) eq. (7.1.22) + 0.0275E0_WP*DLOG(ETA_0)*DLOG(ETA_0) ) &! + ) ! + END IF ! + ELSE IF(DMN == '2D') THEN ! + CV=CV0*(ONE + RS*( 0.75E0_WP*SQR2*PI_INV * &! + (ONE-16.0E0_WP*C) - &! ref. (1) eq. (7.1.26) + DLOG(ETA_0)/DSQRT(TWO*PI) &! + ) &! + ) ! + END IF ! +! + END SUBROUTINE SPECIFIC_HEAT +! +!======================================================================= +! + SUBROUTINE HIGH_T_THERMO_3D(RS,T,TH_PROP,P,U_IN,U_EX,F_FR) +! +! This subroutine computes high-temperature thermodynamics properties +! (per electron) in the 3D system --> 3D +! +! References: (1) A. Isihara, "Electron Liquids", 2nd edition, +! Springer Series in Solid-State Sciences 96, +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! * TH_PROP : type of calculation +! TH_PROP = 'CLAS' : classical approximation +! TH_PROP = 'QUAN' : quantum approximation +! +! +! Output parameters: +! +! * P : electron pressure in SI +! * U_IN : internal energy per electron in SI +! * U_EX : excess internal energy per electron / k_B T in SI +! * F_FR : Helmhotz free energy per electron in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 22 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,TEN, & + HALF,THIRD,FOURTH + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,M_E,E,K_B + USE PI_ETC, ONLY : PI,SQR_PI + USE EULER_CONST, ONLY : EUMAS + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE UTILITIES_1, ONLY : RS_TO_N0 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: TH_PROP +! + REAL (WP) :: RS,T + REAL (WP) :: P,U_IN,U_EX,F_FR + REAL (WP) :: EPS,LAMBDA,GAMMA + REAL (WP) :: KD_SI,N0 + REAL (WP) :: A(4),B(4) + REAL (WP) :: DEN1,DEN2,DEN3,DEN4 + REAL (WP) :: X,X2,X3,X4,X6,ETA,GX +! + DATA A / -0.895929E0_WP, 0.11340656E0_WP, & ! + -0.90872827E0_WP,-0.11614773E0_WP / ! Hansen + DATA B / 4.6664860E0_WP, 13.675411E0_WP, & ! parameters + 1.8905603E0_WP, 1.0277554E0_WP / ! +! +! Computing the Debye screening vector +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! +! Computing the electron density +! + N0=RS_TO_N0('3D',RS) ! +! + EPS=E*E*KD_SI/(K_B*T) ! ref. (1) eq. (1.1.2) + LAMBDA=TWO*PI*H_BAR/DSQRT(TWO*PI*M_E*K_B*T) ! de Broglie thermal wavelength + ETA=TWO*PI*BOHR/LAMBDA ! ref. (1) p. 3 + GAMMA=(THIRD*EPS*EPS)**THIRD ! ref. (1) eq. (1.1.4) + X=ETA/DSQRT(TWO*PI) ! +! + X2=X*X ! + X3=X2*X ! + X4=X2*X2 ! + X6=X4*X2 ! +! +! Calculation of function g(x) +! + IF(X <= ONE) THEN ! + GX=TWO*EUMAS +DLOG(THREE) - FOUR*THIRD - HALF*X2 + & ! + X4/TEN + TWO*X6/21.0E0_WP ! ref. (1) eq. (3.2.13) + ELSE ! + GX=-0.75E0_WP*SQR_PI*X3 + 1.5E0_WP*X2 - & ! + 0.75E0_WP*SQR_PI*(ONE+DLOG(TWO))*X + DLOG(X) + & ! ref. (1) eq. (3.2.13) + HALF*EUMAS + DLOG(THREE) + 0.411E0_WP ! + END IF ! +! + IF(TH_PROP == 'CLASS') THEN ! + P=ONE-HALF*THIRD*EPS*(ONE + EPS*( EUMAS - TWO*THIRD + & ! ref. (1) eq. (3.1.19) + HALF*DLOG(THREE*EPS) ) ) ! + ELSE ! + P=ONE-HALF*THIRD*EPS - FOURTH*THIRD*EPS*EPS*DLOG(EPS) - & ! + FOURTH*THIRD*EPS*EPS*( TWO*EUMAS + DLOG(THREE) - & ! ref. (1) eq. (3.2.12) + FOUR*THIRD + 12.0E0_WP*GX & ! + ) ! + END IF ! +! + F_FR=DLOG(N0*LAMBDA*LAMBDA*LAMBDA/E) - HALF*THIRD* ( & ! + EPS+EPS + EPS*EPS*( EUMAS - 11.0E0_WP/12.0E0_WP + & ! ref. (1) eq. (3.1.18) + HALF*DLOG(THREE*EPS) ) ) ! +! + U_IN=1.5E0_WP - HALF*( EPS + EPS*EPS*( EUMAS - TWO*THIRD + & ! ref. (1) eq. (3.1.16) + HALF*DLOG(THREE*EPS) ) ) ! +! +! Hansen's expansion +! + DEN1=DSQRT(B(1)+GAMMA) ! + DEN2=B(2)+GAMMA ! + DEN3=DSQRT(B(3)+GAMMA)**3 ! + DEN4=(B(4)+GAMMA)**2 ! +! + U_EX=DSQRT(GAMMA**3)*( A(1)/DEN1 + A(2)/DEN2 + & ! + A(3)/DEN3 + A(4)/DEN4 & ! + ) ! +! + END SUBROUTINE HIGH_T_THERMO_3D +! +!======================================================================= +! + SUBROUTINE THERMODYNAMICS_3D(EC_TYPE,RS,T,P,MU,K0,K,BM, & + U_IN,U_EX,F_FR) +! +! This subroutine computes thermodynamics properties (per electron) +! in the 3D system --> 3D +! +! References: (1) G. Giuliani and G. Vignale, "Quantum Theory of the +! Electron Liquid", Cambridge Uiversity Press (2005) +! (2) N. Iwamoto, Phys. Rev. A 30, 3289-3304 (1984) +! (3) S. Ichimaru, Rev. Mod. Phys. 54, 1017-1059 (1982) +! +! Input parameters: +! +! * EC_TYPE : type of correlation energy functional +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! Output parameters: +! +! * P : electron pressure in SI +! * MU : chemical potential in SI +! * K0 : compressibility (non-interacting) * n in SI +! * K : compressibility * n in SI +! * BM : bulk modulus in SI +! * U_IN : internal energy per electron in SI +! * U_EX : excess internal energy per electron / k_B T in SI +! * F_FR : Helmholtz free energy per electron in SI +! +! Note: We write the ground-state energy E = E_0 + E_X + E_C as +! +! E = E_HF + E_C +! +! and use eq. (2.56) of ref. (1) to compute the derivatives of E_HF +! +! E_HF = Ad / rs^2 - Bd / rs +! D_EHF_1 = -2 * Ad / rs^3 + Bd / rs^2 +! D_EHF_2 = 6 * Ad / rs^4 - 2 * Bd / rs^3 +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,SIX, & + HALF,THIRD,FOURTH + USE CONSTANTS_P1, ONLY : K_B + USE CONSTANTS_P2, ONLY : HARTREE + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : ALFA + USE PLASMA_SCALE + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP) :: RS,T + REAL (WP) :: P,MU,K0,K,U_IN,U_EX,F_FR + REAL (WP) :: C_3D,E_C,D_EC_1,D_EC_2,E_HF,D_EHF_1,D_EHF_2 + REAL (WP) :: ALPHA,A3,B3,RS2,RS3,RS4,BM + REAL (WP) :: NONID,DEGEN + REAL (WP) :: A0,B0,C0,D0,G4 +! + ALPHA=ALFA('3D') ! + A3=0.6E0_WP/ALPHA ! ref. (1) table (2.1) + B3=1.5E0_WP*PI_INV/ALPHA ! idem +! + RS2=RS*RS ! + RS3=RS2*RS ! + RS4=RS3*RS ! +! +! Computing the plasma scale parameters +! + CALL PLASMON_SCALE(RS,T,ONE,NONID,DEGEN) ! +! + G4=NONID**(FOURTH) ! +! +! Slattery-Doolen-DeWitt parameters ! ref (3) eq. (2.12) +! + A0=-0.89752E0_WP ! + B0= 0.94544E0_WP ! 1 < NONID < 160 + C0= 0.17954E0_WP ! + D0=-0.80049E0_WP ! +! +! Computing the correlation energy and its derivatives +! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! + E_C=EC_3D(EC_TYPE,1,RS,T)*HALF*HARTREE ! +! +! Computation of the derivatives of E_HF +! + E_HF = A3/RS2 - B3/RS ! + D_EHF_1=- TWO*A3/RS3 + B3/RS2 ! + D_EHF_2=- SIX*A3/RS4 - TWO*B3/RS3 ! +! + P=-THIRD*RS*(D_EHF_1+D_EC_1) * HALF*HARTREE ! ref. (1) eq. (1.137) + MU=E_HF+E_C + P ! ref. (1) eq. (1.138) + K0=1.5E0_WP*ALPHA*ALPHA*RS2 ! ref. (2) eq. (2.17) + BM=THIRD*RS*( THIRD*RS*(D_EHF_2+D_EC_2) - & ! + TWO*THIRD*RS*(D_EHF_1+D_EC_1) & ! ref. (1) eq. (1.139) + ) * HALF*HARTREE ! + K=ONE/BM ! ref. (1) eq. (1.140) +! + U_IN=K_B*T*(A0*NONID + B0*G4 + & ! ref. (3) eq. (2.8) + C0/G4 +D0 + 1.5E0_WP) ! and (2.11) + U_EX=A0*NONID + B0*G4 + C0/G4 + D0 ! ref. (3) eq. (2.11) + F_FR=K_B*T*(A0*NONID + FOUR*(B0*G4 - C0/G4) + & ! + (D0+THREE)*DLOG(NONID) - & ! ref. (3) eq. (2.14) + (A0+FOUR*B0-FOUR*C0+1.135E0_WP)) ! +! + END SUBROUTINE THERMODYNAMICS_3D +! +END MODULE THERMODYNAMIC_QUANTITIES diff --git a/New_libraries/DFM_library/PLASMON_LIBRARY/plasmon_dispersion.f90 b/New_libraries/DFM_library/PLASMON_LIBRARY/plasmon_dispersion.f90 new file mode 100644 index 0000000..c8f68bb --- /dev/null +++ b/New_libraries/DFM_library/PLASMON_LIBRARY/plasmon_dispersion.f90 @@ -0,0 +1,2081 @@ +! +!======================================================================= +! +MODULE PLASMON_DISP_REAL +! +! This module computes analytical plasmon dispersion without damping +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE PLASMON_DISP_R(X,RS,T,PL_DISP,ENE_P_Q) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : dimensionless factor +! * T : temperature in SI +! * PL_DISP : method used to compute the dispersion +! +! +! Output variables : +! +! * ENE_P_Q : plasmon energy at q in J +! +! +! Author : D. Sébilleau +! +! Last modified : 26 Oct 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: PL_DISP +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP), INTENT(OUT) :: ENE_P_Q +! + IF(DMN == '3D') THEN ! + CALL PLASMON_DISP_3D(X,RS,T,PL_DISP,ENE_P_Q) ! + ELSE IF(DMN == '2D') THEN ! + CALL PLASMON_DISP_2D(X,RS,T,PL_DISP,ENE_P_Q) ! + ELSE IF(DMN == '1D') THEN ! + CALL PLASMON_DISP_1D(X,RS,T,PL_DISP,ENE_P_Q) ! + END IF ! +! + END SUBROUTINE PLASMON_DISP_R +! +!======================================================================= +! + SUBROUTINE PLASMON_DISP_1D(X,RS,T,PL_DISP,ENE_P_Q) +! +! This subroutine computes the coefficients AR of the plasmon dispersion +! according to: +! +! ENE_Q^2 = AR(0) + AR(1)*Q + AR(2)*Q^2 + AR(3)*Q^3 + +! AR(4)*Q^4 + AR(5)*Q^5 + AR(6)*Q^6 +! +! = ALPHA2 + BETA2 * Q^2 + GAMMA2 * Q^4 + DELTA^2 Q^6 +! +! where Q = q/ k_F +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! Warnings: i) all input parameters are in SI units +! ii) in the literature, beta^2 and gamma^2 are given +! in atomic units (AU). Here, we work in SI. +! We recall: +! +! ENE : J --> energy +! Q : 1 / M --> wave vector +! V : M / S --> speed +! OMEGA : 1 / S --> angular momentum +! HBAR : J S --> Planck constant / 2 pi +! +! In order to obtain ENE_Q^2 in J^2, a dimension analysis +! shows that: +! +! BETA2_AU = COEF * V_F^2 --> BETA2_SI = HBAR^2 * BETA2_AU +! GAMMA2_AU = 1/4 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU / M^2 +! GAMMA2_AU = COEF * V_F^4 / OMEGA_P^2 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU +! +! Alternatively, we can work in atomic units and then change +! from Hartrees to Joules. This is what is coded here. +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * T : temperature in SI +! * PL_DISP : method used to compute the dispersion (3D) +! PL_DISP = 'HYDRODY' hydrodynamic model +! PL_DISP = 'RPA_MOD' RPA model +! +! +! Output variables : +! +! * ENE_P_Q : plasmon energy at q in J +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,TWO + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_AU, ONLY : KF_AU +! + USE DISP_COEF_REAL +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: PL_DISP +! +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP), INTENT(OUT) :: ENE_P_Q +! + REAL (WP) :: Q,Q2,Q3,Q4,Q5,Q6 + REAL (WP) :: ENE2 +! + REAL (WP) :: SQRT +! + INTEGER :: I +! +! + DO I = 0, 6 ! + AR(I) = ZERO ! initialization + END DO ! +! + Q = TWO * X * KF_AU ! q in AU + Q2 = Q * Q ! + Q3 = Q2 * Q ! powers of q + Q4 = Q3 * Q ! + Q5 = Q4 * Q ! + Q6 = Q5 * Q ! +! + IF(PL_DISP == 'HYDRODY') THEN ! + CALL HYDRODY_DP_1D(RS,T,Q,AR) ! + ELSE IF(PL_DISP == 'RPA_MOD') THEN ! + CALL RPA_MOD_DP_1D(RS,T,Q,AR) ! + END IF ! +! + ENE2 = AR(0) + AR(1) * Q + AR(2) * Q2 + AR(3) * Q3 + & !energy^2 in AU + AR(4) * Q4 + AR(5) * Q5 + AR(6) * Q6 ! +! + ENE_P_Q = SQRT(ENE2) ! plasmon energy at q in AU +! +! Change of units: AU --> SI +! + ENE_P_Q = ENE_P_Q * HARTREE ! +! + END SUBROUTINE PLASMON_DISP_1D +! +!======================================================================= +! + SUBROUTINE PLASMON_DISP_2D(X,RS,T,PL_DISP,ENE_P_Q) +! +! This subroutine computes the coefficients AR of the plasmon dispersion +! according to: +! +! ENE_Q^2 = AR(0) + AR(1)*Q + AR(2)*Q^2 + AR(3)*Q^3 + +! AR(4)*Q^4 + AR(5)*Q^5 + AR(6)*Q^6 +! +! = ALPHA2 + BETA2 * Q^2 + GAMMA2 * Q^4 + DELTA^2 Q^6 +! +! where Q = q/ k_F +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! Warnings: i) all input parameters are in SI units +! ii) in the literature, beta^2 and gamma^2 are given +! in atomic units (AU). Here, we work in SI. +! We recall: +! +! ENE : J --> energy +! Q : 1 / M --> wave vector +! V : M / S --> speed +! OMEGA : 1 / S --> angular momentum +! HBAR : J S --> Planck constant / 2 pi +! +! In order to obtain ENE_Q^2 in J^2, a dimension analysis +! shows that: +! +! BETA2_AU = COEF * V_F^2 --> BETA2_SI = HBAR^2 * BETA2_AU +! GAMMA2_AU = 1/4 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU / M^2 +! GAMMA2_AU = COEF * V_F^4 / OMEGA_P^2 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU +! +! Alternatively, we can work in atomic units and then change +! from Hartrees to Joules. This is what is coded here. +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * PL_DISP : method used to compute the dispersion (3D) +! PL_DISP = 'HYDRODY' hydrodynamic model +! PL_DISP = 'RPA_MOD' RPA model +! PL_DISP = 'RAJAGOP' Rajagopal formula +! +! +! Output variables : +! +! * ENE_P_Q : plasmon energy at q in J +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,TWO + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_AU, ONLY : KF_AU +! + USE DISP_COEF_REAL +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: PL_DISP +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP), INTENT(OUT) :: ENE_P_Q +! + REAL (WP) :: Q,Q2,Q3,Q4,Q5,Q6 + REAL (WP) :: ENE2 +! + REAL (WP) :: SQRT +! + INTEGER :: I +! + DO I = 0, 6 ! + AR(I) = ZERO ! initialization + END DO ! +! + Q = TWO * X * KF_AU ! q in AU + Q2 = Q * Q ! + Q3 = Q2 * Q ! powers of q + Q4 = Q3 * Q ! in AU + Q5 = Q4 * Q ! + Q6 = Q5 * Q ! +! + IF(PL_DISP == 'HYDRODY') THEN ! + CALL HYDRODY_DP_2D(X,RS,T,AR) ! + ELSE IF(PL_DISP == 'RPA_MOD') THEN ! + CALL RPA_MOD_DP_2D(X,RS,T,AR) ! + ELSE IF(PL_DISP == 'RAJAGOP') THEN ! + CALL RAJAGOP_DP_2D(X,RS,T,AR) ! + END IF ! +! + ENE2 = AR(0) + AR(1) * Q + AR(2) * Q2 + AR(3) * Q3 + & !energy^2 in AU + AR(4) * Q4 + AR(5) * Q5 + AR(6) * Q6 ! +! + ENE_P_Q = SQRT(ENE2) ! plasmon energy at q in AU +! +! Change of units: AU --> SI +! + ENE_P_Q = ENE_P_Q * HARTREE ! +! + END SUBROUTINE PLASMON_DISP_2D +! +!======================================================================= +! + SUBROUTINE PLASMON_DISP_3D(X,RS,T,PL_DISP,ENE_P_Q) +! +! This subroutine computes the coefficients AR of the plasmon dispersion +! according to: +! +! ENE_Q^2 = AR(0) + AR(1)*Q + AR(2)*Q^2 + AR(3)*Q^3 + +! AR(4)*Q^4 + AR(5)*Q^5 + AR(6)*Q^6 +! +! = ALPHA2 + BETA2 * Q^2 + GAMMA2 * Q^4 + DELTA^2 Q^6 (1) +! +! or +! +! ENE_Q = omega_p + 2 alpha omega_F q^2 / k_F^2 (2) +! +! where Q = q/ k_F +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! Warnings: i) all input parameters are in SI units +! ii) in the literature, beta^2 and gamma^2 are given +! in atomic units (AU). Here, we work in SI. +! We recall: +! +! ENE : J --> energy +! Q : 1 / M --> wave vector +! V : M / S --> speed +! OMEGA : 1 / S --> angular momentum +! HBAR : J S --> Planck constant / 2 pi +! +! In order to obtain ENE_Q^2 in J^2, a dimension analysis +! shows that: +! +! BETA2_AU = COEF * V_F^2 --> BETA2_SI = HBAR^2 * BETA2_AU +! GAMMA2_AU = 1/4 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU / M^2 +! GAMMA2_AU = COEF * V_F^4 / OMEGA_P^2 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU +! +! Alternatively, we can work in atomic units and then change +! from Hartrees to Joules. This is what is coded here. +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * PL_DISP : method used to compute the dispersion (3D) +! PL_DISP = 'ELASTIC' elastic model +! PL_DISP = 'GOA_MOD' Gorobchenko model +! PL_DISP = 'HER_APP' Hertel-Appel model <-- temperature-dependent +! PL_DISP = 'HUBBARD' Hubbard model +! PL_DISP = 'HYDRODY' hydrodynamic model +! PL_DISP = 'SGBBN_M' SGBBN model +! PL_DISP = 'RP1_MOD' RPA model up to q^2 +! PL_DISP = 'RP2_MOD' RPA model up to q^4 +! PL_DISP = 'AL0_MOD' gamma_0 limit +! PL_DISP = 'ALI_MOD' gamma_inf limit +! PL_DISP = 'NOP_MOD' Nozières-Pines model +! PL_DISP = 'UTI_MOD' Utsumi-Ichimaru model +! PL_DISP = 'TWA_MOD' Toigo-Woodruff model +! PL_DISP = 'SUM_RU2' f-sum rule sum_rule +! PL_DISP = 'SUM_RU3' 3rd-frequency sum_rule +! +! from Hartrees to Joules. This is what is coded here. +! +! Intermediate parameters: +! +! * I_SI : switch for unit of energy +! I_SI = 0 --> in AU unit +! I_SI = 1 --> in SI unit +! * I_SQ : switch for computation of E or E^2 +! I_SQ = 0 --> energy computed +! I_SQ = 1 --> energy^2 computed +! * I_FO : switch for formula used to compute energy +! I_FO = 1 --> formula (1) +! I_FO = 2 --> formula (2) +! +! +! Output variables : +! +! * ENE_P_Q : plasmon energy at q in J +! +! +! Author : D. Sébilleau +! +! Last modified : 7 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,TWO,THREE + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_AU, ONLY : KF_AU + USE LF_VALUES, ONLY : GQ_TYPE,IQ_TYPE + USE SF_VALUES, ONLY : SQ_TYPE + USE PLASMON_ENE_SI +! + USE DISP_COEF_REAL +! + USE OUT_VALUES_3, ONLY : I_ZE +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: PL_DISP +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP), INTENT(OUT) :: ENE_P_Q +! + REAL (WP) :: Q,Q2,Q3,Q4,Q5,Q6 + REAL (WP) :: ENE2,EN_P,C1,C2 +! + REAL (WP) :: SQRT +! + INTEGER :: CHANGE,I + INTEGER :: I_SI,I_SQ,I_FO +! + C1 = THREE / 32.0E0_WP ! coefficient for 'GOA_MOD' + CHANGE = 0 ! set to 1 only for 'GOA_MOD' +! + I_SI = 0 ! switch for energy computed in SI + I_SQ = 0 ! omega(q) computed [ not omega^2(q) ] + I_FO = 1 ! formula (1) used to compute energy +! + Q = TWO * X * KF_AU ! q in AU + Q2 = Q * Q ! + Q3 = Q2 * Q ! powers of q + Q4 = Q3 * Q ! + Q5 = Q4 * Q ! + Q6 = Q5 * Q ! +! +! Computing the plasmon energy in atomic units +! + EN_P = ENE_P_SI / HARTREE ! plasmon energy in AU +! + IF(PL_DISP == 'GOA_MOD') THEN ! + PL_DISP = 'RP1_MOD' ! + CHANGE = 1 ! + END IF ! +! + DO I = 0, 6 ! + AR(I) = ZERO ! initialization + END DO ! +! + IF(PL_DISP == 'ELASTIC') THEN ! + CALL ELASTIC_DP_3D(RS,T,AR) ! + I_SQ = 1 ! + ELSE IF(PL_DISP == ' EXACT') THEN ! + I_ZE = 1 ! post-processing calculation + ELSE IF(PL_DISP == 'HER_APP') THEN ! + CALL HER_APP_DP_3D(RS,T,AR) ! + I_SQ = 1 ! + ELSE IF(PL_DISP == 'HUBBARD') THEN ! + CALL HUBBARD_DP_3D(RS,T,AR) ! + I_SQ = 1 ! + ELSE IF(PL_DISP == 'HYDRODY') THEN ! + CALL HYDRODY_DP_3D(RS,T,AR) ! + I_SQ = 1 ! + ELSE IF(PL_DISP == 'RP2_MOD') THEN ! + CALL RP2_MOD_DP_3D(RS,T,AR) ! + I_SQ = 1 ! + ELSE IF(PL_DISP == 'SGBBN_M') THEN ! + CALL SGBBN_M_DP_3D(RS,T,AR) ! + I_SQ = 1 ! + ELSE IF(PL_DISP == 'SUM_RU2') THEN ! + CALL SUMRULE1_DP_3D(X,ENE2) ! + I_SQ = 1 ! + I_SI = 1 ! + I_FO = 2 ! + ELSE IF(PL_DISP == 'SUM_RU3') THEN ! + CALL SUMRULE3_DP_3D(X,ENE2) ! + I_SQ = 1 ! + I_SI = 1 ! + I_FO = 2 ! + ELSE ! + CALL PLASMON_DISP_3D_2(X,RS,T,PL_DISP,ENE_P_Q) ! + I_SI = 1 ! + I_FO = 2 ! + END IF ! +! + IF(I_FO == 1) THEN ! + ENE2 = AR(0) + AR(1) * Q + AR(2) * Q2 + AR(3) * Q3 + & !energy^2 in AU + AR(4) * Q4 + AR(5) * Q5 + AR(6) * Q6 ! + END IF ! +! + IF(I_SQ == 1) THEN ! + ENE_P_Q = SQRT(ENE2) ! + END IF ! +! + IF(CHANGE == 1) THEN ! + ENE_P_Q = ENE_P_Q / HARTREE - C1 * EN_P * Q2 ! 'GOA_MOD' case + PL_DISP = 'GOA_MOD' ! + CHANGE = 0 ! + I_SI = 0 ! + I_SQ = 0 ! + I_FO = 1 ! + END IF ! +! +! Change of units: AU --> SI +! + IF(I_SI == 0) THEN ! + ENE_P_Q = ENE_P_Q * HARTREE ! + END IF ! +! + END SUBROUTINE PLASMON_DISP_3D +! +!======================================================================= +! + SUBROUTINE ELASTIC_DP_3D(R_S,T,AD) +! +! This subroutine computes the coefficients of the plasmon dispersion +! within the elastic approach in 3D systems according to: +! +! ENE_Q^2 = AD(0) + AD(1)*Q + AD(2)*Q^2 + AD(3)*Q^3 + +! AD(4)*Q^4 + AD(5)*Q^5 + AD(6)*Q^6 +! +! = ALPHA2 + BETA2 * Q^2 + GAMMA2 * Q^4 + DELTA^2 Q^6 +! +! where Q = q/ k_F +! +! +! References: (1) Ll. Serra, F. Garcias, M. Barranco, N. Barberan +! and J. Navarro, Phys. Rev. B 44, 1492-1498 (1991) +! +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! Warnings: i) all input parameters are in SI units +! ii) in the literature, beta^2 and gamma^2 are given +! in atomic units (AU). Here, we work in SI. +! We recall: +! +! ENE : J --> energy +! Q : 1 / M --> wave vector +! V : M / S --> speed +! OMEGA : 1 / S --> angular momentum +! HBAR : J S --> Planck constant / 2 pi +! +! In order to obtain ENE_Q^2 in J^2, a dimension analysis +! shows that: +! +! BETA2_AU = COEF * V_F^2 --> BETA2_SI = HBAR^2 * BETA2_AU +! GAMMA2_AU = 1/4 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU / M^2 +! GAMMA2_AU = COEF * V_F^4 / OMEGA_P^2 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU +! +! Alternatively, we can work in atomic units and then change +! from Hartrees to Joules. This is what is coded here. +! +! Input parameters: +! +! * R_S : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Output variables : +! +! * AD(0:6) : coefficients of the squared dispersion in AU +! +! +! Author : D. Sébilleau +! +! Last modified : 7 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,NINE,THREE,FOURTH + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_AU, ONLY : VF_AU + USE PI_ETC, ONLY : PI + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: R_S,T + REAL (WP), INTENT(OUT) :: AD(0:6) +! + REAL (WP) :: HAR2,VF2,RS + REAL (WP) :: DENOM,XI +! + INTEGER :: I +! +! Initialisations +! + DO I = 0, 6 ! + AD(I) = ZERO ! + END DO ! +! + HAR2 = HARTREE * HARTREE ! + RS = R_S ! rs in AU + VF2 = VF_AU * VF_AU ! v_F^2 in AU + DENOM = NINE * (7.8E0_WP + RS)**3 ! + XI = 0.88E0_WP * RS * (7.80E0_WP + RS + RS) / DENOM ! +! +! Coefficients in AU +! + AD(0) = ENE_P_SI * ENE_P_SI / HAR2 ! + AD(2) = (0.60E0_WP * VF2 - VF_AU / (THREE * PI) - XI) ! ref. (1) eq. (6) + AD(4) = FOURTH ! +! + END SUBROUTINE ELASTIC_DP_3D +! +!======================================================================= +! + SUBROUTINE HER_APP_DP_3D(RS,T,AD) +! +! This subroutine computes the coefficients of the plasmon dispersion +! within the Hertel-Appel approach in 3D systems according to: +! +! ENE_Q^2 = AD(0) + AD(1)*Q + AD(2)*Q^2 + AD(3)*Q^3 + +! AD(4)*Q^4 + AD(5)*Q^5 + AD(6)*Q^6 +! +! = ALPHA2 + BETA2 * Q^2 + GAMMA2 * Q^4 + DELTA^2 Q^6 +! +! where Q = q/ k_F +! +! +! References: (1) P. Hertel and J. Appel, Phys. Rev. B 26, 5730-5742 (1982) +! +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! Warnings: i) all input parameters are in SI units +! ii) in the literature, beta^2 and gamma^2 are given +! in atomic units (AU). Here, we work in SI. +! We recall: +! +! ENE : J --> energy +! Q : 1 / M --> wave vector +! V : M / S --> speed +! OMEGA : 1 / S --> angular momentum +! HBAR : J S --> Planck constant / 2 pi +! +! In order to obtain ENE_Q^2 in J^2, a dimension analysis +! shows that: +! +! BETA2_AU = COEF * V_F^2 --> BETA2_SI = HBAR^2 * BETA2_AU +! GAMMA2_AU = 1/4 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU / M^2 +! GAMMA2_AU = COEF * V_F^4 / OMEGA_P^2 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU +! +! Alternatively, we can work in atomic units and then change +! from Hartrees to Joules. This is what is coded here. +! +! Input parameters: +! +! * R_S : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Output variables : +! +! * AD(0:6) : coefficients of the squared dispersion in AU +! +! +! Author : D. Sébilleau +! +! Last modified : 7 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,THREE,SIX,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE CONSTANTS_P2, ONLY : HARTREE + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP), INTENT(OUT) :: AD(0:6) +! + REAL (WP) :: KBT,H2M + REAL (WP) :: HAR2,EN_P2 +! + INTEGER :: I +! +! Initialisations ! +! + DO I = 0, 6 ! + AD(I) = ZERO ! + END DO ! +! + KBT = K_B * T / HARTREE ! k_B T in AU +! + HAR2 = HARTREE * HARTREE ! +! + EN_P2 = ENE_P_SI * ENE_P_SI / HAR2 ! (plasmon energy)^2 in AU +! +! Coefficients in AU +! + AD(0) = EN_P2 ! + AD(2) = THREE * KBT ! +! + END SUBROUTINE HER_APP_DP_3D +! +!======================================================================= +! + SUBROUTINE HUBBARD_DP_3D(RS,T,AD) +! +! This subroutine computes the coefficients of the plasmon dispersion +! within the Hubbard approach in 3D systems according to: +! +! ENE_Q^2 = AD(0) + AD(1)*Q + AD(2)*Q^2 + AD(3)*Q^3 + +! AD(4)*Q^4 + AD(5)*Q^5 + AD(6)*Q^6 +! +! = ALPHA2 + BETA2 * Q^2 + GAMMA2 * Q^4 + DELTA^2 Q^6 +! +! where Q = q/ k_F +! +! +! References: (1) P. Jewsbury, Aust. J. Phys. 32, 361-368 (1979) +! +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! Warnings: i) all input parameters are in SI units +! ii) in the literature, beta^2 and gamma^2 are given +! in atomic units (AU). Here, we work in SI. +! We recall: +! +! ENE : J --> energy +! Q : 1 / M --> wave vector +! V : M / S --> speed +! OMEGA : 1 / S --> angular momentum +! HBAR : J S --> Planck constant / 2 pi +! +! In order to obtain ENE_Q^2 in J^2, a dimension analysis +! shows that: +! +! BETA2_AU = COEF * V_F^2 --> BETA2_SI = HBAR^2 * BETA2_AU +! GAMMA2_AU = 1/4 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU / M^2 +! GAMMA2_AU = COEF * V_F^4 / OMEGA_P^2 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU +! +! Alternatively, we can work in atomic units and then change +! from Hartrees to Joules. This is what is coded here. +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Output variables : +! +! * AD(0:6) : coefficients of the squared dispersion in AU +! +! +! Author : D. Sébilleau +! +! Last modified : 7 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,NINE,THIRD,FOURTH + USE CONSTANTS_P1, ONLY : BOHR,H_BAR + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_AU, ONLY : KF_AU,VF_AU + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP), INTENT(OUT) :: AD(0:6) +! + REAL (WP) :: HAR2 + REAL (WP) :: VF2,VF4,KF2,KF4 + REAL (WP) :: OMP2,G1,G2 +! + INTEGER :: I +! +! Initialisations ! +! + DO I = 0, 6 ! + AD(I) = ZERO ! + END DO ! +! + HAR2 = HARTREE * HARTREE ! +! + VF2 = VF_AU * VF_AU ! v_F^2 in AU + VF4 = VF2 * VF2 ! v_F^4 in AU + KF2 = KF_AU * KF_AU ! k_F^2 in AU + KF4 = KF2 * KF2 ! k_F^4 in AU +! + OMP2 = ENE_P_SI * ENE_P_SI / HAR2 ! omega_p^2 in AU +! + G1 = FOURTH + 0.00636E0_WP * RS ! ref. (1) eq. (16) + G2 = - 0.0391E0_WP + 0.00248E0_WP * RS ! ref. (1) eq. (16) +! +! Coefficients in AU +! + AD(0) = OMP2 ! + AD(2) = 0.60E0_WP * VF2 - G1 * OMP2 / KF2 ! ref. (1) eq. (18) + AD(4) = FOURTH + 12.0E0_WP * VF4 / (175.0E0_WP * OMP2) - & ! + OMP2 * (G2 + G1 * G1) / KF4 ! ref. (1) eq. (18) +! + END SUBROUTINE HUBBARD_DP_3D +! +!======================================================================= +! + SUBROUTINE HYDRODY_DP_1D(RS,T,Q_SI,AD) +! +! This subroutine computes the coefficients of the plasmon dispersion +! within the hydrodynamic approach in 1D systems according to: +! +! ENE_Q^2 = AD(0) + AD(1)*Q + AD(2)*Q^2 + AD(3)*Q^3 + +! AD(4)*Q^4 + AD(5)*Q^5 + AD(6)*Q^6 +! +! = ALPHA2 + BETA2 * Q^2 + GAMMA2 * Q^4 + DELTA^2 Q^6 +! +! where Q = q/ k_F +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! Warnings: i) all input parameters are in SI units +! ii) in the literature, beta^2 and gamma^2 are given +! in atomic units (AU). Here, we work in SI. +! We recall: +! +! ENE : J --> energy +! Q : 1 / M --> wave vector +! V : M / S --> speed +! OMEGA : 1 / S --> angular momentum +! HBAR : J S --> Planck constant / 2 pi +! +! In order to obtain ENE_Q^2 in J^2, a dimension analysis +! shows that: +! +! BETA2_AU = COEF * V_F^2 --> BETA2_SI = HBAR^2 * BETA2_AU +! GAMMA2_AU = 1/4 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU / M^2 +! GAMMA2_AU = COEF * V_F^4 / OMEGA_P^2 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU +! +! Alternatively, we can work in atomic units and then change +! from Hartrees to Joules. This is what is coded here. +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * Q_SI : plasmon wave vector in 1/m +! +! Output variables : +! +! * AD(0:6) : coefficients of the squared dispersion in AU +! +! +! Author : D. Sébilleau +! +! Last modified : 28 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,TWO,THIRD + USE CONSTANTS_P1, ONLY : BOHR + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_AU, ONLY : VF_AU + USE CONFIN_VAL, ONLY : R0 + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP) :: RS,T,Q_SI + REAL (WP) :: HAR2,Q,QR0,EN_P2,VF2 + REAL (WP) :: AD(0:6) +! + INTEGER :: I +! +! Initialisations +! + DO I=0,6 ! + AD(I)=ZERO ! + END DO ! +! + HAR2=HARTREE*HARTREE ! + Q=Q_SI*BOHR ! q in atomic units + QR0=Q*R0 ! + VF2=VF_AU*VF_AU ! v_F^2 in AU +! + EN_P2=ENE_P_SI*ENE_P_SI/HAR2 ! (plasmon energy)^2 in AU +! +! Coefficients in AU +! + AD(2)=EN_P2*(DLOG(TWO/QR0)+ & ! + THIRD*VF2) ! +! + END SUBROUTINE HYDRODY_DP_1D +! +!======================================================================= +! + SUBROUTINE HYDRODY_DP_2D(X,RS,T,AD) +! +! This subroutine computes the coefficients of the plasmon dispersion +! within the hydrodynamic approach in 2D systems according to: +! +! ENE_Q^2 = AD(0) + AD(1)*Q + AD(2)*Q^2 + AD(3)*Q^3 + +! AD(4)*Q^4 + AD(5)*Q^5 + AD(6)*Q^6 +! +! = ALPHA2 + BETA2 * Q^2 + GAMMA2 * Q^4 + DELTA^2 Q^6 +! +! where Q = q/ k_F +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! Warnings: i) all input parameters are in SI units +! ii) in the literature, beta^2 and gamma^2 are given +! in atomic units (AU). Here, we work in SI. +! We recall: +! +! ENE : J --> energy +! Q : 1 / M --> wave vector +! V : M / S --> speed +! OMEGA : 1 / S --> angular momentum +! HBAR : J S --> Planck constant / 2 pi +! +! In order to obtain ENE_Q^2 in J^2, a dimension analysis +! shows that: +! +! BETA2_AU = COEF * V_F^2 --> BETA2_SI = HBAR^2 * BETA2_AU +! GAMMA2_AU = 1/4 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU / M^2 +! GAMMA2_AU = COEF * V_F^4 / OMEGA_P^2 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU +! +! Alternatively, we can work in atomic units and then change +! from Hartrees to Joules. This is what is coded here. +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Output variables : +! +! * AD(0:6) : coefficients of the squared dispersion in AU +! +! +! Author : D. Sébilleau +! +! Last modified : 28 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,HALF + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_AU, ONLY : VF_AU + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP) :: X,RS,T + REAL (WP) :: HAR2 + REAL (WP) :: AD(0:6) +! + INTEGER :: I +! +! Initialisations +! + DO I = 0, 6 ! + AD(I)=ZERO ! + END DO ! +! + HAR2=HARTREE*HARTREE ! +! +! Coefficients in AU +! + AD(0)=ENE_P_SI*ENE_P_SI/HAR2 ! + AD(2)=HALF*VF_AU*VF_AU ! +! + END SUBROUTINE HYDRODY_DP_2D +! +!======================================================================= +! + SUBROUTINE HYDRODY_DP_3D(RS,T,AD) +! +! This subroutine computes the coefficients of the plasmon dispersion +! within the hydrodynamic approach in 3D systems according to: +! +! ENE_Q^2 = AD(0) + AD(1)*Q + AD(2)*Q^2 + AD(3)*Q^3 + +! AD(4)*Q^4 + AD(5)*Q^5 + AD(6)*Q^6 +! +! = ALPHA2 + BETA2 * Q^2 + GAMMA2 * Q^4 + DELTA^2 Q^6 +! +! where Q = q/ k_F +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! Warnings: i) all input parameters are in SI units +! ii) in the literature, beta^2 and gamma^2 are given +! in atomic units (AU). Here, we work in SI. +! We recall: +! +! ENE : J --> energy +! Q : 1 / M --> wave vector +! V : M / S --> speed +! OMEGA : 1 / S --> angular momentum +! HBAR : J S --> Planck constant / 2 pi +! +! In order to obtain ENE_Q^2 in J^2, a dimension analysis +! shows that: +! +! BETA2_AU = COEF * V_F^2 --> BETA2_SI = HBAR^2 * BETA2_AU +! GAMMA2_AU = 1/4 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU / M^2 +! GAMMA2_AU = COEF * V_F^4 / OMEGA_P^2 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU +! +! Alternatively, we can work in atomic units and then change +! from Hartrees to Joules. This is what is coded here. +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Output variables : +! +! * AD(0:6) : coefficients of the squared dispersion in AU +! +! +! Author : D. Sébilleau +! +! Last modified : 28 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,THIRD,FOURTH + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_AU, ONLY : VF_AU + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP), INTENT(OUT) :: AD(0:6) +! + REAL (WP) :: HAR2 +! + INTEGER :: I +! +! Initialisations +! + DO I = 0, 6 ! + AD(I) = ZERO ! + END DO ! +! + HAR2 = HARTREE * HARTREE ! +! +! Coefficients in AU +! + AD(0) = ENE_P_SI * ENE_P_SI / HAR2 ! + AD(2) = THIRD * VF_AU * VF_AU ! + AD(4) = FOURTH ! +! + END SUBROUTINE HYDRODY_DP_3D +! +!======================================================================= +! + SUBROUTINE RPA_MOD_DP_1D(RS,T,Q_SI,AD) +! +! This subroutine computes the coefficients of the plasmon dispersion +! within the RPA approach in 1D systems according to: +! +! ENE_Q^2 = AD(0) + AD(1)*Q + AD(2)*Q^2 + AD(3)*Q^3 + +! AD(4)*Q^4 + AD(5)*Q^5 + AD(6)*Q^6 +! +! = ALPHA2 + BETA2 * Q^2 + GAMMA2 * Q^4 + DELTA^2 Q^6 +! +! where Q = q/ k_F +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! Warnings: i) all input parameters are in SI units +! ii) in the literature, beta^2 and gamma^2 are given +! in atomic units (AU). Here, we work in SI. +! We recall: +! +! ENE : J --> energy +! Q : 1 / M --> wave vector +! V : M / S --> speed +! OMEGA : 1 / S --> angular momentum +! HBAR : J S --> Planck constant / 2 pi +! +! In order to obtain ENE_Q^2 in J^2, a dimension analysis +! shows that: +! +! BETA2_AU = COEF * V_F^2 --> BETA2_SI = HBAR^2 * BETA2_AU +! GAMMA2_AU = 1/4 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU / M^2 +! GAMMA2_AU = COEF * V_F^4 / OMEGA_P^2 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU +! +! Alternatively, we can work in atomic units and then change +! from Hartrees to Joules. This is what is coded here. +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * Q_SI : plasmon wave vector in 1/m +! +! Output variables : +! +! * AD(0:6) : coefficients of the squared dispersion in AU +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,TWO + USE CONSTANTS_P1, ONLY : BOHR + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_AU, ONLY : VF_AU + USE CONFIN_VAL, ONLY : R0 + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS,T,Q_SI + REAL (WP), INTENT(OUT) :: AD(0:6) +! + REAL (WP) :: HAR2,Q,QR0,EN_P2,VF2 +! + REAL (WP) :: LOG +! + INTEGER :: I +! +! Initialisations +! + DO I = 0,6 ! + AD(I) = ZERO ! + END DO ! +! + HAR2 = HARTREE * HARTREE ! +! + VF2 = VF_AU * VF_AU ! v_F^2 in AU + Q = Q_SI * BOHR ! q in atomic units + QR0 = Q * R0 ! +! + EN_P2 = ENE_P_SI * ENE_P_SI / HAR2 ! (plasmon energy)^2 in AU +! +! Coefficients in AU +! + AD(2) = EN_P2 * ( DLOG(TWO / QR0) + VF2 ) ! +! + END SUBROUTINE RPA_MOD_DP_1D +! +!======================================================================= +! + SUBROUTINE RPA_MOD_DP_2D(X,RS,T,AD) +! +! This subroutine computes the coefficients of the plasmon dispersion +! within the RPA approach in 2D systems according to: +! +! ENE_Q^2 = AD(0) + AD(1)*Q + AD(2)*Q^2 + AD(3)*Q^3 + +! AD(4)*Q^4 + AD(5)*Q^5 + AD(6)*Q^6 +! +! = ALPHA2 + BETA2 * Q^2 + GAMMA2 * Q^4 + DELTA^2 Q^6 +! +! where Q = q/ k_F +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! Warnings: i) all input parameters are in SI units +! ii) in the literature, beta^2 and gamma^2 are given +! in atomic units (AU). Here, we work in SI. +! We recall: +! +! ENE : J --> energy +! Q : 1 / M --> wave vector +! V : M / S --> speed +! OMEGA : 1 / S --> angular momentum +! HBAR : J S --> Planck constant / 2 pi +! +! In order to obtain ENE_Q^2 in J^2, a dimension analysis +! shows that: +! +! BETA2_AU = COEF * V_F^2 --> BETA2_SI = HBAR^2 * BETA2_AU +! GAMMA2_AU = 1/4 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU / M^2 +! GAMMA2_AU = COEF * V_F^4 / OMEGA_P^2 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU +! +! Alternatively, we can work in atomic units and then change +! from Hartrees to Joules. This is what is coded here. +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Output variables : +! +! * AD(0:6) : coefficients of the squared dispersion in AU +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,TWO + USE CONSTANTS_P1, ONLY : M_E + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_SI, ONLY : KF_SI + USE FERMI_AU, ONLY : VF_AU + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP), INTENT(OUT) :: AD(0:6) +! + REAL (WP) :: Q_SI + REAL (WP) :: HAR2,EN_P2,VF2 +! + INTEGER :: I +! +! Initialisations +! + DO I = 0, 6 ! + AD(I) = ZERO ! + END DO ! +! + HAR2 = HARTREE * HARTREE ! +! + Q_SI = TWO * X * KF_SI ! +! + EN_P2 = ENE_P_SI * ENE_P_SI * Q_SI / HAR2 ! +! + VF2 = VF_AU * VF_AU ! +! +! Coefficients in AU +! + AD(0) = EN_P2 ! + AD(2) = 0.75E0_WP * VF2 ! +! + END SUBROUTINE RPA_MOD_DP_2D +! +!======================================================================= +! + SUBROUTINE RAJAGOP_DP_2D(X,RS,T,AD) +! +! This subroutine computes the coefficients of the plasmon dispersion +! within the Rajagopal approach in 2D systems according to: +! +! ENE_Q^2 = AD(0) + AD(1)*Q + AD(2)*Q^2 + AD(3)*Q^3 + +! AD(4)*Q^4 + AD(5)*Q^5 + AD(6)*Q^6 +! +! = ALPHA2 + BETA2 * Q^2 + GAMMA2 * Q^4 + DELTA^2 Q^6 +! +! where Q = q/ k_F +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! Warnings: i) all input parameters are in SI units +! ii) in the literature, beta^2 and gamma^2 are given +! in atomic units (AU). Here, we work in SI. +! We recall: +! +! ENE : J --> energy +! Q : 1 / M --> wave vector +! V : M / S --> speed +! OMEGA : 1 / S --> angular momentum +! HBAR : J S --> Planck constant / 2 pi +! +! In order to obtain ENE_Q^2 in J^2, a dimension analysis +! shows that: +! +! BETA2_AU = COEF * V_F^2 --> BETA2_SI = HBAR^2 * BETA2_AU +! GAMMA2_AU = 1/4 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU / M^2 +! GAMMA2_AU = COEF * V_F^4 / OMEGA_P^2 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU +! +! Alternatively, we can work in atomic units and then change +! from Hartrees to Joules. This is what is coded here. +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Output variables : +! +! * AD(0:6) : coefficients of the squared dispersion in AU +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,NINE,TEN + USE PI_ETC, ONLY : PI + USE SQUARE_ROOTS, ONLY : SQR2 + USE CONSTANTS_P1, ONLY : M_E + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_SI, ONLY : KF_SI + USE FERMI_AU, ONLY : VF_AU + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP), INTENT(OUT) :: AD(0:6) +! + REAL (WP) :: Q_SI + REAL (WP) :: HAR2,EN_P2,VF2 +! + INTEGER :: I +! +! Initialisations +! + DO I = 0, 6 ! + AD(I) = ZERO ! + END DO ! +! + HAR2 = HARTREE * HARTREE ! +! + Q_SI = TWO * X * KF_SI ! +! + EN_P2 = ENE_P_SI * ENE_P_SI * Q_SI / HAR2 ! +! + VF2 = VF_AU * VF_AU ! +! +! Coefficients in AU +! + AD(0) = EN_P2 ! + AD(2) = EN_P2 * ( THREE * SQR2 / (FOUR * RS) ) * ( & ! + ONE - TEN * RS / (NINE * SQR2 * PI) ) ! +! + END SUBROUTINE RAJAGOP_DP_2D +! +!======================================================================= +! + SUBROUTINE RP2_MOD_DP_3D(RS,T,AD) +! +! This subroutine computes the coefficients of the plasmon dispersion +! within the RPA approach in 3D systems according to: +! +! ENE_Q^2 = AD(0) + AD(1)*Q + AD(2)*Q^2 + AD(3)*Q^3 + +! AD(4)*Q^4 + AD(5)*Q^5 + AD(6)*Q^6 +! +! = ALPHA2 + BETA2 * Q^2 + GAMMA2 * Q^4 + DELTA^2 Q^6 +! +! where Q = q/ k_F +! +! +! References: (1) Ll. Serra, F. Garcias, M. Barranco, N. Barberan +! and J. Navarro, Phys. Rev. B 44, 1492-1498 (1991) +! +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! Warnings: i) all input parameters are in SI units +! ii) in the literature, beta^2 and gamma^2 are given +! in atomic units (AU). Here, we work in SI. +! We recall: +! +! ENE : J --> energy +! Q : 1 / M --> wave vector +! V : M / S --> speed +! OMEGA : 1 / S --> angular momentum +! HBAR : J S --> Planck constant / 2 pi +! +! In order to obtain ENE_Q^2 in J^2, a dimension analysis +! shows that: +! +! BETA2_AU = COEF * V_F^2 --> BETA2_SI = HBAR^2 * BETA2_AU +! GAMMA2_AU = 1/4 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU / M^2 +! GAMMA2_AU = COEF * V_F^4 / OMEGA_P^2 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU +! +! Alternatively, we can work in atomic units and then change +! from Hartrees to Joules. This is what is coded here. +! +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Output variables : +! +! * AD(0:6) : coefficients of the squared dispersion in AU +! +! +! Author : D. Sébilleau +! +! Last modified : 28 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,FOURTH + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_AU, ONLY : VF_AU + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP), INTENT(OUT) :: AD(0:6) +! + REAL (WP) :: HAR2,VF2,VF4 + REAL (WP) :: EN_P2 +! + INTEGER :: I +! +! Initialisations +! + DO I = 0, 6 ! + AD(I) = ZERO ! + END DO ! +! + HAR2 = HARTREE * HARTREE ! +! + VF2 = VF_AU * VF_AU ! + VF4 = VF2 * VF2 ! +! + EN_P2 = ENE_P_SI * ENE_P_SI / HAR2 ! +! +! Coefficients in AU +! + AD(0) = EN_P2 ! + AD(2) = 0.60E0_WP * VF2 ! + AD(4) = FOURTH + 12.0E0_WP * VF4 / (175.0E0_WP * EN_P2) ! +! + END SUBROUTINE RP2_MOD_DP_3D +! +!======================================================================= +! + SUBROUTINE SGBBN_M_DP_3D(R_S,T,AD) +! +! This subroutine computes the coefficients of the plasmon dispersion +! within the SGBBN_M_DISP_3D approach in 3D systems according to: +! +! ENE_Q^2 = AD(0) + AD(1)*Q + AD(2)*Q^2 + AD(3)*Q^3 + +! AD(4)*Q^4 + AD(5)*Q^5 + AD(6)*Q^6 +! +! = ALPHA2 + BETA2 * Q^2 + GAMMA2 * Q^4 + DELTA^2 Q^6 +! +! where Q = q/ k_F +! +! +! References: (1) Ll. Serra, F. Garcias, M. Barranco, N. Barberan +! and J. Navarro, Phys. Rev. B 44, 1492-1498 (1991) +! +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! Warnings: i) all input parameters are in SI units +! ii) in the literature, beta^2 and gamma^2 are given +! in atomic units (AU). Here, we work in SI. +! We recall: +! +! ENE : J --> energy +! Q : 1 / M --> wave vector +! V : M / S --> speed +! OMEGA : 1 / S --> angular momentum +! HBAR : J S --> Planck constant / 2 pi +! +! In order to obtain ENE_Q^2 in J^2, a dimension analysis +! shows that: +! +! BETA2_AU = COEF * V_F^2 --> BETA2_SI = HBAR^2 * BETA2_AU +! GAMMA2_AU = 1/4 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU / M^2 +! GAMMA2_AU = COEF * V_F^4 / OMEGA_P^2 --> GAMMA2_SI = HBAR^2 * GAMMA2_AU +! +! Alternatively, we can work in atomic units and then change +! from Hartrees to Joules. This is what is coded here. +! +! Input parameters: +! +! * R_S : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! Output variables : +! +! * AD(0:6) : coefficients of the squared dispersion in AU +! +! +! Author : D. Sébilleau +! +! Last modified : 8 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,THREE,NINE, & + THIRD,FOURTH,NINTH + USE CONSTANTS_P1, ONLY : BOHR + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_AU, ONLY : KF_AU,VF_AU + USE PI_ETC, ONLY : PI + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: R_S,T + REAL (WP), INTENT(OUT) :: AD(0:6) +! + REAL (WP) :: HAR2,VF2,RS + REAL (WP) :: DENOM,XI + REAL (WP) :: BETA +! + INTEGER :: I +! + BETA = NINTH ! Weizsacker coefficient +! +! Initialisations +! + DO I = 0, 6 ! + AD(I) = ZERO ! + END DO ! +! + HAR2 = HARTREE * HARTREE ! + RS = R_S ! rs in AU + VF2 = VF_AU * VF_AU ! v_F^2 in AU + DENOM = NINE * (7.8E0_WP+RS)**3 ! + XI = 0.88E0_WP * RS * (7.80E0_WP + RS + RS) / DENOM ! +! +! Coefficients in AU +! + AD(0) = ENE_P_SI * ENE_P_SI / HAR2 ! + AD(2) = (THIRD * VF2 - VF_AU / (THREE * PI) - XI) ! + AD(4) = FOURTH * BETA ! + AD(6) = ONE / (270.0E0_WP * VF2) ! +! + END SUBROUTINE SGBBN_M_DP_3D +! +!======================================================================= +! + SUBROUTINE SUMRULE1_DP_3D(X,OM12) +! +! This subroutine computes the coefficients of the plasmon dispersion +! within the 3rd-frequency sum rule approach in 3D systems. +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! Output variables : +! +! * OM12 : squared dispersion frequency in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Nov 2020 +! +! + USE CONSTANTS_P1, ONLY : H_BAR + USE LOSS_MOMENTS +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP), INTENT(OUT) :: OM12 +! + REAL (WP) :: C0,C2,C4 +! +! Computing the moments of the loss function +! + CALL LOSS_MOMENTS_AN(X,C0,C2,C4) ! +! +! Squared energy in SI +! + OM12 = H_BAR * H_BAR * C2 / C0 ! +! + END SUBROUTINE SUMRULE1_DP_3D +! +!======================================================================= +! + SUBROUTINE SUMRULE3_DP_3D(X,OM22) +! +! This subroutine computes the coefficients of the plasmon dispersion +! within the 3rd-frequency sum rule approach in 3D systems. +! +! --> This is the real (q, hbar omega_q) case (no damping) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! Output variables : +! +! * OM22 : squared dispersion frequency in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Nov 2020 +! +! + USE CONSTANTS_P1, ONLY : H_BAR + USE LOSS_MOMENTS +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP), INTENT(OUT) :: OM22 +! + REAL (WP) :: C0,C2,C4 +! +! Computing the moments of the loss function +! + CALL LOSS_MOMENTS_AN(X,C0,C2,C4) ! +! +! Squared energy in SI +! + OM22 = H_BAR * H_BAR * C4 / C2 ! +! + END SUBROUTINE SUMRULE3_DP_3D +! +!======================================================================= +! + SUBROUTINE PLASMON_DISP_3D_2(X,RS,T,PL_DISP,ENE_P_Q) +! +! This subroutine computes the plasmon dispersion omega(q) +! in the form +! +! Reference: (1) S. Ichimaru, Rev. Mod. Phys. 54, 1018-1059 (1982) +! +! +! 2 +! ( q ) +! omega(q) = omega_p + 2 alpha omega_F ( ----- ) +! ( k_F ) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * PL_DISP : method used to compute the dispersion (3D) +! PL_DISP = 'RP1_MOD' RPA model up to q^2 +! PL_DISP = 'AL0_MOD' gamma_0 limit +! PL_DISP = 'ALI_MOD' gamma_inf limit +! PL_DISP = 'NOP_MOD' Nozières-Pines model +! PL_DISP = 'UTI_MOD' Utsumi-Ichimaru model +! PL_DISP = 'TWA_MOD' Toigo-Woodruff model +! +! +! Output variables : +! +! * ENE_P_Q : plasmon energy at q in J +! +! +! Author : D. Sébilleau +! +! Last modified : 7 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOURTH,FIFTH + USE SQUARE_ROOTS, ONLY : SQR2 + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : EF_SI + USE PLASMON_ENE_SI + USE UTIC_PARAMETERS, ONLY : UTIC_PARAM + USE ASYMPT, ONLY : G0,GI + USE EXT_FUNCTIONS, ONLY : PDF ! Plasma dispersion function Z(x) +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: PL_DISP +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP), INTENT(OUT) :: ENE_P_Q +! + REAL (WP) :: Y + REAL (WP) :: OMP,OMF,RPF,RFP + REAL (WP) :: AL_RPA,ALPHA + REAL (WP) :: OMQ,OM0 + REAL (WP) :: R1,R2,W +! + Y = X + X ! Y = q / k_F +! + OMP = ENE_P_SI / H_BAR ! omega_p in SI + OMF = EF_SI / H_BAR ! omega_F in SI + RPF = OMP / OMF ! + RFP = OMF / OMP ! +! +! Computing alpha +! + AL_RPA = THREE * FIFTH * RFP ! +! + IF(PL_DISP == 'RP1_MOD') THEN ! + ALPHA = AL_RPA ! ref. (1) eq. (3.97) + ELSE IF(PL_DISP == 'AL0_MOD') THEN ! + ALPHA = AL_RPA - FOURTH * RPF * G0 ! ref. (1) eq. (3.98) + ELSE IF(PL_DISP == 'ALI_MOD') THEN ! + ALPHA = AL_RPA - FOURTH * RPF * GI ! ref. (1) eq. (3.100) + ELSE IF(PL_DISP == 'NOP_MOD') THEN ! + ALPHA = AL_RPA - THREE * RPF / 80.0E0_WP ! ref. (1) eq. (3.101) + ELSE IF(PL_DISP == 'UTI_MOD') THEN ! +! +! Computing the Utsumi-Ichimaru parameters Omega(q) and Omega(0) +! + CALL UTIC_PARAM(X,RS,T,OMQ,OM0) ! +! + R1 = OMP / OM0 ! argument of W + R2 = R1 / SQR2 ! argument of Z +! +! Computing the W function +! + W = ONE + R1 * REAL(PDF(R2),KIND = WP) ! +! + ALPHA = AL_RPA - FOURTH * RPF * (GI * (G0 - GI) * W) ! ref. (1) eq. (3.96) + ELSE IF(PL_DISP == 'TWA_MOD') THEN ! + ALPHA = AL_RPA - RPF / 16.0E0_WP ! ref. (1) eq. (3.99) + END IF ! +! + ENE_P_Q = H_BAR * (OMP + TWO * ALPHA * OMF * Y * Y) ! ref. (1) eq. (3.95) +! + END SUBROUTINE PLASMON_DISP_3D_2 +! +END MODULE PLASMON_DISP_REAL +! +!======================================================================= +! +MODULE PLASMON_DISP_CPLX +! +! This module computes analytical plasmon dispersion with damping +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE PLASMON_DISP_D_2D(PL_DISP,Q,RS,T,MASS_E,TAU, & + ENE_Q,Q_STAR) +! +! This subroutine computes the plasmon dispersion relation with damping +! for different cases, in the 2D case +! +! Warning: all input parameters are in SI units +! +! +! Input parameters: +! +! * PL_DISP : method used to compute the dispersion +! PL_DISP = 'GIQUI_D' Jewsbury' model +! * Q : plasmon wave vector +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in Kelvin +! * MASS_E : mass enhancement m*/m +! * TAU : relaxation time (used for damping) in SI +! +! +! Output variables : +! +! * ENE_Q : plasmon energy at q in J * 1 / bar +! * Q_STAR : critical vector (2D) before which +! no plasmon can be excited +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: PL_DISP +! + REAL (WP) :: RS,T,MASS_E,TAU + REAL (WP) :: Q_STAR +! + COMPLEX (WP) :: Q,ENE_Q +! + IF(PL_DISP == 'GIQUI_D') THEN ! +! + CALL GIQUI_D_DP_2D(Q,RS,T,MASS_E,TAU,ENE_Q,Q_STAR) ! +! + END IF ! +! + END SUBROUTINE PLASMON_DISP_D_2D +! +!======================================================================= +! + SUBROUTINE PLASMON_DISP_D_3D(PL_DISP,Q,RS,T,TAU,ENE_Q) +! +! This subroutine computes the plasmon dispersion relation with damping +! for different cases, in the 3D case +! +! Warning: all input parameters are in SI units +! +! +! Input parameters: +! +! * PL_DISP : method used to compute the dispersion +! PL_DISP = 'JEWSB_D' Jewsbury' model +! PL_DISP = 'HALEV_D' Halevi model +! * Q : plasmon wave vector +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in Kelvin +! * TAU : relaxation time (used for damping) in SI +! +! +! Output variables : +! +! * ENE_Q : plasmon energy at q in J * 1 / bar +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + IMPLICIT NONE +! + CHARACTER (LEN = 7) :: PL_DISP +! + REAL (WP) :: RS,T,TAU +! + COMPLEX (WP) :: Q,ENE_Q +! + IF(PL_DISP == 'JEWSB_D') THEN ! +! + CALL JEWSB_D_DP_3D(Q,RS,T,ENE_Q) ! +! + ELSEIF(PL_DISP == 'HALEV_D') THEN ! +! + CALL HALEV_D_DP_3D(Q,RS,TAU,ENE_Q) ! +! + ENDIF ! +! + END SUBROUTINE PLASMON_DISP_D_3D +! +!======================================================================= +! + SUBROUTINE GIQUI_D_DP_2D(Q,RS,T,MASS_E,TAU,ENE_Q,Q_STAR) +! +! This subroutine computes the plasmon dispersion relation with damping +! for different cases, up to order 2 in q. The dispersion is written as +! +! ENE_Q^2 = ALPHA2 + BETA2 * Q^2 +! +! --> This is the complex (q, hbar omega_q) case (includes damping) +! +! Warning: all input parameters are in SI units +! +! +! References: (1) L. Kong, B. Yan and X. Hu, Plasma Science and +! Technology 9, 519 (2007) +! (2) G. F. Giuliani and J. J. Quinn, Phys. Rev. B 26, +! 4421 (1982) +! +! +! Input parameters: +! +! * Q : plasmon wave vector +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in Kelvin +! * MASS_E : mass enhancement m*/m +! * TAU : relaxation time (used for damping) in SI +! +! +! Output variables : +! +! * ENE_Q : plasmon energy at q in J * 1 / bar +! * Q_STAR : critical vector (2D) before which +! no plasmon can be excited +! +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO + USE COMPLEX_NUMBERS, ONLY : ZEROC,IC + USE CONSTANTS_P1, ONLY : BOHR + USE CONSTANTS_P2, ONLY : HARTREE + USE FERMI_SI, ONLY : VF_SI + USE PLASMON_ENE_SI +! + USE DISP_COEF_COMP +! + IMPLICIT NONE +! + INTEGER :: BYPASS,I +! + REAL (WP) :: RS,T + REAL (WP) :: ENE_P2,VF2 + REAL (WP) :: MASS_E,TAU + REAL (WP) :: K,Q_STAR +! + COMPLEX (WP) :: Q,Q2,Q4,Q6,ENE_Q,ENE2,X + COMPLEX (WP) :: ALPHA2,BETA2,GAMMA2 +! +! Initialisation +! + Q_STAR=ZERO ! + BYPASS=0 ! + ALPHA2=ZEROC ! + BETA2=ZEROC ! + GAMMA2=ZEROC ! +! + DO I=0,6 ! + AC(I)=ZEROC ! + END DO ! +! + Q2=Q*Q ! + Q4=Q2*Q2 ! + Q6=Q4*Q2 ! +! + VF2=VF_SI*VF_SI ! +! +! Initialization of ALPHA2 = (hbar omega_p)^2 +! + ENE_P2=ENE_P_SI*ENE_P_SI ! + ALPHA2=ENE_P2 ! +! ! mass-renormalized + K=MASS_E*TWO/BOHR ! Thomas-Fermi vector + X=Q/K ! + ENE_Q=DCMPLX((ONE+X)/(TWO+X))* & ! + (CDSQRT(X*(TWO+X)*VF2*K*K - & ! + ONE/(TAU*TAU)) - IC/TAU) ! + BYPASS=1 ! + Q_STAR=K*(DSQRT(ONE + ONE/(VF2*K*K*TAU*TAU)) - ONE) ! +! +! Dispersion relation: +! + IF(BYPASS == 0) THEN ! +! + AC(1)=ALPHA2 ! + AC(2)=BETA2 ! + AC(4)=GAMMA2 ! +! + END IF ! + + END SUBROUTINE GIQUI_D_DP_2D +! +!======================================================================= +! + SUBROUTINE HALEV_D_DP_3D(Q,RS,TAU,ENE_Q) +! +! This subroutine computes the plasmon dispersion relation with damping +! for different cases, up to order 2 in q. The dispersion is written as +! +! ENE_Q^2 = ALPHA2 + BETA2 * Q^2 +! +! --> This is the complex (q, hbar omega_q) case (includes damping) +! +! Warning: all input parameters are in SI units +! +! +! Input parameters: +! * Q : plasmon wave vector +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in Kelvin +! * TAU : relaxation time (used for damping) in SI +! +! +! Output variables : +! +! * ENE_Q : plasmon energy at q in J * 1 / bar +! +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,THREE,FOUR,TEN, & + HALF + USE COMPLEX_NUMBERS, ONLY : ZEROC,IC + USE CONSTANTS_P1, ONLY : BOHR,H_BAR + USE FERMI_SI, ONLY : VF_SI + USE PLASMON_ENE_SI +! + USE DISP_COEF_COMP +! + IMPLICIT NONE +! + INTEGER :: BYPASS,I +! + REAL (WP) :: RS,T + REAL (WP) :: ENE_P2,VF2 + REAL (WP) :: TAU + REAL (WP) :: GAMMA,O_P2 +! + COMPLEX (WP) :: Q,Q2,ENE_Q,RAT + COMPLEX (WP) :: ALPHA2,BETA2,GAMMA2,DELTA2 +! +! Initialisation +! + BYPASS=0 ! + ALPHA2=ZEROC ! + BETA2=ZEROC ! + GAMMA2=ZEROC ! + DELTA2=ZEROC ! +! + DO I=0,6 ! + AC(I)=ZEROC ! + END DO ! +! + Q2=Q*Q ! +! + VF2=VF_SI*VF_SI ! +! +! Initialization of ALPHA2 = (hbar omega_p)^2 +! + ENE_P2=ENE_P_SI*ENE_P_SI ! + ALPHA2=ENE_P2 ! +! + GAMMA=ONE/TAU ! + O_P2=ENE_P2/(H_BAR*H_BAR) ! + RAT=Q2*VF2/O_P2 ! +! +! + ENE_Q=DSQRT(ENE_P2) + THREE*DSQRT(ENE_P2)*RAT/TEN - & ! + IC*HALF*GAMMA*(ONE+FOUR*RAT/15.0E0_WP) ! +! +! Dispersion relation: +! + IF(BYPASS == 0) THEN ! + AC(0)=ALPHA2 ! + AC(2)=BETA2 ! + AC(4)=GAMMA2 ! + AC(6)=DELTA2 ! + END IF ! +! + END SUBROUTINE HALEV_D_DP_3D +! +!======================================================================= +! + SUBROUTINE JEWSB_D_DP_3D(Q,RS,T,ENE_Q) +! +! This subroutine computes the plasmon dispersion relation with damping +! for different cases, up to order 2 in q. The dispersion is written as +! +! ENE_Q^2 = ALPHA2 + BETA2 * Q^2 +! +! --> This is the complex (q, hbar omega_q) case (includes damping) +! +! Warning: all input parameters are in SI units +! +! +! Input parameters: +! +! * Q : complex plasmon wave vector +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in Kelvin +! +! +! Output variables : +! +! * ENE_Q : plasmon energy at q in J * 1 / bar +! +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FIVE,SIX, & + HALF,FOURTH + USE COMPLEX_NUMBERS + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PLASMON_ENE_SI +! + USE DISP_COEF_COMP +! + IMPLICIT NONE +! + INTEGER :: BYPASS,I +! + REAL (WP) :: RS,T + REAL (WP) :: G1,BG0,BG1 + REAL (WP) :: NUM,DENOM + REAL (WP) :: KF2,EF2 +! + COMPLEX (WP) :: Q,Q2,Q4,Q6,ENE_Q,ENE2 + COMPLEX (WP) :: A,B,ALPHA2,BETA2,GAMMA2,DELTA2 +! +! Initialisation +! + BYPASS=0 ! + ALPHA2=ZEROC ! + BETA2=ZEROC ! + GAMMA2=ZEROC ! + DELTA2=ZEROC ! +! + DO I=0,6 ! + AC(I)=ZEROC ! + END DO ! +! + Q2=Q*Q ! + Q4=Q2*Q2 ! + Q6=Q4*Q2 ! +! + KF2=KF_SI*KF_SI ! + EF2=EF_SI*EF_SI ! +! +! Initialization of ALPHA2 = (hbar omega_p)^2 +! + ALPHA2=ENE_P_SI*ENE_P_SI ! +! + G1=FOURTH+0.00636E0_WP*RS ! + BG0=0.033E0_WP*RS ! + BG1=0.15E0_WP*DSQRT(RS) ! + NUM=SIX*EF2 ! + DENOM=FIVE*ENE_P_SI*ENE_P_SI ! + A=(ONEC-HALF*IC*BG0) ! + B=(NUM/DENOM-HALF*(G1+IC*BG1))/KF2 ! +! + ALPHA2=DCMPLX(A*A)*ENE_P_SI*ENE_P_SI ! + BETA2=DCMPLX(TWO*A*B) ! + GAMMA2=DCMPLX(B*B) ! +! +! +! Dispersion relation: +! + IF(BYPASS == 0) THEN ! + AC(0)=ALPHA2 ! + AC(2)=BETA2 ! + AC(4)=GAMMA2 ! + AC(6)=DELTA2 ! + END IF ! +! + ENE2=AC(0)+AC(1)*Q+AC(2)*Q2+AC(3)*Q*Q2+AC(4)*Q4+ & ! + AC(5)*Q*Q4+AC(6)*Q6 ! +! + ENE_Q=CDSQRT(ENE2) ! +! + END SUBROUTINE JEWSB_D_DP_3D +! +END MODULE PLASMON_DISP_CPLX diff --git a/New_libraries/DFM_library/PLASMON_LIBRARY/plasmon_dispersion_2.f90 b/New_libraries/DFM_library/PLASMON_LIBRARY/plasmon_dispersion_2.f90 new file mode 100644 index 0000000..1e2f441 --- /dev/null +++ b/New_libraries/DFM_library/PLASMON_LIBRARY/plasmon_dispersion_2.f90 @@ -0,0 +1,81 @@ +! +!======================================================================= +! +MODULE PLASMON_DISP_EXACT +! +! This module computes the exact plasmon dispersion +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE PLASMON_DISP_EX(IS,IC,YB,ENE_P_Q) +! +! This subroutine computes exact plasmon dispersion from the +! dielectric function +! +! +! Output variables : +! +! * YB : q / k_F +! * ENE_P_Q : plasmon energy at q in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Dec 2020 +! +! + USE Q_GRID +! + USE REAL_NUMBERS, ONLY : ZERO + USE FERMI_SI, ONLY : EF_SI +! + USE CALCULATORS_3 + USE RE_EPS_0_TREATMENT +! + IMPLICIT NONE +! + INTEGER, PARAMETER :: N_ZERO = 10000 ! max number of zeros +! + INTEGER, INTENT(OUT) :: IS,IC +! + INTEGER :: IQ + INTEGER :: NB + INTEGER :: IB +! + REAL (WP), INTENT(OUT) :: ENE_P_Q(N_ZERO) + REAL (WP), INTENT(OUT) :: YB(N_ZERO) +! + REAL (WP) :: Y,X + REAL (WP) :: ZERO_B(N_ZERO) + REAL (WP) :: QS,QC +! + REAL (WP) :: FLOAT +! +! Initialisation of ENE_P_Q +! + DO IB = 1,N_ZERO ! + ENE_P_Q(IB) = ZERO ! + END DO ! +! +! Extract the upper branch of Re[ eps(q,omega) ] = 0 +! which is contained in unit IO_ZE +! + CALL SELECT_BRANCH(2,NB,YB,ZERO_B) ! +! +! Get the q-bounds +! + CALL COMPUTE_QBOUNDS_3D(NB,YB,ZERO_B,IS,IC,QS,QC) ! +! +! Storing the plasmon energy in SI +! + DO IB = IS,IC ! + ENE_P_Q(IB) = ZERO_B(IB) * EF_SI ! + END DO ! +! + END SUBROUTINE PLASMON_DISP_EX +! +END MODULE PLASMON_DISP_EXACT diff --git a/New_libraries/DFM_library/PLASMON_LIBRARY/plasmon_ene.f90 b/New_libraries/DFM_library/PLASMON_LIBRARY/plasmon_ene.f90 new file mode 100644 index 0000000..560bac8 --- /dev/null +++ b/New_libraries/DFM_library/PLASMON_LIBRARY/plasmon_ene.f90 @@ -0,0 +1,215 @@ +! +!======================================================================= +! +MODULE PLASMON_ENE_SI +! +! This modules defines the plasmon energy +! +! --> SI version <-- +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: ENE_P_SI +! +END MODULE PLASMON_ENE_SI +! +!======================================================================= +! +MODULE PLASMON_ENE_EV +! +! This modules defines the plasmon energy +! +! --> eV version <-- +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: ENE_P_EV +! +END MODULE PLASMON_ENE_EV +! +!======================================================================= +! +MODULE PLASMON_SCALE_P +! +! This modules defines the plasmon scale parameters +! +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: NONID,DEGEN +! +END MODULE PLASMON_SCALE_P +! +!======================================================================= +! +MODULE PLASMON_ENE +! +! This modules computes the plasmon energy +! +! --> SI version <-- +! +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE CALC_PLASMON_ENE +! + USE MATERIAL_PROP, ONLY : RS,DMN + USE ENE_CHANGE, ONLY : EV +! + USE PLASMON_ENE_SI + USE PLASMON_ENE_EV +! + IMPLICIT NONE +! + CALL PLASMON_ENERGY(DMN,RS,ENE_P_SI) ! +! + ENE_P_EV = ENE_P_SI / EV ! +! + END SUBROUTINE CALC_PLASMON_ENE +! +!======================================================================= +! + SUBROUTINE PLASMON_ENERGY(DMN,RS,ENE_P_SI) +! +! This subroutine calculates the plasmon energy at q = 0 +! for all dimensionalities +! +! Important note: In 2D and 1D, the plasmon energy is q-dependent. We +! have removed here this q-dependency. In reality, OMEGA_P is zero +! in 2D and 1D for q = 0 +! +! Input parameters: +! +! * DMN : problem dimension +! DIM = '3D' +! DIM = '2D' +! DIM = '1D' +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Output variables : +! +! * ENE_P_SI : plasmon energy in J +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Nov 2020 +! +! + USE ACCURACY_REAL + USE REAL_NUMBERS, ONLY : HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,EPS_0 + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : RS_TO_N0 +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP) :: RS + REAL (WP) :: ENE_P_SI + REAL (WP) :: COEF,N0 +! + REAL (WP) :: SQRT +! + COEF = E * E / (M_E * EPS_0) ! +! + N0 = RS_TO_N0(DMN,RS) ! +! + IF(DMN == '3D') THEN ! +! +!.......... 3D case .......... +! + ENE_P_SI = H_BAR * SQRT(COEF * N0) ! +! + ELSE IF(DMN == '2D') THEN ! +! +!.......... 2D case .......... +! + ENE_P_SI = H_BAR * SQRT(HALF * COEF * N0) ! * sqrt(q) +! + ELSE IF(DMN == '1D') THEN ! +! +!.......... 1D case .......... +! + ENE_P_SI = H_BAR * SQRT(HALF * HALF * COEF * PI_INV * N0) ! * q * sqrt(Vc) +! + END IF ! +! + END SUBROUTINE PLASMON_ENERGY +! +END MODULE PLASMON_ENE +! +!======================================================================= +! +MODULE PLASMA_SCALE +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE CALC_PLASMA_SCALE +! + USE MATERIAL_PROP, ONLY : RS + USE EXT_FIELDS, ONLY : T + USE PLASMA, ONLY : ZION +! + USE PLASMON_SCALE_P +! + IMPLICIT NONE +! + CALL PLASMON_SCALE(RS,T,ZION,NONID,DEGEN) ! +! + END SUBROUTINE CALC_PLASMA_SCALE +! +!======================================================================= +! + SUBROUTINE PLASMON_SCALE(RS,T,ZION,NONID,DEGEN) +! +! This subroutine calculates the plasmon scale parameters +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * ZION : atomic number of the ions of the plasma +! +! Output variables : +! +! * NONID : nonideality of plasmon --> dimensionless +! * DEGEN : plasmon degeneracy +! +! +! Author : D. Sébilleau +! +! Last modified : 25 Sep 2020 +! +! +! + USE CONSTANTS_P1, ONLY : BOHR,E,EPS_0,K_B + USE FERMI_SI, ONLY : EF_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: RS,T,ZION + REAL (WP), INTENT(OUT) :: NONID,DEGEN +! + NONID = EF_SI / (K_B * T) ! + DEGEN = ZION * ZION * E * E / (EPS_0 * K_B * T * RS * BOHR) ! +! + END SUBROUTINE PLASMON_SCALE +! +END MODULE PLASMA_SCALE diff --git a/New_libraries/DFM_library/PLASMON_LIBRARY/q_bounds.f90 b/New_libraries/DFM_library/PLASMON_LIBRARY/q_bounds.f90 new file mode 100644 index 0000000..617c0ad --- /dev/null +++ b/New_libraries/DFM_library/PLASMON_LIBRARY/q_bounds.f90 @@ -0,0 +1,212 @@ +! +!======================================================================= +! +MODULE Q_BOUNDS +! +! This module provides subroutines to compute the bounds +! for the q-integration. +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE QBOUNDS(Q_MIN,Q_MAX) +! +! This subroutine computes the bounds for q-integration. +! The lower bounds is zero except when the plasmon is damped. +! The upper bound is given by the intersection of the plasmon +! dispersion curve with the electron-hole pair dispersion. +! +! The dispersion coefficients in modules DISP_COEF_REAL, +! DISP_COEF_COMP and DISP_COEF_EH are in atomic units (AU) +! +! The subroutines find the roots of the polynomial: +! +! AR(6)*q^6 + AR(5)*q^5 + [AR(4)-AE(4)]*q^4 + +! [AR(3)-AE(3)]*q^3 + [AR(2)-AE(2)]*q^2 + +! [AR(1)-AE(1)]*q + [AR(0)-AE(0)] = 0 +! +! +! +! Output variables : +! +! * Q_MIN : lower bound in SI +! * Q_MAX : upper bound in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 15 Sep 2020 +! +! + USE MATERIAL_PROP, ONLY : RS,DMN + USE FERMI_SI, ONLY : KF_SI + USE FERMI_AU, ONLY : KF_AU + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,FIVE,NINE, & + THIRD,FOURTH + USE PI_ETC, ONLY : PI,PI_INV + USE PLASMON_DISPERSION + USE DISP_COEF_REAL + USE DISP_COEF_COMP + USE DISP_COEF_EH + USE UTILITIES_1, ONLY : ALFA + USE FIND_ZERO +! + IMPLICIT NONE +! + INTEGER :: NP,NA,NO,I + INTEGER :: LOGF +! + REAL (WP), INTENT(OUT) :: Q_MIN,Q_MAX +! + REAL (WP) :: COEF,A0KF + REAL (WP) :: A,B,C + REAL (WP) :: XA0,XA1,XA2,XC + REAL (WP) :: ALPHA,DE + REAL (WP) :: SMALL,LARGE + REAL (WP) :: ROOT,MODU + REAL (WP) :: OP(101),OI(101) ! for CPOLY + REAL (WP) :: ZR(101),ZI(101) ! for CPOLY + REAL (WP) :: OP2(101),OI2(101) ! for CPOLY + REAL (WP) :: ZR2(101),ZI2(101) ! for CPOLY +! + REAL (WP) :: SQRT,ABS,REAL,AIMAG,MAX,MIN +! + LOGICAL :: FAIL ! for CPOLY +! + SMALL = 0.0001E0_WP ! + LARGE = 1.0000E9_WP ! +! + COEF = ONE / ALFA('3D') ! (9 pi/4^(1/3) + A0KF = COEF / RS ! (a_0 * k_F) --> dimensionless + ALPHA = SQRT(FOUR * THIRD * PI_INV / A0KF) ! Nozières-Pines q/k_F = omega_p/V_F +! + NA = 4 ! degree of polynomial for +! ! RPA approximation + NP = 6 ! max degree of polynomial +! +! Initialisation +! + DO I = 1,NP ! + ZR(I) = ZERO ! + ZI(I) = ZERO ! + END DO ! +! +! Checking the order of the polynomial --> NO +! + NO = 0 ! + DO I = NP,0,-1 ! + MODU = ABS(AR(I) - AE(I)) ! + IF(MODU > SMALL) THEN ! + NO = I ! + GO TO 5 ! + END IF ! + END DO ! + 5 CONTINUE ! +! + IF(PL_DISP /= 'DAMPED1') THEN ! +! +! Plasmon not damped --> real value of q +! + DO I = 0,NO ! + OP(NO+1-I) = AR(I) - AE(I) ! OP and OI ordered + OI(NO+1-I) = ZERO ! by decreasing order + ENDDO ! +! + Q_MIN = ZERO ! + Q_MAX = LARGE ! +! + ELSE +! +! Plasmon damped --> complex value of q +! + DO I = 0,NO ! + OP(NO+1-I) = REAL(AC(I),KIND=WP) - AE(I) ! OP and OI ordered + OI(NO+1-I) = AIMAG(AC(I)) ! by decreasing order + END DO ! +! + Q_MIN = ZERO ! + Q_MAX = LARGE ! +! + END IF ! +! +! Computing approximation to the critical reduced momenta x = q_c/k_F +! +! +! 1) Nozières-Pines (XA0) +! + XA0 = ALPHA ! 3D value +! +! 2) RPA dispersion limited to q^2 and use of hbar omega_q: +! +! (1 - 3/5*alpha) x^2 + 2x - 2*alpha = 0 ! 3D value +! + A = ONE - THREE / (FIVE * ALPHA) ! + B = TWO ! + C = - TWO * ALPHA ! +! + DE = B * B - FOUR * A * C ! discriminant Delta +! + XA1 = (- B + SQRT(DE)) / (A + A) ! +! +! 3) RPA dispersion limited to q^2 and use of (hbar omega_q)^2: +! +! x^4 + 4 x^3 + (4 - 12/5) x^2 _ 4 alpha^2 = 0 ! 3D value +! + OP2(1) = ONE ! + OP2(2 )= FOUR ! + OP2(3) = FOUR - 12.0E0_WP/ FIVE ! + OP2(4) = ZERO ! + OP2(5) = - FOUR * ALPHA * ALPHA ! + OI2(1) = ZERO ! + OI2(2) = ZERO ! + OI2(3) = ZERO ! + OI2(4) = ZERO ! + OI2(5) = ZERO ! +! + CALL CPOLY(OP2,OI2,NA,ZR2,ZI2,FAIL) ! +! + XA2 = MAX(ZR2(1),ZR2(2),ZR2(3),ZR2(4)) ! +! +! Computing the true intersection between plasmons and e-h dispersions +! + CALL CPOLY(OP,OI,NO,ZR,ZI,FAIL) ! +! +! Filtering the roots to keep only the smallest of the positive ones (XC) +! + XC = LARGE ! + DO I = 1,NO ! + ROOT = ZR(I) / KF_AU ! + IF(ROOT > SMALL) THEN ! + XC = MIN(ROOT,XC,LARGE) ! + END IF ! + END DO ! +! +! Printing out the results +! + WRITE(LOGF,10) ! + WRITE(LOGF,20) NO ! + WRITE(LOGF,30) XA0 ! + WRITE(LOGF,40) XA1 ! + WRITE(LOGF,50) XA2 ! + WRITE(LOGF,60) XC ! +! + Q_MAX = XC * KF_SI ! +! +! Formats: +! + 10 FORMAT(//,5X,'Critical value q_c/k_F of the plasmon momentum:') + 20 FORMAT(/,13X,'---> solving polynomial of order ',I1,/) + 30 FORMAT(10X,'Nozières-Pines approximation : ', F6.3) + 40 FORMAT(10X,'RPA-q^2 linear approximation : ', F6.3) + 50 FORMAT(10X,'RPA-q^2 approximation : ', F6.3) + 60 FORMAT(10X,'Exact value : ', F6.3,/) +! + RETURN +! + END SUBROUTINE QBOUNDS +! +END MODULE Q_BOUNDS diff --git a/New_libraries/DFM_library/POST_PROCESSING_LIBRARY/re_eps_0_treatment.f90 b/New_libraries/DFM_library/POST_PROCESSING_LIBRARY/re_eps_0_treatment.f90 new file mode 100644 index 0000000..03bc161 --- /dev/null +++ b/New_libraries/DFM_library/POST_PROCESSING_LIBRARY/re_eps_0_treatment.f90 @@ -0,0 +1,346 @@ +! +!======================================================================= +! +MODULE RE_EPS_0_TREATMENT +! +! This modules provides the tools to work on the file +! Re [eps(q,omega)] = 0 +! +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE REORDER_EPS0(NZ,Y,ZERO_1,ZERO_2) +! +! This subroutine reorders the file Re [eps(q,omega)] = 0 to +! separate the plasmon dispersion from the lower branch +! +! +! Output parameters: +! +! * NZ : number of zeros in each branch +! * ZERO_1 : lower branch zeros +! * ZERO_2 : upper branch zeros +! +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Dec 2020 +! +! + USE OUT_VALUES_3, ONLY : I_ZE + USE PRINT_FILES, ONLY : IO_ZE +! + IMPLICIT NONE +! + INTEGER, PARAMETER :: N_ZERO = 10000 ! max number of zeros +! + INTEGER, INTENT(OUT) :: NZ +! + INTEGER :: IZ +! + REAL (WP), INTENT(OUT) :: Y(N_ZERO) + REAL (WP), INTENT(OUT) :: ZERO_1(N_ZERO),ZERO_2(N_ZERO) +! + IF(I_ZE == 1) THEN ! +! +! Separating out the two contributions +! + REWIND IO_ZE ! + NZ = 0 ! zero counter + DO IZ = 1, N_ZERO ! + READ(IO_ZE,*,END=10) Y(IZ),ZERO_1(IZ) ! + READ(IO_ZE,*,END=10) Y(IZ),ZERO_2(IZ) ! plasmon + NZ = NZ + 1 ! + END DO ! +! + 10 REWIND IO_ZE ! +! + END IF ! +! + END SUBROUTINE REORDER_EPS0 +! +!======================================================================= +! + SUBROUTINE REORDER_EPS0_PRINT +! +! This subroutine reorders the file Re [eps(q,omega)] = 0 to +! separate the plasmon dispersion from the other branch +! +! +! Output parameters: +! +! * NZ : number of zeros in each branch +! * ZERO_1 : lower branch zeros +! * ZERO_2 : upper branch zeros +! +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Dec 2020 +! +! + USE OUT_VALUES_3, ONLY : I_ZE + USE PRINT_FILES, ONLY : IO_ZE +! + IMPLICIT NONE +! + INTEGER, PARAMETER :: N_ZERO = 10000 ! max number of zeros +! + INTEGER :: NZ +! + INTEGER :: IZ,NBZ +! + REAL (WP) :: Y(N_ZERO) + REAL (WP) :: ZERO_1(N_ZERO),ZERO_2(N_ZERO) +! + IF(I_ZE == 1) THEN ! +! +! Separating out the two contributions +! + REWIND IO_ZE ! + NZ = 0 ! zero counter + DO IZ = 1, N_ZERO ! + READ(IO_ZE,*,END=10) Y(IZ),ZERO_1(IZ) ! + READ(IO_ZE,*,END=10) Y(IZ),ZERO_2(IZ) ! plasmon + NZ = NZ + 1 ! + END DO ! +! + 10 REWIND IO_ZE ! +! +! +! Rewriting it with plasmon first, and then the lower branch +! "backwards" to ensure the continuity of the curve +! + DO IZ = 1, NZ ! + WRITE(IO_ZE,*) Y(IZ),ZERO_2(IZ) ! + END DO ! +! + DO IZ = NZ, 1, -1 ! + WRITE(IO_ZE,*) Y(IZ),ZERO_1(IZ) ! + END DO ! +! + END IF ! +! + END SUBROUTINE REORDER_EPS0_PRINT +! +!======================================================================= +! + SUBROUTINE SELECT_BRANCH(IB,NB,YB,ZERO_B) +! +! This subroutine selects one of the branches of the collective +! excitations +! +! +! Input parameters: +! +! * IB : branch number (counted from E = 0) +! IB = 1 --> lower branch +! IB = 2 --> upper branch +! +! +! Output parameters: +! +! * NB : number of zeros in the selected branch +! * ZERO_B : selected branch zeros +! +! +! +! Author : D. Sébilleau +! +! Last modified : 16 Dec 2020 +! +! + IMPLICIT NONE +! + INTEGER, PARAMETER :: N_ZERO = 10000 ! max number of zeros +! + INTEGER, INTENT(IN) :: IB + INTEGER, INTENT(OUT) :: NB +! + INTEGER :: IQ +! + REAL (WP), INTENT(OUT) :: YB(N_ZERO) + REAL (WP), INTENT(OUT) :: ZERO_B(N_ZERO) +! + REAL (WP) :: Y(N_ZERO) + REAL (WP) :: ZERO_1(N_ZERO),ZERO_2(N_ZERO) +! +! Reordering the branch values +! + CALL REORDER_EPS0(NB,Y,ZERO_1,ZERO_2) ! +! + DO IQ = 1, NB ! +! + IF(IB == 1) THEN ! + ZERO_B(IQ) = ZERO_1(IQ) ! + ELSE IF(IB == 2) THEN ! + ZERO_B(IQ) = ZERO_2(IQ) ! + END IF ! +! + YB(IQ) = Y(IQ) ! +! + END DO ! +! + 10 CONTINUE +! + END SUBROUTINE SELECT_BRANCH +! +!======================================================================= +! + SUBROUTINE COMPUTE_QBOUNDS_3D(NB,YB,ZERO_B,IS,IC,QS,QC) +! +! This subroutine computes the bounds of the plasmon branch +! in 3D +! +! +! Input parameters: +! +! * NB : number of zeros in the selected branch +! * YB : abscissas +! * ZERO_B : branch zeros +! +! +! Output parameters: +! +! * IS : index of lower q-bound +! * IC : index of upper q-bound +! * QS : lower q-bound +! * QC : upper q-bound +! +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,SMALL,TTINY,LARGE +! + USE SMOOTHING + USE DERIVATION, ONLY : DERIV_3P +! + IMPLICIT NONE +! + INTEGER, PARAMETER :: N_ZERO = 10000 ! max number of zeros +! + INTEGER, INTENT(IN) :: NB + INTEGER, INTENT(OUT) :: IS,IC +! + INTEGER :: IM,JB,PTS + INTEGER :: LOGF +! + REAL (WP), PARAMETER :: EPS1 = 0.01E0_WP + REAL (WP), PARAMETER :: EPS2 = 0.5E0_WP +! + REAL (WP), INTENT(IN) :: YB(N_ZERO) + REAL (WP), INTENT(INOUT) :: ZERO_B(N_ZERO) + REAL (WP), INTENT(OUT) :: QS,QC +! + REAL (WP) :: H + REAL (WP) :: DER1(N_ZERO) + REAL (WP) :: MIN_Q,MAX_Q + REAL (WP) :: MAX_B + REAL (WP) :: YS,YC +! + LOGF = 6 ! log file unit +! + MIN_Q = LARGE ! + MAX_Q = TTINY ! + MAX_B = TTINY ! +! +! Number of smoothing neighbours +! + PTS = 50 ! +! +! Step +! + H = YB(2) - YB(1) ! +! +! Smoothing the branch function +! +! CALL SMOOFT(ZERO_B,NB,PTS) ! +! CALL TSAVGOL(ZERO_B,NB) +! +! Computing the first derivative of the branch +! + CALL DERIV_3P(ZERO_B,NB,DER1,H) ! +! +! Computing the maximum MAX_B of the branch +! + DO JB = 1, NB ! + MAX_B = MAX(MAX_B,ZERO_B(JB)) ! + END DO ! +! +! Computing the index IM corresponding to MAX_B +! + DO JB = 1, NB ! + IF(ABS(ZERO_B(JB)-MAX_B) < EPS1) THEN ! + IM = JB ! + GO TO 10 ! + END IF ! + END DO ! +! +! Computing the minimum of YS the derivative (up tu MAX_B) +! + 10 DO JB = 1, IM-5 ! + MIN_Q = MIN(MIN_Q,DER1(JB)) ! + END DO ! + YS = MIN_Q ! +! +! Computing the index IS of lower bound QS +! + DO JB = 1, IM-5 ! + IF(ABS(DER1(JB)-YS) < EPS2) THEN ! + IS = JB ! + QS = YB(JB) ! + GO TO 20 ! + END IF ! + END DO ! +! +! Computing the maximum of the derivative (up tu MAX_B) +! + 20 DO JB = IS,IM ! + MAX_Q = MAX(MAX_Q,DER1(JB)) ! + END DO ! + YC = MAX_Q ! +! +! Computing the index IC of upper bound QC +! + DO JB = IM,IS,-1 ! + IF(ABS(DER1(JB)-YC) < EPS2) THEN ! + IC = JB ! + QC = YB(JB) ! + GO TO 30 ! + END IF ! + END DO ! +! + 30 CONTINUE +! +! Printing the bounds +! + WRITE(LOGF,15) + WRITE(LOGF, 5) + WRITE(LOGF,25) + WRITE(LOGF,35) QS,IS + WRITE(LOGF,45) QC,IC + WRITE(LOGF,55) +! +! Formats: +! + 5 FORMAT(5X,'|',10X,'q-bounds of epsilon : ',22X,'|') + 15 FORMAT(6X,'_________________________________________________________') + 25 FORMAT(5X,'| |') + 35 FORMAT(5X,'|',15X,'q_min = ',F8.3,5X,'index = ',I4,9X,'|') + 45 FORMAT(5X,'|',15X,'q_max = ',F8.3,5X,'index = ',I4,9X,'|') + 55 FORMAT(5X,'|_________________________________________________________|',/) +! + END SUBROUTINE COMPUTE_QBOUNDS_3D +! +END MODULE RE_EPS_0_TREATMENT diff --git a/New_libraries/DFM_library/PRINT_LIBRARY/print_Fermi.f90 b/New_libraries/DFM_library/PRINT_LIBRARY/print_Fermi.f90 new file mode 100644 index 0000000..adae0db --- /dev/null +++ b/New_libraries/DFM_library/PRINT_LIBRARY/print_Fermi.f90 @@ -0,0 +1,131 @@ +! +!======================================================================= +! +MODULE PRINT_FERMI +! +! This module prints the Fermi values in the log file +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE PRINT_FERMI_SI +! +! This subroutine prints the Fermi values in the log file +! +! +! Author : D. Sébilleau +! +! Last modified : 15 Oct 2020 +! +! + USE FERMI_SI + USE OUT_VALUES_5 + USE ENE_CHANGE, ONLY : ANG,EV +! + IMPLICIT NONE +! + INTEGER :: LOGF,I_P +! + LOGF = 6 ! log file unit + I_P = I_EF + I_KF + I_VF + I_TE + I_DL ! +! + IF(I_P > 0) THEN ! + WRITE(LOGF,15) ! + WRITE(LOGF,5) ! + WRITE(LOGF,25) ! + END IF ! +! + IF(I_EF == 1) THEN ! + WRITE(LOGF,10) EF_SI / EV ! + END IF ! +! + IF(I_KF == 1) THEN ! + WRITE(LOGF,20) KF_SI * ANG ! + END IF ! +! + IF(I_VF == 1) THEN ! + WRITE(LOGF,30) VF_SI ! + END IF ! +! + IF(I_TE == 1) THEN ! + WRITE(LOGF,40) TF_SI ! + END IF ! +! + IF(I_DL == 1) THEN ! + WRITE(LOGF,50) NF_SI * EV ! + END IF ! +! + IF(I_P > 0) THEN ! + WRITE(LOGF,35) ! + END IF ! +! +! Formats +! + 10 FORMAT(5X,'|',5X,'Fermi energy : ',F8.3,' eV',5X,' |') + 20 FORMAT(5X,'|',5X,'Fermi wave vector : ',F8.3,' Å^{-1}',5X,'|') + 30 FORMAT(5X,'|',5X,'Fermi velocity : ',E12.6,' m/s',5X,' |') + 40 FORMAT(5X,'|',5X,'Fermi temperature : ',E12.6,' °K',5X,' |') + 50 FORMAT(5X,'|',5X,'Fermi DoS : ',E12.6,' / eV',5X,' |') +! + 5 FORMAT(5X,'|',10X,'Fermi values : ',29X,'|') + 25 FORMAT(5X,'| |') + 15 FORMAT(6X,'_________________________________________________________') + 35 FORMAT(5X,'|_________________________________________________________|',/) +! + END SUBROUTINE PRINT_FERMI_SI +! +!======================================================================= +! + SUBROUTINE PRINT_FERMI_SI_M +! +! This subroutine prints the Fermi values in the log file +! +! +! Author : D. Sébilleau +! +! Last modified : 24 Jul 2020 +! +! + USE FERMI_SI_M + USE OUT_VALUES_5 + USE CONSTANTS_P1, ONLY : BOHR + USE ENE_CHANGE, ONLY : EV +! + IMPLICIT NONE +! + INTEGER :: LOGF +! + LOGF=6 ! log file unit +! + WRITE(LOGF,5) ! +! + IF(I_EF == 1) THEN ! + WRITE(LOGF,10) EF_SI_M/EV ! + END IF ! +! + IF(I_KF == 1) THEN ! + WRITE(LOGF,20) KF_SI_M*BOHR ! + END IF ! +! + IF(I_VF == 1) THEN ! + WRITE(LOGF,30) VF_SI_M ! + END IF ! +! + IF(I_TE == 1) THEN ! + WRITE(LOGF,40) TF_SI_M ! + END IF ! +! +! Formats +! + 5 FORMAT(10X,'Fermi values : ',/) ! + 10 FORMAT(5X,'Fermi energy : ',F8.3,' eV') ! + 20 FORMAT(5X,'Fermi wave vector : ',F8.3,' Å^{-1}') ! + 30 FORMAT(5X,'Fermi velocity : ',E12.6,' m/s') ! + 40 FORMAT(5X,'Fermi temperature : ',F8.3,' °K') ! + 55 FORMAT(' ') ! +! + END SUBROUTINE PRINT_FERMI_SI_M +! +END MODULE PRINT_FERMI diff --git a/New_libraries/DFM_library/PRINT_LIBRARY/print_asymptotic.f90 b/New_libraries/DFM_library/PRINT_LIBRARY/print_asymptotic.f90 new file mode 100644 index 0000000..b90ac8e --- /dev/null +++ b/New_libraries/DFM_library/PRINT_LIBRARY/print_asymptotic.f90 @@ -0,0 +1,51 @@ +! +!======================================================================= +! +MODULE PRINT_ASYMPTOTIC +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE PRINT_ASYMPT_VALUES +! +! This subroutine prints the asymptotic values gamma_0, gamma_inf +! and g(0) in the log file +! +! +! Author : D. Sébilleau +! +! Last modified : 3 Dec 2020 +! +! + USE ASYMPT +! + IMPLICIT NONE +! + INTEGER :: LOGF +! + LOGF = 6 ! log file unit +! + WRITE(LOGF,10) ! + WRITE(LOGF,30) ! + WRITE(LOGF,20) ! + WRITE(LOGF,40) G0 ! + WRITE(LOGF,50) GI ! + WRITE(LOGF,60) GR0 ! + WRITE(LOGF,70) ! +! +! Formats +! + 10 FORMAT(6X,'_________________________________________________________') + 20 FORMAT(5X,'| |') + 30 FORMAT(5X,'| Asymptotic values : |') + 40 FORMAT(5X,'|',5X,'gamma_0 : ',F8.3,15X,' |') + 50 FORMAT(5X,'|',5X,'gamma_i : ',F8.3,15X,' |') + 60 FORMAT(5X,'|',5X,'g(0) : ',F8.3,15X,' |') + 70 FORMAT(5X,'|_________________________________________________________|',/) +! + END SUBROUTINE PRINT_ASYMPT_VALUES +! +END MODULE PRINT_ASYMPTOTIC diff --git a/New_libraries/DFM_library/PRINT_LIBRARY/print_calc_type.f90 b/New_libraries/DFM_library/PRINT_LIBRARY/print_calc_type.f90 new file mode 100644 index 0000000..28bb4ab --- /dev/null +++ b/New_libraries/DFM_library/PRINT_LIBRARY/print_calc_type.f90 @@ -0,0 +1,292 @@ +! +!======================================================================= +! +MODULE PRINT_CALC_TYPE +! +! This module prints the type of calculations requested +! +! +CONTAINS +! +!======================================================================= +! + FUNCTION INDEX_CALC(I) +! +! This function associates to each unit number I the name of the +! switch corresponding to the calculation whose result is printed +! into unit I +! +! +! Author : D. Sébilleau +! +! Last modified : 21 Apr 2021 +! +! + USE DIMENSION_CODE, ONLY : NOFFN +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: IND(NOFFN) + CHARACTER (LEN = 4) :: INDEX_CALC +! + INTEGER, INTENT(IN) :: I +! +! + DATA IND( 1) / ' ' / ! \ + DATA IND( 2) / ' ' / ! \ + DATA IND( 3) / ' ' / ! \>> Fortran units not used + DATA IND( 4) / ' ' / ! />> for output files + DATA IND( 5) / ' ' / ! / + DATA IND( 6) / ' ' / ! / + DATA IND( 7) / 'I_DF' / ! dielectric function file + DATA IND( 8) / 'I_PZ' / ! polarization function + DATA IND( 9) / 'I_SU' / ! susceptibility function + DATA IND(10) / 'I_CD' / ! electrical conductivity +! + DATA IND(11) / 'I_PD' / ! plasmon dispersion file + DATA IND(12) / 'I_EH' / ! electron-hole dispersion file + DATA IND(13) / 'I_E2' / ! two electron-hole dispersion + DATA IND(14) / 'I_CK' / ! screened Coulomb (k-space) + DATA IND(15) / 'I_CR' / ! screened Coulomb (real space) + DATA IND(16) / 'I_PK' / ! plasmon kinetic energy +! + DATA IND(17) / 'I_LF' / ! local-field correction file G(q,om) + DATA IND(18) / 'I_IQ' / ! G(q,inf) file + DATA IND(19) / 'I_SF' / ! structure factor file S(q,om) + DATA IND(20) / 'I_PC' / ! pair correlation function file + DATA IND(21) / 'I_P2' / ! pair distribution function file + DATA IND(22) / 'I_VX' / ! vertex function Gamma(q,om) + DATA IND(23) / 'I_DC' / ! plasmon damping coefficient Im[eps]/q^2 + DATA IND(24) / 'I_MD' / ! momentum distribution + DATA IND(25) / 'I_LD' / ! Landau parameters + DATA IND(26) / 'I_DP' / ! damping file + DATA IND(27) / 'I_LT' / ! plasmon lifetime file + DATA IND(28) / 'I_BR' / ! plasmon broadening + DATA IND(29) / 'I_PE' / ! plasmon energy + DATA IND(30) / 'I_QC' / ! plasmon q-bounds + DATA IND(31) / 'I_RL' / ! relaxation time + DATA IND(32) / 'I_KS' / ! screening wave vector + DATA IND(33) / 'I_DY' / ! Debye wave vector + DATA IND(34) / 'I_ME' / ! moments of epsilon + DATA IND(35) / 'I_MS' / ! moments of S(q,omega) + DATA IND(36) / 'I_ML' / ! moments of loss function + DATA IND(37) / 'I_MC' / ! moments of conductivity + DATA IND(38) / 'I_DE' / ! derivative of Re[ dielectric function ] + DATA IND(39) / 'I_ZE' / ! Re[ dielectric function ] = 0 + DATA IND(40) / 'I_SR' / ! sum rules for epsilon + DATA IND(41) / 'I_CW' / ! confinement wave function + DATA IND(42) / 'I_CF' / ! confinement potential + DATA IND(43) / 'I_EM' / ! effective mass + DATA IND(44) / 'I_MF' / ! mean free path + DATA IND(45) / 'I_SP' / ! spectral function + DATA IND(46) / 'I_SE' / ! self-energy + DATA IND(47) / 'I_SB' / ! subband energies + DATA IND(48) / 'I_ES' / ! Eliashberg function + DATA IND(49) / 'I_GR' / ! Grüneisen parameter + DATA IND(50) / 'I_FD' / ! Fermi-Dirac distribution + DATA IND(51) / 'I_BE' / ! Bose-Einstein distribution + DATA IND(52) / 'I_MX' / ! Maxwell distribution + DATA IND(53) / 'I_SC' / ! scale parameters + DATA IND(54) / 'I_DS' / ! density of states + DATA IND(55) / 'I_NV' / ! Nevanlinaa function + DATA IND(56) / 'I_MT' / ! memory function +! + DATA IND(57) / 'I_GP' / ! grand partition function + DATA IND(58) / 'I_PR' / ! electronic pressure + DATA IND(59) / 'I_CO' / ! compressibility + DATA IND(60) / 'I_CP' / ! chemical potential + DATA IND(61) / 'I_BM' / ! bulk modulus + DATA IND(62) / 'I_SH' / ! shear modulus + DATA IND(63) / 'I_S0' / ! zero sound velocity + DATA IND(64) / 'I_S1' / ! first sound velocity + DATA IND(65) / 'I_DT' / ! Debye temperature + DATA IND(66) / 'I_PS' / ! Pauli paramagnetic susceptibility + DATA IND(67) / 'I_IE' / ! internal energy + DATA IND(68) / 'I_EI' / ! excess internal energy + DATA IND(69) / 'I_FH' / ! Helmholtz free energy + DATA IND(70) / 'I_EY' / ! entropy +! + DATA IND(71) / 'I_EF' / ! Fermi energy + DATA IND(72) / 'I_KF' / ! Fermi momentum + DATA IND(73) / 'I_VF' / ! Fermi velocity + DATA IND(74) / 'I_TE' / ! Fermi temperature + DATA IND(75) / 'I_DL' / ! Fermi density of states +! + DATA IND(76) / 'I_TW' / ! thermal De Broglie wavelength + DATA IND(77) / 'I_VT' / ! thermal velocity + DATA IND(78) / 'I_TC' / ! thermal conductivity +! + DATA IND(79) / 'I_EG' / ! ground state energy + DATA IND(80) / 'I_EX' / ! exchange energy + DATA IND(81) / 'I_XC' / ! exchange correlation energy + DATA IND(82) / 'I_EC' / ! correlation energy + DATA IND(83) / 'I_HF' / ! Hartree-Fock energy + DATA IND(84) / 'I_EK' / ! kinetic energy + DATA IND(85) / 'I_EP' / ! potential energy +! + DATA IND(86) / 'I_VI' / ! shear viscosity + DATA IND(87) / 'I_DI' / ! diffusion coefficient +! + DATA IND(88) / 'I_FP' / ! fluctuation potential file + DATA IND(89) / 'I_EL' / ! energy loss function + DATA IND(90) / 'I_PO' / ! stopping power + DATA IND(91) / 'I_RF' / ! refractive index + DATA IND(92) / 'I_VC' / ! dynamic screened Coulomb potential V(q,omega) +! +! + INDEX_CALC = IND(I) ! +! + END FUNCTION INDEX_CALC +! +!======================================================================= +! + SUBROUTINE PRINT_CALC_INFO +! +! Prints the calculation types in the log file +! +! +! Author : D. Sébilleau +! +! Last modified : 21 Apr 2021 +! +! + USE DIMENSION_CODE, ONLY : NOFFN +! + USE OUT_VALUES_1 + USE OUT_VALUES_2 + USE OUT_VALUES_3 + USE OUT_VALUES_4 + USE OUT_VALUES_5 + USE OUT_VALUES_6 + USE OUT_VALUES_7 + USE OUT_VALUES_8 + USE OUT_VALUES_9 +! + IMPLICIT NONE +! + CHARACTER (LEN = 40) :: CALCTYPE(7:NOFFN),STRING +! + INTEGER :: I,LOGF + INTEGER :: STRING_VALUE +! + DATA CALCTYPE / & ! + 'dielectric function ', & ! + 'polarization function ', & ! + 'susceptibility function ', & ! + 'electrical conductivity ', & ! + 'plasmon dispersion ', & ! + 'electron-hole dispersion ', & ! + 'two electron-hole dispersion ', & ! + 'interaction potential in k-space ', & ! + 'interaction potential in real space ', & ! + 'plasmon kinetic energy ', & ! + 'local-field correction ', & ! + 'G(q,inf) ', & ! + 'structure factor ', & ! + 'pair correlation function ', & ! + 'pair distribution function ', & ! + 'vertex function ', & ! + 'plasmon damping coefficient ', & ! + 'momentum distribution ', & ! + 'Landau parameters ', & ! + 'damping ', & ! + 'plasmon lifetime ', & ! + 'plasmon broadening ', & ! + 'plasmon energy ', & ! + 'plasmon q-bounds ', & ! + 'relaxation time ', & ! + 'screening wave vector ', & ! + 'omega = q * v_F ', & ! + 'moments of epsilon ', & ! + 'moments of S(q,omega) ', & ! + 'moments of loss function ', & ! + 'moments of conductivity ', & ! + 'derivative of Re[ dielectric function ] ', & ! + 'Re[ dielectric function ] = 0 ', & ! + 'sum rules for epsilon ', & ! + 'confinement wave function ', & ! + 'confinement potential ', & ! + 'effective mass ', & ! + 'mean free path ', & ! + 'spectral function ', & ! + 'self-energy ', & ! + 'subband energies ', & ! + 'Eliashberg function ', & ! + 'Gruneisen parameter ', & ! + 'Fermi-Dirac distribution ', & ! + 'Bose-Einstein distribution ', & ! + 'Maxwell-Boltzmann distribution ', & ! + 'scale parameters ', & ! + 'density of states ', & ! + 'Nevanlinaa/memory function ', & ! + 'time domain memory function ', & ! + 'grand partition function ', & ! + 'electronic pressure ', & ! + 'compressibility ', & ! + 'chemical potential ', & ! + 'bulk modulus ', & ! + 'shear modulus ', & ! + 'zero sound velocity ', & ! + 'first sound velocity ', & ! + 'Debye temperature ', & ! + 'Pauli paramagnetic susceptibility ', & ! + 'internal energy ', & ! + 'excess internal energy ', & ! + 'Helmholtz free energy ', & ! + 'entropy ', & ! + 'Fermi energy ', & ! + 'Fermi momentum ', & ! + 'Fermi velocity ', & ! + 'Fermi temperature ', & ! + 'Fermi density of states ', & ! + 'thermal De Broglie wavelength ', & ! + 'thermal velocity ', & ! + 'thermal conductivity ', & ! + 'ground state energy ', & ! + 'exchange energy ', & ! + 'exchange correlation energy ', & ! + 'correlation energy ', & ! + 'Hartree-Fock energy ', & ! + 'kinetic energy ', & ! + 'potential energy ', & ! + 'shear viscosity ', & ! + 'diffusion coefficient ', & ! + 'fluctuation potential file ', & ! + 'energy loss function ', & ! + 'stopping power ', & ! + 'refractive index ', & ! + 'dynamic screened Coulomb potential ' & ! + / +! + LOGF = 6 ! log file unit +! + DO I = 1, 3 ! + WRITE(LOGF,5) ! + END DO ! +! + WRITE(LOGF,10) ! + WRITE(LOGF,20) ! + WRITE(LOGF,30) ! + DO I = 7, NOFFN ! + STRING = INDEX_CALC(I) ! string to variable + READ(STRING,'(I1)') STRING_VALUE ! value of variable + IF(STRING_VALUE == 1) THEN ! + WRITE(LOGF,40) CALCTYPE(I) ! + END IF ! + END DO ! + WRITE(LOGF,20) ! + WRITE(LOGF,50) ! +! +! Formats: +! + 5 FORMAT(' ') + 10 FORMAT(6X,'_________________________________________________________') + 20 FORMAT(5X,'| |') + 30 FORMAT(5X,'| CALCULATIONS PERFORMED: |') + 40 FORMAT(5X,'| * ',A40,' |') + 50 FORMAT(5X,'|_________________________________________________________|',/) +! + END SUBROUTINE PRINT_CALC_INFO +! +END MODULE PRINT_CALC_TYPE + diff --git a/New_libraries/DFM_library/PRINT_LIBRARY/print_energies.f90 b/New_libraries/DFM_library/PRINT_LIBRARY/print_energies.f90 new file mode 100644 index 0000000..16225e1 --- /dev/null +++ b/New_libraries/DFM_library/PRINT_LIBRARY/print_energies.f90 @@ -0,0 +1,147 @@ +! +!======================================================================= +! +MODULE ENERGIES_P +! +! This module defines the energies parameters +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: E_0,E_X,E_X_HF,E_C,E_XC + REAL (WP) :: E_HF,E_GS,E_KIN,E_POT +! +END MODULE ENERGIES_P +! +!======================================================================= +! +MODULE PRINT_ENERGIES_EL +! +! This module prints the energies in the log file +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_ENERGIES_MAT(X,I_SCREEN,K_SC,FF) +! +! This subroutine computes the different energies (per electron) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * I_SCREEN : switch for screened (=1) or unscreened (=0) Coulomb +! * K_SC : screening momentum (in SI) +! * FF : form factor +! +! +! +! Author : D. Sébilleau +! +! Last modified : 28 Jul 2020 +! + USE CALC_ENERGIES + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T + USE ENERGIES, ONLY : EC_TYPE +! + USE ENERGIES_P +! + IMPLICIT NONE +! + REAL (WP) :: X,K_SC,FF +! + INTEGER :: I_SCREEN +! + IF(DMN == '3D') THEN ! + CALL ENERGIES_3D(X,EC_TYPE,RS,T,I_SCREEN,K_SC,E_0,E_X, & ! + E_X_HF,E_C,E_XC,E_HF,E_GS,E_KIN,E_POT) ! + ELSE IF(DMN == '2D') THEN ! + CALL ENERGIES_2D(X,EC_TYPE,RS,T,E_0,E_X,E_X_HF,E_C,E_XC, & ! + E_HF,E_GS,E_KIN,E_POT) ! + ELSE IF(DMN == '1D') THEN ! + CALL ENERGIES_1D(EC_TYPE,FF,RS,T,E_0,E_X,E_C,E_XC,E_HF, & ! + E_GS,E_KIN,E_POT) ! + END IF ! +! + END SUBROUTINE CALC_ENERGIES_MAT +! +!======================================================================= +! + SUBROUTINE PRINT_ENERGIES(X,I_SCREEN,K_SC,FF) +! +! This subroutine prints the different energies (per electron) +! in the log file +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * I_SCREEN : switch for screened (=1) or unscreened (=0) Coulomb +! * K_SC : screening momentum (in SI) +! * FF : form factor +! +! +! +! Author : D. Sébilleau +! +! Last modified : 28 Jul 2020 +! +! + USE ENE_CHANGE, ONLY : EV +! + USE ENERGIES_P +! + IMPLICIT NONE +! + REAL (WP) :: TEST + REAL (WP) :: X,K_SC,FF +! + INTEGER :: LOGF + INTEGER :: I_SCREEN +! + LOGF=6 ! log file unit +! + TEST=90000.0E0_WP ! +! + CALL CALC_ENERGIES_MAT(X,I_SCREEN,K_SC,FF) ! +! + WRITE(LOGF,17) ! + WRITE(LOGF,7) ! + WRITE(LOGF,27) ! +! + WRITE(LOGF,10) E_0/EV ! + WRITE(LOGF,20) E_X/EV ! + WRITE(LOGF,30) E_X_HF/EV ! + WRITE(LOGF,40) E_C/EV ! + WRITE(LOGF,50) E_XC/EV ! + WRITE(LOGF,60) E_HF/EV ! + WRITE(LOGF,70) E_GS/EV ! + WRITE(LOGF,80) E_KIN/EV ! + WRITE(LOGF,90) E_POT/EV ! +! + WRITE(LOGF,77) ! +! +! Formats: +! + 10 FORMAT(5X,'|',5X,'energy of non-interacting electron : ',F8.3,' eV',4X,'|') + 20 FORMAT(5X,'|',5X,'exchange energy (1st order) : ',F8.3,' eV',4X,'|') + 30 FORMAT(5X,'|',5X,'exchange energy (Hartree-Fock) : ',F8.3,' eV',4X,'|') + 40 FORMAT(5X,'|',5X,'correlation energy : ',F8.3,' eV',4X,'|') + 50 FORMAT(5X,'|',5X,'exchange and correlation energy : ',F8.3,' eV',4X,'|') + 60 FORMAT(5X,'|',5X,'Hartree-Fock energy : ',F8.3,' eV',4X,'|') + 70 FORMAT(5X,'|',5X,'ground state energy : ',F8.3,' eV',4X,'|') + 80 FORMAT(5X,'|',5X,'kinetic energy : ',F8.3,' eV',4X,'|') + 90 FORMAT(5X,'|',5X,'potential energy : ',F8.3,' eV',4X,'|') +! + 7 FORMAT(5X,'|',10X,'Energies at q = 0 : ',27X,'|') + 17 FORMAT(6X,'_________________________________________________________') + 27 FORMAT(5X,'| |') + 77 FORMAT(5X,'|_________________________________________________________|',/) +! + END SUBROUTINE PRINT_ENERGIES +! +END MODULE PRINT_ENERGIES_EL diff --git a/New_libraries/DFM_library/PRINT_LIBRARY/print_headers.f90 b/New_libraries/DFM_library/PRINT_LIBRARY/print_headers.f90 new file mode 100644 index 0000000..691b4fc --- /dev/null +++ b/New_libraries/DFM_library/PRINT_LIBRARY/print_headers.f90 @@ -0,0 +1,67 @@ +! +!======================================================================= +! +MODULE PRINT_HEADERS +! +! This module prints the headers for the log file +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE PRINT_ASCII +! +! Headers for the FLDF module ascii logo in the log file +! +! Author : D. Sébilleau +! +! Last modified : 24 Jul 2020 +! +! + IMPLICIT NONE +! + INTEGER :: I,LOGF +! + LOGF = 6 ! log file unit +! + DO I = 1,3 ! + WRITE(LOGF,5) ! + END DO ! +! + WRITE(LOGF,10) ! + WRITE(LOGF,20) ! + WRITE(LOGF,30) ! + WRITE(LOGF,40) ! + WRITE(LOGF,50) ! + WRITE(LOGF,60) ! + WRITE(LOGF,70) ! + WRITE(LOGF,80) ! + WRITE(LOGF,90) ! +! + WRITE(LOGF,5) ! +! + WRITE(LOGF,100) ! +! + DO I = 1,3 ! + WRITE(LOGF,5) ! + END DO ! +! +! Formats: +! + 5 FORMAT(' ') + 10 FORMAT(10X,' ''~``" ') + 20 FORMAT(10X,' ( o o )" ') + 30 FORMAT(10X,'+------------------.oooO--(_)--Oooo.------------------+') + 40 FORMAT(10X,'| |') + 50 FORMAT(10X,'| MsSpec-DFM .oooO module |') + 60 FORMAT(10X,'| ( ) Oooo. |') + 70 FORMAT(10X,'+---------------------\ (----( )--------------------+') + 80 FORMAT(10X,' \_) ) /" ') + 90 FORMAT(10X,' (_/" ') +! + 100 FORMAT(10X,'© 2020-2021, Didier Sébilleau, Aditi Mandal and Sylvain Tricot') +! + END SUBROUTINE PRINT_ASCII +! +END MODULE PRINT_HEADERS diff --git a/New_libraries/DFM_library/PRINT_LIBRARY/print_material.f90 b/New_libraries/DFM_library/PRINT_LIBRARY/print_material.f90 new file mode 100644 index 0000000..b9d076e --- /dev/null +++ b/New_libraries/DFM_library/PRINT_LIBRARY/print_material.f90 @@ -0,0 +1,41 @@ +! +!======================================================================= +! +MODULE PRINT_MATERIAL_PROP +! +! This module prints the material's properties in the log file +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE PRINT_MATERIAL_PROPERTIES(DMN,RS,T,B,DC,TP) +! +! This subroutine prints the material's properties in the log file +! +! +! Input parameters: +! +! * DMN : dimension +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! * B : magnetic field in SI +! * DC : diffusion coefficient +! * TP : phase-breaking relaxation time in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 24 Jun 2020 +! +! + USE MATERIAL_PROPERTIES +! + IMPLICIT NONE +! + CALL CHARACTERISTIC_LENGTHS(DMN,RS,T,B,DC,TP) +! + END SUBROUTINE PRINT_MATERIAL_PROPERTIES +! +END MODULE PRINT_MATERIAL_PROP diff --git a/New_libraries/DFM_library/PRINT_LIBRARY/print_material_lengths.f90 b/New_libraries/DFM_library/PRINT_LIBRARY/print_material_lengths.f90 new file mode 100644 index 0000000..4ce8ab8 --- /dev/null +++ b/New_libraries/DFM_library/PRINT_LIBRARY/print_material_lengths.f90 @@ -0,0 +1,100 @@ +! +!======================================================================= +! +MODULE PRINT_MAT_LENGTHS +! +! This module prints the scale parameters in the log file +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_CHAR_LENGTHS +! +! This subroutine computes the material's characteristic lengths +! + USE REAL_NUMBERS, ONLY : ZERO + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T,H + USE MATERIAL_PROPERTIES +! + IMPLICIT NONE +! + REAL (WP) :: DC,TP +! +! Temporary !!!! +! + DC=ZERO ! + TP=ZERO ! +! + CALL CHARACTERISTIC_LENGTHS(DMN,RS,T,H,DC,TP) ! +! + END SUBROUTINE CALC_CHAR_LENGTHS +! +!======================================================================= +! + SUBROUTINE PRINT_CHAR_LENGTHS +! +! This subroutine prints the material's characteristic lengths +! into the log file +! +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Jul 2020 +! +! + USE MATERIAL_CL + USE MATERIAL_PROP, ONLY : RS + USE CONSTANTS_P1, ONLY : BOHR + USE ENE_CHANGE, ONLY : ANG +! + IMPLICIT NONE +! + INTEGER :: LOGF +! + LOGF=6 ! log file unit +! + CALL CALC_CHAR_LENGTHS ! +! +! Writing the results in Angstroems +! +! + WRITE(LOGF,15) ! + WRITE(LOGF,5) ! + WRITE(LOGF,25) ! +! + WRITE(LOGF,10) RS*BOHR/ANG ! + WRITE(LOGF,20) EMFP/ANG ! + WRITE(LOGF,30) FWL/ANG ! + WRITE(LOGF,40) PCL/ANG ! + WRITE(LOGF,50) THL/ANG ! + WRITE(LOGF,60) ML/ANG ! + WRITE(LOGF,70) CR/ANG ! + WRITE(LOGF,80) DL/ANG ! + WRITE(LOGF,90) TFL/ANG ! +! + WRITE(LOGF,75) ! +! +! Formats +! + 10 FORMAT(5X,'|',5X,'average e-e distance : ',F8.3,' Å',10X,'|') + 20 FORMAT(5X,'|',5X,'elastic mean free path : ',F8.3,' Å',10X,'|') + 30 FORMAT(5X,'|',5X,'Fermi wavelength : ',F8.3,' Å',10X,'|') + 40 FORMAT(5X,'|',5X,'phase coherence length : ',F8.3,' Å',10X,'|') + 50 FORMAT(5X,'|',5X,'thermal length : ',F8.3,' Å',10X,'|') + 60 FORMAT(5X,'|',5X,'magnetic length : ',F8.3,' Å',10X,'|') + 70 FORMAT(5X,'|',5X,'cyclotron radius : ',F8.3,' Å',10X,'|') + 80 FORMAT(5X,'|',5X,'Debye length : ',F8.3,' Å',10X,'|') + 90 FORMAT(5X,'|',5X,'Thomas-Fermi length : ',F8.3,' Å',10X,'|') +! + 5 FORMAT(5X,'|',10X,'Characteristic lengths : ',19X,'|') + 15 FORMAT(6X,'_________________________________________________________') + 25 FORMAT(5X,'| |') + 75 FORMAT(5X,'|_________________________________________________________|',/) +! + END SUBROUTINE PRINT_CHAR_LENGTHS +! +END MODULE PRINT_MAT_LENGTHS diff --git a/New_libraries/DFM_library/PRINT_LIBRARY/print_plasmons.f90 b/New_libraries/DFM_library/PRINT_LIBRARY/print_plasmons.f90 new file mode 100644 index 0000000..77b9685 --- /dev/null +++ b/New_libraries/DFM_library/PRINT_LIBRARY/print_plasmons.f90 @@ -0,0 +1,79 @@ +! +!======================================================================= +! +MODULE PRINT_PLASMONS +! +! This module prints the plasmons properties in the log file +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE PRINT_PLASMA +! +! This subroutine prints the plasmon properties in the log file +! +! +! +! Author : D. Sébilleau +! +! Last modified : 25 Sep 2020 +! + USE PLASMON_ENE_EV + USE PLASMON_ENE + USE PLASMA_SCALE +! + USE PLASMON_SCALE_P +! + IMPLICIT NONE +! + REAL (WP) :: TEST +! + INTEGER :: LOGF +! + LOGF=6 ! log file unit +! + TEST=90000.0E0_WP ! +! + WRITE(LOGF,17) ! + WRITE(LOGF,7) ! + WRITE(LOGF,27) ! +! + IF(ENE_P_EV <= TEST) THEN ! + WRITE(LOGF,10) ENE_P_EV ! + ELSE + WRITE(LOGF,15) ENE_P_EV ! + END IF ! + IF(NONID <= TEST) THEN ! + WRITE(LOGF,20) NONID ! + ELSE + WRITE(LOGF,25) NONID ! + END IF ! + IF(DEGEN <= TEST) THEN ! + WRITE(LOGF,30) DEGEN ! + ELSE + WRITE(LOGF,35) DEGEN ! + END IF ! +! + WRITE(LOGF,70) ! +! +! Formats: +! +! + 10 FORMAT(5X,'|',5X,'plasma energy : ',F10.3,' eV',5X,' |') + 20 FORMAT(5X,'|',5X,'plasma nonideality : ',F10.3,5X,' |') + 30 FORMAT(5X,'|',5X,'plasma degeneracy : ',F10.3,5X,' |') +! + 15 FORMAT(5X,'|',5X,'plasma energy : ',E12.6,' eV',3X,' |') + 25 FORMAT(5X,'|',5X,'plasma nonideality : ',E12.6,3X,' |') + 35 FORMAT(5X,'|',5X,'plasma degeneracy : ',E12.6,3X,' |') +! + 7 FORMAT(5X,'|',10X,'Plasma parameters : ',27X,'|') + 17 FORMAT(6X,'_________________________________________________________') + 27 FORMAT(5X,'| |') + 70 FORMAT(5X,'|_________________________________________________________|',/) +! + END SUBROUTINE PRINT_PLASMA +! +END MODULE PRINT_PLASMONS diff --git a/New_libraries/DFM_library/PRINT_LIBRARY/print_scale_param.f90 b/New_libraries/DFM_library/PRINT_LIBRARY/print_scale_param.f90 new file mode 100644 index 0000000..8803e05 --- /dev/null +++ b/New_libraries/DFM_library/PRINT_LIBRARY/print_scale_param.f90 @@ -0,0 +1,107 @@ +! +!======================================================================= +! +MODULE SCALE_P +! +! This module defines the scale parameters +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: G_Q,G_C,R_W +! +END MODULE SCALE_P +! +!======================================================================= +! +MODULE PRINT_SCALE_PARAM +! +! This module prints the scale parameters in the log file +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_SCALE_PARAM +! + USE MATERIAL_PROP, ONLY : RS + USE EXT_FIELDS, ONLY : T + USE PLASMA_SCALE + USE SCALE_PARAMETERS +! + USE SCALE_P +! + IMPLICIT NONE +! + CALL SCALE_PARAM(RS,T,G_Q,G_C,R_W) ! +! + END SUBROUTINE CALC_SCALE_PARAM +! +!======================================================================= +! + SUBROUTINE PRINT_SCALE_PARAMETERS +! +! This subroutine prints the scale parameters in the log file +! +! +! +! Author : D. Sébilleau +! +! Last modified : 28 Jul 2020 +! + USE SCALE_P +! + IMPLICIT NONE +! + REAL (WP) :: TEST +! + INTEGER :: LOGF +! + LOGF=6 ! log file unit +! + TEST=90000.0E0_WP ! +! + CALL CALC_SCALE_PARAM ! +! + WRITE(LOGF,17) ! + WRITE(LOGF,7) ! + WRITE(LOGF,27) ! +! + IF(G_Q <= TEST) THEN ! + WRITE(LOGF,10) G_Q ! + ELSE + WRITE(LOGF,15) G_Q ! + END IF ! + IF(G_C <= TEST) THEN ! + WRITE(LOGF,20) G_C ! + ELSE + WRITE(LOGF,25) G_C ! + END IF ! + IF(R_W <= TEST) THEN ! + WRITE(LOGF,30) R_W ! + ELSE + WRITE(LOGF,35) R_W ! + END IF ! +! + WRITE(LOGF,70) ! +! +! Formats: +! + 10 FORMAT(5X,'|',5X,'quantum scale parameter : ',F10.3,10X,' |') + 20 FORMAT(5X,'|',5X,'classical scale parameter : ',F10.3,10X,' |') + 30 FORMAT(5X,'|',5X,'Wilson ratio : ',F10.3,10X,' |') +! + 15 FORMAT(5X,'|',5X,'quantum scale parameter : ',E12.6,8X,' |') + 25 FORMAT(5X,'|',5X,'classical scale parameter : ',E12.6,8X,' |') + 35 FORMAT(5X,'|',5X,'Wilson ratio : ',E12.6,8X,' |') +! + 7 FORMAT(5X,'|',10X,'Scale parameters : ',25X,'|') + 17 FORMAT(6X,'_________________________________________________________') + 27 FORMAT(5X,'| |') + 70 FORMAT(5X,'|_________________________________________________________|',/) +! + END SUBROUTINE PRINT_SCALE_PARAMETERS +! +END MODULE PRINT_SCALE_PARAM diff --git a/New_libraries/DFM_library/PRINT_LIBRARY/print_thermal.f90 b/New_libraries/DFM_library/PRINT_LIBRARY/print_thermal.f90 new file mode 100644 index 0000000..248b9a0 --- /dev/null +++ b/New_libraries/DFM_library/PRINT_LIBRARY/print_thermal.f90 @@ -0,0 +1,134 @@ +! +!======================================================================= +! +MODULE THERMAL_P +! +! This module defines the thermal parameters +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: K_TH,V_TH,L_TH,CV,P,MU_TH +! +END MODULE THERMAL_P +! +!======================================================================= +! +MODULE PRINT_THERMAL +! +! This module prints the thermal properties in the log file +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_THERMAL_PROP +! + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T + USE THERMAL_PROPERTIES + USE CHEMICAL_POTENTIAL, ONLY : MU +! + USE THERMAL_P +! + IMPLICIT NONE +! + CALL TH_PROP(DMN,RS,T,K_TH,V_TH,L_TH,CV,P) ! + MU_TH=MU(DMN,T) ! +! + END SUBROUTINE CALC_THERMAL_PROP +! +!======================================================================= +! + SUBROUTINE PRINT_THERMAL_PROP +! +! This subroutine prints the thermal properties in the log file +! +! +! +! Author : D. Sébilleau +! +! Last modified : 28 Jul 2020 +! +! + USE CONSTANTS_P1, ONLY : BOHR + USE ENE_CHANGE, ONLY : ANG,EV + USE EXT_FIELDS, ONLY : T +! + USE THERMAL_P +! + IMPLICIT NONE +! + REAL (WP) :: TEST +! + INTEGER :: LOGF +! + LOGF=6 ! log file unit +! + TEST=90000.0E0_WP ! +! + CALL CALC_THERMAL_PROP ! +! + WRITE(LOGF,17) ! + WRITE(LOGF,7) T ! + WRITE(LOGF,27) ! +! + IF(K_TH*BOHR <= TEST) THEN ! + WRITE(LOGF,10) K_TH*ANG ! + ELSE ! + WRITE(LOGF,15) K_TH*ANG ! + END IF ! + IF(V_TH <= TEST) THEN ! + WRITE(LOGF,20) V_TH ! + ELSE ! + WRITE(LOGF,25) V_TH ! + END IF ! + IF(L_TH <= TEST) THEN ! + WRITE(LOGF,30) L_TH/ANG ! + ELSE ! + WRITE(LOGF,35) L_TH/ANG ! + END IF ! + IF(CV <= TEST) THEN ! + WRITE(LOGF,40) CV ! + ELSE ! + WRITE(LOGF,45) CV ! + END IF ! + IF(P <= TEST) THEN ! + WRITE(LOGF,50) P ! + ELSE ! + WRITE(LOGF,55) P ! + END IF ! + IF(MU_TH/EV <= TEST) THEN ! + WRITE(LOGF,60) MU_TH/EV ! + ELSE ! + WRITE(LOGF,65) MU_TH/EV ! + END IF ! +! + WRITE(LOGF,70) ! +! +! Formats: +! + 10 FORMAT(5X,'|',5X,'De Broglie wave vector : ',F10.3,' Å^{-1}',' |') + 20 FORMAT(5X,'|',5X,'thermal velocity : ',F10.3,' m/s',3X,' |') + 30 FORMAT(5X,'|',5X,'Landau length : ',F10.3,' Å |') + 40 FORMAT(5X,'|',5X,'electron specific heat : ',F10.3,' SI |') + 50 FORMAT(5X,'|',5X,'electron pressure : ',F10.3,' SI |') + 60 FORMAT(5X,'|',5X,'chemical potential : ',F10.3,' eV |') +! + 15 FORMAT(5X,'|',5X,'De Broglie wave vector : ',E12.6,' Å^{-1} |') + 25 FORMAT(5X,'|',5X,'thermal velocity : ',E12.6,' m/s |') + 35 FORMAT(5X,'|',5X,'Landau length : ',E12.6,' Å |') + 45 FORMAT(5X,'|',5X,'electron specific heat : ',E12.6,' SI |') + 55 FORMAT(5X,'|',5X,'electron pressure : ',E12.6,' SI |') + 65 FORMAT(5X,'|',5X,'chemical potential : ',E12.6,' eV |') +! + 7 FORMAT(5X,'|',10X,'Thermal properties at T = ',F10.3,' °K : ',5X,'|') + 17 FORMAT(6X,'_________________________________________________________') + 27 FORMAT(5X,'| |') + 70 FORMAT(5X,'|_________________________________________________________|',/) +! + END SUBROUTINE PRINT_THERMAL_PROP +! +END MODULE PRINT_THERMAL diff --git a/New_libraries/DFM_library/PRINT_LIBRARY/print_thermodynamics.f90 b/New_libraries/DFM_library/PRINT_LIBRARY/print_thermodynamics.f90 new file mode 100644 index 0000000..ae275c2 --- /dev/null +++ b/New_libraries/DFM_library/PRINT_LIBRARY/print_thermodynamics.f90 @@ -0,0 +1,154 @@ +! +!======================================================================= +! +MODULE THERMODYNAMICS_P +! +! This module defines the thermodynamical parameters +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: PP,MU,K0,K,BM,U_IN,U_EX,F_FR +! +END MODULE THERMODYNAMICS_P +! +!======================================================================= +! +! +!======================================================================= +! +MODULE PRINT_THERMODYNAMICS +! +! This module prints the thermodynamics properties in the log file +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_THERMODYNAMICS_PROP +! + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T + USE ENERGIES, ONLY : EC_TYPE + USE THERMODYNAMIC_QUANTITIES +! + USE THERMODYNAMICS_P +! + IMPLICIT NONE +! + IF(DMN == '3D') THEN ! + CALL THERMODYNAMICS_3D(EC_TYPE,RS,T,PP,MU,K0,K,BM, & ! + U_IN,U_EX,F_FR) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! + END IF ! +! + END SUBROUTINE CALC_THERMODYNAMICS_PROP +! +!======================================================================= +! + SUBROUTINE PRINT_THERMODYNAMICS_PROP +! +! This subroutine prints the thermodynamics properties in the log file +! +! +! +! Author : D. Sébilleau +! +! Last modified : 29 Jul 2020 +! +! + USE ENE_CHANGE, ONLY : EV + USE EXT_FIELDS, ONLY : T +! + USE THERMODYNAMICS_P +! + REAL (WP) :: TEST +! + INTEGER :: LOGF +! + LOGF=6 ! log file unit +! + TEST=90000.0E0_WP ! +! + CALL CALC_THERMODYNAMICS_PROP ! +! + WRITE(LOGF,17) ! + WRITE(LOGF,7) T ! + WRITE(LOGF,27) ! +! + IF(K0 <= TEST) THEN ! + WRITE(LOGF,10) K0 ! + ELSE ! + WRITE(LOGF,15) K0 ! + END IF ! + IF(K <= TEST) THEN ! + WRITE(LOGF,20) K ! + ELSE ! + WRITE(LOGF,25) K ! + END IF ! + IF(BM <= TEST) THEN ! + WRITE(LOGF,30) BM ! + ELSE ! + WRITE(LOGF,35) BM ! + END IF ! + IF(U_IN/EV <= TEST) THEN ! + WRITE(LOGF,40) U_IN/EV ! + ELSE ! + WRITE(LOGF,45) U_IN/EV ! + END IF ! + IF(U_EX/EV <= TEST) THEN ! + WRITE(LOGF,50) U_EX/EV ! + ELSE ! + WRITE(LOGF,55) U_EX/EV ! + END IF ! + IF(F_FR/EV <= TEST) THEN ! + WRITE(LOGF,60) F_FR/EV ! + ELSE ! + WRITE(LOGF,65) F_FR/EV ! + END IF ! + IF(PP <= TEST) THEN ! + WRITE(LOGF,70) PP ! + ELSE ! + WRITE(LOGF,75) PP ! + END IF ! + IF(MU/EV <= TEST) THEN ! + WRITE(LOGF,80) MU/EV ! + ELSE ! + WRITE(LOGF,85) MU/EV ! + END IF ! +! + WRITE(LOGF,77) ! +! +! Formats: +! + 10 FORMAT(5X,'|',5X,'compressibility (non-interacting) x n : ',F8.3,' SI |') + 20 FORMAT(5X,'|',5X,'compressibility x n : ',F8.3,' SI |') + 30 FORMAT(5X,'|',5X,'bulk modulus : ',F8.3,' Pa |') + 40 FORMAT(5X,'|',5X,'internal energy per electron : ',F8.3,' eV |') + 50 FORMAT(5X,'|',5X,'excess internal energy per el. / k_B T: ',F8.3,' eV |') + 60 FORMAT(5X,'|',5X,'Helmoltz free energy per electron : ',F8.3,' eV |') + 70 FORMAT(5X,'|',5X,'electron pressure : ',F8.3,' SI |') + 80 FORMAT(5X,'|',5X,'chemical potential : ',F8.3,' SI |') +! + 15 FORMAT(5X,'|',5X,'compressibility (non-interacting) x n : ',E12.6,' SI |') + 25 FORMAT(5X,'|',5X,'compressibility x n : ',E12.6,' SI |') + 35 FORMAT(5X,'|',5X,'bulk modulus : ',E12.6,' Pa |') + 45 FORMAT(5X,'|',5X,'internal energy per electron : ',E12.6,' eV |') + 55 FORMAT(5X,'|',5X,'excess internal energy per el. / k_B T: ',E12.6,' eV |') + 65 FORMAT(5X,'|',5X,'Helmoltz free energy per electron : ',E12.6,' eV |') + 75 FORMAT(5X,'|',5X,'electron pressure : ',E12.6,' SI |') + 85 FORMAT(5X,'|',5X,'chemical potential : ',E12.6,' SI |') +! + 7 FORMAT(5X,'|',10X,'Thermodynamics properties at T = ',F8.3,' °K : |') + 17 FORMAT(6X,'_________________________________________________________') + 27 FORMAT(5X,'| |') + 77 FORMAT(5X,'|_________________________________________________________|',/) +! + END SUBROUTINE PRINT_THERMODYNAMICS_PROP +! +ENDMODULE PRINT_THERMODYNAMICS diff --git a/New_libraries/DFM_library/PRINT_LIBRARY/printfiles.f90 b/New_libraries/DFM_library/PRINT_LIBRARY/printfiles.f90 new file mode 100644 index 0000000..190a7dd --- /dev/null +++ b/New_libraries/DFM_library/PRINT_LIBRARY/printfiles.f90 @@ -0,0 +1,45 @@ +! +!======================================================================= +! +MODULE PRINT_FILES +! +! This module contains the Fortran unit numbers +! of the output files +! + IMPLICIT NONE +! + INTEGER :: IO_DF,IO_PZ,IO_SU,IO_CD +! + INTEGER :: IO_PD,IO_EH,IO_E2,IO_CK + INTEGER :: IO_CR,IO_PK +! + INTEGER :: IO_LF,IO_IQ,IO_SF,IO_PC + INTEGER :: IO_P2 + INTEGER :: IO_VX,IO_DC,IO_MD,IO_LD + INTEGER :: IO_DP,IO_LT,IO_BR,IO_PE + INTEGER :: IO_QC,IO_RL,IO_KS,IO_OQ + INTEGER :: IO_ME,IO_MS,IO_ML,IO_MC + INTEGER :: IO_DE,IO_ZE,IO_SR,IO_CW + INTEGER :: IO_CF,IO_EM,IO_MF,IO_SP + INTEGER :: IO_SE,IO_SB,IO_ES,IO_GR + INTEGER :: IO_FD,IO_BE,IO_MX + INTEGER :: IO_SC,IO_DS,IO_NV,IO_MT +! + INTEGER :: IO_GP,IO_PR,IO_CO,IO_CP + INTEGER :: IO_BM,IO_SH,IO_S0,IO_S1 + INTEGER :: IO_DT,IO_PS,IO_IE,IO_EI + INTEGER :: IO_FH,IO_EY +! + INTEGER :: IO_EF,IO_KF,IO_VF,IO_TE,IO_DL +! + INTEGER :: IO_TW,IO_VT,IO_TC +! + INTEGER :: IO_EG,IO_EX,IO_XC,IO_EC + INTEGER :: IO_HF,IO_EK,IO_EP +! + INTEGER :: IO_VI,IO_DI +! + INTEGER :: IO_FP,IO_EL,IO_PO,IO_RF + INTEGER :: IO_VC +! +END MODULE PRINT_FILES diff --git a/New_libraries/DFM_library/SCALE_PARAMETERS_LIBRARY/scale_parameters.f90 b/New_libraries/DFM_library/SCALE_PARAMETERS_LIBRARY/scale_parameters.f90 new file mode 100644 index 0000000..f764689 --- /dev/null +++ b/New_libraries/DFM_library/SCALE_PARAMETERS_LIBRARY/scale_parameters.f90 @@ -0,0 +1,71 @@ +! +!======================================================================= +! +MODULE SCALE_PARAMETERS +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE SCALE_PARAM(R_S,T,G_Q,G_C,R_W) +! +! This subroutine computes different scale parameters: +! - the quantum scale parameter g_Q +! - the classical scale parameter g_C +! - the Wilson ratio R_W +! +! +! +! Input parameters: +! +! * R_S : dimensionless electron Wigner-Seitz radius +! * T : temperature in Kelvin +! +! +! Output variables : +! +! * G_Q : quantum scale parameter +! * G_C : classical scale parameter +! * R_W : Wilson ratio +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOUR,NINE, & + THIRD + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,M_E,K_B + USE G_FACTORS, ONLY : G_E + USE PI_ETC, ONLY : PI2 +! + IMPLICIT NONE +! + REAL (WP) :: R_S,T + REAL (WP) :: G_Q,G_C,R_W + REAL (WP) :: COEF1,COEF2,NUM,DENOM +! + COEF1=TWO*(16.0E0_WP/(NINE*PI2))**THIRD ! + COEF2=(48.0E0_WP*PI2)**THIRD ! +! +! Quantum scale parameter +! + G_Q=COEF1*R_S ! +! +! Classical scale parameter +! + NUM=H_BAR*H_BAR*COEF2 ! + DENOM=M_E*BOHR*BOHR*K_B*T ! + G_C=(NUM/DENOM)/R_S ! +! +! Wilson ratio (HEG value) +! + R_W=FOUR/(G_E*G_E) ! +! + END SUBROUTINE SCALE_PARAM +! +END MODULE SCALE_PARAMETERS diff --git a/New_libraries/DFM_library/SCREENING_LIBRARY/screening_vec1.f90 b/New_libraries/DFM_library/SCREENING_LIBRARY/screening_vec1.f90 new file mode 100644 index 0000000..2dfbded --- /dev/null +++ b/New_libraries/DFM_library/SCREENING_LIBRARY/screening_vec1.f90 @@ -0,0 +1,157 @@ +! +!======================================================================= +! +MODULE SCREENING_VEC +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE SCREENING_VECTOR(SC_TYPE,DMN,X,RS,T,KS_SI) +! +! This subroutine computes the screening vector +! +! +! Input parameters: +! +! * SC_TYPE : type of screeening +! SC_TYPE = 'NO' no screening +! SC_TYPE = 'DH' Debye-Hückel +! SC_TYPE = 'TF' Thomas-Fermi +! * DMN : dimension of the system +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! Output parameters: +! +! * KS_SI : screening vector expressed in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: SC_TYPE,DMN +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: KS_SI +! + IF(SC_TYPE == 'NO') THEN ! + KS_SI = ZERO ! + ELSE IF(SC_TYPE == 'DH') THEN ! + CALL DEBYE_VECTOR(DMN,T,RS,KS_SI) ! + ELSE IF(SC_TYPE == 'TF') THEN ! + CALL THOMAS_FERMI_VECTOR(DMN,KS_SI) ! + END IF ! +! + END SUBROUTINE SCREENING_VECTOR +! +!======================================================================= +! + SUBROUTINE THOMAS_FERMI_VECTOR(DMN,K_TF_SI) +! +! This subroutine computes the Thomas-Fermi screening vector +! +! +! Input parameters: +! +! * DMN : dimension of the system +! DMN = '3D' +! DMN = '2D' +! DMN = '1D' +! +! +! Output parameters: +! +! * K_TF_SI : screening vector expressed in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOUR,EIGHT + USE CONSTANTS_P1, ONLY : BOHR + USE PI_ETC, ONLY : PI + USE FERMI_SI, ONLY : KF_SI +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP) :: K_TF_SI + REAL (WP) :: KOEF +! + REAL (WP) :: SQRT +! + KOEF = BOHR ! +! + IF(DMN == '3D') THEN ! + K_TF_SI = SQRT(FOUR * KF_SI / (PI * KOEF)) ! + ELSE IF(DMN == '2D') THEN ! + K_TF_SI = TWO / KOEF ! + ELSE IF(DMN == '1D') THEN ! + K_TF_SI = SQRT(EIGHT / (KOEF * KF_SI)) ! + END IF ! +! + END SUBROUTINE THOMAS_FERMI_VECTOR +! +!======================================================================= +! + SUBROUTINE DEBYE_VECTOR(DMN,T,RS,KD_SI) +! +! This subroutine computes the Debye screening vector +! +! +! Input parameters: +! +! * DMN : dimension of the system +! DMN = '3D' +! DMN = '2D' +! DMN = '1D' +! * T : system temperature in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Output parameters: +! +! * KD_SI : screening vector expressed in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Jul 2020 +! +! + USE CONSTANTS_P1, ONLY : EPS_0,E,K_B + USE UTILITIES_1, ONLY : RS_TO_N0 +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP) :: T,RS + REAL (WP) :: KD_SI + REAL (WP) :: N0 +! + REAL (WP) :: SQRT +! +! Computing the electron density +! + N0 = RS_TO_N0(DMN,RS) ! +! + KD_SI = SQRT(E * E * N0 / (EPS_0 * K_B * T)) ! +! + END SUBROUTINE DEBYE_VECTOR +! +END MODULE SCREENING_VEC diff --git a/New_libraries/DFM_library/SCREENING_LIBRARY/screening_vec2.f90 b/New_libraries/DFM_library/SCREENING_LIBRARY/screening_vec2.f90 new file mode 100644 index 0000000..92a87a7 --- /dev/null +++ b/New_libraries/DFM_library/SCREENING_LIBRARY/screening_vec2.f90 @@ -0,0 +1,551 @@ +! +!======================================================================= +! +MODULE SCREENING_VEC2 +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE SCREENING_VECTOR2(SC_TYPE,DMN,X,RS,T,KS_SI) +! +! This subroutine computes the screening vector +! +! +! Input parameters: +! +! * SC_TYPE : type of screeening +! SC_TYPE = 'NO' no screening +! SC_TYPE = 'IS' Tago-Utsumi-Ichimaru +! SC_TYPE = 'KL' Kleinman +! SC_TYPE = 'OC' one-component plasma +! SC_TYPE = 'RP' RPA +! SC_TYPE = 'ST' Streitenberger +! SC_TYPE = 'UI' Utsumi-Ichimaru +! SC_TYPE = 'YT' Yasuhara-Takada +! * DMN : dimension of the system +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! Output parameters: +! +! * KS_SI : screening vector expressed in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: SC_TYPE,DMN +! + INTEGER :: I_KL +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: KS_SI +! + I_KL = 1 ! Kleinman switch +! + IF(SC_TYPE == 'NO') THEN ! + KS_SI = ZERO ! + ELSE IF(SC_TYPE == 'IS') THEN ! + CALL TUI_VECTOR(DMN,T,RS,KS_SI) ! + ELSE IF(SC_TYPE == 'KL') THEN ! + CALL KLEINMAN_VECTOR(DMN,X,I_KL,KS_SI) ! + ELSE IF(SC_TYPE == 'OC') THEN ! + CALL OCP_VECTOR(DMN,T,KS_SI) ! + ELSE IF(SC_TYPE == 'RP') THEN ! + CALL RPA_VECTOR(DMN,X,KS_SI) ! + ELSE IF(SC_TYPE == 'ST') THEN ! + CALL STREITENBERGER_VECTOR(DMN,RS,KS_SI) ! + ELSE IF(SC_TYPE == 'UI') THEN ! + CALL UTSUMI_ICHIMARU_VECTOR(DMN,RS,KS_SI) ! + ELSE IF(SC_TYPE == 'YT') THEN ! + CALL YASUHARA_TAKADA_VECTOR(DMN,RS,T,KS_SI) ! + END IF ! +! + END SUBROUTINE SCREENING_VECTOR2 +! +!======================================================================= +! + SUBROUTINE UTSUMI_ICHIMARU_VECTOR(DMN,RS,K_WS_SI) +! +! This subroutine computes the Utsumi-Ichimaru screening vector +! used for computing the screening static structure factor +! +! Reference: K. Utsumi and S. Ichimaru, Phys. Rev. B 22, +! 5203-5212 (1980) +! +! +! Input parameters: +! +! * DMN : dimension of the system +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Output parameters: +! +! * K_WS_SI : screening vector expressed in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,TWO,THREE,HALF + USE PI_ETC, ONLY : PI_INV + USE FERMI_SI, ONLY : KF_SI + USE UTILITIES_1, ONLY : ALFA + USE ENERGIES, ONLY : EC_TYPE + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP), INTENT(IN) :: RS + REAL (WP), INTENT(OUT) :: K_WS_SI +! + REAL (WP) :: ALPHA,EC,D_EC_1,D_EC_2 +! + IF(DMN /= '3D') THEN ! + K_WS_SI = ZERO ! + GO TO 10 ! + END IF ! +! + ALPHA = ALFA('3D') ! +! +! Computing the correlation energy and its derivatives +! + EC = EC_3D(EC_TYPE,1,RS,ZERO) ! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,ZERO,D_EC_1,D_EC_2) ! +! + K_WS_SI = KF_SI * ( THREE * HALF * PI_INV - ALPHA * ( & ! + RS * RS * EC + TWO * RS * D_EC_1 ) & ! ref. (1) eq. (38) + ) ! +! + 10 RETURN +! + END SUBROUTINE UTSUMI_ICHIMARU_VECTOR +! +!======================================================================= +! + SUBROUTINE KLEINMAN_VECTOR(DMN,X,I_KL,K_KL_SI) +! +! This subroutine computes the Kleinman screening vector +! +! Reference: (1) : P. R. Antoniewicz and L. Kleinman, Phys. Rev. B 2, +! 2808-2811 (1970) +! +! +! Input parameters: +! +! * DMN : dimension of the system +! * X : dimensionless factor --> X = q / (2 * k_F) +! * I_KL : switch +! I_KL = 1 : for coefficient A +! I_KL = 2 : for coefficient B +! +! +! +! Output parameters: +! +! * K_KL_SI : screening vector expressed in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Oct 2020 +! +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE FERMI_SI, ONLY : KF_SI + USE LINDHARD_FUNCTION, ONLY : LINDHARD_S + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + INTEGER, INTENT(IN) :: I_KL +! + REAL (WP), INTENT(IN) :: X + REAL (WP), INTENT(OUT) :: K_KL_SI +! + REAL (WP) :: ALF,K2 + REAL (WP) :: Q_SI,K_TF_SI,LR,LI,Z2 +! + REAL (WP) :: EXP,SQRT +! + IF(DMN /= '3D') THEN ! + K_KL_SI = ZERO ! + GO TO 10 ! + END IF ! +! + Q_SI = TWO * X * KF_SI ! q in SI +! + ALF = HALF * (ONE + EXP(-X)) ! ref. (1) eq. (21) +! + IF(I_KL == 1) THEN ! + K2 = TWO * ALF * KF_SI * KF_SI ! + ELSE IF(I_KL == 2) THEN ! + K2 = TWO * KF_SI * KF_SI * (ALF + TWO * X * X) ! + END IF ! +! +! Computing the Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR(DMN,K_TF_SI) ! +! + Z2 = K_TF_SI * K_TF_SI / (Q_SI * Q_SI) ! (q_{TF}/q)^2 +! +! Computing the RPA static dielectric function: +! +! epsilon(q) = 1 + (q_{TF}/q)^2 * LR +! + CALL LINDHARD_S(X,DMN,LR,LI) ! +! + K_KL_SI = SQRT(K2 * Z2 * LR) ! ref. (1) eq. (20) +! + 10 RETURN +! + END SUBROUTINE KLEINMAN_VECTOR +! +!======================================================================= +! + SUBROUTINE STREITENBERGER_VECTOR(DMN,RS,K_ST_SI) +! +! This subroutine computes the Streintenberger screening vector +! +! Reference: (1) : P. Streintenberger, Phys. Stat. Sol. (b) 125, +! 681-692 (1984) +! +! +! Input parameters: +! +! * DMN : dimension of the system +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! +! Output parameters: +! +! * K_ST_SI : screening vector expressed in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Oct 2020 +! +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOUR,HALF + USE PI_ETC, ONLY : PI + USE FERMI_SI, ONLY : KF_SI + USE FIND_ZERO, ONLY : FIND_ZERO_FUNC +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + INTEGER :: I +! + INTEGER, PARAMETER :: N_MAX = 400 ! max. number of points +! + REAL (WP), INTENT(IN) :: RS + REAL (WP), INTENT(OUT) :: K_ST_SI +! + REAL (WP) :: CC,YY,ZEROF + REAL (WP) :: Y(NSIZE),F(NSIZE) +! + REAL (WP), PARAMETER :: Y_MAX = 16.0E0_WP ! max. value of (K_ST_SI / KF_SI)^2 +! + REAL (WP) :: FLOAT,LOG,SQRT +! + IF(DMN /= '3D') THEN ! + K_ST_SI = ZERO ! + GO TO 10 ! + END IF ! +! + CC = PI * KF_SI ! +! +! Constructing the function whose zero is seeked +! +! Abscissa : Y = (K_ST_SI / KF_SI)^2 +! + DO I = 1, N_MAX ! + Y(I) = FLOAT(I) * Y_MAX / FLOAT(N_MAX) ! + YY = Y(I) + F(I) = YY * (CC - HALF + YY * LOG(ONE + FOUR / YY)) - FOUR ! ref. (1) eq. (59) + END DO ! +! +! Finding the zero +! + CALL FIND_ZERO_FUNC(Y,F,N_MAX,ZEROF) ! +! + K_ST_SI = KF_SI * SQRT(ZEROF) ! +! + 10 RETURN +! + END SUBROUTINE STREITENBERGER_VECTOR +! +!======================================================================= +! + SUBROUTINE YASUHARA_TAKADA_VECTOR(DMN,RS,T,K_YT_SI) +! +! This subroutine computes the Yasuhara-Takada screening vector +! +! Reference: (1) : H. Yasuhara and Y. Takada, Phys. Rev. B 43, +! 7200-7211 (1991) +! +! +! Input parameters: +! +! * DMN : dimension of the system +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! +! Output parameters: +! +! * K_YT_SI : screening vector expressed in SI +! +! +! Note: We use here the fact that the isothermal compressibility +! can be expressed as : +! +! K_T^0 4 +! 1 - ------- = ---- alpha RS * gamma_0(RS) +! K_T pi +! +! Author : D. Sébilleau +! +! Last modified : 6 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR + USE PI_ETC, ONLY : PI_INV + USE GAMMA_ASYMPT, ONLY : GAMMA_0_3D + USE UTILITIES_1, ONLY : ALFA + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP), INTENT(OUT) :: K_YT_SI +! + REAL (WP) :: G0,ALPHA + REAL (WP) :: K0K,K_TF_SI +! + REAL (WP) :: SQRT +! + IF(DMN /= '3D') THEN ! + K_YT_SI = ZERO ! + GO TO 10 ! + END IF ! +! + G0 = GAMMA_0_3D(RS,T) ! gamma_0(RS) +! + ALPHA = ALFA('3D') ! +! + K0K = ONE - FOUR * PI_INV * ALPHA * RS * G0 ! K_T^0 / K_T +! + CALL THOMAS_FERMI_VECTOR('3D',K_TF_SI) ! +! + K_YT_SI = K_TF_SI / SQRT(TWO - K0K) ! ref. (1) eq. (3.31) +! + 10 RETURN +! + END SUBROUTINE YASUHARA_TAKADA_VECTOR +! +!======================================================================= +! + SUBROUTINE OCP_VECTOR(DMN,T,K_OC_SI) +! +! This subroutine computes the one-component plasma screening vector +! +! Reference: (1) : S. V. Adamjan, I. M. Tkachenko, +! J.L. Munoz-Cobo Gonzalez and G. Verdu Martin, +! Phys. Rev. E 48, 2067-2072 (1993) +! (2) : N. G. Nilsson, Phys. Stat. Sol. (a) 19, K75 (1973) +! +! +! Input parameters: +! +! * DMN : dimension of the system +! * T : system temperature in SI +! +! +! +! Output parameters: +! +! * K_YT_SI : screening vector expressed in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,HALF,THIRD,FOURTH + USE PI_ETC, ONLY : SQR_PI +! + USE PLASMON_SCALE_P, ONLY : NONID + USE SPECIFIC_INT_7 + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP), INTENT(IN) :: T + REAL (WP), INTENT(OUT):: K_OC_SI +! + REAL (WP) :: K_TF_SI + REAL (WP) :: TH,U,V,ETA + REAL (WP) :: G3O2,FM1O2 +! + REAL (WP) :: LOG,SQRT +! + TH = ONE / NONID ! +! +! Computing the Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR(DMN,K_TF_SI) ! +! +! Calculation of eta = mu / k_B T from the +! relation: +! 3 1 +! F (eta) = --- ----------- +! 1/2 2 TH^{3/2} +! +! with +! +! F (eta) approximated from ref. (2) +! 1/2 +! + G3O2 = HALF * SQR_PI ! Gamma(3/2) + U = G3O2 * THREE * HALF / (TH*1.5E0_WP) ! ref. (1) eq. (3.5) +! + V = (THREE * SQR_PI * U * FOURTH)**(TWO * THIRD) ! ref. (2) eq. (8) + ETA = LOG(U) / (ONE - U*U) + V - & ! + V / (0.24E0_WP + 1.08E0_WP * V)**2 ! +! +! Computing the Fermi-Dirac integral F (eta) +! -1/2 +! + FM1O2 = FD(ETA,-HALF) ! +! + K_OC_SI = K_TF_SI * SQRT(HALF * SQRT(TH) * FM1O2) ! ref. (1) eq. (3.3) +! + END SUBROUTINE OCP_VECTOR +! +!======================================================================= +! + SUBROUTINE RPA_VECTOR(DMN,X,K_RP_SI) +! +! This subroutine computes the RPA screening vector +! +! +! Input parameters: +! +! * DMN : dimension of the system +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! +! Output parameters: +! +! * K_RP_SI : screening vector expressed in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE LINDHARD_FUNCTION, ONLY : LINDHARD_S + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP), INTENT(IN) :: X + REAL (WP), INTENT(OUT):: K_RP_SI +! + REAL (WP) :: K_TF_SI + REAL (WP) :: LR,LI +! +! Computing the Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR(DMN,K_TF_SI) ! +! +! Computing the Lindhard static function +! + CALL LINDHARD_S(X,DMN,LR,LI) ! +! + K_RP_SI = K_TF_SI * LR ! +! + END SUBROUTINE RPA_VECTOR +! +!======================================================================= +! + SUBROUTINE TUI_VECTOR(DMN,RS,T,K_IS_SI) +! +! This subroutine computes the Tago-Utsumi-Ichimaru screening vector +! +! Reference: (1) : K. Tago, K. Utsumi and S. Ichimaru, +! Prog. Theor. Phys. 65, 54-65 (1981) +! +! +! Input parameters: +! +! * DMN : dimension of the system +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : system temperature in SI +! +! +! +! Output parameters: +! +! * K_IS_SI : screening vector expressed in SI +! +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE CONSTANTS_P1, ONLY : BOHR,K_B + USE PLASMON_SCALE_P, ONLY : NONID + USE THERMODYNAMIC_PROPERTIES, ONLY : U_IT_3D +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP), INTENT(IN) :: RS,T + REAL (WP), INTENT(OUT):: K_IS_SI +! + K_IS_SI = - TWO * U_IT_3D(T) / (RS * BOHR * NONID) ! ref. (1) eq. (31) +! + END SUBROUTINE TUI_VECTOR +! +END MODULE SCREENING_VEC2 + diff --git a/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_1.f90 b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_1.f90 new file mode 100644 index 0000000..e77e839 --- /dev/null +++ b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_1.f90 @@ -0,0 +1,161 @@ +! +!======================================================================= +! +MODULE SPECIFIC_INT_1 +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + FUNCTION SQQZ_INT(Q,D) +! +! This function computes the integral +! +! / + pi/d +! d | dqz +! S(q) = ------ sinh(q*d) | ---------------------- +! 2 pi | cosh(q*d) - cos(qz*d) +! / - pi/d +! +! +! / + pi +! 1 | dx +! = ------ sinh(q*d) | ---------------------- +! 2 pi | cosh(q*d) - cos(x) +! / - pi +! +! +! appearing in the calculation of the dielectric function of a +! stacking of 2D electron gas sheets separated by d +! +! +! Input parameters: +! +! * Q : momentum (in SI) +! * D : distance between the 2D sheets (in SI) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ONE,TWO + USE PI_ETC, ONLY : PI + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + REAL (WP) :: Q,D + REAL (WP) :: SQQZ_INT + REAL (WP) :: QD,COEF,X,H,F(NZ_MAX),IN +! + REAL (WP) :: FLOAT,SINH,COSH,COS +! + INTEGER :: J,ID +! + QD = Q * D ! + ID = 1 ! + H = TWO * PI / FLOAT(NZ_MAX - 1) ! step +! + COEF = SINH(QD) / (TWO * PI) ! +! +! Computing the integrand function +! + DO J = 1,NZ_MAX ! + X = - PI + FLOAT(J - 1) * H ! + F(J) = ONE / (COSH(QD) -DCOS(X)) ! + END DO ! +! +! Computing the integral +! + CALL INTEGR_L(F,H,NZ_MAX,NZ_MAX,IN,ID) ! +! + SQQZ_INT = COEF * IN ! +! + END FUNCTION SQQZ_INT +! +!======================================================================= +! + FUNCTION STEI_INT(X,P) +! +! This function computes Steinberg's J_p(x) integral function +! +! / x +! | z^p +! J_p(x) = | ----------------------- dz +! | (e^z - 1)(1 - e^(-z)) +! / 0 +! +! for p >= 2 so that the integrand does not diverge in 0 +! +! +! Input parameters: +! +! * X : upper bound of the integral +! * P : order of the function +! +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ZERO,ONE + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + REAL (WP) :: X + REAL (WP) :: STEI_INT + REAL (WP) :: Z + REAL (WP) :: INTF(NZ_MAX),H,IN +! + REAL (WP) :: FLOAT,EXP +! + INTEGER :: P,J,ID + INTEGER :: LOGF +! + LOGF = 6 ! +! +! Checking for the value of P +! + IF(P < 2) THEN ! + WRITE(LOGF,10) ! + STOP ! + ELSE IF(P == 2) THEN ! + ID = 2 ! integrand not = 0 in 0 + INTF(1) = ONE ! + ELSE ! + ID = 1 ! integrand = 0 in 0 + INTF(1) = ZERO ! + END IF ! +! + H = X / FLOAT(NZ_MAX - 1) ! step +! +! Computing the integrand function +! + DO J = 2,NZ_MAX ! + Z = FLOAT(J - 1) * H ! + INTF(J) = Z**P / ( (EXP(Z) - ONE) * (ONE - EXP(-Z)) ) ! + END DO ! +! +! Computing the integral +! + CALL INTEGR_L(INTF,H,NZ_MAX,NZ_MAX,IN,ID) ! +! + STEI_INT = IN ! +! + 10 FORMAT(5X,'<<<<< ERROR IN STEI_INT FUNCTION >>>>>',/, & + 5X,'<<<<< P SHOULD BE AT LEAST = 2 >>>>>') ! +! + END FUNCTION STEI_INT +! +END MODULE SPECIFIC_INT_1 diff --git a/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_10.f90 b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_10.f90 new file mode 100644 index 0000000..77e4c6e --- /dev/null +++ b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_10.f90 @@ -0,0 +1,128 @@ +! +!======================================================================= +! +MODULE SPECIFIC_INT_10 +! +! This module provides integrals involving the static dielectric function +! +! + USE ACCURACY_REAL + USE ACCURACY_INTEGER +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE INT_PINO(INTG) +! +! +! Reference: (1) D. Pines and P. Nozi\`{e}res, +! "The Theory of Quantum Liquids -- Normal Fermi Liquids", +! (Benjamin, 1966) +! +! +! Input parameters: +! +! * NONE +! +! Output parameters: +! +! * INTG : integral 1 +! +! +! +! +! / 2 +! 1 | 1 +! INTG(x) = ------ | -------------------- dy +! 3 | 4 2 +! k_F / 0 y | eps(y,0) | +! +! +! +! Note : for the RPA dielectric function, +! +! +! eps = 1 + (k_TF / q)^2 * L(y) +! | +! |---> dimensionless Lindhard function +! +! so that we rewrite +! +! +! y^4 | eps(y,0) |^2 = | y^2 + (k_TF / k_F)^2 * L(y) |^2 +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,HALF,TTINY + USE PI_ETC, ONLY : PI_INV + USE CONSTANTS_P1, ONLY : BOHR + USE FERMI_SI, ONLY : KF_SI + USE LINDHARD_FUNCTION, ONLY : LINDHARD_S + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + INTEGER (IW), PARAMETER :: N_I = 1000 ! number of integration steps + INTEGER (IW) :: I ! loop index + INTEGER (IW) :: ID ! integration variable +! + REAL (WP), INTENT(OUT) :: INTG +! + REAL (WP) :: Y_MIN,Y_MAX,Y_STEP + REAL (WP) :: F(N_I) + REAL (WP) :: Y,Y2,X + REAL (WP) :: K_SI,RAT + REAL (WP) :: LR,LI + REAL (WP) :: Q2EPS +! + ID = 2 ! integrand /= 0 at 0 +! + Y_MIN = 0.010E0_WP ! + Y_MAX = TWO ! + Y_STEP = (Y_MAX - Y_MIN) / FLOAT(N_I - 1) ! +! +! Computing (K_TF / k_F)^2 +! + RAT = FOUR * PI_INV / (BOHR * KF_SI) ! +! +! Initialization of integrand function +! + DO I = 1, N_I ! + F(I) = TTINY ! + END DO ! +! +! Computing the integrand function +! + DO I = 1, N_I ! +! + Y = Y_MIN + FLOAT(I - 1) * Y_STEP ! q / k_F + Y2 = Y * Y ! + X = HALF * Y ! q / 2k_F + K_SI = Y * KF_SI ! q in SI +! +! Calculating the Lindhard function +! + CALL LINDHARD_S(X,'3D',LR,LI) ! +! + Q2EPS = Y2 + RAT * LR ! | q^2 * RPA epsilon | +! + F(I) = ONE / (Q2EPS * Q2EPS) ! +! + END DO ! +! +! Computing the integral +! + CALL INTEGR_L(F,Y_STEP,N_I,N_I,INTG,ID) ! +! + INTG = INTG / (KF_SI * KF_SI * KF_SI) ! +! + END SUBROUTINE INT_PINO +! +END MODULE SPECIFIC_INT_10 + diff --git a/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_2.f90 b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_2.f90 new file mode 100644 index 0000000..b79b71a --- /dev/null +++ b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_2.f90 @@ -0,0 +1,198 @@ +! +!======================================================================= +! +MODULE SPECIFIC_INT_2 +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE INT_SQM1(NMAX,X_MAX,IN_MODE,RS,T,A,L,SQ_TYPE, & + GQ_TYPE,IN) +! +! This subroutine computes several integrals involving (S(q)-1), +! where S(q) is the static structure factor. q is represented +! in reduced units X = q / (2*k_F) +! +! +! Input parameters: +! +! * NMAX : dimensioning of the arrays +! * X_MAX : upper integration value +! * IN_MODE : type of integral computed (see below) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * A : dimensionless screening vector / coefficient / X +! * L : power of X or 1/X +! * SQ_TYPE : structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! +! Output parameters: +! +! * IN : integral result +! +! +! +! +! / x_max +! | +! IN = | (SQ(X) - 1 ) dX : IN_MODE = 1 +! | +! / 0 +! +! +! / x_max +! | X^2 +! IN = | ------------- (SQ(X) - 1 ) dX : IN_MODE = 2 +! | (X^2 + A^2) +! / 0 +! +! +! / x_max +! | X^3 +! IN = | ---------------- (SQ(X) - 1 ) dX : IN_MODE = 3 +! | (X^2 + A^2)^2 +! / 0 +! +! +! / x_max +! | +! IN = | X sin(XA) (SQ(X) - 1 ) dX : IN_MODE = 4 +! | +! / 0 +! +! +! / x_max +! | +! IN = | X^L (SQ(X) - 1 ) dX : IN_MODE = 5 +! | +! / 0 +! +! +! / x_max +! | (SQ(X) - 1 ) +! IN = | ------------- dX : IN_MODE = 6 +! | X^L +! / 0 +! +! +! / x_max +! | +! IN = | X F(X,A) (SQ(X) - 1 ) dX : IN_MODE = 7 +! | +! / 0 +! 5 X^2 A ( X^2 - A^2 )^2 | X + A | +! with F(X,A) = --- - ------- + ----- ( ----------- ) Ln |-------| +! 6 2 A^2 4 X ( A^2 ) | X - A | +! +! +! | X + A | +! Note: for X = A , ( X^2 - A^2 )^2 Ln |-------| = 0 +! | X - A | +! +! +! Author : D. Sébilleau +! +! Last modified : 3 Dec 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ZERO,ONE,FIVE,HALF,THIRD + USE STRUCTURE_FACTOR_STATIC, ONLY : STFACT_STATIC_3D + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: NMAX,IN_MODE,L +! + INTEGER :: K ! loop index + INTEGER :: ID + INTEGER :: N1 +! + CHARACTER (LEN = 4) :: GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE +! + REAL (WP), INTENT(IN) :: X_MAX,RS,T,A + REAL (WP), INTENT(OUT) :: IN +! + REAL (WP) :: X_MIN + REAL (WP) :: XA(NZ_MAX),INTF(NZ_MAX) + REAL (WP) :: SQQ,XX,H,FXA + REAL (WP) :: X_STEP,X,EPS +! + REAL (WP) :: FLOAT,ABS,SIN,LOG +! + ID = 1 ! + N1 = NMAX ! index of upper bound +! + EPS = 1.0E-3_WP ! +! + X_MIN = EPS + X_STEP = (X_MAX -X_MIN) / FLOAT(NMAX - 1) ! +! + DO K = 1,NMAX ! +! + XX = X_MIN + FLOAT(K - 1) * X_STEP ! x grid + XA(K) = XX ! + X = HALF * XX ! input for S(q) +! +! Computing the static structure factor S(q) +! + CALL STFACT_STATIC_3D(X,RS,T,SQ_TYPE,GQ_TYPE,SQQ) ! +! +! Computing the integrand function +! + IF(IN_MODE == 1) THEN ! +! + INTF(K) = SQQ - ONE ! +! + ELSE IF(IN_MODE == 2) THEN ! +! + INTF(K) = XX * XX * (SQQ - ONE) / (XX * XX + A * A) ! +! + ELSE IF(IN_MODE == 3) THEN ! +! + INTF(K) = XX * XX * XX * (SQQ - ONE) / & ! + (XX * XX + A * A)**2 ! +! + ELSE IF(IN_MODE == 4) THEN ! +! + INTF(K) = XX * SIN(A * XX) * (SQQ - ONE) ! +! + ELSE IF(IN_MODE == 5) THEN ! +! + INTF(K) = XX**L * (SQQ - ONE) ! +! + ELSE IF(IN_MODE == 6) THEN ! +! + INTF(K) = (SQQ - ONE) / ( XX**L ) ! +! +! + ELSE IF(IN_MODE == 7) THEN ! +! + IF(XX == A) THEN ! + FXA = THIRD ! + ELSE ! + FXA = FIVE * HALF * THIRD - HALF * XX * XX /( A * A) + & ! + HALF * HALF * A / XX * ( XX * XX / & ! + (A * A) - ONE )**2 * & ! F(X,A) + LOG( ABS( (XX + A)/(XX - A) ) ) ! + END IF ! + INTF(K) = XX * FXA * (SQQ - ONE) ! +! + END IF ! +! + END DO ! +! +! + H = XA(2) - XA(1) ! step +! +! Computing the integral +! + CALL INTEGR_L(INTF,H,NMAX,N1,IN,ID) ! +! + END SUBROUTINE INT_SQM1 +! +END MODULE SPECIFIC_INT_2 diff --git a/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_3.f90 b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_3.f90 new file mode 100644 index 0000000..752de5b --- /dev/null +++ b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_3.f90 @@ -0,0 +1,169 @@ +! +!======================================================================= +! +MODULE SPECIFIC_INT_3 +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE INT_GRM1(NMAX,X_MAX,IN_MODE,RS,T,A,L,GR_TYPE, & + RH_TYPE,IN) +! +! This subroutine computes several integrals involving (g(r)-1), +! where g(r) is the pair correlation function. +! +! +! Input parameters: +! +! * NMAX : dimensioning of the arrays +! * X_MAX : upper integration value +! * IN_MODE : type of integral computed (see below) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * A : dimensionless screening vector / coefficient / X +! * L : power of X or 1/X +! * GR_TYPE : pair correlation approximation (3D) +! * RH_TYPE : choice of pair distribution function rho_2(r) (3D) +! +! +! Output parameters: +! +! * IN : integral result +! +! +! +! +! / x_max +! | +! IN = | (g(X) - 1 ) dX : IN_MODE = 1 +! | +! / 0 +! +! +! / x_max +! | +! IN = | X^L (g(X) - 1 ) dX : IN_MODE = 2 +! | +! / 0 +! +! +! / x_max +! | (g(X) - 1 ) +! IN = | ------------- dX : IN_MODE = 3 +! | X^L +! / 0 +! +! +! / x_max +! | 2 sin(AX) +! IN = | X -------- (g(X) - 1 ) dX : IN_MODE = 4 +! | AX +! / 0 +! +! +! / x_max +! | +! IN = | j (AX) (g(X) - 1 ) dX : IN_MODE = 5 +! | 1 +! / 0 +! +! +! / x_max +! | 1 +! IN = | --- j (AX) (g(X) - 1 ) dX : IN_MODE = 6 +! | X 2 +! / 0 +! +! +! +! Author : D. Sébilleau +! +! Last modified : 22 Oct 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ZERO,ONE,THREE + USE PAIR_CORRELATION, ONLY : PAIR_CORRELATION_3D + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: GR_TYPE,RH_TYPE +! + INTEGER, INTENT(IN) :: NMAX,IN_MODE,L + INTEGER :: ID,IR,N1 +! + REAL (WP), INTENT(IN) :: X_MAX,RS,T,A + REAL (WP), INTENT(OUT):: IN + REAL (WP) :: X_MIN,X_STEP,EPS + REAL (WP) :: XA(NZ_MAX),INTF(NZ_MAX) + REAL (WP) :: GR,XX,H,FXA + REAL (WP) :: J0,J1,J2 +! + ID = 1 ! +! + EPS = 1.0E-3_WP ! +! + X_MIN = EPS + X_STEP = (X_MAX -X_MIN) / FLOAT(NMAX - 1) ! +! + N1 = NMAX ! index of upper bound +! + DO IR = 1, NMAX ! +! + XX = X_MIN + FLOAT(IR - 1) * X_STEP ! x grid + XA(IR) = XX ! +! +! Computing the pair correlation function g(r) +! + CALL PAIR_CORRELATION_3D(XX,RS,T,GR_TYPE,RH_TYPE,GR) ! +! +! Computing the integrand function +! + IF(IN_MODE == 1) THEN ! +! + INTF(IR) = GR - ONE ! +! + ELSE IF(IN_MODE == 2) THEN ! +! + INTF(IR) = XX**L * (GR - ONE) ! +! + ELSE IF(IN_MODE == 3) THEN ! +! + INTF(IR) = (GR - ONE) / XX**L ! +! + ELSE IF(IN_MODE == 4) THEN ! +! + J0 = SIN(A * XX) / (A * XX) ! +! + INTF(IR) = XX * XX * (GR - ONE) * J0 ! +! + ELSE IF(IN_MODE == 5) THEN ! +! + J1 = SIN(A * XX) / (A * XX)**2 - COS(A * XX) / (A * XX) ! +! + INTF(IR) = (GR - ONE) * J1 ! +! + ELSE IF(IN_MODE == 6) THEN ! +! + J2 = (THREE - (A * XX)**2) * SIN(A * XX) / (A * XX)**3 - &! + THREE * COS(A * XX) / (A * XX)**2 ! +! + INTF(IR) = (GR - ONE) * J2 / XX ! +! + END IF ! +! + END DO ! +! + H = XA(2) - XA(1) ! step +! +! Computing the integral +! + CALL INTEGR_L(INTF,H,NMAX,N1,IN,ID) ! +! + END SUBROUTINE INT_GRM1 +! +END MODULE SPECIFIC_INT_3 diff --git a/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_4.f90 b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_4.f90 new file mode 100644 index 0000000..32b4147 --- /dev/null +++ b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_4.f90 @@ -0,0 +1,171 @@ +! +!======================================================================= +! +MODULE SPECIFIC_INT_4 +! +! This module provides six integrals used by Kugler to compute +! the local field correction G(q) +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE INT_KUG(X,INTGR_1,INTGR_2,INTGR_3,INTGR_4,INTGR_5, & + INTGR_6) +! +! This subroutine computes six integrals used by Kugler to compute +! the local field correction G(q) +! +! +! Reference: (1) A. A. Kugler, J. Stat. Phys. 12, 35-87 (1975) +! +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! Output parameters: +! +! * INTGR_1 : integral 1 +! * INTGR_2 : integral 2 +! * INTGR_3 : integral 3 +! * INTGR_4 : integral 4 +! * INTGR_5 : integral 5 +! * INTGR_6 : integral 6 +! +! +! / 1 +! | 1 +! INTGR_1 = | ------------- Log |y^2 - 1| dy +! | ( y + x/2) +! / 1-x +! +! +! / 1+x +! | 1 +! INTGR_2 = | ------------- Log |y^2 - 1| dy +! | ( y - x/2) +! / 1 +! +! +! / 1 +! | 1 | y + 1 | +! INTGR_3 = | ------------- Log |-------| dy +! | ( y + x/2) | y - 1 | +! / 1-x +! +! +! / 1+x +! | 1 | y + 1 | +! INTGR_4 = | ------------- Log |-------| dy +! | ( y - x/2) | y - 1 | +! / 1 +! +! +! / 1 _ _ +! | 1 | | +! INTGR_5 = | ------------- | Log |y^2 - 1| + Log |(y + x)^2| - 1 | dy +! | ( y + x/2) |_ _| +! / -1 +! +! +! / 1 _ _ +! | 1 | | y + 1 | | y + x + 1 | | +! INTGR_6 = | ------------- | Log |-------| - Log |-----------| | dy +! | ( y + x/2) | | y - 1 | | y + x - 1 | _| +! / -1 +! +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Sep 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + INTEGER, PARAMETER :: N_I = 100 ! number of integration steps + INTEGER :: I ! loop index + INTEGER :: ID ! integration variable +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: INTGR_1,INTGR_2 + REAL (WP) :: INTGR_3,INTGR_4 + REAL (WP) :: INTGR_5,INTGR_6 +! + REAL (WP) :: I_STEP_1,I_STEP_2 + REAL (WP) :: DO_1,DO_2,DO_3 + REAL (WP) :: DO_4,DO_5,DO_6 + REAL (WP) :: Y1,Y2,Y3,Y4,Y5,Y6 ! integration variables + REAL (WP) :: F1(NZ_MAX),F2(NZ_MAX) + REAL (WP) :: F3(NZ_MAX),F4(NZ_MAX) + REAL (WP) :: F5(NZ_MAX),F6(NZ_MAX) +! + REAL (WP) :: FLOAT,LOG,ABS +! + ID = 1 ! +! +! Initialization of integrand functions +! + DO I = 1, NZ_MAX ! + F1(I) = ZERO ! + F2(I) = ZERO ! + F3(I) = ZERO ! + F4(I) = ZERO ! + F5(I) = ZERO ! + F6(I) = ZERO ! + END DO ! +! + I_STEP_1 = X / FLOAT(N_I -1) ! step for INTGR_1-INTGR_4 + I_STEP_2 = TWO / FLOAT(N_I -1) ! step for INTGR_5-INTGR_6 +! + DO_1 = ONE - X ! \ + DO_2 = ONE ! \ + DO_3 = ONE - X ! \ lower integration + DO_4 = ONE ! / bounds + DO_5 = - ONE ! / + DO_6 = - ONE ! / +! + DO I = 1, N_I ! +! + Y1 = DO_1 + FLOAT(I - 1) * I_STEP_1 ! \ + Y2 = DO_2 + FLOAT(I - 1) * I_STEP_1 ! \ + Y3 = DO_3 + FLOAT(I - 1) * I_STEP_1 ! \ integration + Y4 = DO_4 + FLOAT(I - 1) * I_STEP_1 ! / variable + Y5 = DO_5 + FLOAT(I - 1) * I_STEP_2 ! / + Y6 = DO_6 + FLOAT(I - 1) * I_STEP_2 ! / +! +! Integrand functions +! + F1(I) = LOG(ABS(Y1 * Y1 - ONE)) / (Y1 + HALF * X) ! \ + F2(I) = LOG(ABS(Y2 * Y2 - ONE)) / (Y2 - HALF * X) ! \ + F3(I) = LOG(ABS((Y3 + ONE) / (Y3 - ONE))) / (Y3 + HALF * X) ! \ integrand + F4(I) = LOG(ABS((Y4 + ONE) / (Y4 - ONE))) / (Y4 - HALF * X) ! / function + F5(I) = ( LOG(ABS(Y5 * Y5 - ONE)) + & ! / + LOG(ABS((Y5 + X)**2 - ONE)) ) / (Y5 + HALF * X) ! / + F6(I) = ( LOG(ABS((Y6 + ONE) / (Y6 - ONE))) - & ! | + LOG(ABS((Y6 + X + ONE) / (Y6 + X - ONE))) ) / & ! | + (Y6 + HALF * X) ! | +! + END DO ! +! +! Computing the integrals +! + CALL INTEGR_L(F1,I_STEP_1,NZ_MAX,N_I,INTGR_1,ID) ! \ + CALL INTEGR_L(F2,I_STEP_1,NZ_MAX,N_I,INTGR_2,ID) ! \ + CALL INTEGR_L(F3,I_STEP_1,NZ_MAX,N_I,INTGR_3,ID) ! \ integration + CALL INTEGR_L(F4,I_STEP_1,NZ_MAX,N_I,INTGR_4,ID) ! / results + CALL INTEGR_L(F5,I_STEP_2,NZ_MAX,N_I,INTGR_5,ID) ! / + CALL INTEGR_L(F6,I_STEP_2,NZ_MAX,N_I,INTGR_6,ID) ! / +! + END SUBROUTINE INT_KUG +! +END MODULE SPECIFIC_INT_4 diff --git a/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_5.f90 b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_5.f90 new file mode 100644 index 0000000..1246f6f --- /dev/null +++ b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_5.f90 @@ -0,0 +1,169 @@ +! +!======================================================================= +! +MODULE SPECIFIC_INT_5 +! +! This module numerically computes moments of F(q,omega) functions +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE MOMENTS_FQO(I_F,P,M) +! +! This subroutines computes moments of a F(q,omega) function +! +! Input parameters: +! +! * I_F : type of F(q,omega) function +! I_F = 1 --> epsilon(q,omega) +! I_F = 2 --> Im [ - 1 / epsilon(q,omega) ] +! I_F = 3 --> Pi(q,omega) +! I_F = 4 --> chi(q,omega) +! I_F = 5 --> S(q,omega) +! * P : moment order +! +! +! Output parameters: +! +! * M : resulting moment +! +! +! +! Author : D. Sébilleau +! +! +! Last modified : 9 Oct 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE +! + USE MATERIAL_PROP, ONLY : DMN,RS + USE EXT_FIELDS, ONLY : T,H + USE DF_VALUES, ONLY : EPS_T,D_FUNC + USE SF_VALUES, ONLY : SQ_TYPE,SQO_TYPE +! + USE REAL_NUMBERS, ONLY : ZERO,HALF,FOURTH,SMALL,INF +! + USE Q_GRID + USE E_GRID + USE UNITS, ONLY : UNIT +! + USE UTILITIES_3, + USE COULOMB_K, ONLY : COULOMB_FF + USE DFUNC_STATIC + USE DFUNCT_STAN_DYNAMIC + USE DFUNCL_STAN_DYNAMIC + USE DFUNCL_MAGN_DYNAMIC + USE STRUCTURE_FACTOR_DYNAMIC + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: D_FUNCL,D_FUNCT +! + INTEGER, INTENT(IN) :: I_F,P + INTEGER :: IQ,IE + INTEGER :: ID +! + REAL (WP) :: FQO(NSIZE),RQO(NSIZE),IQO(NSIZE) + REAL (WP) :: Q,X,E,Z + REAL (WP) :: VC,KS,A,NU + REAL (WP) :: REPS,IEPS + REAL (WP) :: RPOL,IPOL + REAL (WP) :: RSUS,ISUS + REAL (WP) :: SQO + REAL (WP) :: IN + REAL (WP) :: M(N_Q),MR(N_Q),MI(N_Q) +! + REAL (WP) :: FLOAT +! + KS = ZERO ! temporary + A = ZERO ! temporary + NU = ZERO ! temporary +! +! Computing the Coulomb potential +! + CALL COULOMB_FF(DMN,UNIT,Q,ZERO,VC) ! +! + DO IQ = 1, N_Q ! q-loop +! + Q = Q_MIN + FLOAT(IQ - 1) * Q_STEP ! Q = q/k_F +! + X = HALF * Q ! X = q/(2k_f) + +! + DO IE = 1, N_E ! energy loop +! + E = E_MIN + FLOAT(IE - 1) * E_STEP ! E = hbar omega / E_F +! + Z = FOURTH * E / (X * X) ! Z = omega / omega_q +! +! Computing the integrand +! + IF(I_F < 5) THEN ! +! + IF(EPS_T == 'LONG') THEN ! longitudinal eps +! + D_FUNCL=D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNCL,IE,REPS,IEPS) ! no magnetic field + ELSE ! + CALL DFUNCL_DYNAMIC_M(X,Z,KS,A,NU,D_FUNCL,REPS,IEPS)! magnetic field + END IF ! + ELSE ! transverse eps + D_FUNCT=D_FUNC ! + IF(H < SMALL) THEN ! + CALL DFUNCT_DYNAMIC(X,Z,D_FUNCT,REPS,IEPS) ! no magnetic field + ELSE ! + CONTINUE ! magnetic field + END IF ! + END IF ! +! + IF(I_F == 1) THEN ! + RQO(IE) = E**P * REPS ! + IQO(IE) = E**P * IEPS ! + ELSE IF(I_F == 2) THEN ! + FQO(IE) = E**P * IEPS / (REPS**2 + IEPS**2) ! + ID = 1 ! + ELSE IF(I_F == 3) THEN ! + CALL EPS_TO_PI(REPS,IEPS,VC,RPOL,IPOL) + RQO(IE) = E**P * RPOL ! + IQO(IE) = E**P * IPOL ! + ELSE IF(I_F == 4) THEN ! + CALL EPS_TO_CHI(REPS,IEPS,VC,RSUS,ISUS) ! + RQO(IE) = E**P * RSUS ! + IQO(IE) = E**P * ISUS ! + END IF ! +! + ELSE IF(I_F == 5) THEN ! +! + CALL STFACT_DYNAMIC(X,Z,RS,T,SQO_TYPE,SQ_TYPE,SQO) ! + FQO(IE) = E**P * SQO ! + ID = 1 ! +! + END IF ! +! + END DO ! end of energy loop +! +! Computation of the integral +! + IF(I_F == 2 .OR. I_F == 5) THEN ! + CALL INTEGR_L(FQO,E_STEP,NSIZE,N_E,IN,ID) ! + M(IQ) = IN ! + ELSE + CALL INTEGR_L(RQO,E_STEP,NSIZE,N_E,IN,2) ! + MR(IQ) = IN ! + CALL INTEGR_L(IQO,E_STEP,NSIZE,N_E,IN,1) ! + MI(IQ) = IN ! + END IF ! +! + END DO ! end of q loop +! + END SUBROUTINE MOMENTS_FQO +! +END MODULE SPECIFIC_INT_5 +! diff --git a/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_6.f90 b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_6.f90 new file mode 100644 index 0000000..85a92aa --- /dev/null +++ b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_6.f90 @@ -0,0 +1,260 @@ +! +!======================================================================= +! +MODULE SPECIFIC_INT_6 +! +! This module computes Macke function and related integrals +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE MACKE_FUNC(Q,IQ) +! +! This subroutine computes Macke function +! +! +! Reference: (1) P. Ziesche, Ann. Phys. (Berlin) 522, 739-765 (2010) +! +! +! Input parameters: +! +! * Q : point q at which the function is computed +! +! +! Output parameters: +! +! * IQ : Macke function at q +! +! +! Author : D. Sébilleau +! +! +! Last modified : 9 Oct 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX +! + USE REAL_NUMBERS, ONLY : EIGHT,SMALL + USE PI_ETC, ONLY : PI +! + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + INTEGER :: IU + INTEGER :: ID +! + INTEGER, PARAMETER :: NU = 200 ! number of integration points +! + REAL (WP), INTENT(IN) :: Q + REAL (WP), INTENT(OUT):: IQ + REAL (WP) :: U_MIN,U_STEP + REAL (WP) :: IN + REAL (WP) :: RQ(NZ_MAX),RQ2(NZ_MAX) +! + REAL (WP), PARAMETER :: U_MAX = 20.0E0_WP ! upper bound for intergration +! + REAL (WP) :: FLOAT,LOG,ATAN +! + U_MIN = SMALL ! + U_STEP = (U_MAX - U_MIN) / FLOAT(NU - 1) ! +! +! Computing the R(q,u) function ! ref. (1) eq. (C12) +! + CALL RQU(Q,RQ) ! +! +! Computing the integrand function ! ref. (1) eq. (C12) +! + DO IU = 1, NU ! +! + RQ2(IU) = RQ(IU) * RQ(IU) ! +! + END DO ! +! +! Computing the integral +! + CALL INTEGR_L(RQ2,U_STEP,NZ_MAX,NU,IN,ID) ! +! + IQ = EIGHT * PI * Q * IN ! +! + END SUBROUTINE MACKE_FUNC +! +!======================================================================= +! + SUBROUTINE RQU(Q,RQ) +! +! This subroutine computes the R(q,u) function +! +! Reference: (1) P. Ziesche, Ann. Phys. (Berlin) 522, 739-765 (2010) +! +! +! +! Author : D. Sébilleau +! +! +! Last modified : 9 Oct 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX +! + USE REAL_NUMBERS, ONLY : ONE,HALF,FOURTH,SMALL +! + IMPLICIT NONE +! + INTEGER :: IU +! + INTEGER, PARAMETER :: NU = 200 ! number of integration points +! + REAL (WP), INTENT(IN) :: Q + REAL (WP) :: Q2,U_MIN,U_STEP,U,U2 + REAL (WP) :: RQ(NZ_MAX) +! + REAL (WP), PARAMETER :: U_MAX = 20.0E0_WP ! upper bound for intergration +! + REAL (WP) :: FLOAT,LOG,ATAN +! + Q2 = Q * Q ! + U_MIN = SMALL ! + U_STEP = (U_MAX - U_MIN) / FLOAT(NU - 1) ! +! +! Computing the function R(q,u) ! ref. (1) eq. (B1) +! + DO IU = 1, NU ! +! + U = U_MIN + FLOAT(IU - 1) * U_STEP ! + U2 = U * U ! +! + RQ(IU) = HALF * ( ONE + HALF * & ! + (ONE + U2 - FOURTH * Q2) / Q * & ! + LOG( ((HALF * Q + ONE)**2 + U2) / & ! + ((HALF * Q - ONE)**2 + U2) & ! + ) - & ! + U * ( ATAN((ONE + HALF * Q)/U) + & ! + ATAN((ONE - HALF * Q)/U) & ! + ) & ! + ) ! +! + END DO ! +! + END SUBROUTINE RQU +! +!======================================================================= +! + SUBROUTINE R0U(R0) +! +! This subroutine computes the R_0(u) function +! +! Reference: (1) P. Ziesche, Ann. Phys. (Berlin) 522, 739-765 (2010) +! +! +! +! Author : D. Sébilleau +! +! +! Last modified : 9 Oct 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX +! + USE REAL_NUMBERS, ONLY : ONE,SMALL +! + IMPLICIT NONE +! + INTEGER :: IU +! + INTEGER, PARAMETER :: NU = 200 ! number of integration points +! + REAL (WP), INTENT(OUT):: R0(NZ_MAX) + REAL (WP) :: U_MIN,U_STEP + REAL (WP) :: U +! + REAL (WP), PARAMETER :: U_MAX = 20.0E0_WP ! upper bound for intergration +! + REAL (WP) :: FLOAT,ATAN +! + U_MIN = SMALL ! + U_STEP = (U_MAX - U_MIN) / FLOAT(NU - 1) ! +! +! Computing the function R(q,u) ! ref. (1) eq. (B1) +! + DO IU = 1, NU ! +! + U = U_MIN + FLOAT(IU - 1) * U_STEP ! +! + R0(IU) = ONE - U * ATAN(ONE / U) ! +! + END DO ! +! + END SUBROUTINE R0U +! +!======================================================================= +! + SUBROUTINE RPA_CONSTANTS(A,BPR) +! +! This subroutine computes the main RPA constants +! +! Reference: (1) P. Ziesche, Ann. Phys. (Berlin) 522, 739-765 (2010) +! +! +! +! Author : D. Sébilleau +! +! +! Last modified : 9 Oct 2020 +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX +! + USE REAL_NUMBERS, ONLY : ONE,THREE,SMALL + USE PI_ETC, ONLY : PI3 +! + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + INTEGER :: IU + INTEGER :: ID +! + INTEGER, PARAMETER :: NU = 200 ! number of integration points +! + REAL (WP), INTENT(OUT):: A,BPR + REAL (WP) :: U_MIN,U_STEP + REAL (WP) :: R0(NZ_MAX) + REAL (WP) :: INT1(NZ_MAX),INT2(NZ_MAX) + REAL (WP) :: IN1,IN2 +! + REAL (WP), PARAMETER :: U_MAX = 20.0E0_WP ! upper bound for intergration +! + REAL (WP) :: FLOAT,LOG +! + ID = 2 ! +! + U_MIN = SMALL ! + U_STEP = (U_MAX - U_MIN) / FLOAT(NU - 1) ! +! +! Computing the R0(u) function ! +! + CALL R0U(R0) ! +! +! Computing the integrand function ! +! + DO IU = 1, NU ! +! + INT1(IU) = R0(IU) * R0(IU) ! + INT2(IU) = R0(IU) * R0(IU) * LOG(R0(IU)) ! +! + END DO ! +! + CALL INTEGR_L(INT1,U_STEP,NZ_MAX,NU,IN1,ID) ! + CALL INTEGR_L(INT2,U_STEP,NZ_MAX,NU,IN2,ID) ! +! + A = THREE * IN1 / PI3 ! + BPR = THREE * IN2 / PI3 ! +! + END SUBROUTINE RPA_CONSTANTS +! +END MODULE SPECIFIC_INT_6 diff --git a/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_7.f90 b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_7.f90 new file mode 100644 index 0000000..762d9b1 --- /dev/null +++ b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_7.f90 @@ -0,0 +1,100 @@ +! +!======================================================================= +! +MODULE SPECIFIC_INT_7 +! +! This module computes the Fermi-Dirac integrals +! +! + USE ACCURACY_REAL + USE ACCURACY_INTEGER + USE MINMAX_VALUES +! +CONTAINS +! +!======================================================================= +! + FUNCTION FD(ETA,NU) +! +! This function return a Fermi-Dirac integral +! +! / + INF nu +! | x +! F (eta) = | ------------------ dx +! nu | exp(x - eta) + 1 +! / 0 +! +! +! Input parameters: +! +! * ETA : parameter +! * NU : power of x +! +! +! Output parameters: +! +! * FD : value of the Fermi-Dirac integral +! +! +! Author : D. Sébilleau +! +! +! Last modified : 4 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,SMALL,MIC +! + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + INTEGER (IW) :: IX + INTEGER (IW) :: ID +! + INTEGER (IW), PARAMETER :: NX = 1000 ! number of integration points +! + REAL (WP), INTENT(IN) :: ETA,NU + REAL (WP) :: FD + REAL (WP) :: X_MIN,X_STEP,X + REAL (WP) :: IN + REAL (WP) :: INTG(NX) + REAL (WP) :: XMETA + REAL (WP) :: MAX_EXP,MIN_EXP +! + REAL (WP), PARAMETER :: X_MAX = 20.0E0_WP ! upper bound for integration +! + REAL (WP) :: FLOAT,EXP +! +! Computing the max and min value of the exponent of e^x +! + CALL MINMAX_EXP(MAX_EXP,MIN_EXP) ! +! + ID = 2 ! +! + X_MIN = SMALL ! + X_STEP = (X_MAX - X_MIN) / FLOAT(NX - 1) ! +! +! Computing the integrand function ! +! + DO IX = 1, NX ! +! + X = X_MIN + FLOAT(IX - 1) * X_STEP ! +! + XMETA = X - ETA ! + IF(XMETA > MIN_EXP) THEN ! + INTG(IX) = X**NU / (ONE + EXP(X - ETA)) ! + ELSE ! + INTG(IX) = X**NU ! pathological case + END IF ! +! + END DO ! +! +! Computing the integral +! + CALL INTEGR_L(INTG,X_STEP,NX,NX,IN,ID) ! +! + FD = IN ! +! + END FUNCTION FD +! +END MODULE SPECIFIC_INT_7 diff --git a/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_8.f90 b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_8.f90 new file mode 100644 index 0000000..5846af0 --- /dev/null +++ b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_8.f90 @@ -0,0 +1,217 @@ +! +!======================================================================= +! +MODULE SPECIFIC_INT_8 +! +! This module provides integrals to compute the real part +! of the dielectric function +! +! + USE ACCURACY_REAL + USE ACCURACY_INTEGER + USE MINMAX_VALUES +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE INT_ARB(X,A,B,INTG) +! +! This subroutine computes an integral often used +! to compute the real part of the dielectric function +! +! +! Reference: (1) N. R. Arista and W. Brandt, Phys. Rev. A 29, +! 1471-1480 (1984) +! (2) M. D. Barriga-Carrasco, Phys. Rev. E 76, 016405 (2007) +! +! +! +! Input parameters: +! +! * X : dimensionless parameter +! * A : parameter of the exponential +! * B : parameter of the exponential +! +! Output parameters: +! +! * INTG : integral 1 +! +! +! +! +! / INF +! | y | x + y | +! INTG = | ------------------- Log |-------| dy +! | exp(A y^2 - B) + 1 | x - y | +! / 0 +! +! +! +! Warning: the integrand becomes infinite when y = x. We correct +! this problem by making a linear interpolation at this value +! +! Warning: the exponential can come quickly too large or too small +! to be represented. We need to test it exponent against +! MAX_EXP and MIN_EXP which represents the limits of the +! representation of e^x for real numbers of kind WP +! +! +! Note: If x < 0, then INTG (x) = - INTG (-x) +! so, we compute the integral only for z = |x| +! +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF,SMALL,LARGE,TTINY,INF,MIC + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + INTEGER (IW), PARAMETER :: N_I = 1000 ! number of integration steps +! + INTEGER (IW) :: I ! loop index + INTEGER (IW) :: I0 ! pathological index + INTEGER (IW) :: ID ! integration variable + INTEGER (IW) :: ISGN ! sign of X +! + REAL (WP), INTENT(IN) :: X,A,B + REAL (WP), INTENT(OUT) :: INTG +! + REAL (WP) :: MAX_EXP,MIN_EXP + REAL (WP) :: Z + REAL (WP) :: Y_MIN,Y_MAX,Y_STEP + REAL (WP) :: Y,Y2 + REAL (WP) :: F(N_I) + REAL (WP) :: INTGR + REAL (WP) :: AYB,LN,DEN,LNN +! + REAL (WP) :: FLOAT,LOG,ABS,EXP +! +! Computing the max and min value of the exponent of e^x +! + CALL MINMAX_EXP(MAX_EXP,MIN_EXP) ! +! + ID = 1 ! integrand = 0 at 0 +! + I0 = 0 ! counter for pathological case +! + IF(X < ZERO) THEN ! + Z = - X ! + ISGN = - 1 ! + ELSE ! + Z = X ! + ISGN = 1 ! + END IF ! +! + Y_MIN = 0.010E0_WP ! + Y_MAX = 4.0E0_WP ! + Y_STEP = (Y_MAX - Y_MIN) / FLOAT(N_I - 1) ! +! +! Initialization of integrand function +! + DO I = 1, N_I ! + F(I) = TTINY ! + END DO ! +! +! Computing the integrand function +! + DO I = 1, N_I ! +! + Y = Y_MIN + FLOAT(I - 1) * Y_STEP ! + Y2 = Y * Y ! +! + AYB = A * Y2 - B ! exponent of denominator +! +! Evaluation of the denominator +! + IF(AYB >= ZERO) THEN ! + IF(AYB < MAX_EXP) THEN ! + DEN = EXP(AYB) + ONE ! + ELSE ! + DEN = LARGE ! <-- e^{ayb} too large for being represented + END IF ! + ELSE ! + IF(AYB > MIN_EXP) THEN ! + DEN = EXP(AYB) + ONE ! + ELSE ! + DEN = ONE ! <-- e^{ayb} too small for being represented + END IF ! + END IF ! +! +! Evaluation of the logarithm (note: z always >= 0) +! + IF(ABS(Z - Y) <= SMALL) THEN ! + LN = LARGE ! <-- logarithm infinite + ELSE ! + LN = LOG( ABS( (Z + Y) / (Z - Y) ) ) ! + END IF ! +! +! Case where calculation is not done +! + IF(LN == INF) THEN ! + F(I) = LARGE ! + I0 = I ! + GO TO 10 ! + END IF ! +! + IF(DEN == INF) THEN ! + F(I) = TTINY ! + ELSE ! +! +! Checking if LN/DEN can be represented +! +! + LNN = LOG(LN) - LOG(DEN) ! + IF(LNN >= ZERO) THEN ! + IF(LNN < MAX_EXP / Y2) THEN ! + F(I) = Y * LN / DEN ! + ELSE ! + F(I) = LARGE ! + END IF ! + ELSE ! + IF(LNN > MIN_EXP / Y2) THEN ! + F(I) = Y * LN / DEN ! + ELSE ! + F(I)= TTINY ! + END IF ! + END IF +! + END IF ! +! + 10 CONTINUE +! + END DO ! +! +! Correcting the pathological values +! through linear interpolation +! + IF(I0 /= 0) THEN ! + IF(I0 == 1) THEN ! + F(I0) = TWO * F(I0+1) - F(I0+2) ! + ELSE IF (I0 == N_I) THEN ! + F(I0) = TWO * F(I0-1) - F(I0-2) ! + ELSE ! + F(I0) = HALF * (F(I0-1) + F(I0+1)) ! + END IF ! + END IF ! +! +! Computing the integral +! + CALL INTEGR_L(F,Y_STEP,N_I,N_I,INTGR,ID) ! +! +! Final result +! + IF(ISGN == 1) THEN ! + INTG = INTGR ! + ELSE ! + INTG = - INTGR ! + END IF ! +! + END SUBROUTINE INT_ARB +! +END MODULE SPECIFIC_INT_8 diff --git a/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_9.f90 b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_9.f90 new file mode 100644 index 0000000..78f2681 --- /dev/null +++ b/New_libraries/DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_9.f90 @@ -0,0 +1,185 @@ +! +!======================================================================= +! +MODULE SPECIFIC_INT_9 +! +! This module provides integrals to compute the real part +! of the dielectric function +! +! + USE ACCURACY_REAL + USE ACCURACY_INTEGER + USE MINMAX_VALUES +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE INT_XIZ(X,A,B,INTG) +! +! This subroutine computes an integral often used +! to compute the real part of the dielectric function +! +! +! Reference: (1) Yu. V. Arkhipov et al, +! Contrib. Plasma Phys. 58, 967–975 (2018) +! +! +! +! Input parameters: +! +! * X : dimensionless parameter +! * A : parameter of the exponential +! * B : parameter of the exponential +! +! Output parameters: +! +! * INTG : integral 1 +! +! +! +! +! / + INF +! | 1 + exp(B) 1 +! INTG(x) = | --------------------- ------- dy +! | exp(A y^2) + exp(B) y - x +! / - INF +! +! +! +! Warning: the integrand becomes infinite when y = x. We correct +! this problem by making a linear interpolation at this value +! +! Warning: the exponential can come quickly too large or too small +! to be represented. We need to test it exponent against +! MAX_EXP and MIN_EXP which represents the limits of the +! representation of e^x for real numbers of kind WP +! +! +! +! +! Author : D. Sébilleau +! +! Last modified : 27 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF,LARGE,TTINY + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + INTEGER (IW), PARAMETER :: N_I = 1000 ! number of integration steps + INTEGER (IW) :: I ! loop index + INTEGER (IW) :: I0 ! pathological index + INTEGER (IW) :: ID ! integration variable +! + REAL (WP), INTENT(IN) :: X,A,B + REAL (WP), INTENT(OUT) :: INTG + REAL (WP) :: MAX_EXP,MIN_EXP + REAL (WP) :: EXA,EXB + REAL (WP) :: Y_MIN,Y_MAX,Y_STEP + REAL (WP) :: Y,Y2 + REAL (WP) :: F(N_I) + REAL (WP) :: AY2,NUM,DEN +! + REAL (WP) :: FLOAT,EXP +! +! Computing the max and min value of the exponent of e^x +! + CALL MINMAX_EXP(MAX_EXP,MIN_EXP) ! +! + ID = 2 ! integrand /= 0 at 0 +! + I0 = 0 ! counter for pathological case +! +! Evaluation of the exp(B) +! + IF(B >= ZERO) THEN ! + IF(B < HALF * MAX_EXP) THEN ! + EXB = EXP(B) ! + ELSE ! + EXB = LARGE ! <-- e^{b} too large for being represented + END IF ! + ELSE ! + IF(B > HALF * MIN_EXP) THEN ! + EXB = EXP(B) ! + ELSE ! + EXB = TTINY ! <-- e^{b} too small for being represented + END IF ! + END IF ! +! + Y_MIN = - 4.0E0_WP ! + Y_MAX = 4.0E0_WP ! + Y_STEP = (Y_MAX - Y_MIN) / FLOAT(N_I - 1) ! +! +! Initialization of integrand function +! + DO I = 1, N_I ! + F(I) = TTINY ! + END DO ! +! +! Computing the integrand function +! + DO I = 1, N_I ! +! + Y = Y_MIN + FLOAT(I - 1) * Y_STEP ! + Y2 = Y * Y ! +! + AY2 = A * Y2 ! +! +! Evaluation of the exp(Ay^2) +! + IF(AY2 >= ZERO) THEN ! + IF(AY2 < HALF * MAX_EXP) THEN ! + EXA = EXP(AY2) ! + ELSE ! + EXA = LARGE ! <-- e^{ay^2} too large for being represented + END IF ! + ELSE ! + IF(AY2 > HALF * MIN_EXP) THEN ! + EXA = EXP(AY2) ! + ELSE ! + EXA = TTINY ! <-- e^{ay^2} too small for being represented + END IF ! + END IF ! +! +! Case where calculation is not done +! + IF(Y == X) THEN ! + F(I) = LARGE ! + I0 = I ! + GO TO 10 ! + END IF ! +! +! Computing the integrand function +! + NUM = ONE + EXB ! + DEN = (EXA + EXB) * (Y - X) ! +! + F(I) = NUM / DEN ! +! + 10 CONTINUE +! + END DO ! +! +! Correcting the pathological values +! through linear interpolation +! + IF(I0 /= 0) THEN ! + IF(I0 == 1) THEN ! + F(I0) = TWO * F(I0+1) - F(I0+2) ! + ELSE IF (I0 == N_I) THEN ! + F(I0) = TWO * F(I0-1) - F(I0-2) ! + ELSE ! + F(I0) = HALF * (F(I0-1) + F(I0+1)) ! + END IF ! + END IF ! +! +! Computing the integral +! + CALL INTEGR_L(F,Y_STEP,N_I,N_I,INTG,ID) ! +! + END SUBROUTINE INT_XIZ +! +END MODULE SPECIFIC_INT_9 + diff --git a/New_libraries/DFM_library/SPECTRAL_FUNCTION_LIBRARY/spectral_function.f90 b/New_libraries/DFM_library/SPECTRAL_FUNCTION_LIBRARY/spectral_function.f90 new file mode 100644 index 0000000..23b32d4 --- /dev/null +++ b/New_libraries/DFM_library/SPECTRAL_FUNCTION_LIBRARY/spectral_function.f90 @@ -0,0 +1,253 @@ +! +!======================================================================= +! +MODULE SPECTRAL_FUNCTION +! + USE ACCURACY_REAL +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE SPEC_FUNC_3D(X,Z,RS,T,SPF_TYPE,AQ) +! +! This subroutine computes a spectral function A(q,omega) +! for 3D systems +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega()_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * SPF_TYPE : spectral function type +! SPF_TYPE = 'NAIC' Nakano-Ichimaru approximation +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Sep 2020 +! +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: SPF_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT) :: AQ +! + IF(SPF_TYPE == 'NAIC') THEN ! + AQ = NAIC_SP(X,Z,T) ! + END IF ! +! + END SUBROUTINE SPEC_FUNC_3D +! +!======================================================================= +! + FUNCTION NAIC_SP(X,Z,T) +! +! This function computes the Nakano-Ichimaru approximation for +! the dynamical structure factor S(q,omega) for 3D systems +! +! References: +! +! Input parameters: (1) A. Nakano and S. Ichimaru, Phys. Rev. B 39, +! 4938-4944 (1989) +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Sep 2020 +! +! + USE MATERIAL_PROP, ONLY : RS + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR, & + HALF,THIRD,FOURTH + USE PI_ETC, ONLY : PI,PI_INV + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,T + REAL (WP) :: NAIC_SP + REAL (WP) :: Y,Y2,ALPHA,OMP,OMG + REAL (WP) :: MB,G1,G2,G3,G4 + REAL (WP) :: Z1,Z2,OPH,GPH,CPH + REAL (WP) :: QC + REAL (WP) :: R1,R2,R3,R4,R5,R6,R7,R8 + REAL (WP) :: A(0:5),B(0:4),C(0:8),D(0:8) + REAL (WP) :: E(0:4),F(0:4),G(0:4),H(0:4) + REAL (WP) :: I(0:5),J(0:6),K(0:4),L(0:8) + REAL (WP) :: ZQPK,ZPHK,ZBGS,ZBGI,OQPK + REAL (WP) :: GQPK,OPHK,GPHK,OBGS,OBGI + REAL (WP) :: KC,K5,K6 + REAL (WP) :: YOKC,YOK1,ZQP1 + REAL (WP) :: A_QP,A_PH,A_BG +! + REAL (WP) :: SQRT,LOG,EXP +! + DATA A / 0.95566E0_WP , - 0.015485E0_WP , 0.012991E0_WP , & ! mb polynomial + - 0.0042626E0_WP , 0.00048299E0_WP ,- 1.8255E-05_WP / ! coefficients +! + DATA B / 0.14694E0_WP , 0.09893E0_WP ,- 0.01982E0_WP , & ! gamma_1 polynomial + 0.0035589E0_WP , - 0.0001342E0_WP / ! coefficients +! + DATA C / 11.217E0_WP , -19.345E0_WP , 17.044E0_WP , & ! gamma_2 polynomial + - 8.0637E0_WP , 2.239E0_WP ,- 0.37438E0_WP , & ! coefficients + 0.0370160_WP , - 0.0019907E0_WP , 4.4836E-05_WP / ! +! + DATA D / 84.0E0_WP ,- 158.99E0_WP ,133.44E0_WP , & ! gamma_3 polynomial + - 60.994E0_WP , 16.449E0_WP ,- 2.6852E0_WP , & ! coefficients + 0.26036E0_WP , - 0.013781E0_WP , 0.00030639E0_WP / ! +! + DATA E / 2.4276E0_WP , - 0.78543E0_WP , 0.19432E0_WP , & ! gamma_4 polynomial + - 0.019369E0_WP , 0.00068405E0_WP / ! coefficients +! + DATA F / 0.0016811E0_WP , 0.16429E0_WP ,- 0.025994E0_WP , & ! z1 polynomial + 0.002031E0_WP , - 6.6367E-05_WP / ! coefficients +! + DATA G / 0.077768E0_WP , 0.10837E0_WP ,- 0.019335E0_WP , & ! z2 polynomial + 0.0032477E0_WP , - 0.00014138E0_WP / ! coefficients +! + DATA H / - 1.5992E0_WP , - 0.67358E0_WP , 0.053912E0_WP , & ! omega_ph polynomial + - 0.0031731E0_WP , 8.8869E-05_WP / ! coefficients +! + DATA I / 0.086133E0_WP , - 0.086136E0_WP , 0.03301E0_WP , & ! gamma_ph polynomial + - 0.0056481E0_WP , 0.00046469E0_WP ,- 1.4487E-05_WP / ! coefficients +! + DATA J / 10.161E0_WP , - 11.071E0_WP , 5.3875E0_WP , & ! c_ph polynomial + - 1.327E0_WP , 0.17581E0_WP ,- 0.011883E0_WP , & ! coefficients + 0.00032153E0_WP / ! +! + DATA K / 0.25244E0_WP , 0.23827E0_WP ,- 0.045418E0_WP , & ! qc polynomial + 0.0042734E0_WP , - 0.00015059E0_WP / ! coefficients +! + DATA L / 0.26548E0_WP , - 1.1141E0_WP , 1.5208E0_WP , & ! k6 polynomial + - 0.82343E0_WP , 0.24225E0_WP ,- 0.041703E0_WP , & ! coefficients + 0.004191E0_WP , - 0.00022763E0_WP , 5.1593E-06_WP / ! +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + ALPHA = ALFA('3D') ! +! + OMP = SQRT(16.0E0_WP * ALPHA * RS * PI_INV * THIRD) ! h_bar omega_p / E_F +! + OMG = FOUR * Z * X * X ! h_bar omega / E_F +! +! Powers of RS +! + R1 = RS ! + R2 = R1 * R1 ! + R3 = R2 * R1 ! + R4 = R3 * R1 ! + R5 = R4 * R1 ! + R6 = R5 * R1 ! + R7 = R6 * R1 ! + R8 = R7 * R1 ! +! +! Fitting parameters as a function of RS +! + MB = A(0) + A(1) * R1 + A(2) * R2 + A(3) * R3 + & ! + A(4) * R4 + A(5) * R5 ! + G1 = B(0) + B(1) * R1 + B(2) * R2 + B(3) * R3 + & ! + B(4) * R4 ! + G2 = C(0) + C(1) * R1 + C(2) * R2 + C(3) * R3 + & ! + C(4) * R4 + C(5) * R5 + C(6) * R6 + & ! + C(7) * R7 + C(8) ! + G3 = D(0) + D(1) * R1 + D(2) * R2 + D(3) * R3 + & ! + D(4) * R4 + D(5) * R5 + D(6) * R6 + & ! + D(7) * R7 + D(8) ! + G4 = E(0) + E(1) * R1 + E(2) * R2 + E(3) * R3 + & ! + E(4) * R4 ! + Z1 = F(0) + F(1) * R1 + F(2) * R2 + F(3) * R3 + & ! + F(4) * R4 ! + Z2 = G(0) + G(1) * R1 + G(2) * R2 + G(3) * R3 + & ! + G(4) * R4 ! + OPH = H(0) + H(1) * R1 + H(2) * R2 + H(3) * R3 + & ! + H(4) * R4 ! + GPH = I(0) + I(1) * R1 + I(2) * R2 + I(3) * R3 + & ! + I(4) * R4 + I(5) * R5 ! + CPH = J(0) + J(1) * R1 + J(2) * R2 + J(3) * R3 + & ! + J(4) * R4 + J(5) * R5 + J(6) * R6 ! + QC = K(0) + K(1) * R1 + K(2) * R2 + K(3) * R3 + & ! + K(4) * R4 ! + K6 = L(0) + L(1) * R1 + L(2) * R2 + L(3) * R3 + & ! + L(4) * R4 + L(5) * R5 + L(6) * R6 + & ! + L(7) * R7 + L(8) ! +! + KC = QC + ONE ! + K5 = (FOUR * THIRD / SQRT(PI))**THIRD ! +! + YOKC = Y / KC ! + YOK1 = ONE / KC ! +! + ZQPK = (Z1 + Z2 * YOKC * YOKC) * ( HALF + & ! + (ONE - YOKC * YOKC) * LOG( & ! + ABS((ONE + YOKC) / (ONE - YOKC)) ) & ! ref. (1) eq. (30) + ) / & ! + (ONE + YOKC * YOKC) ! + ZQP1 = (Z1 + Z2 * YOK1 * YOK1) * ( HALF + & ! + (ONE - YOK1 * YOK1) * LOG( & ! case Y = 1 + ABS((ONE + YOK1) / (ONE - YOK1)) ) & ! + ) / & ! + (ONE + YOK1 * YOK1) + ZPHK = (ONE - ZQP1) * EXP(- (Y / K5)**2 - (Y / K6)**2) ! ref. (1) eq. (31) + ZBGS = ONE - ZQPK - (ONE - ZQP1) * (ONE - EXP(- (Y / K5)**2)) ! ref. (1) eq. (32) + ZBGI = (ONE - ZQP1) * EXP(- (Y / K5)**2) * ( & ! + ONE - EXP(- (Y / K6)**6) & ! ref. (1) eq. (33) + ) ! + OQPK = (Y2 - ONE) / MB ! ref. (1) eq. (34) + IF(Y <= ONE) THEN ! + GQPK = G1 * (Y - ONE)**2 / (ONE + G2 * (Y - ONE)**2) ! ref. (1) eq. (35a) + ELSE ! + GQPK = ONE / & ! + ( G3 * (QC / (Y - ONE))**2 + & ! + 32.0E0_WP * G4 * (Y - ONE) / & ! ref. (1) eq. (35b) + ( THREE * PI * OMP**3 * & ! + LOG(ABS(TWO * (Y - ONE) / OMP + ONE)) & ! + ) & ! + ) ! + END IF ! + OPHK = OPH - (OPH + OMP) * Y2 ! ref. (1) eq. (36) + GPHK = GPH + CPH * Y2 ! ref. (1) eq. (37) + IF(Y <= ONE) THEN ! + OBGS = OMP * (ONE - Y) ! ref. (1) eq. (38a) + ELSE ! + OBGS = OQPK + OMP ! ref. (1) eq. (38b) + END IF ! + IF(Y <= ONE) THEN ! + OBGI = OPHK ! ref. (1) eq. (39a) + ELSE ! + OBGI = - OMP * (Y - ONE) ! ref. (1) eq. (39b) + END IF ! +! +! Quasiparticle peak +! + A_QP = ZQPK * EXP(- (OMG - OQPK)**2 / GQPK**2) / & ! ref. (1) eq. (27) + (SQRT(PI) * GQPK) ! +! +! Plasmon-hole resonant peak +! + A_PH = ZPHK * EXP(- (OMG - OPHK)**2 / GPHK**2) / & ! ref. (1) eq. (28) + (SQRT(PI) * GPHK) ! +! +! Background contribution +! + IF(OMG >= ZERO) THEN ! + A_BG = FOUR * ZBGS * OMG**2 * EXP( - OMG**2 / OBGS**2) / & ! + (SQRT(PI) * OBGS**3) ! + ELSE ! ref. (1) eq. (28) + A_BG = FOUR * ZBGI * OMG**2 * EXP( - OMG**2 / OBGI**2) / & ! + (SQRT(PI) * OBGI**3) ! + END IF ! +! + NAIC_SP = A_QP + A_PH + A_BG ! +! + END FUNCTION NAIC_SP +! +END MODULE SPECTRAL_FUNCTION diff --git a/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/PhysRevA.8.990.pdf b/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/PhysRevA.8.990.pdf new file mode 100644 index 0000000..b006025 Binary files /dev/null and b/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/PhysRevA.8.990.pdf differ diff --git a/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_dynamic.f90 b/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_dynamic.f90 new file mode 100644 index 0000000..2c46b50 --- /dev/null +++ b/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_dynamic.f90 @@ -0,0 +1,1184 @@ +! +!======================================================================= +! +MODULE STRUCTURE_FACTOR_DYNAMIC +! + USE ACCURACY_REAL +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE STFACT_DYNAMIC(X,Z,RS,T,SQO_TYPE,SQ_TYPE,SQ) +! +! This subroutine computes a dynamical structure factor S(q,omega) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega()_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * SQO_TYPE : structure factor approximation (3D) +! SQO_TYPE = 'ABA' Arista-Brandt approximation +! SQO_TYPE = 'HFA' Hartree-Fock approximation +! SQO_TYPE = 'HYD' hyrodynamic approximation +! SQO_TYPE = 'IGA' ideal gas approximation +! SQO_TYPE = 'ITA' Ichimaru-Tanaka approximation +! SQO_TYPE = 'MFA' Hansen-McDonald-Pollock approximation +! SQO_TYPE = 'MFD' memory function model +! SQO_TYPE = 'NAI' Nakano-Ichimaru approximation +! SQO_TYPE = 'NIC' Nakano-Ichimaru approximation +! SQO_TYPE = 'VLA' linearized Vlasov approximation +! SQO_TYPE = 'UTI' Utsumi-Ichimaru approximation +! * SQ_TYPE : static structure factor approximation (3D) +! +! +! Output parameters: +! +! * SQ : structure factor +! +! +! Author : D. Sébilleau +! +! Last modified : 19 Jun 2020 +! + USE MATERIAL_PROP, ONLY : DMN +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: SQO_TYPE,SQ_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT):: SQ +! + IF(DMN == '3D') THEN ! + CALL STFACT_DYNAMIC_3D(X,Z,RS,T,SQO_TYPE,SQ_TYPE,SQ) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! + END IF ! +! + END SUBROUTINE STFACT_DYNAMIC +! +!======================================================================= +! + SUBROUTINE STFACT_DYNAMIC_3D(X,Z,RS,T,SQO_TYPE,SQ_TYPE,SQ) +! +! This subroutine computes a dynamical structure factor S(q,omega) +! for 3D systems +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * SQO_TYPE : structure factor approximation (3D) +! SQO_TYPE = 'ABA' Arista-Brandt approximation +! SQO_TYPE = 'HFA' Hartree-Fock approximation +! SQO_TYPE = 'HYD' hyrodynamic approximation +! SQO_TYPE = 'IGA' ideal gas approximation +! SQO_TYPE = 'ITA' Ichimaru-Tanaka approximation +! SQO_TYPE = 'MFA' Hansen-McDonald-Pollock approximation +! SQO_TYPE = 'MFD' memory function model +! SQO_TYPE = 'NAI' Nakano-Ichimaru approximation +! SQO_TYPE = 'NIC' Nakano-Ichimaru approximation +! SQO_TYPE = 'VLA' linearized Vlasov approximation +! SQO_TYPE = 'UTI' Utsumi-Ichimaru approximation +! * SQ_TYPE : static structure factor approximation (3D) +! +! Intermediate parameters: +! +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! * IQ_TYPE : type of approximation for I(q) +! +! +! Output parameters: +! +! * SQ : structure factor +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Nov 2020 +! +! +! + USE LF_VALUES, ONLY : GQ_TYPE,IQ_TYPE + USE ENERGIES, ONLY : EC_TYPE +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: SQO_TYPE,SQ_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT):: SQ +! + IF(SQO_TYPE == 'ABA') THEN ! + SQ = ABA_SF(X,Z,RS,T) ! + ELSE IF(SQO_TYPE == 'HFA') THEN ! + SQ = HFA_SF(X,Z) ! + ELSE IF(SQO_TYPE == 'HYD') THEN ! + SQ = HYD_SF(X,Z,RS,T,GQ_TYPE,EC_TYPE,SQ_TYPE,IQ_TYPE) ! + ELSE IF(SQO_TYPE == 'IGA') THEN ! + SQ = IGA_SF(X,Z,T) ! + ELSE IF(SQO_TYPE == 'ITA') THEN ! + SQ = ITA_SF(X,Z,RS,T,SQ_TYPE,GQ_TYPE,IQ_TYPE) ! + ELSE IF(SQO_TYPE == 'MFA') THEN ! + SQ = MFA_SF(X,Z,T) ! + ELSE IF(SQO_TYPE == 'MFD') THEN ! + SQ = MFD_SF(X,Z,RS,T,SQ_TYPE,GQ_TYPE) ! + ELSE IF(SQO_TYPE == 'NIC') THEN ! + SQ = NIC_SF(X,Z,T) ! + ELSE IF(SQO_TYPE == 'UTI') THEN ! + SQ = UTI_SF(X,Z,T,RS,SQ_TYPE,GQ_TYPE,EC_TYPE,IQ_TYPE) ! + ELSE IF(SQO_TYPE == 'VLA') THEN ! + SQ = VLA_SF(X,Z,RS,T,GQ_TYPE,SQ_TYPE) ! + END IF ! +! + END SUBROUTINE STFACT_DYNAMIC_3D +! +!======================================================================= +! + FUNCTION ABA_SF(X,Z,RS,T) +! +! This function computes the Arista-Brandt approximation for +! the dynamical structure factor S(q,omega) for 3D systems +! +! References: (1) N. R. Arista and W. Brandt, Phys. Rev. A 29, +! 1471-1480 (1984) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,EIGHTH + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,K_B + USE FERMI_SI, ONLY : EF_SI,KF_SI,VF_SI + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE SCREENING_VEC +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: ABA_SF + REAL (WP) :: Y,U + REAL (WP) :: Q_SI,OM + REAL (WP) :: KBT,THETA + REAL (WP) :: C1,C2,C3 + REAL (WP) :: NUM,DEN + REAL (WP) :: K_TF_SI,KD_SI + REAL (WP) :: N0 + REAL (WP) :: M2E2,HB3,KO +! + REAL (WP) :: EXP +! + Y = X + X ! Y = q / k_F + U = X * Z ! U = omega / (q v_F) +! + Q_SI = Y * KF_SI ! q in SI +! + OM = Q_SI * VF_SI * U ! omega in SI +! +! Computing the number density +! + N0 = RS_TO_N0('3D',RS) ! +! + KBT = K_B * T ! + THETA = KBT / EF_SI ! 1 / degeneracy +! + M2E2 = M_E * M_E * E * E ! m^2 e^2 + HB3 = H_BAR * H_BAR * H_BAR ! h_bar^3 + KO = Q_SI * OM ! q omega +! +! Computation of the Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR('3D',K_TF_SI) ! +! +! Computation of the Debye screening vector +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! +! Computation of S(q,omega) +! + C1 = M2E2 * KO ! +! + IF(THETA < ONE) THEN ! case (a) +! + C2 = (Q_SI * Q_SI + K_TF_SI * K_TF_SI)**2 ! +! + IF(X < ONE) THEN ! +! + ABA_SF = TWO * C1 / (HB3 * C2) ! ref. (1) eq. (33) +! + ELSE ! +! + ABA_SF = ZERO ! +! + END IF ! +! + ELSE ! +! + C2 = (Q_SI * Q_SI + KD_SI * KD_SI)**2 ! + C3 = ONE / (M_E * KBT) ! +! + ABA_SF = N0 * C1 / C2 * (TWO * PI * C3)**1.5E0_WP * & ! + EXP(- EIGHTH * H_BAR* H_BAR * Q_SI * Q_SI * C3) ! +! + END IF ! +! + END FUNCTION ABA_SF +! +!======================================================================= +! + FUNCTION HFA_SF(X,Z) +! +! This function computes the Hartree-Fock approximation for +! the dynamical structure factor S(q,omega) for 3D systems +! +! References: (1) J. S\'{o}lyom, "Fundamentals of the Physics +! of Solids" Vol. III (Springer, 2010) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! +! Intermediate parameters: +! +! * U : dimensionless factor --> U = omega / (q * v_F) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,THREE,HALF + USE PI_ETC, ONLY : PI + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : EF_SI,KF_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z + REAL (WP) :: HFA_SF + REAL (WP) :: Y,U + REAL (WP) :: COEF + REAL (WP) :: BND1,BND2,BND3 +! + Y = X + X ! Y = q / k_F +! + U = X * Z ! omega / (q * v_F) +! + COEF = THREE * PI * HALF * H_BAR / EF_SI ! +! +! Various bounds +! + BND1 = ONE - X ! + BND2 = ONE + X ! + BND3 = X - ONE ! +! + IF(X < ONE) THEN ! ref. (1) eq. (28.4.102) +! + IF( U < BND1 ) THEN ! + HFA_SF = COEF * U ! + ELSE IF( BND1 <= U .AND. U <= BND2 ) THEN ! + HFA_SF = COEF * ( ONE - (U - X)**2 ) / X ! + ELSE ! + HFA_SF = ZERO ! + END IF ! +! + ELSE ! ref. (1) eq. (28.4.103) +! + IF( U < BND3 ) THEN ! + HFA_SF = ZERO ! + ELSE IF( BND3 <= U .AND. U <= BND2 ) THEN ! + HFA_SF = COEF * ( ONE - (U - X)**2 ) / X ! + ELSE ! + HFA_SF = ZERO ! + END IF ! +! + END IF ! +! + END FUNCTION HFA_SF +! +!======================================================================= +! + FUNCTION HYD_SF(X,Z,RS,T,GQ_TYPE,EC_TYPE,SQ_TYPE,IQ_TYPE) +! +! This function computes the hydrodynamic approximation for +! the dynamical structure factor S(q,omega) for 3D systems +! +! References: (1) S. Tanaka and S. Ichimaru, Phys. Rev. A 35, +! 4743-4754 (1987) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! * SQ_TYPE : static structure factor approximation (3D) +! * IQ_TYPE : type of approximation for I(q) +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Oct 2020 +! +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI_INV + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE IQ_FUNCTIONS_1 + USE LOCAL_FIELD_STATIC + USE RELAXATION_TIME_STATIC, ONLY : TAIQ_RT_3D +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE + CHARACTER (LEN = 4) :: GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE,IQ_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: HYD_SF + REAL (WP) :: Y,U + REAL (WP) :: Q_SI,KD_SI,OM + REAL (WP) :: TAU_K,GQ,IQ + REAL (WP) :: NUM,DEN +! + Y = X + X ! Y = q / k_F + U = X * Z ! U = omega / (q v_F) +! + Q_SI = Y * KF_SI ! q in SI +! + OM = Q_SI * VF_SI * U ! omega in SI +! +! Computing the Debye momentum +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! +! Computing the local-field correction +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ) ! + CALL IQ_3D(X,RS,IQ_TYPE,IQ) ! +! +! Computing the q-dependent relaxation time TAU_K +! + TAU_K = TAIQ_RT_3D(X,RS,T) ! + print *, TAU_K, Q_SI/KD_SI +! + NUM = PI_INV * Q_SI * Q_SI * TAU_K * (GQ - IQ) ! + DEN = KD_SI * KD_SI * (ONE + OM * OM * TAU_K * TAU_K) ! +! + HYD_SF = NUM / DEN ! ref. (1) eq. (23) +! + END FUNCTION HYD_SF +! +!======================================================================= +! + FUNCTION IGA_SF(X,Z,T) +! +! This function computes the ideal gas approximation for +! the dynamical structure factor S(q,omega) for 3D systems +! +! References: +! +! Input parameters: (1) J. P. Mithen, J. Daligault and G. Gregori, +! Phys. Rev. E 85, 056407 (2012) +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * T : temperature in SI +! +! +! Note: As IGA_SF will be scaled by EF_SI / H_BAR for plotting, +! we check that IGA_SF * EF_SI / H_BAR can be represented +! +! +! +! Author : D. Sébilleau +! +! Last modified : 22 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOUR,HALF,TTINY,MIC + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,T +! + REAL (WP) :: IGA_SF +! + REAL (WP) :: Y,U + REAL (WP) :: OM,OMQ,OMT + REAL (WP) :: LOGA,LOGB + REAL (WP) :: Q_SI,COEF +! + REAL (WP) :: LOG,EXP +! + Y = X + X ! Y = q / k_F + U = X * Z ! U = omega / (q v_F) +! + Q_SI = Y * KF_SI ! q in SI +! + OM = Q_SI * VF_SI * U ! omega in SI + OMT = K_B * T / H_BAR ! omega_T + OMQ = HALF * H_BAR * Q_SI * Q_SI / M_E ! omega_q +! + COEF = ONE / (FOUR * OMT * OMQ) ! 1 / (4 omega_T omega_q) +! + LOGA = HALF * LOG(COEF * PI_INV) - COEF * OM * OM ! Log[S(q,omega)] +! +! + IF(LOGA > MIC) THEN ! + IGA_SF = EXP(LOGA) ! ref. (1) eq. (9) + ELSE ! + IGA_SF = ZERO ! + END IF ! +! + END FUNCTION IGA_SF +! +!======================================================================= +! + FUNCTION ITA_SF(X,Z,RS,T,SQ_TYPE,GQ_TYPE,IQ_TYPE) +! +! This function computes the Ichimaru-Tanaka approximation for +! the dynamical structure factors S(q,omega) for 3D systems +! +! References: +! +! Input parameters: (1) S. Ichimaru and S. Tanaka, Phys. Rev. Lett. 56, +! 2815-2818 (1986) +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * SQ_TYPE : static structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! * IQ_TYPE : type of approximation for I(q) +! +! +! Author : D. Sébilleau +! +! Last modified : 22 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,HALF + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI,PI_INV + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE UTILITIES_1, ONLY : RS_TO_N0 + USE VISCOSITY, ONLY : LHPO_VISC_3D + USE RELAXATION_TIME_STATIC, ONLY : TAI0_RT_3D + USE IQ_FUNCTIONS_1 + USE LOCAL_FIELD_STATIC +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE + CHARACTER (LEN = 4) :: GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE,IQ_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: ITA_SF + REAL (WP) :: Y,U + REAL (WP) :: OM,Q_SI + REAL (WP) :: GQ,IQ + REAL (WP) :: A,ETA,XI,TAU_M,TAU_Q,ETA_L + REAL (WP) :: KD_SI,R,R2,R4 + REAL (WP) :: N0 + REAL (WP) :: NUM,DEN +! + REAL (WP) :: EXP +! + XI = 2.7E0_WP ! +! + Y = X + X ! Y = q / k_F + U = X * Z ! U = omega / (q v_F) +! + Q_SI = Y * KF_SI ! q in SI +! + OM = Q_SI * VF_SI * U ! omega in SI + A = RS * BOHR ! r_s in SI +! +! Computing the viscosity (LHPO case only) +! + ETA = LHPO_VISC_3D(RS,T) ! +! +! Computing the static relaxation time +! + TAU_M = TAI0_RT_3D(RS,T) ! +! + TAU_Q = TAU_M * EXP(- (A * Q_SI / XI)**2) ! +! + N0 = RS_TO_N0('3D',RS) ! +! +! Computing the Debye momentum +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + R = Q_SI / KD_SI ! + R2 = R * R ! + R4 = R2 * R2 ! +! +! Computing the static functions G(q) and I(q) +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ) ! + CALL IQ_3D(X,RS,IQ_TYPE,IQ) ! +! +! Computing the dynamical viscosity +! + ETA_L = TAU_Q * N0 * K_B * T * (GQ - IQ) / R2 ! ref. (1) eq. (8) +! + NUM = R4 * ETA_L ! + DEN = PI * K_B * T * ( ONE + (TAU_Q * OM)**2) ! +! + ITA_SF = NUM / DEN ! ref. (1) eq. (6) +! + END FUNCTION ITA_SF +! +!======================================================================= +! + FUNCTION MFA_SF(X,Z,T) +! +! This function computes the Hansen-McDonald-Pollock approximation for +! the dynamical structure factor S(q,omega) for 3D systems +! +! References: (1) J. P. Hansen, I. R. McDonald and E. L. Pollock, +! Phys. Rev. A 11, 1025-1039 (1975) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,HALF + USE CONSTANTS_P1, ONLY : H_BAR,M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI,PI_INV + USE EXT_FUNCTIONS, ONLY : DAWSON ! Dawson function D(x) + USE PLASMON_SCALE_P, ONLY : DEGEN + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,T + REAL (WP) :: MFA_SF + REAL (WP) :: Y,U + REAL (WP) :: OQ,Q_SI,GAM,COEF,S0 + REAL (WP) :: VQ,ZZ,PHI,OM,OMP + REAL (WP) :: NUM,DEN +! + REAL (WP) :: EXP,SQRT +! + Y = X + X ! Y = q / k_F + U = X * Z ! U = omega / (q v_F) +! + Q_SI = Y * KF_SI ! q in SI + OM = Q_SI * VF_SI * U ! omega in SI + OMP = H_BAR * OM / ENE_P_SI ! omega in unit of omega_p +! +! + GAM = DEGEN ! Gamma + COEF = THREE * HALF * GAM * PI_INV / (Q_SI * Q_SI) ! 3 Gamma / 2 pi q^2 (dimensionless) + S0 = SQRT(COEF) * EXP(- COEF * PI * OMP * OMP) ! IGA approximation +! + VQ = TWO * PI * COEF ! + ZZ = SQRT(PI * COEF) * OMP ! + PHI = - ( ONE - TWO * ZZ * DAWSON(ZZ) ) ! +! + NUM = S0 ! + DEN = (ONE - VQ * PHI)**2 + (OMP * PI * VQ * S0)**2 ! +! + MFA_SF = NUM / DEN ! ref. (1) eq. (4.2) +! + END FUNCTION MFA_SF +! +!======================================================================= +! + FUNCTION MFD_SF(X,Z,RS,T,SQ_TYPE,GQ_TYPE) +! +! This function computes the memory function model for +! the dynamical structure factor S(q,omega) for 3D systems +! +! References: (1) J. P. Hansen, I. R. McDonald and E. L. Pollock, +! Phys. Rev. A 11, 1025-1039 (1975) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * SQ_TYPE : static structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Oct 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,HALF + USE CONSTANTS_P1, ONLY : BOHR,H_BAR,M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI,PI_INV +! + USE PLASMON_SCALE_P, ONLY : DEGEN + USE PC_VALUES, ONLY : GR_TYPE + USE PD_VALUES +! + USE EXT_FUNCTIONS, ONLY : DAWSON ! Dawson function D(x) + USE RELAXATION_TIME_STATIC, ONLY : TAIQ_RT_3D + USE PLASMON_ENE_SI + USE STRUCTURE_FACTOR_STATIC + USE SPECIFIC_INT_3 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: MFD_SF + REAL (WP) :: Y,U + REAL (WP) :: Q_SI,OM,OMP + REAL (WP) :: GAM,SQ + REAL (WP) :: KK,IN,IQ + REAL (WP) :: O2K,O2L,O2,O4 + REAL (WP) :: TAU_K,TKO + REAL (WP) :: K2PP,K2PS + REAL (WP) :: NUM,DEN +! + REAL (WP), PARAMETER :: X_MAX = 4.0E0_WP +! + REAL (WP) :: EXP,SQRT +! + Y = X + X ! Y = q / k_F + U = X * Z ! U = omega / (q v_F) +! + Q_SI = Y * KF_SI ! q in SI + OM = Q_SI * VF_SI * U ! omega in SI + OMP = H_BAR * OM / ENE_P_SI ! omega in unit of omega_p +! + GAM = DEGEN ! +! + KK = Q_SI * BOHR ! q in units of 1 / a_0 +! +! Computing the static structure factor +! + CALL STFACT_STATIC_3D(X,RS,T,SQ_TYPE,GQ_TYPE,SQ) ! +! +! Computing the I(q) factor +! + CALL INT_GRM1(NSIZE,X_MAX,6,RS,T,KK,0,GR_TYPE,RH_TYPE,IN) ! + IQ = - IN ! +! +! Computing the < omega_k^2> and < omega_L^2> factors (ref. 1 appendix) +! + O2K = K_B * T * Q_SI / (M_E * SQ) ! < omega_k^2> + O2L = KK * KK / GAM + ONE - TWO * IQ ! < omega_L^2> +! +! Computing the q-dependent relaxation time TAU_K +! + TAU_K = TAIQ_RT_3D(X,RS,T) ! +! + TKO = TAU_K * OM * SQRT(PI_INV) ! +! +! Computing the k^2 phi' and k^2 phi" coeffcients +! + K2PP = TAU_K * (O2L - O2K) * EXP(- TKO * TKO) ! ref. (1) eq. (7) + K2PS = TWO * SQRT(PI_INV) * TAU_K * (O2L - O2K) * DAWSON(TKO) ! ref. (1) eq. (8) +! + NUM = SQ * PI_INV * O2K * K2PP ! + DEN = (OMP * OMP - O2K - OMP * K2PS)**2 + (OMP * K2PP)**2 ! +! + MFD_SF = NUM / DEN ! ref. (1) eq. (4) +! + END FUNCTION MFD_SF +! +!======================================================================= +! + FUNCTION NIC_SF(X,Z,T) +! +! This function computes the Nakano-Ichimaru approximation for +! the dynamical structure factor S(q,omega) for 3D systems +! +! References: +! +! Input parameters: (1) A. Nakano and S. Ichimaru, Phys. Rev. B 39, +! 4938-4944 (1989) +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Dec 2020 +! +! + USE MATERIAL_PROP, ONLY : RS + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,FIVE,EIGHT, & + HALF,THIRD,FOURTH,TTINY + USE PI_ETC, ONLY : PI,PI_INV + USE UTILITIES_1, ONLY : ALFA + USE GAMMA_ASYMPT, ONLY : GAMMA_0_3D + USE MINMAX_VALUES +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,T + REAL (WP) :: NIC_SF +! + REAL (WP) :: Y,Y2,Y4,Y6 + REAL (WP) :: R1,R2,R3,R4,R5,R6,R7,R8,R9,R10 + REAL (WP) :: A(0:5),B(0:4),C(0:10),D(0:5) + REAL (WP) :: E(0:5),F(0:5),G(0:5),H(0:10),I(0:5) + REAL (WP) :: K1,K2,K3,K4,KS,AL,OM,CM,G0 + REAL (WP) :: FPK,FMK,FSK,OPK,GPK,OMK + REAL (WP) :: ALPHA,OMG,KTF,OMP + REAL (WP) :: PDC,GAM_0,KKP + REAL (WP) :: NUM1,DEN1,NUM2,DEN2 + REAL (WP) :: MAX_EXP,MIN_EXP + REAL (WP) :: EXPO,EXP22 + REAL (WP) :: SPK,SSK,SMK +! + REAL (WP) :: SQRT,EXP +! + DATA A / 3.6589E0_WP , 0.41154E0_WP , - 0.13214E0_WP , & ! k1 polynomial + 0.020511E0_WP,- 0.0016079E0_WP, 4.9763E-05_WP / ! coefficients +! + DATA B / 0.30078E0_WP , 0.47133E0_WP , - 0.068996E0_WP , & ! k2 polynomial + 0.0064815E0_WP,- 0.00023811E0_WP / ! coefficients +! + DATA C /-1.6111E0_WP , 14.373E0_WP , - 24.339E0_WP , & ! k3 polynomial + 19.883E0_WP ,- 9.2979E0_WP , 2.7058E0_WP , & ! coefficients + -0.50785E0_WP , 0.061592E0_WP , - 0.0046652E0_WP, & ! + 0.00020069E0_WP,- 3.7434E-06_WP / ! +! + DATA D / 0.73153E0_WP , 0.59597E0_WP , - 0.15927E0_WP , & ! k4 polynomial + 0.020467E0_WP, -0.0013217E0_WP, 3.44945E-05_WP / ! coefficients +! + DATA E / 1.6346E0_WP , 0.48593E0_WP , - 0.14513E0_WP , & ! ks polynomial + 0.021578E0_WP, -0.0016023E0_WP , 4.6925E-05_WP / ! coefficients +! + DATA F / 1.2013E0_WP , - 0.85002E0_WP , 0.30359E0_WP , & ! alpha polynomial + -0.054964E0_WP, 0.0047306E0_WP , - 0.00015434E0_WP / ! coefficients +! + DATA G / 0.41083E0_WP , 0.84227E0_WP , - 0.17643E0_WP , & ! omega_m polynomial + 0.027536E0_WP, - 0.00222936E0_WP, 7.083E-05_WP / ! coefficients +! + DATA H / 2.2149E0_WP , - 5.6161E0_WP , 9.2856E0_WP , & ! c_m polynomial + -7.6535E0_WP , 3.624E0_WP , - 1.0662E0_WP , & ! coefficients + 0.20187E0_WP , - 0.02465E0_WP , 0.001877E0_WP , & ! + -8.1083E-05_WP, 1.5173E-06_WP / ! +! + DATA I / 0.48603E0_WP , - 0.28313E0_WP , 0.074042E0_WP , & ! g0 polynomial + -0.010109E0_WP, 0.0006944E0_WP , - 1.8894E-05_WP / ! coefficients +! +! Computing the max and min value of the exponent of e^x +! + CALL MINMAX_EXP(MAX_EXP,MIN_EXP) ! +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! + Y4 = Y2 * Y2 ! + Y6 = Y4 * Y2 ! +! + ALPHA = ALFA('3D') ! +! +! Powers of RS +! + R1 = RS ! + R2 = R1 * R1 ! + R3 = R2 * R1 ! + R4 = R3 * R1 ! + R5 = R4 * R1 ! + R6 = R5 * R1 ! + R7 = R6 * R1 ! + R8 = R7 * R1 ! + R9 = R8 * R1 ! + R10= R9 * R1 ! +! +! Thomas-Fermi screening vector and plasmon energy +! + KTF = SQRT(FOUR * ALPHA * RS * PI_INV) ! k_TF / k_F + OMP = SQRT(16.0E0_WP * ALPHA * RS * PI_INV * THIRD) ! h_bar omega_p / E_F +! + OMG = FOUR * Z * X * X ! omega / omega_F +! + PDC = THREE / (FIVE * OMP) - FOURTH * OMP * GAMMA_0_3D(RS,T) ! +! +! Fitting parameters as a function of RS +! + K1 = A(0) + A(1) * R1 + A(2) * R2 + A(3) * R3 + & ! + A(4) * R4 + A(5) * R5 ! + K2 = B(0) + B(1) * R1 + B(2) * R2 + B(3) * R3 + & ! + B(4) * R4 ! + K3 = C(0) + C(1) * R1 + C(2) * R2 + C(3) * R3 + & ! + C(4) * R4 + C(5) * R5 + C(6) * R6 + & ! + C(7) * R7 + C(8) * R8 + C(9) * R9 + & ! + C(10) * R10 ! + K4 = D(0) + D(1) * R1 + D(2) * R2 + D(3) * R3 + & ! + D(4) * R4 + D(5) * R5 ! + KS = E(0) + E(1) * R1 + E(2) * R2 + E(3) * R3 + & ! + E(4) * R4 + E(5) * R5 ! + AL = F(0) + F(1) * R1 + F(2) * R2 + F(3) * R3 + & ! + F(4) * R4 + F(5) * R5 ! + OM = G(0) + G(1) * R1 + G(2) * R2 + G(3) * R3 + & ! + G(4) * R4 + G(5) * R5 ! + CM = H(0) + H(1) * R1 + H(2) * R2 + H(3) * R3 + & ! + H(4) * R4 + H(5) * R5 + H(6) * R6 + & ! + H(7) * R7 + H(8) * R8 + H(9) * R9 + & ! + H(10) * R10 ! + G0 = I(0) + I(1) * R1 + I(2) * R2 + I(3) * R3 + & ! + I(4) * R4 + I(5) * R5 ! +! + KKP = KTF * KTF * K3 * K3 ! +! + FPK = ( ONE - ( ONE - HALF * ( EXP(- Y2 / (K1 * K1)) + & ! + EXP(- Y4 / K2**4) & ! + ) & ! + ) * & !! ref. (1) eq. (5) + KKP / (Y4 + KKP) & ! + ) * EXP( - Y6 / K4**6) ! + + FMK = (ONE - EXP(- Y2 / (K1 * K1))) * KKP / (TWO * (Y4 + KKP))! ref. (1) eq. (6) + FSK = ONE - FPK - FMK ! ref. (1) eq. (7) + OPK = OMP + TWO * PDC * Y2 ! ref. (1) eq. (8) + GPK = ( SQRT(PI) * OMP**6 * Y2 * THIRD / & ! ref. (1) eq. (9) + (OM**5 * K1 * K1) ) * EXP(- OMP * OMP / (OM * OM)) ! + OMK = OM + CM * Y2 ! ref. (1) eq. (10) + goto 10 +! +! Plasmon contribution to S(q,omega) +! + NUM1 = FPK * Y2 ! + DEN1 = SQRT(PI) * OPK * GPK ! + NUM2 = (OMG - OPK)**2 ! + DEN2 = GPK * GPK ! +! + EXPO = - NUM2 / DEN2 ! +! + IF(EXPO > MIN_EXP) THEN ! + EXP22 = EXP(EXPO) ! + ELSE ! + EXP22 = TTINY ! + END IF ! +! + SPK = NUM1 * EXP22 / DEN1 ! ref. (1) eq. (2) +! +! Single pair contribution to S(q,omega) +! + 10 SSK = FSK * HFA_SF(X,Z) ! ref. (1) eq. (3) + goto 20 +! +! Multipair contribution to S(q,omega) +! + NUM1 = EIGHT * THIRD * FMK * Y2 * OMG**3 ! + DEN1 = SQRT(PI) * OMK**5 ! + NUM2 = OMG * OMG ! + DEN2 = OMK * OMK ! +! + EXPO = - NUM2 / DEN2 ! +! + IF(EXPO > MIN_EXP) THEN ! + EXP22 = EXP(EXPO) ! + ELSE ! + EXP22 = TTINY ! + END IF ! +! + SMK = NUM1 * EXP22 / DEN1 ! ref. (1) eq. (3) +! +! NIC_SF = SPK + SSK + SMK ! + 20 NIC_SF = SSK ! +! + END FUNCTION NIC_SF +! +!======================================================================= +! + FUNCTION UTI_SF(X,Z,T,RS,SQ_TYPE,GQ_TYPE,EC_TYPE,IQ_TYPE) +! +! This function computes the Utsumi-Ichimaru approximation for +! the dynamical structure factor S(q,omega) for 3D systems +! +! Reference: (1) K. Utsumi and S. Ichimaru, +! Phys. Rev. B 22, 1522-1533 (1980) +! (2) S. Ichimaru, "Statistical Plasma Physics", Vol2, +! (CRC Press,2019) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * T : temperature (in SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! * SQ_TYPE : static structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! * IQ_TYPE : type of approximation for I(q) +! +! Output parameters: +! +! * UTI_SF : dynamic structure factor +! +! +! Warning: We note in eq. (5.1) that the S(q,omega) they define +! is N times the standard definition. Therefore, all +! results have to be divided by N +! +! Note: ref. (2) rectifies the awkward k_{TF} of ref. (1) by k_F +! +! +! Author : D. Sébilleau +! +! Last modified : 22 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,HALF,TTINY + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : EF_SI,KF_SI,VF_SI + USE PI_ETC, ONLY : PI,PI2,PI_INV +! + USE PLASMON_ENE_SI + USE UTIC_VALUES + USE MINMAX_VALUES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE + CHARACTER (LEN = 4) :: GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE,IQ_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,T,RS + REAL (WP) :: UTI_SF +! + REAL (WP) :: Y,U,V + REAL (WP) :: Q_SI + REAL (WP) :: OMP,OMQ,OME,OMF + REAL (WP) :: KS,RAT1,RAT2 + REAL (WP) :: NUM,DEN + REAL (WP) :: S_PL,S_SP,S_MP + REAL (WP) :: MAX_EXP,MIN_EXP + REAL (WP) :: EXPO,EXPA +! + REAL (WP) :: SQRT,EXP +! +! Computing the max and min value of the exponent of e^x +! + CALL MINMAX_EXP(MAX_EXP,MIN_EXP) ! +! + Y = X + X ! Y = q / k_F + U = X * Z ! omega / (q * v_F) + V = Z * Y * Y ! omega / omega_{k_F} +! + Q_SI = Y * KF_SI ! q in SI +! +! Computing the different frequencies involved +! + OMQ = HALF * H_BAR * Q_SI * Q_SI / M_E ! omega_q in SI + OME = Z * OMQ ! omega in SI + OMP = ENE_P_SI / H_BAR ! omega_p in SI + OMF = EF_SI / H_BAR ! omega_F in SI +! + RAT1 = (OME / MO_Q)**2 ! (omega / Omega(q))^2 + RAT2 = (OME / (U * OMP) )**2 ! (omega / (U omega_p))^2 +! +! Plasmon contribution to S(q,omega) +! + NUM = - PI_INV * OMQ * GAM_Q ! + DEN = OM_Q * ( (OME - OM_Q)**2 + GAM_Q * GAM_Q ) ! +! + S_PL = NUM / DEN ! ref. (1) eq. (5.14) +! +! Single-pair contribution to S(q,omega) +! + IF(U < ONE) THEN ! + NUM = THREE * Y**4 * U ! + DEN = PI2 * OMF * (U * U + FOUR / PI2) ! +! + S_SP = NUM / DEN ! ref. (1) eq. (5.15) + ELSE ! + S_SP = ZERO ! + END IF ! +! +! Multipair contribution to S(q,omega) +! + EXPO = - HALF * RAT1 ! + IF(EXPO > MIN_EXP / TWO) THEN ! + EXPA = EXP(EXPO) ! + ELSE ! + EXPA = TTINY ! + END IF ! +! + IF(OME < OMP) THEN ! +! + NUM = OME * RAT2 * EXPA ! + DEN = TWO * PI * OMF * OMP * OMP * TAU_Q ! +! + ELSE ! +! + NUM = RAT2 * EXPA ! + DEN = TWO * PI * OMF * OME * TAU_Q ! +! + END IF ! +! + S_MP = NUM / DEN ! ref. (1) eq. (5.19) +! +! UTI_SF = S_PL + S_SP + S_MP ! + UTI_SF = S_PL + S_MP ! +! + END FUNCTION UTI_SF +! +!======================================================================= +! + FUNCTION VLA_SF(X,RS,Z,T,GQ_TYPE,SQ_TYPE) +! +! This function computes the linearized Vlasov approximation for +! the dynamical structure factor S(q,omega) for 3D systems +! +! It has been derived for classical fluids. +! +! References: (1) M. Nelkin and S. Ranganathan, Phys. Rev. 164, +! 222-227 (1967) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * GQ_TYPE : local-field correction type (3D) +! * SQ_TYPE : static structure factor approximation (3D) +! +! +! Intermediate parameters: +! +! * Y : dimensionless factor --> Y = X+X = q / k_F +! +! +! Author : D. Sébilleau +!barb +! Last modified : 4 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,TTINY + USE CONSTANTS_P1, ONLY : M_E,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI + USE EXT_FUNCTIONS, ONLY : DAWSON ! Dawson function D(x) + USE STRUCTURE_FACTOR_STATIC + USE STRUCTURE_FACTOR_STATIC_2 + USE MINMAX_VALUES +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP) :: VLA_SF + REAL (WP) :: Y,U,U2 + REAL (WP) :: Q_SI + REAL (WP) :: SQ,V0_SI,N0C + REAL (WP) :: AX,BX,OOSQ + REAL (WP) :: NUM,DEN + REAL (WP) :: MAX_EXP,MIN_EXP +! + REAL (WP) :: EXP,SQRT +! + INTEGER :: I_MODE +! +! Computing the max and min value of the exponent of e^x +! + CALL MINMAX_EXP(MAX_EXP,MIN_EXP) ! +! + Y = X + X ! Y = q / k_F + U = X * Z ! U = omega / q v_F +! + Q_SI = Y * KF_SI ! q in SI +! +! Choice of the velocity: --> I_MODE = 0 : v = v_F +! --> I_MODE = 1 : v = v_0 = sqrt(2 * k_B * T / m) +! + I_MODE = 1 ! +! + IF(I_MODE == 1) THEN ! + V0_SI = SQRT(TWO * K_B * T / M_E) ! + U = U * VF_SI / V0_SI ! omega / (q * v_0) + ELSE ! + V0_SI = VF_SI ! + END IF ! +! + U2 = U * U ! +! +! Computing the static structure factor +! + IF(SQ_TYPE /= 'GEA' .AND. SQ_TYPE /= 'ICH' .AND. & ! + SQ_TYPE /= 'PKA' .AND. SQ_TYPE /= 'SIN' .AND. & ! + SQ_TYPE /= 'SPA') THEN ! + CALL STFACT_STATIC_3D(X,RS,T,SQ_TYPE,GQ_TYPE,SQ) ! + ELSE ! + CALL STFACT_STATIC_3D_2(X,RS,T,SQ_TYPE,GQ_TYPE,SQ) ! + END IF ! +! + OOSQ = ONE / SQ ! +! + N0C = ONE - OOSQ ! + IF(- U2 > MIN_EXP / TWO) THEN ! + AX = SQRT(PI) * EXP(- U2) ! ref. (1) eq. (14) + ELSE ! + AX = SQRT(PI) * TTINY ! + END IF ! + BX = TWO * DAWSON(U) ! +! + NUM = TWO * AX ! + DEN = Q_SI * V0_SI * ( & ! + ( OOSQ + N0C * U * BX )**2 + (N0C * U * AX)**2 & ! + ) ! +! + VLA_SF = NUM / DEN ! ref. (1) eq. (13) +! + END FUNCTION VLA_SF +! +END MODULE STRUCTURE_FACTOR_DYNAMIC diff --git a/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_dynamic_2.f90 b/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_dynamic_2.f90 new file mode 100644 index 0000000..6516059 --- /dev/null +++ b/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_dynamic_2.f90 @@ -0,0 +1,65 @@ +! +!======================================================================= +! +MODULE STRUCTURE_FACTOR_DYNAMIC_2 +! + USE ACCURACY_REAL +! +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE STFACT_DYNAMIC_FROM_EPS(X,Z,RS,T,SQ) +! +! This subroutine computes a dynamical structure factor S(q,omega) +! from the knowledge of the dielectric function +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega()_q +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Output parameters: +! +! * SQ : structure factor +! +! +! Author : D. Sébilleau +! +! Last modified : 30 Apr 2021 +! + USE MATERIAL_PROP, ONLY : DMN + USE REAL_NUMBERS, ONLY : ZERO,TWO,INF + USE FERMI_SI, ONLY : KF_SI +! + USE UTILITIES_3, ONLY : EPS_TO_SQO + USE DF_VALUES, ONLY : D_FUNC + USE SCREENING_TYPE + USE SCREENING_VEC + USE COULOMB_K + USE DFUNCL_STAN_DYNAMIC +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,RS,T + REAL (WP), INTENT(OUT):: SQ +! + REAL (WP) :: KS_SI,Q_SI + REAL (WP) :: VC + REAL (WP) :: EPSR,EPSI +! + Q_SI = TWO * X * KF_SI ! q in SI +! + CALL DFUNCL_DYNAMIC(X,Z,RS,T,D_FUNC,1,EPSR,EPSI) ! eps(q,omega) + CALL SCREENING_VECTOR(SC_TYPE,DMN,X,RS,T,KS_SI) ! screening vector + CALL COULOMB_FF(DMN,'SIU',Q_SI,KS_SI,VC) ! Coulomb potential +! + CALL EPS_TO_SQO(X,Z,T,RS,DMN,EPSR,EPSI,VC,SQ) ! +! + END SUBROUTINE STFACT_DYNAMIC_FROM_EPS +! +END MODULE STRUCTURE_FACTOR_DYNAMIC_2 diff --git a/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_static.f90 b/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_static.f90 new file mode 100644 index 0000000..766667f --- /dev/null +++ b/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_static.f90 @@ -0,0 +1,958 @@ +! +!======================================================================= +! +MODULE STRUCTURE_FACTOR_STATIC +! + USE ACCURACY_REAL +! +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE STFACT_STATIC(X,RS,T,SQ_TYPE,SQ) +! +! This subroutine computes a static structure factor S(q) that +! does not involve the local field corrections G(q) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0)FACT +! * T : temperature in SI +! * SQ_TYPE : structure factor approximation (3D) +! SQ_TYPE = 'DEH' Debye-Hückel approximation +! SQ_TYPE = 'GEA' generalized approximation +! SQ_TYPE = 'GOR' Gorobchenko approximation +! SQ_TYPE = 'GR2' computed from g(r) (GR_TO_SQ.f code) +! SQ_TYPE = 'GSB' Gori-Giorgi-Sacchetti-Bachelet approximation +! SQ_TYPE = 'HFA' Hartree-Fock approximation (only exchange) +! SQ_TYPE = 'HUB' Hubbard approximation +! SQ_TYPE = 'ICH' Ichimaru approximation +! SQ_TYPE = 'LEE' Lee ideal Fermi gas +! SQ_TYPE = 'MSA' mean spherical approximation +! SQ_TYPE = 'PKA' Pietiläinen-Kallio +! SQ_TYPE = 'RPA' RPA approximation +! SQ_TYPE = 'SHA' Shaw approximation +! SQ_TYPE = 'SIN' Singh +! SQ_TYPE = 'SPA' Singh-Pathak +! SQ_TYPE = 'TWA' Toigo-Woodruff approximation +! +! Intermeduate parameters: +! +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! +! +! Output parameters: +! +! * SQ : static structure factor +! +! Author : D. Sébilleau +! +! Last modified : 3 Dec 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN + USE LF_VALUES, ONLY : GQ_TYPE +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: SQ_TYPE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP), INTENT(OUT) :: SQ +! + IF(DMN == '3D') THEN ! + CALL STFACT_STATIC_3D(X,RS,T,SQ_TYPE,GQ_TYPE,SQ) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! + END IF ! +! + END SUBROUTINE STFACT_STATIC +! +!======================================================================= +! + SUBROUTINE STFACT_STATIC_3D(X,RS,T,SQ_TYPE,GQ_TYPE,SQ) +! +! This subroutine computes a static structure factor S(q) +! for 3D systems +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * SQ_TYPE : structure factor approximation (3D) +! SQ_TYPE = 'DEH' Debye-Hückel approximation +! SQ_TYPE = 'GEA' generalized approximation +! SQ_TYPE = 'GOR' Gorobchenko approximation +! SQ_TYPE = 'GR2' computed from g(r) (GR_TO_SQ.f code) +! SQ_TYPE = 'GSB' Gori-Giorgi-Sacchetti-Bachelet approximation +! SQ_TYPE = 'HFA' Hartree-Fock approximation (only exchange) +! SQ_TYPE = 'HUB' Hubbard approximation +! SQ_TYPE = 'ICH' Ichimaru approximation +! SQ_TYPE = 'LEE' Lee ideal Fermi gas +! SQ_TYPE = 'MSA' mean spherical approximation +! SQ_TYPE = 'PKA' Pietiläinen-Kallio +! SQ_TYPE = 'RPA' RPA approximation +! SQ_TYPE = 'SHA' Shaw approximation +! SQ_TYPE = 'SIN' Singh +! SQ_TYPE = 'SPA' Singh-Pathak +! SQ_TYPE = 'TWA' Toigo-Woodruff approximation +! * GQ_TYPE : local-field correction type (3D) +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Jun 2020 +! +! +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE +! + REAL (WP) :: X,RS,T + REAL (WP) :: SQ +! + IF(SQ_TYPE == 'DEH') THEN ! + SQ = DEH_SF(X,RS,T) ! + ELSE IF(SQ_TYPE == 'HFA') THEN ! + SQ = HFA_SF(X) ! + ELSE IF(SQ_TYPE == 'GOR') THEN ! + SQ = GOR_SF(X,RS) ! + ELSE IF(SQ_TYPE == 'GSB') THEN ! + SQ = GSB_SF(X,RS) ! + ELSE IF(SQ_TYPE == 'HUB') THEN ! + SQ = HUB_SF(X) ! + ELSE IF(SQ_TYPE == 'LEE') THEN ! + SQ = LEE_SF(X) ! + ELSE IF(SQ_TYPE == 'MSA') THEN ! + SQ = MSA_SF(X,RS) ! + ELSE IF(SQ_TYPE == 'RPA') THEN ! + SQ = RPA_SF(X,RS) ! + ELSE IF(SQ_TYPE == 'SHA') THEN ! + SQ = SHA_SF(X) ! + ELSE IF(SQ_TYPE == 'TWA') THEN ! + SQ = TWA_SF(X,RS) ! + END IF ! +! + END SUBROUTINE STFACT_STATIC_3D +! +!======================================================================= +! + FUNCTION DEH_SF(X,RS,T) +! +! This function computes the Debye-Hückel approximation static +! structure factor S(q) for 3D systems +! +! References: (1) S. Ichimaru, Rev. Mod. Phys. 54, 1017-1059 (1982) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 1 Oct 2020 +! +! + USE FERMI_SI, ONLY : KF_SI + USE SCREENING_VEC, ONLY : DEBYE_VECTOR +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: DEH_SF + REAL (WP) :: Y + REAL (WP) :: Q_SI,Q2_SI,KD_SI +! + Y = X + X ! Y = q / k_F + Q_SI = Y * KF_SI ! q in SI + Q2_SI = Q_SI * Q_SI ! +! +! Computing the Debye screening vector +! + CALL DEBYE_VECTOR('3D',T,RS,KD_SI) ! +! + DEH_SF = Q2_SI / (Q2_SI + KD_SI * KD_SI) ! ref. (1) eq. (2.2) +! + END FUNCTION DEH_SF +! +!======================================================================= +! +! + FUNCTION GR2_SF(X,RS,T) +! +! This function computes the static structure factor S(q) +! from the pair correlation g(r) +! +! References: +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : SIX + USE PC_VALUES, ONLY : GR_TYPE + USE PD_VALUES, ONLY : RH_TYPE +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: GR2_SF + REAL (WP) :: Y + REAL (WP) :: SQ +! + REAL (WP), PARAMETER :: MAX_R = SIX ! upper r-integration value +! + Y = X + X ! q/k_F +! + CALL GR_TO_SQ_3D(Y,MAX_R,T,RS,GR_TYPE,RH_TYPE,SQ) +! + GR2_SF = SQ ! +! +CONTAINS +! +!----------------------------------------------------------------------- +! + SUBROUTINE GR_TO_SQ_3D(Q,MAX_R,T,RS,GR_TYPE,RH_TYPE,SQ) +! +! This subroutine computes the 3D static structure factor S(q) +! from the pair correlation function g(r) according to +! +! / + inf +! | -i q.r +! S(q) = 1 + n | ( g(r)-1 ) e dr +! | +! / 0 +! +! / + inf +! 4 pi n | +! = 1 + -------- | r sin(qr) ( g(r)-1 ) dr +! q | +! / 0 +! +! +! Input parameters: +! +! * Q : point q where S(q) is computed +! * MAX_R : upper integration value +! * T : temperature in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! * GR_TYPE : pair correlation function type (3D) +! * RH_TYPE : choice of pair distribution function rho_2(r) (3D) +! +! +! Output variables : +! +! * SQ : S(q) at point q +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ONE,FOUR + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE INTEGRATION, ONLY : INTEGR_L + USE PAIR_CORRELATION, ONLY : PAIR_CORRELATION_3D +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: GR_TYPE,RH_TYPE +! + REAL (WP), INTENT(IN) :: Q,T,RS,MAX_R + REAL (WP) :: GR,SQ + REAL (WP) :: N0,R + REAL (WP) :: INTF(NSIZE),XA(NSIZE),H,IN +! + INTEGER :: NMAX,K,N1,ID +! +! Computing the electron density +! + N0=RS_TO_N0('3D',RS) ! +! +! Computing the integrand function +! + N1=NMAX ! index of upper bound + DO K=1,NMAX ! +! + XA(K)=MAX_R*FLOAT(K-1)/FLOAT(NSIZE-1) ! + R=XA(K) ! +! +! Computing the pair correlation factor g(r) +! + CALL PAIR_CORRELATION_3D(R,RS,T,GR_TYPE,RH_TYPE,GR) ! +! + INTF(K)=XA(K)*SIN(Q*XA(K))*(GR-ONE) ! +! + END DO ! +! + H=XA(2)-XA(1) ! step + ID=1 ! +! +! Computing the integral +! + CALL INTEGR_L(INTF,H,NMAX,N1,IN,ID) ! +! + SQ=ONE + (FOUR*PI*N0/Q) * IN ! +! + END SUBROUTINE GR_TO_SQ_3D +! +!----------------------------------------------------------------------- +! + END FUNCTION GR2_SF +! +!======================================================================= +! + FUNCTION GSB_SF(X,RS) +! +! This function computes the Gori-Giorgi-Sacchtti-Bachelet +! static structure factor S(q) for 3D systems +! +! References: (1) P. Gori-Giorgi, F. Sacchetti and G. B. Bachelet, +! Phys. Rev. B 61, 7353-7363 (2000) +! (2) P. Gori-Giorgi, F. Sacchetti and G. B. Bachelet, +! Phys. Rev. B 66, 159901 (2002) <-- Erratum +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Note: They write S(q) as +! +! S(q) = S_{ex}(q) + S_c^{++}(q) + S_c^{+-}(q) +! | +! ---> Hartree-Fock exchange value +! +! +! Author : D. Sébilleau +! +! Last modified : 24 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,FIVE,SEVEN,EIGHT,NINE, & + HALF,THIRD,FOURTH,SIXTH + USE PI_ETC, ONLY : PI,PI2,PI_INV + USE ENE_CHANGE, ONLY : RYD + USE UTILITIES_1, ONLY : ALFA + USE PLASMON_ENE_EV +! + USE ZETA_RIEMANN +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS + REAL (WP) :: GSB_SF + REAL (WP) :: KF,OP + REAL (WP) :: K,K2,K3,K4,K5,K6,K7,K8,K9,K10,K12 + REAL (WP) :: ALPHA + REAL (WP) :: S0,SCP,SCM + REAL (WP) :: AA_P,AA_M,BB_P,BB_M + REAL (WP) :: A_P,B1_P,B_P,A_M,B1_M,B_M + REAL (WP) :: P3,L4_P,L5_P,L6_P,G4_P,G5_P,G6_P + REAL (WP) :: K_3,L4_M,L5_M,L6_M,G4_M,G5_M,G6_M + REAL (WP) :: K_1,K_2,P1,P2 + REAL (WP) :: C1_P,C2_P,C3_P,C4_P,C5_P,C6_P + REAL (WP) :: C1_M,C2_M,C3_M,C4_M,C5_M,C6_M + REAL (WP) :: A6_P,A8_P,A10_P,A4_M,A6_M + REAL (WP) :: K2_T,AB2,KOEF + REAL (WP) :: FCT(10) +! + REAL (WP), PARAMETER :: AA = (ONE - LOG(TWO)) / PI2 + REAL (WP), PARAMETER :: BB_D = - 0.0711E0_WP + REAL (WP), PARAMETER :: BB_X = SIXTH * LOG(TWO) - 0.75E0_WP * ZETA(3) / PI2 +! + REAL (WP) :: LOG,SQRT,EXP +! + DATA FCT / 1.0E0_WP, & ! --> 1! Factorials + 2.0E0_WP, & ! --> 2! + 6.0E0_WP, & ! --> 3! + 24.0E0_WP, & ! --> 4! + 120.0E0_WP, & ! --> 5! + 720.0E0_WP, & ! --> 6! + 5040.0E0_WP, & ! --> 7! + 40320.0E0_WP, & ! --> 8! + 362880.0E0_WP, & ! --> 9! + 3628800.0E0_WP & ! --> 10! + / +! + K = X + X ! q / k_F +! +! Powers of k +! + K2 = K * K ! + K3 = K2 * K ! + K4 = K3 * K ! + K5 = K4 * K ! + K6 = K5 * K ! + K7 = K6 * K ! + K8 = K7 * K ! + K9 = K8 * K ! + K10 = K9 * K ! + K12 = K6 * K6 ! +! + ALPHA = ALFA('3D') ! +! + KF = ALPHA / RS ! k_F in AU +! + KOEF = FIVE / 11.0E0_WP ! corrected coef. for eq. (44) +! +! Plasmon energy in Ry +! + OP = ENE_P_EV / RYD ! +! +! Computation of the exchange Hartree-Fock contribution S0 +! + S0 = HFA_SF(X) ! +! +! Computation of the correlation S_c^{++}(q) contribution SCP +! + AA_P = HALF * AA ! A^++ + BB_P = HALF * BB_D ! B^++ + A_P = 1.32E0_WP ! a^++ + B1_P = 3.47E0_WP ! b1^++ + B_P = ALPHA * PI * SQRT(THREE / RS) + B1_P ! b^++ : ref. (1) eq. (51) + AB2 = A_P * A_P * B_P * B_P ! (a^++ * b^++)^2 + P3 = 0.015E0_WP ! p3 + L4_P = 98.0E0_WP ! lambda_4^++ + L5_P = -295.0E0_WP ! lambda_5^++ + L6_P = 170.0E0_WP ! lambda_6^++ + G4_P = - 36.0E0_WP ! gamma_4^++ + G5_P = 74.0E0_WP ! gamma_5^++ + G6_P = - 13.0E0_WP ! gamma_6^++ + P1 = 18.0E0_WP * PI * A_P * A_P * AA_P / ALPHA ! p1 : ref. (1) eq. (39) + P2 = 729.0E0_WP * A_P * A_P / (64.0E0_WP * ALPHA**FOUR) - & ! + 21.0E0_WP / (64.0E0_WP * A_P * ALPHA) + & ! p2 : ref. (1) eq. (40) + NINE * HALF * A_P * A_P * PI * (AA_P + TWO * BB_P) / & ! + ALPHA ! +! + C1_P = THREE / EIGHT ! + C2_P = B_P * C1_P + FOURTH * KF * KF / OP ! + C3_P = B_P * B_P * HALF * C1_P + & ! + B_P * FOURTH * KF * KF / OP - ONE / 32.0E0_WP ! + C4_P = (L4_P + G4_P * RS) / (ONE + RS**1.5E0_WP) ! c4^++: \ + C5_P = (L5_P + G5_P * RS) / (ONE + RS**1.5E0_WP) ! c5^++: > ref. (1) eq. (52) + C6_P = (L6_P + G6_P * RS) / (ONE + RS**1.5E0_WP) ! c6^++: / +! + A6_P = EIGHT * ( ONE - P1 * RS * LOG(ONE + P2 / RS) ) / & ! alpha_6^++ : ref. (1) eq. (49) + ( FIVE * PI * KF * (ONE + P3 * RS * RS) ) ! + A8_P = 2048.0E0_WP * THIRD * PI_INV * A_P**5 * ( & ! + C1_P * (FCT(3) - KOEF * FCT(5) / AB2) / B_P**4 + & ! + C2_P * (FCT(4) - KOEF * FCT(6) / AB2) / B_P**5 + & ! + C3_P * (FCT(5) - KOEF * FCT(7) / AB2) / B_P**6 + & ! + C4_P * (FCT(6) - KOEF * FCT(8) / AB2) / B_P**7 + & ! + C5_P * (FCT(7) - KOEF * FCT(9) / AB2) / B_P**8 + & ! alpha_8^++ : ref. (1) eq. (44) + C6_P * (FCT(8) - KOEF * FCT(10) / AB2) / B_P**9 & ! + ) + & ! corrected : ref. (2) eq. (2) + 4096.0E0_WP * A_P**3 / (33.0E0_WP * PI) - & ! + A6_P * A_P**3 * ( 2560.0E0_WP * KF / 33.0E0_WP + & ! + 26.0E0_WP / A_P & ! + ) ! + A10_P= 2048.0E0_WP * THIRD * PI_INV * A_P**7 * ( & ! + C1_P * (FCT(5) / AB2 - 13.0E0_WP * THIRD * FCT(3)) / B_P**4 + & ! + C2_P * (FCT(6) / AB2 - 13.0E0_WP * THIRD * FCT(4)) / B_P**5 + & ! + C3_P * (FCT(7) / AB2 - 13.0E0_WP * THIRD * FCT(5)) / B_P**6 + & ! + C4_P * (FCT(8) / AB2 - 13.0E0_WP * THIRD * FCT(6)) / B_P**7 + & ! ref. (1) eq. (45) + C5_P * (FCT(9) / AB2 - 13.0E0_WP * THIRD * FCT(7)) / B_P**8 + & ! + C6_P * (FCT(10) / AB2 - 13.0E0_WP * THIRD * FCT(8)) / B_P**9 & ! + ) - & ! + 4096.0E0_WP * A_P**5 / (15.0E0_WP * PI) + & ! + A6_P * A_P**5 * THIRD * ( 143.0E0_WP / A_P + & ! + 512.0E0_WP * KF & ! + ) ! +! + SCP = EXP(- B_P * K) * ( C1_P * K + C2_P * K2 + & ! + C3_P * K3 + C4_P * K4 + & ! ref. (1) eq. (41) + C5_P * K5 + C6_P * K6 ) + & ! + (A10_P * K8 + A8_P * K10 + A6_P * K12) / & ! + (A_P * A_P + K2)**NINE ! +! +! Computation of the correlation S_c^{+-}(q) contribution SCM +! + AA_M = HALF * AA ! A^+- + BB_M = HALF * BB_D + BB_X ! B^+- + A_M = 0.838E0_WP ! a^+- + B1_M = 3.27E0_WP ! b1^+- + B_M = ALPHA * PI * SQRT(THREE / RS) + B1_M ! b^+- : ref. (1) eq. (51) + K_3 = 0.141E0_WP ! k3 + L4_M = - 78.0E0_WP ! lambda_4^+- + L5_M = 216.0E0_WP ! lambda_5^+- + L6_M = -140.0E0_WP ! lambda_6^+- + G4_M = 28.0E0_WP ! gamma_4^+- + G5_M = -124.0E0_WP ! gamma_5^+- + G6_M = 55.0E0_WP ! gamma_6^+- + K_1 = 18.0E0_WP * PI * A_M * A_M * AA_M / ALPHA ! k1 : ref. (1) eq. (39) + K_2 = 729.0E0_WP * A_M * A_M / (64.0E0_WP * ALPHA**FOUR) - & ! + 21.0E0_WP / (64.0E0_WP * A_M * ALPHA) + & ! k2 : ref. (1) eq. (40) + NINE * HALF * A_M * A_M * PI * (AA_M + TWO * BB_M) / & ! + ALPHA ! + K2_T = EXP( SEVEN / (384.0E0_WP * A_M * A_M * A_M * AA_M) - & ! + 81.0E0_WP / (128.0E0_WP * ALPHA**3 * AA_M) - & ! + BB_M / AA_M - HALF & ! + ) ! +! + C1_M = - THREE / EIGHT ! c1^+-: ref. (1) eq. (30) + C2_M = B_M * C1_M + FOURTH * KF * KF / OP ! c2^+-: ref. (1) eq. (31) + C3_M = B_M * B_M * HALF * C1_M + & ! c3^+-: ref. (1) eq. (31) + B_M * FOURTH * KF * KF / OP + ONE / 32.0E0_WP ! + C4_M = (L4_M + G4_M * RS) / (ONE + RS**1.5E0_WP) ! c4^+-: \ + C5_M = (L5_M + G5_M * RS) / (ONE + RS**1.5E0_WP) ! c5^+-: > ref. (1) eq. (52) + C6_M = (L6_M + G6_M * RS) / (ONE + RS**1.5E0_WP) ! c6^+-: / +! + A4_M = - (FOUR * (ONE - K_1 * RS * LOG(ONE + K2_T / RS))) / & ! alpha_4^+- : ref. (1) eq. (48) + (THREE * PI * KF * (ONE + K_3 * RS * RS)) ! + A6_M = A_M * A_M * A_M * ( & ! + A4_M * ( - 11.0E0_WP / A_M - & ! + 512.0E0_WP * KF / 21.0E0_WP ) - & ! + 2048.0E0_WP / (21.0E0_WP * PI)* & ! + ( THIRD + & ! + C1_M * FCT(3) / B_M**4 + & ! alpha_6^+- : ref. (1) eq. (33) + C2_M * FCT(4) / B_M**5 + & ! + C3_M * FCT(5) / B_M**6 + & ! corrected : ref. (2) eq. (1) + C4_M * FCT(6) / B_M**7 + & ! + C5_M * FCT(7) / B_M**8 + & ! + C6_M * FCT(8) / B_M**9 & ! + ) & ! + ) ! +! + SCM = EXP(- B_M * K) * ( C1_M * K + C2_M * K2 + & ! + C3_M * K3 + C4_M * K4 + & ! ref. (1) eq. (27) + C5_M * K5 + C6_M * K6 ) + & ! + (A6_M * K8 + A4_M * K10) / (A_M * A_M + K2)**SEVEN ! +! +! Value of S(q) +! + GSB_SF = S0 + SCP + SCM ! +! + END FUNCTION GSB_SF +! +!======================================================================= +! + FUNCTION GOR_SF(X,RS) +! +! This function computes Gorobchenko static structure factor S(q) +! for 3D systems +! +! References: V. G. Kohn and V. D. Gorobchenko, +! J. Phys. C:Solid State Phys. 15, 2935-2950 (1982) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,FOUR,EIGHT, & + THIRD + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS + REAL (WP) :: Y2_INV + REAL (WP) :: Y,Y2 + REAL (WP) :: GOR_SF + REAL (WP) :: Y4,Y4_INV + REAL (WP) :: ALPHA,ZS +! + ALPHA = ALFA('3D') ! +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! + Y4 = Y2 * Y2 ! +! + Y2_INV = ONE / Y2 ! + Y4_INV = ONE / Y4 ! +! + ZS = ALPHA * RS * PI_INV / Y4 ! +! + GOR_SF = ONE - FOUR * THIRD * ZS * ( & ! + ONE - 0.40E0_WP * Y2_INV - & ! ref. (1) eq. (4.14) + 176.0E0_WP * Y4_INV / 175.0E0_WP & ! + ) + & ! + EIGHT * ZS * ZS * THIRD ! +! + END FUNCTION GOR_SF +! +!======================================================================= +! + FUNCTION HFA_SF(X) +! +! This function computes Hartree-Fock static structure factor S(q) +! for 3D systems +! +! References: (1) H. B. Singh and K. N. Pathak, Phys. Rev. B 8, +! 6035-6937 (1973) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: HFA_SF + REAL (WP) :: Y,Y3 +! + Y = X + X ! Y = q / k_F + Y3 = Y * Y * Y ! +! + IF(Y <= TWO) THEN ! + HFA_SF = 0.75E0_WP * Y - Y3 / 16.0E0_WP ! + ELSE ! + HFA_SF = ONE ! + END IF ! +! + END FUNCTION HFA_SF +! +!======================================================================= +! + FUNCTION HUB_SF(X) +! +! This function computes Hubbard static structure factor S(q) +! for 3D systems +! +! References: (1) R. W. Shaw, J. Phys. C: Solid State Phys. 3, +! 1140-1158 (1970) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THREE,FOUR,THIRD + USE PI_ETC, ONLY : PI,PI_INV +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: HUB_SF + REAL (WP) :: Y,Y2 + REAL (WP) :: AL2,COEF +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + AL2 = FOUR / SQRT(THREE * PI) ! + COEF = 16.0E0_WP * THIRD * PI_INV ! +! + HUB_SF = ONE - COEF * AL2 / (AL2 + Y2)**3 ! ref. (1) eq. (5.3) +! + END FUNCTION HUB_SF +! +!======================================================================= +! + FUNCTION LEE_SF(X) +! +! This function computes Lee's static structure factor S(q) +! for 3D systems +! +! References: M. H. Lee, J. Math. Phys. 36, 1136-1145 (1995) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THREE,HALF + USE CONFLUENT_HYPGEOM_REAL, ONLY : HYGFX +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: LEE_SF + REAL (WP) :: A,B,C,X2 + REAL (WP) :: HF1,HF2 +! + IF(X < ONE) THEN ! + X2 = X * X ! + A = HALF ! + B = ONE ! + C = THREE * A ! +! + CALL HYGFX(A,-B,C,X2,HF1) ! + CALL HYGFX(A,-B,C,ONE,HF2) ! +! + LEE_SF = X * HF1 / HF2 ! ref. (1) eq. (12a) +! + ELSE ! + LEE_SF = ONE ! ref. (1) eq. (12b) + END IF ! +! + END FUNCTION LEE_SF +! +!======================================================================= +! + FUNCTION MSA_SF(X,RS) +! +! This function computes mean spherical static structure factor S(q) +! for 3D systems +! +! References: A. Gold and L. Calmels, Phys. Rev. B 48, +! 11622-11637 (1993) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,FOUR + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,EPS_0 + USE FERMI_SI, ONLY : KF_SI + USE UTILITIES_1, ONLY : RS_TO_N0 +! + IMPLICIT NONE +! + REAL (WP) :: X,Y + REAL (WP) :: MSA_SF + REAL (WP) :: VQ,Q_SI,S0,SP + REAL (WP) :: RS,N0 +! + REAL (WP) :: DSQRT +! + Y=X+X ! Y = q / k_F +! + Q_SI=Y*KF_SI ! q in SI +! + VQ=E*E/(EPS_0*Q_SI*Q_SI) ! Coulomb potential +! +! noninteracting electron gas structure factor +! + S0=HFA_SF(X) ! +! + N0=RS_TO_N0('3D',RS) ! +! +! plasmon contribution +! + SP=H_BAR*Q_SI/DSQRT(FOUR*M_E*N0*VQ) ! +! + MSA_SF=ONE/DSQRT(ONE/(S0*S0) + ONE/(SP*SP)) ! ref. (1) eq. (3) +! + END FUNCTION MSA_SF +! +!======================================================================= +! + FUNCTION RPA_SF(X,RS) +! +! This function computes RPA static structure factor S(q) +! for 3D systems +! +! References: V. G. Kohn and V. D. Gorobchenko, +! J. Phys. C:Solid State Phys. 15, 2935-2950 (1982) +! +! +! Warning : Asymptotic value for q/k_F > 2 +! +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOURTH,EIGHT,THIRD + USE PI_ETC, ONLY : PI,PI_INV + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS + REAL (WP) :: RPA_SF + REAL (WP) :: Y,Y2,Y2_INV + REAL (WP) :: Y4,Y4_INV + REAL (WP) :: ALPHA + REAL (WP) :: YS,ZS +! + REAL (WP) :: SQRT +! + ALPHA = ALFA('3D') ! +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! + Y4 = Y2 * Y2 ! +! + Y2_INV = ONE / Y2 ! + Y4_INV = ONE / Y4 ! +! + YS = SQRT(THREE * PI / (ALPHA * RS)) ! + ZS = ALPHA * RS * PI_INV / Y4 ! +! + IF(Y <= 1.E0_WP) THEN ! + RPA_SF = FOURTH * YS * Y2 ! + ELSE ! + RPA_SF = ONE - EIGHT * THIRD * ZS * ( & ! + ONE + 0.40E0_WP * Y2_INV + & ! ref. (1) eq. (4.12) + 72.0E0_WP * Y4_INV / 175.0E0_WP & ! + ) + & ! + 32.0E0_WP * ZS * ZS * THIRD ! + END IF ! +! + END FUNCTION RPA_SF +! +!======================================================================= +! + FUNCTION SHA_SF(X) +! +! This function computes Shaw static structure factor S(q) +! for 3D systems +! +! References: (1) R. W. Shaw, J. Phys. C: Solid State Phys. 3, +! 1140-1158 (1970) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Author : D. Sébilleau +! +! Last modified : 3 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,NINE,THIRD,FOURTH,TTINY + USE PI_ETC, ONLY : PI +! + USE MINMAX_VALUES +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: SHA_SF + REAL (WP) :: Y,Y2 + REAL (WP) :: AL2,EXPO,EXPA + REAL (WP) :: MAX_EXP,MIN_EXP +! + REAL (WP) :: EXP +! + CALL MINMAX_EXP(MAX_EXP,MIN_EXP) ! +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! +! + AL2 = ONE / (NINE * PI)**THIRD ! + EXPO = - FOURTH * Y2 / AL2 ! + IF(EXPO > MIN_EXP) THEN ! + EXPA = EXP(EXPO) ! + ELSE ! + EXPA = TTINY ! + END IF ! +! + SHA_SF = ONE - EXPA ! ref. (1) eq. (5.6) +! + END FUNCTION SHA_SF +! +!======================================================================= +! + FUNCTION TWA_SF(X,RS) +! +! This function computes Toigo-Woodruff static structure factor S(q) +! for 3D systems +! +! References: V. G. Kohn and V. D. Gorobchenko, +! J. Phys. C:Solid State Phys. 15, 2935-2950 (1982) +! +! +! Warning : Asymptotic value for q/k_F > 2 +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,TEN,THIRD + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : ALFA +! + IMPLICIT NONE +! + REAL (WP) :: X,Y,RS,Y2,Y2_INV + REAL (WP) :: TWA_SF + REAL (WP) :: Y4,Y4_INV + REAL (WP) :: ALPHA,ZS +! +! + ALPHA = ALFA('3D') ! +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! + Y4 = Y2 * Y2 ! +! + Y2_INV = ONE / Y2 ! + Y4_INV = ONE / Y4 ! +! + ZS = ALPHA * RS * PI_INV ! +! + TWA_SF = ONE - TEN * THIRD * THIRD * ZS * Y4_INV * ( & ! + ONE + 129.0E0_WP * Y2_INV / 250.0E0_WP + & ! + 3162.0E0_WP * Y4_INV / 6125.0E0_WP ) + & ! ref. (1) eq. (4.13) + 128.0E0_WP * (ZS * Y4_INV)**2 / 81.0E0_WP ! +! + END FUNCTION TWA_SF +! +END MODULE STRUCTURE_FACTOR_STATIC diff --git a/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_static_2.f90 b/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_static_2.f90 new file mode 100644 index 0000000..9212469 --- /dev/null +++ b/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_static_2.f90 @@ -0,0 +1,458 @@ +! +!======================================================================= +! +MODULE STRUCTURE_FACTOR_STATIC_2 +! + USE ACCURACY_REAL +! +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE STFACT_STATIC_2(X,RS,T,SQ_TYPE,SQ) +! +! This subroutine computes a static structure factor S(q) with the +! help of the local field correction G(q) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0)FACT +! * T : temperature in SI +! * SQ_TYPE : structure factor approximation (3D) +! SQ_TYPE = 'DEH' Debye-Hückel approximation +! SQ_TYPE = 'GEA' generalized approximation +! SQ_TYPE = 'GOR' Gorobchenko approximation +! SQ_TYPE = 'GR2' computed from g(r) (GR_TO_SQ.f code) +! SQ_TYPE = 'GSB' Gori-Giorgi-Sacchetti-Bachelet approximation +! SQ_TYPE = 'HFA' Hartree-Fock approximation (only exchange) +! SQ_TYPE = 'HUB' Hubbard approximation +! SQ_TYPE = 'ICH' Ichimaru approximation +! SQ_TYPE = 'LEE' Lee ideal Fermi gas +! SQ_TYPE = 'MSA' mean spherical approximation +! SQ_TYPE = 'PKA' Pietiläinen-Kallio +! SQ_TYPE = 'RPA' RPA approximation +! SQ_TYPE = 'SHA' Shaw approximation +! SQ_TYPE = 'SIN' Singh +! SQ_TYPE = 'SPA' Singh-Pathak +! SQ_TYPE = 'TWA' Toigo-Woodruff approximation +! +! Intermeduate parameters: +! +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! +! +! Output parameters: +! +! * SQ : static structure factor +! +! Author : D. Sébilleau +! +! Last modified : 23 Jun 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN + USE LF_VALUES, ONLY : GQ_TYPE +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: SQ_TYPE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP), INTENT(OUT) :: SQ +! + IF(DMN == '3D') THEN ! + CALL STFACT_STATIC_3D_2(X,RS,T,SQ_TYPE,GQ_TYPE,SQ) ! + ELSE IF(DMN == '2D') THEN ! + CONTINUE ! + ELSE IF(DMN == '1D') THEN ! + CONTINUE ! + END IF ! +! + END SUBROUTINE STFACT_STATIC_2 +! +!======================================================================= +! + SUBROUTINE STFACT_STATIC_3D_2(X,RS,T,SQ_TYPE,GQ_TYPE,SQ) +! +! This subroutine computes a static structure factor S(q) +! for 3D systems +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * SQ_TYPE : structure factor approximation (3D) +! SQ_TYPE = 'DEH' Debye-Hückel approximation +! SQ_TYPE = 'GEA' generalized approximation +! SQ_TYPE = 'GOR' Gorobchenko approximation +! SQ_TYPE = 'GR2' computed from g(r) (GR_TO_SQ.f code) +! SQ_TYPE = 'GSB' Gori-Giorgi-Sacchetti-Bachelet approximation +! SQ_TYPE = 'HFA' Hartree-Fock approximation (only exchange) +! SQ_TYPE = 'HUB' Hubbard approximation +! SQ_TYPE = 'ICH' Ichimaru approximation +! SQ_TYPE = 'LEE' Lee ideal Fermi gas +! SQ_TYPE = 'MSA' mean spherical approximation +! SQ_TYPE = 'PKA' Pietiläinen-Kallio +! SQ_TYPE = 'RPA' RPA approximation +! SQ_TYPE = 'SHA' Shaw approximation +! SQ_TYPE = 'SIN' Singh +! SQ_TYPE = 'SPA' Singh-Pathak +! SQ_TYPE = 'TWA' Toigo-Woodruff approximation +! * GQ_TYPE : local-field correction type (3D) +! +! +! Author : D. Sébilleau +! +! Last modified : 3 Dec 2020 +! +! +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE +! + REAL (WP) :: X,RS,T + REAL (WP) :: SQ +! + IF(SQ_TYPE == 'GEA') THEN ! + SQ = GEA_SF(X,RS,T,GQ_TYPE) ! + ELSE IF(SQ_TYPE == 'ICH') THEN ! + SQ = ICH_SF(X,RS,T,GQ_TYPE) ! + ELSE IF(SQ_TYPE == 'PKA') THEN ! + SQ = PKA_SF(X,RS,T,GQ_TYPE) ! + ELSE IF(SQ_TYPE == 'SIN') THEN ! + SQ = SIN_SF(X,RS,T) ! + ELSE IF(SQ_TYPE == 'SPA') THEN ! + SQ = SPA_SF(X,RS,T) ! + END IF ! +! + END SUBROUTINE STFACT_STATIC_3D_2 +! +!======================================================================= +! + FUNCTION GEA_SF(X,RS,T,GQ_TYPE) +! +! This function computes generalized approximation static +! structure factor S(q) for 3D systems +! +! References: A. Gold and L. Calmels, Phys. Rev. B 48, +! 11622-11637 (1993) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,FOUR + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,EPS_0 + USE FERMI_SI, ONLY : KF_SI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE COULOMB_K, ONLY : COULOMB_FF + USE SCREENING_TYPE + USE SCREENING_VEC + USE LOCAL_FIELD_STATIC + USE STRUCTURE_FACTOR_STATIC, ONLY : HFA_SF +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: GEA_SF + REAL (WP) :: Y + REAL (WP) :: VQ,Q_SI,S0,PP,GQ + REAL (WP) :: N0,KS +! + REAL (WP) :: SQRT +! + Y = X + X ! Y = q / k_F +! + Q_SI = Y * KF_SI ! q in SI +! +! Computing the screening vector +! + CALL SCREENING_VECTOR(SC_TYPE,'3D',X,RS,T,KS) ! +! +! Computing the Coulomb potential +! + CALL COULOMB_FF('3D','SIU',Q_SI,KS,VQ) ! +! + N0 = RS_TO_N0('3D',RS) ! +! +! Calling the local-field correction +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ) ! +! +! noninteracting electron gas structure factor +! + S0 = HFA_SF(X) ! +! +! plasmon contribution +! + PP = H_BAR * Q_SI / SQRT(FOUR * M_E * N0 * VQ *(ONE - GQ)) ! ref. (1) eq. (5) +! + GEA_SF = ONE / SQRT(ONE / (S0 * S0) + ONE / (PP * PP)) ! ref. (1) eq. (4) +! + END FUNCTION GEA_SF +! +!======================================================================= +! + FUNCTION ICH_SF(X,RS,T,GQ_TYPE) +! +! This function computes Ichimaru static structure factor S(q) +! for 3D systems +! +! References: (1) S. Tanaka and S. Ichimaru, Phys. Rev. A 35, +! 4754 (1987) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * GQ_TYPE : local-field correction type (3D) +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE FERMI_SI, ONLY : KF_SI + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE LOCAL_FIELD_STATIC +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE +! + REAL (WP) :: X,RS,T,Y + REAL (WP) :: ICH_SF + REAL (WP) :: Q_SI,QD_SI,R,R2 + REAL (WP) :: GQ +! + Y = X + X ! Y = q / k_F + Q_SI = Y * KF_SI ! q in SI +! +! Computing the Debye momentum +! + CALL DEBYE_VECTOR('3D',T,RS,QD_SI) ! +! + R = QD_SI / Q_SI ! + R2 = R * R ! +! +! Computing the local-field correction +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ) ! +! + ICH_SF = ONE / (ONE + R2 * (ONE - GQ)) ! ref. (1) eq. (7) +! + END FUNCTION ICH_SF +! +!======================================================================= +! + FUNCTION PKA_SF(X,RS,T,GQ_TYPE) +! +! This function computes Pietiläinen-Kallio static structure factor S(q) +! for 3D systems +! +! References: (1) C. Bowen, G. Sugiyama and B. J. Alder, +! Phys. Rev. B 50, 14838-14848 (1994) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * GQ_TYPE : local-field correction type (3D) +! +! +! Author : D. Sébilleau +! +! Last modified : 10 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,FOUR + USE FERMI_AU, ONLY : KF_AU + USE LOCAL_FIELD_STATIC +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: PKA_SF + REAL (WP) :: Y + REAL (WP) :: GQ,QR0 +! + REAL (WP) :: SQRT +! + Y = X + X ! Y = q / k_F +! + QR0 = Y * KF_AU * RS ! q * r_s * a0 +! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ) ! +! + PKA_SF = ONE / SQRT( ONE + 12.0E0_WP * RS * (ONE - GQ) / & ! + (QR0**4) ) ! ref. (1) eq. (2.16) +! + END FUNCTION PKA_SF +! +!======================================================================= +! + FUNCTION SIN_SF(X,RS,T) +! +! This function computes Singh static structure factor S(q) +! for 3D systems +! +! References: (1) H. B. Singh, Phys. Rev. B 12, 1364-1370 (1975) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Note: we do not solve self-consistently equation (23) +! but keep to the initial value with G3(q) calculated +! with the Ichimaru-Utsumi I(q). In addition, g(0) +! is also taken as the Ichimaru value +! +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THREE,FOUR,HALF,THIRD,FOURTH + USE PI_ETC, ONLY : PI + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E + USE FERMI_SI, ONLY : KF_SI + USE UTILITIES_1, ONLY : ALFA + USE GR_0, ONLY : GR_0_3D + USE PLASMON_ENE_SI + USE LOCAL_FIELD_STATIC, ONLY : IWA4_LFC + USE STRUCTURE_FACTOR_STATIC, ONLY : HFA_SF +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: SIN_SF + REAL (WP) :: Y,Q_SI,Q2 + REAL (WP) :: ALPHA + REAL (WP) :: C,ETA,KC + REAL (WP) :: OP2,OQ2 + REAL (WP) :: SF_0,G3Q,G0 + REAL (WP) :: NUM,DEN,AAA +! + REAL (WP) :: SQRT,EXP +! + Y = X + X ! Y = q / k_F +! + Q_SI = Y * KF_SI ! q in SI + Q2 = Q_SI * Q_SI ! q^2 in SI +! + ALPHA = ALFA('3D') ! +! + C = THREE * PI / (16.0E0_WP * ALPHA * RS) ! ref. (1) eq. (25) +! + KC = HALF / SQRT(C) ! ref. (1) eq. (26) + ETA = EXP(- KC * KC / Q2) ! ref. (1) eq. (28) + OP2 = ENE_P_SI * ENE_P_SI / (H_BAR * H_BAR) ! omega_p^2 + OQ2 = FOURTH * H_BAR * H_BAR * Q2 * Q2 / (M_E * M_E) ! omega_q^2 +! +! Values of S0, G3(q) and g(0) +! + SF_0 = HFA_SF(X) ! + G3Q = IWA4_LFC(X,RS) ! ref. (1) eq. (24) + G0 = GR_0_3D(RS,'ICHI') ! +! + NUM = OP2 + G3Q + THIRD * ETA * OP2 * (G0 - ONE) ! + DEN = OQ2 ! +! + AAA = NUM / DEN + ONE / (SF_0 * SF_0) ! ref. (1) eq. (11) +! + SIN_SF = SQRT(ONE / AAA) ! ref. (1) eq. (11) +! + END FUNCTION SIN_SF +! +!======================================================================= +! + FUNCTION SPA_SF(X,RS,T) +! +! This function computes Singh-Pathak static structure factor S(q) +! for 3D systems +! +! References: (1) H. B. Singh and K. N. Pathak, Phys. Rev. B 8, +! 6035-6937 (1973) +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 12 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THIRD + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : ALFA + USE LOCAL_FIELD_STATIC, ONLY : IWA4_LFC + USE STRUCTURE_FACTOR_STATIC, ONLY : HFA_SF +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP) :: SPA_SF + REAL (WP) :: Y,Y2,Y4 + REAL (WP) :: G3Q,S0,C,ALPHA + REAL (WP) :: NUM,DEN +! + REAL (WP) :: SQRT +! + Y = X + X ! Y = q / k_F + Y2 = Y * Y ! + Y4 = Y2 * Y2 ! +! + ALPHA = ALFA('3D') ! +! + C = ONE / (16.0E0_WP * THIRD * PI_INV * ALPHA * RS) ! ref. (1) eq. (8) +! + G3Q = IWA4_LFC(X,RS) ! +! + S0 = HFA_SF(X) ! +! + NUM = C * Y4 ! + DEN = ONE + G3Q + NUM / (S0 * S0) ! +! + SPA_SF = SQRT(NUM / DEN) ! ref. (1) eq. (7) +! + END FUNCTION SPA_SF +! +END MODULE STRUCTURE_FACTOR_STATIC_2 + diff --git a/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/utic_values.f90 b/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/utic_values.f90 new file mode 100644 index 0000000..f702ce6 --- /dev/null +++ b/New_libraries/DFM_library/STRUCTURE_FACTOR_LIBRARY/utic_values.f90 @@ -0,0 +1,15 @@ +! +!======================================================================= +! +MODULE UTIC_VALUES +! +! This module stoes the values of the omega-independent +! Utsumi-Ichimaru parameters +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: TAU_Q,OM_Q,GAM_Q,MO_Q,MO_0 +! +END MODULE UTIC_VALUES diff --git a/New_libraries/DFM_library/SUM_RULES_LIBRARY/sum_rules.f90 b/New_libraries/DFM_library/SUM_RULES_LIBRARY/sum_rules.f90 new file mode 100644 index 0000000..a2d8114 --- /dev/null +++ b/New_libraries/DFM_library/SUM_RULES_LIBRARY/sum_rules.f90 @@ -0,0 +1,130 @@ +! +!======================================================================= +! +MODULE SUM_RULES +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE DF_SUM_RULES(IQ,Q,Z,RS,EPSR,EPSI,N_Z,Z_MAX) +! +! This program computes the sum rules involving the dielectric function. +! +! +! Input parameters: +! +! * IQ : index of the external array containing Q +! * Q : value of Q = q/k_F +! * Z : array containing Z = hbar omega / E_F +! * EPSR : array Re [ epsilon(hbar omega) ] +! * EPSI : array Im [ epsilon(hbar omega) ] +! * N_Z : size of the Z and EPS arrays +! * ENE_P_SI : plasmon energy at q = 0 (SI) +! * Z_MAX : largest value of Z for which epsilon(Q,Z) is defined +! +! +! Output parameters: +! +! * SR1 : conductivity sum rule +! * SR2 : compressibility sum rule +! * SR3 : f sum rule +! * SR4 : screening sum rule +! * SR5 : Bethe sum rule +! +! +! Author : D. Sébilleau +! +! Last modified : 22 Sep 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO, & + HALF + USE PI_ETC, ONLY : PI,PI2 + USE UTILITIES_1, ONLY : RS_TO_N0 + USE INTEGRATION, ONLY : INTEGR_L,INTDE + USE PLASMON_ENE_SI +! + USE OUT_VALUES_3 + USE PRINT_FILES +! + IMPLICIT NONE +! + INTEGER :: I,IQ,N_Z,ID +! + REAL (WP) :: Q,Z_MAX + REAL (WP) :: Z(NSIZE),EPSR(NSIZE),EPSI(NSIZE) + REAL (WP) :: F1(NSIZE),F2(NSIZE),F3(NSIZE),F4(NSIZE),F5(NSIZE) ! integrands + REAL (WP) :: SR1,SR2,SR3,SR4,SR5 + REAL (WP) :: EX1,EX2,EX3,EX4,EX5 + REAL (WP) :: ALPHA_Q ! screening parameter + REAL (WP) :: PIO2 ! pi/2 + REAL (WP) :: A,B + REAL (WP) :: EPS,ERR1,ERR2,ERR3,ERR4,ERR5 + REAL (WP) :: H + REAL (WP) :: EI + REAL (WP) :: RS,N0 + REAL (WP) :: TTINY +! + REAL (WP) :: ABS,SIGN +! + ID = 2 ! +! + N0 = RS_TO_N0('3D',RS) ! +! + H = Z(2) - Z(1) ! +! + ALPHA_Q = EPSR(1) ! + PIO2 = HALF * PI ! + EPS = 0.01E0_WP ! + TTINY = 1.0E-30_WP ! +! + A = ZERO ! + B = Z_MAX ! +! +! Exact values of sum rules: +! + EX1 = PIO2 * ENE_P_SI * ENE_P_SI ! + EX2 = PIO2 * ALPHA_Q ! + EX3 = - PIO2 * ENE_P_SI * ENE_P_SI ! + EX4 = - PIO2 *ALPHA_Q / (ONE + ALPHA_Q) ! + EX5 = - TWO * PI2 * N0 ! +! +! Integrands for the sum rules +! + DO I = 1,N_Z ! +! + EI = EPSI(I) ! + IF(ABS(EPSI(I)) < TTINY) EPSI(I )= SIGN(TTINY,EI) ! + F1(I) = EPSI(I) * Z(I) ! + F2(I) = EPSI(I) / Z(I) ! + F3(I) = ONE / F2(I) ! + F4(I) = ONE / F1(I) ! + IF(IQ == 1) THEN ! + F5(I) = F3(I) ! + END IF ! +! + END DO ! +! +! Computing the integrals from 0 to Z_MAX +! + CALL INTEGR_L(F1,H,NSIZE,N_Z,A,ID) ! + CALL INTDE(F1,Z,N_Z,A,B,EPS,SR1,ERR1) ! + CALL INTDE(F2,Z,N_Z,A,B,EPS,SR2,ERR2) ! + CALL INTDE(F3,Z,N_Z,A,B,EPS,SR3,ERR3) ! + CALL INTDE(F4,Z,N_Z,A,B,EPS,SR4,ERR4) ! + CALL INTDE(F5,Z,N_Z,A,B,EPS,SR5,ERR5) ! +! +! Writing the results (EXn - SRn) +! + IF(I_SR == ONE) THEN ! + WRITE(IO_SR,*) Q,EX1-SR1,EX2-SR2,EX3-SR3,EX4-SR4,EX5-SR5 ! + END IF ! +! + END SUBROUTINE DF_SUM_RULES +! +END MODULE SUM_RULES diff --git a/New_libraries/DFM_library/TEST_LIBRARY/calculators_test.f90 b/New_libraries/DFM_library/TEST_LIBRARY/calculators_test.f90 new file mode 100644 index 0000000..84aaf16 --- /dev/null +++ b/New_libraries/DFM_library/TEST_LIBRARY/calculators_test.f90 @@ -0,0 +1,83 @@ +! +!======================================================================= +! +MODULE CALCULATORS_TEST +! + USE ACCURACY_REAL +! +! This module contains the test subroutines +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_TEST(IX,X) +! +! This subroutine tests different subroutines +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Intermediate parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! +! Author : D. Sébilleau +! +! Last modified : 15 Sep 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ONE + USE FERMI_SI, ONLY : EF_SI + USE MATERIAL_PROP, ONLY : RS + USE EXT_FIELDS, ONLY : T +! + USE E_GRID +! + USE LF_VALUES, ONLY : GQ_TYPE + USE SF_VALUES, ONLY : SQ_TYPE +! + USE RELAXATION_TIME_STATIC +! + IMPLICIT NONE +! + INTEGER :: IX,IE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: E,EK + REAL (WP) :: TAU_1,TAU_2,TAU_3,TAU_4,TAU_5 +! + IF(IX == 1) THEN + TAU_1 = BACA_RT_3D(RS,T) ! + TAU_2 = FSTB_RT_3D(RS) ! + TAU_3 = UTIC_RT_3D(X,RS,T,SQ_TYPE,GQ_TYPE) ! +! PRINT *,'BACA_RT_3D = ',TAU_1 ! +! PRINT *,'FSTB_RT_3D = ',TAU_2 ! +! PRINT *,'UTIC_RT_3D = ',TAU_3 ! + END IF ! +! + DO IE = 1, N_E ! energy loop +! + E = E_MIN + FLOAT(IE - 1) * E_STEP ! E = hbar omega / E_F + EK = E * EF_SI +! + TAU_4 = QIVI_RT_3D(EK,X,T) ! + TAU_5 = QIV2_RT_3D(EK,X,T) ! +! + IF(TAU_4 < ONE) THEN ! +! PRINT *,'QIVI_RT_3D = ',TAU_4 ! +! PRINT *,'QIV2_RT_3D = ',TAU_5 ! + END IF ! +! +! + END DO ! +! + END SUBROUTINE CALC_TEST +! +END MODULE CALCULATORS_TEST diff --git a/New_libraries/DFM_library/TEST_LIBRARY/test_int_Hubbard.f90 b/New_libraries/DFM_library/TEST_LIBRARY/test_int_Hubbard.f90 new file mode 100644 index 0000000..b1e3ba9 --- /dev/null +++ b/New_libraries/DFM_library/TEST_LIBRARY/test_int_Hubbard.f90 @@ -0,0 +1,157 @@ +! +!======================================================================= +! +MODULE TEST_INT_HUBBARD +! + USE ACCURACY_REAL +! +! This module contains the test subroutine for the Hubbard double integral +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_TEST_HUBBARD +! +! This subroutine tests the Hubbard double integral occuring +! in the calculation of the correlation energy +! +! Reference : J. Hubbard, Proc. Roy. Soc. A 243, 336-352 (1958) +! +! +! Author : D. Sébilleau +! +! Last modified : 15 Dec 2020 +! +! +! + USE DIMENSION_CODE, ONLY : NZ_MAX + USE MATERIAL_PROP, ONLY : RS + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF,FOURTH + USE PI_ETC, ONLY : PI,PI_INV + USE UTILITIES_1, ONLY : ALFA + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + INTEGER :: IX,IY + INTEGER :: LOGF +! + REAL (WP) :: XI,HX,HY + REAL (WP) :: X,X3,Y + REAL (WP) :: A(NZ_MAX,NZ_MAX) + REAL (WP) :: SIGMA(NZ_MAX,NZ_MAX) + REAL (WP) :: F1(NZ_MAX),F2(NZ_MAX) + REAL (WP) :: INT_1,INT_2 + REAL (WP) :: NUM1,NUM2,DEN1,DEN2,Z1,Z2 +! + REAL (WP), PARAMETER :: MX = 5.0E0_WP ! upper integration + REAL (WP), PARAMETER :: MY = 5.0E0_WP ! bounds in x and y +! + REAL (WP), PARAMETER :: SM = 1.0E-8_WP ! starting grid value +! + REAL (WP) :: FLOAT,LOG,ABS +! + LOGF = 6 ! log file +! + XI = TWO * ALFA('3D') * PI_INV * RS ! ref. 1 eq. (28) +! + HX = MX / FLOAT(NZ_MAX - 1) ! x-step + HY = MY / FLOAT(NZ_MAX - 1) ! y-step +! + WRITE(LOGF,10) ! + WRITE(LOGF,20) ! + WRITE(LOGF,30) ! + WRITE(LOGF,20) ! +! + WRITE(LOGF,40) NZ_MAX,MX ! + WRITE(LOGF,40) NZ_MAX,MY ! + WRITE(LOGF,20) ! +! +! Construction the functions A and Sigma +! + DO IX = 1, NZ_MAX ! +! + X = SM + FLOAT(IX - 1) * HX ! + X3 = X * X * X ! +! + DO IY = 1, NZ_MAX ! +! + Y = SM + FLOAT(IY - 1) * HY ! +! +! Calculation of Sigma(x,y) ! ref. 1 eq. (26) +! + IF(Y > X * (X + TWO)) THEN ! + SIGMA(IX,IY) = ZERO ! + ELSE IF(X > TWO .AND. Y < X * (X - TWO)) THEN ! + SIGMA(IX,IY) = ZERO ! + ELSE IF( X > TWO .AND. X * (X - TWO) < Y .AND. & ! + Y < X * (X + TWO) & ! + .OR. & ! + X < TWO .AND. X * (TWO - X) < Y .AND. & ! + Y < X * (X + TWO) & ! + ) THEN ! + SIGMA(IX,IY) = - PI * XI * HALF * ( ONE - FOURTH * & ! + (Y / X - X)**2 & ! + ) / X3 ! + ELSE IF(X < TWO .AND. ZERO < Y .AND. & ! + Y < X * (TWO - X)) THEN ! + SIGMA(IX,IY) = - PI * XI * Y * HALF / X3 ! + END IF ! +! +! Calculation of A(x,y) ! ref. 1 eq. (27) +! + NUM1 = Y - X * (X + TWO) ! + NUM2 = Y + X * (X + TWO) ! + DEN1 = Y - X * (X - TWO) ! + DEN2 = Y + X * (X - TWO) ! +! + Z1 = (Y / X - X)**2 ! + Z2 = (Y / X + X)**2 ! +! + A(IX,IY) = - XI * ( X + & ! + HALF * (ONE - FOURTH * Z1) * & ! + LOG(ABS(NUM1 / DEN1)) + & ! + HALF * (ONE - FOURTH * Z2) * & ! + LOG(ABS(NUM2 / DEN2)) & ! + ) / X3 ! +! +! y-integrand +! + F2(IY) = ATAN( SIGMA(IX,IY) / (ONE - A(IX,IY)) ) - & ! + SIGMA(IX,IY) ! +! + END DO ! +! +! Computing the integral over y +! + CALL INTEGR_L(F2,HY,NZ_MAX,NZ_MAX,INT_2,1) ! +! +! x-integrand +! + F1(IX) = X * X * INT_2 ! +! + + END DO ! +! +! Computing the integral over x +! + CALL INTEGR_L(F1,HX,NZ_MAX,NZ_MAX,INT_1,1) ! +! + WRITE(LOGF,60) INT_1 ! +! + WRITE(LOGF,80) ! +! +! Formats: +! + 10 FORMAT(6X,'_________________________________________________________') + 20 FORMAT(5X,'| |') + 30 FORMAT(5X,'|',3X,'Test of the integrals contained in HUbbard eps_c |') + 40 FORMAT(5X,'|',5X,'Integr. points: ',I4,' Up. bound x: ',F8.3,9X,'|') + 50 FORMAT(5X,'|',5X,'Integr. points: ',I4,' Up. bound y: ',F8.3,9X,'|') + 60 FORMAT(5X,'|',36X,'INT = ',F8.3,7X,'|') + 80 FORMAT(5X,'|_________________________________________________________|',/) +! + END SUBROUTINE CALC_TEST_HUBBARD +! +END MODULE TEST_INT_HUBBARD diff --git a/New_libraries/DFM_library/TEST_LIBRARY/test_integrals_2.f90 b/New_libraries/DFM_library/TEST_LIBRARY/test_integrals_2.f90 new file mode 100644 index 0000000..460b0df --- /dev/null +++ b/New_libraries/DFM_library/TEST_LIBRARY/test_integrals_2.f90 @@ -0,0 +1,104 @@ +! +!======================================================================= +! +MODULE TEST_INTEGRALS_2 +! + USE ACCURACY_REAL +! +! This module contains the test subroutine for MODULE SPECIFIC_INT_2 +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_TEST_INT_2 +! +! This subroutine allows to test the integrals contained in +! MODULE SPECIFIC_INT_2 +! +! +! Author : D. Sébilleau +! +! Last modified : 3 Dec 2020 +! +! + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T + USE LF_VALUES, ONLY : GQ_TYPE + USE SF_VALUES, ONLY : SQ_TYPE +! + USE FERMI_SI, ONLY : KF_SI +! + USE SCREENING_VEC, ONLY : THOMAS_FERMI_VECTOR + USE SPECIFIC_INT_2 +! + IMPLICIT NONE +! + INTEGER :: LOGF + INTEGER :: IN_MODE,NMAX + INTEGER :: L +! + REAL (WP) :: KS + REAL (WP) :: X_MAX,AA,A,X_TF + REAL (WP) :: IN +! + LOGF = 6 ! log file +! + NMAX = 1000 ! number of integration points + X_MAX = 4.0E0_WP ! upper intergration bound + L = 2 ! power of x + AA = 1.0E0_WP ! +! +! Computing Thomas-Fermi screening vector +! + CALL THOMAS_FERMI_VECTOR(DMN,KS) ! + X_TF = KS / KF_SI ! q_{TF} / k_F +! + WRITE(LOGF,10) ! + WRITE(LOGF,20) ! + WRITE(LOGF,30) ! + WRITE(LOGF,20) ! +! + WRITE(LOGF,40) NMAX,X_MAX ! + WRITE(LOGF,20) ! +! +! Computing the integral +! + DO IN_MODE = 1, 7 ! +! + IF(IN_MODE == 3) THEN ! + A = X_TF ! + ELSE ! + A = AA ! + END IF ! +! + CALL INT_SQM1(NMAX,X_MAX,IN_MODE,RS,T,X_TF,L,SQ_TYPE, & ! + GQ_TYPE,IN) ! +! + IF(IN_MODE == 1) THEN ! + WRITE(LOGF,50) IN_MODE,IN ! + ELSE IF(IN_MODE == 5) THEN ! + WRITE(LOGF,60) IN_MODE,L,IN ! + ELSE ! + WRITE(LOGF,70) IN_MODE,A,IN ! + END IF ! +! + END DO ! +! + WRITE(LOGF,20) ! + WRITE(LOGF,80) ! +! +! Formats: +! + 10 FORMAT(6X,'_________________________________________________________') + 20 FORMAT(5X,'| |') + 30 FORMAT(5X,'|',3X,'Test of the integrals contained in SPECIFIC_INT_2 |') + 40 FORMAT(5X,'|',5X,'Integr. points: ',I4,' Up. bound: ',F8.3,11X,'|') + 50 FORMAT(5X,'|',5X,'IN_MODE = ',I1,20X,'INT = ',F8.3,7X,'|') + 60 FORMAT(5X,'|',5X,'IN_MODE = ',I1,' L = ',I4,10X,'INT = ',F8.3,7X,'|') + 70 FORMAT(5X,'|',5X,'IN_MODE = ',I1,' A = ',F8.3,6X,'INT = ',F8.3,7X,'|') + 80 FORMAT(5X,'|_________________________________________________________|',/) +! + END SUBROUTINE CALC_TEST_INT_2 +! +END MODULE TEST_INTEGRALS_2 diff --git a/New_libraries/DFM_library/TEST_LIBRARY/test_integrals_3.f90 b/New_libraries/DFM_library/TEST_LIBRARY/test_integrals_3.f90 new file mode 100644 index 0000000..c1b4b97 --- /dev/null +++ b/New_libraries/DFM_library/TEST_LIBRARY/test_integrals_3.f90 @@ -0,0 +1,88 @@ +! +!======================================================================= +! +MODULE TEST_INTEGRALS_3 +! + USE ACCURACY_REAL +! +! This module contains the test subroutine for MODULE SPECIFIC_INT_3 +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_TEST_INT_3 +! +! This subroutine allows to test the integrals contained in +! MODULE SPECIFIC_INT_3 +! +! +! Author : D. Sébilleau +! +! Last modified : 3 Dec 2020 +! +! + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : T + USE PC_VALUES, ONLY : GR_TYPE + USE PD_VALUES, ONLY : RH_TYPE +! + USE SPECIFIC_INT_3 +! + IMPLICIT NONE +! + INTEGER :: LOGF + INTEGER :: IN_MODE,NMAX,L +! + REAL (WP) :: X_MAX,A + REAL (WP) :: IN +! + LOGF = 6 ! log file +! + NMAX = 1000 ! number of integration points + X_MAX = 4.0E0_WP ! upper intergration bound + L = 2 ! power of x + A = 1.0E0_WP ! +! + WRITE(LOGF,10) ! + WRITE(LOGF,20) ! + WRITE(LOGF,30) ! + WRITE(LOGF,20) ! +! + WRITE(LOGF,40) NMAX,X_MAX ! + WRITE(LOGF,20) ! +! +! Computing the integral +! + DO IN_MODE = 1, 6 ! +! + CALL INT_GRM1(NMAX,X_MAX,IN_MODE,RS,T,A,L,GR_TYPE, & ! + RH_TYPE,IN) ! +! + IF(IN_MODE == 1) THEN ! + WRITE(LOGF,50) IN_MODE,IN ! + ELSE IF(IN_MODE == 2 .OR. IN_MODE == 3) THEN ! + WRITE(LOGF,60) IN_MODE,L,IN ! + ELSE ! + WRITE(LOGF,70) IN_MODE,A,IN ! + END IF ! +! + END DO ! +! + WRITE(LOGF,20) ! + WRITE(LOGF,80) ! +! +! Formats: +! + 10 FORMAT(6X,'_________________________________________________________') + 20 FORMAT(5X,'| |') + 30 FORMAT(5X,'|',3X,'Test of the integrals contained in SPECIFIC_INT_3 |') + 40 FORMAT(5X,'|',5X,'Integr. points: ',I4,' Up. bound: ',F8.3,11X,'|') + 50 FORMAT(5X,'|',5X,'IN_MODE = ',I1,20X,'INT = ',F8.3,7X,'|') + 60 FORMAT(5X,'|',5X,'IN_MODE = ',I1,' L = ',I4,10X,'INT = ',F8.3,7X,'|') + 70 FORMAT(5X,'|',5X,'IN_MODE = ',I1,' A = ',F8.3,6X,'INT = ',F8.3,7X,'|') + 80 FORMAT(5X,'|_________________________________________________________|',/) +! + END SUBROUTINE CALC_TEST_INT_3 +! +END MODULE TEST_INTEGRALS_3 diff --git a/New_libraries/DFM_library/TEST_LIBRARY/test_integrals_8.f90 b/New_libraries/DFM_library/TEST_LIBRARY/test_integrals_8.f90 new file mode 100644 index 0000000..19329cd --- /dev/null +++ b/New_libraries/DFM_library/TEST_LIBRARY/test_integrals_8.f90 @@ -0,0 +1,84 @@ +! +!======================================================================= +! +MODULE TEST_INTEGRALS_8 +! + USE ACCURACY_REAL +! +! This module contains the test subroutine for MODULE SPECIFIC_INT_8 +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE CALC_TEST_INT_8 +! +! This subroutine allows to test the integrals contained in +! MODULE SPECIFIC_INT_38 +! +! +! Author : D. Sébilleau +! +! Last modified : 3 Dec 2020 +! +! + USE Q_GRID +! + USE REAL_NUMBERS, ONLY : HALF +! + USE SPECIFIC_INT_8 +! + IMPLICIT NONE +! + INTEGER :: LOGF ! log file index + INTEGER :: IQ ! loop index + +! + REAL (WP) :: Q,X + REAL (WP) :: A,B + REAL (WP) :: INTG +! + LOGF = 6 ! log file +! + A = 1.0E0_WP ! + B = 1.0E0_WP ! +! + OPEN(UNIT = 2, FILE = 'test_int8.dat', STATUS = 'unknown') ! +! + WRITE(LOGF,10) ! + WRITE(LOGF,20) ! + WRITE(LOGF,30) ! + WRITE(LOGF,20) ! +! +! Computing the q values +! + DO IQ = 1, N_Q ! +! + Q = Q_MIN + FLOAT(IQ - 1) * Q_STEP ! Q = q/k_F +! + X = HALF * Q ! X = q/(2k_f) +! + CALL INT_ARB(X,A,B,INTG) ! +! + WRITE(2,*) X,INTG ! +! + END DO ! +! + CLOSE(2) +! + WRITE(LOGF,40) ! + WRITE(LOGF,20) ! + WRITE(LOGF,80) ! +! +! Format: +! + 10 FORMAT(6X,'_________________________________________________________') + 20 FORMAT(5X,'| |') + 30 FORMAT(5X,'|',3X,'Test of the integrals contained in SPECIFIC_INT_8 |') + 40 FORMAT(5X,'|',7X,'Result written into file "test_int8.dat"',10X,'|') + 80 FORMAT(5X,'|_________________________________________________________|',/) +! + END SUBROUTINE CALC_TEST_INT_8 +! +END MODULE TEST_INTEGRALS_8 + diff --git a/New_libraries/DFM_library/THERMAL_PROPERTIES_LIBRARY/chemical_potential.f90 b/New_libraries/DFM_library/THERMAL_PROPERTIES_LIBRARY/chemical_potential.f90 new file mode 100644 index 0000000..c03a225 --- /dev/null +++ b/New_libraries/DFM_library/THERMAL_PROPERTIES_LIBRARY/chemical_potential.f90 @@ -0,0 +1,297 @@ +! +!======================================================================= +! +MODULE CHEMICAL_POTENTIAL +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + FUNCTION MU_RS(RS,EC_TYPE) +! +! This function computes the chemical potential as a function of r_s +! for a 3D system +! +! References: (1) G. E. Simion and G. F. Giuliani, Phys. Rev. B 77, +! 035131 (2008) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * EC_TYPE : type of correlation energy functional +! +! Output parameters: +! +! * MU_RS : chemical potential in SI +! +! +! Warning : all correlation energies are given in Ryd +! +! +! +! Author : D. Sébilleau +! +! Last modified : 2 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,HALF,THIRD + USE CONSTANTS_P1, ONLY : BOHR,E + USE PI_ETC, ONLY : PI_INV + USE UTILITIES_1, ONLY : ALFA + USE CORRELATION_ENERGIES, ONLY : EC_3D,DERIVE_EC_3D + USE ENE_CHANGE, ONLY : EV,RYD +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP), INTENT(IN) :: RS + REAL (WP) :: MU_RS + REAL (WP) :: ALPHA,COEF,K + REAL (WP) :: EC,D_EC_1,D_EC_2 +! + ALPHA = ALFA('3D') ! + COEF = E * E / (BOHR * RS) ! e^2 /(a_0 * r_s) + K = EV * RYD ! conversion Ryd --> SI +! +! Computing the correlation energy derivatives +! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,ZERO,D_EC_1,D_EC_2) ! +! + MU_RS = HALF * COEF / (RS * ALPHA * ALPHA) - & ! + PI_INV * COEF / ALPHA + & ! ref. (1) eq. (50) + EC_3D(EC_TYPE,1,RS,ZERO) * K - & ! + THIRD * RS * D_EC_1 * K ! +! + END FUNCTION MU_RS +! +!======================================================================= +! + FUNCTION MU(DMN,T) +! +! This function computes the chemical potential as a function of T, +! for small values of T +! +! References: (1) M. Selmke, https://photonicsdesign.jimdo.com/app/ +! download/5512592980/SommerfeldExpansion.pdf?t=1418743530 +! (2) E. Cetina, F. Magana and A. A. Valladares, +! Am. J. Phys. 45, 960-963 (1977) +! +! Input parameters: +! +! * DMN : dimension +! * T : temperature (SI) +! +! +! Author : D. Sébilleau +! +! Last modified : 2 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI2 +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP), INTENT(IN) :: T + REAL (WP) :: MU + REAL (WP) :: BETA,THETA,THETA2,THETA4 + REAL (WP) :: PI4 +! + REAL (WP) :: LOG,EXP +! + BETA = ONE / (K_B * T) ! + THETA = ONE / (BETA * EF_SI) ! k_B T / E_F + THETA2 = THETA * THETA ! + THETA4 = THETA2 * THETA2 ! +! + PI4 = PI2 * PI2 ! +! + IF(DMN == '3D') THEN ! +! + MU = EF_SI * (ONE - PI2 * THETA2 / 12.0E0_WP - & ! ref. 1 eq. (29) + PI4 * THETA4 / 80.0E0_WP) ! +! + ELSE IF(DMN == '2D') THEN ! +! + MU = EF_SI * (ONE + THETA * LOG(ONE - EXP(- ONE / THETA))) ! ref. 2 eq. (13) +! + ELSE IF(DMN == '1D') THEN ! +! + MU = EF_SI * (ONE + PI2 * THETA2 / 12.0E0_WP) ! +! + END IF ! +! + END FUNCTION MU +! +!======================================================================= +! + FUNCTION MU_T(DMN,T) +! +! This function computes the chemical potential as a function of T +! for any value if T +! +! References: (1) N.G. Nilsson, Phys. Stat. Sol. (a) 19, K75-K78 (1973) +! +! +! Note : we use here Nilsson' approximation for eta = mu / (k_B T), as in 3D, +! +! 2/3 D^{3/2) = F_{1/2}(eta) <-- Fermi-Dirac integral +! +! +! Input parameters: +! +! * DMN : dimension +! * T : temperature (SI) +! +! +! Author : D. Sébilleau +! +! Last modified : 3 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,HALF,THIRD,FOURTH + USE CONSTANTS_P1, ONLY : K_B + USE FERMI_SI, ONLY : EF_SI + USE PI_ETC, ONLY : PI2,SQR_PI +! + USE SPECIFIC_INT_7, ONLY : FD +! + USE OUT_VALUES_10, ONLY : I_WR +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + INTEGER :: NN,I,NE + INTEGER :: LOGF +! + REAL (WP), INTENT(IN) :: T + REAL (WP) :: MU_T + REAL (WP) :: ETA,TH + REAL (WP) :: KBT + REAL (WP) :: U,V,W,FF,FDF + REAL (WP) :: FDF1,FDF2,FDF3,FDF4,FDF5 + REAL (WP) :: ETA1,ETA2,ETA3,ETA4,ETA5 + REAL (WP) :: GF + REAL (WP) :: D + REAL (WP) :: DD,ET_STEP,ET,ET_M,ET_AV +! + REAL (WP) :: FLOAT,LOG,SQRT,ABS +! + LOGF = 6 ! +! + GF = HALF * SQR_PI ! Gamma(3/2) +! + KBT = K_B * T ! + TH = KBT / EF_SI ! +! +! Calculating eta +! + IF(DMN == '3D') THEN ! +! + D = ONE / TH ! E_F / k_B T + U = TWO * THIRD * (D**1.5E0_WP) / GF ! + W = THREE * SQR_PI * U * FOURTH ! + V = W**(TWO * THIRD) ! +! +! Computing Nilsson's approximations to eta +! +! + ETA1 = LOG(U) ! + FDF1 = FD(ETA1,0.5D0) ! +! + IF(U < 3.703704D0) THEN ! + ETA2 = LOG( U / (1.0D0 - 0.27D0 * U) ) ! + FDF2 = FD(ETA2,0.5D0) ! + END IF ! +! + IF(V * V > PI2 / 6.0D0) THEN ! + ETA3 = SQRT( V * V - PI2 / 6.0D0 ) ! + FDF3 = FD(ETA3,0.5D0) ! + END IF ! +! + IF(U /= 1.0D0) THEN ! + ETA4 = LOG(U) / (1.0D0 - U) + V + 2.0D0 * V / & ! + (3.0D0 + V)**2 ! + FDF4 = FD(ETA4,0.5D0) ! + END IF ! +! + IF(U /= 1.0D0) THEN ! + ETA5 = LOG(U) / (1.0D0 - U * U) + V - & ! + V / (0.24D0 + 1.08D0 * V)**2 ! + FDF5 = FD(ETA5,0.5D0) ! + END IF ! +! + FF = 2.0D0 * THIRD * D**1.5D0 +! + IF(U == 1.0D0) THEN ! + ET_AV = ETA3 ! + DD = U ! + ELSE ! + ET_AV = ETA4 ! + DD = ABS(ETA5 - ETA4) / ABS(ETA5) ! + END IF ! +! + IF(DD > 0.001D0) THEN ! +! + ET_M = DD * 5.0D0 ! + ET_STEP = 2.0D0 * ET_M / FLOAT(NE - 1) ! +! + DO I = 1, NE ! + ET = ET_AV - ET_M + FLOAT(I - 1) * ET_STEP ! + FDF = FD(ET,0.5D0) ! + IF(ABS((FDF - FF)/FF) < 0.001D0) GO TO 5 ! + END DO ! + 5 ETA = ET ! + ELSE ! + ETA = ETA5 ! + FDF = FDF5 ! + END IF ! +! + ELSE IF(DMN == '2D') THEN ! +! + ETA = LOG(EXP(- TH) - ONE) ! +! + ELSE IF(DMN == '1D') THEN ! +! + CONTINUE ! not implemented yet +! + END IF ! +! + IF(I_WR == 1) THEN ! + WRITE(LOGF,10) ETA1,FDF1,FF ! + WRITE(LOGF,20) ETA2,FDF2,FF ! + WRITE(LOGF,30) ETA3,FDF3,FF ! + WRITE(LOGF,40) ETA4,FDF4,FF ! + WRITE(LOGF,50) ETA5,FDF5,FF ! + WRITE(LOGF,60) ETA ,FDF ,FF ! + END IF ! +! + MU_T = ETA * KBT ! +! +! Formats: +! + 10 FORMAT(//,5X,'eta_1 = ',F12.6,' F_{1/2} approx. = ',F12.6, & + ' F_{1/2} exact. = ',F12.6) + 20 FORMAT(//,5X,'eta_2 = ',F12.6,' F_{1/2} approx. = ',F12.6, & + ' F_{1/2} exact. = ',F12.6) + 30 FORMAT(//,5X,'eta_3 = ',F12.6,' F_{1/2} approx. = ',F12.6, & + ' F_{1/2} exact. = ',F12.6) + 40 FORMAT(//,5X,'eta_4 = ',F12.6,' F_{1/2} approx. = ',F12.6, & + ' F_{1/2} exact. = ',F12.6) + 50 FORMAT(//,5X,'eta_5 = ',F12.6,' F_{1/2} approx. = ',F12.6, & + ' F_{1/2} exact. = ',F12.6) + 60 FORMAT(//,5X,'eta = ',F12.6,' F_{1/2} approx. = ',F12.6, & + ' F_{1/2} exact. = ',F12.6) +! + END FUNCTION MU_T +! +END MODULE CHEMICAL_POTENTIAL diff --git a/New_libraries/DFM_library/THERMAL_PROPERTIES_LIBRARY/thermal_properties.f90 b/New_libraries/DFM_library/THERMAL_PROPERTIES_LIBRARY/thermal_properties.f90 new file mode 100644 index 0000000..de8ddcc --- /dev/null +++ b/New_libraries/DFM_library/THERMAL_PROPERTIES_LIBRARY/thermal_properties.f90 @@ -0,0 +1,84 @@ +! +!======================================================================= +! +MODULE THERMAL_PROPERTIES +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE TH_PROP(DMN,RS,T,K_TH,V_TH,L_TH,CV,P) +! +! This subroutine computes the thermal variations of different +! physical properties +! +! References: (1) J.-S. Chen, J. Stat. Mech. L08002 (2009) +! (2) M. Selmke, https://photonicsdesign.jimdo.com/app/ +! download/5512592980/SommerfeldExpansion.pdf?t=1418743530 +! +! Input parameters: +! +! * DMN : dimension +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! +! Output parameters: +! +! * K_TH : De Broglie momentum +! * V_TH : thermal velocity +! * L_TH : Landau length +! * CV : electron specific heat +! * P : electron pressure +! +! +! Author : D. Sébilleau +! +! Last modified : 28 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FIVE,SIX, & + HALF,THIRD + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,COULOMB,K_B + USE FERMI_SI, ONLY : EF_SI,TF_SI + USE PI_ETC, ONLY : PI,PI2,PI3 + USE UTILITIES_1, ONLY : RS_TO_N0 +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP) :: RS,T,BETA,RAT + REAL (WP) :: T_F,K_TH,V_TH,L_TH,CV,P + REAL (WP) :: N0 +! + N0=RS_TO_N0(DMN,RS) ! +! + BETA=ONE/(K_B*T) +! + RAT=T/TF_SI ! T / T_F ratio +! + K_TH=ONE/DSQRT(TWO*PI*H_BAR*H_BAR*BETA/M_E) ! De Broglie momentum + V_TH=DSQRT(ONE/(M_E*BETA)) ! thermal velocity + L_TH=E*E*COULOMB*BETA ! Landau length +! + IF(DMN == '3D') THEN + CV=K_B*N0 * ( HALF*PI2*RAT - & ! ref. 2 eq. 31 + THREE*PI2*PI2*RAT*RAT*RAT / 20.0E0_WP - & ! + 247.0E0_WP*PI3*PI3*RAT*RAT*RAT*RAT*RAT / & ! + 2016.0E0_WP & ! + ) ! + P=TWO*THIRD*EF_SI*N0 * (ONE + FIVE*PI2*RAT*RAT/12.0E0_WP -& ! ref. 1 eq. (23) + PI2*PI2*RAT*RAT*RAT*RAT/16.0E0_WP) ! + ELSE IF(DMN == '2D') THEN ! + CV=K_B*N0 * THIRD*PI2*RAT ! + ELSE IF(DMN == '1D') THEN ! + CV=K_B*N0 * (PI2*RAT/SIX) ! + END IF ! +! + END SUBROUTINE TH_PROP + +! +END MODULE THERMAL_PROPERTIES diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/atomic_properties.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/atomic_properties.f90 new file mode 100644 index 0000000..e80c993 --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/atomic_properties.f90 @@ -0,0 +1,610 @@ +! +!======================================================================= +! +MODULE ATOMIC_PROPERTIES +! +! This module contains physical properties of the chemical elements, +! namely: The atomic mass, the density of all the +! elements,the various radii available in the literature, +! Debye temperatures and bulk, shear, Young moduli and Poisson ratio, +! the work function and the valence (integer and noninteger), +! the electric resistivity and the lattice constants, +! the magnetic type. +! +! Units and main references: +! +! atomic mass --> g/mol http://periodictable.com/Properties/A/AtomicMass.html +! density --> g/cm^3 http://periodictable.com/Properties/A/Density.html +! atomic radius --> Angstroem http://periodictable.com/Properties/A/AtomicRadius.html +! ionic radius --> Angstroem http://chemistry-reference.com/images/ionic%20radius%20table.jpg +! covalent radius --> Angstroem http://periodictable.com/Properties/A/CovalentRadius.html +! Wigner-Seitz radius --> Angstroem "Solid State Physics", Ashcroft-Mermin p.5 +! Debye temperature --> Kelvin http://www.knowledgedoor.com/2/elements_handbook/debye_temperature.html +! bulk modulus --> GPa http://periodictable.com/Properties/A/BulkModulus.html +! shear modulus --> GPa http://periodictable.com/Properties/A/ShearModulus.html +! Young modulus --> GPa http://periodictable.com/Properties/A/YoungModulus.html +! Poisson ratio --> dimensionless http://periodictable.com/Properties/A/PoissonRatio.v.html +! work function --> eV S. Halas, Materials Science-Poland 24, 951 (2006) +! valence --> dimensionless https://ptable.com/#Property/Valence +! noninteger valence --> dimensionless "The Physics of Solids. Essentials and Beyond" +! resistivity --> m Ohm http://periodictable.com/Properties/A/Resistivity.an.log.html +! lattice constants --> Angstroem http://periodictable.com/Properties/A/LatticeConstants.html +! crystal structure --> dimensionless http://periodictable.com/Properties/A/CrystalStructure.html +! magnetic type --> dimensionless http://periodictable.com/Properties/A/MagneticType.html +! +! Additional references: +! +! * "Fundamentals of the Physics of Solids", Vol1, Solyom p.596 (Debye) +! * A. Ruban et al, J. Mol. Cat. A: Chem 115, 421-429 (1997) (WS) +! * "The Physics of Solids. Essentials and Beyond", E.N. Economou, Springer, table 4.2 p. 89 (WS) +! table 4.1 p. 85 (NIBV) +! * https://i.stack.imgur.com/1mEVV.png (Work function) +! * http://periodictable.com/Properties/A/Valence.al.html (Valence) +! +! +! Value Z = 0 added for empty spheres (ES). The values entered in this +! case are arbitrary and set to the corresponding Z = 1 value +! divided by 1836 (the ratio of the mass of the proton and electron). +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Aug 2020 +! +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! +! 1) Chemical symbol +! + CHARACTER (LEN = 2), DIMENSION(0:105), PARAMETER :: CHEM_SY = (/ & ! + 'ES',' H','He','Li','Be',' B',' C',' N',' O', & ! + ' F','Ne','Na','Mg','Al','Si',' P',' S','Cl', & ! + 'Ar',' K','Ca','Sc','Ti',' V','Cr','Mn','Fe', & ! + 'Co','Ni','Cu','Zn','Ga','Ge','As','Se','Br', & ! + 'Kr','Rb','Sr',' Y','Zr','Nb','Mo','Tc','Ru', & ! + 'Rh','Pd','Ag','Cd','In','Sn','Sb','Te',' I', & ! + 'Xe','Cs','Ba','La','Ce','Pr','Nd','Pm','Sm', & ! + 'Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb','Lu', & ! + 'Hf','Ta',' W','Re','Os','Ir','Pt','Au','Hg', & ! + 'Tl','Pb','Bi','Po','At','Rn','Fr','Ra','Ac', & ! + 'Th','Pa',' U','Np','Pu','Am','Cm','Bk','Cf', & ! + 'Es','Fm','Md','No','Lr','Rf','Db' & ! + /) ! +! +! 2) Atomic mass --> g/mol +! + REAL (WP), DIMENSION(0:105), PARAMETER :: MASS_AT = (/ & ! + 0.00055E0_WP,1.0079E0_WP,4.0026E0_WP,6.941E0_WP,9.0122E0_WP,10.81E0_WP,& ! ES | H | He | Li | Be | B | + 12.011E0_WP, 14.0067E0_WP,15.9994E0_WP,18.998403E0_WP,20.179E0_WP , & ! C | N | O | F | Ne | + 22.98977E0_WP,24.305E0_WP,26.98154E0_WP,28.0855E0_WP,30.97376E0_WP, & ! Na | Mg | Al | Si | P | + 32.06E0_WP,35.453E0_WP,39.948E0_WP,39.0983E0_WP,40.08E0_WP, & ! S | Cl | Ar | K | Ca | + 44.9559E0_WP,47.88E0_WP,50.9415E0_WP,51.996E0_WP,54.9380E0_WP, & ! Sc | Ti | V | Cr | Mn | + 55.847E0_WP,58.9332E0_WP,58.69E0_WP,63.546E0_WP,65.38E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 69.72E0_WP,72.59E0_WP,74.9216E0_WP,78.96E0_WP,79.904E0_WP, & ! Ga | Ge | As | Se | Br | + 83.80E0_WP,85.4678E0_WP,87.62E0_WP,88.9059E0_WP,91.22E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 92.9064E0_WP,95.94E0_WP,98.E0_WP, 101.07E0_WP,102.9055E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 106.42E0_WP,107.8682E0_WP,112.41E0_WP,114.82E0_WP,118.69E0_WP, & ! Pd | Ag | Cd | In | Sn | + 121.75E0_WP,127.60E0_WP,126.9045E0_WP,131.29E0_WP,132.9054E0_WP, & ! Sb | Te | I | Xe | Cs | + 137.33E0_WP,138.9055E0_WP,140.12E0_WP,140.9077E0_WP,144.24E0_WP, & ! Ba | La | Ce | Pr | Nd | + 145.E0_WP,150.36E0_WP,151.96E0_WP,157.25E0_WP,158.9254E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 162.50E0_WP,164.9304E0_WP,167.26E0_WP,168.9342E0_WP,173.04E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 174.967E0_WP,178.49E0_WP,180.9479E0_WP,183.85E0_WP,186.207E0_WP, & ! Lu | Hf | Ta | W | Re | + 190.2E0_WP,192.22E0_WP,195.08E0_WP,196.9665E0_WP,200.59E0_WP, & ! Os | Ir | Pt | Au | Hg | + 204.383E0_WP,207.2E0_WP,208.9804E0_WP,209.E0_WP,210.E0_WP, & ! Tl | Pb | Bi | Po | At | + 222.E0_WP,223.E0_WP,226.0254E0_WP,227.0278E0_WP,232.0381E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 231.0359E0_WP,238.0289E0_WP,237.0482E0_WP,244.054E0_WP,243.061E0_WP, & ! Pa | U | Np | Pu | Am | + 247.070E0_WP,247.070E0_WP,251.080E0_WP,254.E0_WP,257.095E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 258.1E0_WP,259.101E0_WP,262.E0_WP,261.E0_WP,262.E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 3) Atomic density --> g/cm^3 +! + REAL (WP), DIMENSION(0:105), PARAMETER :: ATOM_DE = (/ & ! + 0.00005E0_WP,0.0899E0_WP,0.122E0_WP,0.535E0_WP,1.848E0_WP,2.46E0_WP,& ! ES | H | He | Li | Be | B | + 2.26E0_WP,1.251E0_WP,1.429E0_WP,1.696E0_WP,0.9E0_WP, & ! C | N | O | F | Ne | + 0.968E0_WP,1.738E0_WP,2.7E0_WP,2.33E0_WP,1.823E0_WP, & ! Na | Mg | Al | Si | P | + 1.96E0_WP,3.214E0_WP,1.784E0_WP,0.856E0_WP,1.55E0_WP, & ! S | Cl | Ar | K | Ca | + 2.985E0_WP,4.507E0_WP,6.11E0_WP,7.19E0_WP,7.47E0_WP, & ! Sc | Ti | V | Cr | Mn | + 7.874E0_WP,8.9E0_WP,8.9E0_WP,8.908E0_WP,7.14E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 5.904E0_WP,5.323E0_WP,5.727E0_WP,4.819E0_WP,3.12E0_WP, & ! Ga | Ge | As | Se | Br | + 3.75E0_WP,1.532E0_WP,2.63E0_WP,4.472E0_WP,6.511E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 8.57E0_WP,10.28E0_WP,11.5E0_WP,12.37E0_WP,12.45E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 12.023E0_WP,10.49E0_WP,8.65E0_WP,7.31E0_WP,7.31E0_WP, & ! Pd | Ag | Cd | In | Sn | + 6.697E0_WP,6.24E0_WP,4.94E0_WP,5.9E0_WP,1.879E0_WP, & ! Sb | Te | I | Xe | Cs | + 3.51E0_WP,6.146E0_WP,6.689E0_WP,6.64E0_WP,7.01E0_WP, & ! Ba | La | Ce | Pr | Nd | + 7.264E0_WP,7.353E0_WP,5.244E0_WP,7.901E0_WP,8.219E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 8.551E0_WP,8.795E0_WP,9.066E0_WP,9.32E0_WP,6.57E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 9.841E0_WP,13.31E0_WP,16.65E0_WP,19.25E0_WP,21.02E0_WP, & ! Lu | Hf | Ta | W | Re | + 22.59E0_WP,22.56E0_WP,21.45E0_WP,19.3E0_WP,13.534E0_WP, & ! Os | Ir | Pt | Au | Hg | + 11.85E0_WP,11.34E0_WP,9.78E0_WP,9.196E0_WP,0.0E0_WP, & ! Tl | Pb | Bi | Po | At | + 9.73E0_WP,0.0E0_WP,5.E0_WP,10.07E0_WP,11.724E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 15.37E0_WP,19.05E0_WP,20.45E0_WP,19.816E0_WP,13.67E0_WP, & ! Pa | U | Np | Pu | Am | + 13.51E0_WP,14.78E0_WP,15.1E0_WP,0.0E0_WP,0.0E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 0.0E0_WP,0.0E0_WP,0.0E0_WP,0.0E0_WP,0.0E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 4) Atomic radius --> Angstroem +! + REAL (WP), DIMENSION(0:105), PARAMETER :: ATOM_RD = (/ & ! + 0.000289E0_WP,0.53E0_WP,0.31E0_WP,1.67E0_WP,1.12E0_WP,0.87E0_WP, & ! ES | H | He | Li | Be | B | + 0.67E0_WP,0.56E0_WP,0.48E0_WP,0.42E0_WP,0.38E0_WP, & ! C | N | O | F | Ne | + 1.90E0_WP,1.45E0_WP,1.18E0_WP,1.11E0_WP,0.98E0_WP, & ! Na | Mg | Al | Si | P | + 0.88E0_WP,0.79E0_WP,0.71E0_WP,2.43E0_WP,1.94E0_WP, & ! S | Cl | Ar | K | Ca | + 1.84E0_WP,1.76E0_WP,1.71E0_WP,1.66E0_WP,1.61E0_WP, & ! Sc | Ti | V | Cr | Mn | + 1.56E0_WP,1.52E0_WP,1.49E0_WP,1.45E0_WP,1.42E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 1.36E0_WP,1.25E0_WP,1.14E0_WP,1.03E0_WP,0.94E0_WP, & ! Ga | Ge | As | Se | Br | + 0.88E0_WP,2.65E0_WP,2.19E0_WP,2.12E0_WP,2.06E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 1.98E0_WP,1.90E0_WP,1.83E0_WP,1.78E0_WP,1.73E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 1.69E0_WP,1.65E0_WP,1.61E0_WP,1.56E0_WP,1.45E0_WP, & ! Pd | Ag | Cd | In | Sn | + 1.33E0_WP,1.23E0_WP,1.15E0_WP,1.08E0_WP,2.98E0_WP, & ! Sb | Te | I | Xe | Cs | + 2.53E0_WP,1.95E0_WP,1.85E0_WP,2.47E0_WP,2.06E0_WP, & ! Ba | La | Ce | Pr | Nd | + 2.05E0_WP,2.38E0_WP,2.31E0_WP,2.33E0_WP,2.25E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 2.28E0_WP,1.75E0_WP,2.26E0_WP,2.22E0_WP,2.22E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 2.17E0_WP,2.08E0_WP,2.00E0_WP,1.93E0_WP,1.88E0_WP, & ! Lu | Hf | Ta | W | Re | + 1.85E0_WP,1.80E0_WP,1.77E0_WP,1.74E0_WP,1.71E0_WP, & ! Os | Ir | Pt | Au | Hg | + 1.56E0_WP,1.54E0_WP,1.43E0_WP,1.35E0_WP,1.38E0_WP, & ! Tl | Pb | Bi | Po | At | + 1.20E0_WP,3.48E0_WP,2.15E0_WP,1.95E0_WP,1.80E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 1.80E0_WP,1.75E0_WP,1.75E0_WP,1.75E0_WP,1.75E0_WP, & ! Pa | U | Np | Pu | Am | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,1.31E0_WP,1.26E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 5) Ionic radius --> Angstroem +! + REAL (WP), DIMENSION(0:105), PARAMETER :: IONI_RD = (/ & ! + 0.00084E0_WP,1.54E0_WP,0.00E0_WP,0.76E0_WP,0.34E0_WP,0.23E0_WP, & ! ES | H | He | Li | Be | B | + 2.60E0_WP,1.46E0_WP,1.40E0_WP,1.33E0_WP,1.12E0_WP, & ! C | N | O | F | Ne | + 1.02E0_WP,0.72E0_WP,0.54E0_WP,2.71E0_WP,2.12E0_WP, & ! Na | Mg | Al | Si | P | + 1.84E0_WP,1.81E0_WP,1.54E0_WP,1.38E0_WP,1.00E0_WP, & ! S | Cl | Ar | K | Ca | + 0.83E0_WP,0.80E0_WP,0.72E0_WP,0.84E0_WP,0.91E0_WP, & ! Sc | Ti | V | Cr | Mn | + 0.82E0_WP,0.82E0_WP,0.78E0_WP,0.96E0_WP,0.83E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 1.13E0_WP,0.90E0_WP,0.69E0_WP,0.69E0_WP,1.96E0_WP, & ! Ga | Ge | As | Se | Br | + 1.69E0_WP,1.52E0_WP,1.18E0_WP,1.06E0_WP,1.09E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 0.74E0_WP,0.92E0_WP,0.95E0_WP,0.77E0_WP,0.86E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 0.86E0_WP,1.13E0_WP,1.14E0_WP,1.32E0_WP,0.93E0_WP, & ! Pd | Ag | Cd | In | Sn | + 0.89E0_WP,2.11E0_WP,2.10E0_WP,1.90E0_WP,1.65E0_WP, & ! Sb | Te | I | Xe | Cs | + 1.43E0_WP,1.22E0_WP,1.07E0_WP,1.06E0_WP,1.04E0_WP, & ! Ba | La | Ce | Pr | Nd | + 1.06E0_WP,1.11E0_WP,1.12E0_WP,0.97E0_WP,0.93E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 0.91E0_WP,0.89E0_WP,0.89E0_WP,0.87E0_WP,1.13E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 0.85E0_WP,0.84E0_WP,0.72E0_WP,0.68E0_WP,0.72E0_WP, & ! Lu | Hf | Ta | W | Re | + 0.89E0_WP,0.89E0_WP,0.85E0_WP,1.37E0_WP,1.27E0_WP, & ! Os | Ir | Pt | Au | Hg | + 1.49E0_WP,1.32E0_WP,0.96E0_WP,0.65E0_WP,2.27E0_WP, & ! Tl | Pb | Bi | Po | At | + 0.00E0_WP,1.80E0_WP,1.52E0_WP,1.18E0_WP,1.01E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 1.13E0_WP,1.03E0_WP,1.10E0_WP,1.08E0_WP,1.07E0_WP, & ! Pa | U | Np | Pu | Am | + 1.19E0_WP,1.18E0_WP,1.17E0_WP,0.00E0_WP,0.00E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 6) Covalent radius --> Angstroem +! + REAL (WP), DIMENSION(0:105), PARAMETER :: COVA_RD = (/ & ! + 0.00017E0_WP,0.31E0_WP,0.28E0_WP,1.28E0_WP,0.96E0_WP,0.83E0_WP, & ! ES | H | He | Li | Be | B | + 0.76E0_WP,0.71E0_WP,0.66E0_WP,0.57E0_WP,0.58E0_WP, & ! C | N | O | F | Ne | + 1.66E0_WP,1.41E0_WP,1.21E0_WP,1.11E0_WP,1.07E0_WP, & ! Na | Mg | Al | Si | P | + 1.05E0_WP,1.02E0_WP,1.06E0_WP,2.03E0_WP,1.76E0_WP, & ! S | Cl | Ar | K | Ca | + 1.70E0_WP,1.60E0_WP,1.53E0_WP,1.39E0_WP,1.39E0_WP, & ! Sc | Ti | V | Cr | Mn | + 1.32E0_WP,1.26E0_WP,1.24E0_WP,1.32E0_WP,1.22E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 1.22E0_WP,1.20E0_WP,1.19E0_WP,1.20E0_WP,1.20E0_WP, & ! Ga | Ge | As | Se | Br | + 1.16E0_WP,2.10E0_WP,1.95E0_WP,1.90E0_WP,1.75E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 1.64E0_WP,1.54E0_WP,1.47E0_WP,1.46E0_WP,1.42E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 1.39E0_WP,1.45E0_WP,1.44E0_WP,1.42E0_WP,1.39E0_WP, & ! Pd | Ag | Cd | In | Sn | + 1.39E0_WP,1.38E0_WP,1.39E0_WP,1.40E0_WP,2.44E0_WP, & ! Sb | Te | I | Xe | Cs | + 2.15E0_WP,2.07E0_WP,2.04E0_WP,2.03E0_WP,2.01E0_WP, & ! Ba | La | Ce | Pr | Nd | + 1.99E0_WP,1.98E0_WP,1.98E0_WP,1.96E0_WP,1.94E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 1.92E0_WP,1.92E0_WP,1.89E0_WP,1.90E0_WP,1.87E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 1.87E0_WP,1.75E0_WP,1.70E0_WP,1.62E0_WP,1.51E0_WP, & ! Lu | Hf | Ta | W | Re | + 1.44E0_WP,1.41E0_WP,1.36E0_WP,1.36E0_WP,1.32E0_WP, & ! Os | Ir | Pt | Au | Hg | + 1.45E0_WP,1.46E0_WP,1.48E0_WP,1.40E0_WP,1.50E0_WP, & ! Tl | Pb | Bi | Po | At | + 1.50E0_WP,2.60E0_WP,2.12E0_WP,2.15E0_WP,2.06E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 2.00E0_WP,1.96E0_WP,1.90E0_WP,1.87E0_WP,1.80E0_WP, & ! Pa | U | Np | Pu | Am | + 1.69E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 7) Wigner-Seitz radius --> Angstroem +! + REAL (WP), DIMENSION(0:105), PARAMETER :: WISE_RD = (/ & ! + 0.00E0_WP,1.61E0_WP,0.00E0_WP,1.72E0_WP,0.99E0_WP,0.00E0_WP, & ! ES | H | He | Li | Be | B | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! C | N | O | F | Ne | + 2.08E0_WP,1.41E0_WP,1.10E0_WP,0.00E0_WP,0.00E0_WP, & ! Na | Mg | Al | Si | P | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,2.57E0_WP,1.73E0_WP, & ! S | Cl | Ar | K | Ca | + 1.25E0_WP,1.02E0_WP,0.94E0_WP,0.98E0_WP,1.13E0_WP, & ! Sc | Ti | V | Cr | Mn | + 1.12E0_WP,1.10E0_WP,0.95E0_WP,1.41E0_WP,1.22E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 1.16E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Ga | Ge | As | Se | Br | + 0.00E0_WP,2.75E0_WP,1.89E0_WP,1.38E0_WP,1.16E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 1.63E0_WP,0.85E0_WP,0.95E0_WP,0.93E0_WP,1.03E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 1.05E0_WP,1.60E0_WP,1.37E0_WP,1.27E0_WP,1.17E0_WP, & ! Pd | Ag | Cd | In | Sn | + 1.34E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,2.98E0_WP, & ! Sb | Te | I | Xe | Cs | + 1.96E0_WP,1.41E0_WP,1.40E0_WP,1.40E0_WP,1.40E0_WP, & ! Ba | La | Ce | Pr | Nd | + 0.00E0_WP,1.38E0_WP,1.79E0_WP,1.38E0_WP,1.36E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 1.36E0_WP,1.35E0_WP,1.34E0_WP,1.34E0_WP,1.70E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 1.32E0_WP,1.10E0_WP,0.95E0_WP,0.86E0_WP,0.84E0_WP, & ! Lu | Hf | Ta | W | Re | + 0.83E0_WP,0.94E0_WP,1.06E0_WP,1.59E0_WP,1.40E0_WP, & ! Os | Ir | Pt | Au | Hg | + 1.31E0_WP,1.22E0_WP,1.19E0_WP,0.00E0_WP,0.00E0_WP, & ! Tl | Pb | Bi | Po | At | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,1.44E0_WP,1.25E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 1.14E0_WP,1.07E0_WP,1.95E0_WP,1.06E0_WP,0.00E0_WP, & ! Pa | U | Np | Pu | Am | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 8) Debye temperature at 0 K --> Kelvin +! + REAL (WP), DIMENSION(0:105), PARAMETER :: DEBY_TE = (/ & ! + 0.00E0_WP, 122.E0_WP, 26.E0_WP, 344.E0_WP,1481.E0_WP,1480.E0_WP, & ! ES | H | He | Li | Be | B | + 2230.E0_WP, 68.E0_WP, 91.E0_WP, 0.00E0_WP, 75.E0_WP, & ! C | N | O | F | Ne | + 157.E0_WP, 403.E0_WP, 433.E0_WP, 645.E0_WP, 193.E0_WP, & ! Na | Mg | Al | Si | P | + 250.E0_WP, 115.E0_WP, 92.E0_WP, 91.E0_WP, 229.E0_WP, & ! S | Cl | Ar | K | Ca | + 346.E0_WP, 420.E0_WP, 399.E0_WP, 606.E0_WP, 409.E0_WP, & ! Sc | Ti | V | Cr | Mn | + 477.E0_WP, 460.E0_WP, 477.E0_WP, 347.E0_WP, 329.E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 325.E0_WP, 373.E0_WP, 282.E0_WP, 153.E0_WP, 0.00E0_WP, & ! Ga | Ge | As | Se | Br | + 72.E0_WP, 57.E0_WP, 147.E0_WP, 248.E0_WP, 290.E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 276.E0_WP, 423.E0_WP, 454.E0_WP, 555.E0_WP, 512.E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 271.E0_WP, 227.E0_WP, 210.E0_WP, 112.E0_WP, 199.E0_WP, & ! Pd | Ag | Cd | In | Sn | + 220.E0_WP, 152.E0_WP, 109.E0_WP, 64.E0_WP, 40.E0_WP, & ! Sb | Te | I | Xe | Cs | + 111.E0_WP, 150.E0_WP, 179.E0_WP, 152.E0_WP, 163.E0_WP, & ! Ba | La | Ce | Pr | Nd | + 158.E0_WP, 169.E0_WP, 118.E0_WP, 182.E0_WP, 176.E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 183.E0_WP, 190.E0_WP, 188.E0_WP, 200.E0_WP, 118.E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 183.E0_WP, 272.E0_WP, 246.E0_WP, 383.E0_WP, 416.E0_WP, & ! Lu | Hf | Ta | W | Re | + 467.E0_WP, 420.E0_WP, 237.E0_WP, 162.E0_WP, 72.E0_WP, & ! Os | Ir | Pt | Au | Hg | + 79.E0_WP, 105.E0_WP, 120.E0_WP, 81.E0_WP, 0.00E0_WP, & ! Tl | Pb | Bi | Po | At | + 0.00E0_WP, 39.E0_WP, 89.E0_WP, 124.E0_WP, 160.E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 185.E0_WP, 248.E0_WP, 259.E0_WP, 206.E0_WP, 121.E0_WP, & ! Pa | U | Np | Pu | Am | + 123.E0_WP, 0.00E0_WP, 0.00E0_WP, 0.00E0_WP, 0.00E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 0.00E0_WP, 0.00E0_WP, 0.00E0_WP, 0.00E0_WP, 0.00E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 9) Bulk modulus --> GPa +! + REAL (WP), DIMENSION(0:105), PARAMETER :: BULK_MD = (/ & ! + 0.00E0_WP ,0.00E0_WP ,0.00E0_WP ,11.0E0_WP ,130.E0_WP ,320.E0_WP , & ! ES | H | He | Li | Be | B | + 33.0E0_WP ,0.00E0_WP ,0.00E0_WP ,0.00E0_WP ,0.00E0_WP , & ! C | N | O | F | Ne | + 6.30E0_WP ,45.0E0_WP ,76.0E0_WP ,100.E0_WP ,11.0E0_WP , & ! Na | Mg | Al | Si | P | + 7.70E0_WP ,1.10E0_WP ,0.00E0_WP ,3.10E0_WP ,17.0E0_WP , & ! S | Cl | Ar | K | Ca | + 57.0E0_WP ,110.E0_WP ,160.E0_WP ,160.E0_WP ,120.E0_WP , & ! Sc | Ti | V | Cr | Mn | + 170.E0_WP ,180.E0_WP ,180.E0_WP ,140.E0_WP ,70.0E0_WP , & ! Fe | Co | Ni | Cu | Zn | + 0.00E0_WP ,0.00E0_WP ,22.0E0_WP ,8.30E0_WP ,1.90E0_WP , & ! Ga | Ge | As | Se | Br | + 0.00E0_WP ,2.50E0_WP ,0.00E0_WP ,41.0E0_WP ,0.00E0_WP , & ! Kr | Rb | Sr | Y | Zr | + 170.E0_WP ,230.E0_WP ,0.00E0_WP ,220.E0_WP ,380.E0_WP , & ! Nb | Mo | Tc | Ru | Rh | + 180.E0_WP ,100.E0_WP ,42.0E0_WP ,0.00E0_WP ,58.0E0_WP , & ! Pd | Ag | Cd | In | Sn | + 42.0E0_WP ,64.0E0_WP ,7.70E0_WP ,0.00E0_WP ,1.60E0_WP , & ! Sb | Te | I | Xe | Cs | + 9.40E0_WP ,28.0E0_WP ,22.0E0_WP ,29.0E0_WP ,32.0E0_WP , & ! Ba | La | Ce | Pr | Nd | + 33.0E0_WP ,38.0E0_WP ,8.30E0_WP ,38.0E0_WP ,38.7E0_WP , & ! Pm | Sm | Eu | Gd | Tb | + 41.0E0_WP ,40.0E0_WP ,44.0E0_WP ,45.0E0_WP ,31.0E0_WP , & ! Dy | Ho | Er | Tm | Yb | + 48.0E0_WP ,110.E0_WP ,200.E0_WP ,310.E0_WP ,370.E0_WP , & ! Lu | Hf | Ta | W | Re | + 0.00E0_WP ,320.E0_WP ,230.E0_WP ,220.E0_WP ,25.0E0_WP , & ! Os | Ir | Pt | Au | Hg | + 43.0E0_WP ,46.0E0_WP ,31.0E0_WP ,0.00E0_WP ,0.00E0_WP , & ! Tl | Pb | Bi | Po | At | + 0.00E0_WP ,0.00E0_WP ,0.00E0_WP ,0.00E0_WP ,90.0E0_WP , & ! Rn | Fr | Ra | Ac | Th | + 0.00E0_WP ,100.E0_WP ,0.00E0_WP ,0.00E0_WP ,0.00E0_WP , & ! Pa | U | Np | Pu | Am | + 0.00E0_WP ,0.00E0_WP ,0.00E0_WP ,0.00E0_WP ,0.00E0_WP , & ! Cm | Bk | Cf | Es | Fm | + 0.00E0_WP ,0.00E0_WP ,0.00E0_WP ,0.00E0_WP ,0.00E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 10) Shear modulus --> GPa +! + REAL (WP), DIMENSION(0:105), PARAMETER :: SHEA_MD = (/ & ! + 0.0E0_WP,0.00E0_WP,0.00E0_WP,4.20E0_WP,132.E0_WP,0.00E0_WP, & ! ES | H | He | Li | Be | B | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! C | N | O | F | Ne | + 3.30E0_WP,17.0E0_WP,26.0E0_WP,0.00E0_WP,0.00E0_WP, & ! Na | Mg | Al | Si | P | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,1.30E0_WP,7.40E0_WP, & ! S | Cl | Ar | K | Ca | + 29.0E0_WP,44.0E0_WP,47.0E0_WP,115.E0_WP,0.00E0_WP, & ! Sc | Ti | V | Cr | Mn | + 82.0E0_WP,76.0E0_WP,76.0E0_WP,48.0E0_WP,43.0E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,3.70E0_WP,0.00E0_WP, & ! Ga | Ge | As | Se | Br | + 0.00E0_WP,0.00E0_WP,6.10E0_WP,26.0E0_WP,33.0E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 38.0E0_WP,20.0E0_WP,0.00E0_WP,173.E0_WP,155.E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 44.0E0_WP,30.0E0_WP,19.0E0_WP,0.00E0_WP,18.0E0_WP, & ! Pd | Ag | Cd | In | Sn | + 20.0E0_WP,16.0E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Sb | Te | I | Xe | Cs | + 4.90E0_WP,14.0E0_WP,14.0E0_WP,15.0E0_WP,16.0E0_WP, & ! Ba | La | Ce | Pr | Nd | + 18.0E0_WP,20.0E0_WP,7.90E0_WP,22.0E0_WP,22.0E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 25.0E0_WP,26.0E0_WP,28.0E0_WP,31.0E0_WP,10.0E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 27.0E0_WP,30.0E0_WP,67.0E0_WP,161.E0_WP,178.E0_WP, & ! Lu | Hf | Ta | W | Re | + 222.E0_WP,210.E0_WP,61.0E0_WP,27.0E0_WP,0.00E0_WP, & ! Os | Ir | Pt | Au | Hg | + 2.80E0_WP,5.60E0_WP,12.0E0_WP,0.00E0_WP,0.00E0_WP, & ! Tl | Pb | Bi | Po | At | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,31.0E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 0.00E0_WP,111.E0_WP,0.00E0_WP,43.0E0_WP,0.00E0_WP, & ! Pa | U | Np | Pu | Am | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 11) Young modulus --> GPa +! + REAL (WP), DIMENSION(0:105), PARAMETER :: YOUN_MD = (/ & ! + 0.00E0_WP,0.00E0_WP,0.00E0_WP,4.90E0_WP,287.E0_WP,0.00E0_WP, & ! ES | H | He | Li | Be | B | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! C | N | O | F | Ne | + 10.0E0_WP,45.0E0_WP,70.0E0_WP,47.0E0_WP,0.00E0_WP, & ! Na | Mg | Al | Si | P | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,20.0E0_WP, & ! S | Cl | Ar | K | Ca | + 74.0E0_WP,116.E0_WP,128.E0_WP,279.E0_WP,198.E0_WP, & ! Sc | Ti | V | Cr | Mn | + 211.E0_WP,209.E0_WP,200.E0_WP,130.E0_WP,108.E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 0.00E0_WP,0.00E0_WP,8.00E0_WP,10.0E0_WP,0.00E0_WP, & ! Ga | Ge | As | Se | Br | + 0.00E0_WP,2.40E0_WP,0.00E0_WP,64.0E0_WP,67.0E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 105.E0_WP,329.E0_WP,0.00E0_WP,447.E0_WP,275.E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 121.E0_WP,85.0E0_WP,50.0E0_WP,11.0E0_WP,50.0E0_WP, & ! Pd | Ag | Cd | In | Sn | + 55.0E0_WP,43.0E0_WP,0.00E0_WP,0.00E0_WP,1.70E0_WP, & ! Sb | Te | I | Xe | Cs | + 13.0E0_WP,37.0E0_WP,34.0E0_WP,37.0E0_WP,41.0E0_WP, & ! Ba | La | Ce | Pr | Nd | + 46.0E0_WP,50.0E0_WP,18.0E0_WP,55.0E0_WP,56.0E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 61.0E0_WP,64.0E0_WP,70.0E0_WP,74.0E0_WP,24.0E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 67.0E0_WP,78.0E0_WP,186.E0_WP,411.E0_WP,463.E0_WP, & ! Lu | Hf | Ta | W | Re | + 0.00E0_WP,528.E0_WP,168.E0_WP,78.0E0_WP,0.00E0_WP, & ! Os | Ir | Pt | Au | Hg | + 8.00E0_WP,16.0E0_WP,32.0E0_WP,0.00E0_WP,0.00E0_WP, & ! Tl | Pb | Bi | Po | At | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,79.0E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 0.00E0_WP,208.E0_WP,0.00E0_WP,96.0E0_WP,0.00E0_WP, & ! Pa | U | Np | Pu | Am | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 12) Poisson ratio --> dimensionless +! + REAL (WP), DIMENSION(0:105), PARAMETER :: POIS_RT = (/ & ! + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.36E0_WP,0.03E0_WP,0.00E0_WP, & ! ES | H | He | Li | Be | B | + 0.20E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! C | N | O | F | Ne | + 0.00E0_WP,0.29E0_WP,0.35E0_WP,0.27E0_WP,0.00E0_WP, & ! Na | Mg | Al | Si | P | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! S | Cl | Ar | K | Ca | + 0.28E0_WP,0.32E0_WP,0.37E0_WP,0.21E0_WP,0.31E0_WP, & ! Sc | Ti | V | Cr | Mn | + 0.29E0_WP,0.31E0_WP,0.31E0_WP,0.34E0_WP,0.25E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 0.47E0_WP,0.28E0_WP,0.00E0_WP,0.33E0_WP,0.00E0_WP, & ! Ga | Ge | As | Se | Br | + 0.00E0_WP,0.00E0_WP,0.28E0_WP,0.24E0_WP,0.34E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 0.40E0_WP,0.31E0_WP,0.00E0_WP,0.30E0_WP,0.26E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 0.34E0_WP,0.37E0_WP,0.30E0_WP,0.26E0_WP,0.36E0_WP, & ! Pd | Ag | Cd | In | Sn | + 0.00E0_WP,0.33E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Sb | Te | I | Xe | Cs | + 0.00E0_WP,0.28E0_WP,0.24E0_WP,0.28E0_WP,0.28E0_WP, & ! Ba | La | Ce | Pr | Nd | + 0.28E0_WP,0.27E0_WP,0.15E0_WP,0.00E0_WP,0.26E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 0.25E0_WP,0.23E0_WP,0.24E0_WP,0.21E0_WP,0.21E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 0.26E0_WP,0.37E0_WP,0.34E0_WP,0.28E0_WP,0.30E0_WP, & ! Lu | Hf | Ta | W | Re | + 0.25E0_WP,0.26E0_WP,0.38E0_WP,0.44E0_WP,0.00E0_WP, & ! Os | Ir | Pt | Au | Hg | + 0.45E0_WP,0.44E0_WP,0.33E0_WP,0.00E0_WP,0.00E0_WP, & ! Tl | Pb | Bi | Po | At | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.27E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 0.00E0_WP,0.23E0_WP,0.00E0_WP,0.21E0_WP,0.00E0_WP, & ! Pa | U | Np | Pu | Am | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 13) Work function --> eV +! + REAL (WP), DIMENSION(0:105), PARAMETER :: WORK_FC = (/ & ! + 0.00E0_WP,0.00E0_WP,0.00E0_WP,2.93E0_WP,4.98E0_WP,4.45E0_WP, & ! ES | H | He | Li | Be | B | + 5.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! C | N | O | F | Ne | + 2.36E0_WP,3.66E0_WP,4.17E0_WP,4.79E0_WP,0.00E0_WP, & ! Na | Mg | Al | Si | P | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,2.29E0_WP,2.87E0_WP, & ! S | Cl | Ar | K | Ca | + 3.50E0_WP,4.33E0_WP,4.20E0_WP,4.50E0_WP,4.10E0_WP, & ! Sc | Ti | V | Cr | Mn | + 4.74E0_WP,5.00E0_WP,5.20E0_WP,4.76E0_WP,4.25E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 4.32E0_WP,5.00E0_WP,3.75E0_WP,5.90E0_WP,0.00E0_WP, & ! Ga | Ge | As | Se | Br | + 0.00E0_WP,2.26E0_WP,2.59E0_WP,3.10E0_WP,4.05E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 4.33E0_WP,4.57E0_WP,0.00E0_WP,4.71E0_WP,4.98E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 5.41E0_WP,4.63E0_WP,4.08E0_WP,4.09E0_WP,4.42E0_WP, & ! Pd | Ag | Cd | In | Sn | + 4.63E0_WP,4.95E0_WP,0.00E0_WP,0.00E0_WP,1.95E0_WP, & ! Sb | Te | I | Xe | Cs | + 2.52E0_WP,3.50E0_WP,2.90E0_WP,0.00E0_WP,3.20E0_WP, & ! Ba | La | Ce | Pr | Nd | + 0.00E0_WP,2.70E0_WP,2.50E0_WP,2.90E0_WP,3.00E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 3.30E0_WP,3.90E0_WP,4.30E0_WP,4.61E0_WP,4.72E0_WP, & ! Lu | Hf | Ta | W | Re | + 5.93E0_WP,5.46E0_WP,5.55E0_WP,5.38E0_WP,4.47E0_WP, & ! Os | Ir | Pt | Au | Hg | + 3.84E0_WP,4.25E0_WP,4.34E0_WP,5.00E0_WP,0.00E0_WP, & ! Tl | Pb | Bi | Po | At | + 0.00E0_WP,2.10E0_WP,2.80E0_WP,3.20E0_WP,3.40E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 3.70E0_WP,3.73E0_WP,3.90E0_WP,3.60E0_WP,3.70E0_WP, & ! Pa | U | Np | Pu | Am | + 3.90E0_WP,3.80E0_WP,4.00E0_WP,3.30E0_WP,0.00E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 14) Valence --> dimensionless +! + REAL (WP), DIMENSION(0:105), PARAMETER :: VALE_IN = (/ & ! + 0.00E0_WP,1.00E0_WP,0.00E0_WP,1.00E0_WP,2.00E0_WP,3.00E0_WP, & ! ES | H | He | Li | Be | B | + 4.00E0_WP,5.00E0_WP,2.00E0_WP,1.00E0_WP,0.00E0_WP, & ! C | N | O | F | Ne | + 1.00E0_WP,2.00E0_WP,3.00E0_WP,4.00E0_WP,5.00E0_WP, & ! Na | Mg | Al | Si | P | + 6.00E0_WP,7.00E0_WP,2.00E0_WP,1.00E0_WP,2.00E0_WP, & ! S | Cl | Ar | K | Ca | + 3.00E0_WP,4.00E0_WP,5.00E0_WP,6.00E0_WP,7.00E0_WP, & ! Sc | Ti | V | Cr | Mn | + 6.00E0_WP,5.00E0_WP,4.00E0_WP,4.00E0_WP,2.00E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 3.00E0_WP,4.00E0_WP,5.00E0_WP,6.00E0_WP,7.00E0_WP, & ! Ga | Ge | As | Se | Br | + 2.00E0_WP,1.00E0_WP,2.00E0_WP,3.00E0_WP,4.00E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 5.00E0_WP,6.00E0_WP,7.00E0_WP,8.00E0_WP,6.00E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 4.00E0_WP,4.00E0_WP,2.00E0_WP,3.00E0_WP,4.00E0_WP, & ! Pd | Ag | Cd | In | Sn | + 5.00E0_WP,6.00E0_WP,7.00E0_WP,8.00E0_WP,1.00E0_WP, & ! Sb | Te | I | Xe | Cs | + 2.00E0_WP,3.00E0_WP,4.00E0_WP,4.00E0_WP,3.00E0_WP, & ! Ba | La | Ce | Pr | Nd | + 3.00E0_WP,3.00E0_WP,3.00E0_WP,3.00E0_WP,4.00E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 3.00E0_WP,3.00E0_WP,3.00E0_WP,3.00E0_WP,3.00E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 3.00E0_WP,4.00E0_WP,5.00E0_WP,6.00E0_WP,7.00E0_WP, & ! Lu | Hf | Ta | W | Re | + 8.00E0_WP,8.00E0_WP,6.00E0_WP,5.00E0_WP,4.00E0_WP, & ! Os | Ir | Pt | Au | Hg | + 3.00E0_WP,4.00E0_WP,5.00E0_WP,6.00E0_WP,7.00E0_WP, & ! Tl | Pb | Bi | Po | At | + 8.00E0_WP,1.00E0_WP,2.00E0_WP,3.00E0_WP,4.00E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 5.00E0_WP,6.00E0_WP,7.00E0_WP,8.00E0_WP,6.00E0_WP, & ! Pa | U | Np | Pu | Am | + 4.00E0_WP,4.00E0_WP,4.00E0_WP,3.00E0_WP,3.00E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 3.00E0_WP,3.00E0_WP,3.00E0_WP,0.00E0_WP,0.00E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 15) Noninteger bonding valence --> dimensionless +! + REAL (WP), DIMENSION(0:105), PARAMETER :: VALE_NI = (/ & ! + 0.00E0_WP,0.00E0_WP,0.00E0_WP,1.09E0_WP,1.99E0_WP,0.00E0_WP, & ! ES | H | He | Li | Be | B | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! C | N | O | F | Ne | + 1.11E0_WP,2.08E0_WP,2.76E0_WP,0.00E0_WP,0.00E0_WP, & ! Na | Mg | Al | Si | P | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,1.21E0_WP,2.22E0_WP, & ! S | Cl | Ar | K | Ca | + 2.85E0_WP,3.20E0_WP,3.45E0_WP,3.53E0_WP,3.41E0_WP, & ! Sc | Ti | V | Cr | Mn | + 3.32E0_WP,3.09E0_WP,2.83E0_WP,2.57E0_WP,2.40E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 2.43E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Ga | Ge | As | Se | Br | + 0.00E0_WP,1.24E0_WP,2.32E0_WP,3.21E0_WP,3.15E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 4.14E0_WP,4.42E0_WP,4.24E0_WP,4.05E0_WP,3.67E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 3.15E0_WP,2.70E0_WP,2.48E0_WP,2.51E0_WP,0.00E0_WP, & ! Pd | Ag | Cd | In | Sn | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,1.28E0_WP, & ! Sb | Te | I | Xe | Cs | + 2.58E0_WP,3.50E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Ba | La | Ce | Pr | Nd | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 0.00E0_WP,3.97E0_WP,4.51E0_WP,4.29E0_WP,4.79E0_WP, & ! Lu | Hf | Ta | W | Re | + 4.72E0_WP,4.36E0_WP,3.90E0_WP,3.26E0_WP,2.52E0_WP, & ! Os | Ir | Pt | Au | Hg | + 2.38E0_WP,3.50E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Tl | Pb | Bi | Po | At | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Pa | U | Np | Pu | Am | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 16) -log_10 (electric resisitivity) --> m Ohm +! + REAL (WP), DIMENSION(0:105), PARAMETER :: ELEC_RE = (/ & ! + 0.00E0_WP,0.00E0_WP,0.00E0_WP,7.02E0_WP,7.39E0_WP,-4.00E0_WP, & ! ES | H | He | Li | Be | B | + 5.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! C | N | O | F | Ne | + 7.33E0_WP,7.36E0_WP,7.58E0_WP,3.00E0_WP,7.00E0_WP, & ! Na | Mg | Al | Si | P | + -15.00E0_WP,-2.00E0_WP,0.00E0_WP,7.15E0_WP,7.47E0_WP, & ! S | Cl | Ar | K | Ca | + 6.26E0_WP,6.39E0_WP,6.69E0_WP,6.89E0_WP,5.79E0_WP, & ! Sc | Ti | V | Cr | Mn | + 7.01E0_WP,7.22E0_WP,7.15E0_WP,7.77E0_WP,7.23E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 6.85E0_WP,3.30E0_WP,6.52E0_WP,0.00E0_WP,-10.00E0_WP, & ! Ga | Ge | As | Se | Br | + 0.00E0_WP,6.92E0_WP,6.89E0_WP,6.24E0_WP,6.38E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 6.82E0_WP,7.30E0_WP,6.69E0_WP,7.15E0_WP,7.37E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 7.00E0_WP,7.79E0_WP,7.15E0_WP,7.09E0_WP,6.96E0_WP, & ! Pd | Ag | Cd | In | Sn | + 6.39E0_WP,4.00E0_WP,-7.00E0_WP,0.00E0_WP,6.69E0_WP, & ! Sb | Te | I | Xe | Cs | + 6.46E0_WP,6.21E0_WP,6.12E0_WP,6.15E0_WP,6.19E0_WP, & ! Ba | La | Ce | Pr | Nd | + 6.12E0_WP,6.03E0_WP,6.04E0_WP,5.89E0_WP,5.92E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 6.04E0_WP,6.03E0_WP,6.06E0_WP,6.15E0_WP,6.55E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 6.24E0_WP,6.52E0_WP,6.88E0_WP,7.30E0_WP,6.74E0_WP, & ! Lu | Hf | Ta | W | Re | + 7.09E0_WP,7.33E0_WP,6.96E0_WP,7.66E0_WP,6.02E0_WP, & ! Os | Ir | Pt | Au | Hg | + 6.82E0_WP,6.68E0_WP,5.89E0_WP,6.37E0_WP,0.00E0_WP, & ! Tl | Pb | Bi | Po | At | + 0.00E0_WP,0.00E0_WP,6.00E0_WP,0.00E0_WP,6.77E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 6.74E0_WP,6.55E0_WP,5.92E0_WP,5.82E0_WP,0.00E0_WP, & ! Pa | U | Np | Pu | Am | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP,0.00E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 17) lattice parameter a --> Angstroem +! + REAL (WP), DIMENSION(0:105), PARAMETER :: ALAT_PA = (/ & ! + 00.0000E0_WP, 4.7000E0_WP, 4.2420E0_WP, 3.5100E0_WP, 2.2858E0_WP, 5.0600E0_WP,& ! ES | H | He | Li | Be | B | + 2.4640E0_WP, 3.8610E0_WP, 5.4030E0_WP, 5.5000E0_WP, 4.4290E0_WP, & ! C | N | O | F | Ne | + 4.2906E0_WP, 3.2094E0_WP, 4.0495E0_WP, 5.4309E0_WP,11.4500E0_WP, & ! Na | Mg | Al | Si | P | + 10.4370E0_WP, 6.2235E0_WP, 5.2560E0_WP, 5.3280E0_WP, 5.5884E0_WP, & ! S | Cl | Ar | K | Ca | + 3.3090E0_WP, 2.9508E0_WP, 3.0300E0_WP, 2.9100E0_WP, 8.9125E0_WP, & ! Sc | Ti | V | Cr | Mn | + 2.8665E0_WP, 2.5071E0_WP, 3.5240E0_WP, 3.6149E0_WP, 2.6649E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 4.5197E0_WP, 5.6575E0_WP, 3.7598E0_WP, 9.0540E0_WP, 6.7265E0_WP, & ! Ga | Ge | As | Se | Br | + 5.7060E0_WP, 5.5850E0_WP, 6.0849E0_WP, 3.6474E0_WP, 3.2320E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 3.3004E0_WP, 3.1470E0_WP, 2.7350E0_WP, 2.7059E0_WP, 3.8034E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 3.8907E0_WP, 4.0853E0_WP, 2.9794E0_WP, 3.2523E0_WP, 5.8318E0_WP, & ! Pd | Ag | Cd | In | Sn | + 4.3070E0_WP, 4.4572E0_WP, 7.1802E0_WP, 6.2023E0_WP, 6.1410E0_WP, & ! Sb | Te | I | Xe | Cs | + 5.0280E0_WP, 3.7720E0_WP, 6.1410E0_WP, 3.6725E0_WP, 3.6580E0_WP, & ! Ba | La | Ce | Pr | Nd | + 00.0000E0_WP, 3.6210E0_WP, 4.5810E0_WP, 3.6360E0_WP, 3.6010E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 3.5930E0_WP, 3.5773E0_WP, 3.5588E0_WP, 3.5375E0_WP, 5.4847E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 3.5031E0_WP, 3.1964E0_WP, 3.3013E0_WP, 3.1652E0_WP, 2.7610E0_WP, & ! Lu | Hf | Ta | W | Re | + 2.7344E0_WP, 3.8390E0_WP, 3.9242E0_WP, 4.0782E0_WP, 3.0050E0_WP, & ! Os | Ir | Pt | Au | Hg | + 3.4566E0_WP, 4.9508E0_WP, 6.6740E0_WP, 3.3590E0_WP,00.0000E0_WP, & ! Tl | Pb | Bi | Po | At | + 00.0000E0_WP,00.0000E0_WP, 5.1480E0_WP, 5.6700E0_WP, 5.0842E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 3.9250E0_WP, 2.8537E0_WP, 6.6630E0_WP, 6.1830E0_WP, 3.4681E0_WP, & ! Pa | U | Np | Pu | Am | + 3.4960E0_WP, 3.4160E0_WP, 3.3800E0_WP,00.0000E0_WP,00.0000E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 00.0000E0_WP,00.0000E0_WP,00.0000E0_WP,00.0000E0_WP,00.0000E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 18) lattice parameter B --> Angstroem +! + REAL (WP), DIMENSION(0:105), PARAMETER :: BLAT_PA = (/ & ! + 00.0000E0_WP, 4.7000E0_WP, 4.2420E0_WP, 3.5100E0_WP, 2.2858E0_WP, 5.0600E0_WP,& ! ES | H | He | Li | Be | B | + 2.4640E0_WP, 3.8610E0_WP, 3.4290E0_WP, 3.2800E0_WP, 4.4290E0_WP, & ! C | N | O | F | Ne | + 4.2906E0_WP, 3.2094E0_WP, 4.0495E0_WP, 5.4309E0_WP, 5.5030E0_WP, & ! Na | Mg | Al | Si | P | + 12.8450E0_WP, 4.4561E0_WP, 5.2560E0_WP, 5.3280E0_WP, 5.5884E0_WP, & ! S | Cl | Ar | K | Ca | + 3.3090E0_WP, 2.9508E0_WP, 3.0300E0_WP, 2.9100E0_WP, 8.9125E0_WP, & ! Sc | Ti | V | Cr | Mn | + 2.8665E0_WP, 2.5071E0_WP, 3.5240E0_WP, 3.6149E0_WP, 2.6649E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 7.6633E0_WP, 5.6575E0_WP, 3.7598E0_WP, 9.0830E0_WP, 4.6451E0_WP, & ! Ga | Ge | As | Se | Br | + 5.7060E0_WP, 5.5850E0_WP, 6.0849E0_WP, 3.6474E0_WP, 3.2320E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 3.3004E0_WP, 3.1470E0_WP, 2.7350E0_WP, 2.7059E0_WP, 3.8034E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 3.8907E0_WP, 4.0853E0_WP, 2.9794E0_WP, 3.2523E0_WP, 5.8318E0_WP, & ! Pd | Ag | Cd | In | Sn | + 4.3070E0_WP, 4.4572E0_WP, 4.7102E0_WP, 6.2023E0_WP, 6.1410E0_WP, & ! Sb | Te | I | Xe | Cs | + 5.0280E0_WP, 3.7720E0_WP, 6.1410E0_WP, 3.6725E0_WP, 3.6580E0_WP, & ! Ba | La | Ce | Pr | Nd | + 00.0000E0_WP, 3.6210E0_WP, 4.5810E0_WP, 3.6360E0_WP, 3.6010E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 3.5930E0_WP, 3.5773E0_WP, 3.5588E0_WP, 3.5375E0_WP, 5.4847E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 3.5031E0_WP, 3.1964E0_WP, 3.3013E0_WP, 3.1652E0_WP, 2.7610E0_WP, & ! Lu | Hf | Ta | W | Re | + 2.7344E0_WP, 3.8390E0_WP, 3.9242E0_WP, 4.0782E0_WP, 3.0050E0_WP, & ! Os | Ir | Pt | Au | Hg | + 3.4566E0_WP, 4.9508E0_WP, 6.1170E0_WP, 3.3590E0_WP,00.0000E0_WP, & ! Tl | Pb | Bi | Po | At | + 00.0000E0_WP,00.0000E0_WP, 5.1480E0_WP, 5.6700E0_WP, 5.0842E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 3.9250E0_WP, 5.8695E0_WP, 4.7230E0_WP, 4.8220E0_WP, 3.4681E0_WP, & ! Pa | U | Np | Pu | Am | + 3.4960E0_WP, 3.4160E0_WP, 3.3800E0_WP,00.0000E0_WP,00.0000E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 00.0000E0_WP,00.0000E0_WP,00.0000E0_WP,00.0000E0_WP,00.0000E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 19) lattice parameter C --> Angstroem +! + REAL (WP), DIMENSION(0:105), PARAMETER :: CLAT_PA = (/ & ! + 00.0000E0_WP, 3.4000E0_WP, 4.2420E0_WP, 3.5100E0_WP, 3.5843E0_WP, 5.0600E0_WP,& ! ES | H | He | Li | Be | B | + 6.7110E0_WP, 6.2650E0_WP, 5.0860E0_WP, 7.2800E0_WP, 4.4290E0_WP, & ! C | N | O | F | Ne | + 4.2906E0_WP, 5.2108E0_WP, 4.0495E0_WP, 5.4309E0_WP,11.2610E0_WP, & ! Na | Mg | Al | Si | P | + 24.3690E0_WP, 8.1785E0_WP, 5.2560E0_WP, 5.3280E0_WP, 5.5884E0_WP, & ! S | Cl | Ar | K | Ca | + 5.2733E0_WP, 4.6855E0_WP, 3.0300E0_WP, 2.9100E0_WP, 8.9125E0_WP, & ! Sc | Ti | V | Cr | Mn | + 2.8665E0_WP, 4.0695E0_WP, 3.5240E0_WP, 3.6149E0_WP, 4.9468E0_WP, & ! Fe | Co | Ni | Cu | Zn | + 4.5260E0_WP, 5.6575E0_WP,10.5475E0_WP,11.6010E0_WP, 8.7023E0_WP, & ! Ga | Ge | As | Se | Br | + 5.7060E0_WP, 5.5850E0_WP, 6.0849E0_WP, 5.7306E0_WP, 5.1470E0_WP, & ! Kr | Rb | Sr | Y | Zr | + 3.3004E0_WP, 3.1470E0_WP, 4.3880E0_WP, 4.2815E0_WP, 3.8034E0_WP, & ! Nb | Mo | Tc | Ru | Rh | + 3.8907E0_WP, 4.0853E0_WP, 5.6186E0_WP, 4.9461E0_WP, 3.1819E0_WP, & ! Pd | Ag | Cd | In | Sn | + 11.2730E0_WP, 5.9290E0_WP, 9.8103E0_WP, 6.2023E0_WP, 6.1410E0_WP, & ! Sb | Te | I | Xe | Cs | + 5.0280E0_WP,12.1440E0_WP, 6.1410E0_WP,11.8354E0_WP,11.7990E0_WP, & ! Ba | La | Ce | Pr | Nd | + 00.0000E0_WP, 2.6250E0_WP, 4.5810E0_WP, 5.7826E0_WP, 5.6936E0_WP, & ! Pm | Sm | Eu | Gd | Tb | + 5.6537E0_WP, 5.6158E0_WP, 5.5874E0_WP, 5.5546E0_WP, 5.4847E0_WP, & ! Dy | Ho | Er | Tm | Yb | + 5.5509E0_WP, 5.0511E0_WP, 3.3013E0_WP, 3.1652E0_WP, 4.4560E0_WP, & ! Lu | Hf | Ta | W | Re | + 4.3173E0_WP, 3.8390E0_WP, 3.9242E0_WP, 4.0782E0_WP, 3.0050E0_WP, & ! Os | Ir | Pt | Au | Hg | + 5.5248E0_WP, 4.9508E0_WP, 3.3040E0_WP, 3.3590E0_WP,00.0000E0_WP, & ! Tl | Pb | Bi | Po | At | + 00.0000E0_WP,00.0000E0_WP, 5.1480E0_WP, 5.6700E0_WP, 5.0842E0_WP, & ! Rn | Fr | Ra | Ac | Th | + 3.2380E0_WP, 4.9548E0_WP, 4.8870E0_WP,10.9630E0_WP,11.2410E0_WP, & ! Pa | U | Np | Pu | Am | + 11.3310E0_WP,11.0690E0_WP,11.0250E0_WP,00.0000E0_WP,00.0000E0_WP, & ! Cm | Bk | Cf | Es | Fm | + 00.0000E0_WP,00.0000E0_WP,00.0000E0_WP,00.0000E0_WP,00.0000E0_WP & ! Md | No | Lr | Rf | Db | + /) ! +! +! 20) Crystal structure +! +! CUB : simple cubic BCC : body-centered cubic +! FCC : face-centered cubic HEX : simple hexagonal +! TRG : simple trigonal BCM : based-centered monoclinic +! TEP : tetrahedral packing TRC : simple triclinic +! FCO : face-centered orthorombic BOR : base orthorombic +! MON : simple monoclinic CTE : centered tetragonal +! ORT : simple orthorombic +! +! + CHARACTER (LEN = 3), DIMENSION(0:105), PARAMETER :: CRYS_ST = (/ & ! + ' ','HEX','FCC','BCC','HEX','TRG', & ! ES | H | He | Li | Be | B | + 'HEX','HEX','BCM','BCM','FCC', & ! C | N | O | F | Ne | + 'BCC','HEX','FCC','TEP','TRC', & ! Na | Mg | Al | Si | P | + 'FCO','BOR','FCC','BCC','FCC', & ! S | Cl | Ar | K | Ca | + 'HEX','HEX','BCC','BCC','BCC', & ! Sc | Ti | V | Cr | Mn | + 'BCC','HEX','FCC','FCC','HEX', & ! Fe | Co | Ni | Cu | Zn | + 'BOR','FCC','TRG','MON','BOR', & ! Ga | Ge | As | Se | Br | + 'FCC','BCC','FCC','HEX','HEX', & ! Kr | Rb | Sr | Y | Zr | + 'BCC','BCC','HEX','HEX','FCC', & ! Nb | Mo | Tc | Ru | Rh | + 'FCC','FCC','HEX','CTE','CTE', & ! Pd | Ag | Cd | In | Sn | + 'TRG','TRG','BOR','FCC','BCC', & ! Sb | Te | I | Xe | Cs | + 'BCC','HEX','HEX','HEX','HEX', & ! Ba | La | Ce | Pr | Nd | + ' ','TRG','BCC','HEX','HEX', & ! Pm | Sm | Eu | Gd | Tb | + 'HEX','HEX','HEX','HEX','FCC', & ! Dy | Ho | Er | Tm | Yb | + 'HEX','HEX','BCC','BCC','HEX', & ! Lu | Hf | Ta | W | Re | + 'HEX','FCC','FCC','FCC','TRG', & ! Os | Ir | Pt | Au | Hg | + 'HEX','FCC','BCM','CUB',' ', & ! Tl | Pb | Bi | Po | At | + ' ',' ','BCC','FCC','FCC', & ! Rn | Fr | Ra | Ac | Th | + 'CTE','BOR','ORT','MON','HEX', & ! Pa | U | Np | Pu | Am | + 'HEX','HEX','HEX',' ',' ', & ! Cm | Bk | Cf | Es | Fm | + ' ',' ',' ',' ',' ' & ! Md | No | Lr | Rf | Db | + /) ! +! +! 21) Magnetic type +! +! +! DIA : diamagnetic PAR : paramagnetic +! FER : ferromagnetic AFM : antiferromagnetic +! +! + CHARACTER (LEN = 3), DIMENSION(0:105), PARAMETER :: MAGN_TY = (/ & ! + ' ','DIA','DIA','PAR','DIA','DIA', & ! ES | H | He | Li | Be | B | + 'DIA','DIA','PAR',' ','DIA', & ! C | N | O | F | Ne | + 'PAR','PAR','PAR','DIA','DIA', & ! Na | Mg | Al | Si | P | + 'DIA','DIA','DIA','PAR','PAR', & ! S | Cl | Ar | K | Ca | + 'PAR','PAR','PAR','AFM','PAR', & ! Sc | Ti | V | Cr | Mn | + 'FER','FER','FER','DIA','DIA', & ! Fe | Co | Ni | Cu | Zn | + 'DIA','DIA','DIA','DIA','DIA', & ! Ga | Ge | As | Se | Br | + 'DIA','PAR','PAR','PAR','PAR', & ! Kr | Rb | Sr | Y | Zr | + 'PAR','PAR','PAR','PAR','PAR', & ! Nb | Mo | Tc | Ru | Rh | + 'PAR','DIA','DIA','DIA','DIA', & ! Pd | Ag | Cd | In | Sn | + 'DIA','DIA','DIA','DIA','PAR', & ! Sb | Te | I | Xe | Cs | + 'PAR','PAR','PAR','PAR','PAR', & ! Ba | La | Ce | Pr | Nd | + ' ','PAR','PAR','FER','PAR', & ! Pm | Sm | Eu | Gd | Tb | + 'PAR','PAR','PAR','PAR','PAR', & ! Dy | Ho | Er | Tm | Yb | + 'PAR','PAR','PAR','PAR','PAR', & ! Lu | Hf | Ta | W | Re | + 'PAR','PAR','PAR','DIA','DIA', & ! Os | Ir | Pt | Au | Hg | + 'DIA','DIA','DIA',' ',' ', & ! Tl | Pb | Bi | Po | At | + ' ',' ',' ',' ','PAR', & ! Rn | Fr | Ra | Ac | Th | + 'PAR','PAR',' ','PAR','PAR', & ! Pa | U | Np | Pu | Am | + ' ',' ',' ',' ',' ', & ! Cm | Bk | Cf | Es | Fm | + ' ',' ',' ',' ',' ' & ! Md | No | Lr | Rf | Db | + /) ! +! +END MODULE ATOMIC_PROPERTIES diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/derivation.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/derivation.f90 new file mode 100644 index 0000000..cd7f9de --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/derivation.f90 @@ -0,0 +1,855 @@ +! +!======================================================================= +! +MODULE DERIVATION +! +! This module containes subroutines to perform +! calculations of the first derivative of a function +! +! +! Modules used: ACCURACY_REAL +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE DERIV_1(F,N,IDERIV,H,F1) +! +! This subroutine is the driver program for the derivation of +! f(x) by x +! +! Input parameters: +! +! F : y coordinates of the input file +! N : dimension of the array F +! IDERIV : number of point used in the derivation +! H : x step of the input file +! +! +! Output parameters: +! +! F1 : first derivative of F +! +! +! Author : D. Sébilleau +! Last version : 10 Jun 2021 +! +! +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: N,IDERIV +! + REAL (WP), INTENT(IN) :: F(N) + REAL (WP), INTENT(IN) :: H + REAL (WP), INTENT(OUT) :: F1(N) +! + IF(IDERIV == 2) THEN ! + CALL DERIV_2P(F,N,F1,H) ! + ELSE IF(IDERIV == 3) THEN ! + CALL DERIV_3P(F,N,F1,H) ! + ELSE IF(IDERIV == 4) THEN ! + CALL DERIV_4P(F,N,F1,H) ! + ELSE IF(IDERIV == 5) THEN ! + CALL DERIV_5P(F,N,F1,H) ! + ELSE IF(IDERIV == 6) THEN ! + CALL DERIV_6P(F,N,F1,H) ! + END IF ! +! + END SUBROUTINE DERIV_1 +! +!======================================================================= +! + SUBROUTINE DERIV_2P(F,N,F1,H) +! +! This subroutine computes the first derivative F1 of function F, +! using a 2-point formula. +! +! The general formula used is a central difference formula, +! except for the first two points (forward difference formula) +! and for the last two points (backward difference formula). +! +! Input parameters: +! +! F : y coordinates of the input file +! N : dimension of the arrays +! H : step of the input file +! +! +! Output parameters: +! +! F1 : order 1 derivative of F +! +! +! +! References : A. K. Singh and G. R. Thorpe, +! RGMIA Res. Rep. Coll., 2(6), Article 7, 1999. +! +! T. F. Guidry, +! http://www.trentfguidry.net/post/2010/09/04/Numerical-differentiation-formulas.aspx +! +! +! Author : D. Sébilleau +! Last version : 10 Jun 2021 +! +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: N +! + INTEGER :: N_POINTS,JP +! + REAL (WP), INTENT(IN) :: F(N) + REAL (WP), INTENT(IN) :: H + REAL (WP), INTENT(OUT) :: F1(N) +! + REAL (WP) :: STEP1 + REAL (WP) :: A(10,0:10),B(10,-10:0),C(10,-10:10) +! + STEP1 = H ! +! + N_POINTS = 2 ! +! + CALL COEF_DERIV(N_POINTS,A,B,C) ! +! +! First derivative for the extremal point 1 +! + F1(1) = (A(1,0) * F(1) + A(1,1) * F(2)) / STEP1 ! +! +! First derivative for the other points +! + DO JP = 2, N ! + F1(JP) = ( B(1,0) * F(JP) + B(1,-1) * F(JP-1) ) / STEP1 ! + END DO ! +! + END SUBROUTINE DERIV_2P +! +!======================================================================= +! + SUBROUTINE DERIV_3P(F,N,F1,H) +! +! This subroutine computes the first derivative F1 of function F, +! using a 3-point formula. +! +! The general formula used is a central difference formula, +! except for the first two points (forward difference formula) +! and for the last two points (backward difference formula). +! +! Input parameters: +! +! F : y coordinates of the input file +! N : dimension of the arrays +! H : step of the input file +! +! +! Output parameters: +! +! F1 : order 1 derivative of F +! +! +! +! References : A. K. Singh and G. R. Thorpe, +! RGMIA Res. Rep. Coll., 2(6), Article 7, 1999. +! +! T. F. Guidry, +! http://www.trentfguidry.net/post/2010/09/04/Numerical-differentiation-formulas.aspx +! +! +! Author : D. Sébilleau +! Last version : 10 Jun 2021 +! + USE REAL_NUMBERS, ONLY : TWO +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: N +! + INTEGER :: N_POINTS,JP +! + REAL (WP), INTENT(IN) :: F(N) + REAL (WP), INTENT(IN) :: H + REAL (WP), INTENT(OUT) :: F1(N) +! + REAL (WP) :: STEP1 + REAL (WP) :: A(10,0:10),B(10,-10:0),C(10,-10:10) +! + STEP1 = TWO * H ! +! + N_POINTS = 3 ! +! + CALL COEF_DERIV(N_POINTS,A,B,C) ! +! +! First derivative for the extremal points 1 and N +! + F1(1) = ( A(1,0) * F(1) + A(1,1) * F(2) + A(1,2) * F(3) ) & ! + / STEP1 ! +! + F1(N) = ( B(1,0) * F(N) + B(1,-1) * F(N-1) + B(1,-2) * & ! + F(N-2) ) / STEP1 ! +! +! First derivative for the other points +! + DO JP = 2, N-1 ! +! + F1(JP) = ( C(1,-1) * F(JP-1) + C(1,0) * F(JP) + C(1,1) * & ! + F(JP+1) ) / STEP1 ! +! + END DO ! +! + END SUBROUTINE DERIV_3P +! +!======================================================================= +! + SUBROUTINE DERIV_4P(F,N,F1,H) +! +! This subroutine computes the first derivative F1 of function F, +! using a 4-point formula. +! +! The general formula used is a central difference formula, +! except for the first two points (forward difference formula) +! and for the last two points (backward difference formula). +! +! Input parameters: +! +! F : y coordinates of the input file +! N : dimension of the arrays +! H : step of the input file +! +! +! Output parameters: +! +! F1 : order 1 derivative of F +! +! +! +! References : A. K. Singh and G. R. Thorpe, +! RGMIA Res. Rep. Coll., 2(6), Article 7, 1999. +! +! T. F. Guidry, +! http://www.trentfguidry.net/post/2010/09/04/Numerical-differentiation-formulas.aspx +! +! +! Author : D. Sébilleau +! Last version : 4 Jun 2020 +! +! + IMPLICIT NONE +! + INTEGER :: N,N_POINTS,JP +! + REAL (WP) :: F(N),F1(N) + REAL (WP) :: H,STEP1 + REAL (WP) :: A(10,0:10),B(10,-10:0),C(10,-10:10) +! + STEP1=H ! +! + N_POINTS=4 ! +! + CALL COEF_DERIV(N_POINTS,A,B,C) ! +! +! First derivative for the extremal points 1 and N +! + F1(1)=(A(1,0)*F(1)+A(1,1)*F(2)+A(1,2)*F(3)+A(1,3)*F(4))/STEP1 ! + F1(2)=(A(1,0)*F(2)+A(1,1)*F(3)+A(1,2)*F(4)+A(1,3)*F(5))/STEP1 ! + F1(3)=(A(1,0)*F(3)+A(1,1)*F(4)+A(1,2)*F(5)+A(1,3)*F(6))/STEP1 ! +! +! First derivative for the other points +! + DO JP=4,N ! +! + F1(JP)=(B(1,0)*F(JP)+B(1,-1)*F(JP-1)+B(1,-2)*F(JP-2)+ & ! + B(1,-3)*F(JP-3))/STEP1 ! +! + END DO ! +! + END SUBROUTINE DERIV_4P +! +!======================================================================= +! + SUBROUTINE DERIV_5P(F,N,F1,H) +! +! This subroutine computes the first derivative F1 of function F, +! using a 5-point formula. +! +! The general formula used is a central difference formula, +! except for the first two points (forward difference formula) +! and for the last two points (backward difference formula). +! +! Input parameters: +! +! F : y coordinates of the input file +! N : dimension of the arrays +! H : step of the input file +! +! +! Output parameters: +! +! F1 : order 1 derivative of F +! +! +! +! References : A. K. Singh and G. R. Thorpe, +! RGMIA Res. Rep. Coll., 2(6), Article 7, 1999. +! +! T. F. Guidry, +! http://www.trentfguidry.net/post/2010/09/04/Numerical-differentiation-formulas.aspx +! +! +! Author : D. Sébilleau +! Last version : 4 Jun 2020 +! +! + IMPLICIT NONE +! + INTEGER :: N,N_POINTS,JP +! + REAL (WP) :: F(N),F1(N) + REAL (WP) :: H,STEP1 + REAL (WP) :: A(10,0:10),B(10,-10:0),C(10,-10:10) +! + STEP1=12.E0_WP*H ! +! + N_POINTS=5 ! +! + + CALL COEF_DERIV(N_POINTS,A,B,C) ! +! +! First derivative for the extremal points 1, 2, N-1 and N +! + F1(1)=(A(1,0)*F(1)+A(1,1)*F(2)+A(1,2)*F(3)+A(1,3)*F(4)+ & ! + A(1,4)*F(5))/STEP1 ! + F1(2)=(A(1,0)*F(2)+A(1,1)*F(3)+A(1,2)*F(4)+A(1,3)*F(5)+ & ! + A(1,4)*F(6))/STEP1 ! +! + F1(N-1)=(B(1,0)*F(N-1)+B(1,-1)*F(N-2)+B(1,-2)*F(N-3)+ & ! + B(1,-3)*F(N-4)+B(1,-4)*F(N-5))/STEP1 ! + F1(N)=(B(1,0)*F(N)+B(1,-1)*F(N-1)+B(1,-2)*F(N-2)+ & ! + B(1,-3)*F(N-3)+B(1,-4)*F(N-4))/STEP1 ! +! +! First derivative for the other points +! + DO JP=3,N-2 ! +! + F1(JP)=(C(1,-2)*F(JP-2)+C(1,-1)*F(JP-1)+C(1,0)*F(JP)+ & ! + C(1,1)*F(JP+1)+C(1,2)*F(JP+2))/STEP1 ! +! + END DO ! +! + END SUBROUTINE DERIV_5P +! +!======================================================================= +! + SUBROUTINE DERIV_6P(F,N,F1,H) +! +! This subroutine computes the first derivative F1 of function F, +! using a 6-point formula. +! +! The general formula used is a central difference formula, +! except for the first two points (forward difference formula) +! and for the last two points (backward difference formula). +! +! Input parameters: +! +! F : y coordinates of the input file +! N : dimension of the arrays +! H : step of the input file +! +! +! Output parameters: +! +! F1 : order 1 derivative of F +! +! +! +! References : A. K. Singh and G. R. Thorpe, +! RGMIA Res. Rep. Coll., 2(6), Article 7, 1999. +! +! T. F. Guidry, +! http://www.trentfguidry.net/post/2010/09/04/Numerical-differentiation-formulas.aspx +! +! +! Author : D. Sébilleau +! Last version : 4 Jun 2020 +! +! + IMPLICIT NONE +! + INTEGER :: N,N_POINTS,JP +! + REAL (WP) :: F(N),F1(N) + REAL (WP) :: H,STEP1 + REAL (WP) :: A(10,0:10),B(10,-10:0),C(10,-10:10) +! + STEP1=60.E0_WP*H ! +! + N_POINTS=6 ! +! + + CALL COEF_DERIV(N_POINTS,A,B,C) ! +! +! First derivative for the extremal points 1, 2, 3, 4 and 5 +! + F1(1)=(A(1,0)*F(1)+A(1,1)*F(2)+A(1,2)*F(3)+A(1,3)*F(4)+ & ! + A(1,4)*F(5)+A(1,5)*F(6))/STEP1 ! + F1(2)=(A(1,0)*F(2)+A(1,1)*F(3)+A(1,2)*F(4)+A(1,3)*F(5)+ & ! + A(1,4)*F(6)+A(1,5)*F(7))/STEP1 ! + F1(3)=(A(1,0)*F(3)+A(1,1)*F(4)+A(1,2)*F(5)+A(1,3)*F(6)+ & ! + A(1,4)*F(7)+A(1,5)*F(8))/STEP1 ! + F1(4)=(A(1,0)*F(4)+A(1,1)*F(5)+A(1,2)*F(6)+A(1,3)*F(7)+ & ! + A(1,4)*F(8)+A(1,5)*F(9))/STEP1 ! + F1(5)=(A(1,0)*F(5)+A(1,1)*F(6)+A(1,2)*F(7)+A(1,3)*F(8)+ & ! + A(1,4)*F(9)+A(1,5)*F(10))/STEP1 ! +! +! First derivative for the other points +! + DO JP=6,N ! +! + F1(JP)=(B(1,0)*F(JP)+B(1,-1)*F(JP-1)+B(1,-2)*F(JP-2)+ & ! + B(1,-3)*F(JP-3)+B(1,-4)*F(JP-4)+ & ! + B(1,-5)*F(JP-5))/STEP1 ! +! + END DO ! +! + END SUBROUTINE DERIV_6P +! +!======================================================================= +! + SUBROUTINE COEF_DERIV(NP,A,B,C) +! +! This subroutine computes the coefficients for the +! NP-point derivation with 1 < NP < 8 +! +! Derivatives up to order (NP-1) can be computed from +! these coefficients (limited to order 5) +! +! Input parameters: +! +! * NP : number of points of the derivation +! +! +! Output parameters: +! +! * A(ND,NP) : coefficients of the derivation for the forward +! difference scheme +! * B(ND,NP) : coefficients of the derivation for the backward +! difference scheme +! * C(ND,NP) : coefficients of the derivation for the central +! difference scheme +! +! with ND the order of the derivation +! +! References: T. F. Guidry, +! http://www.trentfguidry.net/post/2010/09/04/Numerical-differentiation-formulas.aspx +! +! +! Note: the coefficients are computed for three different schemes: +! +! = F : forward difference +! = B : backward difference +! = C : central difference (Stirling) +! +! The order of the coefficients is the following: +! +! = F : A(0)*F(I) + A(1)*F(I+1) + ... +! = B : B(0)*F(I) + B(-1)*F(I-1) + ... +! = C : ... + C(-1)*F(I-1) + C(0)*F(I) + C(1)*F(I+1) + ... +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! + IMPLICIT NONE +! + INTEGER :: NP + INTEGER :: I,J,K +! + REAL (WP) :: A(10,0:10),B(10,-10:0),C(10,-10:10) +! +! Initializations +! + DO J=1,10 ! + DO K=0,10 ! + A(J,K)=0.0E0_WP ! + END DO ! + DO K=-10,0 ! + B(J,K)=0.0E0_WP ! + END DO ! + DO K=-10,10 ! + C(J,K)=0.0E0_WP ! + END DO ! + END DO ! +! + IF(NP == 2) THEN ! +! +! Forward difference scheme +! + A(1,0)=-1.0E0_WP ! + A(1,1)=1.0E0_WP ! +! +! Backward difference scheme +! + B(1,0)=1.0E0_WP ! + B(1,-1)=-1.0E0_WP ! +! + ELSE IF(NP == 3) THEN ! +! +! Forward difference scheme +! + A(1,0)=-3.0E0_WP ! + A(1,1)=4.0E0_WP ! + A(1,2)=-1.0E0_WP ! +! + A(2,0)=1.0E0_WP ! + A(2,1)=-2.0E0_WP ! + A(2,2)=1.0E0_WP ! +! +! Backward difference scheme +! + B(1,0)=3.0E0_WP ! + B(1,-1)=-4.0E0_WP ! + B(1,-2)=1.0E0_WP ! +! + B(2,0)=1.0E0_WP ! + B(2,-1)=-2.0E0_WP ! + B(2,-2)=1.0E0_WP ! +! +! Central difference scheme +! + C(1,-1)=-1.0E0_WP ! + C(1,0)=0.0E0_WP ! + C(1,1)=1.0E0_WP ! +! + C(2,-1)=1.0E0_WP ! + C(2,0)=-2.0E0_WP ! + C(2,1)=1.0E0_WP ! +! + ELSE IF(NP == 4) THEN ! +! +! Forward difference scheme +! + A(1,0)=-11.0E0_WP ! + A(1,1)=18.0E0_WP ! + A(1,2)=-9.0E0_WP ! + A(1,3)=2.0E0_WP ! +! + A(2,0)=2.0E0_WP ! + A(2,1)=-5.0E0_WP ! + A(2,2)=4.0E0_WP ! + A(2,3)=-1.0E0_WP ! +! + A(3,0)=-1.0E0_WP ! + A(3,1)=3.0E0_WP ! + A(3,2)=-3.0E0_WP ! + A(3,3)=1.0E0_WP ! +! +! Backward difference scheme +! + B(1,0)=11.0E0_WP ! + B(1,-1)=-18.0E0_WP ! + B(1,-2)=9.0E0_WP ! + B(1,-3)=-2.0E0_WP ! +! + B(2,0)=2.0E0_WP ! + B(2,-1)=-5.0E0_WP ! + B(2,-2)=4.0E0_WP ! + B(2,-3)=-1.0E0_WP ! +! + B(3,0)=1.0E0_WP ! + B(3,-1)=-3.0E0_WP ! + B(3,-2)=3.0E0_WP ! + B(3,-3)=-1.0E0_WP ! +! + ELSE IF(NP == 5) THEN ! +! +! Forward difference scheme +! + A(1,0)=-25.0E0_WP ! + A(1,1)=48.0E0_WP ! + A(1,2)=-36.0E0_WP ! + A(1,3)=16.0E0_WP ! + A(1,4)=-3.0E0_WP ! +! + A(2,0)=35.0E0_WP ! + A(2,1)=-104.0E0_WP ! + A(2,2)=114.0E0_WP ! + A(2,3)=-56.0E0_WP ! + A(2,4)=11.0E0_WP ! +! + A(3,0)=-5.0E0_WP ! + A(3,1)=18.0E0_WP ! + A(3,2)=-24.0E0_WP ! + A(3,3)=14.0E0_WP ! + A(3,4)=-3.0E0_WP ! +! + A(4,0)=1.0E0_WP ! + A(4,1)=-4.0E0_WP ! + A(4,2)=6.0E0_WP ! + A(4,3)=-4.0E0_WP ! + A(4,4)=1.0E0_WP ! +! +! Backward difference scheme +! + B(1,0)=25.0E0_WP ! + B(1,-1)=-48.0E0_WP ! + B(1,-2)=36.0E0_WP ! + B(1,-3)=-16.0E0_WP ! + B(1,-4)=3.0E0_WP ! +! + B(2,0)=35.0E0_WP ! + B(2,-1)=-104.0E0_WP ! + B(2,-2)=114.0E0_WP ! + B(2,-3)=-56.0E0_WP ! + B(2,-4)=11.0E0_WP ! +! + B(3,0)=5.0E0_WP ! + B(3,-1)=-18.0E0_WP ! + B(3,-2)=24.0E0_WP ! + B(3,-3)=-14.0E0_WP ! + B(3,-4)=3.0E0_WP ! +! + B(4,0)=1.0E0_WP ! + B(4,-1)=-4.0E0_WP ! + B(4,-2)=6.0E0_WP ! + B(4,-3)=-4.0E0_WP ! + B(4,-4)=1.0E0_WP ! +! +! Central difference scheme +! + C(1,-2)=1.0E0_WP ! + C(1,-1)=-8.0E0_WP ! + C(1,0)=0.0E0_WP ! + C(1,1)=8.0E0_WP ! + C(1,2)=-1.0E0_WP ! +! + C(2,-2)=-1.0E0_WP ! + C(2,-1)=16.0E0_WP ! + C(2,0)=-30.0E0_WP ! + C(2,1)=16.0E0_WP ! + C(2,2)=-1.0E0_WP ! +! + C(3,-2)=-1.0E0_WP ! + C(3,-1)=2.0E0_WP ! + C(3,0)=0.0E0_WP ! + C(3,1)=-2.0E0_WP ! + C(3,2)=1.0E0_WP ! +! + C(4,-2)=1.0E0_WP ! + C(4,-1)=-4.0E0_WP ! + C(4,0)=6.0E0_WP ! + C(4,1)=-4.0E0_WP ! + C(4,2)=1.0E0_WP ! +! + ELSE IF(NP == 6) THEN ! +! +! Forward difference scheme +! + A(1,0)=-137.0E0_WP ! + A(1,1)=300.0E0_WP ! + A(1,2)=-300.0E0_WP ! + A(1,3)=200.0E0_WP ! + A(1,4)=-75.0E0_WP ! + A(1,5)=12.0E0_WP ! +! + A(2,0)=45.0E0_WP ! + A(2,1)=-154.0E0_WP ! + A(2,2)=214.0E0_WP ! + A(2,3)=-156.0E0_WP ! + A(2,4)=61.0E0_WP ! + A(2,5)=-10.0E0_WP ! +! + A(3,0)=-17.0E0_WP ! + A(3,1)=71.0E0_WP ! + A(3,2)=-118.0E0_WP ! + A(3,3)=98.0E0_WP ! + A(3,4)=-41.0E0_WP ! + A(3,5)=7.0E0_WP ! +! + A(4,0)=3.0E0_WP ! + A(4,1)=-14.0E0_WP ! + A(4,2)=26.0E0_WP ! + A(4,3)=-24.0E0_WP ! + A(4,4)=11.0E0_WP ! + A(4,5)=-2.0E0_WP ! +! + A(5,0)=-1.0E0_WP ! + A(5,1)=5.0E0_WP ! + A(5,2)=-10.0E0_WP ! + A(5,3)=10.0E0_WP ! + A(5,4)=-5.0E0_WP ! + A(5,5)=1.0E0_WP ! +! +! Backward difference scheme +! + B(1,0)=137.0E0_WP ! + B(1,-1)=-300.0E0_WP ! + B(1,-2)=300.0E0_WP ! + B(1,-3)=-200.0E0_WP ! + B(1,-4)=75.0E0_WP ! + B(1,-5)=-12.0E0_WP ! +! + B(2,0)=45.0E0_WP ! + B(2,-1)=-154.0E0_WP ! + B(2,-2)=214.0E0_WP ! + B(2,-3)=-156.0E0_WP ! + B(2,-4)=61.0E0_WP ! + B(2,-5)=-10.0E0_WP ! +! + B(3,0)=17.0E0_WP ! + B(3,-1)=-71.0E0_WP ! + B(3,-2)=118.0E0_WP ! + B(3,-3)=-98.0E0_WP ! + B(3,-4)=41.0E0_WP ! + B(3,-5)=-7.0E0_WP ! +! + B(4,0)=3.0E0_WP ! + B(4,-1)=-14.0E0_WP ! + B(4,-2)=26.0E0_WP ! + B(4,-3)=-24.0E0_WP ! + B(4,-4)=11.0E0_WP ! + B(4,-5)=-2.0E0_WP ! +! + B(5,0)=1.0E0_WP ! + B(5,-1)=-5.0E0_WP ! + B(5,-2)=10.0E0_WP ! + B(5,-3)=-10.0E0_WP ! + B(5,-4)=5.0E0_WP ! + B(5,-5)=-1.0E0_WP ! +! + ELSE IF(NP == 7) THEN ! +! +! Forward difference scheme +! + A(1,0)=-147.0E0_WP ! + A(1,1)=360.0E0_WP ! + A(1,2)=-450.0E0_WP ! + A(1,3)=400.0E0_WP ! + A(1,4)=-225.0E0_WP ! + A(1,5)=72.0E0_WP ! + A(1,6)=-10.0E0_WP ! +! + A(2,0)=812.0E0_WP ! + A(2,1)=-3132.0E0_WP ! + A(2,2)=5265.0E0_WP ! + A(2,3)=-5080.0E0_WP ! + A(2,4)=2970.0E0_WP ! + A(2,5)=-972.0E0_WP ! + A(2,6)=137.0E0_WP ! +! + A(3,0)=-49.0E0_WP ! + A(3,1)=232.0E0_WP ! + A(3,2)=-461.0E0_WP ! + A(3,3)=496.0E0_WP ! + A(3,4)=-307.0E0_WP ! + A(3,5)=104.0E0_WP ! + A(3,6)=-15.0E0_WP ! +! + A(4,0)=35.0E0_WP ! + A(4,1)=-186.0E0_WP ! + A(4,2)=411.0E0_WP ! + A(4,3)=-484.0E0_WP ! + A(4,4)=321.0E0_WP ! + A(4,5)=-114.0E0_WP ! + A(4,6)=17.0E0_WP ! +! + A(5,0)=-7.0E0_WP ! + A(5,1)=40.0E0_WP ! + A(5,2)=-95.0E0_WP ! + A(5,3)=120.0E0_WP ! + A(5,4)=-85.0E0_WP ! + A(5,5)=32.0E0_WP ! + A(5,6)=-5.0E0_WP ! +! +! Backward difference scheme +! + B(1,0)=147.0E0_WP ! + B(1,-1)=-360.0E0_WP ! + B(1,-2)=450.0E0_WP ! + B(1,-3)=-400.0E0_WP ! + B(1,-4)=225.0E0_WP ! + B(1,-5)=-72.0E0_WP ! + B(1,-6)=10.0E0_WP ! +! + B(2,0)=812.0D0 + B(2,-1)=-3132.0D0 + B(2,-2)=5265.0D0 + B(2,-3)=-5080.0D0 + B(2,-4)=2970.0D0 + B(2,-5)=-972.0D0 + B(2,-6)=137.0D0 +! + B(3,0)=49.0E0_WP ! + B(3,-1)=-232.0E0_WP ! + B(3,-2)=461.0E0_WP ! + B(3,-3)=-496.0E0_WP ! + B(3,-4)=307.0E0_WP ! + B(3,-5)=-104.0E0_WP ! + B(3,-6)=15.0E0_WP ! +! + B(4,0)=35.0E0_WP ! + B(4,-1)=-186.0E0_WP ! + B(4,-2)=411.0E0_WP ! + B(4,-3)=-484.0E0_WP ! + B(4,-4)=321.0E0_WP ! + B(4,-5)=-114.0E0_WP ! + B(4,-6)=17.0E0_WP ! +! + B(5,0)=7.0E0_WP ! + B(5,-1)=-40.0E0_WP ! + B(5,-2)=95.0E0_WP ! + B(5,-3)=-120.0E0_WP ! + B(5,-4)=85.0E0_WP ! + B(5,-5)=-32.0E0_WP ! + B(5,-6)=5.0E0_WP ! +! +! Central difference scheme +! + C(1,-3)=-1.0E0_WP ! + C(1,-2)=9.0E0_WP ! + C(1,-1)=-45.0E0_WP ! + C(1,0)=0.0E0_WP ! + C(1,1)=45.0E0_WP ! + C(1,2)=-9.0E0_WP ! + C(1,3)=1.0E0_WP ! +! + C(2,-3)=2.0E0_WP ! + C(2,-2)=-27.0E0_WP ! + C(2,-1)=270.0E0_WP ! + C(2,0)=-490.0E0_WP ! + C(2,1)=270.0E0_WP ! + C(2,2)=-27.0E0_WP ! + C(2,3)=2.0E0_WP ! +! + C(3,-3)=1.0E0_WP ! + C(3,-2)=-8.0E0_WP ! + C(3,-1)=13.0E0_WP ! + C(3,0)=0.0E0_WP ! + C(3,1)=-13.0E0_WP ! + C(3,2)=8.0E0_WP ! + C(3,3)=-1.0E0_WP ! +! + C(4,-3)=-1.0E0_WP ! + C(4,-2)=12.0E0_WP ! + C(4,-1)=-39.0E0_WP ! + C(4,0)=56.0E0_WP ! + C(4,1)=-39.0E0_WP ! + C(4,2)=12.0E0_WP ! + C(4,3)=-1.0E0_WP ! +! + C(5,-3)=-1.0E0_WP ! + C(5,-2)=4.0E0_WP ! + C(5,-1)=-5.0E0_WP ! + C(5,0)=0.0E0_WP ! + C(5,1)=5.0E0_WP ! + C(5,2)=-4.0E0_WP ! + C(5,3)=1.0E0_WP ! +! + END IF ! +! + END SUBROUTINE COEF_DERIV + +! +END MODULE DERIVATION diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/factorials.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/factorials.f90 new file mode 100644 index 0000000..7fe8aaa --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/factorials.f90 @@ -0,0 +1,214 @@ +! +!======================================================================= +! +MODULE FACTORIALS +! +! This module provides factorials and other related numbers +! +! + USE ACCURACY_REAL + USE REAL_NUMBERS, ONLY : ZERO,ONE +! +CONTAINS +! +!======================================================================= +! + FUNCTION FAC(N) +! +! This function computes the factorial of n +! +! Input parameters: +! +! * N : integer +! +! Output variables : +! +! * FAC : n! +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Aug 2020 +! + IMPLICIT NONE +! + REAL (WP) :: FAC + REAL (WP) :: FACT(50) +! + REAL (WP) :: FLOAT +! + INTEGER :: N,K + INTEGER :: LOGF +! + LOGF = 6 ! +! + IF(N > 50) THEN ! + WRITE(LOGF,10) ! + STOP ! + END IF ! +! + FACT(1) = ONE ! +! + DO K = 2, N ! + FACT(K) =FACT(K-1) * FLOAT(K) ! + END DO ! +! + FAC = FACT(N) ! +! + 10 FORMAT(5X,'<<<<< DIMENSION ERROR IN FAC FUNCTION >>>>>',/, &! + 5X,'<<<<< N SHOULD BE <= 50 OR REDIMENSION >>>>>',//) ! +! + END FUNCTION FAC +! +!======================================================================= +! + SUBROUTINE COMBINATORIAL(NMAX,NUMBER,CN) +! +! This subroutine computes numbers resulting from combinatorics +! +! --> This version if for integers only <-- +! +! +! +! Input variables : +! +! NMAX : upper value of n +! NUMBER : type of numbers computed +! ---> 'BINOMIAL ' : binomial coefficients +! ---> 'POCHHAMMER' : Pochhammer coefficients +! ---> 'STIRLING1S' : signed Stirling numbers of 1st kind +! ---> 'STIRLING1U' : unsigned Stirling numbers of 1st kind +! ---> 'STIRLING2N' : Stirling numbers of 2nd kind +! +! Output variables : +! +! +! CN : resulting numbers +! +! +! Author : D. Sébilleau +! +! Last modified : 31 Jan 2019 +! +! + IMPLICIT NONE +! + REAL (WP) :: LG(NMAX),CN(0:NMAX,0:NMAX),X +! + REAL (WP) :: EXP,FLOAT +! + INTEGER :: NMAX,I,J,K,N +! + CHARACTER (LEN = 10) :: NUMBER +! +! Initialization of the array +! + DO I = 0,NMAX ! + DO J = 0,NMAX ! + CN(I,J) = ZERO ! + END DO ! + END DO ! +! + IF(NUMBER == 'BINOMIAL ') THEN ! ( N ) +! ! ( K ) + CALL LOG_GAMMA(NMAX,LG) ! +! + CN(0,0) = ONE ! + DO N = 1,NMAX ! + DO K = 1,NMAX-N ! + X = LG(N)-LG(K)-LG(N-K) ! + CN(N,K) = EXP(X) ! + END DO ! + END DO ! +! + ELSE IF(NUMBER == 'POCHHAMMER') THEN ! (N)_K +! + CALL LOG_GAMMA(NMAX,LG) ! +! + CN(0,0) = ONE ! + DO N = 1,NMAX ! + DO K = 1,NMAX-N ! + X = LG(N+K)-LG(N) ! + CN(N,K) = EXP(X) ! + END DO ! + END DO ! +! + ELSE IF(NUMBER == 'STIRLING1U') THEN ! c(N,K) +! + CN(0,0) = ONE ! + CN(NMAX,0) = ZERO ! +! + DO N = 1, NMAX-1 ! + CN(N,0) = ZERO ! + DO K = 1, NMAX-N+1 ! + CN(N+1,K) = FLOAT(N) * CN(N,K) + CN(N,K-1) ! + END DO ! + END DO ! +! + ELSE IF(NUMBER == 'STIRLING1S') THEN ! s(N,K) +! + CN(0,0) = ONE ! + CN(NMAX,0) = ZERO ! +! + DO N = 1, NMAX-1 ! + CN(N,0) = ZERO ! + DO K = 1, NMAX-N+1 ! + CN(N+1,K) = - FLOAT(N) * CN(N,K) + CN(N,K-1) ! + END DO ! + END DO ! +! + ELSE IF(NUMBER == 'STIRLING2N') THEN ! S(N,K) +! + CN(0,0) = ONE ! + CN(NMAX,0) = ZERO ! +! + DO N = 1, NMAX-1 ! + CN(N,0) = ZERO ! + DO K = 1,NMAX-N+1 ! + CN(N+1,K) = FLOAT(K) * CN(N,K) + CN(N,K-1) ! + END DO ! + END DO ! +! + END IF +! + END SUBROUTINE COMBINATORIAL +! +!======================================================================= +! + SUBROUTINE LOG_GAMMA(NMAX,LG) +! +! This subroutine computes the logarithm of the Gamma function for +! integer values (i.e. Log(n!)) +! +! +! Input variables : +! +! NMAX : upper value of n +! +! Output variables : +! +! LG : array containing Log(n!) +! +! Author : D. Sébilleau +! +! Last modified : 5 Aug 2020 +! +! + IMPLICIT NONE +! + REAL (WP) :: LG(NMAX) +! + REAL (WP) :: LOG,FLOAT +! + INTEGER :: NMAX,I,J +! + LG(1) = ZERO ! +! + DO I = 2,NMAX ! + J = I - 1 ! + LG(I) = LG(J) + LOG(FLOAT(J)) ! + END DO ! +! + END SUBROUTINE LOG_GAMMA +! +END MODULE FACTORIALS diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/find_zero.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/find_zero.f90 new file mode 100644 index 0000000..34454c3 --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/find_zero.f90 @@ -0,0 +1,1139 @@ +! +!======================================================================= +! +MODULE CPOLY_VAR +! +! This module contains input values for print switches +! +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + INTEGER :: NN +! + REAL (WP) :: PR(50),PI(50),HR(50),HI(50) + REAL (WP) :: QPR(50),QPI(50),QHR(50),QHI(50) + REAL (WP) :: SHR(50),SHI(50) + REAL (WP) :: SR,SI,TR,TI,PVR,PVI + REAL (WP) :: ARE,MRE,ETA,INFIN +! +END MODULE CPOLY_VAR +! +!======================================================================= +! +MODULE FIND_ZERO +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE FIND_ZERO_FUNC(X,F,N_X,ZEROF) +! +! This subroutine finds the solution of F_Y(X) = 0 in the interval [A,B] +! +! +! Input parameters: +! +! * X : array representing the abscissae of f_y +! * F : array representing the function f_y +! * N_X : size of the X and F arrays +! +! +! Output variables : +! +! * ZEROF : zero of f(x) in [A,B] +! +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Oct 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + INTEGER :: I,N_X +! + REAL (WP) :: A,B,FA,FB + REAL (WP) :: X(NSIZE),F(NSIZE) + REAL (WP) :: PROD,ZEROF +! + REAL (WP), PARAMETER :: TOL = 0.00001E0_WP +! +! Finding the intervals containing a zero +! + DO I = 2,N_X ! +! + PROD = F(I) * F(I-1) ! +! + IF(PROD < ZERO) THEN ! + A = X(I-1) ! + B = X(I) ! + FA = F(I-1) ! + FB = F(I) ! + ZEROF = ZEROIN(A,B,FA,FB,TOL) ! + END IF ! +! + END DO ! +! + END SUBROUTINE FIND_ZERO_FUNC +! +!======================================================================= +! + SUBROUTINE PRINT_ZERO_FUNC(Y,X,F,N_X) +! +! This subroutine finds the solution of F_Y(X) = 0 in the interval [A,B] +! +! +! Input parameters: +! +! * Y : actual abcissa point +! * X : array representing the abscissae of f_y +! * F : array representing the function f_y +! * N_X : size of the X and F arrays +! +! +! Output variables : +! +! * ZEROF : zero of f(x) in [A,B] +! +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Oct 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ZERO +! + USE PRINT_FILES, ONLY : IO_ZE +! + IMPLICIT NONE +! + INTEGER :: I,N_X +! + REAL (WP) :: Y + REAL (WP) :: A,B,FA,FB + REAL (WP) :: X(NSIZE),F(NSIZE) + REAL (WP) :: PROD,ZEROF +! + REAL (WP), PARAMETER :: TOL = 0.00001E0_WP +! +! Finding the intervals containing a zero +! + DO I = 2,N_X ! +! + PROD = F(I) * F(I-1) ! +! + IF(PROD < ZERO) THEN ! + A = X(I-1) ! + B = X(I) ! + FA = F(I-1) ! + FB = F(I) ! + ZEROF = ZEROIN(A,B,FA,FB,TOL) ! + WRITE(IO_ZE,*) Y,ZEROF ! + END IF ! +! + END DO ! +! + END SUBROUTINE PRINT_ZERO_FUNC +! +!======================================================================= +! + FUNCTION ZEROIN(AX,BX,FAX,FBX,TOL) +! +! A zero of the function F(X) is computed in the interval AX,BX +! +! Input parameters: +! +! * AX : left endpoint of initial interval +! * BX : right endpoint of initial interval +! * FAX : value of F(X) at AX +! * FBX : value of F(X) at BX +! * TOL : desired length of the interval of uncertainty of the +! final result ( .GE. 0.0D0) +! +! Output parameters: +! +! * ZEROIN : abcissa approximating a zero of F(X) +! in the interval AX,BX +! +! +! It is assumed that F(AX) and F(BX) have opposite signs +! without a check. ZEROIN returns a zero X in the given interval +! AX,BX to within a tolerance 4*MACHEPS*ABS(X) + TOL, where MACHEPS +! is the relative machine precision. +! +! This function subprogram is a slightly modified translation of +! the ALGOL 60 procedure ZERO given in Richard Brent, "Algorithms for +! Minimization Without Derivatives", Prentice-Hall, Inc. (1973). +! +! +! Last Modified : 18 Jun 2020 by D. Sébilleau +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE, & + HALF +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: AX,BX,FAX,FBX,TOL + REAL (WP) :: ZEROIN + REAL (WP) :: A,B,C,D,E,EPS + REAL (WP) :: FA,FB,FC,TOL1,XM + REAL (WP) :: P,Q,R,S +! + REAL (WP) :: ABS,SIGN +! +! Compute EPS, the relative machine precision +! + EPS = ONE ! + 10 EPS = EPS / TWO ! + TOL1 = ONE + EPS ! + IF(TOL1 > ONE) GO TO 10 ! +! +! Initialization +! + A = AX ! + B = BX ! + FA = FAX ! + FB = FBX ! +! +! Begin step +! + 20 C = A ! + FC = FA ! + D = B - A ! + E = D ! +! + 30 IF(ABS(FC) >= ABS(FB)) GO TO 40 ! +! + A = B ! + B = C ! + C = A ! + FA = FB ! + FB = FC ! + FC = FA ! +! +! Convergence test +! + 40 TOL1 = TWO * EPS * ABS(B) + HALF * TOL ! + XM = HALF * (C - B) ! + IF(ABS(XM) <= TOL1) GO TO 90 ! + IF(FB == ZERO) GO TO 90 ! +! +! Is bisection necessary ? +! + IF(ABS(E) < TOL1) GO TO 70 ! + IF(ABS(FA) <= ABS(FB)) GO TO 70 ! +! +! Is quadratic interpolation possible ? +! + IF(A /= C) GO TO 50 ! +! +! Linear interpolation +! + S = FB / FA ! + P = TWO * XM * S ! + Q = ONE - S ! + GO TO 60 ! +! +! Inverse quadratic interpolation +! + 50 Q = FA / FC ! + R = FB / FC ! + S = FB / FA ! + P = S * ( TWO * XM * Q * (Q - R) - (B - A) * (R - ONE) ) ! + Q = (Q - ONE) * (R - ONE) * (S - ONE) ! +! +! Adjust signs +! + 60 IF(P > ZERO) Q = -Q ! + P = ABS(P) ! +! +! Is interpolation acceptable ? +! + IF((TWO*P) >= (THREE * XM * Q - ABS(TOL1 * Q))) GO TO 70 ! + IF (P >= ABS(HALF * E * Q)) GO TO 70 ! + E = D ! + D = P / Q ! + GO TO 80 ! +! +! Bisection +! + 70 D = XM ! + E = D ! +! +! Complete step +! + 80 A = B ! + FA = FB ! + IF(ABS(D).GT.TOL1) B = B + D ! + IF(ABS(D).LE.TOL1) B = B + SIGN(TOL1,XM) ! + FB = FBX ! + IF((FB * (FC / ABS(FC))) > ZERO) GO TO 20 ! + GO TO 30 ! +! +! Done +! + 90 ZEROIN = B ! +! + END FUNCTION ZEROIN +! +!======================================================================= +! +! Algorithm 419 collected algorithms from ACM. +! +! Algorithm appeared in Comm. ACM, Vol. 15, No. 02, p. 097. +! + SUBROUTINE CPOLY(OPR,OPI,DEGREE,ZEROR,ZEROI,FAIL) +! +! Finds the zeros of a complex polynomial. +! +! OPR, OPI : double precision vectors of real and +! imaginary parts of the coefficients in +! order of decreasing powers. +! DEGREE : integer degree of polynomial. +! ZEROR, ZEROI : output double precision vectors of +! real and imaginary parts of the zeros. +! FAIL : output logical parameter, .true. only if +! leading coefficient is zero or if CPOLY +! has found fewer than degree zeros. +! +! The program has been written to reduce the chance of overflow +! occurring. If it does occur, there is still a possibility that +! the zerofinder will work provided the overflowed quantity is +! replaced by a large number. +! +! +! Last Modified : 18 Jun 2020 by D. Sébilleau +! +! + USE CPOLY_VAR + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO + USE SQUARE_ROOTS, ONLY : SQR2 +! + IMPLICIT NONE +! +! To change the size of polynomials which can be solved, replace +! the dimension of the arrays in the common area +! +! + REAL (WP) :: XX,YY,COSR,SINR,SMALNO,BASE + REAL (WP) :: XXX,ZR,ZI,BND + REAL (WP) :: OPR(101),OPI(101) + REAL (WP) :: ZEROR(101),ZEROI(101) +! + LOGICAL :: FAIL,CONV +! + INTEGER :: DEGREE,CNT1,CNT2 + INTEGER :: I,IDNN2 +! +! Initialization of constants +! + CALL MCON(ETA,INFIN,SMALNO,BASE) ! + ARE = ETA ! + MRE = TWO*SQR2*ETA ! + XX = 0.70710678E0_WP ! + YY = -XX ! + COSR = -0.060756474E0_WP ! + SINR = 0.99756405E0_WP ! + FAIL = .FALSE. ! + NN = DEGREE+1 ! +! +! Algorithm fails if the leading coefficient is zero. +! + IF (OPR(1) /= ZERO .OR. OPI(1) /= ZERO) GO TO 10 ! + FAIL = .TRUE. ! + RETURN ! +! +! Remove the zeros at the origin if any +! + 10 IF (OPR(NN) /= ZERO .OR. OPI(NN) /= ZERO) GO TO 20 ! + IDNN2 = DEGREE-NN+2 ! + ZEROR(IDNN2) = ZERO ! + ZEROI(IDNN2) = ZERO ! + NN = NN-1 ! + GO TO 10 ! +! +! Make a copy of the coefficients +! + 20 DO I = 1,NN ! + PR(I) = OPR(I) ! + PI(I) = OPI(I) ! + SHR(I) = CMOD(PR(I),PI(I)) ! + END DO ! +! +! Scale the polynomial +! + BND = RESCALE(NN,SHR,ETA,INFIN,SMALNO,BASE) ! + IF (BND == ONE) GO TO 40 ! + DO I = 1,NN ! + PR(I) = BND*PR(I) ! + PI(I) = BND*PI(I) ! + END DO ! +! +! Start the algorithm for one zero +! + 40 IF (NN > 2) GO TO 50 ! +! +! Calculate the final zero and return +! + CALL CDIVID(-PR(2),-PI(2),PR(1),PI(1),ZEROR(DEGREE), & ! + ZEROI(DEGREE)) ! + RETURN ! +! +! Calculate BND, a lower bound on the modulus of the zeros +! + 50 DO I = 1,NN ! + SHR(I) = CMOD(PR(I),PI(I)) ! + END DO ! + BND = CAUCHY(NN,SHR,SHI) ! +! +! Outer loop to control 2 major passes with different sequences +! of shifts +! + DO CNT1 = 1,2 ! +! +! First stage calculation, no shift +! + CALL NOSHFT(5) ! +! +! Inner loop to select a shift +! + DO CNT2 = 1,9 ! +! +! Shift is chosen with modulus BND and amplitude rotated by +! 94 degrees from the previous shift +! + XXX = COSR*XX-SINR*YY ! + YY = SINR*XX+COSR*YY ! + XX = XXX ! + SR = BND*XX ! + SI = BND*YY ! +! +! Second stage calculation, fixed shift +! + CALL FXSHFT(10*CNT2,ZR,ZI,CONV) ! +! + IF (.NOT. CONV) GO TO 80 ! +! +! The second stage jumps directly to the third stage iteration. +! If successful the zero is stored and the polynomial deflated +! + IDNN2 = DEGREE-NN+2 ! + ZEROR(IDNN2) = ZR ! + ZEROI(IDNN2) = ZI ! + NN = NN-1 ! + DO I = 1,NN ! + PR(I) = QPR(I) ! + PI(I) = QPI(I) ! + END DO ! +! + GO TO 40 ! +! + 80 CONTINUE ! +! +! If the iteration is unsuccessful another shift is chosen +! + END DO ! +! +! If 9 shifts fail, the outer loop is repeated with another +! sequence of shifts +! + END DO ! +! +! The zerofinder has failed on two major passes. +! Return empty handed +! + FAIL = .TRUE. ! +! + END SUBROUTINE CPOLY +! +!======================================================================= +! + SUBROUTINE NOSHFT(L1) +! +! Computes the derivative polynomial as the initial H +! polynomial and computes L1 no-shift H polynomials. +! +! +! Last Modified : 18 Jun 2020 by D. Sébilleau +! +! + USE CPOLY_VAR + USE REAL_NUMBERS, ONLY : ZERO,TEN +! + IMPLICIT NONE +! + REAL (WP) :: XNI,T1,T2 +! + REAL (WP) :: FLOAT +! + INTEGER :: L1,N,NM1,I,J,JJ +! + N = NN-1 ! + NM1 = N-1 ! + DO I = 1,N ! + XNI = FLOAT(NN-I) ! + HR(I) = XNI*PR(I)/FLOAT(N) ! + HI(I) = XNI*PI(I)/FLOAT(N) ! + END DO ! +! + DO JJ = 1,L1 ! +! + IF (CMOD(HR(N),HI(N)) <= ETA*TEN*CMOD(PR(N),PI(N))) & ! + GO TO 30 ! + CALL CDIVID(-PR(NN),-PI(NN),HR(N),HI(N),TR,TI) ! + DO I = 1,NM1 ! + J = NN-I ! + T1 = HR(J-1) ! + T2 = HI(J-1) ! + HR(J) = TR*T1-TI*T2+PR(J) ! + HI(J) = TR*T2+TI*T1+PI(J) ! + END DO ! + HR(1) = PR(1) ! + HI(1) = PI(1) ! + GO TO 50 ! +! +! If the constant term is essentially zero, shift H coefficients +! + 30 DO I = 1,NM1 ! + J = NN-I ! + HR(J) = HR(J-1) ! + HI(J) = HI(J-1) ! + END DO ! + HR(1) = ZERO ! + HI(1) = ZERO ! + 50 CONTINUE ! +! + END DO ! +! + END SUBROUTINE NOSHFT +! +!======================================================================= +! + SUBROUTINE FXSHFT(L2,ZR,ZI,CONV) +! +! Computes L2 fixed-shift H polynomials and tests for +! convergence. +! Initiates a variable-shift iteration and returns with the +! approximate zero if successful. +! +! L2 : limit of fixed shift steps +! ZR,ZI : approximate zero if conv is .TRUE. +! CONV : logical indicating convergence of stage 3 iteration +! +! +! Last Modified : 18 Jun 2020 by D. Sébilleau +! +! + USE CPOLY_VAR + USE REAL_NUMBERS, ONLY : HALF +! + IMPLICIT NONE +! + REAL (WP) :: ZR,ZI,OTR,OTI,SVSR,SVSI +! + INTEGER :: L2,N,J,I +! + LOGICAL :: CONV,TEST,PASD,BOOL +! + N = NN-1 ! +! +! Evaluate P at S +! + CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI) ! + TEST = .TRUE. ! + PASD = .FALSE. ! +! +! Calculate first T = -P(S)/H(S) +! + CALL CALCT(BOOL) ! +! +! Main loop for one second stage step +! + DO J = 1,L2 ! +! + OTR = TR ! + OTI = TI ! +! +! Compute next H polynomial and new T +! + CALL NEXTH(BOOL) ! + CALL CALCT(BOOL) ! + ZR = SR+TR ! + ZI = SI+TI ! +! +! Test for convergence unless stage 3 has failed once or this +! is the last H polynomial . +! + IF ( BOOL .OR. .NOT. TEST .OR. J .EQ. L2) GO TO 50 ! + IF (CMOD(TR-OTR,TI-OTI) >= HALF*CMOD(ZR,ZI)) GO TO 40 ! + IF (.NOT. PASD) GO TO 30 ! +! +! The weak convergence test has been passed twice, start the +! third stage iteration, after saving the current H polynomial +! and shift +! + DO I = 1,N ! + SHR(I) = HR(I) ! + SHI(I) = HI(I) ! + END DO ! + SVSR = SR ! + SVSI = SI ! + CALL VRSHFT(10,ZR,ZI,CONV) ! + IF (CONV) RETURN ! +! +! The iteration failed to converge. turn off testing and restore +! H,S,PV and T +! + TEST = .FALSE. ! + DO I = 1,N ! + HR(I) = SHR(I) ! + HI(I) = SHI(I) ! + END DO ! + SR = SVSR ! + SI = SVSI ! + CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI) ! + CALL CALCT(BOOL) ! + GO TO 50 ! +! + 30 PASD = .TRUE. ! + GO TO 50 ! +! + 40 PASD = .FALSE. ! + 50 CONTINUE ! +! + END DO ! +! +! Attempt an iteration with final H polynomial from second stage +! + CALL VRSHFT(10,ZR,ZI,CONV) ! +! + END SUBROUTINE FXSHFT +! +!======================================================================= +! + SUBROUTINE VRSHFT(L3,ZR,ZI,CONV) +! +! Carries out the third stage iteration. +! +! L3 : limit of steps in stage 3. +! ZR,ZI : on entry contains the initial iterate, if the +! iteration converges it contains the final iterate +! on exit. +! CONV : .TRUE. if iteration converges +! +! +! Last Modified : 18 Jun 2020 by D. Sébilleau +! +! + USE CPOLY_VAR + USE REAL_NUMBERS, ONLY : ONE +! + IMPLICIT NONE +! + REAL (WP) :: ZR,ZI,MP,MS,OMP,RELSTP + REAL (WP) :: R1,R2,TP +! + REAL (WP) :: SQRT +! + INTEGER :: L3,I,J +! + LOGICAL :: CONV,B,BOOL +! + CONV = .FALSE. ! + B = .FALSE. ! + SR = ZR ! + SI = ZI ! +! +! Main loop for stage three +! + DO I = 1,L3 ! +! +! Evaluate P at S and test for convergence +! + CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI) ! + MP = CMOD(PVR,PVI) ! + MS = CMOD(SR,SI) ! + IF (MP > 20.0E0_WP*ERREV(NN,QPR,QPI,MS,MP,ARE,MRE)) & ! + GO TO 10 ! +! +! Polynomial value is smaller in value than a bound on the error +! in evaluating P, terminate the iteration +! + CONV = .TRUE. ! + ZR = SR ! + ZI = SI ! + RETURN ! +! + 10 IF (I == 1) GO TO 40 ! + IF (B .OR. MP < OMP .OR. RELSTP >= 0.05E0_WP) & ! + GO TO 30 ! +! +! Iteration has stalled. Probably a cluster of zeros. Do 5 fixed +! shift steps into the cluster to force one zero to dominate +! + TP = RELSTP ! + B = .TRUE. ! + IF (RELSTP < ETA) TP = ETA ! + R1 = SQRT(TP) ! + R2 = SR*(ONE+R1)-SI*R1 ! + SI = SR*R1+SI*(ONE+R1) ! + SR = R2 ! + CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI) ! + DO J = 1,5 ! + CALL CALCT(BOOL) ! + CALL NEXTH(BOOL) ! + END DO ! + OMP = INFIN ! + GO TO 50 ! +! +! Exit if polynomial value increases significantly +! + 30 IF (MP*0.1E0_WP > OMP) RETURN ! + 40 OMP = MP ! +! +! Calculate next iterate +! + 50 CALL CALCT(BOOL) ! + CALL NEXTH(BOOL) ! + CALL CALCT(BOOL) ! +! + IF (BOOL) GO TO 60 ! +! + RELSTP = CMOD(TR,TI)/CMOD(SR,SI) ! + SR = SR+TR ! + SI = SI+TI ! + 60 CONTINUE ! + END DO ! +! + END SUBROUTINE VRSHFT +! +!======================================================================= +! + SUBROUTINE CALCT(BOOL) +! +! Computes T = -P(S)/H(S). +! +! BOOL : logical, set true if H(S) is essentially zero. +! +! +! Last Modified : 18 Jun 2020 by D. Sébilleau +! +! + USE CPOLY_VAR + USE REAL_NUMBERS, ONLY : ZERO,TEN +! + IMPLICIT NONE +! + REAL (WP) :: HVR,HVI +! + LOGICAL :: BOOL +! + INTEGER :: N +! + N = NN-1 ! +! +! +! Evaluate H(S) +! + CALL POLYEV(N,SR,SI,HR,HI,QHR,QHI,HVR,HVI) ! + BOOL = CMOD(HVR,HVI) <= ARE*TEN*CMOD(HR(N),HI(N)) ! +! + IF (BOOL) GO TO 10 ! +! + CALL CDIVID(-PVR,-PVI,HVR,HVI,TR,TI) ! + RETURN ! +! + 10 TR = ZERO ! + TI = ZERO ! +! + END SUBROUTINE CALCT +! +!======================================================================= +! + SUBROUTINE NEXTH(BOOL) +! +! Calculates the next shifted H polynomial. +! +! BOOL : logical, if .TRUE. H(S) is essentially zero +! +! +! Last Modified : 18 Jun 2020 by D. Sébilleau +! +! + USE CPOLY_VAR + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + REAL (WP) :: T1,T2 +! + LOGICAL :: BOOL +! + INTEGER :: N,NM1,J +! + N = NN-1 ! + NM1 = N-1 ! +! + IF (BOOL) GO TO 20 ! +! + DO J = 2,N ! + T1 = QHR(J-1) ! + T2 = QHI(J-1) ! + HR(J) = TR*T1-TI*T2+QPR(J) ! + HI(J) = TR*T2+TI*T1+QPI(J) ! + END DO ! +! + HR(1) = QPR(1) ! + HI(1) = QPI(1) ! + RETURN ! +! +! If H(S) is zero replace H with QH +! + 20 DO J = 2,N ! + HR(J) = QHR(J-1) ! + HI(J) = QHI(J-1) ! + END DO ! +! + HR(1) = ZERO ! + HI(1) = ZERO ! +! + END SUBROUTINE NEXTH +! +!======================================================================= +! + SUBROUTINE POLYEV(NN,SR,SI,PR,PI,QR,QI,PVR,PVI) +! +! Evaluates a polynomial P at S by the Horner recurrence +! Placing the partial sums in Q and the computed value in PV. +! +! +! + IMPLICIT NONE +! + REAL (WP) :: PR(NN),PI(NN),QR(NN),QI(NN) + REAL (WP) :: SR,SI,PVR,PVI,T +! + INTEGER :: NN,I +! + QR(1) = PR(1) ! + QI(1) = PI(1) ! + PVR = QR(1) ! + PVI = QI(1) ! + DO I = 2,NN ! + T = PVR*SR-PVI*SI+PR(I) ! + PVI = PVR*SI+PVI*SR+PI(I) ! + PVR = T ! + QR(I) = PVR ! + QI(I) = PVI ! + END DO ! +! + END SUBROUTINE POLYEV +! +!======================================================================= +! + FUNCTION ERREV(NN,QR,QI,MS,MP,ARE,MRE) +! +! Bounds the error in evaluating the polynomial by the Horner +! recurrence. +! +! QR,QI : the partial sums +! MS : modulus of the point +! MP : modulus of polynomial value +! ARE, MRE : error bounds on complex addition and multiplication +! +! +! + IMPLICIT NONE +! + REAL (WP) :: QR(NN),QI(NN),MS,MP,ARE,MRE,E + REAL (WP) :: ERREV +! + INTEGER :: NN,I +! + E = CMOD(QR(1),QI(1))*MRE/(ARE+MRE) ! +! + DO I = 1,NN ! + E = E*MS+CMOD(QR(I),QI(I)) ! + END DO ! +! + ERREV = E*(ARE+MRE)-MP*MRE ! +! + END FUNCTION ERREV +! +!======================================================================= +! + FUNCTION CAUCHY(NN,PT,Q) +! +! Cauchy computes a lower bound on the moduli of the zeros of a +! polynomial +! +! PT : modulus of the coefficients. +! +! Last Modified : 18 Jun 2020 by D. Sébilleau +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + REAL (WP) :: Q(NN),PT(NN),X,XM,F,DX,DF + REAL (WP) :: CAUCHY +! + REAL (WP) :: ABS,EXP,LOG,FLOAT +! + INTEGER :: NN,N,I +! + PT(NN) = -PT(NN) ! +! +! Compute upper estimate of bound +! + N = NN-1 ! + X = EXP( (LOG(-PT(NN)) - LOG(PT(1)))/FLOAT(N) ) ! +! + IF (PT(N) == ZERO) GO TO 20 ! +! +! If Newton step at the origin is better, use it +! + XM = -PT(NN)/PT(N) ! + IF (XM.LT.X) X=XM ! +! +! Chop the interval (0,X) until F <= 0 +! + 20 XM = X*0.1E0_WP ! + F = PT(1) ! + DO I = 2,NN ! + F = F*XM+PT(I) ! + END DO ! +! + IF (F <= ZERO) GO TO 40 ! +! + X = XM ! + GO TO 20 ! +! + 40 DX = X ! +! +! Do Newton iteration until X converges to two decimal places +! + 50 IF (ABS(DX/X) <= 0.005E0_WP) GO TO 70 ! +! + Q(1) = PT(1) ! + DO I = 2,NN ! + Q(I) = Q(I-1)*X+PT(I) ! + END DO ! +! + F = Q(NN) ! + DF = Q(1) ! + DO I = 2,N ! + DF = DF*X+Q(I) ! + END DO ! +! + DX = F/DF ! + X = X-DX ! + GO TO 50 ! +! + 70 CAUCHY = X ! +! + END FUNCTION CAUCHY +! +!======================================================================= +! + FUNCTION RESCALE(NN,PT,ETA,INFIN,SMALNO,BASE) +! +! Returns a scale factor to multiply the coefficients of the +! polynomial. The scaling is done to avoid overflow and to avoid +! undetected underflow interfering with the convergence +! criterion. The factor is a power of the base. +! +! PT : modulus of coefficients of P +! ETA,INFIN,SMALNO,BASE : constants describing the +! floating point arithmetic. +! +! Last Modified : 18 Jun 2020 by D. Sébilleau +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,HALF +! + IMPLICIT NONE +! + REAL (WP) :: PT(NN),ETA,INFIN,SMALNO,BASE + REAL (WP) :: RESCALE + REAL (WP) :: HI,LO,X,SC + REAL (WP) :: MAX,MIN,SQRT,LOG +! + INTEGER :: NN,I,L +! +! Find largest and smallest moduli of coefficients. +! + HI = SQRT(INFIN) ! + LO = SMALNO/ETA ! + MAX = ZERO ! + MIN = INFIN ! +! + DO I = 1,NN ! + X = PT(I) ! + IF (X > MAX) MAX = X ! + IF (X /= ZERO .AND. X < MIN) MIN = X ! + END DO ! +! +! Scale only if there are very large or very small components +! + RESCALE = ONE ! +! + IF (MIN >= LO .AND. MAX <= HI) RETURN ! +! + X = LO/MIN ! + IF (X > ONE) GO TO 20 ! +! + SC = ONE/(SQRT(MAX)*SQRT(MIN)) ! + GO TO 30 ! +! + 20 SC = X ! + IF (INFIN/SC > MAX) SC = ONE ! +! + 30 L = LOG(SC)/LOG(BASE) + HALF ! + RESCALE = BASE**L ! +! + END FUNCTION RESCALE +! +!======================================================================= +! + SUBROUTINE CDIVID(AR,AI,BR,BI,CR,CI) +! +! Complex division C = A/B, avoiding overflow. +! +! Last Modified : 18 Jun 2020 by D. Sébilleau +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + REAL (WP) :: AR,AI,BR,BI,CR,CI,R,D,T,INFIN + REAL (WP) :: ABS +! + IF (BR /= ZERO .OR. BI /= ZERO) GO TO 10 ! +! +! Division by zero, C = infinity +! + CALL MCON (T,INFIN,T,T) ! + CR = INFIN ! + CI = INFIN ! + RETURN ! +! + 10 IF (ABS(BR) >= ABS(BI)) GO TO 20 ! +! + R = BR/BI ! + D = BI+R*BR ! + CR = (AR*R+AI)/D ! + CI = (AI*R-AR)/D ! + RETURN ! +! + 20 R = BI/BR ! + D = BR+R*BI ! + CR = (AR+AI*R)/D ! + CI = (AI-AR*R)/D ! + RETURN ! +! + END SUBROUTINE CDIVID +! +!======================================================================= +! + FUNCTION CMOD(R,I) +! +! Modulus of a complex number avoiding overflow. +! +! +! Last Modified : 18 Jun 2020 by D. Sébilleau +! +! + USE REAL_NUMBERS, ONLY : ONE + USE SQUARE_ROOTS, ONLY : SQR2 +! + IMPLICIT NONE +! + REAL (WP) :: R,I,AR,AI + REAL (WP) :: CMOD +! + REAL (WP) :: ABS,SQRT +! + AR = ABS(R) ! + AI = ABS(I) ! +! + IF (AR >= AI) GO TO 10 ! +! + CMOD = AI*SQRT(ONE+(AR/AI)**2) ! + RETURN ! +! + 10 IF (AR <= AI) GO TO 20 ! +! + CMOD = AR*SQRT(ONE+(AI/AR)**2) ! + RETURN ! +! + 20 CMOD = AR*SQR2 ! + RETURN ! +! + END FUNCTION CMOD +! +!======================================================================= +! + SUBROUTINE MCON(ETA,INFINY,SMALNO,BASE) +! +! MCON provides machine constants used in various parts of the +! program. The user may either set them directly or use the +! statements below to compute them. The meaning of the four +! constants are: +! +! ETA : The maximum relative representation error +! which can be described as the smallest positive +! floating-point number such that 1.0D0 + ETA is +! greater than 1.0D0. +! INFINY : the largest floating-point number +! SMALNO : the smallest positive floating-point number +! BASE : the base of the floating-point number system used +! +! Let T be the number of base-digits in each floating-point +! number(DOUBLE PRECISION). Then ETA is either .5*B**(1-T) +! or B**(1-T) depending on whether rounding or truncation +! is used. +! +! Let M be the largest exponent and N the smallest exponent +! in the number system. Then INFINY is (1-BASE**(-T))*BASE**M +! and SMALNO IS BASE**N. +! +! The values for BASE,T,M,N below correspond to the ibm/360. +! +! +! Last Modified : 18 Jun 2020 by D. Sébilleau +! +! + USE REAL_NUMBERS, ONLY : ONE +! + IMPLICIT NONE +! + REAL (WP) :: ETA,INFINY,SMALNO,BASE +! + INTEGER :: M,N,T +! + BASE = 16.0E0_WP ! + T = 14 ! + M = 63 ! + N = -65 ! + ETA = BASE**(1-T) ! + INFINY = BASE*(ONE-BASE**(-T))*BASE**(M-1) ! + SMALNO = (BASE**(N+3))/BASE**3 ! +! + END SUBROUTINE MCON +! +END MODULE FIND_ZERO diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/integration.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/integration.f90 new file mode 100644 index 0000000..b148ff8 --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/integration.f90 @@ -0,0 +1,1132 @@ +! +!======================================================================= +! +MODULE INTEGRATION +! +! This module contains integration routines in order to integrate +! a function F over the interval [A,B]. +! +! These routines are: +! +! +! * Lagrange : INTEGR_L(F,DR,NSIZE,NMAX,A,ID) +! +! * N-point Gauss-Legendre : GAUSS_LEG(FCT,A,B,NGL,RES) +! +! * CERNLIB adaptive Gauss quadrature : DGAUSS1(OM,KK,A,B,EPS) +! +! * double exponential transformation : INTDE(F,A,B,EPS,I,ERR) +! +! * fast double exponential transformation: INTDE_F(F,A,B,AW,I,ERR) +! +! * Romberg : RBI1(FCT,A,B,PREC,OBTPREC,NITER,ITERMIN,ITERMAX) +! +! * Simpson : SIMPSON(FCT,A,B,N,RES) +! +! * : QANC8(FCT,A,B,AERR,RERR,RES,ERR,NBF,FLG) +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE INTEGR_L(F,DR,NSIZE,NMAX,A,ID) +! +!.....Based on Lagrange integration formula 25.4.12 +! +! (See Table 25.3 for numerical coefficients) - Chapter 25 of +! Abramowitz & Stegun, "Handbook of mathematical functions", +! page 886 (Dover) +! +! +! Input parameters: +! +! * F : function to be integrated +! * DR : constant grid step +! * NSIZE : dimensioning of the arrays +! * NMAX : index of upper limit of integration on the r mesh +! * ID : integer parameter +! ID = 1 --> F0 = 0 at the origin +! ID > 1 --> F0 not 0 at the origin +! +! +! Output parameters: +! +! * A : integral result +! +! +! --> Real function F case <-- +! +! Author : C. R. Natoli +! +! Last modified (DS) : 2 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,FIVE,NINE +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: F(NSIZE),DR + REAL (WP), INTENT(OUT) :: A +! + REAL (WP) :: H,A0,F0 + REAL (WP) :: S720,S251,S646,S264 + REAL (WP) :: S106,S19,S346,S456,S74,S11 +! + INTEGER, INTENT(IN) :: NSIZE,NMAX,ID +! + INTEGER :: K0,KX,K +! +! Coefficients given by table 25.3 p. 915: +! + S720 = 720.0E0_WP ! + S251 = 251.0E0_WP ! + S646 = 646.0E0_WP ! + S264 = 264.0E0_WP ! + S106 = 106.0E0_WP ! + S19 = 19.0E0_WP ! + S346 = 346.0E0_WP ! + S456 = 456.0E0_WP ! + S74 = 74.0E0_WP ! + S11 = 11.0E0_WP ! +! + H = DR ! + A0 = ZERO ! +! + IF(ID == 1) THEN ! + F0 = ZERO ! + K0 = 0 ! + ELSE ! + F0 = F(1) ! + K0 = 1 ! + END IF ! +! + KX = NMAX ! +! + A = A0 + H * ( S251 * F0 + S646 * F(K0+1) - & ! + S264 * F(K0+2) + S106 * F(K0+3) - & ! + S19 * F(K0+4) & ! + ) / S720 ! + A = A + H * ( -S19 * F0 + S346 * F(K0+1) + & ! + S456 * F(K0+2) - S74 * F(K0+3) + & ! + S11 * F(K0+4) & ! + ) / S720 ! + A = A + H * ( S11 * F0 - S74 * F(K0+1) + & ! + S456 * F(K0+2) + S346 * F(K0+3) - & ! + S19 * F(K0+4) & ! + ) / S720 ! +! + K0 = K0 + 4 ! +! + DO K = K0, KX ! + A = A + H * ( NINE * F(K) + 19.0E0_WP * F(K-1) - & ! + FIVE * F(K-2) + F(K-3) & ! + ) / 24.0E0_WP ! + END DO ! +! + END SUBROUTINE INTEGR_L +! +!======================================================================= +! + SUBROUTINE GAUSS_LEG(FCT,A,B,NGL,RES) +! +! This subroutine performs a Gauss-Legendre integration of +! the external function FCT +! +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: NGL +! + INTEGER :: J +! + REAL (WP), INTENT(IN) :: A,B + REAL (WP), INTENT(OUT) :: RES +! + REAL (WP) :: XGL(NGL),WGT(NGL) +! + REAL (WP), EXTERNAL :: FCT +! +! Construct Gauss-Legendre points from Numerical Recipes subroutine +! + CALL GAULEG(A,B,XGL,WGT,NGL) ! +! +! Performing the integral +! + RES = ZERO ! + DO J = 1, NGL ! + RES = RES + WGT(J) * FCT(XGL(J)) ! + END DO ! +! + END SUBROUTINE GAUSS_LEG +! +!======================================================================= +! + SUBROUTINE GAULEG(X1,X2,X,W,N) +! +! Given the lower and upper limits of integration X1 and X2, +! and given N, this routine returns arrays X[1..N] and W[1..N] +! of length N, containing the abscissas and weights +! of the Gauss-Legendre N-point quadrature formula +! +! This subroutine is taken from the book : +! +! "Numerical Recipes : The Art of Scientific +! Computing" par W.H. Press, B.P. Flannery, +! S.A. Teukolsky et W.T. Vetterling +! (Cambridge University Press 1992) +! +! p. 145 +! +! Input parameters: +! +! X1 : lower limit of integration +! X2 : upper limit of integration +! N : order of the Gauss-Legendre quadrature formula +! +! +! Output parameters: +! +! X : abscissas for Gauss-Legendre N-point quadrature formula +! W : weights for Gauss-Legendre N-point quadrature formula +! +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF,FOURTH + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + REAL (WP) :: X1,X2,X(N),W(N) + REAL (WP) :: EPS + REAL (WP) :: XM,XL,Z,Z1,P1,P2,P3,PP +! + REAL (WP) :: DCOS,DFLOAT,DABS +! + INTEGER N,M,I,J +! + EPS=3.0E-14_WP ! +! + M=(N+1)/2 ! the roots are symmetric + XM=HALF*(X2+X1) ! in the interval, so we only + XL=HALF*(X2-X1) ! have to find half of them +! +! Loop over the desired roots +! + DO I=1,M ! +! +! Starting with the approximation to the ith root, +! we enter the main loop of refinement by Newton’s method +! + Z=DCOS(PI*(DFLOAT(I)-FOURTH)/(DFLOAT(N)+HALF)) ! approx for ith root +! + 1 CONTINUE ! +! + P1=ONE ! + P2=ZERO ! +! +! Loop up the recurrence relation to get the +! Legendre polynomial evaluated at Z +! + DO J=1,N ! + P3=P2 ! + P2=P1 ! + P1=((TWO*DFLOAT(J)-ONE)*Z*P2-(DFLOAT(J)-ONE)*P3) & ! + /DFLOAT(J) ! + END DO ! +! +! P1 is now the desired Legendre polynomial. We next compute PP, +! its derivative,by a standard relation involving also P2, +! the polynomial of one lower order +! + PP=DFLOAT(N)*(Z*P1-P2)/(Z*Z-ONE) ! + Z1=Z ! + Z=Z1-P1/PP ! Newton’s method +! + IF(DABS(Z-Z1) > EPS) GO TO 1 ! +! +! Scale the root to the desired interval and put in +! its symmetric counterpart +! + X(I)=XM-XL*Z ! + X(N+1-I)=XM+XL*Z ! +! +! Compute the weight and its symmetric counterpart +! + W(I)=TWO*XL/((ONE-Z*Z)*PP*PP) ! + W(N+1-I)=W(I) ! +! + END DO ! +! + END SUBROUTINE GAULEG +! +!======================================================================= +! + FUNCTION DGAUSS1(FCT,OM,KK,A,B,EPS) +! +! ****************************************************************** +! +! ADAPTIVE GAUSSIAN QUADRATURE. +! +! GAUSS IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF +! THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER +! EPS. +! +! ****************************************************************** +! +! Originally written by K.S. Kölbig for CERNLIB +! +! First version: 12 May 1966 +! Revised : 15 Mar 1993 +! +! $Id: imp64.inc,v 1.1.1.1 1996/04/01 15:02:59 mclareni Exp $ +! +! $Log: imp64.inc,v $ +! Revision 1.1.1.1 1996/04/01 15:02:59 mclareni +! Mathlib gen +! +! +! imp64.inc +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FIVE +! + IMPLICIT NONE +! + REAL (WP) :: W(12),X(12) + REAL (WP) :: CONST,AA,BB,U,S8,S16,C1,C2,H + REAL (WP) :: Z1,HF,CST + REAL (WP) :: A,B,EPS + REAL (WP) :: DGAUSS1 + REAL (WP) :: OM +! + REAL (WP) :: FCT +! + REAL (WP) :: DABS +! + INTEGER :: I,KK + INTEGER :: LOGF +! + PARAMETER (Z1 = ONE, HF = Z1/TWO, CST = FIVE*Z1/1000.0E0_WP) ! +! + DATA X( 1) /9.6028985649753623E-01_WP/ ! + DATA X( 2) /7.9666647741362674E-01_WP/ ! + DATA X( 3) /5.2553240991632899E-01_WP/ ! + DATA X( 4) /1.8343464249564980E-01_WP/ ! + DATA X( 5) /9.8940093499164993E-01_WP/ ! + DATA X( 6) /9.4457502307323258E-01_WP/ ! + DATA X( 7) /8.6563120238783174E-01_WP/ ! + DATA X( 8) /7.5540440835500303E-01_WP/ ! + DATA X( 9) /6.1787624440264375E-01_WP/ ! + DATA X(10) /4.5801677765722739E-01_WP/ ! + DATA X(11) /2.8160355077925891E-01_WP/ ! + DATA X(12) /9.5012509837637440E-02_WP/ ! +! + DATA W( 1) /1.0122853629037626E-01_WP/ ! + DATA W( 2) /2.2238103445337447E-01_WP/ ! + DATA W( 3) /3.1370664587788729E-01_WP/ ! + DATA W( 4) /3.6268378337836198E-01_WP/ ! + DATA W( 5) /2.7152459411754095E-02_WP/ ! + DATA W( 6) /6.2253523938647893E-02_WP/ ! + DATA W( 7) /9.5158511682492785E-02_WP/ ! + DATA W( 8) /1.2462897125553387E-01_WP/ ! + DATA W( 9) /1.4959598881657673E-01_WP/ ! + DATA W(10) /1.6915651939500254E-01_WP/ ! + DATA W(11) /1.8260341504492359E-01_WP/ ! + DATA W(12) /1.8945061045506850E-01_WP/ ! +! + H=ZERO ! +! + LOGF=6 ! +! + IF(B == A) GO TO 99 ! +! + CONST=CST/DABS(B-A) ! + BB=A ! +! + 1 AA=BB ! + BB=B ! +! + 2 C1=HF*(BB+AA) ! + C2=HF*(BB-AA) ! +! + S8=ZERO ! + DO I = 1,4 ! + U=C2*X(I) ! + S8=S8+W(I)*(FCT(C1+U,OM,KK)+FCT(C1-U,OM,KK)) ! + END DO ! +! + S16=ZERO ! + DO I = 5,12 ! + U=C2*X(I) ! + S16=S16+W(I)*(FCT(C1+U,OM,KK)+FCT(C1-U,OM,KK)) ! + END DO ! + S16=C2*S16 ! +! + IF(DABS(S16-C2*S8) <= EPS*(ONE+DABS(S16))) THEN ! + H=H+S16 ! + IF(BB /= B) GO TO 1 ! + ELSE ! + BB=C1 ! + IF(ONE+CONST*DABS(C2) /= ONE) GO TO 2 ! + H=ZERO ! +! + WRITE(LOGF,*)' DGAUSS: D103.1, too high accuracy required' ! + STOP ! +! + END IF ! +! + 99 DGAUSS1=H ! +! + END FUNCTION DGAUSS1 +! +!======================================================================= +! + SUBROUTINE INTDE(F,A,B,EPS,I,ERR) +! +! This subroutine is the integrator of f(x) over (a,b) +! +! +! Input parameters: +! +! * F : integrand f(x) +! * A : lower limit of integration +! * B : upper limit of integration +! * EPS : relative error requested +! +! +! Output variables: +! +! * I : approximation to the integral +! * ERR : estimate of the absolute error +! +! +! Remarks: +! +! function +! f(x) needs to be analytic over (a,b). +! relative error +! EPS is relative error requested excluding +! cancellation of significant digits. +! i.e. EPS means : (absolute error) / +! (integral_a^b |f(x)| dx). +! EPS does not mean : (absolute error) / I. +! error message +! ERR >= 0 : normal termination. +! ERR < 0 : abnormal termination (M >= MMAX). +! i.e. convergent error is detected : +! 1. f(x) or (d/dx)^n f(x) has +! discontinuous points or sharp +! peaks over (a,b). +! you must divide the interval +! (a,b) at this points. +! 2. relative error of f(x) is +! greater than eps. +! 3. f(x) has oscillatory factor +! and frequency of the oscillation +! is very high. +! +! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). +! You may use, copy, modify this code for any purpose and +! without fee. You may distribute this ORIGINAL package. +! +! +! Modified: D. Sébilleau 4 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF,FOURTH +! + IMPLICIT NONE +! + REAL (WP) :: A,B,EPS,I,ERR + REAL (WP) :: EFS,HOFF + REAL (WP) :: PI2,EPSLN,EPSH,H0,EHP,EHM,EPST,BA,IR,H + REAL (WP) :: IBACK,IRBACK,T,EP,EM,XW,XA,WG,FA,FB,ERRT + REAL (WP) :: ERRH,ERRD +! + REAL (WP), EXTERNAL :: F +! + REAL (WP) :: DATAN,DLOG,DSQRT,DEXP,DABS +! + INTEGER :: MMAX + INTEGER :: M +! +! ---- adjustable parameter ---- +! + MMAX = 256 ! + EFS = 0.1E0_WP ! + HOFF = 8.5E0_WP ! +! +! ------------------------------ +! + PI2 = TWO*DATAN(ONE) ! + EPSLN = ONE-DLOG(EFS*EPS) ! + EPSH = DSQRT(EFS*EPS) ! + H0 = HOFF/EPSLN ! + EHP = DEXP(H0) ! + EHM = ONE/EHP ! + EPST = DEXP(-EHM*EPSLN) ! + BA = B-A ! + IR = F((A+B)*HALF)*(BA*FOURTH) ! + I = IR*(TWO*PI2) ! + ERR = DABS(I)*EPST ! + H = TWO *H0 ! + M = 1 ! +! + 10 CONTINUE ! +! + IBACK = I ! + IRBACK = IR ! + T = H*HALF ! +! + 20 CONTINUE ! +! + EM = DEXP(T) ! + EP = PI2*EM ! + EM = PI2/EM ! +! + 30 CONTINUE ! +! + XW = ONE/(ONE+DEXP(EP-EM)) ! + XA = BA*XW ! + WG = XA*(ONE-XW) ! + FA = F(A+XA)*WG ! + FB = F(B-XA)*WG ! + IR = IR+(FA+FB) ! + I = I+(FA+FB)*(EP+EM) ! + ERRT = (DABS(FA)+DABS(FB))*(EP+EM) ! +! + IF(M == 1) ERR = ERR+ERRT*EPST ! +! + EP = EP*EHP ! + EM = EM*EHM ! +! + IF(ERRT > ERR .OR. XW > EPSH) GO TO 30 ! +! + T = T+H ! +! + IF(T < H0) GO TO 20 ! +! + IF(M == 1) THEN ! + ERRH = (ERR/EPST)*EPSH*H0 ! + ERRD = ONE + TWO*ERRH ! + ELSE ! + ERRD = H*(DABS(I-TWO*IBACK) + FOUR*DABS(IR-TWO*IRBACK)) ! + END IF ! +! + H = H*HALF ! + M = M*2 ! +! + IF(ERRD > ERRH .AND. M < MMAX) GO TO 10 ! +! + I = I*H ! +! + IF(ERRD > ERRH) THEN ! + ERR = -ERRD*M ! + ELSE ! + ERR = ERRH*EPSH*M / (TWO*EFS) ! + END IF ! +! + END SUBROUTINE INTDE +! +!======================================================================= +! + SUBROUTINE INTDE_F(F,A,B,AW,I,ERR) +! +! This subroutine is the integrator of f(x) over (a,b) +! +! +! --> <-- +! --> This is the fast version <-- +! --> <-- +! +! +! Usage: +! +! CALL INTDEINI(LENAW,TINY,EPS,AW) ! initialization of AW +! ... +! CALL INTDE_F(F,A,B,AW,I,ERR) +! +! +! Input parameters: +! +! * F : integrand f(x) +! * A : lower limit of integration +! * B : upper limit of integration +! * AW : points and weights of the quadrature +! formula, AW(0...LENAW-1) +! +! +! Output variables: +! +! * I : approximation to the integral +! * ERR : estimate of the absolute error +! +! +! Remarks: +! +! initial parameters +! LENAW > 1000, +! IEEE double : +! LENAW = 8000 +! TINY = 1.0D-307 +! function +! f(x) needs to be analytic over (a,b). +! relative error +! EPS is relative error requested excluding +! cancellation of significant digits. +! i.e. EPS means : (absolute error) / +! (integral_a^b |f(x)| dx). +! EPS does not mean : (absolute error) / I. +! error message +! ERR >= 0 : normal termination. +! ERR < 0 : abnormal termination (M >= MMAX). +! i.e. convergent error is detected : +! 1. f(x) or (d/dx)^n f(x) has +! discontinuous points or sharp +! peaks over (a,b). +! you must divide the interval +! (a,b) at this points. +! 2. relative error of f(x) is +! greater than eps. +! 3. f(x) has oscillatory factor +! and frequency of the oscillation +! is very high. +! +! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). +! You may use, copy, modify this code for any purpose and +! without fee. You may distribute this ORIGINAL package. +! +! +! Modified: D. Sébilleau 4 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF +! + IMPLICIT NONE +! + REAL (WP) :: A,B,AW(0 : *),I,ERR + REAL (WP) :: EPSH,BA,IR,XA,FA,FB,ERRT,ERRH,ERRD,H,IBACK,IRBACK +! + REAL (WP), EXTERNAL :: F +! + REAL (WP) :: DABS +! + INTEGER :: NOFF,LENAWM,NK,K,J,JTMP,JM,M,KLIM +! + INTEGER :: INT +! + NOFF = 5 ! + LENAWM = INT(AW(0)+HALF) ! + NK = INT(AW(1)+HALF) ! + EPSH = AW(4) ! + BA = B - A ! + I = F((A+B) * AW(NOFF)) ! + IR = I * AW(NOFF+1) ! + I = I * AW(NOFF+2) ! + ERR = DABS(I) ! + K = NK + NOFF ! + J = NOFF ! +! + 10 CONTINUE ! +! + J = J + 3 ! + XA = BA * AW(J) ! + FA = F(A+XA) ! + FB = F(B-XA) ! + IR = IR + (FA+FB) * AW(J+1) ! + FA = FA * AW(J+2) ! + FB = FB * AW(J+2) ! + I = I + (FA+FB) ! + ERR = ERR + (DABS(FA)+DABS(FB)) ! +! + IF (AW(J) > EPSH .AND. J < K) GO TO 10 ! +! + ERRT = ERR * AW(3) ! + ERRH = ERR * EPSH ! + ERRD = ONE + TWO*ERRH ! + JTMP = J ! +! + DO WHILE (DABS(FA) > ERRT .AND. J < K) ! + J = J + 3 ! + FA = F(A + BA*AW(J)) ! + IR = IR + FA*AW(J+1) ! + FA = FA * AW(J+2) ! + I = I + FA ! + END DO ! +! + JM = J ! + J = JTMP ! +! + DO WHILE (DABS(FB) > ERRT .AND. J < K) ! + J = J + 3 ! + FB = F(B - BA*AW(J)) ! + IR = IR + FB*AW(J+1) ! + FB = FB * AW(J+2) ! + I = I + FB ! + END DO ! +! + IF(J < JM) JM = J ! +! + JM = JM - (NOFF+3) ! + H = ONE ! + M = 1 ! + KLIM = K + NK ! +! + DO WHILE (ERRD > ERRH .AND. KLIM <= LENAWM) ! + IBACK = I ! + IRBACK = IR ! +! + 20 CONTINUE ! +! + JTMP = K + JM ! + DO J = K + 3, JTMP, 3 ! + XA = BA*AW(J) ! + FA = F(A + XA) ! + FB = F(B - XA) ! + IR = IR + (FA + FB)*AW(J+1) ! + I = I + (FA + FB)*AW(J+2) ! + END DO ! +! + K = K + NK ! + J = JTMP ! +! + 30 CONTINUE ! +! + J = J + 3 ! + FA = F(A + BA*AW(J)) ! + IR = IR + FA*AW(J+1) ! + FA = FA * AW(J+2) ! + I = I + FA ! +! + IF(DABS(FA) > ERRT .AND. J < K) GO TO 30 ! +! + J = JTMP ! +! + 40 CONTINUE ! +! + J = J + 3 ! + FB = F(B - BA*AW(J)) ! + IR = IR + FB*AW(J+1) ! + FB = FB * AW(J+2) ! + I = I + FB ! +! + IF(DABS(FB) > ERRT .AND. J < K) GO TO 40 ! +! + IF(K < KLIM) GO TO 20 ! +! + ERRD = H * (DABS(I-2*IBACK) + DABS(IR-2*IRBACK)) ! + H = H * HALF ! + M = M * 2 ! + KLIM = 2*KLIM - NOFF ! + END DO ! +! + I = I * (H*BA) ! + IF(ERRD > ERRH) THEN ! + ERR = -ERRD * (M * DABS(BA)) ! + ELSE ! + ERR = ERR * AW(2)*(M * DABS(BA)) ! + END IF ! +! + END SUBROUTINE INTDE_F +! +!======================================================================= +! + SUBROUTINE INTDEINI_F(LENAW,TINY,EPS,AW) +! +! This subroutine calculates the points and weights of the quadrature +! formula +! +! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). +! You may use, copy, modify this code for any purpose and +! without fee. You may distribute this ORIGINAL package. +! +! +! Modified: D. Sébilleau 4 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,HALF +! + IMPLICIT NONE +! + REAL (WP) :: TINY,EPS,AW(0 : LENAW - 1) + REAL (WP) :: EFS,HOFF + REAL (WP) :: PI2,TINYLN,EPSLN,H0,EHP,EHM,H,T,EP,EM,XW,WG +! + REAL (WP) :: DATAN,DLOG,DEXP,DSQRT +! + INTEGER :: LENAW + INTEGER :: NOFF,NK,K,J +! +! ---- adjustable parameter ---- +! + EFS = 0.1E0_WP ! + HOFF = 8.5E0_WP ! +! +! ------------------------------ +! + PI2 = TWO * DATAN(ONE) ! + TINYLN = -DLOG(TINY) ! + EPSLN = ZERO - DLOG(EFS*EPS) ! + H0 = HOFF / EPSLN ! + EHP = DEXP(H0) ! + EHM = ONE / EHP ! + AW(2) = EPS ! + AW(3) = DEXP(-EHM*EPSLN) ! + AW(4) = DSQRT(EFS*EPS) ! + NOFF = 5 ! + AW(NOFF) = HALF ! + AW(NOFF+1) = H0 ! + AW(NOFF+2) = PI2 * H0 * HALF ! + H = TWO ! + NK = 0 ! + K = NOFF + 3 ! +! + 10 CONTINUE ! +! + T = H * HALF ! +! + 20 CONTINUE ! +! + EM = DEXP(H0*T) ! + EP = PI2 * EM ! + EM = PI2 / EM ! + J = K ! +! + 30 CONTINUE ! +! + XW = ONE / (ONE + DEXP(EP-EM)) ! + WG = XW * (ONE-XW) * H0 ! + AW(J) = XW ! + AW(J+1) = WG * FOUR ! + AW(J+2) = WG * (EP+EM) ! + EP = EP * EHP ! + EM = EM * EHM ! + J = J + 3 ! +! + IF (EP < TINYLN .AND. J <= (LENAW-3)) GO TO 30 ! +! + T = T + H ! + K = K + NK ! +! + IF(T < ONE) GO TO 20 ! +! + H = H * HALF ! +! + IF(NK == 0) THEN ! + IF(J > (LENAW-6)) J = J - 3 ! + NK = J - NOFF ! + K = K + NK ! + AW(1) = NK ! + END IF ! +! + IF((2*K - NOFF - 3) <= LENAW) GO TO 10 ! +! + AW(0) = DFLOAT(K-3) ! +! + END SUBROUTINE INTDEINI_F +! +!======================================================================= +! + FUNCTION RBI1(FCT,A,B,PREC,OBTPREC,NITER,ITERMIN,ITERMAX) +! +!******************************************************* +!* Integral of a function FCT(X) by Romberg's method * +!* --------------------------------------------------- * +!* INPUTS: * +!* A begin value of x variable * +!* B end value of x variable * +!* PREC desired precision * +!* ITERMIN minimum number of iterations * +!* ITERMAX maximum number of iterations * +!* * +!* OUTPUTS: * +!* OBTPREC obtained precision for integral * +!* NITER number of iterations done * +!* INTEGRAL the integral of FCT(X) from a to b * +!* * +!******************************************************* +! +! Last modified: D. Sébilleau 5 June 2020 +! +! + USE DIMENSION_CODE, ONLY : MAXITER + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR +! +! + IMPLICIT NONE +! + REAL (WP) :: RBI1 + REAL (WP) :: A,B,PREC,OBTPREC + REAL (WP) :: T(0:MAXITER,0:MAXITER) + REAL (WP) :: PAS,R,S,TA +! + REAL (WP), EXTERNAL :: FCT +! + REAL (WP) :: DABS +! + INTEGER :: NITER,ITERMIN,ITERMAX,I,J +! + IF (ITERMAX > MAXITER) ITERMAX=MAXITER ! +! + R = FCT(A) ! + TA = (R + FCT(B) ) / TWO ! + NITER=0 ! + PAS=B-A ! + T(0,0)=TA*PAS ! + 100 NITER=NITER+1 ! + PAS=PAS/TWO ! + S=TA ! +! + DO I=1, 2**NITER-1 ! + S = S + FCT(A+PAS*I) ! + END DO ! +! + T(0,NITER)=S*PAS ! + R=ONE ! + DO I=1, NITER ! + R=R*FOUR ! + J=NITER-I ! + T(I,J)=(R*T(I-1,J+1) - T(I-1,J))/(R-ONE) ! + END DO ! +! + OBTPREC = DABS(T(NITER,0) - T(NITER-1,0)) ! +! + IF (NITER > ITERMAX) GO TO 200 ! + IF (NITER < ITERMIN) GO TO 100 ! + IF (OBTPREC > PREC) GO TO 100 ! +! + 200 RBI1 = T(NITER,0) ! +! + END FUNCTION RBI1 +! +!======================================================================= +! + SUBROUTINE SIMPSON(FCT,A,B,N,RES) +! +!******************************************************* +!* Integral of a function FCT(X) by Simpson's method * +!* --------------------------------------------------- * +!* INPUTS: * +!* A begin value of x variable * +!* B end value of x variable * +!* N number of integration steps * +!* * +!* OUTPUT: * +!* RES the integral of FCT(X) from a to b * +!* * +!******************************************************* +! + USE REAL_NUMBERS, ONLY : TWO,THREE +! + IMPLICIT NONE +! + REAL (WP) :: A,B,RES + REAL (WP) :: STEP,R +! + REAL (WP), EXTERNAL :: FCT +! + INTEGER :: N,I +! + STEP = (B-A)/TWO/N ! + R = FCT(A) ! + RES = (R+FCT(B))/TWO ! +! + DO I=1, 2*N-1 ! + R = FCT(A+I*STEP) ! + IF(MOD(I,2) /= 0) THEN ! + RES = RES + R + R ! + ELSE ! + RES = RES + R ! + END IF ! + END DO ! +! + RES = RES * STEP*TWO/THREE ! +! + END SUBROUTINE SIMPSON +! +!======================================================================= +! + SUBROUTINE QANC8 (FCT,A,B,AERR,RERR,RES,ERR,NBF,FLG) +! +! Integrate a real function FCT(X) from X = A to X = B, +! with given absolute and relative precisions, AERR, RERR. +! +! Inputs: +! +! FCT : external user-defined function for any X value +! in interval [A,B] +! A,B : limits of interval +! AERR,RERR : respectively absolute error and relative error +! required by user +! +! Outputs: +! +! RES : value of integral +! ERR : estimated error +! NBF : number of necessary FCT(X) evaluations +! FLG : indicator +! = 0.0 correct result +! = NNN.RRR no convergence du to a singularity +! the singular point abcissa is given by formula: +! XS = B-.RRR*(B-A) + +! Reference : +! +! G.E. Forsythe, Computer Methods for Mathematical +! Computations, Prentice-Hall, Inc. (1977) +! +! ----------------------------------------------------------------------- +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: A,B,AERR,RERR + REAL (WP), INTENT(OUT) :: RES,FLG + REAL (WP) :: ERR + REAL (WP) :: QR(31),F(16),X(16),FS(8,30),XS(8,30) + REAL (WP) :: W0,W1,W2,W3,W4 + REAL (WP) :: COR,SUM + REAL (WP) :: X0,QP,PAS1,PAS,QL,QN,QD,ERR1,TOL1 + REAL (WP) :: F0,TEMP + REAL (WP) :: DABS,MAX +! + REAL (WP), EXTERNAL :: FCT +! + INTEGER, INTENT(OUT) :: NBF + INTEGER :: LMIN,LMAX,LOUT,NMAX,NFIN + INTEGER :: L,NIM,J,I +! + LMIN = 1 ! + LMAX = 30 ! + LOUT = 6 ! + NMAX = 5000 ! + NFIN = NMAX-8*(LMAX-LOUT+2**(LOUT+1)) ! + W0 = 3956.E0_WP/14175.E0_WP ! + W1 = 23552.E0_WP/14175.E0_WP ! + W2 = -3712.E0_WP/14175.E0_WP ! + W3 = 41984.E0_WP/14175.E0_WP ! + W4 = -18160.E0_WP/14175.E0_WP ! + FLG = ZERO ! + RES = ZERO ! + COR = ZERO ! + ERR = ZERO ! + SUM = ZERO ! + NBF = 0 ! +! + IF (A == B) RETURN ! +! + L = 0 ! + NIM = 1 ! + X0 = A ! + X(16) = B ! + QP = ZERO ! + F0 = FCT(X0) ! + PAS1 = (B-A)/16.E0_WP ! + X(8) = (X0+X(16))*HALF ! + X(4) = (X0+X(8))*HALF ! + X(12) = (X(8)+X(16))*HALF ! + X(2) = (X0+X(4))*HALF ! + X(6) = (X(4)+X(8))*HALF ! + X(10) = (X(8)+X(12))*HALF ! + X(14) = (X(12)+X(16))*HALF ! +! + DO J = 2,16,2 ! + F(J) = FCT(X(J)) ! + END DO ! +! + NBF = 9 ! + 30 X(1) = (X0+X(2))*HALF ! + F(1) = FCT(X(1)) ! +! + DO J = 3,15,2 ! + X(J) = (X(J-1)+X(J+1))*HALF ! + F(J) = FCT(X(J)) ! + END DO +! + NBF = NBF+8 ! + PAS = (X(16)-X0)/16.E0_WP ! + QL = (W0*(F0+F(8))+W1*(F(1)+F(7))+W2*(F(2)+F(6)) & ! + +W3*(F(3)+F(5))+W4*F(4))*PAS ! + QR(L+1) = (W0*(F(8)+F(16))+W1*(F(9)+F(15)) & ! + +W2*(F(10)+F(14))+W3*(F(11)+F(13))+W4*F(12))*PAS ! + QN = QL + QR(L+1) ! + QD = QN - QP ! + SUM = SUM + QD ! + ERR1 = DABS(QD)/1023.E0_WP ! + TOL1 = MAX(AERR,RERR*DABS(SUM))*(PAS/PAS1) ! +! + IF (L < LMIN) GO TO 50 ! + IF (L >= LMAX) GO TO 62 ! + IF (NBF > NFIN) GO TO 60 ! + IF (ERR1 <= TOL1) GO TO 70 ! +! + 50 NIM = 2*NIM ! + L = L+1 ! +! + DO I = 1,8 ! + FS(I,L) = F(I+8) ! + XS(I,L) = X(I+8) ! + END DO ! +! + QP = QL ! +! + DO I = 1,8 ! + F(18-2*I) = F(9-I) ! + X(18-2*I) = X(9-I) ! + END DO ! +! + GO TO 30 ! +! + 60 NFIN = 2*NFIN ! + LMAX = LOUT ! + FLG = FLG + (B-X0)/(B-A) ! +! + GO TO 70 ! +! + 62 FLG = FLG + ONE ! + 70 RES = RES + QN ! + ERR = ERR + ERR1 ! + COR = COR + QD/1023.E0_WP ! +! + 72 IF (NIM == 2*(NIM/2)) GO TO 75 ! + NIM = NIM/2 ! + L = L-1 ! +! + GO TO 72 ! +! + 75 NIM = NIM+1 ! + IF (L <= 0) GO TO 80 ! + QP = QR(L) ! + X0 = X(16) ! + F0 = F(16) ! +! + DO I = 1,8 ! + F(2*I) = FS(I,L) ! + X(2*I) = XS(I,L) ! + END DO ! +! + GO TO 30 ! +! + 80 RES = RES + COR ! + IF (ERR == ZERO) RETURN ! + 82 TEMP = DABS(RES) + ERR ! + IF (TEMP /= DABS(RES)) RETURN ! + ERR = TWO*ERR ! +! + GO TO 82 ! +! + END SUBROUTINE QANC8 +! +END MODULE INTEGRATION diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/integration2.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/integration2.f90 new file mode 100644 index 0000000..193dc9d --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/integration2.f90 @@ -0,0 +1,877 @@ +! +!======================================================================= +! +MODULE INTEGRATION2 +! +! This module contains integration routines in order to integrate +! a function F over the interval [0,+INF]. +! +! These routines are: +! +! +! * Lagrange : INTEGR_L_0_INF(F,X1,NSIZE,NMAX1,ID,F_INF,HOP,A) +! +! * double exponential transformation : INTDEI(F,A,EPS,I,ERR) <-- standard version +! INTDEI_1(F,A,X,EPS,I,ERR) <-- 1-parameter version (X) +! INTDEI_2(F,A,X,Y,EPS,I,ERR) <-- 2-parameter version (X,Y) +! INTDEI_F(F,A,AW,I,ERR) <-- fast version +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE INTEGR_L_0_INF(F,X1,N_SIZE,NMAX1,ID,F_INF,HOP,A) +! +! This subroutine integrates from 0 to infinity a function f(x) +! defined by the arrays X and F up to NMAX and for which +! the asymptotic value at infinity F_INF is known. +! +! +! Input parameters: +! +! * F : function array +! * X1 : mesh array (constant step) +! * N_SIZE : dimensioning of the arrays +! * NMAX1 : index of upper limit of integration on the mesh +! * ID : integer parameter +! ID = 1 --> F0 = 0 at the origin +! ID > 1 --> F0 not 0 at the origin +! * F_INF : limit of f(x) for x --> infinity +! * HOP : hopping parameter defining the mesh X(NMAX) --> infinity +! +! +! Output parameters: +! +! * A : integral result +! +! +! Method: The integral is separated as +! +! / X1(NMAX) / + INF = X1(NMAX+NMAX/HOP) +! | | +! | f(x) dx + | f(x) dx +! | | +! / 0 / X1(NMAX) +! +! +! * The first integral is computed using Lagrange integration. +! * For the second integral, a new mesh containing NMAX/HOP points +! is constructed. This is done by a 5-point Lagrange interpolation +! from X1(NMAX-3*HOP), X1(NMAX-2*HOP), X1(NMAX-HOP), X1(NMAX) +! and X1(NMAX+NMAX/HOP) whose F value is taken as F_INF +! * Once the new F and X1 arrays are constructed, the second integral +! is also computed using a Lagrange integration. +! +! +! --> Real function F case <-- +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Aug 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE + USE INTEGRATION, ONLY : INTEGR_L + USE INTERPOLATION, ONLY : LAG_5P_INTERP +! + IMPLICIT NONE +! + REAL (WP) :: X1(N_SIZE),F(N_SIZE) ! 1st integral + REAL (WP) :: X2(NSIZE),G(NSIZE) ! 2nd integral + REAL (WP) :: XX(5),AA(5) ! interpolation points + REAL (WP) :: F_INF + REAL (WP) :: H1,H2 + REAL (WP) :: A1,A2,A +! + REAL (WP) :: DFLOAT +! + INTEGER :: N_SIZE,NMAX1,ID,HOP + INTEGER :: NMAX2,IP +! + H1=X1(2)-X1(1) ! step for 1st integral +! +! Computing the first integral +! + CALL INTEGR_L(F,H1,N_SIZE,NMAX1,A1,ID) ! +! + NMAX2=NMAX1/HOP ! nb of points of mesh X2 + H2=H1*HOP ! step for mesh X2 +! +! Defining the [ X(NMAX, + INF ] mesh +! + DO IP=1,NMAX2 ! + X2(IP)=X1(NMAX1)+DFLOAT(IP-1)*H2 ! + END DO ! +! +! Constructing the Lagrange interpolation points +! + XX(1)=X1(NMAX1-3*HOP) ! + XX(2)=X1(NMAX1-2*HOP) ! + XX(3)=X1(NMAX1-HOP) ! + XX(4)=X1(NMAX1) ! + XX(5)=X2(NMAX2) ! +! + AA(1)=F(NMAX1-3*HOP) ! + AA(2)=F(NMAX1-2*HOP) ! + AA(3)=F(NMAX1-HOP) ! + AA(4)=F(NMAX1) ! + AA(5)=F_INF ! +! +! Evaluating f(x) = G over the X2 mesh +! + DO IP=1,NMAX2 ! + G(IP)=LAG_5P_INTERP(XX,AA,X2(IP)) ! + END DO ! +! +! Computing the second integral +! + CALL INTEGR_L(G,H2,NSIZE,NMAX2,A2,1) ! +! + A=A1+A2 ! +! + END SUBROUTINE INTEGR_L_0_INF +! +!======================================================================= +! + SUBROUTINE INTDEI(F,A,EPS,I,ERR) +! +! This subroutine is the integrator of f(x) over (a,infinity) +! +! +! Input parameters: +! +! * F : integrand f(x) +! * A : lower limit of integration +! * EPS : relative error requested +! +! +! Output variables : +! +! * I : approximation to the integral +! * ERR : estimate of the absolute error +! +! +! Remarks: +! function +! f(x) needs to be analytic over (a,infinity). +! relative error +! EPS is relative error requested excluding +! cancellation of significant digits. +! i.e. EPS means : (absolute error) / +! (integral_a^infinity |f(x)| dx). +! EPS does not mean : (absolute error) / I. +! error message +! ERR >= 0 : normal termination. +! ERR < 0 : abnormal termination (m >= MMAX). +! i.e. convergent error is detected : +! 1. f(x) or (d/dx)^n f(x) has +! discontinuous points or sharp +! peaks over (a,infinity). +! you must divide the interval +! (a,infinity) at this points. +! 2. relative error of f(x) is +! greater than EPS. +! 3. f(x) has oscillatory factor +! and decay of f(x) is very slow +! as x -> infinity. +! is very high. +! +! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). +! You may use, copy, modify this code for any purpose and +! without fee. You may distribute this ORIGINAL package. +! +! +! Modified: D. Sébilleau 4 Aug 2020 +! +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF +! + IMPLICIT NONE +! + REAL (WP) :: A,EPS,I,ERR + REAL (WP) :: EFS,HOFF + REAL (WP) :: PI4,EPSLN,EPSH,H0,EHP,EHM,EPST,IR,H,IBACK + REAL (WP) :: IRBACK,T,EP,EM,XP,XM,FP,FM,ERRT,ERRH,ERRD +! + REAL (WP), EXTERNAL :: F +! + REAL (WP) :: DATAN,DLOG,DSQRT,DEXP,DABS +! + INTEGER :: MMAX + INTEGER :: M +! +! ---- adjustable parameter ---- +! + MMAX = 256 ! + EFS = 0.1E0_WP ! + HOFF = 11.0E0_WP ! +! +! ------------------------------ +! + PI4 = DATAN(ONE) ! + EPSLN = ONE - DLOG(EFS*EPS) ! + EPSH = DSQRT(EFS*EPS) ! + H0 = HOFF /EPSLN ! + EHP = DEXP(H0) ! + EHM = ONE/EHP ! + EPST = DEXP(-EHM*EPSLN) ! + IR = F(A+1) ! + I = IR*(TWO*PI4) ! + ERR = DABS(I)*EPST ! + H = TWO*H0 ! + M = 1 ! +! + 10 CONTINUE ! +! + IBACK = I ! + IRBACK = IR ! + T = H * HALF ! +! + 20 CONTINUE ! +! + EM = DEXP(T) ! + EP = PI4 * EM ! + EM = PI4 / EM ! +! + 30 CONTINUE ! +! + XP = DEXP(EP-EM) ! + XM = ONE/XP ! + FP = F(A+XP)*XP ! + FM = F(A+XM)*XM ! + IR = IR+(FP+FM) ! + I = I+(FP+FM)*(EP+EM) ! + ERRT = (DABS(FP)+DABS(FM))*(EP+EM) ! +! + IF(M == 1) ERR = ERR+ERRT*EPST ! +! + EP = EP*EHP ! + EM = EM*EHM ! +! + IF(ERRT > ERR .OR. XM > EPSH) GO TO 30 ! +! + T = T+H ! +! + IF(T < H0) GO TO 20 ! +! + IF(M == 1) THEN ! + ERRH = (ERR/EPST)*EPSH*H0 ! + ERRD = ONE+TWO*ERRH ! + ELSE ! + ERRD = H*(DABS(I-TWO*IBACK)+FOUR*DABS(IR-TWO*IRBACK)) ! + END IF ! +! + H = H*HALF ! + M = M*2 ! +! + IF(ERRD > ERRH .AND. M < MMAX) GO TO 10 ! + I = I*H ! + IF(ERRD > ERRH) THEN ! + ERR = -ERRD*M ! + ELSE ! + ERR = ERRH*EPSH*M / (TWO*EFS) ! + END IF ! +! + END SUBROUTINE INTDEI +! +!======================================================================= +! + SUBROUTINE INTDEI_1(F,A,X,EPS,I,ERR) +! +! This subroutine is the integrator of f(x) over (a,infinity) +! with ONE extra parameter in the definition of the integrand +! +! +! Input parameters: +! +! * F : integrand f(x) +! * A : lower limit of integration +! * X : extra parameter of F +! * EPS : relative error requested +! +! +! Output variables : +! +! * I : approximation to the integral +! * ERR : estimate of the absolute error +! +! +! Remarks: +! function +! f(x) needs to be analytic over (a,infinity). +! relative error +! EPS is relative error requested excluding +! cancellation of significant digits. +! i.e. EPS means : (absolute error) / +! (integral_a^infinity |f(x)| dx). +! EPS does not mean : (absolute error) / I. +! error message +! ERR >= 0 : normal termination. +! ERR < 0 : abnormal termination (m >= MMAX). +! i.e. convergent error is detected : +! 1. f(x) or (d/dx)^n f(x) has +! discontinuous points or sharp +! peaks over (a,infinity). +! you must divide the interval +! (a,infinity) at this points. +! 2. relative error of f(x) is +! greater than EPS. +! 3. f(x) has oscillatory factor +! and decay of f(x) is very slow +! as x -> infinity. +! is very high. +! +! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). +! You may use, copy, modify this code for any purpose and +! without fee. You may distribute this ORIGINAL package. +! +! +! Last modified: D. Sébilleau 4 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF +! + IMPLICIT NONE +! + REAL (WP) :: A,X,EPS,I,ERR + REAL (WP) :: EFS,HOFF + REAL (WP) :: PI4,EPSLN,EPSH,H0,EHP,EHM,EPST,IR,H,IBACK + REAL (WP) :: IRBACK,T,EP,EM,XP,XM,FP,FM,ERRT,ERRH,ERRD +! + REAL (WP), EXTERNAL :: F +! + REAL (WP) :: DATAN,DLOG,DSQRT,DEXP,DABS +! + INTEGER :: MMAX + INTEGER :: M +! +! ---- adjustable parameter ---- +! + MMAX = 256 ! + EFS = 0.1E0_WP ! + HOFF = 11.0E0_WP ! +! +! ------------------------------ +! + PI4 = DATAN(ONE) ! + EPSLN = ONE - DLOG(EFS*EPS) ! + EPSH = DSQRT(EFS*EPS) ! + H0 = HOFF /EPSLN ! + EHP = DEXP(H0) ! + EHM = ONE/EHP ! + EPST = DEXP(-EHM*EPSLN) ! + IR = F(A+1,X) ! + I = IR*(TWO*PI4) ! + ERR = DABS(I)*EPST ! + H = TWO*H0 ! + M = 1 ! +! + 10 CONTINUE ! +! + IBACK = I ! + IRBACK = IR ! + T = H * HALF ! +! + 20 CONTINUE ! +! + EM = DEXP(T) ! + EP = PI4 * EM ! + EM = PI4 / EM ! +! + 30 CONTINUE ! +! + XP = DEXP(EP-EM) ! + XM = ONE/XP ! + FP = F(A+XP,X)*XP ! + FM = F(A+XM,X)*XM ! + IR = IR+(FP+FM) ! + I = I+(FP+FM)*(EP+EM) ! + ERRT = (DABS(FP)+DABS(FM))*(EP+EM) ! +! + IF(M == 1) ERR = ERR+ERRT*EPST ! +! + EP = EP*EHP ! + EM = EM*EHM ! +! + IF(ERRT > ERR .OR. XM > EPSH) GO TO 30 ! +! + T = T+H ! +! + IF(T < H0) GO TO 20 ! +! + IF(M == 1) THEN ! + ERRH = (ERR/EPST)*EPSH*H0 ! + ERRD = ONE+TWO*ERRH ! + ELSE ! + ERRD = H*(DABS(I-TWO*IBACK)+FOUR*DABS(IR-TWO*IRBACK)) ! + END IF ! +! + H = H*HALF ! + M = M*2 ! +! + IF(ERRD > ERRH .AND. M < MMAX) GO TO 10 ! + I = I*H ! + IF(ERRD > ERRH) THEN ! + ERR = -ERRD*M ! + ELSE ! + ERR = ERRH*EPSH*M / (TWO*EFS) ! + END IF ! +! + END SUBROUTINE INTDEI_1 +! +!======================================================================= +! + SUBROUTINE INTDEI_2(F,A,X,Y,EPS,I,ERR) +! +! This subroutine is the integrator of f(x) over (a,infinity) +! with TWO extra parameters in the definition of the integrand +! +! +! Input parameters: +! +! * F : integrand f(x) +! * A : lower limit of integration +! * X : first extra parameter of F +! * Y : second extra parameter of F +! * EPS : relative error requested +! +! +! Output variables : +! +! * I : approximation to the integral +! * ERR : estimate of the absolute error +! +! +! Remarks: +! function +! f(x) needs to be analytic over (a,infinity). +! relative error +! EPS is relative error requested excluding +! cancellation of significant digits. +! i.e. EPS means : (absolute error) / +! (integral_a^infinity |f(x)| dx). +! EPS does not mean : (absolute error) / I. +! error message +! ERR >= 0 : normal termination. +! ERR < 0 : abnormal termination (m >= MMAX). +! i.e. convergent error is detected : +! 1. f(x) or (d/dx)^n f(x) has +! discontinuous points or sharp +! peaks over (a,infinity). +! you must divide the interval +! (a,infinity) at this points. +! 2. relative error of f(x) is +! greater than EPS. +! 3. f(x) has oscillatory factor +! and decay of f(x) is very slow +! as x -> infinity. +! is very high. +! +! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). +! You may use, copy, modify this code for any purpose and +! without fee. You may distribute this ORIGINAL package. +! +! +! Last modified: D. Sébilleau 4 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF +! + IMPLICIT NONE +! + REAL (WP) :: A,X,Y,EPS,I,ERR + REAL (WP) :: EFS,HOFF + REAL (WP) :: PI4,EPSLN,EPSH,H0,EHP,EHM,EPST,IR,H,IBACK + REAL (WP) :: IRBACK,T,EP,EM,XP,XM,FP,FM,ERRT,ERRH,ERRD +! + REAL (WP), EXTERNAL :: F +! + REAL (WP) :: DATAN,DLOG,DSQRT,DEXP,DABS +! + INTEGER :: MMAX + INTEGER :: M +! +! ---- adjustable parameter ---- +! + MMAX = 256 ! + EFS = 0.1E0_WP ! + HOFF = 11.0E0_WP ! +! +! ------------------------------ +! + PI4 = DATAN(ONE) ! + EPSLN = ONE - DLOG(EFS*EPS) ! + EPSH = DSQRT(EFS*EPS) ! + H0 = HOFF /EPSLN ! + EHP = DEXP(H0) ! + EHM = ONE/EHP ! + EPST = DEXP(-EHM*EPSLN) ! + IR = F(A+1,X,Y) ! + I = IR*(TWO*PI4) ! + ERR = DABS(I)*EPST ! + H = TWO*H0 ! + M = 1 ! +! + 10 CONTINUE ! +! + IBACK = I ! + IRBACK = IR ! + T = H * HALF ! +! + 20 CONTINUE ! +! + EM = DEXP(T) ! + EP = PI4 * EM ! + EM = PI4 / EM ! +! + 30 CONTINUE ! +! + XP = DEXP(EP-EM) ! + XM = ONE/XP ! + FP = F(A+XP,X,Y)*XP ! + FM = F(A+XM,X,Y)*XM ! + IR = IR+(FP+FM) ! + I = I+(FP+FM)*(EP+EM) ! + ERRT = (DABS(FP)+DABS(FM))*(EP+EM) ! +! + IF(M == 1) ERR = ERR+ERRT*EPST ! +! + EP = EP*EHP ! + EM = EM*EHM ! +! + IF(ERRT > ERR .OR. XM > EPSH) GO TO 30 ! +! + T = T+H ! +! + IF(T < H0) GO TO 20 ! +! + IF(M == 1) THEN ! + ERRH = (ERR/EPST)*EPSH*H0 ! + ERRD = ONE+TWO*ERRH ! + ELSE ! + ERRD = H*(DABS(I-TWO*IBACK)+FOUR*DABS(IR-TWO*IRBACK)) ! + END IF ! +! + H = H*HALF ! + M = M*2 ! +! + IF(ERRD > ERRH .AND. M < MMAX) GO TO 10 ! + I = I*H ! + IF(ERRD > ERRH) THEN ! + ERR = -ERRD*M ! + ELSE ! + ERR = ERRH*EPSH*M / (TWO*EFS) ! + END IF ! +! + END SUBROUTINE INTDEI_2 +! +!======================================================================= +! + SUBROUTINE INTDEI_F(F,A,AW,I,ERR) +! +! This subroutine is the integrator of f(x) over (a,infinity) +! +! +! +! --> <-- +! --> This is the fast version <-- +! --> <-- +! +! +! Usage: +! +! CALL INTDEIINI(LENAW,TINY,EPS,AW) ! initialization of AW +! ... +! CALL INTDEI_F(F,A,AW,I,ERR) +! +! +! Input parameters: +! +! * F : integrand f(x) +! * A : lower limit of integration +! * AW : points and weights of the quadrature +! formula, AW(0...LENAW-1) +! +! +! Output variables : +! +! * I : approximation to the integral +! * ERR : estimate of the absolute error +! +! +! Remarks: +! +! initial parameters +! LENAW > 1000, +! IEEE double : +! LENAW = 8000 +! TINY = 1.0D-307 +! function +! f(x) needs to be analytic over (a,infinity). +! relative error +! EPS is relative error requested excluding +! cancellation of significant digits. +! i.e. EPS means : (absolute error) / +! (integral_a^infinity |f(x)| dx). +! EPS does not mean : (absolute error) / I. +! error message +! ERR >= 0 : normal termination. +! ERR < 0 : abnormal termination (m >= MMAX). +! i.e. convergent error is detected : +! 1. f(x) or (d/dx)^n f(x) has +! discontinuous points or sharp +! peaks over (a,infinity). +! you must divide the interval +! (a,infinity) at this points. +! 2. relative error of f(x) is +! greater than EPS. +! 3. f(x) has oscillatory factor +! and decay of f(x) is very slow +! as x -> infinity. +! is very high. +! +! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). +! You may use, copy, modify this code for any purpose and +! without fee. You may distribute this ORIGINAL package. +! +! +! Modified: D. Sébilleau 4 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF +! + IMPLICIT NONE +! + REAL (WP) :: A,AW(0 : *),I,ERR + REAL (WP) :: EPSH,IR,FP,FM,ERRT,ERRH,ERRD + REAL (WP) :: H,IBACK,IRBACK +! + REAL (WP), EXTERNAL :: F +! + REAL (WP) :: DABS +! + INTEGER :: NOFF,LENAWM,NK,K,J,JTMP,JM,M,KL,KLIM +! + INTEGER :: INT +! + NOFF = 5 ! + LENAWM = INT(AW(0) + HALF) ! + NK = INT(AW(1) + HALF) ! + EPSH = AW(4) ! + I = F(A + AW(NOFF)) ! + IR = I * AW(NOFF+1) ! + I = I * AW(NOFF+2) ! + ERR = DABS(I) ! + K = NK + NOFF ! + J = NOFF ! +! + 10 CONTINUE ! +! + J = J + 6 ! + FM = F(A + AW(J)) ! + FP = F(A + AW(J+1)) ! + IR = IR + (FM*AW(J+2) + FP*AW(J+3)) ! + FM = FM * AW(J+4) ! + FP = FP * AW(J+5) ! + I = I + (FM+FP) ! + ERR = ERR + (DABS(FM)+DABS(FP)) ! +! + IF(AW(J) > EPSH .AND. J < K) GO TO 10 ! +! + ERRT = ERR * AW(3) ! + ERRH = ERR * EPSH ! + ERRD = ONE + TWO*ERRH ! + JTMP = J ! +! + DO WHILE (DABS(FM) > ERRT .AND. J < K) ! + J = J + 6 ! + FM = F(A + AW(J)) ! + IR = IR + FM*AW(J+2) ! + FM = FM * AW(J+4) ! + I = I + FM ! + END DO ! +! + JM = J ! + J = JTMP ! +! + DO WHILE (DABS(FP) > ERRT .AND. J < K) ! + J = J + 6 ! + FP = F(A + AW(J+1)) ! + IR = IR + FP*AW(J+3) ! + FP = FP * AW(J+5) ! + I = I + FP ! + END DO ! +! + IF(J < JM) JM = J ! +! + JM = JM - (NOFF+6) ! + H = ONE ! + M = 1 ! + KLIM = K + NK ! +! + DO WHILE (ERRD > ERRH .AND. KLIM <= LENAWM) ! + IBACK = I ! + IRBACK = IR ! +! + 20 CONTINUE ! +! + JTMP = K + JM ! +! + DO J = K+6,JTMP,6 ! + FM = F(A + AW(J)) ! + FP = F(A + AW(J+1)) ! + IR = IR + (FM*AW(J+2) + FP*AW(J+3)) ! + I = I + (FM*AW( +4) + FP*AW(J+5)) ! + END DO ! +! + K = K + NK ! + J = JTMP ! +! + 30 CONTINUE ! +! + J = J + 6 ! + FM = F(A + AW(J)) ! + IR = IR + FM*AW(J+2) ! + FM = FM * AW(J+4) ! + I = I + FM ! +! + IF(DABS(FM) > ERRT .AND. J < K) GO TO 30 ! +! + J = JTMP ! +! + 40 CONTINUE ! +! + J = J + 6 ! + FP = F(A + AW(J+1)) ! + IR = IR + FP*AW(J+3) ! + FP = FP * AW(J+5) ! + I = I + FP ! +! + IF(DABS(FP) > ERRT .AND. J < K) GO TO 40 ! +! + IF(K < KLIM) GO TO 20 ! +! + ERRD = H * (DABS(I - 2*IBACK) + DABS(IR - 2*IRBACK)) ! + H = H * HALF ! + M = M * 2 ! + KLIM = 2*KLIM - NOFF ! + END DO ! +! + I = I * H ! +! + IF(ERRD > ERRH) THEN ! + ERR = -ERRD * M ! + ELSE ! + ERR = ERR * (AW(2)*M) ! + END IF ! +! + END SUBROUTINE INTDEI_F +! +!======================================================================= +! + SUBROUTINE INTDEIINI_F(LENAW,TINY,EPS,AW) +! +! This subroutine calculates the points and weights of the quadrature +! formula +! +! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). +! You may use, copy, modify this code for any purpose and +! without fee. You may distribute this ORIGINAL package. +! +! +! Modified: D. Sébilleau 5 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF +! + IMPLICIT NONE +! + REAL (WP) :: TINY,EPS,AW(0 : LENAW - 1) + REAL (WP) :: EFS,HOFF + REAL (WP) :: PI4,TINYLN,EPSLN,H0,EHP,EHM + REAL (WP) :: H,T,EP,EM,XP,XM,WWP,WWM +! + REAL (WP) :: DATAN,DLOG,DSQRT,DEXP,DFLOAT +! + INTEGER :: LENAW + INTEGER :: NOFF,NK,K,J +! +! ---- adjustable parameter ---- +! + EFS = 0.1E0_WP ! + HOFF = 11.0E0_WP ! +! +! ------------------------------ +! + PI4 = DATAN(ONE) ! + TINYLN = -DLOG(TINY) ! + EPSLN = ONE - DLOG(EFS*EPS) ! + H0 = HOFF / EPSLN ! + EHP = DEXP(H0) ! + EHM = ONE / EHP ! + AW(2) = EPS ! + AW(3) = DEXP(-EHM*EPSLN) ! + AW(4) = DSQRT(EFS*EPS) ! + NOFF = 5 ! + AW(NOFF) = ONE ! + AW(NOFF+1) = FOUR * H0 ! + AW(NOFF+2) = TWO * PI4 * H0 ! + H = TWO ! + NK = 0 ! + K = NOFF + 6 ! +! + 10 CONTINUE ! +! + T = H * HALF ! +! + 20 CONTINUE ! +! + EM = DEXP(H0*T) ! + EP = PI4 * EM ! + EM = PI4 / EM ! + J = K ! +! + 30 CONTINUE ! +! + XP = DEXP(EP-EM) ! + XM = ONE / XP ! + WWP= XP * ((EP+EM)*H0) ! + WWM= XM * ((EP+EM)*H0) ! + AW(J) = XM ! + AW(J+1) = XP ! + AW(J+2) = XM * (FOUR*H0) ! + AW(J+3) = XP * (FOUR*H0) ! + AW(J+4) = WWM ! + AW(J+5) = WWP ! + EP = EP * EHP ! + EM = EM * EHM ! + J = J + 6 ! +! + IF(EP < TINYLN .AND. J <= (LENAW-6)) GO TO 30 ! +! + T = T + H ! + K = K + NK ! +! + IF(T < ONE) GO TO 20 ! +! + H = H * HALF ! +! + IF(NK == 0) THEN ! + IF(J > (LENAW-12)) J = J - 6 ! + NK = J - NOFF ! + K = K + NK ! + AW(1) = NK ! + END IF ! +! + IF((2*K - NOFF - 6) <= LENAW) GO TO 10 ! +! + AW(0) = DFLOAT(K-6) ! +! + END SUBROUTINE INTDEIINI_F +! +END MODULE INTEGRATION2 diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/integration3.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/integration3.f90 new file mode 100644 index 0000000..cb293f5 --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/integration3.f90 @@ -0,0 +1,1044 @@ +! +!======================================================================= +! +MODULE INTEGRATION3 +! +! This module contains integration routines in order to integrate +! a function F over the interval [0,+INF] when f(x) has +! an oscillatory behaviour. + +! +! These routines are: +! +! * double exponential transformation : INTDEO(F,A,OMEGA,EPS,I,ERR) <-- standard version +! INTDEO_1(F,AA,A,OMEGA,EPS,I,ERR) <-- 1-parameter version (AA) +! INTDEO_2(F,AA,LL,A,OMEGA,EPS,I,ERR) <-- 2-parameter version (AA,LL) +! INTDEO_F(F,A,OMEGA,AW,I,ERR) <-- fast version ^ +! | + USE ACCURACY_REAL ! +! integer +CONTAINS +! +!======================================================================= +! + SUBROUTINE INTDEO(F,A,OMEGA,EPS,I,ERR) +! +! This subroutine is the integrator of f(x) over (a,infinity) when +! f(x) has an oscillatory behaviour: +! +! f(x) = g(x) * sin(omega * x + theta) as x -> infinity +! +! +! Input parameters: +! +! * F : integrand f(x) +! * A : lower limit of integration +! * OMEGA : frequency of oscillation +! * EPS : relative error requested +! +! +! Output variables: +! +! * I : approximation to the integral +! * ERR : estimate of the absolute error +! +! Remarks: +! function +! f(x) needs to be analytic over (a,infinity). +! relative error +! EPS is relative error requested excluding +! cancellation of significant digits. +! i.e. EPS means : (absolute error) / +! (integral_a^R |f(x)| dx). +! EPS does not mean : (absolute error) / I. +! error message +! ERR >= 0 : normal termination. +! ERR < 0 : abnormal termination (m >= MMAX). +! i.e. convergent error is detected : +! 1. f(x) or (d/dx)^n f(x) has +! discontinuous points or sharp +! peaks over (a,infinity). +! you must divide the interval +! (a,infinity) at this points. +! 2. relative error of f(x) is +! greater than EPS. +! +! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). +! You may use, copy, modify this code for any purpose and +! without fee. You may distribute this ORIGINAL package. +! +! +! Modified: D. Sébilleau 5 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF +! + IMPLICIT NONE +! + REAL (WP) :: A,OMEGA,EPS,I,ERR + REAL (WP) :: EFS,ENOFF,PQOFF,PPOFF + REAL (WP) :: PI4,EPSLN,EPSH,FRQ4,PER2,PP,PQ,EHP,EHM,IR,H + REAL (WP) :: IBACK,IRBACK,T,EP,EM,TK,XW,WG,XA,FP,FM,ERRH + REAL (WP) :: TN,ERRD +! + REAL (WP), EXTERNAL :: F +! + REAL (WP) :: DATAN,DLOG,DSQRT,DEXP,DABS +! + INTEGER :: MMAX,LMAX + INTEGER :: N,M,L,K +! + INTEGER :: INT +! +! ---- adjustable parameter ---- +! + MMAX = 256 ! + LMAX = 5 ! + EFS = 0.1E0_WP ! + ENOFF = 0.40E0_WP ! + PQOFF = 2.9E0_WP ! + PPOFF = -0.72E0_WP ! +! +! ------------------------------ +! + PI4 = DATAN(ONE) ! + EPSLN = ONE - DLOG(EFS*EPS) ! + EPSH = DSQRT(EFS*EPS) ! + N = INT(ENOFF*EPSLN) ! + FRQ4 = DABS(OMEGA) / (TWO*PI4) ! + PER2 = FOUR * PI4 / DABS(OMEGA) ! + PQ = PQOFF / EPSLN ! + PP = PPOFF - DLOG(PQ*PQ*FRQ4) ! + EHP = DEXP(TWO*PQ) ! + EHM = ONE / EHP ! + XW = DEXP(PP-TWO*PI4) ! + I = F(A + DSQRT(XW * (PER2*HALF))) ! + IR = I*XW ! + I = I*(PER2*HALF) ! + ERR = DABS(I) ! + H = 2 ! + M = 1 ! +! + 10 CONTINUE ! +! + IBACK = I ! + IRBACK = IR ! + T = H * HALF ! +! + 20 CONTINUE ! +! + EM = DEXP(TWO*PQ*T) ! + EP = PI4 * EM ! + EM = PI4 / EM ! + TK = T ! +! + 30 CONTINUE ! +! + XW = DEXP(PP-EP-EM) ! + WG = DSQRT(FRQ4*XW + TK*TK) ! + XA = XW / (TK+WG) ! + WG = (PQ*XW*(EP-EM)+XA) / WG ! + FM = F(A + XA) ! + FP = F(A + XA + PER2*TK) ! + IR = IR + (FP + FM)*XW ! + FM = FM * WG ! + FP = FP * (PER2-WG) ! + I = I + (FP+FM) ! +! + IF (M == 1) ERR = ERR + (DABS(FP) + DABS(FM)) ! + + EP = EP * EHP ! + EM = EM * EHM ! + TK = TK + ONE ! +! + IF (EP < EPSLN) GO TO 30 ! +! + IF (M == 1) THEN ! + ERRH = ERR * EPSH ! + ERR = ERR * EPS ! + END IF ! +! + TN = TK ! +! + DO WHILE(DABS(FM) > ERR) ! + XW = DEXP(PP-EP-EM) ! + XA = XW / TK * HALF ! + WG = XA * (ONE / TK + TWO*PQ*(EP - EM)) ! + FM = F(A + XA) ! + IR = IR + FM*XW ! + FM = FM * WG ! + I = I + FM ! + EP = EP * EHP ! + EM = EM * EHM ! + TK = TK + ONE ! + END DO ! +! + FM = F(A + PER2*TN) ! + EM = PER2 * FM ! + I = I + EM ! +! + IF(DABS(FP) > ERR .OR. DABS(EM) > ERR) THEN ! + L = 0 ! + 40 CONTINUE ! + L = L + 1 ! + TN = TN + N ! + EM = FM ! + FM = F(A + PER2*TN) ! + XA = FM ! + EP = FM ! + EM = EM + FM ! + XW = ONE ! + WG = ONE ! + DO K = 1, N-1 ! + XW = XW * (N+1-K) / K ! + WG = WG + XW ! + FP = F(A + PER2*(TN-K)) ! + XA = XA + FP ! + EP = EP + FP*WG ! + EM = EM + FP*XW ! + END DO ! + WG = PER2 * N / (WG*N + XW) ! + EM = WG * DABS(EM) ! + IF(EM <= ERR .OR. L >= LMAX) GO TO 50 ! + I = I + PER2*XA ! + GO TO 40 ! + 50 CONTINUE ! + I = I + WG*EP ! + IF(EM > ERR) ERR = EM ! + END IF ! +! + T = T + H ! +! + IF(T < ONE) GO TO 20 ! +! + IF(M == 1) THEN ! + ERRD = ONE + TWO*ERRH ! + ELSE ! + ERRD = H*(DABS(I-TWO*IBACK) + PQ*DABS(IR-TWO*IRBACK)) ! + END IF ! +! + H = H * HALF ! + M = M * 2 ! +! + IF(ERRD > ERRH .AND. M < MMAX) GO TO 10 ! +! + I = I*H ! +! + IF(ERRD > ERRH) THEN ! + ERR = -ERRD ! + ELSE ! + ERR = ERR * (M*HALF) ! + END IF ! +! + END SUBROUTINE INTDEO +! +!======================================================================= +! + SUBROUTINE INTDEO_1(F,G,AA,A,OMEGA,EPS,I,ERR) +! +! This subroutine is the integrator of g(x) over (a,infinity) when +! g(x) has an oscillatory behaviour: +! +! g(x) = f(x) * sin(omega * x + theta) * x, as x -> infinity +! +! +! This version: f(x) has ONE extra parameters: AA (real) +! +! so that f(x) = g(a*x) +! +! +! Input parameters: +! +! * F : integrand f(x) +! * AA : parameter used in function f +! * A : lower limit of integration +! * OMEGA : frequency of oscillation +! * EPS : relative error requested +! +! +! Intermediate parameters: +! +! * G : function g(a,x) to be integrated +! +! +! Output variables: +! +! * I : approximation to the integral +! * ERR : estimate of the absolute error +! +! Remarks: +! function +! f(x) needs to be analytic over (a,infinity). +! relative error +! EPS is relative error requested excluding +! cancellation of significant digits. +! i.e. EPS means : (absolute error) / +! (integral_a^R |f(x)| dx). +! EPS does not mean : (absolute error) / I. +! error message +! ERR >= 0 : normal termination. +! ERR < 0 : abnormal termination (m >= MMAX). +! i.e. convergent error is detected : +! 1. f(x) or (d/dx)^n f(x) has +! discontinuous points or sharp +! peaks over (a,infinity). +! you must divide the interval +! (a,infinity) at this points. +! 2. relative error of f(x) is +! greater than EPS. +! +! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). +! You may use, copy, modify this code for any purpose and +! without fee. You may distribute this ORIGINAL package. +! +! +! Modified: D. Sébilleau 5 Aug 2020 +! +! +! --> f(x) changed into g(f,a,omega,x) +! where G(f,a,omega,x) = f(a,x) * sin(omega*x) * x +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF +! + IMPLICIT NONE +! + REAL (WP) :: A,AA,OMEGA,EPS,I,ERR + REAL (WP) :: EFS,ENOFF,PQOFF,PPOFF + REAL (WP) :: PI4,EPSLN,EPSH,FRQ4,PER2,PP,PQ,EHP,EHM,IR,H + REAL (WP) :: IBACK,IRBACK,T,EP,EM,TK,XW,WG,XA,FP,FM,ERRH + REAL (WP) :: TN,ERRD +! + REAL (WP), EXTERNAL :: F,G +! + REAL (WP) :: DATAN,DLOG,DSQRT,DEXP,DABS +! + INTEGER :: MMAX,LMAX + INTEGER :: N,M,L,K +! + INTEGER :: INT +! +! ---- adjustable parameter ---- +! + MMAX = 256 ! + LMAX = 5 ! + EFS = 0.1E0_WP ! + ENOFF = 0.40E0_WP ! + PQOFF = 2.9E0_WP ! + PPOFF = -0.72E0_WP ! +! +! ------------------------------ +! + PI4 = DATAN(ONE) ! + EPSLN = ONE - DLOG(EFS*EPS) ! + EPSH = DSQRT(EFS*EPS) ! + N = INT(ENOFF*EPSLN) ! + FRQ4 = DABS(OMEGA) / (TWO*PI4) ! + PER2 = FOUR * PI4 / DABS(OMEGA) ! + PQ = PQOFF / EPSLN ! + PP = PPOFF - DLOG(PQ*PQ*FRQ4) ! + EHP = DEXP(TWO*PQ) ! + EHM = ONE / EHP ! + XW = DEXP(PP-TWO*PI4) ! + I = G(F,AA,OMEGA,A + DSQRT(XW * (PER2*HALF))) ! + IR = I*XW ! + I = I*(PER2*HALF) ! + ERR = DABS(I) ! + H = 2 ! + M = 1 ! +! + 10 CONTINUE ! +! + IBACK = I ! + IRBACK = IR ! + T = H * HALF ! +! + 20 CONTINUE ! +! + EM = DEXP(TWO*PQ*T) ! + EP = PI4 * EM ! + EM = PI4 / EM ! + TK = T ! +! + 30 CONTINUE ! +! + XW = DEXP(PP-EP-EM) ! + WG = DSQRT(FRQ4*XW + TK*TK) ! + XA = XW / (TK+WG) ! + WG = (PQ*XW*(EP-EM)+XA) / WG ! + FM = G(F,AA,OMEGA,A + XA) ! + FP = G(F,AA,OMEGA,A + XA + PER2*TK) ! + IR = IR + (FP + FM)*XW ! + FM = FM * WG ! + FP = FP * (PER2-WG) ! + I = I + (FP+FM) ! +! + IF (M == 1) ERR = ERR + (DABS(FP) + DABS(FM)) ! + + EP = EP * EHP ! + EM = EM * EHM ! + TK = TK + ONE ! +! + IF (EP < EPSLN) GO TO 30 ! +! + IF (M == 1) THEN ! + ERRH = ERR * EPSH ! + ERR = ERR * EPS ! + END IF ! +! + TN = TK ! +! + DO WHILE(DABS(FM) > ERR) ! + XW = DEXP(PP-EP-EM) ! + XA = XW / TK * HALF ! + WG = XA * (ONE / TK + TWO*PQ*(EP - EM)) ! + FM = G(F,AA,OMEGA,A + XA) ! + IR = IR + FM*XW ! + FM = FM * WG ! + I = I + FM ! + EP = EP * EHP ! + EM = EM * EHM ! + TK = TK + ONE ! + END DO ! +! + FM = G(F,AA,OMEGA,A + PER2*TN) ! + EM = PER2 * FM ! + I = I + EM ! +! + IF(DABS(FP) > ERR .OR. DABS(EM) > ERR) THEN ! + L = 0 ! + 40 CONTINUE ! + L = L + 1 ! + TN = TN + N ! + EM = FM ! + FM = G(F,AA,OMEGA,A + PER2*TN) ! + XA = FM ! + EP = FM ! + EM = EM + FM ! + XW = ONE ! + WG = ONE ! + DO K = 1, N-1 ! + XW = XW * (N+1-K) / K ! + WG = WG + XW ! + FP = F(A + PER2*(TN-K)) ! + XA = XA + FP ! + EP = EP + FP*WG ! + EM = EM + FP*XW ! + END DO ! + WG = PER2 * N / (WG*N + XW) ! + EM = WG * DABS(EM) ! + IF(EM <= ERR .OR. L >= LMAX) GO TO 50 ! + I = I + PER2*XA ! + GO TO 40 ! + 50 CONTINUE ! + I = I + WG*EP ! + IF(EM > ERR) ERR = EM ! + END IF ! +! + T = T + H ! +! + IF(T < ONE) GO TO 20 ! +! + IF(M == 1) THEN ! + ERRD = ONE + TWO*ERRH ! + ELSE ! + ERRD = H*(DABS(I-TWO*IBACK) + PQ*DABS(IR-TWO*IRBACK)) ! + END IF ! +! + H = H * HALF ! + M = M * 2 ! +! + IF(ERRD > ERRH .AND. M < MMAX) GO TO 10 ! +! + I = I*H ! +! + IF(ERRD > ERRH) THEN ! + ERR = -ERRD ! + ELSE ! + ERR = ERR * (M*HALF) ! + END IF ! +! + END SUBROUTINE INTDEO_1 +! +!======================================================================= +! + SUBROUTINE INTDEO_2(F,G,AA,LL,A,OMEGA,EPS,I,ERR) +! +! This subroutine is the integrator of g(x) over (a,infinity) when +! g(x) has an oscillatory behaviour: +! +! g(x) = f(x) * sin(omega * x + theta), as x -> infinity +! +! +! This version: f(x) has TWO extra parameters: AA (real) +! LL (integer) +! so that f(x) = g_l(a*x) +! +! +! Input parameters: +! +! * F : function f(x) to be Fourier transformed +! * AA : parameter used in function F +! * LL : order of the oscillatory function F +! * A : lower limit of integration +! * OMEGA : frequency of oscillation +! * EPS : relative error requested +! +! +! Intermediate parameters: +! +! * G : function g(x) to be integrated +! +! +! Output variables: +! +! * I : approximation to the integral +! * ERR : estimate of the absolute error +! +! Remarks: +! function +! f(x) needs to be analytic over (a,infinity). +! relative error +! EPS is relative error requested excluding +! cancellation of significant digits. +! i.e. EPS means : (absolute error) / +! (integral_a^R |f(x)| dx). +! EPS does not mean : (absolute error) / I. +! error message +! ERR >= 0 : normal termination. +! ERR < 0 : abnormal termination (m >= MMAX). +! i.e. convergent error is detected : +! 1. f(x) or (d/dx)^n f(x) has +! discontinuous points or sharp +! peaks over (a,infinity). +! you must divide the interval +! (a,infinity) at this points. +! 2. relative error of f(x) is +! greater than EPS. +! +! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). +! You may use, copy, modify this code for any purpose and +! without fee. You may distribute this ORIGINAL package. +! +! +! Modified: D. Sébilleau 5 Aug 2020 +! +! +! --> f(x) changed into g(f,a,l,omega,x) +! where G(f,a,l,omega,x) = f(a,x) * j_l(omega*x) * x^2 +! --> a replaced by AA, as A is used for the lower integration bound +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF +! + IMPLICIT NONE +! + REAL (WP) :: A,AA,OMEGA,EPS,I,ERR + REAL (WP) :: EFS,ENOFF,PQOFF,PPOFF + REAL (WP) :: PI4,EPSLN,EPSH,FRQ4,PER2,PP,PQ,EHP,EHM,IR,H + REAL (WP) :: IBACK,IRBACK,T,EP,EM,TK,XW,WG,XA,FP,FM,ERRH + REAL (WP) :: TN,ERRD +! + REAL (WP), EXTERNAL :: F,G +! + REAL (WP) :: DATAN,DLOG,DSQRT,DEXP,DABS +! + INTEGER :: MMAX,LMAX + INTEGER :: N,M,L,K + INTEGER :: LL +! + INTEGER :: INT +! +! ---- adjustable parameter ---- +! + MMAX = 256 ! + LMAX = 5 ! + EFS = 0.1E0_WP ! + ENOFF = 0.40E0_WP ! + PQOFF = 2.9E0_WP ! + PPOFF = -0.72E0_WP ! +! +! ------------------------------ +! + PI4 = DATAN(ONE) ! + EPSLN = ONE - DLOG(EFS*EPS) ! + EPSH = DSQRT(EFS*EPS) ! + N = INT(ENOFF*EPSLN) ! + FRQ4 = DABS(OMEGA) / (TWO*PI4) ! + PER2 = FOUR * PI4 / DABS(OMEGA) ! + PQ = PQOFF / EPSLN ! + PP = PPOFF - DLOG(PQ*PQ*FRQ4) ! + EHP = DEXP(TWO*PQ) ! + EHM = ONE / EHP ! + XW = DEXP(PP-TWO*PI4) ! + I = G(F,AA,OMEGA,A + DSQRT(XW * (PER2*HALF))) ! + IR = I*XW ! + I = I*(PER2*HALF) ! + ERR = DABS(I) ! + H = 2 ! + M = 1 ! +! + 10 CONTINUE ! +! + IBACK = I ! + IRBACK = IR ! + T = H * HALF ! +! + 20 CONTINUE ! +! + EM = DEXP(TWO*PQ*T) ! + EP = PI4 * EM ! + EM = PI4 / EM ! + TK = T ! +! + 30 CONTINUE ! +! + XW = DEXP(PP-EP-EM) ! + WG = DSQRT(FRQ4*XW + TK*TK) ! + XA = XW / (TK+WG) ! + WG = (PQ*XW*(EP-EM)+XA) / WG ! + FM = G(F,AA,LL,OMEGA,A + XA) ! + FP = G(F,AA,LL,OMEGA,A + XA + PER2*TK) ! + IR = IR + (FP + FM)*XW ! + FM = FM * WG ! + FP = FP * (PER2-WG) ! + I = I + (FP+FM) ! +! + IF (M == 1) ERR = ERR + (DABS(FP) + DABS(FM)) ! + + EP = EP * EHP ! + EM = EM * EHM ! + TK = TK + ONE ! +! + IF (EP < EPSLN) GO TO 30 ! +! + IF (M == 1) THEN ! + ERRH = ERR * EPSH ! + ERR = ERR * EPS ! + END IF ! +! + TN = TK ! +! + DO WHILE(DABS(FM) > ERR) ! + XW = DEXP(PP-EP-EM) ! + XA = XW / TK * HALF ! + WG = XA * (ONE / TK + TWO*PQ*(EP - EM)) ! + FM = G(F,AA,LL,OMEGA,A + XA) ! + IR = IR + FM*XW ! + FM = FM * WG ! + I = I + FM ! + EP = EP * EHP ! + EM = EM * EHM ! + TK = TK + ONE ! + END DO ! +! + FM = G(F,AA,LL,OMEGA,A + PER2*TN) ! + EM = PER2 * FM ! + I = I + EM ! +! + IF(DABS(FP) > ERR .OR. DABS(EM) > ERR) THEN ! + L = 0 ! + 40 CONTINUE ! + L = L + 1 ! + TN = TN + N ! + EM = FM ! + FM = G(F,AA,LL,OMEGA,A + PER2*TN) ! + XA = FM ! + EP = FM ! + EM = EM + FM ! + XW = ONE ! + WG = ONE ! + DO K = 1, N-1 ! + XW = XW * (N+1-K) / K ! + WG = WG + XW ! + FP = F(A + PER2*(TN-K)) ! + XA = XA + FP ! + EP = EP + FP*WG ! + EM = EM + FP*XW ! + END DO ! + WG = PER2 * N / (WG*N + XW) ! + EM = WG * DABS(EM) ! + IF(EM <= ERR .OR. L >= LMAX) GO TO 50 ! + I = I + PER2*XA ! + GO TO 40 ! + 50 CONTINUE ! + I = I + WG*EP ! + IF(EM > ERR) ERR = EM ! + END IF ! +! + T = T + H ! +! + IF(T < ONE) GO TO 20 ! +! + IF(M == 1) THEN ! + ERRD = ONE + TWO*ERRH ! + ELSE ! + ERRD = H*(DABS(I-TWO*IBACK) + PQ*DABS(IR-TWO*IRBACK)) ! + END IF ! +! + H = H * HALF ! + M = M * 2 ! +! + IF(ERRD > ERRH .AND. M < MMAX) GO TO 10 ! +! + I = I*H ! +! + IF(ERRD > ERRH) THEN ! + ERR = -ERRD ! + ELSE ! + ERR = ERR * (M*HALF) ! + END IF ! +! + END SUBROUTINE INTDEO_2 +! +!======================================================================= +! + SUBROUTINE INTDEO_F(F,A,OMEGA,AW,I,ERR) +! +! This subroutine is the integrator of f(x) over (a,infinity) when +! f(x) has an oscillatory behaviour: +! +! f(x) = g(x) * sin(omega * x + theta) as x -> infinity +! +! +! +! --> <-- +! --> This is the fast version <-- +! --> <-- +! +! +! Usage: +! +! CALL INTDEOINI(LENAW,TINY,EPS,AW) ! initialization of AW +! ... +! CALL INTDEO_F(F,A,AW,I,ERR) +! +! +! Input parameters: +! +! * F : integrand f(x) +! * A : lower limit of integration +! * OMEGA : frequency of oscillation +! * EPS : relative error requested +! +! +! Output variables: +! +! * I : approximation to the integral +! * ERR : estimate of the absolute error +! +! Remarks: +! initial parameters +! LENAW > 1000, +! IEEE double : +! LENAW = 8000 +! TINY = 1.0D-307 +! function +! f(x) needs to be analytic over (a,infinity). +! relative error +! EPS is relative error requested excluding +! cancellation of significant digits. +! i.e. EPS means : (absolute error) / +! (integral_a^R |f(x)| dx). +! EPS does not mean : (absolute error) / I. +! error message +! ERR >= 0 : normal termination. +! ERR < 0 : abnormal termination (m >= MMAX). +! i.e. convergent error is detected : +! 1. f(x) or (d/dx)^n f(x) has +! discontinuous points or sharp +! peaks over (a,infinity). +! you must divide the interval +! (a,infinity) at this points. +! 2. relative error of f(x) is +! greater than EPS. +! +! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). +! You may use, copy, modify this code for any purpose and +! without fee. You may distribute this ORIGINAL package. +! +! +! Modified: D. Sébilleau 5 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF +! + IMPLICIT NONE +! + REAL (WP) :: A,OMEGA,AW(0 : *),I,ERR + REAL (WP) :: EPS,PER,PERW,W02,IR,H,IBACK,IRBACK,T,TK + REAL (WP) :: XA,FM,FP,ERRH,S0,S1,S2,ERRD +! + REAL (WP), EXTERNAL :: F +! + REAL (WP) :: DABS +! + INTEGER :: LENAWM,NK0,NOFF0,NK,NOFF,LMAX,M,K,J,JM,L +! + INTEGER :: INT +! + LENAWM = INT(AW(0) + HALF) ! + NK0 = INT(AW(1) + HALF) ! + NOFF0 = 6 ! + NK = INT(AW(2) + HALF) ! + NOFF = 2*NK0 + NOFF0 ! + LMAX = INT(AW(3) + HALF) ! + EPS = AW(4) ! + PER = ONE / DABS(OMEGA) ! + W02 = TWO * AW(NOFF+2) ! + PERW = PER * W02 ! + I = F(A + AW(NOFF)*PER) ! + IR = I * AW(NOFF+1) ! + I = I * AW(NOFF+2) ! + ERR = DABS(I) ! + H = TWO ! + M = 1 ! + K = NOFF ! +! + 10 CONTINUE ! +! + IBACK = I ! + IRBACK = IR ! + T = H * HALF ! +! + 20 CONTINUE ! +! + IF(K == NOFF) THEN ! + TK = ONE ! + K = K + NK ! + J = NOFF ! +! + 30 CONTINUE ! +! + J = J + 3 ! + XA = PER * AW(J) ! + FM = F(A + XA) ! + FP = F(A + XA + PERW*TK) ! + IR = IR + (FM+FP) * AW(J+1) ! + FM = FM * AW(J+2) ! + FP = FP * (W02-AW(J+2)) ! + I = I + (FM+FP) ! + ERR = ERR + (DABS(FM)+DABS(FP)) ! + TK = TK + ONE ! +! + IF(AW(J) > EPS .AND. J < K) GO TO 30 ! +! + ERRH = ERR * AW(5) ! + ERR = ERR * EPS ! + JM = J - NOFF ! + ELSE ! + TK = T ! + DO J = K+3, K+JM, 3 ! + XA = PER * AW(J) ! + FM = F(A + XA) ! + FP = F(A + XA + PERW*TK) ! + IR = IR + (FM+FP) * AW(J+1) ! + FM = FM * AW(J+2) ! + FP = FP * (W02-AW(J+2)) ! + I = I + (FM+FP) ! + TK = TK + ONE ! + END DO ! + J = K + JM ! + K = K + NK ! + END IF ! +! + DO WHILE (DABS(FM) > ERR .AND. J < K) ! + J = J + 3 ! + FM = F(A + PER*AW(J)) ! + IR = IR + FM*AW(J+1) ! + FM = FM * AW(J+2) ! + I = I + FM ! + END DO ! +! + FM = F(A + PERW*TK) ! + S2 = W02 * FM ! + I = I + S2 ! +! + IF(DABS(FP) > ERR .OR. DABS(S2) > ERR) THEN ! + L = 0 ! +! + 40 CONTINUE ! +! + L = L + 1 ! + S0 = ZERO ! + S1 = ZERO ! + S2 = FM * AW(NOFF0+1) ! +! + DO J = NOFF0+2, NOFF-2, 2 ! + TK = TK + ONE ! + FM = F(A + PERW*TK) ! + S0 = S0 + FM ! + S1 = S1 + FM*AW(J) ! + S2 = S2 + FM*AW(J+1) ! + END DO +! + IF(S2 <= ERR .OR. L >= LMAX) GO TO 50 ! +! + I = I + W02*S0 ! + GO TO 40 ! +! + 50 CONTINUE ! +! + I = I + S1 ! +! + IF(S2 > ERR) ERR = S2 ! +! + END IF ! +! + T = T + H ! +! + IF(T < ONE) GO TO 20 ! +! + IF(M == 1) THEN ! + ERRD = ONE + TWO*ERRH ! + ELSE ! + ERRD = H * (DABS(I-2*IBACK) + DABS(IR- 2*IRBACK)) ! + END IF ! +! + H = H * HALF ! + M = M * 2 ! +! + IF(ERRD > ERRH .AND. (2*K - NOFF) <= LENAWM) GO TO 10 ! +! + I = I * (H*PER) ! +! + IF(ERRD > ERRH) THEN ! + ERR = -ERRD*PER ! + ELSE ! + ERR = ERR * (PER*M*HALF) ! + END IF ! +! + END SUBROUTINE INTDEO_F +! +!======================================================================= +! + SUBROUTINE INTDEOINI_F(LENAW,TINY,EPS,AW) +! +! This subroutine calculates the points and weights of the quadrature +! formula +! +! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). +! You may use, copy, modify this code for any purpose and +! without fee. You may distribute this ORIGINAL package. +! +! +! Modified: D. Sébilleau 5 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,HALF +! + IMPLICIT NONE +! + REAL (WP) :: TINY,EPS,AW(0 : LENAW - 1) + REAL (WP) :: EFS,ENOFF,PQOFF,PPOFF + REAL (WP) :: PI4,TINYLN,EPSLN,FRQ4,PER2,PP,PQ,EHP,EHM,H + REAL (WP) :: T,EP,EM,TK,XW,WG,XA +! + REAL (WP) :: DATAN,DLOG,DSQRT,DEXP,DFLOAT +! + INTEGER :: NOFF0,NK0,NOFF,K,NK,J + INTEGER :: LENAW + INTEGER :: LMAX +! + INTEGER :: INT +! +! ---- adjustable parameter ---- +! + LMAX = 5 ! + EFS = 0.1E0_WP ! + ENOFF = 0.40E0_WP ! + PQOFF = 2.9E0_WP ! + PPOFF = -0.72E0_WP ! +! +! ------------------------------ +! + PI4 = DATAN(ONE) ! + TINYLN = -DLOG(TINY) ! + EPSLN = ONE - DLOG(EFS*EPS) ! + FRQ4 = ONE / (TWO*PI4) ! + PER2 = FOUR * PI4 ! + PQ = PQOFF / EPSLN ! + PP = PPOFF - DLOG(PQ*PQ*FRQ4) ! + EHP = DEXP(TWO*PQ) ! + EHM = ONE / EHP ! + AW(3) = DFLOAT(LMAX) ! + AW(4) = EPS ! + AW(5) = DSQRT(EFS*EPS) ! + NOFF0 = 6 ! + NK0 = 1 + INT(ENOFF*EPSLN) ! + AW(1) = NK0 ! + NOFF = 2*NK0 + NOFF0 ! + WG = ZERO ! + XW = ONE ! +! + DO K = 1, NK0 ! + WG = WG + XW ! + AW(NOFF - 2*K) = WG ! + AW(NOFF - 2*K + 1) = XW ! + XW = XW * (NK0-K) / K ! + END DO ! +! + WG = PER2 / WG ! +! + DO K = NOFF0, NOFF-2, 2 ! + AW(K) = AW(K)*WG ! + AW(K+1) = AW(K+1)*WG ! + END DO ! +! + XW = DEXP(PP - TWO*PI4) ! + AW(NOFF) = DSQRT(XW * (PER2*HALF)) ! + AW(NOFF+1) = XW * PQ ! + AW(NOFF+2) = PER2 * HALF ! + H = TWO ! + NK = 0 ! + K = NOFF + 3 ! +! + 10 CONTINUE ! +! + T = H * HALF ! +! + 20 CONTINUE ! +! + EM = DEXP(2*PQ*T) ! + EP = PI4 * EM ! + EM = PI4 / EM ! + TK = T ! + J = K ! +! + 30 CONTINUE ! +! + XW = DEXP(PP - EP - EM) ! + WG = DSQRT(FRQ4*XW + TK*TK) ! + XA = XW / (TK + WG) ! + WG = (PQ*XW*(EP-EM) + XA) / WG ! + AW(J) = XA ! + AW(J+1) = XW * PQ ! + AW(J+2) = WG ! + EP = EP * EHP ! + EM = EM * EHM ! + TK = TK + ONE ! + J = J + 3 ! +! + IF(EP < TINYLN .AND. J <= (LENAW-3)) GO TO 30 ! +! + T = T + H ! + K = K + NK ! +! + IF(T < ONE) GO TO 20 ! +! + H = H * HALF ! +! + IF(NK == 0) THEN ! + IF(J > (LENAW-6)) J = J - 3 ! + NK = J - NOFF ! + K = K + NK ! + AW(2) = NK ! + END IF ! +! + IF ((2*K - NOFF - 3) <= LENAW) GO TO 10 ! +! + AW(0) = DFLOAT(K-3) ! +! + END SUBROUTINE INTDEOINI_F +! +END MODULE INTEGRATION3 diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/integration4.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/integration4.f90 new file mode 100644 index 0000000..bd5224d --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/integration4.f90 @@ -0,0 +1,872 @@ +! +!======================================================================= +! +MODULE INTEGRATION4 +! +! This module contains integration routines in order to integrate +! a function F over the interval [A,B]. +! +! These routines are: +! +! +! * Newton-Cotes/Euler-Mac Laurin : INTEGR_I(X,F,F_1,F_3,F_5,N_BEG, +! N_END,N_POINTS,METH,N_RULE,RES) +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE INTEGR_I(X,F,F_1,F_3,F_5,N_BEG,N_END,N_POINTS, & + METH,N_RULE,RES) +! +! This is the driver routine that calls the subroutine that +! integrates a function F(X), defined over +! the interval [1,N_POINTS] with constant step H +! over the interval [N_BEG,N_END] +! +! To increase the accuracy, it computes the integral according +! to different schemes. There are four ways to compute the +! integral: +! int[N_BEG,N_END] (1) +! int[1,N_END]-int[1,N_BEG] (2) +! int[N_BEG,N_POINTS]-int[N_END,N_POINTS] (3) +! int[1,N_POINTS]-int[1,N_BEG]-int[N_END,N_POINTS] (4) +! +! Method (4) is never used as it is equivalent either to method (2) +! or to method (3) in terms of accuracy +! +! This subroutine selects the method involving the larger number +! of points, i.e. max([N_BEG,N_END],int[1,N_BEG],[N_END,N_POINTS]) +! +! +! Input parameters: +! +! * X : X point of function to be integrated +! * F : function to be integrated +! * F_1 : first order derivative of F +! * F_3 : third order derivative of F +! * F_5 : fifth order derivative of F +! * N_BEG : starting X point for integration of F +! * N_END : end X point for integration of F +! * N_POINTS : dimensioning of F (1 to N_POINTS) +! * METH : integration method used +! +! = 'NCQ' : Newton-Cotes +! = 'EMS' : Euler-Mac Laurin summation +! +! * N_RULE : number of points used in the quadrature formula +! +! NCQ : Newton-Cotes quadrature rule | Accuracy +! +! --> N_RULE = 2 : trapezoidal | H^3 +! --> N_RULE = 3 : Simpson 1/3 | H^5 +! --> N_RULE = 4 : Simpson 3/8 | H^5 +! --> N_RULE = 5 : Boole/Milne | H^7 +! --> N_RULE = 6 : Weddle | H^7 +! +! EMS : Euler-Mac Laurin summation | Accuracy +! +! --> N_RULE = 2 (uses F_1) | H^5 +! --> N_RULE = 3 (uses F_1,F_3) | H^7 +! --> N_RULE = 4 (uses F_1,F_3,F_5) | H^9 +! +! BN(J) is a Bernoulli number +! +! +! Output parameters: +! +! * RES : result of the integration of F over the whole +! interval [1,N_END] +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Aug 2020 +! +! + IMPLICIT NONE +! + REAL (WP) :: F(N_POINTS),F_1(N_POINTS) + REAL (WP) :: F_3(N_POINTS),F_5(N_POINTS) + REAL (WP) :: X(N_POINTS) + REAL (WP) :: RES,RES1,RES2 +! + INTEGER :: N_BEG,N_END,N_POINTS,N_RULE + INTEGER :: N_SIZE_I,N_SIZE_L,N_SIZE_U + INTEGER :: N_HALF +! + CHARACTER (LEN = 3) :: METH +! +! Checking the number of points in the integration interval +! with respect to that over which the function F(X) is defined +! + N_SIZE_I=N_END-N_BEG+1 ! + N_SIZE_L=N_BEG ! + N_SIZE_U=N_POINTS-N_END+1 ! +! + N_HALF=N_POINTS/2 ! +! + IF(N_SIZE_I >= N_HALF) THEN ! +! +!........... Interval of integration larger than half of ........... +!........... the interval of definition of F(X) ........... +! +! Using method (1) +! + CALL INTEGR_INT(X,F,F_1,F_3,F_5,N_BEG,N_END,N_POINTS, & ! + METH,N_RULE,RES) ! +! + ELSE ! +! +!........... Interval of integration smaller than half of ........... +!........... the interval of definition of F(X) ........... +! + IF(N_SIZE_U >= N_SIZE_L) THEN ! +! +! Using method (3) +! + CALL INTEGR_INT(X,F,F_1,F_3,F_5,N_BEG,N_POINTS,N_POINTS,& ! + METH,N_RULE,RES1) ! + CALL INTEGR_INT(X,F,F_1,F_3,F_5,N_END,N_POINTS,N_POINTS,& ! + METH,N_RULE,RES2) ! +! + RES=RES1-RES2 ! +! + ELSE ! +! +! Using method (2) +! + CALL INTEGR_INT(X,F,F_1,F_3,F_5,1,N_END,N_POINTS, & ! + METH,N_RULE,RES1) ! + CALL INTEGR_INT(X,F,F_1,F_3,F_5,1,N_BEG,N_POINTS, & ! + METH,N_RULE,RES2) ! +! + RES=RES1-RES2 ! +! + END IF ! +! + END IF ! +! + END SUBROUTINE INTEGR_I +! +!======================================================================= +! + SUBROUTINE INTEGR_INT(X,F,F_1,F_3,F_5,N_BEG,N_END,N_POINTS, & + METH,N_RULE,RES) +! +! This subroutine integrates the function F(X), defined over +! the interval [1,N_POINTS] with constant step H +! over the interval [N_BEG,N_END]. +! +! +! Input parameters: +! +! * X : X point of function to be integrated +! * F : function to be integrated +! * F_1 : first order derivative of F +! * F_3 : third order derivative of F +! * F_5 : fifth order derivative of F +! * N_BEG : starting X point for integration of F +! * N_END : end X point for integration of F +! * N_POINTS : dimensioning of F (1 to N_POINTS) +! * METH : integration method used +! +! = 'NCQ' : Newton-Cotes +! = 'EMS' : Euler-Mac Laurin summation +! +! * N_RULE : number of points used in the quadrature formula +! +! NCQ : Newton-Cotes quadrature rule | Accuracy +! +! --> N_RULE = 2 : trapezoidal | H^3 +! --> N_RULE = 3 : Simpson 1/3 | H^5 +! --> N_RULE = 4 : Simpson 3/8 | H^5 +! --> N_RULE = 5 : Boole/Milne | H^7 +! --> N_RULE = 6 : Weddle | H^7 +! +! EMS : Euler-Mac Laurin summation | Accuracy +! +! --> N_RULE = 2 (uses F_1) | H^5 +! --> N_RULE = 3 (uses F_1,F_3) | H^7 +! --> N_RULE = 4 (uses F_1,F_3,F_5) | H^9 +! +! BN(J) is a Bernoulli number +! +! +! Output parameters: +! +! * RES : result of the integration of F over the whole +! interval [1,N_END] +! +! +! References: M. Abramowitz and I. A. Stegun, "Handbook of Mathematical +! "Functions", 9th Dover printing, pp.886-887, Dover +! +! P. A. Almeida Magalhaes Jr and C. Almeida Magalhaes, +! J. Math. Stat. 6, 193-204 (2010) +! +! This version: closed Newton-Cotes formula limited to N_RULE = 6 +! no open Newton-Cotes formula included +! Euler-MacLaurin formula limited to N_RULE = 3 +! +! Author : D. Sébilleau +! +! Last modified : 6 Aug 2020 +! +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,FIVE, & + HALF,THIRD,FOURTH,FIFTH +! + IMPLICIT NONE +! + REAL (WP) :: F(N_POINTS),F_1(N_POINTS) + REAL (WP) :: F_3(N_POINTS),F_5(N_POINTS) + REAL (WP) :: X(N_POINTS) + REAL (WP) :: F_INT1,F_INT2,F_INT3,F_INT4 + REAL (WP) :: RES,RES0,RES1,C_H + REAL (WP) :: BN(0:6),H,H1 + REAL (WP) :: CNC2(2),CNC3(3),CNC4(4),CNC5(5),CNC6(6) + REAL (WP) :: CN(6) + REAL (WP) :: P,A(10) +! + REAL (WP) :: DFLOAT +! + INTEGER :: N_BEG,N_END,N_POINTS,N_RULE + INTEGER :: I_FLAG + INTEGER :: J + INTEGER :: N_REM,N_FIN + INTEGER :: LOGF +! + CHARACTER (LEN = 3) :: METH +! +! Bernouilli numbers +! + DATA BN /1.0E0_WP,-0.50E0_WP, & + 0.166666666666666666666666667E0_WP,0.0E0_WP, & + 0.000000000000000000000000000E0_WP,0.0E0_WP, & + 0.023809523809523809523809524E0_WP / +! +! Closed formula Newton-Cotes coefficients CNCn for n-point formula +! + DATA CNC2 / 1.0E0_WP, 1.0E0_WP/ + DATA CNC3 / 1.0E0_WP, 4.0E0_WP, 1.0E0_WP/ + DATA CNC4 / 1.0E0_WP ,3.0E0_WP, 3.0E0_WP, 1.0E0_WP/ + DATA CNC5 / 7.0E0_WP,32.0E0_WP,12.0E0_WP,32.0E0_WP, 7.0E0_WP/ + DATA CNC6 /19.0E0_WP,75.0E0_WP,50.0E0_WP,50.0E0_WP,75.0E0_WP, 19.0E0_WP/ +! + DATA CN / 0.0E0_WP, 2.0E0_WP, 6.0E0_WP, 8.0E0_WP,90.0E0_WP,288.0E0_WP/ +! + LOGF=6 ! +! +! Checking for consistency of input data +! + IF(N_BEG < 1) THEN ! + WRITE(6,10) ! + STOP ! + END IF ! +! + IF(N_END > N_POINTS) THEN ! + WRITE(6,20) ! + STOP ! + END IF ! +! + IF(METH == 'NCQ') THEN ! + IF( (N_RULE < 2) .OR. (N_RULE > 6) ) THEN ! + WRITE(6,30) ! + STOP ! + END IF ! + ELSEIF(METH == 'EMS') THEN ! + IF( (N_RULE < 2) .OR. (N_RULE > 4) ) THEN ! + WRITE(6,40) ! + STOP ! + END IF ! + END IF ! +! + H=X(2)-X(1) ! +! + I_FLAG=N_RULE-1 ! +! +! +! Computation of Int_{1}^{X} F(X) dX for X in [N_BEG,N_END] +! +! +! The number of points used for each +! formula is N_RULE. (N_END-N_BEG-1) must +! must be divisible by I_FLAG in +! order to fully apply the formula. +! So, the formula is applied in +! the interval [N_BEG,N_END-N_REM], +! where N_REM is the remainder of +! the division of (N_END-N_BEG-1) by I_FLAG, +! and for the remaining interval, +! an interpolation is used to +! obtain exactly I_FLAG+1 points +! (F_INT1,F_INT2,F_INT3,F_INT4). +! We note N_END-N_REM-1 = N_FIN. +! + IF(METH == 'NCQ') THEN ! +! + N_REM=MOD(N_END-N_BEG,I_FLAG) ! + N_FIN=N_END-N_REM-1 ! + C_H=DFLOAT(I_FLAG)/CN(N_RULE) ! + RES0=ZERO ! +! + IF(I_FLAG == 1) THEN ! +! +!............. 2-point formula ........ +! + DO J=N_BEG,N_FIN,I_FLAG ! + RES0=RES0+CNC2(1)*F(J)+CNC2(2)*F(J+1) ! + END DO ! + RES=RES0*H*C_H ! +! + ELSE IF(I_FLAG == 2) THEN ! +! +!............. 3-point formula ........ +! + IF(N_FIN > N_BEG) THEN ! + DO J=N_BEG,N_FIN,I_FLAG ! + RES0=RES0+CNC3(1)*F(J)+CNC3(2)*F(J+1)+CNC3(3)*F(J+2) ! + END DO ! + END IF ! + RES0=RES0*H*C_H ! +! + IF(N_REM == 0) THEN ! + RES=RES0 ! + ELSE IF(N_REM == 1) THEN ! +! +! Lagrange 3-point interpolation for step H/2 point +! (or Lagrange 2-point when not possible) +! + P=HALF ! + IF(N_END > 2) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT1=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT1=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + RES1=CNC3(1)*F(N_END-1)+CNC3(2)*F_INT1+CNC3(3)*F(N_END) ! + H1=H/TWO ! + RES=RES0+RES1*H1*C_H ! + END IF ! +! + ELSE IF(I_FLAG == 3) THEN ! +! +!............. 4-point formula ........ +! + IF(N_FIN > N_BEG) THEN ! + DO J=N_BEG,N_FIN,I_FLAG ! + RES0=RES0 + CNC4(1)*F(J) + CNC4(2)*F(J+1) + & ! + CNC4(3)*F(J+2) + CNC4(4)*F(J+3) ! + END DO ! + END IF ! + RES0=RES0*H*C_H ! +! + IF(N_REM == 0) THEN ! + RES=RES0 ! + ELSE IF(N_REM == 1) THEN ! +! +! Lagrange 3-point interpolation for step H/3 points +! (or Lagrange 2-point when not possible) +! + P=THIRD ! + IF(N_END > 2) THEN + CALL LAGR_INTERP(3,P,A) ! + F_INT1=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT1=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + P=TWO*THIRD ! + IF(N_END > 2) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT2=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT2=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + RES1=CNC4(1)*F(N_END-1) + CNC4(2)*F_INT1 + & ! + CNC4(3)*F_INT2 + CNC4(4)*F(N_END) ! + H1=H/THREE ! + RES=RES0+RES1*H1*C_H ! +! + ELSE IF(N_REM == 2) THEN ! +! +! Lagrange 3-point interpolation for step 2H/3 points +! (or Lagrange 2-point when not possible) +! (F(N_END-1) is not used for the calculation of integral) +! + P=TWO*THIRD ! + IF(N_END > 3) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT1=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1)! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT1=A(1)*F(N_END-2)+A(2)*F(N_END-1) ! + END IF ! +! + P=THIRD ! + IF(N_END > 3) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT2=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT2=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + RES1=CNC4(1)*F(N_END-2) + CNC4(2)*F_INT1 + & ! + CNC4(3)*F_INT2 + CNC4(4)*F(N_END) ! + H1=TWO*H/THREE ! + RES=RES0+RES1*H1*C_H ! +! + END IF ! +! + ELSE IF(I_FLAG == 4) THEN ! +! +!............. 5-point formula ........ +! + IF(N_FIN > N_BEG) THEN ! + DO J=N_BEG,N_FIN,I_FLAG ! + RES0=RES0 + CNC5(1)*F(J) + CNC5(2)*F(J+1) + & ! + CNC5(3)*F(J+2) + CNC5(4)*F(J+3) + & ! + CNC5(5)*F(J+4) ! + END DO ! + END IF ! + RES0=RES0*H*C_H ! +! + IF(N_REM == 0) THEN ! + RES=RES0 ! + ELSE IF(N_REM == 1) THEN ! +! +! Lagrange 3-point interpolation for step H/4 points +! (or Lagrange 2-point when not possible) +! + P=FOURTH ! + IF(N_END > 2) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT1=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT1=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + P=HALF ! + IF(N_END > 2) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT2=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT2=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + P=THREE/FOUR ! + IF(N_END > 2) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT3=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT3=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + RES1=CNC5(1)*F(N_END-1) + CNC5(2)*F_INT1 + & ! + CNC5(3)*F_INT2 + CNC5(4)*F_INT3 + & ! + CNC5(5)*F(N_END) ! + H1=H/FOUR ! + RES=RES0+RES1*H1*C_H ! +! + ELSE IF(N_REM == 2) THEN ! +! +! Lagrange 3 point interpolation for step 2H/4 points +! (or Lagrange 2-point when not possible) +! + P=HALF ! + IF(N_END > 3) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT1=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1)! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT1=A(1)*F(N_END-2)+A(2)*F(N_END-1) ! + END IF ! +! + P=HALF ! + IF(N_END > 3) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT3=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT3=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + RES1=CNC5(1)*F(N_END-2) + CNC5(2)*F_INT1 + & ! + CNC5(3)*F(N_END-1) + CNC5(4)*F_INT3 + & ! + CNC5(5)*F(N_END) ! + H1=H/TWO ! + RES=RES0+RES1*H1*C_H ! +! + ELSE IF(N_REM == 3) THEN ! +! +! Lagrange 3 point interpolation for step 3H/4 points +! + P=THREE/FOUR ! + CALL LAGR_INTERP(3,P,A) ! + F_INT1=A(1)*F(N_END-4)+A(2)*F(N_END-3)+A(3)*F(N_END-2) ! +! + P=HALF ! + CALL LAGR_INTERP(3,P,A) ! + F_INT2=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1) ! +! + P=FOURTH ! + CALL LAGR_INTERP(3,P,A) ! + F_INT3=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! +! + RES1=CNC5(1)*F(N_END-3) + CNC5(2)*F_INT1 + & ! + CNC5(3)*F_INT2 + CNC5(4)*F_INT3 + & ! + CNC5(5)*F(N_END) ! + H1=THREE*H/FOUR ! + RES=RES0+RES1*H1*C_H ! +! + END IF ! +! + ELSE IF(I_FLAG == 5) THEN ! +! +!............. 6-point formula ........ +! + IF(N_FIN > N_BEG) THEN ! + DO J=N_BEG,N_FIN,I_FLAG ! + RES0=RES0 + CNC6(1)*F(J) + CNC6(2)*F(J+1) + & ! + CNC6(3)*F(J+2) + CNC6(4)*F(J+3) + & ! + CNC6(5)*F(J+4) + CNC6(6)*F(J+5) ! + END DO ! + END IF ! + RES0=RES0*H*C_H ! +! + IF(N_REM == 0) THEN ! + RES=RES0 ! + ELSE IF(N_REM == 1) THEN ! +! +! Lagrange 3-point interpolation for step H/5 points +! (or Lagrange 2-point when not possible) +! + P=FIFTH ! + IF(N_END > 2) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT1=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT1=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + P=TWO/FIVE ! + IF(N_END > 2) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT2=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT2=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + P=THREE/FIVE ! + IF(N_END > 2) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT3=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT3=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + P=FOUR/FIVE ! + IF(N_END > 2) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT4=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT4=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + RES1=CNC6(1)*F(N_END-1) + CNC6(2)*F_INT1 + & ! + CNC6(3)*F_INT2 + CNC6(4)*F_INT3 + & ! + CNC6(5)*F_INT4 + CNC6(6)*F(N_END) ! + H1=H/FIVE ! + RES=RES0+RES1*H1*C_H ! +! + ELSE IF(N_REM == 2) THEN ! +! +! Lagrange 3 point interpolation for step 2H/5 points +! (or Lagrange 2-point when not possible) +! + P=TWO/FIVE ! + IF(N_END > 3) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT1=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1)! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT1=A(1)*F(N_END-2)+A(2)*F(N_END-1) ! + END IF ! +! + P=FOUR/FIVE ! + IF(N_END > 3) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT2=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1)! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT2=A(1)*F(N_END-2)+A(2)*F(N_END-1) ! + END IF ! +! + P=FIFTH ! + IF(N_END > 3) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT3=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT3=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + P=THREE/FIVE ! + IF(N_END > 3) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT4=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT4=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + RES1=CNC6(1)*F(N_END-2) + CNC6(2)*F_INT1 + & ! + CNC6(3)*F_INT2 + CNC6(4)*F_INT3 + & ! + CNC6(5)*F_INT4 + CNC6(6)*F(N_END) ! + H1=TWO*H/FIVE ! + RES=RES0+RES1*H1*C_H ! +! + ELSE IF(N_REM == 3) THEN ! +! +! Lagrange 3 point interpolation for step 3H/5 points +! (or Lagrange 2-point when not possible) +! + P=THREE/FIVE ! + IF(N_END > 4) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT1=A(1)*F(N_END-4)+A(2)*F(N_END-3)+A(3)*F(N_END-2)! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT1=A(1)*F(N_END-3)+A(2)*F(N_END-2) ! + END IF ! +! + P=FIFTH ! + IF(N_END > 4) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT2=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1)! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT2=A(1)*F(N_END-2)+A(2)*F(N_END-1) ! + END IF ! +! + P=FOUR/FIVE ! + IF(N_END > 4) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT3=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1)! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT3=A(1)*F(N_END-2)+A(2)*F(N_END-1) ! + END IF ! +! + P=TWO/FIVE ! + IF(N_END > 4) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT4=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT4=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + RES1=CNC6(1)*F(N_END-3) + CNC6(2)*F_INT1 + & ! + CNC6(3)*F_INT2 + CNC6(4)*F_INT3 + & ! + CNC6(5)*F_INT4 + CNC6(6)*F(N_END) ! + H1=THREE*H/FIVE ! + RES=RES0+RES1*H1*C_H ! +! + ELSE IF(N_REM == 4) THEN ! +! +! Lagrange 3 point interpolation for step 4H/5 points +! (or Lagrange 2-point when not possible) +! + P=FOUR/FIVE ! + IF(N_END > 5) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT1=A(1)*F(N_END-5)+A(2)*F(N_END-4)+A(3)*F(N_END-3)! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT1=A(1)*F(N_END-4)+A(2)*F(N_END-3) ! + END IF ! +! + P=THREE/FIVE ! + IF(N_END > 5) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT2=A(1)*F(N_END-4)+A(2)*F(N_END-3)+A(3)*F(N_END-2)! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT2=A(1)*F(N_END-3)+A(2)*F(N_END-2) ! + END IF ! +! + P=TWO/FIVE ! + IF(N_END > 5) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT3=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1)! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT3=A(1)*F(N_END-2)+A(2)*F(N_END-1) ! + END IF ! +! + P=FIFTH ! + IF(N_END > 5) THEN ! + CALL LAGR_INTERP(3,P,A) ! + F_INT4=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) ! + ELSE ! + CALL LAGR_INTERP(2,P,A) ! + F_INT4=A(1)*F(N_END-1)+A(2)*F(N_END) ! + END IF ! +! + RES1=CNC6(1)*F(N_END-4) + CNC6(2)*F_INT1 + & ! + CNC6(3)*F_INT2 + CNC6(4)*F_INT3 + & ! + CNC6(5)*F_INT4 + CNC6(6)*F(N_END) ! + H1=FOUR*H/FIVE ! + RES=RES0+RES1*H1*C_H ! +! + END IF ! +! + END IF ! +! + ELSE IF(METH == 'EMS') THEN ! +! + IF(N_RULE >= 1) THEN ! + RES1=(F(N_BEG)+F(N_END))*HALF ! + DO J=N_BEG+1,N_END-1 ! + RES1=RES1+F(J) ! + END DO ! + RES1=RES1*H ! + END IF ! + IF(N_RULE >= 2) THEN ! + RES1=RES1-BN(2)*H*H*(F_1(N_END)-F_1(N_BEG))/TWO ! + END IF ! + IF(N_RULE >= 3) THEN ! + RES1=RES1-BN(4)*H*H*H*H*(F_3(N_END)-F_3(N_BEG))/24.0E0_WP ! + END IF ! + IF(N_RULE >= 4) THEN ! + RES1=RES1-BN(6)*H*H*H*H*H*H*(F_5(N_END)-F_5(N_BEG)) / & ! + 720.0E0_WP ! + END IF ! + RES=RES1 ! +! + END IF ! +! +! Formats +! + 10 FORMAT(//,10X,'<<<<< Wrong value of N_BEG: >>>>>',/, & + 10X,'<<<<< Cannot be lower than 1 >>>>>',//) + 20 FORMAT(//,10X,'<<<<< Wrong value of N_END: >>>>>',/, & + 10X,'<<<<< Cannot exceed N_POINTS >>>>>',//) + 30 FORMAT(//,10X,'<<<<< Wrong value of N_RULE: >>>>>',/, & + 10X,'<<<<< Should be in [2,6] >>>>>',//) + 40 FORMAT(//,10X,'<<<<< Wrong value of N_RULE: >>>>>',/, & + 10X,'<<<<< Should be in [2,4] >>>>>',//) +! + END SUBROUTINE INTEGR_INT +! +!======================================================================= +! + SUBROUTINE LAGR_INTERP(N,P,A) +! +! This subroutine computes the coefficients for the Lagrange +! n-point interpolation, 1 < n < 7 +! +! Input parameters: +! +! * N : number of points of the interpolation +! * P : value of the step fraction +! +! Output parameters: +! +! * A(N) : coefficients of the interpolation +! +! +! References: M. Abramowitz and I. A. Stegun, "Handbook of Mathematical +! "Functions", 9th Dover printing, pp.878-879, Dover +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,SIX, & + HALF +! + IMPLICIT NONE +! + REAL (WP) :: P,A(10) +! + INTEGER :: N + INTEGER :: J +! +! Initialization +! + DO J=1,10 ! + A(J)=ZERO ! + END DO ! +! + IF(N == 2) THEN ! +! +!.......... 2-point Lagrange interpolation ............ +! + A(1)=ONE-P ! + A(2)=P ! +! + ELSE IF(N == 3) THEN ! +! +!.......... 3-point Lagrange interpolation ............ +! + A(1)=HALF*P*(P-ONE) ! + A(2)=ONE-P*P ! + A(3)=HALF*P*(P+ONE) ! +! + ELSE IF(N == 4) THEN ! +! +!.......... 4-point Lagrange interpolation ............ +! + A(1)=-P*(P-ONE)*(P-TWO)/SIX ! + A(2)=(P*P-ONE)*(P-TWO)/TWO ! + A(3)=-P*(P+ONE)*(P-TWO)/TWO ! + A(4)=P*(P*P-ONE)/SIX ! +! + ELSE IF(N == 5) THEN ! +! +!.......... 5-point Lagrange interpolation ............ +! + A(1)=(P*P-ONE)*P*(P-TWO)/24.0E0_WP ! + A(2)=-(P-ONE)*P*(P*P-FOUR)/SIX ! + A(3)=(P*P-ONE)*(P*P-FOUR)/FOUR ! + A(4)=-(P+ONE)*P*(P*P-FOUR)/SIX ! + A(5)=(P*P-ONE)*P*(P+TWO)/24.0E0_WP ! +! + ELSE IF(N == 6) THEN ! +! +!.......... 6-point Lagrange interpolation ............ +! + A(1)=-P*(P*P-ONE)*(P-TWO)*(P-THREE)/120.0E0_WP ! + A(2)=P*(P-ONE)*(P*P-FOUR)*(P-THREE)/24.0E0_WP ! + A(3)=-(P*P-ONE)*(P*P-FOUR)*(P-THREE)/12.0E0_WP ! + A(4)=P*(P+ONE)*(P*P-FOUR)*(P-THREE)/12.0E0_WP ! + A(5)=-P*(P*P-ONE)*(P+TWO)*(P-THREE)/24.0E0_WP ! + A(6)=P*(P*P-ONE)*(P*P-FOUR)/120.0E0_WP ! +! + END IF ! +! + END SUBROUTINE LAGR_INTERP +! +END MODULE INTEGRATION4 diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/integration5.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/integration5.f90 new file mode 100644 index 0000000..aa0a613 --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/integration5.f90 @@ -0,0 +1,533 @@ +! +!======================================================================= +! +MODULE INTEGRATION5 +! +! This module contains Gauss quadrature routines in order to integrate +! a function F over the interval [A,B]. +! +! These routines are: +! +! * SUBROUTINE GAUSSQ(KIND,N,ALPHA,BETA,KPTS,ENDPTS,B,T,W) +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE GAUSSQ(KIND,N,ALPHA,BETA,KPTS,ENDPTS,B,T,W) +! +! This set of routines computes the nodes T(J) and weights +! W(J) for Gaussian-type quadrature rules with pre-assigned +! nodes. these are used when one wishes to approximate +! +! integral (from a to b) f(x) w(x) dx +! +! n +! by sum w f(t ) +! j=1 j j +! +! (note w(x) and W(J) have no connection with each other.) +! here w(x) is one of six possible non-negative weight +! functions (listed below), and f(x) is the +! function to be integrated. Gaussian quadrature is particularly +! useful on infinite intervals (with appropriate weight +! functions), since then other techniques often fail. +! +! Associated with each weight function w(x) is a set of +! orthogonal polynomials. The nodes T(J) are just the zeroes +! of the proper n-th degree polynomial. +! + ! input parameters (all real numbers are in double precision) +! +! KIND an integer between 1 and 6 giving the type of +! quadrature rule: +! +! KIND = 1: Legendre quadrature, w(x) = 1 on (-1, 1) +! +! KIND = 2: Chebyshev quadrature of the first kind +! w(x) = 1/sqrt(1 - x*x) on (-1, +1) +! +! KIND = 3: Chebyshev quadrature of the second kind +! w(x) = sqrt(1 - x*x) on (-1, 1) +! +! KIND = 4: Hermite quadrature, w(x) = exp(-x*x) on +! (-infinity, +infinity) +! +! KIND = 5: Jacobi quadrature, w(x) = (1-x)**ALPHA * (1+x)** +! BETA on (-1, 1), ALPHA, BETA .GT. -1. +! note: KIND=2 and 3 are a special case of this. +! +! KIND = 6: generalized Laguerre quadrature, w(x) = exp(-x)* +! x**ALPHA on (0, +infinity), ALPHA .GT. -1 +! +! N the number of points used for the quadrature rule +! ALPHA real parameter used only for Gauss-Jacobi and Gauss- +! Laguerre quadrature (otherwise use 0.d0). +! BETA real parameter used only for Gauss-Jacobi quadrature-- +! (otherwise use 0.d0) +! KPTS (integer) normally 0, unless the left or right end- +! point (or both) of the interval is required to be a +! node (this is called gauss-radau or Gauss-Lobatto +! quadrature). Then KPTS is the number of fixed +! endpoints (1 or 2). +! ENDPTS real array of length 2. Contains the values of +! any fixed endpoints, if KPTS = 1 or 2. +! B real scratch array of length N +! +! Output parameters (both double precision arrays of length N) +! +! T will contain the desired nodes. +! W will contain the desired weights W(J). +! +! Underflow may sometimes occur, but is harmless. +! +! References +! 1. Golub, G. H., and Welsch, J. H., "Calculation of Gaussian +! quadrature rules," Mathematics of Computation 23 (April, +! 1969), pp. 221-230. +! 2. Golub, G. H., "Some modified matrix eigenvalue problems," +! SIAM Review 15 (April, 1973), pp. 318-334 (section 7). +! 3. Stroud and Secrest, Gaussian Quadrature Formulas, Prentice- +! Hall, Englewood Cliffs, N.J., 1966. +! +! Original version 20 Jan 1975 from Stanford +! Modified 21 Dec 1983 by Eric Grosse +! IMTQL2 => GAUSQ2 +! hex constant => D1MACH (from core library) +! compute pi using datan +! removed accuracy claims, description of method +! added single precision version +! +! Last modified (DS) : 7 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE + USE SPECFUNC_SLATEC, ONLY : DGAMMA +! + IMPLICIT NONE +! + REAL (WP) :: B(N),T(N),W(N) + REAL (WP) :: ENDPTS(2),MUZERO,T1,GAM,ALPHA,BETA +! + REAL (WP) :: DSQRT +! + INTEGER :: KIND,KPTS + INTEGER :: N,I,IERR +! + CALL CLASS(KIND,N,ALPHA,BETA,B,T,MUZERO) ! +! +! The matrix of coefficients is assumed to be symmetric. +! The array T contains the diagonal elements, the array +! B the off-diagonal elements. +! Make appropriate changes in the lower right 2 by 2 +! submatrix. +! + IF (KPTS == 0) GO TO 100 ! + IF (KPTS == 2) GO TO 50 ! +! +! if KPTS=1, only T(N) must be changed +! + T(N) = SOLVE(ENDPTS(1),N,T,B)*B(N-1)**2 + ENDPTS(1) ! + GO TO 100 ! +! +! if KPTS=2, T(N) and B(N-1) must be recomputed +! + 50 GAM = SOLVE(ENDPTS(1),N,T,B) ! + T1 = ((ENDPTS(1) - ENDPTS(2))/(SOLVE(ENDPTS(2),N,T,B) - GAM)) ! + B(N-1) = DSQRT(T1) ! + T(N) = ENDPTS(1) + GAM*T1 ! +! +! Note that the indices of the elements of B run from 1 to n-1 +! and thus the value of B(N) is arbitrary. +! Now compute the eigenvalues of the symmetric tridiagonal +! matrix, which has been modified as necessary. +! the method used is a ql-type method with origin shifting +! + 100 W(1) = ONE ! +! + DO I=2,N ! + W(I) = ZERO ! + END DO ! +! + CALL GAUSQ2(N,T,B,W,IERR) ! +! + DO I=1,N ! + W(I) = MUZERO * W(I) * W(I) ! + END DO ! +! + END SUBROUTINE GAUSSQ +! +!======================================================================= +! + FUNCTION SOLVE(SHIFT,N,A,B) +! +! This procedure performs elimination to solve for the +! n-th component of the solution delta to the equation +! +! (jn - shift*identity) * delta = en, +! +! where en is the vector of all zeroes except for 1 in +! the n-th position. +! +! The matrix jn is symmetric tridiagonal, with diagonal +! elements A(I), off-diagonal elements B(I). This equation +! must be solved to obtain the appropriate changes in the lower +! 2 by 2 submatrix of coefficients for orthogonal polynomials. +! +! Last modified (DS) : 7 Aug 2020 +! + USE REAL_NUMBERS, ONLY : ONE +! + IMPLICIT NONE +! + REAL (WP) :: SOLVE + REAL (WP) :: SHIFT,A(N),B(N),ALPHA +! + INTEGER :: N,NM1,I +! + ALPHA = A(1) - SHIFT ! + NM1 = N - 1 ! +! + DO I=2,NM1 ! + ALPHA = A(I) - SHIFT - B(I-1)**2/ALPHA ! + END DO ! + SOLVE = ONE/ALPHA ! +! + END FUNCTION SOLVE +! +!======================================================================= +! + SUBROUTINE CLASS(KIND,N,ALPHA,BETA,B,A,MUZERO) +! +! This procedure supplies the coefficients A(J), B(J) of the +! recurrence relation +! +! b p (x) = (x - a ) p (x) - b p (x) +! j j j j-1 j-1 j-2 +! +! for the various classical (normalized) orthogonal polynomials, +! and the zero-th moment +! +! muzero = integral w(x) dx +! +! of the given polynomial's weight function w(x). Since the +! polynomials are orthonormalized, the tridiagonal matrix is +! guaranteed to be symmetric. +! +! The input parameter ALPHA is used only for Laguerre and +! Jacobi polynomials, and the parameter BETA is used only for +! Jacobi polynomials. The Laguerre and Jacobi polynomials +! require the Gamma function. +! +! Last modified (DS) : 4 Jun 2020 +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR, & + HALF +! + IMPLICIT NONE +! + REAL (WP) :: A(N),B(N) + REAL (WP) :: MUZERO,ALPHA,BETA + REAL (WP) :: ABI,A2B2,DGAMMA,PI,AB +! + REAL (WP) :: DATAN,DFLOAT,DSQRT +! + INTEGER :: KIND,N + INTEGER :: NM1,I +! + PI = FOUR * DATAN(ONE) ! + NM1 = N - 1 ! +! + IF(KIND == 1) THEN ! +! +! KIND = 1: Legendre polynomials p(x) +! on (-1, +1), w(x) = 1. +! + MUZERO = TWO ! + DO I=1,NM1 ! + A(I) = ZERO ! + ABI = DFLOAT(I) ! + B(I) = ABI/DSQRT(FOUR*ABI*ABI - ONE) + END DO ! + A(N) = ZERO ! + RETURN ! +! + ELSE IF(KIND == 2) THEN ! +! +! KIND = 2: Chebyshev polynomials of the first kind t(x) +! on (-1, +1), w(x) = 1 / sqrt(1 - x*x) +! + MUZERO = PI ! +! + DO I=1,NM1 ! + A(I) = ZERO ! + B(I) = HALF ! + END DO ! +! + B(1) = DSQRT(HALF) ! + A(N) = ZERO ! +! + RETURN ! +! + ELSE IF(KIND == 3) THEN ! +! +! KIND = 3: Chebyshev polynomials of the second kind u(x) +! on (-1, +1), w(x) = sqrt(1 - x*x) +! + MUZERO = PI/TWO ! +! + DO I=1,NM1 ! + A(I) = ZERO ! + B(I) = HALF ! + END DO ! +! + A(N) = ZERO ! +! + RETURN ! +! + ELSE IF(KIND == 4) THEN ! +! +! KIND = 4: Hermite polynomials h(x) on (-infinity, +! +infinity), w(x) = exp(-x**2) +! + MUZERO = DSQRT(PI) ! +! + DO I=1,NM1 ! + A(I) = ZERO ! + B(I) = DSQRT( DFLOAT(I)/TWO ) ! + END DO ! +! + A(N) = ZERO ! +! + RETURN ! +! + ELSE IF(KIND == 5) THEN ! +! +! KIND = 5: Jacobi polynomials p(alpha, beta)(x) on +! (-1, +1), w(x) = (1-x)**alpha + (1+x)**beta, alpha and +! beta greater than -1 +! + AB = ALPHA + BETA ! + ABI = TWO + AB ! + MUZERO = TWO ** (AB + ONE) * DGAMMA(ALPHA + ONE) * & ! + DGAMMA(BETA + ONE) / DGAMMA(ABI) ! + A(1) = (BETA - ALPHA) / ABI ! + B(1) = DSQRT( FOUR*(ONE + ALPHA)*(ONE + BETA) / & ! + ((ABI + ONE)* ABI*ABI) & ! + ) ! + A2B2 = BETA*BETA - ALPHA*ALPHA ! +! + DO I=2,NM1 ! + ABI = TWO*I + AB ! + A(I) = A2B2/((ABI - TWO)*ABI) ! + B(I) = DSQRT( FOUR*DFLOAT(I)*(DFLOAT(I) + ALPHA) * & ! + (DFLOAT(I) + BETA)*(DFLOAT(I) + AB) / & ! + ((ABI*ABI - ONE)*ABI*ABI) & ! + ) ! + END DO ! +! + ABI = TWO*N + AB ! + A(N) = A2B2/((ABI - TWO)*ABI) ! +! + RETURN ! +! + ELSE IF(KIND == 6) THEN ! +! +! KIND = 6: Laguerre polynomials l(alpha)(x) on +! (0, +infinity), w(x) = exp(-x) * x**alpha, alpha greater +! than -1. +! + MUZERO = DGAMMA(ALPHA + ONE) ! +! + DO I = 1, NM1 ! + A(I) = TWO*DFLOAT(I) - ONE + ALPHA ! + B(I) = DSQRT( DFLOAT(I)*(DFLOAT(I) + ALPHA) ) ! + END DO ! +! + A(N) = TWO*DFLOAT(N) - ONE + ALPHA ! +! + RETURN ! +! + END IF ! +! + END SUBROUTINE CLASS +! +!======================================================================= +! + SUBROUTINE GAUSQ2(N,D,E,Z,IERR) +! +! This subroutine is a translation of an Algol procedure, +! Num. Math. 12, 377-383(1968) by Martin and Wilkinson, +! as modified in Num. Math. 15, 450(1970) by Dubrulle. +! Handbook for Auto. Comp., vol.ii-Linear Algebra, 241-248(1971). +! This is a modified version of the 'EISPACK' routine IMTQL2. +! +! This subroutine finds the eigenvalues and first components of the +! eigenvectors of a symmetric tridiagonal matrix by the implicit ql +! method. +! +! On input: +! +! N is the order of the matrix; +! +! D contains the diagonal elements of the input matrix; +! +! E contains the subdiagonal elements of the input matrix +! in its first N-1 positions. E(N) is arbitrary; +! +! Z contains the first row of the identity matrix. +! +! On output: +! +! D contains the eigenvalues in ascending order. If an +! error exit is made, the eigenvalues are correct but +! unordered for indices 1, 2, ..., ierr-1; +! +! E has been destroyed; +! +! Z contains the first components of the orthonormal eigenvectors +! of the symmetric tridiagonal matrix. If an error exit is +! made, Z contains the eigenvectors associated with the stored +! eigenvalues; +! +! IERR is set to +! ZERO for normal return, +! J if the j-th eigenvalue has not been +! determined after 30 iterations. +! +! ------------------------------------------------------------------ +! +! Last modified (DS) : 11 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO + USE MACHINE_ACCURACY, ONLY : D1MACH +! + IMPLICIT NONE +! + REAL (WP) :: D(N),E(N),Z(N) + REAL (WP) :: B,C,F,G,P,R,S,MACHEP +! + REAL (WP) :: DSQRT,DABS,DSIGN +! + INTEGER :: I,J,K,L,M,N,II,MML,IERR +! + MACHEP=D1MACH(4) ! +! + IERR = 0 ! + IF(N == 1) GO TO 1001 ! +! + E(N) = ZERO ! + DO L=1,N ! +! + J = 0 ! +! +! :::::::::: look for small sub-diagonal element :::::::::: +! + 105 DO M=L,N ! + IF(M == N) GO TO 120 ! + IF( DABS(E(M)) <= MACHEP * (DABS(D(M)) + DABS(D(M+1)))& ! + ) GO TO 120 ! + END DO ! +! + 120 P = D(L) ! + IF(M == L) GO TO 240 ! + IF(J == 30) GO TO 1000 ! + J = J + 1 +! +! :::::::::: form shift :::::::::: +! + G = (D(L+1) - P) / (TWO * E(L)) ! + R = DSQRT(G*G+ONE) ! + G = D(M) - P + E(L) / (G + DSIGN(R,G)) ! + S = ONE ! + C = ONE ! + P = ZERO ! + MML = M - L ! +! +! :::::::::: for i=m-1 step -1 until l do -- :::::::::: +! + DO II=1,MML + I = M - II ! + F = S * E(I) ! + B = C * E(I) ! +! + IF(DABS(F) < DABS(G)) GO TO 150 ! +! + C = G / F ! + R = DSQRT(C*C+ONE) ! + E(I+1) = F * R ! + S = ONE / R ! + C = C * S ! + GO TO 160 ! +! + 150 S = F / G ! + R = DSQRT(S*S+ONE) ! + E(I+1) = G * R ! + C = ONE / R ! + S = S * C ! +! + 160 G = D(I+1) - P ! + R = (D(I) - G) * S + TWO * C * B ! + P = S * R ! + D(I+1) = G + P ! + G = C * R - B ! +! +! :::::::::: form first component of vector :::::::::: +! + F = Z(I+1) ! + Z(I+1) = S * Z(I) + C * F ! + Z(I) = C * Z(I) - S * F ! +! + END DO ! +! + D(L) = D(L) - P ! ! + E(L) = G ! + E(M) = ZERO ! + GO TO 105 ! +! + 240 CONTINUE ! +! + END DO ! +! +! :::::::::: order eigenvalues and eigenvectors :::::::::: +! + DO II=2,N ! +! + I = II - 1 ! + K = I ! + P = D(I) ! +! + DO J=II,N ! + IF (D(J) >= P) GO TO 260 ! + K = J ! + P = D(J) ! + 260 CONTINUE ! + END DO ! +! + IF(K == I) GO TO 300 ! + D(K) = D(I) ! + D(I) = P ! + P = Z(I) ! + Z(I) = Z(K) ! + Z(K) = P ! +! + 300 CONTINUE ! +! + END DO ! +! + GO TO 1001 ! +! +! :::::::::: set error -- no convergence to an +! eigenvalue after 30 iterations :::::::::: +! + 1000 IERR = L ! + 1001 RETURN ! +! +! :::::::::: last card of GAUSQ2 :::::::::: +! + END SUBROUTINE GAUSQ2 +! +END MODULE INTEGRATION5 diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/interpolation.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/interpolation.f90 new file mode 100644 index 0000000..5c75903 --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/interpolation.f90 @@ -0,0 +1,541 @@ +! +!======================================================================= +! +MODULE INTERPOLATION +! +! This module contains interpolation routines using the +! following approaches: +! +! +! * cubic spline interpolation : CUBIC_SPLINE_INTERP(F,X,N_X,XX) +! +! * Lagrange interpolation : LAG_NP_INTERP(X,F,XX) with N = 3-5 +! +! +! where F is the array representing the function to interpolate, +! X the abscissae array and XX the interpolation point +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + FUNCTION CUBIC_SPLINE_INTERP(F,X,N_X,XX) +! +! This function takes a user-defined function F +! and computes its value at XX +! +! +! Input parameters: +! +! * F : array defining f +! * X : array defining the abscissae of f +! * N_X : size of the X and F arrays +! * XX : value at which F is computed +! +! +! Output variables : +! +! * FUNC : value F(XX) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE DIMENSION_CODE + USE REAL_NUMBERS, ONLY : SMALL +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: N_X +! + INTEGER :: I,INTERP,NN + INTEGER :: LOGF +! + REAL (WP), INTENT(IN) :: F(NSIZE),X(NSIZE) + REAL (WP), INTENT(IN) :: XX +! + REAL (WP) :: CUBIC_SPLINE_INTERP + REAL (WP) :: DIFF,RES +! + REAL (WP) :: ABS +! + INTERP = 1 ! + LOGF = 6 ! index of log file +! +! Checking if XX is part of the X array +! + DO I = 1, N_X ! + DIFF = ABS(X(I) - XX) ! + IF(DIFF < SMALL) THEN ! + INTERP = 0 ! + NN = I ! + GO TO 10 ! + END IF ! + END DO ! + 10 CONTINUE ! +! +! Interpolation whenever necessary +! + IF(INTERP == 1) THEN ! + CALL INTERP_NR(LOGF,X,F,N_X,XX,RES) ! + CUBIC_SPLINE_INTERP = RES ! + ELSE ! + CUBIC_SPLINE_INTERP = F(NN) ! + END IF ! +! + END FUNCTION CUBIC_SPLINE_INTERP +! +!======================================================================= +! + SUBROUTINE INTERP_NR(LOGF,X,F,N_POINTS,XG,G) +! +! This subroutine interpolates a function F(X) at point XG using +! the cubic spline interpolation of +! +! "Numerical Recipes in Fortran 77 second edition" +! +! from W. H. Press, S. A. Teukolsky, W. T. Vetterling +! and B. P. Flannery, p. 109 +! +! +! Input parameters: +! +! LOGF : Fortran unit for log file +! X : x coordinates of the input function F +! F : y coordinates of the input function F +! N_POINTS : number of points of the input function +! XG : x point at which the interpolation is made +! +! +! Output parameters: +! +! G : interpolated value of F at x = XG +! +! +! Intermediate parameters: +! +! YP1 : value of first derivative of interpolating function at point 1 +! YPN : value of first derivative of interpolating function at point N +! +! If YP1 and/or YPN are larger or equal than 1.0D+30, the routine will set them +! at the boundary condition of a natural spline, with second derivative on +! that boundary. +! +! +! +! Author : D. Sébilleau +! +! Last modified : 17 Dec 2020 +! +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: N_POINTS,LOGF +! + REAL (WP), INTENT(IN) :: X(N_POINTS),F(N_POINTS) + REAL (WP), INTENT(IN) :: XG + REAL (WP), INTENT(OUT) :: G +! + REAL (WP) :: F2(N_POINTS) + REAL (WP) :: YP1,YPN +! +! Construction of the cubic spline used for the interpolation +! + YP1 = 2.0E+30_WP ! + YPN = 2.0E+30_WP ! +! + CALL SPLINE(X,F,N_POINTS,YP1,YPN,F2) ! +! +! Interpolation at x = XG +! + CALL SPLINT(X,F,F2,N_POINTS,XG,G,*10) ! +! + RETURN ! +! + 10 WRITE(LOGF,11) ! + STOP ! +! +! Formats +! + 11 FORMAT(//,10X,'<<<<< WRONG VALUE FOR XA IN SUBROUTINE ', & + ' SPLINT >>>>>',//) +! + END SUBROUTINE INTERP_NR +! +!======================================================================= +! + SUBROUTINE SPLINE(X,Y,N,YP1,YPN,Y2) +! +! This subroutine constructs the second derivative of the +! interpolating function for the input function Y = f(X). +! +! Taken from "Numerical Recipes in Fortran 77 second edition" +! +! from W. H. Press, S. A. Teukolsky, W. T. Vetterling +! and B. P. Flannery, p. 109 +! +! +! Input parameters: +! +! X : x coordinates of the input function +! Y : y coordinates of the input function +! N : number of points of the input function +! YP1 : value of first derivative of interpolating function at point 1 +! YPN : value of first derivative of interpolating function at point N +! +! +! Output parameters: +! +! Y2 : second derivative of the interpolating function on X grid +! +! +! If YP1 and/or YPN are larger or equal than 1.0D+30, the routine will set them +! at the boundary condition of a natural spline, with second derivative on +! that boundary. +! +! ---> This is the double precision version <--- +! +! +! Last modified (DS) : 21 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,HALF,MIC + USE DIMENSION_CODE, ONLY : NZ_MAX +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: N +! + INTEGER :: I,K +! + REAL (WP), INTENT(IN) :: X(N),Y(N) + REAL (WP), INTENT(IN) :: YP1,YPN + REAL (WP), INTENT(OUT) :: Y2(N) +! + REAL (WP) :: U(NZ_MAX) + REAL (WP) :: SIG,P,QN,UN +! +! Lower boundary condition +! + IF(YP1 > 0.99E+30_WP) THEN ! + Y2(1) = ZERO ! + U(1) = ZERO ! + ELSE ! + Y2(1) = - HALF ! + U(1) = ( THREE / (X(2)-X(1)) ) * & ! + ( (Y(2) - Y(1)) / (X(2) - X(1)) - YP1 ) ! + END IF ! +! +! Decomposition loop of the tridiagonal algorithm +! + DO I = 2, N-1 ! + SIG = (X(I) - X(I-1)) / (X(I+1) - X(I-1)) ! + P = SIG * Y2(I-1) + TWO ! + Y2(I) = (SIG - ONE) / P ! + U(I) = ( 6.0E0_WP * ( (Y(I+1) - Y(I)) / (X(I+1) - X(I)) - &! + (Y(I) - Y(I-1)) / (X(I) - X(I-1)) &! + ) / (X(I+1) - X(I-1)) - SIG * U(I-1) &! + ) / P ! + IF(U(I) < MIC) U(I) = ZERO ! + END DO ! +! +! Upper boundary condition +! + IF(YPN > 0.99E+30_WP) THEN ! + QN = ZERO ! + UN = ZERO ! + ELSE ! + QN = HALF ! + UN = ( THREE / (X(N) - X(N-1)) ) * & ! + ( YPN - (Y(N) - Y(N-1)) / (X(N) - X(N-1)) ) ! + END IF ! +! + Y2(N) = (UN - QN * U(N-1)) / (QN * Y2(N-1) + ONE) ! +! +! Backsubstitution loop of the tridiagonal algorithm +! + DO K = N-1, 1, -1 ! + Y2(K) = Y2(K) * Y2(K+1) + U(K) ! + END DO ! +! + END SUBROUTINE SPLINE +! +!======================================================================= +! + SUBROUTINE SPLINT(XA,YA,Y2A,N,X,Y,*) +! +! This subroutine performs a cubic spline interpolation Y +! of YA(XA) at point X +! +! Taken from "Numerical Recipes in Fortran 77 second edition" +! +! from W. H. Press, S. A. Teukolsky, W. T. Vetterling +! and B. P. Flannery, p. 110 +! +! +! Input parameters: +! +! XA : x coordinates of the input function +! YA : y coordinates of the input function +! Y2A : y coordinates second derivative of the interpolating function +! (output of subroutine SPLINE) +! N : number of points of the input function +! X : x value at which interpolation is made +! +! +! Output parameters: +! +! Y : cubic-spline interpolated value +! +! +! ---> This is the double precision version <--- +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: N +! + INTEGER :: KLO,KHI,K +! + REAL (WP), INTENT(IN) :: XA(N),YA(N),Y2A(N) + REAL (WP), INTENT(IN) :: X + REAL (WP), INTENT(OUT) :: Y +! + REAL (WP) :: H,A,B +! +! Starting values for the points of the XA grid bracketing +! the value X at which we interpolate YA +! + KLO = 1 ! + KHI = N ! +! +! Bisection algorithm to find the exact values of KLO and KHI +! + 1 IF(KHI - KLO > 1) THEN ! + K = (KHI + KLO) / 2 ! + IF(XA(K) > X) THEN ! + KHI = K ! + ELSE ! + KLO = K ! + END IF ! + GO TO 1 ! + END IF ! +! +! Now, KLO < X < KHI +! + H = XA(KHI) - XA(KLO) ! +! + IF(H == ZERO) RETURN 1 ! +! +! Evaluation of the cubic spline polynomial +! + A = (XA(KHI) - X) / H ! + B = (X - XA(KLO)) / H ! + Y = A * YA(KLO) + B * YA(KHI) + & ! + ( (A**3 - A) * Y2A(KLO) + (B**3 - B) * Y2A(KHI) ) * & ! + (H**2) / 6.0E0_WP ! +! + END SUBROUTINE SPLINT +! +!======================================================================= +! + FUNCTION LAG_3P_INTERP(X,A,XX) +! +! This function computes a 3-point Lagrange interpolation +! +! Reference: (1) https://en.wikipedia.org/wiki/Lagrange_polynomial +! +! Input parameters : +! +! * X : array containing the abscissae of A +! * A : function to interpolate +! * XX : interpolation point +! +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X(3),A(3) + REAL (WP), INTENT(IN) :: XX + REAL (WP) :: LAG_3P_INTERP +! + REAL (WP) :: L1,L2,L3 +! +! Computing the Lagrange polynomials in XX +! + L1 = (XX-X(2))/(X(1)-X(2)) * (XX-X(3))/(X(1)-X(3)) ! + L2 = (XX-X(1))/(X(2)-X(1)) * (XX-X(3))/(X(2)-X(3)) ! + L3 = (XX-X(1))/(X(3)-X(1)) * (XX-X(2))/(X(3)-X(2)) ! +! +! Computing the interpolated value +! + LAG_3P_INTERP = A(1) * L1 + A(2) * L2 + A(3) * L3 ! +! + END FUNCTION LAG_3P_INTERP +! +!======================================================================= +! + FUNCTION LAG_4P_INTERP(X,A,XX) +! +! This function computes a 4-point Lagrange interpolation +! +! Reference: (1) https://en.wikipedia.org/wiki/Lagrange_polynomial +! +! Input parameters : +! +! * X : array containing the abscissae of A +! * A : function to interpolate +! * XX : interpolation point +! +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + IMPLICIT NONE +! + REAL (WP) :: X(4),A(4) + REAL (WP) :: XX + REAL (WP) :: LAG_4P_INTERP + REAL (WP) :: L1,L2,L3,L4 +! +! Computing the Lagrange polynomials in XX +! + L1 = (XX-X(2))/(X(1)-X(2)) * (XX-X(3))/(X(1)-X(3)) * & ! + (XX-X(4))/(X(1)-X(4)) ! + L2 = (XX-X(1))/(X(2)-X(1)) * (XX-X(3))/(X(2)-X(3)) * & ! + (XX-X(4))/(X(2)-X(4)) ! + L3 = (XX-X(1))/(X(3)-X(1)) * (XX-X(2))/(X(3)-X(2)) * & ! + (XX-X(4))/(X(3)-X(4)) ! + L4 = (XX-X(1))/(X(4)-X(1)) * (XX-X(2))/(X(4)-X(2)) * & ! + (XX-X(3))/(X(4)-X(3)) ! +! +! Computing the interpolated value +! + LAG_4P_INTERP = A(1)*L1 + A(2)*L2 + A(3)*L3 + A(4)*L4 ! +! + END FUNCTION LAG_4P_INTERP +! +!======================================================================= +! + FUNCTION LAG_5P_INTERP(X,A,XX) +! +! This function computes a 5-point Lagrange interpolation +! +! Reference: (1) https://en.wikipedia.org/wiki/Lagrange_polynomial +! +! Input parameters : +! +! * X : array containing the abscissae of A +! * A : function to interpolate +! * XX : interpolation point +! +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + IMPLICIT NONE +! + REAL (WP) :: X(5),A(5) + REAL (WP) :: XX + REAL (WP) :: LAG_5P_INTERP + REAL (WP) :: L1,L2,L3,L4,L5 +! +! Computing the Lagrange polynomials in XX +! + L1 = (XX-X(2))/(X(1)-X(2)) * (XX-X(3))/(X(1)-X(3)) * & ! + (XX-X(4))/(X(1)-X(4)) * (XX-X(5))/(X(1)-X(5)) ! + L2 = (XX-X(1))/(X(2)-X(1)) * (XX-X(3))/(X(2)-X(3)) * & ! + (XX-X(4))/(X(2)-X(4)) * (XX-X(5))/(X(2)-X(5)) ! + L3 = (XX-X(1))/(X(3)-X(1)) * (XX-X(2))/(X(3)-X(2)) * & ! + (XX-X(4))/(X(3)-X(4)) * (XX-X(5))/(X(3)-X(5)) ! + L4 = (XX-X(1))/(X(4)-X(1)) * (XX-X(2))/(X(4)-X(2)) * & ! + (XX-X(3))/(X(4)-X(3)) * (XX-X(5))/(X(4)-X(5)) ! + L5 = (XX-X(1))/(X(5)-X(1)) * (XX-X(2))/(X(5)-X(2)) * & ! + (XX-X(3))/(X(5)-X(3)) * (XX-X(4))/(X(5)-X(4)) ! +! +! Computing the interpolated value +! + LAG_5P_INTERP= A(1)*L1 + A(2)*L2 + A(3)*L3 + A(4)*L4 + A(5)*L5! +! + END FUNCTION LAG_5P_INTERP +! +!======================================================================= +! + FUNCTION LAG_6P_INTERP(X,A,XX) +! +! This function computes a 6-point Lagrange interpolation +! +! Reference: (1) https://en.wikipedia.org/wiki/Lagrange_polynomial +! +! Input parameters : +! +! * X : array containing the abscissae of A +! * A : function to interpolate +! * XX : interpolation point +! +! +! +! Author : D. Sébilleau +! +! Last modified : 15 Sep 2020 +! +! + IMPLICIT NONE +! + REAL (WP) :: X(6),A(6) + REAL (WP) :: XX + REAL (WP) :: LAG_6P_INTERP + REAL (WP) :: L1,L2,L3,L4,L5,L6 +! +! Computing the Lagrange polynomials in XX +! + L1 = (XX-X(2))/(X(1)-X(2)) * (XX-X(3))/(X(1)-X(3)) * & ! + (XX-X(4))/(X(1)-X(4)) * (XX-X(5))/(X(1)-X(5)) * & ! + (XX-X(6))/(X(1)-X(6)) ! +! + L2 = (XX-X(1))/(X(2)-X(1)) * (XX-X(3))/(X(2)-X(3)) * & ! + (XX-X(4))/(X(2)-X(4)) * (XX-X(5))/(X(2)-X(5)) * & ! + (XX-X(6))/(X(2)-X(6)) ! +! + L3 = (XX-X(1))/(X(3)-X(1)) * (XX-X(2))/(X(3)-X(2)) * & ! + (XX-X(4))/(X(3)-X(4)) * (XX-X(5))/(X(3)-X(5)) * & ! + (XX-X(6))/(X(3)-X(6)) ! +! + L4 = (XX-X(1))/(X(4)-X(1)) * (XX-X(2))/(X(4)-X(2)) * & ! + (XX-X(3))/(X(4)-X(3)) * (XX-X(5))/(X(4)-X(5)) * & ! + (XX-X(6))/(X(4)-X(6)) ! +! + L5 = (XX-X(1))/(X(5)-X(1)) * (XX-X(2))/(X(5)-X(2)) * & ! + (XX-X(3))/(X(5)-X(3)) * (XX-X(4))/(X(5)-X(4)) * & ! + (XX-X(6))/(X(5)-X(6)) ! +! + L6 = (XX-X(1))/(X(6)-X(1)) * (XX-X(2))/(X(6)-X(2)) * & ! + (XX-X(3))/(X(6)-X(3)) * (XX-X(4))/(X(6)-X(4)) * & ! + (XX-X(5))/(X(6)-X(5)) ! +! +! Computing the interpolated value +! + LAG_6P_INTERP = A(1) * L1 + A(2) * L2 + A(3) * L3 + & ! + A(4) * L4 + A(5) * L5 + A(6) * L6 ! +! + END FUNCTION LAG_6P_INTERP +! +END MODULE INTERPOLATION diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/mathematical_constants.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/mathematical_constants.f90 new file mode 100644 index 0000000..078636e --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/mathematical_constants.f90 @@ -0,0 +1,658 @@ +! +!======================================================================= +! +MODULE BELL +! +! This module defines Bell numbers +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP), DIMENSION(0:20), PARAMETER :: BL = (/ 1.00000000000000000000000000E0_WP, & + 1.00000000000000000000000000E0_WP, & + 2.00000000000000000000000000E0_WP, & + 5.00000000000000000000000000E0_WP, & + 15.00000000000000000000000000E0_WP, & + 52.00000000000000000000000000E0_WP, & + 203.00000000000000000000000000E0_WP, & + 877.00000000000000000000000000E0_WP, & + 4140.00000000000000000000000000E0_WP, & + 21147.00000000000000000000000000E0_WP, & + 115975.00000000000000000000000000E0_WP, & + 678570.00000000000000000000000000E0_WP, & + 4213597.00000000000000000000000000E0_WP, & + 27644437.00000000000000000000000000E0_WP, & + 190899322.00000000000000000000000000E0_WP, & + 1382958545.00000000000000000000000000E0_WP, & + 10480142147.00000000000000000000000000E0_WP, & + 82864869804.00000000000000000000000000E0_WP, & + 682076806159.00000000000000000000000000E0_WP, & + 5832742205057.00000000000000000000000000E0_WP, & + 51724158235372.00000000000000000000000000E0_WP /) +! +END MODULE BELL +! +!======================================================================= +! +MODULE BERNOUILLI +! +! This module defines Bernouilli numbers +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP), DIMENSION(0:20), PARAMETER :: BN = (/ 1.00000000000000000000000000E0_WP, & ! 1 + -0.50000000000000000000000000E0_WP, & ! -1/2 + 0.16666666666666666666666667E0_WP, & ! 1/6 + 0.00000000000000000000000000E0_WP, & ! 0 + -0.03333333333333333333333333E0_WP, & ! -1/30 + 0.00000000000000000000000000E0_WP, & ! 0 + 0.02380952380952380952380952E0_WP, & ! 1/42 + 0.00000000000000000000000000E0_WP, & ! 0 + -0.03333333333333333333333333E0_WP, & ! -1/30 + 0.00000000000000000000000000E0_WP, & ! 0 + 0.07575757575757575757575758E0_WP, & ! 5/66 + 0.00000000000000000000000000E0_WP, & ! 0 + -0.25311355311355311355311355E0_WP, & ! -691/2730 + 0.00000000000000000000000000E0_WP, & ! 0 + 1.16666666666666666666666667E0_WP, & ! 7/6 + 0.00000000000000000000000000E0_WP, & ! 0 + -7.09215686274509803921568627E0_WP, & ! -3617/510 + 0.00000000000000000000000000E0_WP, & ! 0 + 54.97117794486215538847117794E0_WP, & ! 43867/798 + 0.00000000000000000000000000E0_WP, & ! 0 + -529.12424242424242424242424242E0_WP /) ! -174611/330 +! +END MODULE BERNOUILLI +! +!======================================================================= +! +MODULE BINOMIAL +! +! This module defines the values of the binomial coefficients +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + FUNCTION C(N,K) +! k n! +! This function computes the binomial coefficients C = ( n ) = ----------- +! n ( k ) k! (n-k)! +! +! Input parameters: +! +! * N,K : input integer numbers +! +! Output variables : +! +! * C : binomial coefficient C(n,k) +! +! +! Author : D. Sébilleau +! +! Last modified : 20 Sep 2021 +! +! + IMPLICIT NONE +! + REAL (WP) :: C + REAL (WP) :: S(0:10,0:10) +! + INTEGER :: N,K + INTEGER :: I,J +! +! Initialization +! + DO I=0,10 ! + DO J=0,10 ! + S(I,J)=0.0E0_WP ! + END DO ! + END DO ! +! +! Particular values +! + DO I=0,10 ! + S(I,0)=1.0E0_WP ! + S(I,1)=DFLOAT(I) ! + IF(I > 0) THEN ! + S(I,I-1)=DFLOAT(I) ! + END IF ! + S(I,I)=1.0E0_WP ! + END DO +! + S(4,2)=6.0E0_WP ! +! + S(5,2)=10.0E0_WP ! + S(5,3)=10.0E0_WP ! +! + S(6,2)=15.0E0_WP ! + S(6,3)=20.0E0_WP ! + S(6,4)=15.0E0_WP ! +! + S(7,2)=21.0E0_WP ! + S(7,3)=35.0E0_WP ! + S(7,4)=35.0E0_WP ! + S(7,5)=21.0E0_WP ! +! + S(8,2)=28.0E0_WP ! + S(8,3)=56.0E0_WP ! + S(8,4)=70.0E0_WP ! + S(8,5)=56.0E0_WP ! + S(8,6)=28.0E0_WP ! +! + S(9,2)= 36.0E0_WP ! + S(9,3)= 84.0E0_WP ! + S(9,4)=126.0E0_WP ! + S(9,5)=126.0E0_WP ! + S(9,6)= 84.0E0_WP ! + S(9,7)= 36.0E0_WP ! +! + S(10,2)= 45.0E0_WP ! + S(10,3)=120.0E0_WP ! + S(10,4)=210.0E0_WP ! + S(10,5)=252.0E0_WP ! + S(10,6)=210.0E0_WP ! + S(10,7)=120.0E0_WP ! + S(10,8)= 45.0E0_WP ! +! + IF(K <= N) THEN ! + C=S(N,K) ! + ELSE ! + C=0.0E0_WP ! + END IF ! +! + END FUNCTION C +! +END MODULE BINOMIAL +! +!======================================================================= +! +MODULE CUBE_ROOTS +! +! This module defines standard cube roots +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP), PARAMETER :: CUB2 = 1.25992104989487316476721061E0_WP ! cube root of 2 + REAL (WP), PARAMETER :: CUB3 = 1.44224957030740838232163831E0_WP ! cube root of 3 + REAL (WP), PARAMETER :: CUB4 = 1.58740105196819947475170564E0_WP ! cube root of 4 + REAL (WP), PARAMETER :: CUB5 = 1.70997594667669698935310887E0_WP ! cube root of 5 + REAL (WP), PARAMETER :: CUB6 = 1.81712059283213965889121176E0_WP ! cube root of 6 + REAL (WP), PARAMETER :: CUB7 = 1.91293118277238910119911684E0_WP ! cube root of 7 +! +END MODULE CUBE_ROOTS +! +!======================================================================= +! +MODULE DIRICHLET +! +! This module defines the Dirichlet beta function +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP), DIMENSION(0:20), PARAMETER :: DB = (/ 0.50000000000000000000000000E0_WP, & ! 1/2 + 0.78539816339744830961566085E0_WP, & ! pi/4 + 0.91596559417721901505460351E0_WP, & ! Catalan's constant + 0.96894614625936938048363485E0_WP, & ! pi^2 /32 + 0.98894455174110533610842263E0_WP, & ! + 0.99615782807708806400631937E0_WP, & ! 5 pi^2 / 1536 + 0.99868522221843813544160079E0_WP, & ! + 0.99955450789053990949634655E0_WP, & ! 61 pi^7 / 184320 + 0.99984999024682965633806706E0_WP, & ! + 0.99994968418722008982135887E0_WP, & ! 277 pi^9 / 8257536 + 0.99998316402619687740554073E0_WP, & ! + 0.99999437497382369916918245E0_WP, & ! 50521 pi^11 / 14863564800 + 0.99999812235058788220654297E0_WP, & ! + 0.99999937358377184111280361E0_WP, & ! 540553 pi^13 / 1569592442880 + 0.99999979108724873385223325E0_WP, & ! + 0.99999993034084262438716069E0_WP, & ! 199360981 pi^15 / 5713316492083200 + 0.99999997677595090321057729E0_WP, & ! + 0.99999999225778210428842451E0_WP, & ! + 0.99999999741908674468308413E0_WP, & ! + 0.99999999913966074455903291E0_WP, & ! + 0.99999999971321327422902900E0_WP /) ! +! +END MODULE DIRICHLET +! +!======================================================================= +! +MODULE EULER_CONST +! +! This module defines the Euler contants +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP), PARAMETER :: EULER = 2.71828182845904523536028747E0_WP ! Euler constant e + REAL (WP), PARAMETER :: EUMAS = 0.57721566490153286060651209E0_WP ! Euler-Mascheroni gamma +! +END MODULE EULER_CONST +! +!======================================================================= +! +MODULE EULER_NUMB +! +! This module defines the Euler numbers +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP), DIMENSION(0:20), PARAMETER :: EN = (/ 1.00000000000000000000000000E0_WP, & + 0.00000000000000000000000000E0_WP, & + -1.00000000000000000000000000E0_WP, & + 0.00000000000000000000000000E0_WP, & + 5.00000000000000000000000000E0_WP, & + 0.00000000000000000000000000E0_WP, & + -61.00000000000000000000000000E0_WP, & + 0.00000000000000000000000000E0_WP, & + 1385.00000000000000000000000000E0_WP, & + 0.00000000000000000000000000E0_WP, & + -50521.00000000000000000000000000E0_WP, & + 0.00000000000000000000000000E0_WP, & + 2702765.00000000000000000000000000E0_WP, & + 0.00000000000000000000000000E0_WP, & + -199360981.00000000000000000000000000E0_WP, & + 0.00000000000000000000000000E0_WP, & + 19391512145.00000000000000000000000000E0_WP, & + 0.00000000000000000000000000E0_WP, & + -2404879675145.00000000000000000000000000E0_WP, & + 0.00000000000000000000000000E0_WP, & + 370371188237525.00000000000000000000000000E0_WP /) +! +END MODULE EULER_NUMB +! +!======================================================================= +! +MODULE FIBONACCI +! +! This module defines the Fibonacci numbers +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP), DIMENSION(0:20), PARAMETER :: FN = (/ 0.00000000000000000000000000E0_WP, & + 1.00000000000000000000000000E0_WP, & + 1.00000000000000000000000000E0_WP, & + 2.00000000000000000000000000E0_WP, & + 3.00000000000000000000000000E0_WP, & + 5.00000000000000000000000000E0_WP, & + 8.00000000000000000000000000E0_WP, & + 13.00000000000000000000000000E0_WP, & + 21.00000000000000000000000000E0_WP, & + 34.00000000000000000000000000E0_WP, & + 55.00000000000000000000000000E0_WP, & + 89.00000000000000000000000000E0_WP, & + 144.00000000000000000000000000E0_WP, & + 233.00000000000000000000000000E0_WP, & + 377.00000000000000000000000000E0_WP, & + 610.00000000000000000000000000E0_WP, & + 987.00000000000000000000000000E0_WP, & + 1597.00000000000000000000000000E0_WP, & + 2584.00000000000000000000000000E0_WP, & + 4181.00000000000000000000000000E0_WP, & + 6765.00000000000000000000000000E0_WP /) +! +END MODULE FIBONACCI +! +!======================================================================= +! +MODULE GAMMA_FUNC +! +! This module defines various values of the Gamma function +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP), PARAMETER :: GAM_1_HALF= 1.77245385090551602729816748E0_WP ! Gamma(1/2) + REAL (WP), PARAMETER :: GAM_1_3RD = 2.67893853470774763365569294E0_WP ! Gamma(1/3) + REAL (WP), PARAMETER :: GAM_2_3RD = 1.35411793942640041694528803E0_WP ! Gamma(2/3) + REAL (WP), PARAMETER :: GAM_1_4TH = 3.62560990822190831193068515E0_WP ! Gamma(1/4) + REAL (WP), PARAMETER :: GAM_3_4TH = 1.22541670246517764512909830E0_WP ! Gamma(3/4) + REAL (WP), PARAMETER :: GAM_4_3RD = 0.89297951156924921121856431E0_WP ! Gamma(4/3) + REAL (WP), PARAMETER :: GAM_5_3RD = 0.90274529295093361129685868E0_WP ! Gamma(5/3) + REAL (WP), PARAMETER :: GAM_5_4TH = 0.90640247705547707798267129E0_WP ! Gamma(5/4) + REAL (WP), PARAMETER :: GAM_7_4TH = 0.91906252684888323384682373E0_WP ! Gamma(7/4) +! + COMPLEX (WP), PARAMETER :: GAM_I =(-0.15494982830181068512495513E0_WP, &! + -0.49801566811835604271369112E0_WP) ! Gamma(i) + COMPLEX (WP), PARAMETER :: GAM_1I =( 0.49801566811835604271369112E0_WP, &! + -0.15494982830181068512495513E0_WP) ! Gamma(i+1) +! +END MODULE GAMMA_FUNC +! +!======================================================================= +! +MODULE PI_ETC +! +! This module defines Pi-related values +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP), PARAMETER :: PI = 3.14159265358979323846264338E0_WP ! pi + REAL (WP), PARAMETER :: PI2 = 9.86960440108935861883449099E0_WP ! pi^2 + REAL (WP), PARAMETER :: PI3 = 31.00627668029982017547631507E0_WP ! pi^3 + REAL (WP), PARAMETER :: PI_INV = 0.31830988618379067153776753E0_WP ! 1/pi + REAL (WP), PARAMETER :: SQR_PI = 1.77245385090551602729816748E0_WP ! sqrt(pi) + REAL (WP), PARAMETER :: CUB_PI = 1.46459188756152326302014253E0_WP ! cube root of pi + REAL (WP), PARAMETER :: LOG_PI = 1.14472988584940017414342735E0_WP ! Log(pi) +! +END MODULE PI_ETC +! +!======================================================================= +! +MODULE SQUARE_ROOTS +! +! This module defines values standard square roots +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP), PARAMETER :: SQR2 = 1.41421356237309504880168872E0_WP ! sqrt(2) + REAL (WP), PARAMETER :: SQR3 = 1.73205080756887729352744634E0_WP ! sqrt(3) + REAL (WP), PARAMETER :: SQR5 = 2.23606797749978969640917367E0_WP ! sqrt(5) + REAL (WP), PARAMETER :: SQR6 = 2.44948974278317809819728407E0_WP ! sqrt(6) + REAL (WP), PARAMETER :: SQR7 = 2.64575131106459059050161575E0_WP ! sqrt(7) +! + COMPLEX (WP), PARAMETER :: SQRI =( 0.70710678118654752440084436E0_WP ,&! + 0.70710678118654752440084436E0_WP) ! sqrt(i) +! +END MODULE SQUARE_ROOTS +! +!======================================================================= +! +MODULE STERLING_1 +! +! This module defines the values of the (signed) Stirling numbers of the first kind +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + FUNCTION SNK_1(N,K) +! +! This function computes the Stirling numbers of the first kind +! +! +! Input parameters: +! +! * N,K : input integer numbers +! +! Output variables : +! +! * SNK_1 : Stirling number S(n,k) +! +! +! Author : D. Sébilleau +! +! Last modified : 7 Aug 2020 +! +! + IMPLICIT NONE +! + REAL (WP) :: SNK_1 + REAL (WP) :: S(0:10,0:10) +! + INTEGER :: N,K + INTEGER :: I,J +! +! Initialization +! + DO I=0,10 ! + DO J=0,10 ! + S(I,J)=0.0E0_WP ! + END DO ! + END DO ! +! +! Particular values +! + DO I=0,10 ! + S(I,I)=1.0E0_WP ! + END DO +! + S(2,1)=-1.0E0_WP ! +! + S(3,1)= 2.0E0_WP ! + S(3,2)=-3.0E0_WP ! +! + S(4,1)= -6.0E0_WP ! + S(4,2)= 11.0E0_WP ! + S(4,3)= -6.0E0_WP ! +! + S(5,1)= 24.0E0_WP ! + S(5,2)=-50.0E0_WP ! + S(5,3)= 35.0E0_WP ! + S(5,4)=-10.0E0_WP ! +! + S(6,1)=-120.0E0_WP ! + S(6,2)= 274.0E0_WP ! + S(6,3)=-225.0E0_WP ! + S(6,4)= 85.0E0_WP ! + S(6,5)= -15.0E0_WP ! +! + S(7,1)= 720.0E0_WP ! + S(7,2)=-1764.0E0_WP ! + S(7,3)= 1624.0E0_WP ! + S(7,4)= -735.0E0_WP ! + S(7,5)= 175.0E0_WP ! + S(7,6)= -21.0E0_WP ! +! + S(8,1)= -5040.0E0_WP ! + S(8,2)= 13068.0E0_WP ! + S(8,3)=-13132.0E0_WP ! + S(8,4)= 6769.0E0_WP ! + S(8,5)= -1960.0E0_WP ! + S(8,6)= 322.0E0_WP ! + S(8,7)= -28.0E0_WP ! +! + S(9,1)= 40320.0E0_WP ! + S(9,2)=-109584.0E0_WP ! + S(9,3)= 118124.0E0_WP ! + S(9,4)= -67284.0E0_WP ! + S(9,5)= 22449.0E0_WP ! + S(9,6)= -4536.0E0_WP ! + S(9,7)= 546.0E0_WP ! + S(9,8)= -36.0E0_WP ! +! + S(10,1)= -362880.0E0_WP ! + S(10,2)= 1026576.0E0_WP ! + S(10,3)=-1172700.0E0_WP ! + S(10,4)= 723680.0E0_WP ! + S(10,5)= -269325.0E0_WP ! + S(10,6)= 63273.0E0_WP ! + S(10,7)= -9450.0E0_WP ! + S(10,8)= 870.0E0_WP ! + S(10,9)= -45.0E0_WP ! +! + IF(K <= N) THEN ! + SNK_1=S(N,K) ! + ELSE ! + SNK_1=0.0E0_WP ! + END IF ! +! + END FUNCTION SNK_1 +! +END MODULE STERLING_1 +! +!======================================================================= +! +MODULE STERLING_2 +! +! This module defines the values of the Stirling numbers of the second kind +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + FUNCTION SNK_2(N,K) +! +! This function computes the Stirling numbers of the second kind +! +! +! Input parameters: +! +! * N,K : input integer numbers +! +! Output variables : +! +! * SNK_2 : Stirling number S(n,k) +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Aug 2020 +! +! + IMPLICIT NONE +! + REAL (WP) :: SNK_2 + REAL (WP) :: S(0:10,0:10) +! + INTEGER :: N,K + INTEGER :: I,J +! +! Initialization +! + DO I=0,10 ! + DO J=0,10 ! + S(I,J)=0.0E0_WP ! + END DO ! + END DO ! +! +! Particular values +! + S(0,0)=1.0E0_WP ! +! + DO I=0,10 ! + S(I,1)=1.0E0_WP ! + S(I,I)=1.0E0_WP ! + END DO +! + S(3,2)=3.0E0_WP ! +! + S(4,2)=7.0E0_WP ! + S(4,3)=6.0E0_WP ! +! + S(5,2)=15.0E0_WP ! + S(5,3)=25.0E0_WP ! + S(5,4)=10.0E0_WP ! +! + S(6,2)=31.0E0_WP ! + S(6,3)=90.0E0_WP ! + S(6,4)=65.0E0_WP ! + S(6,5)=15.0E0_WP ! +! + S(7,2)= 63.0E0_WP ! + S(7,3)=301.0E0_WP ! + S(7,4)=350.0E0_WP ! + S(7,5)=140.0E0_WP ! + S(7,6)= 21.0E0_WP ! +! + S(8,2)= 127.0E0_WP ! + S(8,3)= 966.0E0_WP ! + S(8,4)=1701.0E0_WP ! + S(8,5)=1050.0E0_WP ! + S(8,6)= 266.0E0_WP ! + S(8,7)= 28.0E0_WP ! +! + S(9,2)= 255.0E0_WP ! + S(9,3)=3025.0E0_WP ! + S(9,4)=7770.0E0_WP ! + S(9,5)=6951.0E0_WP ! + S(9,6)=2646.0E0_WP ! + S(9,7)= 462.0E0_WP ! + S(9,8)= 36.0E0_WP ! +! + S(10,2)= 511.0E0_WP ! + S(10,3)= 9330.0E0_WP ! + S(10,4)=34105.0E0_WP ! + S(10,5)=42525.0E0_WP ! + S(10,6)=22827.0E0_WP ! + S(10,7)= 5880.0E0_WP ! + S(10,8)= 750.0E0_WP ! + S(10,9)= 45.0E0_WP ! +! + IF(K <= N) THEN ! + SNK_2=S(N,K) ! + ELSE ! + SNK_2=0.0E0_WP ! + END IF ! +! + END FUNCTION SNK_2 +! +END MODULE STERLING_2 +! +!======================================================================= +! +MODULE ZETA_RIEMANN +! +! This module defines values of Riemann's zeta function +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP), PARAMETER :: ZETA(-20:20) = (/ & ! + 0.00000000000000000000000000E0_WP, & ! 0 (-20) + 26.45621212121212121212121212E0_WP, & ! 174611 / 6600 (-19) + 0.00000000000000000000000000E0_WP, & ! 0 (-18) + -3.05395433027011974380395433E0_WP, & ! -43867 / 14364 (-17) + 0.00000000000000000000000000E0_WP, & ! 0 (-16) + 0.44325980392156862745098039E0_WP, & ! 3617 / 8160 (-15) + 0.00000000000000000000000000E0_WP, & ! 0 (-14) + -0.08333333333333333333333333E0_WP, & ! -1 / 12 (-13) + 0.00000000000000000000000000E0_WP, & ! 0 (-12) + 0.02109279609279609279609279E0_WP, & ! 691 / 32760 (-11) + 0.00000000000000000000000000E0_WP, & ! 0 (-10) + -0.00757575757575757575757576E0_WP, & ! -1 / 132 (- 9) + 0.00000000000000000000000000E0_WP, & ! 0 (- 8) + 0.00416666666666666666666667E0_WP, & ! 1 / 240 (- 7) + 0.00000000000000000000000000E0_WP, & ! 0 (- 6) + -0.00396825396825396825396825E0_WP, & ! -1 / 252 (- 5) + 0.00000000000000000000000000E0_WP, & ! 0 (- 4) + 0.00833333333333333333333333E0_WP, & ! 1 / 120 (- 3) + 0.00000000000000000000000000E0_WP, & ! 0 (- 2) + -0.08333333333333333333333333E0_WP, & ! -1 / 12 (- 1) + -0.50000000000000000000000000E0_WP, & ! -1 / 2 ( 0) + 1.000000000000000000000000E+30_WP, & ! infinity ( 1) + 1.64493406684822643647241517E0_WP, & ! pi^2 / 6 ( 2) + 1.20205690315959428539973816E0_WP, & ! Apéry's constant ( 3) + 1.08232323371113819151600369E0_WP, & ! pi^4 / 90 ( 4) + 1.03692775514336992633136549E0_WP, & ! ( 5) + 1.01734306198444913971451793E0_WP, & ! pi^6 / 945 ( 6) + 1.00834927738192282683979755E0_WP, & ! ( 7) + 1.00407735619794433937868524E0_WP, & ! pi^8 / 9450 ( 8) + 1.00200839282608221441785277E0_WP, & ! ( 9) + 1.00099457512781808533714596E0_WP, & ! pi^10 / 93555 ( 10) + 1.00049418860411946455870228E0_WP, & ! ( 11) + 1.00024608655330804829863799E0_WP, & ! 691 pi^12 / 638512875 ( 12) + 1.00012271334757848914675184E0_WP, & ! ( 13) + 1.00006124813505870482925854E0_WP, & ! 2 pi^14 / 18243225 ( 14) + 1.00003058823630702049355173E0_WP, & ! ( 15) + 1.00001528225940865187173257E0_WP, & ! ( 16) + 1.00000763719763789976227360E0_WP, & ! ( 17) + 1.00000381729326499983985646E0_WP, & ! ( 18) + 1.00000190821271655393892566E0_WP, & ! ( 19) + 1.00000095396203387279611315E0_WP & ! ( 20) + /) ! +! +END MODULE ZETA_RIEMANN diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/oxides_properties.odt b/New_libraries/DFM_library/UTILITIES_LIBRARY/oxides_properties.odt new file mode 100644 index 0000000..9f1c84b Binary files /dev/null and b/New_libraries/DFM_library/UTILITIES_LIBRARY/oxides_properties.odt differ diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/physical_constants.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/physical_constants.f90 new file mode 100644 index 0000000..1965635 --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/physical_constants.f90 @@ -0,0 +1,99 @@ +! +!======================================================================= +! +MODULE CONSTANTS_P1 +! +! This module defines standard physical constants +! +! Note : COULOMB = 1 / (4 pi epsilon_0) +! +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: BOHR =5.2917721067E-011_WP ! Bohr radius ... a_0 + REAL (WP) :: H_BAR =1.054571800E-034_WP ! reduced Planck constant ... J s + REAL (WP) :: M_E =9.10938356E-031_WP ! electron mass ... kg + REAL (WP) :: E =1.6021766208E-019_WP ! charge of electron ... C + REAL (WP) :: EPS_0 =8.854187817E-012_WP ! vacuum permittivity ... F / m + REAL (WP) :: COULOMB=8.9875517873681764E+009_WP ! Coulomb constant ... kg m^3 / (s^4 A^2) + REAL (WP) :: K_B =1.38064852E-023_WP ! Boltzmann constant ... J / K +! +END MODULE CONSTANTS_P1 +! +!======================================================================= +! +MODULE CONSTANTS_P2 +! +! This module defines standard physical constants +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: ALPHA =7.2973525664E-003_WP ! fine structure constant ... dimensionless + REAL (WP) :: HARTREE=4.359744650E-018_WP ! Hartree energy ... J + REAL (WP) :: RYDBERG=10973731.568508E0_WP ! Rydberg constant ... m^{-1} +! +END MODULE CONSTANTS_P2 +! +!======================================================================= +! +MODULE CONSTANTS_P3 +! +! This module defines standard physical constants +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: R_E =2.8179403227E-015_WP ! classical electron radius ... m + REAL (WP) :: M_P =1.672621898E-027_WP ! proton mass ... kg + REAL (WP) :: M_N =1.674927211E-027_WP ! neutron mass ... kg + REAL (WP) :: C =299792458.0E0_WP ! speed of light in vacuum ... m/s + REAL (WP) :: G =6.67408E-011_WP ! constant of gravitation ... m^3 / (kg s^2) + REAL (WP) :: PLANCK=6.626070040E-034_WP ! Planck constant ... J s + REAL (WP) :: MU_0 =1.256637061E-006_WP ! vacuum permeability ... N / A^2 + REAL (WP) :: MU_B =9.274009994E-024_WP ! Bohr magneton ... J / T + REAL (WP) :: MU_N =5.050783699E-027_WP ! nuclear magneton ... J / T + REAL (WP) :: N_A =6.022140857E+023_WP ! Avogadro constant ... mol^{-1} +! +END MODULE CONSTANTS_P3 +! +!======================================================================= +! +MODULE G_FACTORS +! +! This module defines standard physical constants +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: G_E=-2.00231930436182E0_WP ! electron g-factor ... dimensionless + REAL (WP) :: G_P=+5.585694702E0_WP ! proton g-factor ... dimensionless + REAL (WP) :: G_N=-3.82608545E0_WP ! neutron g-factor ... dimensionless +! +END MODULE G_FACTORS +! +!======================================================================= +! +MODULE ENE_CHANGE +! +! This module defines energy, etc change factors +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP) :: EV =1.6021766208E-019_WP ! electron volt ... J + REAL (WP) :: RYD =13.605693009E0_WP ! Rydberg energy ... eV + REAL (WP) :: HAR =27.21138602E0_WP ! Hartree energy ... eV + REAL (WP) :: BOHR2A=0.52917721067E0_WP ! Bohr radius ... Angstroem + REAL (WP) :: ANG =1.0E-010_WP ! Angstroem ... m + REAL (WP) :: RY2SI =2.17987232488E-18_WP ! conversion Ryd --> SI +! + REAL (WP) :: ROOM =273.0E0_WP ! room temperature ... K +! +END MODULE ENE_CHANGE diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/polynomial_equations.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/polynomial_equations.f90 new file mode 100644 index 0000000..358f609 --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/polynomial_equations.f90 @@ -0,0 +1,366 @@ +! +!======================================================================= +! +MODULE POLYNOMIAL_EQ +! +! This module provides solutions for low-degree polynomial equations +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE QUADRATIC_EQUATION(A,B,C,X1,X2) +! +! This subroutine solves the quadratic equation: +! +! A*X^3 + B*X^2 + C = 0 +! +! using the general quadratic formula +! +! References: (1) https://en.wikipedia.org/wiki/Quadratic_formula +! +! +! +! Input parameters: +! +! * A,B,C : coefficients of cubic formula +! +! +! Output parameters: +! +! * X1,X2 : roots of the equation +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : FOUR,HALF +! + IMPLICIT NONE +! + COMPLEX (WP) :: A,B,C + COMPLEX (WP) :: X1,X2 + COMPLEX (WP) :: DD,KK +! +! Intermediate formula +! + DD=CDSQRT(B*B-FOUR*A*C) ! + KK=HALF/A ! +! +! Roots +! + X1=KK*(-B+DD) ! + X2=KK*(-B-DD) ! +! + END SUBROUTINE QUADRATIC_EQUATION +! +!======================================================================= +! + SUBROUTINE CUBIC_EQUATION(A,B,C,D,X1,X2,X3) +! +! This subroutine solves the cubic equation: +! +! A*X^3 + B*X^2 + C*X + D = 0 +! +! using the general cubic formula +! +! References: (1) https://en.wikipedia.org/wiki/Cubic_equation +! +! +! +! Input parameters: +! +! * A,B,C,D : coefficients of cubic formula +! +! +! Output parameters: +! +! * X1,X2,X3 : roots of the equation +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,NINE,HALF,THIRD + USE COMPLEX_NUMBERS, ONLY : ONEC,IC +! + IMPLICIT NONE +! + COMPLEX (WP) :: A,B,C,D + COMPLEX (WP) :: X1,X2,X3 + COMPLEX (WP) :: D0,D1,CC + COMPLEX (WP) :: SQ,KK + COMPLEX (WP) :: Z0,Z1,Z2 +! + REAL (WP) :: EPS + REAL (WP) :: CP +! + EPS=1.0E-6_WP ! accuracy +! +! Intermediate formulas +! + D0=B*B-THREE*A*C ! + D1=TWO*B*B*B - NINE*A*B*C + 27.0E0_WP*A*A*D ! + SQ=CDSQRT(D1*D1-FOUR*D0*D0*D0) ! + CP=CDABS(D1-SQ) ! +! + IF(CP < EPS) THEN ! + CC=(HALF*(D1+SQ))**THIRD ! + ELSE ! + CC=(HALF*(D1-SQ))**THIRD ! + END IF ! +! + KK=-THIRD/A ! +! + Z0=ONEC ! + Z1=HALF*(IC*DSQRT(THREE)-ONE) ! + Z2=Z1*Z1 ! +! +! Roots +! + X1=KK*(B + Z0*CC + D0/(Z0*CC)) ! + X2=KK*(B + Z1*CC + D0/(Z1*CC)) ! + X3=KK*(B + Z2*CC + D0/(Z2*CC)) ! +! + END SUBROUTINE CUBIC_EQUATION +! +!======================================================================= +! + SUBROUTINE QUARTIC_EQUATION(A,B,C,D,E,X1,X2,X3,X4) +! +! This subroutine solves the quartic equation: +! +! A*X^4 + B*X^3 + C*X^2 + D*X + E = 0 +! +! using the general quartic formula +! +! References: (1) https://en.wikipedia.org/wiki/Quartic_function +! +! +! +! Input parameters: +! +! * A,B,C,D,E : coefficients of cubic formula +! +! +! Output parameters: +! +! * X1,X2,X3,X4 : roots of the equation +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,THREE,FOUR,EIGHT,NINE,HALF,THIRD + USE COMPLEX_NUMBERS, ONLY : ONEC,IC +! + IMPLICIT NONE +! + COMPLEX (WP) :: A,B,C,D,E + COMPLEX (WP) :: X1,X2,X3,X4 + COMPLEX (WP) :: PP,QQ,S,Q + COMPLEX (WP) :: D0,D1 +! +! Intermediate formulas +! + PP=0.125E0_WP*(EIGHT*A*C-THREE*B*B)/(A*A) ! + QQ=0.125E0_WP*(B*B*B-FOUR*A*B*C+EIGHT*A*A*D)/(A*A*A) ! +! + D0=C*C - THREE*B*D + 12.0E0_WP*A*E ! + D1=TWO*C*C*C - NINE*B*C*D + 27.0E0_WP*B*B*E + & ! + 27.0E0_WP*A*D*D - 72.0E0_WP*A*C*E ! +! + Q=(HALF*(D1 + CDSQRT(D1*D1-FOUR*D0*D0*D0)) )**THIRD ! + S=HALF*CDSQRT( -TWO*THIRD*PP + THIRD*(Q + D0/Q)/A ) ! +! +! Roots +! + X1=-B*HALF*HALF/A - S + HALF*CDSQRT(-FOUR*S*S-TWO*PP+QQ/S) ! + X2=-B*HALF*HALF/A - S - HALF*CDSQRT(-FOUR*S*S-TWO*PP+QQ/S) ! + X3=-B*HALF*HALF/A + S + HALF*CDSQRT(-FOUR*S*S-TWO*PP-QQ/S) ! + X4=-B*HALF*HALF/A + S - HALF*CDSQRT(-FOUR*S*S-TWO*PP-QQ/S) ! +! + END SUBROUTINE QUARTIC_EQUATION +! +!======================================================================= +! + SUBROUTINE CHECK_ROOTS3(X1,X2,X3,Y) +! +! This subroutine checks among the three roots of a +! cubic equation if one is real and positive +! +! Input parameters: +! +! * X1,X2,X3 : roots of the equation +! +! +! Output parameters: +! +! * Y : real and positive of the equation +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + COMPLEX (WP) :: X1,X2,X3 +! + REAL (WP) :: R1,R2,R3,I1,I2,I3 + REAL (WP) :: Y + REAL (WP) :: EPS +! + INTEGER :: IM1,IM2,IM3 + INTEGER :: IR1,IR2,IR3 + INTEGER :: IR,IM + INTEGER :: LOGF +! + EPS=1.0E-6_WP ! accuracy +! + LOGF=6 ! +! + R1=DREAL(X1) ! + R2=DREAL(X2) ! + R3=DREAL(X3) ! +! + I1=DIMAG(X1) ! + I2=DIMAG(X2) ! + I3=DIMAG(X3) ! +! + IR1=0 ! + IR2=0 ! + IR3=0 ! +! + IM1=0 ! + IM2=0 ! + IM3=0 ! +! + IF(R1 >= ZERO) IR1=1 ! + IF(R2 >= ZERO) IR2=1 ! + IF(R3 >= ZERO) IR3=1 ! +! + IF(DABS(I1) < EPS) IM1=1 ! + IF(DABS(I2) < EPS) IM2=1 ! + IF(DABS(I3) < EPS) IM3=1 ! +! + IR=MAX(IR1,IR2,IR3) ! + IM=MAX(IM1,IM2,IM3) ! +! +! Result +! + IF(IR*IM == 0) THEN ! + WRITE(LOGF,10) ! + STOP ! + ELSE + IF(IR1*IM1 == 1) THEN ! + Y=R1 ! + ELSE IF(IR2*IM2 == 1) THEN ! + Y=R2 ! + ELSE IF(IR3*IM3 == 1) THEN ! + Y=R3 ! + END IF ! + END IF ! +! +! Format +! + 10 FORMAT(//,5X,'<<<<< Subroutine CUBIC_EQUATION: >>>>>',/, & + 5X,'<<<<< No real positive value X^2 >>>>>') +! + END SUBROUTINE CHECK_ROOTS3 +! +!======================================================================= +! + SUBROUTINE CHECK_ROOTS2(X1,X2,Y) +! +! This subroutine checks among the two roots of a +! quadratic equation if one is real and positive +! +! Input parameters: +! +! * X1,X2 : roots of quadratic formula +! +! +! Output parameters: +! +! * Y : real and positive of the equation +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + COMPLEX (WP) :: X1,X2 +! + REAL (WP) :: R1,R2,I1,I2 + REAL (WP) :: Y + REAL (WP) :: EPS +! + INTEGER :: IM1,IM2 + INTEGER :: IR1,IR2 + INTEGER :: IR,IM + INTEGER :: LOGF +! + EPS=1.0E-6_WP ! accuracy +! + LOGF=6 ! +! + R1=DREAL(X1) ! + R2=DREAL(X2) ! +! + I1=DIMAG(X1) ! + I2=DIMAG(X2) ! +! + IR1=0 ! + IR2=0 ! +! + IM1=0 ! + IM2=0 ! +! + IF(R1 >= ZERO) IR1=1 ! + IF(R2 >= ZERO) IR2=1 ! +! + IF(DABS(I1) < EPS) IM1=1 ! + IF(DABS(I2) < EPS) IM2=1 ! +! + IR=MAX(IR1,IR2) ! + IM=MAX(IM1,IM2) ! +! +! Result +! + IF(IR*IM == 0) THEN ! + WRITE(LOGF,10) ! + STOP ! + ELSE + IF(IR1*IM1 == 1) THEN ! + Y=R1 ! + ELSE IF(IR2*IM2 == 1) THEN ! + Y=R2 ! + END IF ! + END IF ! +! +! Format +! + 10 FORMAT(//,5X,'<<<<< Subroutine QUADRATIC_EQUATION: >>>>>',/,& + 5X,'<<<<< No real positive value of X >>>>>') +! + END SUBROUTINE CHECK_ROOTS2 +! +END MODULE POLYNOMIAL_EQ diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/powers_of_ten.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/powers_of_ten.f90 new file mode 100644 index 0000000..29deb68 --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/powers_of_ten.f90 @@ -0,0 +1,30 @@ +! +!======================================================================= +! +MODULE POWERS_OF_TEN +! +! This module defines the prefixes in the SI +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP), PARAMETER :: KILO = 1.0E+03_WP + REAL (WP), PARAMETER :: MEGA = 1.0E+06_WP + REAL (WP), PARAMETER :: GIGA = 1.0E+09_WP + REAL (WP), PARAMETER :: TERA = 1.0E+12_WP + REAL (WP), PARAMETER :: PETA = 1.0E+15_WP + REAL (WP), PARAMETER :: EXA = 1.0E+18_WP + REAL (WP), PARAMETER :: ZETTA = 1.0E+21_WP + REAL (WP), PARAMETER :: YOTTA = 1.0E+24_WP +! + REAL (WP), PARAMETER :: MILLI = 1.0E-03_WP + REAL (WP), PARAMETER :: MICRO = 1.0E-06_WP + REAL (WP), PARAMETER :: NANO = 1.0E-09_WP + REAL (WP), PARAMETER :: PICO = 1.0E-12_WP + REAL (WP), PARAMETER :: FEMTO = 1.0E-15_WP + REAL (WP), PARAMETER :: ATTO = 1.0E-18_WP + REAL (WP), PARAMETER :: ZEPTO = 1.0E-21_WP + REAL (WP), PARAMETER :: YOCTO = 1.0E-24_WP +! +END MODULE POWERS_OF_TEN diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/semiconductors_properties.odt b/New_libraries/DFM_library/UTILITIES_LIBRARY/semiconductors_properties.odt new file mode 100644 index 0000000..bbb4147 Binary files /dev/null and b/New_libraries/DFM_library/UTILITIES_LIBRARY/semiconductors_properties.odt differ diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/simple_numbers.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/simple_numbers.f90 new file mode 100644 index 0000000..d2fcde7 --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/simple_numbers.f90 @@ -0,0 +1,62 @@ +! +!======================================================================= +! +MODULE REAL_NUMBERS +! +! This module defines frequent real numbers +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + REAL (WP), PARAMETER :: ZERO = 0.00E0_WP + REAL (WP), PARAMETER :: ONE = 1.00E0_WP + REAL (WP), PARAMETER :: TWO = 2.00E0_WP + REAL (WP), PARAMETER :: THREE = 3.00E0_WP + REAL (WP), PARAMETER :: FOUR = 4.00E0_WP + REAL (WP), PARAMETER :: FIVE = 5.00E0_WP +! + REAL (WP), PARAMETER :: SIX = 6.00E0_WP + REAL (WP), PARAMETER :: SEVEN = 7.00E0_WP + REAL (WP), PARAMETER :: EIGHT = 8.00E0_WP + REAL (WP), PARAMETER :: NINE = 9.00E0_WP + REAL (WP), PARAMETER :: TEN = 10.00E0_WP +! + REAL (WP), PARAMETER :: TWENTY = 20.00E0_WP +! + REAL (WP), PARAMETER :: HALF = 0.50E0_WP + REAL (WP), PARAMETER :: THIRD = 0.33333333333333333333333333333333E0_WP + REAL (WP), PARAMETER :: FOURTH = 0.25E0_WP + REAL (WP), PARAMETER :: FIFTH = 0.20E0_WP +! + REAL (WP), PARAMETER :: SIXTH = 0.16666666666666666666666666666667E0_WP + REAL (WP), PARAMETER :: SEVENTH = 0.14285714285714285714285714285714E0_WP + REAL (WP), PARAMETER :: EIGHTH = 0.125E0_WP + REAL (WP), PARAMETER :: NINTH = 0.11111111111111111111111111111111E0_WP + REAL (WP), PARAMETER :: TENTH = 0.10E0_WP +! + REAL (WP), PARAMETER :: SMALL = 1.0E-006_WP + REAL (WP), PARAMETER :: TTINY = 1.0E-030_WP + REAL (WP), PARAMETER :: LARGE = 1.0E+030_WP + REAL (WP), PARAMETER :: INF = 1.0E+300_WP + REAL (WP), PARAMETER :: MIC = 1.0E-300_WP + REAL (WP), PARAMETER :: EPS = 1.0E-010_WP +! +END MODULE REAL_NUMBERS +! +!======================================================================= +! +MODULE COMPLEX_NUMBERS +! +! This module defines frequent complex numbers +! + USE ACCURACY_REAL +! + IMPLICIT NONE +! + COMPLEX (WP), PARAMETER :: ZEROC = (0.0E0_WP,0.0E0_WP) + COMPLEX (WP), PARAMETER :: ONEC = (1.0E0_WP,0.0E0_WP) + COMPLEX (WP), PARAMETER :: IC = (0.0E0_WP,1.0E0_WP) +! +END MODULE COMPLEX_NUMBERS + diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/smoothing.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/smoothing.f90 new file mode 100644 index 0000000..632147c --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/smoothing.f90 @@ -0,0 +1,705 @@ +! +!======================================================================= +! +MODULE SMOOTHING +! +! This module contains smoothing routines for curves + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE SMOOFT(Y,N,PTS) +! +! This subroutine smoothes an array Y of length N, with a window +! whose full width is of order PTS neighboring points +! +! Based on J-P Moreau's implementation of a routine from +! "Numerical Recipes" by W.H. Press, B. P. Flannery, +! S.A. Teukolsky and W.T. Vetterling, Cambridge +! University Press, 1986 +! +! Note: the grid is assumed to be equally spaced +! +! +! Input parameters: +! +! * Y : function to be smoothed +! * N : size of array Y +! * PTS : number of neighbouring points taken into account +! +! +! Output parameters: +! +! * Y : smoothed function +! +! +! Last modified (DS) : 16 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,FOURTH +! + IMPLICIT NONE +! + INTEGER, PARAMETER :: NMAX = 2048 ! double of maximum sample size +! + INTEGER, INTENT(IN) :: N,PTS +! + INTEGER :: LOGF + INTEGER :: M,NMIN + INTEGER :: J,MO2,K +! + REAL (WP), INTENT(INOUT) :: Y(NMAX) +! + REAL (WP) :: CONST,Y1,YN,RN1 + REAL (WP) :: FAC +! + REAL (WP) :: FLOAT,MAX +! + LOGF = 6 ! log file unit +! + M = 2 ! + NMIN = N + 2 * PTS ! +! + 1 IF(M < NMIN) THEN ! + M = 2 * M ! + GO TO 1 ! + END IF ! +! + IF(M > NMAX) THEN ! + WRITE(LOGF,10) ! + STOP ! + END IF ! +! + CONST = FLOAT((PTS / M)**2) ! + Y1 = Y(1) ! + YN = Y(N) ! + RN1 = ONE / FLOAT(N-1) ! +! + DO J = 1, N ! \ + Y(J) = Y(J) - RN1 * ( Y1 * FLOAT(N-J) + YN* FLOAT(J-1) ) ! > remove linear trend + END DO ! / +! + IF(N+1 <= M) THEN ! + DO J = N+1, M ! + Y(J) = ZERO ! + END DO ! + END IF ! +! + MO2 = M / 2 ! +! + CALL REALFT(Y,MO2,1) ! Fourier transform +! + Y(1) = Y(1) / FLOAT(MO2) ! + FAC = ONE ! +! + DO J = 1, MO2-1 ! + K = 2 * J + 1 ! + IF(FAC /= ZERO) THEN ! + FAC = MAX(ZERO,(ONE - CONST * FLOAT(J)**2) / MO2) ! + Y(K ) = FAC * Y(K) ! + Y(K+1) = FAC * Y(K+1) ! + ELSE ! + Y(K) = ZERO ! + Y(K+1) = ZERO ! + END IF ! + END DO ! +! + FAC = MAX(ZERO,(ONE - FOURTH * FLOAT(PTS**2)) / MO2) ! last point + Y(2) = FAC * Y(2) ! +! + CALL REALFT(Y,MO2,-1) ! inverse Fourier transform +! + DO J = 1, N ! restore linear trend + Y(J) = RN1 * (Y1 * FLOAT(N-J) + YN * FLOAT(J-1)) + Y(J) ! + END DO ! +! +! Formats +! + 10 FORMAT(5X,'<<<<< SAMPLE TOO LARGE: INCREASE NMAX >>>>>',/, & + 5X,'<<<<< IN SUBROUTINE SMOOFT (UTILITIES) >>>>>',//) +! +CONTAINS +! +!----------------------------------------------------------------------- +! + SUBROUTINE FOUR1(DATA,NN,ISIGN) +! +! This subroutine replaces DATA(1:2*NN) by: +! +! * its discrete Fourier transform if ISIGN is 1 +! * NN times its inverse discrete Fourier transform if ISIGN is -1 +! +! DATA is either: +! +! * a complex array of length NN +! * a real array of length 2*NN +! +! Warning: NN MUST be an integer power of 2 (this is not checked for!) +! +! +! +! Last modified (DS) : 16 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: NN,ISIGN +! + INTEGER :: N,J,I,M + INTEGER :: MMAX,ISTEP +! + REAL (WP), INTENT(INOUT) :: DATA(2*NN) +! + REAL (WP) :: TEMPR,TEMPI + REAL (WP) :: THETA,WI,WPI,WPR,WR,WTEMP !for the trigonometric recurrences +! + REAL (WP) :: FLOAT,SIN +! + N = 2 * NN ! + J = 1 ! +! + DO I = 1, N, 2 ! this is the bit-reversal section of the routine + IF(J > I)THEN ! + TEMPR = DATA(J) ! exchange the two complex numbers + TEMPI = DATA(J+1) ! + DATA(J) = DATA(I) ! + DATA(J+1) = DATA(I+1) ! + DATA(I) = TEMPR ! + DATA(I+1) = TEMPI ! + END IF ! + M = NN ! + 1 IF((M > 2) .AND. (J > M)) THEN ! + J = J - M ! + M = M / 2 ! + GO TO 1 ! + END IF ! + J = J + M ! + END DO ! +! + mmax = 2 ! here begins the Danielson-Lanczos +! ! section of the routine + 2 IF (N > MMAX) THEN ! outer loop executed log2 NN times. +! ! + ISTEP = 2 * MMAX ! + THETA = TWO * PI / FLOAT(ISIGN * MMAX) ! initialize for the trigonometric recurrence. + WPR = - TWO * SIN(HALF * THETA)**2 ! + WPI = SIN(THETA) ! + WR = ONE ! + WI = ZERO ! +! ! + DO M =1, MMAX, 2 ! here are the two nested inner loops. + DO I=M,N,ISTEP ! + J = I + MMAX ! this is the Danielson-Lanczos formula: + TEMPR = WR * DATA(J) - WI * DATA(J+1) ! + TEMPI = WR * DATA(J+1) + WI * DATA(J) ! + DATA(J) = DATA(I) - TEMPR ! + DATA(J+1) = DATA(I+1) - TEMPI ! + DATA(I) = DATA(I) + TEMPR ! + DATA(I+1) = DATA(I+1) + TEMPI ! + END DO ! + WTEMP = WR ! trigonometric recurrence. + WR = WR * WPR - WI * WPI + WR ! + WI = WI * WPR + WTEMP * WPI + WI ! + END DO ! +! ! + MMAX = ISTEP ! + GO TO 2 ! not yet done. +! + END IF ! all done. +! + END SUBROUTINE FOUR1 +! +!----------------------------------------------------------------------- +! + SUBROUTINE REALFT(DATA,N,ISIGN) +! +! This subroutine calculates the Fourier transform of a set of +! N real-valued data points.Replaces this data (which is stored in +! array DATA(1:N)) by the positive frequency half of its complex Fourier +! transform. The real-valued first and last components of the +! complex transform are returned as elements DATA(1) and DATA(2), +! respectively. N must be a power of 2. This routine also calculates +! the inverse transform of a complex data array if it is the transform of real +! data. (Result in this case must be multiplied by 2/N.) +! +! +! +! Last modified (DS) : 16 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: N,ISIGN + INTEGER :: I,I1,I2,I3,I4,N2P3 +! + REAL (WP), INTENT(INOUT) :: DATA(N) +! + REAL (WP) :: C1,C2 + REAL (WP) :: H1I,H1R,H2I,H2R + REAL (WP) :: WIS,WRS + REAL (WP) :: THETA,WI,WR ! for the trigonometric + REAL (WP) :: WPI,WPR,WTEMP ! recurrences +! + THETA = PI / FLOAT(N / 2) ! initialize the recurrence. + C1 = HALF ! +! + IF(ISIGN == 1) THEN ! + C2 = - HALF ! + CALL FOUR1(DATA,N/2,+1) ! the forward transform is here. + ELSE ! + C2 = HALF ! otherwise set up for an inverse transform. + THETA = - THETA ! + END IF ! +! + WPR = - TWO * SIN(HALF * THETA)**2 ! + WPI = SIN(THETA) ! + WR = ONE + WPR ! + WI = WPI ! + N2P3 = N + 3 ! +! + DO I = 2, N / 4 ! case I=1 done separately below. + I1 = 2 * I - 1 ! + I2 = I1 + 1 ! + I3 = N2P3 - I2 ! + I4 = I3 + 1 ! + WRS = WR ! + WIS = WI ! + H1R = C1 * (DATA(I1) + DATA(I3)) ! \ + H1I = C1 * (DATA(I2) - DATA(I4)) ! > the two separate transforms + H2R = - C2 * (DATA(I2) + DATA(I4)) ! > are separated out of DATA + H2I = C2 * (DATA(I1) - DATA(I3)) ! / +! + DATA(I1) = H1R + WRS * H2R - WIS * H2I ! \ + DATA(I2) = H1I + WRS * H2I + WIS * H2R ! > here they are recombined + DATA(I3) = H1R - WRS * H2R + WIS * H2I ! > to form the true transform + DATA(I4) = - H1I + WRS * H2I + WIS * H2R ! / of the original real data +! + WTEMP = WR ! the recurrence. + WR = WR * WPR - WI * WPI + WR ! + WI = WI * WPR + WTEMP * WPI + WI ! + END DO ! +! + IF(ISIGN == 1) THEN ! + H1R = DATA(1) ! + DATA(1) = H1R + DATA(2) ! squeeze the first and last data together + DATA(2) = H1R - DATA(2) ! to get them all within the original array + ! + ELSE ! + H1R = DATA(1) ! + DATA(1) = C1 * (H1R + DATA(2)) ! + DATA(2) = C1 * (H1R - DATA(2)) ! + CALL FOUR1(DATA,N/2,-1) ! This is the inverse transform + END IF ! for the case ISIGN = -1 +! + END SUBROUTINE REALFT +! + END SUBROUTINE SMOOFT +! +!======================================================================= +! + SUBROUTINE TSAVGOL(Y,N) +! +! This subroutine smoothes an array Y of length N, using +! a Savitzky-Golay filter + +! +! Based on J-P Moreau's implementation of a routine from +! "Numerical Recipes" by W.H. Press, B. P. Flannery, +! S.A. Teukolsky and W.T. Vetterling, Cambridge +! University Press, 1986 +! +! Note: the grid is assumed to be equally spaced +! +! +! Input parameters: +! +! * Y : function to be smoothed +! * N : size of array Y +! +! +! Output parameters: +! +! * Y : smoothed function +! +! +! Last modified (DS) : 16 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + INTEGER, PARAMETER :: NMAX = 2048 ! double of maximum sample size + INTEGER, PARAMETER :: NP = 1000 ! +! + INTEGER, INTENT(IN) :: N +! + INTEGER :: NL,NR,M + INTEGER :: INDEX(NP) + INTEGER :: I,J +! + REAL (WP), INTENT(INOUT) :: Y(NMAX) +! + REAL (WP) :: YSAVE(NMAX) + REAL (WP) :: C(NP) +! + YSAVE = Y ! save unsmoothed signal +! + NL = 5 ! \ + NR = 5 ! > see SAVGOL + M = 4 ! / +! + INDEX(1) = 0 ! seek shift index for given case NL, NR, M +! ! (see SAVGOL) + J = 3 ! + DO I = 2, NL+1 ! + INDEX(I) = I - J ! + J = J + 2 ! + END DO ! +! ! (see SAVGOL) + J = 2 ! + DO I = NL+2, NL+NR+1 ! + INDEX(I) = I - J ! + J = J + 2 ! + END DO ! +! +! Calculate Savitzky-Golay filter coefficients +! + CALL SAVGOL(C,NL+NR+1,NL,NR,0,M) ! +! +! Apply filter to input data +! + DO I = 1, N - NR ! + Y(I) = ZERO ! + DO J = 1, NL + NR + 1 ! + IF(I + INDEX(J) > 0) THEN ! skip left points that do not exist + Y(I) = Y(I) + C(J) * YSAVE(I+INDEX(J)) ! + END IF ! + END DO ! + END DO ! +! +CONTAINS +! +!----------------------------------------------------------------------- +! + SUBROUTINE SAVGOL(C,NP,NL,NR,LD,M) +! +! This subroutine returns in C(1:NP), in wrap-around order +! (see reference) consistent with the argument RESPNS +! in routine CONVLV, a set of Savitzky-Golay filter coefficients. +! +! +! Based on J-P Moreau's implementation of a routine from +! "Numerical Recipes" by W.H. Press, B. P. Flannery, +! S.A. Teukolsky and W.T. Vetterling, Cambridge +! University Press, 1986 +! +! +! Input parameters: +! +! * NL : number of data points to the left of each point > to include in the filter +! * NR : number of data points to the right of each point > +! the total number of data points used NL + NR + 1. +! * LD : order of the derivative desired +! LD = 0 for smoothed function +! LD = 1 for smoothed first derivative of the function +! * M : order of the smoothing polynomial +! equal to the highest conserved moment +! usual values are M = 2 or M = 4 +! Lower values for M will produce smoother results +! but may introduce bias +! Higher values for M will reduce the filter bias +! but may "over fit" the data and give a noisier result +! +! +! Output parameters: +! +! * C : Savitzky-Golay filter coefficients +! * NP : size of the C array +! +! +! Last modified (DS) : 16 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE +! + IMPLICIT NONE +! + INTEGER, PARAMETER :: MMAX = 6 +! + INTEGER, INTENT(IN) :: NL,NR,LD,M + INTEGER, INTENT(IN) :: NP +! + INTEGER :: LOGF + INTEGER :: D,ICODE,IMJ,IPJ + INTEGER :: J,K,KK,MM + INTEGER :: INDX(MMAX+1) +! + REAL (WP), INTENT(OUT) :: C(NP) +! + REAL (WP) :: FAC,SUM + REAL (WP) :: A(MMAX+1,MMAX+1),B(MMAX+1) +! + REAL (WP) :: FLOAT,MIN +! + LOGF = 6 ! log file unit +! +! Testing the arguments +! + IF(NP < NL+NR+1 .OR. NL < 0 .OR. NR < 0 .OR. LD > M .OR. & + M > MMAX .OR. NL+NR < M) THEN ! + WRITE(LOGF,10) + STOP + END IF ! +! +! Set up the normal equations of the desired least squares fit +! + DO IPJ = 0, 2 * M ! + SUM = ZERO ! + IF(IPJ == 0) SUM = ONE ! + DO K = 1, NR ! + SUM = SUM + FLOAT(K)**IPJ ! + END DO ! + DO K = 1, NL ! + SUM = SUM + FLOAT(-K)**IPJ ! + END DO ! + MM = MIN(IPJ,2*M-IPJ) ! + DO IMJ = -MM, MM, 2 ! + A(1+(IPJ+IMJ)/2,1+(IPJ-IMJ)/2) = SUM ! + END DO ! + END DO ! +! +! Solve them: LU decomposition. +! + CALL LUDCMP(A,M+1,MMAX+1,INDX,D,ICODE) ! +! + DO J = 1, M+1 ! + B(J) = ZERO ! + END DO ! +! +! Right-hand side vector is unit vector, +! depending on which derivative we want +! + B(LD+1) = ONE ! +! +! Backsubstitute, giving one row of the inverse matrix +! + CALL LUBKSB(A,M+1,MMAX+1,INDX,B) ! +! +! Zero the output array (it may be bigger +! than the number of coefficients) +! + DO KK = 1 ,NP ! + C(KK) = ZERO ! + END DO ! +! +! Each Savitzky-Golay coefficient is the dot product +! of powers of an integer with the inverse matrix row +! + DO K = -NL, NR ! + SUM = B(1) ! + FAC = ONE ! + DO MM = 1, M ! + FAC = FAC * K ! + SUM = SUM + B(MM+1) * FAC ! + END DO ! + KK = MOD(NP-K,NP) + 1 ! Store in wrap-around order + C(KK) = SUM ! + END DO ! +! +! Formats: +! + 10 FORMAT(5X,'<<<<< BAD ARGS IN SAVGOL >>>>>',//) ! +! + END SUBROUTINE SAVGOL +! +!----------------------------------------------------------------------- +! + SUBROUTINE LUDCMP(A,N,NP,INDX,D,CODE) +! +! Given an N x N matrix A, this routine replaces it by the LU +! decomposition of a rowwise permutation of itself. +! +! +! Input parameters: +! +! * A : input matrix +! * N : dimensioning of matrix A +! * NP : physical dimension of matrix A +! +! +! Output parameters: +! +! * INDX : output vector recording the row permutation +! effected by the partial pivoting +! * D : = 1 number of row interchanges even +! = -1 number of row interchanges odd +! * CODE : return code (1 matrix is singular) +! +! This routine is used in combination with LUBKSB +! to solve linear equations or to invert a matrix. +! +! +! Last modified (DS) : 16 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE +! + IMPLICIT NONE +! + INTEGER, PARAMETER :: NMAX = 100 +! + INTEGER, INTENT(IN) :: N,NP + INTEGER, INTENT(OUT) :: INDX(N),D,CODE +! + INTEGER :: AMAX,DUM,SUM + INTEGER :: VV(NMAX) + INTEGER :: I,J,K + INTEGER :: IMAX +! + REAL (WP), INTENT(OUT) :: A(NP,NP) +! + REAL (WP) :: ABS +! + REAL (WP), PARAMETER :: TINY = 1.0E-12_WP +! + D = 1 ! + CODE = 0 ! + + DO I = 1, N ! + AMAX = ZERO ! + DO J = 1, N ! + IF(ABS(A(I,J)) > AMAX) AMAX = ABS(A(I,J)) ! + END DO ! + IF(AMAX < TINY) THEN ! + CODE = 1 ! + RETURN ! + END IF ! + VV(I) = ONE / AMAX ! + END DO ! +! + DO J = 1, N ! + DO I = 1, J - 1 ! + SUM = A(I,J) ! + DO K = 1, I-1 ! + SUM = SUM - A(I,K) * A(K,J) ! + END DO ! + A(I,J) = SUM ! + END DO ! + AMAX = ZERO ! + DO I = J, N ! + SUM = A(I,J) ! + DO K = 1,J - 1 ! + SUM = SUM - A(I,K) * A(K,J) ! + END DO ! + A(I,J) = SUM ! + DUM = VV(I) * ABS(SUM) ! + IF(DUM >= AMAX) THEN ! + IMAX = I ! + AMAX = DUM ! + END IF ! + END DO ! +! + IF(J /= IMAX) THEN ! + DO K = 1, N ! + DUM = A(IMAX,K) ! + A(IMAX,K) = A(J,K) ! + A(J,K) = DUM ! + END DO ! + D = - D ! + VV(IMAX) = VV(J) ! + END IF ! +! + INDX(J) = IMAX ! + IF(ABS(A(J,J)) < TINY) A(J,J) = TINY ! +! + IF(J /= N) THEN ! + DUM = ONE / A(J,J) ! + DO I = J + 1, N ! + A(I,J) = A(I,J) * DUM ! + END DO ! + END IF ! + END DO ! +! + END SUBROUTINE LUDCMP +! +!----------------------------------------------------------------------- +! + SUBROUTINE LUBKSB(A,N,NP,INDX,B) +! +! This subroutine solves the set of N linear equations A * X = B +! +! +! Input parameters: +! +! * A : input LU decomposition from routine LUDCMP +! * N : same as in routine LUDCMP +! * NP : +! * INDX : same as in routine LUDCMP +! * B : right-handside vector +! +! +! Output parameters: +! +! * B : solution vector X +! +! +! This routine is also efficient for plain matrix inversion. +! +! +! Last modified (DS) : 16 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: N,NP + INTEGER, INTENT(INOUT) :: INDX(N) +! + INTEGER :: I,II,J,LL +! + REAL (WP), INTENT(INOUT) :: A(NP,NP) + REAL (WP), INTENT(INOUT) :: B(N) +! + REAL (WP) :: SUM +! + II = 0 ! +! + DO I = 1, N ! + LL = INDX(I) ! + SUM = B(LL) ! + B(LL) = B(I) ! + IF(II /= 0) THEN ! + DO J = II, I-1 ! + SUM = SUM - A(I,J) * B(J) ! + END DO ! + ELSE IF(SUM /= ZERO) THEN ! + II = I ! + END IF ! + B(I) = SUM ! + END DO ! +! + DO I = N, 1, -1 ! + SUM = B(I) ! + IF(I < N) THEN ! + DO J = I+1, N ! + SUM = SUM - A(I,J) * B(J) ! + END DO ! + END IF ! + B(I) = SUM / A(I,I) ! + END DO ! +! + END SUBROUTINE LUBKSB +! + END SUBROUTINE TSAVGOL +! +END MODULE SMOOTHING diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/tools.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/tools.f90 new file mode 100644 index 0000000..d53e112 --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/tools.f90 @@ -0,0 +1,95 @@ +! +!======================================================================= +! +MODULE TOOLS +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE TRUNCATE(F,N_F,N_G) +! +! This subroutine takes an function array F of length N_F +! and truncates it to length N_G to suppress zero values +! when f(x) tends to zero with increasing x. +! +! It is particularly useful when f(x) in an integrand function +! +! +! Input parameters: +! +! * F : the function array +! * N_F : the size of the F array +! +! +! Outut parameters: +! +! * N_G : the size of the truncated array +! +! +! +! Author : D. Sébilleau +! +! Last modified : 6 Nov 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,SMALL,INF,MIC +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: N_F + INTEGER, INTENT(OUT) :: N_G +! + INTEGER :: I ! loop index + INTEGER :: I_T ! threshold index + INTEGER :: I_M ! index of maximum +! + REAL (WP), INTENT(IN) :: F(N_F) +! + REAL (WP) :: F_MIN,F_MAX + REAL (WP) :: F_CUT +! + REAL (WP), PARAMETER :: F_SCA = 1.0E+4_WP +! + I_T = 1 ! + I_M = 1 ! +! +! Computing the min and max of f(x) +! + F_MIN = INF ! + F_MAX = MIC ! +! + DO I = 1, N_F ! + F_MIN = MIN(F(I),F_MIN) ! + F_MAX = MAX(F(I),F_MAX) ! + END DO ! +! +! Computing the index max of f(x) +! + DO I = 1, N_F ! + IF( ABS(F_MAX - F(I)) / F_MAX <= SMALL ) THEN ! + I_M = I ! + GO TO 10 ! + END IF ! + END DO ! + 10 CONTINUE ! +! +! Computing the threshold value F_CUT +! + F_CUT = MAX(F_MAX,ABS(F_MIN)) / F_SCA ! +! +! Finding the first value below threshold +! + DO I = 1, N_F ! + IF(ABS(F(I) <= F_CUT) THEN ! + I_T = I ! + GO TO 20 ! + END DO ! + 20 CONTINUE ! +! + END SUBROUTINE TRUNCATE +! +END MODULE TOOLS diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/transforms.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/transforms.f90 new file mode 100644 index 0000000..320586b --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/transforms.f90 @@ -0,0 +1,167 @@ +! +!======================================================================= +! +MODULE TRANSFORMS +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE KK(TR,NS,X,U_INP,UR_INF,U_OUT) +! +! This subroutine computes the Kramers-Kronig transform +! +! U_OUT(X) = KK( I_INP(X) ) +! +! with U_INP(X) = UR(X)/UI(X) +! U_OUT(X) = UI(X)/UR(X) +! +! The convention here is that UR(X) is an even function of X and that +! UI(X) is an odd function of X +! +! In this case, we have the Kramers-Kronig relations: +! +! _ _ +! | / + inf | +! 2 | | X' UI(X') - X UI(X) | +! UR(X) = ---- P | | ------------------- dX' | + UR(+ inf) +! pi | | X'^2 - X^2 | +! |_ / 0 _| +! +! +! _ _ +! | / + inf | +! 2X | | UR(X') - UR(X) | +! UI(X) = - ---- P | | -------------------- dX' | +! pi | | X'^2 - X^2 | +! |_ / 0 _| +! +! +! where the Cauchy' principal part P[ ] can be removed +! as the integrand is no longer singular at X' = X +! +! Input parameters: +! +! * TR : type of transformation +! TR = 'R2I' --> UI = KK(UR) +! TR = 'I2R' --> UR = KK(UI) +! * NS : size of arrays of X, UR and UI +! * X : argument array of UR/UI +! * U_INP : input array +! * UR_INF : value of UR(X) for X --> + inf +! +! Output variables : +! +! * U_OUT : output array +! +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE PI_ETC, ONLY : PI + USE INTEGRATION, ONLY : INTEGR_L +! + IMPLICIT NONE +! + REAL (WP) :: X(NS),U_INP(NS),U_OUT(NS) + REAL (WP) :: UR_INF + REAL (WP) :: ADD,COEF,H + REAL (WP) :: I1,C,R1,R2 + REAL (WP) :: F0(NSIZE),G1(NSIZE) +! + INTEGER :: NS + INTEGER :: J,ID,NSIZE1,K + INTEGER :: LOGF +! + CHARACTER (LEN = 3) :: TR +! + LOGF=6 ! +! + ID=0 ! +! +! Integration bound +! + NSIZE1=NS ! +! +! Checking for the dimensioning +! + IF(NS > NSIZE) THEN ! + WRITE(LOGF,10) ! + STOP ! + ENDIF ! +! + H=X(2)-X(1) ! step +! +! Initialization +! + DO J=1,NS ! + IF(TR == 'R2I') THEN ! + F0(J)=U_INP(J) ! + ELSE IF(TR == 'I2R') THEN ! + F0(J)=X(J)*U_INP(J) ! + END IF ! + G1(J)=ZERO ! + END DO ! +! +! Case-dependent sign +! + IF(TR == 'R2I') THEN ! + COEF=+TWO/PI ! + ADD=ZERO ! + ELSE IF(TR == 'I2R') THEN ! + COEF=-TWO/PI ! + ADD=UR_INF ! + END IF ! +! +! Loop over omega +! + DO J=1,NS ! +! + IF(TR == 'R2I') THEN ! + C=X(J) ! + ELSE IF(TR == 'I2R') THEN ! + C=ONE ! + END IF ! +! +! Computing the integrand functions +! + DO K=2,NS-1 ! + IF(K /= J) THEN ! + G1(K)=(F0(K)-F0(J)) / & ! + (X(K)*X(K)-X(J)*X(J)) ! + END IF ! + END DO ! + R1=(X(1)-X(2))/(X(3)-X(2)) ! + R2=(X(NS)-X(NS-1))/(X(NS-2)-X(NS-1)) ! + G1(1)=G1(2)+R1*(G1(3)-G1(2)) ! + G1(NS)=G1(NS-1)+R2*(G1(NS-2)-G1(NS-1)) ! + IF( (J /= 1) .AND. (J /= NS) ) THEN ! + G1(J)=HALF*(G1(J-1)+G1(J+1)) ! + END IF ! +! +! Computing the integrals with Lagrange method +! + CALL INTEGR_L(G1,H,NS,NSIZE1,I1,ID) ! +! +! Result of transform +! + U_OUT(J)=ADD - C * COEF * I1 ! + END DO ! +! +! Format +! + 10 FORMAT(//,5X,'<<<<< Size > NSIZE >>>>>', & ! + /,5X,'<<<<< Increase NSIZE >>>>>',//) ! +! + END SUBROUTINE KK +! +! +END MODULE TRANSFORMS diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/utic_parameters.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/utic_parameters.f90 new file mode 100644 index 0000000..76c7c62 --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/utic_parameters.f90 @@ -0,0 +1,87 @@ +! +!======================================================================= +! +MODULE UTIC_PARAMETERS +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE UTIC_PARAM(X,RS,T,OMQ,OM0) +! +! This subroutine computes the OMEGA(q) and OMEGA(0) parameters +! entering the Utsumi-Ichimaru dielectric function approach +! +! Reference: (1) K. Utsumi and S. Ichimaru, +! Phys. Rev. B 22, 1522-1533 (1980) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (in SI) +! +! +! Intermediate parameters: +! +! * SQ_TYPE : structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! * EC_TYPE : type of correlation energy functional +! * IQ_TYPE : type of approximation for I(q) +! +! Output parameters: +! +! * OMQ : OMEGA(q) characteristic frequency +! * OM0 : OMEGA(0) parameter = lim_{q --> 0} OMEGA(q) +! +! Author : D. Sébilleau +! +! Last modified : 3 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE CONSTANTS_P1, ONLY : H_BAR + USE FERMI_SI, ONLY : EF_SI,KF_SI + USE PI_ETC, ONLY : PI,PI_INV + USE LF_VALUES, ONLY : GQ_TYPE,IQ_TYPE + USE SF_VALUES, ONLY : SQ_TYPE + USE ASYMPT, ONLY : G0,GI + USE RELAXATION_TIME_STATIC, ONLY : UTIC_RT_3D + USE IQ_FUNCTIONS_1 + USE LOCAL_FIELD_STATIC + USE PLASMON_ENE_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,RS,T + REAL (WP), INTENT(OUT) :: OMQ,OM0 + REAL (WP) :: Y,OMP + REAL (WP) :: IQ,GQ,TAU_Q + REAL (WP) :: COEF +! + REAL (WP) :: SQRT +! + Y = X + X ! q / k_F + OMP = ENE_P_SI / H_BAR ! omega_p in SI +! +! Computing the static values I(q) and G(q) +! + CALL IQ_3D(X,RS,IQ_TYPE,IQ) ! + CALL LOCAL_FIELD_STATIC_3D(X,RS,T,GQ_TYPE,GQ) ! +! +! Computing the relaxation time TAU_Q +! + TAU_Q = UTIC_RT_3D(X,RS,T,SQ_TYPE,GQ_TYPE) ! +! + COEF = SQRT(HALF * PI) * OMP * OMP * TAU_Q ! +! + OMQ = COEF * (GQ - IQ) ! ref. 1 eq. (3.19) + OM0 = COEF * Y * Y * (G0 - GI) ! ref. 1 eq. (5.7) +! + END SUBROUTINE UTIC_PARAM +! +END MODULE UTIC_PARAMETERS diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/utilities_1.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/utilities_1.f90 new file mode 100644 index 0000000..4c92c54 --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/utilities_1.f90 @@ -0,0 +1,336 @@ +! +!======================================================================= +! +MODULE UTILITIES_1 +! + USE ACCURACY_REAL +! +! It contains the following functions/subroutines: +! +! * FUNCTION ADD_RT(TAU_E,TAU_P,TAU_I) +! * FUNCTION ALFA(DMN) +! * FUNCTION D(DMN) +! * FUNCTION DOS_EF(DMN) +! * SUBROUTINE MSTAR_TO(MS,GV) +! * FUNCTION RS_TO_N0(DMN,RS) +! * SUBROUTINE VELOCITIES_3D(RS,EC_TYPE,VE2,V_INT_2) +! +! +CONTAINS +! +! +!======================================================================= +! + FUNCTION ADD_RT(TAU_E,TAU_P,TAU_I) +! +! This function computes the total relaxtion time from +! the knowledge of e-e, e-phonon and e-impurities relaxation times +! +! Input parameters: +! +! * TAU_E : electron-electron relaxation time +! * TAU_P : electron-phonon relaxation time +! * TAU_I : electron-impurity relaxation time +! +! Output variables : +! +! * ADD_RT : resulting relaxation time +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE +! + IMPLICIT NONE +! + REAL (WP) :: TAU_E,TAU_P,TAU_I + REAL (WP) :: ADD_RT + REAL (WP) :: SSUM +! + SSUM=ONE/TAU_E + ONE/TAU_P + ONE/TAU_I ! +! + ADD_RT=ONE/SSUM ! +! + END FUNCTION ADD_RT +! +!======================================================================= +! + FUNCTION ALFA(DMN) +! +! This function computes the constant alpha occuring in the +! electron liquid theory +! +! References: (1) G. F. Giuliani and G. Vignale, +! "Quantum Theory of the Electron Liquid", +! (Cambridge University Press 2005) +! eq. (1.79) +! +! Input parameters: +! +! * DMN : problem dimension +! +! +! Output variables : +! +! * ALFA : alpha coefficient +! +! +! Author : D. Sébilleau +! +! Last modified : 3 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,THIRD,FOUR + USE SQUARE_ROOTS, ONLY : SQR2 + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL (WP) :: ALFA +! + CHARACTER (LEN = 2) :: DMN +! + IF(DMN == '3D') THEN ! + ALFA = (FOUR * THIRD * THIRD * PI_INV)**THIRD ! + ELSE IF(DMN == '2D') THEN ! + ALFA = ONE / SQR2 ! + ELSE IF(DMN == 'Q2') THEN ! to be checked ! + ALFA = ONE / SQR2 ! + ELSE IF(DMN == 'BL') THEN ! to be checked ! + ALFA = ONE / SQR2 ! + ELSE IF(DMN == 'ML') THEN ! to be checked ! + ALFA = ONE / SQR2 ! + ELSE IF(DMN == '1D') THEN ! + ALFA = FOUR * PI_INV ! + ELSE IF(DMN == 'Q1') THEN ! to be checked ! + ALFA = FOUR * PI_INV ! + ELSE IF(DMN == 'Q0') THEN ! to be checked ! + ALFA = FOUR * PI_INV ! + END IF ! +! + END FUNCTION ALFA +! +!======================================================================= +! + FUNCTION D(DMN) +! +! This function computes the dimensionality +! +! Input parameters: +! +! * DMN : problem dimension +! +! +! Output variables : +! +! * D : dimensionality +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP) :: D +! + IF(DMN == '3D') THEN ! + D = THREE ! + ELSE IF(DMN == '2D') THEN ! + D = TWO ! + ELSE IF(DMN == '1D') THEN ! + D = ONE ! + END IF ! +! + END FUNCTION D +! +!======================================================================= +! + FUNCTION DOS_EF(DMN) +! +! This function computes the density of states at the Fermi level. +! +! Note: it is NOT spin-resolved. In order to obtain the DoS per spin, +! the values should be divided by 2 +! +! Input parameters: +! +! * DMN : problem dimension +! +! +! Output variables : +! +! * DOS_EF : DoS at EF +! +! +! Author : D. Sébilleau +! +! Last modified : 9 Apr 2020 +! + USE REAL_NUMBERS, ONLY : TWO + USE CONSTANTS_P1, ONLY : H_BAR,M_E + USE FERMI_SI, ONLY : KF_SI + USE PI_ETC, ONLY : PI,PI2 +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP) :: DOS_EF +! + IF(DMN == '3D') THEN ! + DOS_EF = M_E * KF_SI /(PI2 * H_BAR * H_BAR) ! + ELSE IF(DMN == '2D') THEN ! + DOS_EF = M_E / (PI * H_BAR * H_BAR) ! + ELSE IF(DMN == '1D') THEN ! + DOS_EF = TWO * M_E/ (PI * H_BAR * H_BAR * KF_SI) ! + END IF ! +! + END FUNCTION DOS_EF +! +!======================================================================= +! + FUNCTION KF_TO_N0(DMN,KF) +! +! This function computes the electron density from the Wigner-Seitz +! radius. +! +! Input parameters: +! +! * DMN : problem dimension +! * KF : Fermi wave vector in SI +! +! Output variables : +! +! * KF_TO_N0 : electron density in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,HALF,THIRD + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP) :: KF,KF_TO_N0 +! + IF(DMN == '3D') THEN ! + KF_TO_N0=THIRD*PI_INV*PI_INV*KF*KF*KF ! in 1/m^3 + ELSE IF(DMN == '2D') THEN ! + KF_TO_N0=HALF*PI_INV*KF*KF ! in 1/m^2 + ELSE IF(DMN == '1D') THEN ! + KF_TO_N0=TWO*PI_INV*KF ! in 1/m + END IF ! +! + END FUNCTION KF_TO_N0 +! +!======================================================================= +! + SUBROUTINE MSTAR_TO(MS,GV) +! +! This subroutine recomputes all fundamental quantities depending +! on the mass of a particle. In practice, it modifies the values +! stored in the different common blocks +! +! +! Input parameters: +! +! * MS : m* --> mass of the electron/hole considered +! * GV : valley degeneracy +! +! +! Output variables : +! +! * BOHR : +! * RYD : +! * HAR : +! * ALPHA : +! * MU_B : +! * EPS : +! * RS : +! * GV : +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE CONSTANTS_P1, ONLY : BOHR,M_E + USE CONSTANTS_P2 + USE CONSTANTS_P3, ONLY : MU_B +! + IMPLICIT NONE +! + REAL (WP) :: MS,GV + REAL (WP) :: RT +! + RT=MS/M_E ! ratio m*/m +! + BOHR=BOHR/RT ! + M_E=M_E*RT ! + ALPHA=ALPHA/RT ! + MU_B=MU_B/RT ! + HARTREE=HARTREE/RT ! + RYDBERG=RYDBERG/RT ! +! + END SUBROUTINE MSTAR_TO +! +!======================================================================= +! + FUNCTION RS_TO_N0(DMN,RS) +! +! This function computes the electron density from the Wigner-Seitz +! radius. +! +! Input parameters: +! +! * DMN : problem dimension +! * RS : Wigner-Seitz radius (in units of a_0) +! +! Output variables : +! +! * RS_TO_N0 : electron density in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : HALF + USE CONSTANTS_P1, ONLY : BOHR + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP), INTENT(IN) :: RS + REAL (WP) :: RS_TO_N0 + REAL (WP) :: R_S +! + R_S = RS * BOHR ! RS in SI (meters) +! + IF(DMN.EQ.'3D') THEN ! + RS_TO_N0 = 0.750E0_WP * PI_INV / (R_S * R_S * R_S) ! in 1/m^3 + ELSE IF(DMN.EQ.'2D') THEN ! + RS_TO_N0 = PI_INV / (R_S * R_S) ! in 1/m^2 + ELSE IF(DMN.EQ.'1D') THEN ! + RS_TO_N0 = HALF / R_S ! in 1/m + END IF ! +! + END FUNCTION RS_TO_N0 +! +END MODULE UTILITIES_1 diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/utilities_2.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/utilities_2.f90 new file mode 100644 index 0000000..48ba25b --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/utilities_2.f90 @@ -0,0 +1,429 @@ +! +!======================================================================= +! +MODULE UTILITIES_2 +! + USE ACCURACY_REAL +! +! It contains the following functions/subroutines: +! +! * SUBROUTINE IMAG_TO_REAL(IM,OM,NS,RE) +! * SUBROUTINE REAL_TO_IMAG(RE,OM,NS,RE_INF,IM) +! * SUBROUTINE EPSI_TO_EPSR(EPSI,OM,NS,EPSR) +! * SUBROUTINE EPSR_TO_EPSI(EPSR,OM,NS,EPSI) +! * SUBROUTINE GR_TO_SQ_3D(Q,NSIZE,MAX_R,T,RS,GR_TYPE,RH_TYPE,SQ) +! * SUBROUTINE SQ_TO_GR_3D(R,NSIZE,MAX_X,IN_MODE,T,RS,SQ_TYPE,& +! GQ_TYPE,EC_TYPE,GR) +! * SUBROUTINE SQ_TO_VA_3D(NSIZE,MAX_X,IN_MODE,T,SQ_TYPE, & +! GQ_TYPE,EC_TYPE,VA) +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE IMAG_TO_REAL(IM,OM,NS,RE) +! +! This subroutine computes the real part of the function F(omega) +! form the knowledge of the imaginary part, using the Kramers-Kronig +! relations. +! +! +! +! Input parameters: +! +! * IM : array containing Im[ F(omega) ] +! * OM : array containing omega +! * NS : size of arrays of OM, RE and IM +! +! +! Output variables : +! +! * RE : array containing Re[ F(omega) ] +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO + USE TRANSFORMS, ONLY : KK +! + IMPLICIT NONE +! + REAL (WP) :: IM(NS),OM(NS) + REAL (WP) :: RE(NS),RE_INF +! + INTEGER :: NS +! +! Calling the Kramers-Kronig subroutine +! + RE_INF=ZERO ! unused inside KK + CALL KK('I2R',NS,OM,RE,RE_INF,IM) ! for 'I2R' +! + RETURN +! + END +! +!======================================================================= +! + SUBROUTINE REAL_TO_IMAG(RE,OM,NS,RE_INF,IM) +! +! This subroutine computes the imaginary part of the function F(omega) +! form the knowledge of the real part, using the Kramers-Kronig +! relations. +! +! +! +! Input parameters: +! +! * RE : array containing Re[ F(omega) ] +! * OM : array containing omega +! * NS : size of arrays of OM, RE and IM +! * RE_INF : value of Re[ F(omega --> + infinity) ] +! +! +! Output variables : +! +! * IM : array containing Im[ F(omega) ] +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Jun 2020 +! +! + USE TRANSFORMS, ONLY : KK +! + IMPLICIT NONE +! + REAL (WP) :: RE(NS),OM(NS) + REAL (WP) :: IM(NS),RE_INF +! + INTEGER :: NS +! +! Calling the Kramers-Kronig subroutine +! + CALL KK('R2I',NS,OM,RE,RE_INF,IM) ! +! + END SUBROUTINE REAL_TO_IMAG +! +!======================================================================= +! + SUBROUTINE EPSI_TO_EPSR(EPSI,OM,NS,EPSR) +! +! This subroutine computes the real part of the dielectric function +! form the knowledge of the imaginary part, using the Kramers-Kronig +! relations. +! +! +! +! Input parameters: +! +! * EPSI : array containing Im[ EPS(q,omega) ] for a given q +! * OM : array containing omega +! * NS : size of arrays of OM, EPSR and EPSI +! +! +! Output variables : +! +! * EPSR : array containing Re[ EPS(q,omega) ] for a given q +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ONE + USE TRANSFORMS, ONLY : KK +! + IMPLICIT NONE +! + REAL (WP) :: EPSI(NSIZE),OM(NSIZE) + REAL (WP) :: EPSR(NSIZE),EPSR_INF +! + INTEGER :: NS +! +! Calling the Kramers-Kronig subroutine +! + EPSR_INF=ONE ! value of EPSR at infinity +! + CALL KK('I2R',NS,OM,EPSI,EPSR_INF,EPSR) ! +! + END SUBROUTINE EPSI_TO_EPSR +! +!======================================================================= +! + SUBROUTINE EPSR_TO_EPSI(EPSR,OM,NS,EPSI) +! +! This subroutine computes the imaginary part of the dielectric function +! form the knowledge of the real part, using the Kramers-Kronig +! relations. +! +! +! +! Input parameters: +! +! * EPSR : array containing Re[ EPS(q,omega) ] for a given q +! * OM : array containing omega +! * NS : size of arrays of OM, EPSR and EPSI +! +! +! Output variables : +! +! * EPSI : array containing Im[ EPS(q,omega) ] for a given q +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ONE + USE TRANSFORMS, ONLY : KK +! + IMPLICIT NONE +! + REAL (WP) :: EPSR(NSIZE),OM(NSIZE) + REAL (WP) :: EPSI(NSIZE),EPSR_INF +! + INTEGER :: NS +! +! Calling the Kramers-Kronig subroutine +! + EPSR_INF=ONE ! value of EPSR at infinity +! + CALL KK('R2I',NS,OM,EPSR,EPSR_INF,EPSI) ! +! + END SUBROUTINE EPSR_TO_EPSI +! +!======================================================================= +! + SUBROUTINE GR_TO_SQ_3D(Q,MAX_R,T,RS,GR_TYPE,RH_TYPE,SQ) +! +! This subroutine computes the 3D static structure factor S(q) +! from the pair correlation function g(r) according to +! +! / + inf +! | -i q.r +! S(q) = 1 + n | ( g(r)-1 ) e dr +! | +! / 0 +! +! / + inf +! 4 pi n | +! = 1 + -------- | r sin(qr) ( g(r)-1 ) dr +! q | +! / 0 +! +! +! Input parameters: +! +! * Q : point q where S(q) is computed +! * MAX_R : upper integration value +! * T : temperature in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! * GR_TYPE : pair correlation function type (3D) +! * RH_TYPE : choice of pair distribution function rho_2(r) (3D) +! +! +! Output variables : +! +! * SQ : S(q) at point q +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE DIMENSION_CODE, ONLY : NSIZE + USE REAL_NUMBERS, ONLY : ONE,FOUR + USE PI_ETC, ONLY : PI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE INTEGRATION, ONLY : INTEGR_L + USE PAIR_CORRELATION, ONLY : PAIR_CORRELATION_3D +! + IMPLICIT NONE +! + CHARACTER (LEN = 3) :: GR_TYPE,RH_TYPE +! + REAL (WP), INTENT(IN) :: Q,T,RS,MAX_R + REAL (WP) :: GR,SQ + REAL (WP) :: N0,R + REAL (WP) :: INTF(NSIZE),XA(NSIZE),H,IN +! + INTEGER :: NMAX,K,N1,ID +! +! Computing the electron density +! + N0=RS_TO_N0('3D',RS) ! +! +! Computing the integrand function +! + N1=NMAX ! index of upper bound + DO K=1,NMAX ! +! + XA(K)=MAX_R*FLOAT(K-1)/FLOAT(NSIZE-1) ! + R=XA(K) ! +! +! Computing the pair correlation factor g(r) +! + CALL PAIR_CORRELATION_3D(R,RS,T,GR_TYPE,RH_TYPE,GR) ! +! + INTF(K)=XA(K)*SIN(Q*XA(K))*(GR-ONE) ! +! + END DO ! +! + H=XA(2)-XA(1) ! step + ID=1 ! +! +! Computing the integral +! + CALL INTEGR_L(INTF,H,NMAX,N1,IN,ID) ! +! + SQ=ONE + (FOUR*PI*N0/Q) * IN ! +! + END SUBROUTINE GR_TO_SQ_3D +! +!======================================================================= +! + SUBROUTINE SQ_TO_GR_3D(R,NMAX,MAX_X,IN_MODE,T,RS,SQ_TYPE, & + GQ_TYPE,GR) +! +! This subroutine computes the 3D pair correlation function g(r) +! from the static structure factor S(q) according to +! +! / + inf +! 1 1 | i q.r +! g(r) = 1 + --- ---------- | ( S(q)-1 ) e dq +! n (2 pi)^d | +! / 0 +! +! / + inf +! 1 1 | +! = 1 + + --- ------------ | q sin(qr) ( S(q)-1 ) dq +! n (2 pi)^2 r | +! / 0 +! +! +! Input parameters: +! +! * R : point r where g(r) is computed +! * NMAX : dimensioning of the arrays +! * MAX_X : upper integration value +! * IN_MODE : type of integral computed +! * T : temperature in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! * SQ_TYPE : structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! +! +! Output variables : +! +! * GR : g(r) at point r +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! + USE REAL_NUMBERS, ONLY : ONE,TWO + USE PI_ETC, ONLY : PI2 + USE UTILITIES_1, ONLY : RS_TO_N0 + USE SPECIFIC_INT_2, ONLY : INT_SQM1 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE +! + REAL (WP) :: R,T,RS,MAX_X + REAL (WP) :: GR + REAL (WP) :: IN,N0 +! + INTEGER :: NMAX,IN_MODE,LL +! + IN_MODE=4 ! + LL=0 ! +! +! Computing the integral +! + CALL INT_SQM1(NMAX,MAX_X,IN_MODE,RS,T,R,LL,SQ_TYPE, & ! + GQ_TYPE,IN) ! +! +! Computing the electron density +! + N0=RS_TO_N0('3D',RS) ! +! + GR=ONE + ONE/N0 * IN/(TWO*PI2*R) ! +! + END SUBROUTINE SQ_TO_GR_3D +! +!======================================================================= +! + SUBROUTINE SQ_TO_VA_3D(NMAX,MAX_X,IN_MODE,RS,T,SQ_TYPE, & + GQ_TYPE,VA) +! +! This subroutine computes the average potential energy per electron +! from the static structure factor S(q) according to +! +! / + inf +! e^2 | +! = ----- | ( S(q)-1 ) dq +! pi | +! / 0 +! +! +! Input parameters: +! +! * NMAX : dimensioning of the arrays +! * MAX_X : upper integration value +! * IN_MODE : type of integral computed +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! * SQ_TYPE : structure factor approximation (3D) +! * GQ_TYPE : local-field correction type (3D) +! +! +! Output variables : +! +! * VA : per electron +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! + USE REAL_NUMBERS, ONLY : ZERO + USE CONSTANTS_P1, ONLY : E + USE PI_ETC, ONLY : PI + USE SPECIFIC_INT_2, ONLY : INT_SQM1 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: GQ_TYPE + CHARACTER (LEN = 3) :: SQ_TYPE +! + REAL (WP) :: MAX_X,RS,T + REAL (WP) :: VA + REAL (WP) :: R,IN +! + INTEGER :: NMAX,IN_MODE,LL +! + IN_MODE=1 ! + LL=0 ! unused + R=ZERO ! parameters +! +! Computing the integral +! + CALL INT_SQM1(NMAX,MAX_X,IN_MODE,RS,T,R,LL,SQ_TYPE, & ! + GQ_TYPE,IN) ! +! + VA=E*E/PI * IN ! +! + END SUBROUTINE SQ_TO_VA_3D +! +END MODULE UTILITIES_2 diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/utilities_3.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/utilities_3.f90 new file mode 100644 index 0000000..1867476 --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/utilities_3.f90 @@ -0,0 +1,545 @@ +! +!======================================================================= +! +MODULE UTILITIES_3 +! + USE ACCURACY_REAL +! +! It contains the following functions/subroutines: +! +! * SUBROUTINE EPS_TO_CHI(EPSR,EPSI,VC,CHIR,CHII) +! * SUBROUTINE EPS_TO_PI(EPSR,EPSI,VC,PIR,PII) +! * SUBROUTINE EPS_TO_SIGMA(X,Z,EPSR,EPSI,SIGMAR,SIGMAI) +! * SUBROUTINE EPS_TO_SQO(X,Z,T,RS,DMN,EPSR,EPSI,VC,SQO) +! * FUNCTION LOSS_TO_SF(X,Z,T,LOSS) +! * FUNCTION SF_TO_LOSS(X,Z,T,SQO) +! * SUBROUTINE SQO_TO_EPSI(X,Z,T,RS,DMN,VC,SQO,EPSI) +! +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE EPS_TO_CHI(EPSR,EPSI,VC,CHIR,CHII) +! +! This subroutine computes the dielectric susceptibility, also called +! the density-density response function, from the knowledge +! of the dielectric function, following the formula +! +! 1 +! EPS(q,omega) = ---------------------------- +! 1 + Vc(q) * CHI(q,omega) +! +! +! +! Input parameters: +! +! * EPSR : real part of dielectric function +! * EPSI : imaginary part of dielectric function +! * VC : Coulomb potential in k-space +! +! +! Output variables : +! +! * CHIR : real part of dielectric susceptibility +! * CHII : imaginary part of dielectric susceptibility +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE + USE COMPLEX_NUMBERS, ONLY : IC +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EPSR,EPSI,VC + REAL (WP), INTENT(OUT) :: CHIR,CHII +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EPS,CHI +! + EPS = EPSR + IC * EPSI ! +! + CHI = (ONE / EPS - ONE) / VC ! +! + CHIR = REAL(CHI,KIND=WP) ! + CHII = AIMAG(CHI) ! +! + END SUBROUTINE EPS_TO_CHI +! +!======================================================================= +! + SUBROUTINE EPS_TO_PI(EPSR,EPSI,VC,PIR,PII) +! +! This subroutine computes irreducible polarizability, +! following the formula +! +! EPS(q,omega) = 1 - Vc(q) * PI(q,omega) +! +! +! +! Input parameters: +! +! * EPSR : real part of dielectric function +! * EPSI : imaginary part of dielectric function +! * VC : Coulomb potential in k-space +! +! +! Output variables : +! +! * PIR : real part of irreducible polarizability +! * PII : imaginary part of irreducible polarizability +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! + USE REAL_NUMBERS, ONLY : ONE + USE COMPLEX_NUMBERS, ONLY : IC +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: EPSR,EPSI,VC + REAL (WP), INTENT(OUT) :: PIR,PII +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EPS,PPI +! + EPS = EPSR + IC * EPSI ! + PPI = (EPS - ONE) / VC ! +! + PIR = REAL(PPI,KIND=WP) ! + PII = AIMAG(PPI) ! +! + END SUBROUTINE EPS_TO_PI +! +!======================================================================= +! + SUBROUTINE EPS_TO_SIGMA(X,Z,EPSR,EPSI,SIGMAR,SIGMAI) +! +! This subroutine computes conductivity, +! following the formula +! +! i +! EPS(q,omega) = 1 + --------------- * SIGMA(q,omega) +! omega * EPS_0 +! +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * EPSR : real part of dielectric function +! * EPSI : imaginary part of dielectric function +! +! +! Output variables : +! +! * SIGMAR : real part of conductivity +! * SIGMAI : imaginary part of conductivity +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Oct 2020 +! + USE REAL_NUMBERS, ONLY : ONE,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : EPS_0 + USE FERMI_SI, ONLY : KF_SI,VF_SI +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,EPSR,EPSI + REAL (WP), INTENT(OUT) :: SIGMAR,SIGMAI +! + REAL (WP) :: Y,U + REAL (WP) :: Q_SI,OMEGA +! + REAL (WP) :: REAL,AIMAG +! + COMPLEX (WP) :: EPS,SIGMA +! + Y = X + X ! Y = q / k_F + U = X * Z ! U = omega / (q v_F) +! + Q_SI = Y * KF_SI ! q in SI +! + OMEGA = Q_SI * VF_SI * U ! omega in SI +! + EPS = EPSR + IC * EPSI ! +! + SIGMA = (ONE - EPS) * IC * OMEGA * EPS_0 ! +! + SIGMAR = REAL(SIGMA,KIND=WP) ! + SIGMAI = AIMAG(SIGMA) ! +! + END SUBROUTINE EPS_TO_SIGMA +! +!======================================================================= +! + SUBROUTINE EPS_TO_SQO(X,Z,T,RS,DMN,EPSR,EPSI,VC,SQO) +! +! This subroutine computes dynamic structure factor, +! following the formula +! _ _ +! 2*h_bar 1 | 1 | +! S(q,omega) = --------- * ------------------------------- * Im| - --- | +! n*Vc(q) 1 - exp(-h_bar*omega / k_B*T) |_ eps _| +! +! +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * T : temperature in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! * DMN : problem dimension +! * EPSR : real part of dielectric function +! * EPSI : imaginary part of dielectric function +! * VC : Coulomb potential in k-space +! +! +! Output variables : +! +! * SQO : dynamic structure factor +! +! +! Author : D. Sébilleau +! +! Last modified : 21 Dec 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE COMPLEX_NUMBERS, ONLY : IC + USE CONSTANTS_P1, ONLY : H_BAR,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE UTILITIES_1, ONLY : RS_TO_N0 + USE MINMAX_VALUES +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,T,RS + REAL (WP), INTENT(IN) :: EPSR,EPSI,VC + REAL (WP), INTENT(OUT) :: SQO +! + REAL (WP) :: MAX_EXP,MIN_EXP + REAL (WP) :: Y,U + REAL (WP) :: Q_SI,OMEGA,EX,KOEF + REAL (WP) :: IMG,EXPO + REAL (WP) :: N0 +! + REAL (WP) :: EXP +! + CHARACTER (LEN = 2) :: DMN +! +! Computing the max and min value of the exponent of e^x +! + CALL MINMAX_EXP(MAX_EXP,MIN_EXP) ! +! + Y = X + X ! Y = q / k_F + U = X * Z ! U = omega / (q v_F) +! + Q_SI = Y * KF_SI ! q in SI +! + OMEGA = Q_SI * VF_SI * U ! omega in SI +! _ _ +! | 1 | +! Computing Im| - --- | +! |_ eps _| +! + IMG = EPSI / (EPSR * EPSR + EPSI * EPSI) ! +! +! Computing the electron density from the Wigner-Seitz radius +! + N0 = RS_TO_N0(DMN,RS) ! +! + EX = - H_BAR * OMEGA / (K_B * T) ! +! +! Checking if exp(- ex) can be represented +! + IF(EX > MIN_EXP) THEN ! + EXPO = EXP(EX) ! + ELSE ! + EXPO = ZERO ! + END IF ! +! + KOEF = TWO * H_BAR / (N0 * VC) ! coef. of formula +! + SQO = KOEF * ONE / (ONE - EXPO) * IMG ! +! + END SUBROUTINE EPS_TO_SQO +! +!======================================================================= +! + FUNCTION LOSS_TO_SF(X,Z,T,LOSS) +! +! This function transforms a loss function L(q,omega) into a +! structure factor S(q,omega) + +! Note: It makes use of the fluctuation-dissipation theorem +! to obtain +! +! S(q,omega) = (k_B T / Pi V_C) * B(h_bar omega / k_B T) * L(q,omega) +! +! where B(x) is the Bose factor : B(x) = x / ( 1 - exp(-x) ) +! +! +! References: (1) Yu. V. Arkhipov et al, Contrib. Plasma Phys. +! 55, 381-389 (2015) +! +! +! --> Warning: 3D only at present <-- +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * T : temperature in SI +! * LOSS : value of the loss function +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN,RS + USE SCREENING_TYPE +! + USE REAL_NUMBERS, ONLY : ONE,HALF + USE CONSTANTS_P1, ONLY : H_BAR,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI_INV +! + USE SCREENING_VEC + USE COULOMB_K +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,T,LOSS + REAL (WP) :: LOSS_TO_SF + REAL (WP) :: Y,U + REAL (WP) :: KBT,XX,BOSE,COEF + REAL (WP) :: Q_SI,OMEGA + REAL (WP) :: KS_SI,VC +! + REAL (WP) :: EXP +! + Y = X + X ! Y = q / k_F + U = X * Z ! U = omega / (q v_F) +! + Q_SI = Y * KF_SI ! q in SI +! + OMEGA = Q_SI * VF_SI * U ! omega in SI +! + KBT = K_B * T ! +! +! Computing the screening vector +! + CALL SCREENING_VECTOR(SC_TYPE,DMN,X,RS,T,KS_SI) +! +! Computation of the Coulomb potential +! + CALL COULOMB_FF(DMN,'SIU',Q_SI,KS_SI,VC) ! +! +! Computation of the Bose factor +! + XX = H_BAR * OMEGA / KBT ! + BOSE = XX / (ONE - EXP(- XX)) ! +! + COEF = PI_INV / (KBT * VC) ! +! + LOSS_TO_SF = COEF * BOSE * LOSS ! +! + END FUNCTION LOSS_TO_SF +! +!======================================================================= +! + FUNCTION SF_TO_LOSS(X,Z,T,SQO) +! +! This function transforms a structure factor S(q,omega) into a +! loss function L(q,omega) + +! Note: It makes use of the fluctuation-dissipation theorem +! to obtain +! +! L(q,omega) = S(q,omega) / ( (k_B T / Pi V_C) * B(h_bar omega / k_B T) ) +! +! +! where B(x) is the Bose factor : B(x) = x / ( 1 - exp(-x) ) +! +! +! References: (1) Yu. V. Arkhipov et al, Contrib. Plasma Phys. +! 55, 381-389 (2015) +! +! +! --> Warning: 3D only at present <-- +! +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * T : temperature in SI +! * SQO : value of the structure factor +! +! +! Author : D. Sébilleau +! +! +! Last modified : 23 Oct 2020 +! + USE MATERIAL_PROP, ONLY : DMN,RS + USE SCREENING_TYPE +! + USE REAL_NUMBERS, ONLY : ONE,HALF + USE CONSTANTS_P1, ONLY : H_BAR,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI + USE PI_ETC, ONLY : PI_INV +! + USE SCREENING_VEC + USE COULOMB_K +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,T,SQO + REAL (WP) :: SF_TO_LOSS + REAL (WP) :: Y,U + REAL (WP) :: Q_SI,OMEGA + REAL (WP) :: KBT,XX,BOSE,COEF + REAL (WP) :: KS_SI,VC +! + REAL (WP) :: EXP +! + Y = X + X ! Y = q / k_F + U = X * Z ! U = omega / (q v_F) +! + Q_SI = Y * KF_SI ! q in SI +! + OMEGA = Q_SI * VF_SI * U ! omega in SI +! + KBT = K_B * T ! +! +! Computing the screening vector +! + CALL SCREENING_VECTOR(SC_TYPE,DMN,X,RS,T,KS_SI) +! +! Computation of the Coulomb potential +! + CALL COULOMB_FF(DMN,'SIU',Q_SI,KS_SI,VC) ! +! +! Computation of the Bose factor +! + XX = H_BAR * OMEGA / KBT ! + BOSE = XX / (ONE - EXP(- XX)) ! +! + COEF = PI_INV / (KBT * VC) ! +! + SF_TO_LOSS = SQO / (COEF * BOSE) ! +! + END FUNCTION SF_TO_LOSS +! +!======================================================================= +! + SUBROUTINE SQO_TO_EPSI(X,Z,T,RS,SQO,EPSI) +! +! This subroutine computes the imaginary part of the dielectric function +! from the knowledge of the dynamic structure factor, +! following the formula +! _ _ +! h_bar 1 | 1 | +! S(q,omega) = ----------- * ------------------------------- * Im| - --- | +! pi*n*Vc(q) 1 - exp(-h_bar*omega / k_B*T) |_ eps _| +! +! +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : omega / omega_q --> dimensionless +! * T : temperature in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! * SQO : dynamic structure factor +! +! +! Output variables : +! +! * EPSI : imaginary part of dielectric function +! +! +! Author : D. Sébilleau +! +! Last modified : 4 Jun 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN + USE SCREENING_TYPE +! + USE REAL_NUMBERS, ONLY : ONE,TWO,HALF + USE PI_ETC, ONLY : PI + USE CONSTANTS_P1, ONLY : H_BAR,K_B + USE FERMI_SI, ONLY : KF_SI,VF_SI +! + USE UTILITIES_1, ONLY : RS_TO_N0 +! + USE SCREENING_VEC + USE COULOMB_K +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,Z,T,RS,SQO + REAL (WP), INTENT(OUT) :: EPSI + REAL (WP) :: Y,U + REAL (WP) :: Q_SI,OMEGA,KBT + REAL (WP) :: N0,KS_SI,VC + REAL (WP) :: EX,KOEF +! + REAL (WP) :: EXP +! + Y = X + X ! Y = q / k_F + U = X * Z ! U = omega / (q v_F) +! + Q_SI = Y * KF_SI ! q in SI +! + OMEGA = Q_SI * VF_SI * U ! omega in SI +! + KBT = K_B * T ! +! +! Computing the screening vector +! + CALL SCREENING_VECTOR(SC_TYPE,DMN,X,RS,T,KS_SI) +! +! Computation of the Coulomb potential +! + CALL COULOMB_FF(DMN,'SIU',Q_SI,KS_SI,VC) ! +! +! Computing the electron density from the Wigner-Seitz radius +! + N0=RS_TO_N0(DMN,RS) ! +! + EX= H_BAR * OMEGA / KBT ! +! + KOEF = H_BAR / (PI * N0 * VC) ! coef. of formula +! + EPSI = - KOEF * ONE / ( (ONE - EXP(- EX)) * SQO ) ! +! +! Computing the real part +! + END SUBROUTINE SQO_TO_EPSI +! +END MODULE UTILITIES_3 + diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/utilities_4.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/utilities_4.f90 new file mode 100644 index 0000000..1088c3b --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/utilities_4.f90 @@ -0,0 +1,242 @@ +! +!======================================================================= +! +MODULE UTILITIES_4 +! + USE ACCURACY_REAL +! +! It contains the following functions/subroutines: +! +! * SUBROUTINE TAU_TO_D(TAU,DC) +! * SUBROUTINE D_TO_TAU(DC,TAU) +! * SUBROUTINE ETA_TO_D(ETA,DC,T,RD,D) +! * SUBROUTINE D_TO_ETA(ETA,DC,T,RD,D) +! * SUBROUTINE TAU_TO_ETA(TAU,RS,T,ETA) +! +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE TAU_TO_D(TAU,DC) +! +! This subroutine computes the diffusion coefficient from the +! knowledge of the relaxation time using the relation: +! +! +! v_F^2 * TAU +! DC = ---------------- where d is the dimensionality +! d +! +! +! Input parameters: +! +! * TAU : relaxation time (in SI) +! +! +! Output parameters: +! +! * DC : diffusion coefficient (in SI) +! +! +! Author : D. Sébilleau +! +! Last modified : 25 Jun 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN + USE FERMI_SI, ONLY : VF_SI + USE UTILITIES_1, ONLY : D +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: TAU + REAL (WP) :: DC +! + DC=VF_SI*VF_SI*TAU/D(DMN) ! +! + END SUBROUTINE TAU_TO_D +! +!======================================================================= +! + SUBROUTINE D_TO_TAU(DC,TAU) +! +! This subroutine computes the relaxation time from the +! knowledge of the diffusion coefficient using the relation: +! +! +! v_F^2 * TAU +! DC = ---------------- where d is the dimensionality +! d +! +! +! Input parameters: +! +! * DC : diffusion coefficient (in SI) +! +! +! Output parameters: +! +! * TAU : relaxation time (in SI) +! +! +! +! Author : D. Sébilleau +! +! Last modified : 23 Oct 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN + USE FERMI_SI, ONLY : VF_SI + USE UTILITIES_1, ONLY : D +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: DC + REAL (WP), INTENT(OUT) :: TAU +! + TAU = DC * D(DMN) / (VF_SI * VF_SI) ! +! + END SUBROUTINE D_TO_TAU +! +!======================================================================= +! + SUBROUTINE ETA_TO_D(ETA,T,RD,DC) +! +! This subroutine computes the shear viscosity from the +! knowledge of the diffusion coefficient using the relation: +! +! +! k_B * T +! DC = ---------------- +! 6*pi * ETA* RD +! +! +! Input parameters: +! +! * ETA : viscosity in SI +! * T : temperature in SI +! * RD : sphere radius in SI +! +! +! Output parameters: +! +! * DC : diffusion coefficient (in SI) +! +! +! Author : D. Sébilleau +! +! Last modified : 25 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : SIXTH + USE CONSTANTS_P1, ONLY : K_B + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: ETA,T,RD + REAL (WP), INTENT(OUT) :: DC +! + DC = K_B * T * SIXTH * PI_INV / (ETA * RD) ! +! + END SUBROUTINE ETA_TO_D +! +!======================================================================= +! + SUBROUTINE D_TO_ETA(DC,T,RD,ETA) +! +! This subroutine computes the diffusion coefficient from the +! knowledge of the shear viscosity using the relation: +! +! +! k_B * T +! DC = ---------------- +! 6*pi * ETA* RD +! +! +! Input parameters: +! +! * DC : diffusion coefficient (in SI) +! * T : temperature in SI +! * RD : sphere radius in SI +! +! +! Output parameters: +! +! * ETA : viscosity in SI +! +! +! Author : D. Sébilleau +! +! Last modified : 25 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : SIXTH + USE CONSTANTS_P1, ONLY : K_B + USE PI_ETC, ONLY : PI_INV +! + IMPLICIT NONE +! + REAL (WP),INTENT(IN) :: DC,T,RD + REAL (WP),INTENT(OUT) :: ETA +! + ETA = K_B * T * SIXTH * PI_INV / (DC * RD) ! +! + END SUBROUTINE D_TO_ETA +! +!======================================================================= +! + SUBROUTINE TAU_TO_ETA(TAU,RS,T,ETA) +! +! This subroutine computes the shear viscosity from the +! knowledge of the relaxation using the relation: +! +! References: (1) R. Kishore and K. N. Pathak, +! Phys. Rev. 183, 672-674 (1069) +! +! +! 2 +! ETA = --- * N0 * mu * TAU +! 5 +! +! This formula is valid in the low-temperature limit k_B*T << mu +! for 3D systems +! +! +! Input parameters: +! +! * TAU : relaxation time (in SI) +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature in SI +! +! +! Output parameters: +! +! * ETA : shear viscosity (in SI) +! +! +! Author : D. Sébilleau +! +! Last modified : 25 Jun 2020 +! +! + USE MATERIAL_PROP, ONLY : DMN + USE REAL_NUMBERS, ONLY : TWO,FIFTH + USE UTILITIES_1, ONLY : RS_TO_N0 + USE CHEMICAL_POTENTIAL, ONLY : MU +! + REAL (WP), INTENT(IN) :: TAU,RS,T + REAL (WP), INTENT(OUT) :: ETA + REAL (WP) :: N0,MU0 +! + N0 = RS_TO_N0('3D',RS) ! +! + MU0 = MU('3D',T) ! +! + ETA = TWO * FIFTH * N0 * MU0 * TAU ! +! + END SUBROUTINE TAU_TO_ETA +! +END MODULE UTILITIES_4 diff --git a/New_libraries/DFM_library/UTILITIES_LIBRARY/velocities.f90 b/New_libraries/DFM_library/UTILITIES_LIBRARY/velocities.f90 new file mode 100644 index 0000000..e8e9c02 --- /dev/null +++ b/New_libraries/DFM_library/UTILITIES_LIBRARY/velocities.f90 @@ -0,0 +1,66 @@ +! +!======================================================================= +! +MODULE VELOCITIES +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + SUBROUTINE VELOCITIES_3D(RS,T,EC_TYPE,VE2,V_INT_2) +! +! This subroutine computes velocities as a function of the +! correlation energy +! +! +! References: (1) I. M. Tkachenko, J. Alcober and J. L. Munoz-Cobo, +! Contrib. Plasma Phys. 5, 467-475 (2002) +! +! Input parameters: +! +! * RS : Wigner-Seitz radius (in units of a_0) +! * T : temperature (SI) +! * EC_TYPE : type of correlation energy functional +! +! Output parameters: +! +! * VE2 : square of the average kinetic energy velocity +! * V_INT_2 : square of the correlation energy velocity +! +! +! +! Author : D. Sébilleau +! +! Last modified : 18 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO + USE CONSTANTS_P1, ONLY : H_BAR,E + USE CORRELATION_ENERGIES +! + IMPLICIT NONE +! + CHARACTER (LEN = 6) :: EC_TYPE +! + REAL (WP) :: RS,T + REAL (WP) :: VE2,V_INT_2 + REAL (WP) :: COEF,EC,D_EC_1,D_EC_2 +! + COEF= (E*E/H_BAR)**2 ! +! + EC = EC_3D(EC_TYPE,1,RS,T) ! + CALL DERIVE_EC_3D(EC_TYPE,1,5,RS,T,D_EC_1,D_EC_2) ! +! +! Velocities (with EC per electron in Ryd) ! +! + VE2 = COEF*(2.21E0_WP/(RS*RS) - EC - RS*D_EC_1) ! ref (1) eq. (22) + V_INT_2 = -TWO*COEF/15.0E0_WP * & ! + (-0.916E0_WP/RS + TWO*EC + RS*D_EC_1) ! ref (1) eq. (22) +! + END SUBROUTINE VELOCITIES_3D +! +END MODULE VELOCITIES + diff --git a/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/2F1_real.f90 b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/2F1_real.f90 new file mode 100644 index 0000000..b244b11 --- /dev/null +++ b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/2F1_real.f90 @@ -0,0 +1,374 @@ +! +!======================================================================= +! +MODULE CONFLUENT_HYPGEOM_REAL +! +! This module provides several subroutines to compute +! the Gauss hypergeometric function +! +! 2F1(a,b,c;x) +! +! +! --> <-- +! --> x real <-- +! --> <-- +! +! +! +! 1) SUBROUTINE HYGFX(A,B,C,X,HF) +! +! 2) SUBROUTINE HYP(Z,A,B,C,RE,IM) +! +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE HYGFX(A,B,C,X,HF) +! +! HYGFX computes the hypergeometric function F(a,b,c,x). +! +! 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: +! +! 04 April 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. +! +! ========================================================== +! +! Purpose: Compute hypergeometric function F(a,b,c,x) +! +! Input : A --- Parameter +! B --- Parameter +! C --- Parameter, C <> 0,-1,-2,... +! X --- Argument (X < 1) +! +! Output: HF --- F(A,B,C,X) +! +! Routines called: +! (1) GAMMA for computing gamma function +! (2) PSI for computing psi function +! +! ========================================================== +! +! +! Last modified (DS) : 1 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE PI_ETC, ONLY : PI + USE GAMMA_FUNCTION, ONLY : GAMMA + USE DIGAMMA_FUNCTION, ONLY : PSI +! + IMPLICIT NONE +! + INTEGER :: J,K,M,NM +! + REAL (WP), INTENT(IN) :: C + REAL (WP) :: A,B,X + REAL (WP), INTENT(OUT) :: HF +! + REAL (WP) :: C0 + REAL (WP) :: EPS + REAL (WP) :: G0,G1,G2,G3 + REAL (WP) :: GC,R + REAL (WP) :: A0,AA,BB,C1 + REAL (WP) :: F0,F1 + REAL (WP) :: GA,GABC,GAM,GB,GBM,GCA,GCAB,GCB,GM + REAL (WP) :: HW + REAL (WP) :: PA,PB,R1,RM,RP + REAL (WP) :: SM,SP,SP0 + REAL (WP) :: R0,X1 +! + REAL, PARAMETER :: EL = 0.5772156649015329E+00_WP +! + LOGICAL :: L0,L1,L2,L3,L4,L5 +! + L0 = C == INT(C) .AND. C < ZERO ! + L1 = ONE - X < 1.0E-15_WP .AND. C - A - B <= ZERO ! + L2 = A == INT(A) .AND. A < ZERO ! + L3 = B == INT(B) .AND. B < ZERO ! + L4 = C - A == INT(C - A) .AND. C - A <= ZERO ! + L5 = C - B == INT(C - B) .AND. C - B <= ZERO ! +! + IF(L0 .OR. L1) THEN ! + WRITE(6,110) ! + WRITE(6,111) ! + WRITE(6,112) ! + STOP ! + END IF ! +! + IF(0.95E+00_WP < X) THEN ! + EPS = 1.0E-08_WP ! + ELSE ! + EPS = 1.0E-15_WP ! + END IF ! +! + IF(X == ZERO .OR. A == ZERO .OR. B == ZERO) THEN ! + HF = ONE ! + RETURN ! + ELSE IF(ONE - X == EPS .AND. ZERO < C - A - B) THEN ! + CALL GAMMA(C, GC) ! + CALL GAMMA(C - A - B, GCAB) ! + CALL GAMMA(C - A, GCA) ! + CALL GAMMA(C - B, GCB) ! + HF = GC * GCAB / (GCA * GCB) ! + RETURN ! + ELSE IF(ONE + X <= EPS .AND. & ! + DABS(C - A + B -ONE) <= EPS) THEN ! + G0 = DSQRT(PI) * TWO ** (- A) ! + CALL GAMMA(C, G1) ! + CALL GAMMA(ONE + A / TWO - B, G2) ! + CALL GAMMA(HALF + HALF * A, G3) ! + HF = G0 * G1 / (G2 * G3) ! + RETURN ! + ELSE IF(L2 .OR. L3) THEN ! + IF(L2) THEN ! + NM = INT(DABS(A)) ! + END IF ! + IF(L3) THEN ! + NM = INT(DABS(B)) ! + END IF ! + HF = ONE ! + R = ONE ! + DO K = 1, NM ! + R = R * (A + K - ONE) * (B + K - ONE) / & ! + (K * (C + K - ONE)) * X ! + HF = HF + R ! + END DO ! + RETURN ! + ELSE IF(L4 .OR. L5) THEN ! + IF(L4) THEN ! + NM = INT(DABS(C - A)) ! + END IF ! + IF(L5) THEN ! + NM = INT(DABS(C - B)) ! + END IF ! + HF = ONE ! + R = ONE ! + DO K = 1, NM ! + R = R * (C - A + K - ONE) * (C - B + K - ONE) / & ! + (K * (C + K - ONE)) * X ! + HF = HF + R ! + END DO ! + HF = (ONE - X) ** (C - A - B) * HF ! + RETURN ! + END IF ! +! + AA = A ! + BB = B ! + X1 = X ! +! + IF(X < ZERO) THEN ! + X = X / (X - ONE) ! + IF(A < C .AND. B < A .AND. ZERO < B) THEN ! + A = BB ! + B = AA ! + END IF ! + B = C - B ! + END IF ! +! + IF(0.75E+00_WP <= X) THEN ! + GM = ZERO ! + IF(DABS(C - A - B - INT(C - A - B)) < 1.0E-15_WP) THEN ! + M = INT(C - A - B) ! + CALL GAMMA(A, GA) ! + CALL GAMMA(B, GB) ! + CALL GAMMA(C, GC) ! + CALL GAMMA(A + M, GAM) ! + CALL GAMMA(B + M, GBM) ! + CALL PSI(A, PA) ! + CALL PSI(B, PB) ! + IF(M .NE. 0) THEN ! + GM = ONE ! + END IF ! + DO J = 1, ABS (M) - 1 ! + GM = GM * J ! + END DO ! + RM = ONE ! + DO J = 1, ABS (M) ! + RM = RM * J ! + END DO ! + F0 = ONE ! + R0 = ONE ! + R1 = ONE ! + SP0 = ZERO ! + SP = ZERO ! + IF(0 <= M) THEN ! + C0 = GM * GC / (GAM * GBM) ! + C1 = - GC * (X - ONE) ** M / (GA * GB * RM) ! + DO K = 1, M - 1 ! + R0 = R0 * (A + K - ONE) * (B + K - ONE) / & ! + (K * (K - M)) * (ONE - X) ! + F0 = F0 + R0 ! + END DO ! +! + DO K = 1, M ! + SP0 = SP0 + ONE / (A + K - ONE) + & ! + ONE / (B + K - ONE) - ONE / K ! + END DO ! +! + F1 = PA + PB + SP0 + TWO * EL + DLOG(ONE - X) ! +! + DO K = 1, 250 ! + SP = SP + (ONE - A) / (K * (A + K - ONE)) + & ! + (ONE - B) / (K * (B + K - ONE)) ! + SM = ZERO ! + DO J = 1,M ! + SM = SM + (ONE - A) / ((J + K) * & ! + (A + J + K - ONE)) + ONE / & ! + (B + J + K - ONE) ! + END DO ! + RP = PA + PB + TWO * EL + SP + SM + DLOG(ONE - X) ! + R1 = R1 * (A + M + K - ONE) * (B + M + K - ONE) / & ! + (K * (M + K)) * (ONE - X) ! + F1 = F1 + R1 * RP ! + IF(DABS(F1 - HW) < DABS(F1) * EPS) THEN ! + GO TO 10 ! + END IF ! + HW = F1 ! + END DO ! +! + 10 CONTINUE +! + HF = F0 *C0 + F1 * C1 ! +! + ELSE IF(M < 0) THEN ! +! + M = - M ! + C0 = GM * GC / (GA * GB * (ONE - X)**M) ! + C1 = - (-1)**M * GC / (GAM * GBM * RM) ! +! + DO K = 1,M-1 ! + R0 = R0 * (A - M + K - ONE) * & ! + (B - M + K - ONE) / & ! + (K * (K - M)) * (ONE - X) ! + F0 = F0 + R0 ! + END DO ! +! + DO K = 1,M ! + SP0 = SP0 + ONE / K ! + END DO ! + F1 = PA + PB - SP0 + TWO * EL + DLOG(ONE - X) ! + DO K = 1,250 ! + SP = SP + (ONE - A) / (K * (A + K - ONE)) + & ! + (ONE - B) / (K * (B + K - ONE)) ! + SM = ZERO ! + DO J = 1,M ! + SM = SM+ ONE /(J + K) ! + END DO ! + RP = PA + PB + TWO * EL + SP - SM + & ! + DLOG(ONE - X) ! + R1 = R1 * (A + K - ONE) * (B + K - ONE) / & ! + (K * (M + K)) * (ONE - X) ! + F1 = F1 + R1 * RP ! + IF(DABS(F1 - HW) < DABS(F1) * EPS) THEN ! + GO TO 20 ! + END IF ! + HW = F1 ! + END DO ! +! + 20 CONTINUE ! +! + HF = F0 * C0 + F1 * C1 ! + END IF ! + ELSE ! + CALL GAMMA(A,GA) ! + CALL GAMMA(B,GB) ! + CALL GAMMA(C,GC) ! + CALL GAMMA(C-A,GCA) ! + CALL GAMMA(C-B,GCB) ! + CALL GAMMA(C-A-B,GCAB) ! + CALL GAMMA(A+B-C,GABC) ! + C0 = GC * GCAB / (GCA * GCB) ! + C1 = GC * GABC / (GA * GB) * (ONE - X)**(C - A - B) ! + HF = ZERO ! + R0 = C0 ! + R1 = C1 ! + DO K = 1,250 ! + R0 = R0 * (A + K - ONE) * (B + K - ONE) / & ! + (K * (A + B - C + K)) * (ONE - X) ! + R1 = R1 * (C - A + K - ONE) * (C - B + K - ONE) /& ! + (K * (C - A - B + K)) * (ONE - X) ! + HF = HF + R0 + R1 ! + IF(DABS(HF - HW) < DABS(HF) * EPS) THEN ! + GO TO 30 ! + END IF ! + HW = HF ! + END DO ! +! + 30 CONTINUE ! +! + HF = HF + C0 + C1 ! +! + END IF ! + ELSE ! + A0 = ONE ! + IF(C > A .AND. C < TWO * A .AND. & ! + C > B .AND. C < TWO*B) THEN ! + A0 = (ONE - X) ** (C - A - B) ! + A = C - A ! + B = C - B ! + END IF ! + HF = ONE ! + R = ONE ! + DO K = 1,250 ! + R = R *(A + K - ONE) * (B + K - ONE) / & ! + (K * (C + K - ONE)) * X ! + HF = HF + R ! + IF(DABS(HF - HW) <= DABS(HF) * EPS) THEN ! + GO TO 40 ! + END IF ! + HW = HF ! + END DO ! +! + 40 CONTINUE ! +! + HF = A0 * HF ! +! + END IF ! +! + IF(X1 < ZERO) THEN ! + X = X1 ! + C0 = ONE / (ONE - X) ** AA ! + HF = C0 * HF ! + END IF +! + A = AA ! + B = BB ! +! + IF(120 < K) THEN ! + WRITE(*,115) ! + END IF ! +! +! Formats: +! + 110 FORMAT(' ') + 111 FORMAT('HYGFX - Fatal error!') + 112 FORMAT('The hypergeometric series is divergent.') + 115 FORMAT('Warning! You should check the accuracy') +! + RETURN ! +! + END SUBROUTINE HYGFX +! +END MODULE CONFLUENT_HYPGEOM_REAL diff --git a/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/Legendre_functions.f90 b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/Legendre_functions.f90 new file mode 100644 index 0000000..e51ce77 --- /dev/null +++ b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/Legendre_functions.f90 @@ -0,0 +1,315 @@ +! +!======================================================================= +! +MODULE LEGENDRE_FUNCTIONS +! +! This module provides Legendre polynomials and functions +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE POLLEG(NC,X,PL) +! +! This routine computes the Legendre polynomials up to order NC +! using the standard Bonnet recurrence: +! +! (n+1) P_(n+1)(x) = (2n+1)x P_(n)(x) - n P_(n-1)(x) +! +! starting from P_0(x) = 1 +! P_1(x) = x +! +! +! Author : D. Sébilleau +! +! Last modified : 14 Aug 2020 +! + USE REAL_NUMBERS, ONLY : ONE +! + IMPLICIT NONE +! + REAL (WP) :: X + REAL (WP) :: XL,XL1,XL3 + REAL (WP) :: PL(0:150) +! + INTEGER :: NC,L + INTEGER :: L1,L2 + INTEGER :: LOGF +! + LOGF = 6 ! +! + IF(NC > 150) THEN ! + WRITE(LOGF,10) ! + STOP ! + END IF ! +! + PL(0) = ONE ! + PL(1) = X ! +! + DO L=2,NC ! +! + L1 = L - 1 ! + L2 = L - 2 ! + XL = DFLOAT(L) ! L + XL1 = DFLOAT(L1) ! L+1 + XL3 = XL+XL+ONE ! 2L+1 + PL(L) = (X*XL3*PL(L1)-XL1*PL(L2))/XL ! +! +! Format: +! + 10 FORMAT(5X,'<<<<< DIMENSION ERROR IN POLLEG >>>>>',/, & + 5X,'<<<<< L > 150. RE-DIMENSION PL >>>>>',//) +! + END DO ! +! + END SUBROUTINE POLLEG +! +!======================================================================= +! + SUBROUTINE PLM(NC,X,PLMM) +! +! This routine computes the associated Legendre functions +! of the first kind. It is a modified version of that written by +! +! W.H. Press, B.P. Flannery, S.A. Teukolsky and W.T. Vetterling +! in "Numerical Recipes : The Art of Scientific Computing" +! (Cambridge University Press 1992). +! +! It computes all values of P_l^m(x) up to l = NC +! and stores them as PLMM(L,M) +! +! +! Input variables : +! +! * NC : upper value of l +! * X : argument of P_l^m +! +! Output variables : +! +! * PLMM : P_l^m(x) for l = 0 to l = NC +! +! +! Last modified : 14 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO +! + IMPLICIT NONE +! + REAL (WP) :: X + REAL (WP) :: PLMM(0:150,0:150) + REAL (WP) :: PMM,FACT,SOMX2,PMMP1,PLL +! + INTEGER :: NC,L,I,M + INTEGER :: LOGF +! + LOGF = 6 ! +! +! Initialization with Legendre polynomials PLMM(L,0) +! (recurrence on L) +! + PLMM(0,0) = ONE ! + PLMM(1,0) = X ! +! + DO L=2,NC ! + PLMM(L,0)=( X * DFLOAT(L+L-1) * PLMM(L-1,0) - & ! + DFLOAT(L-1) * PLMM(L-2,0) & ! + ) / DFLOAT(L) ! + END DO ! +! + DO M=1,NC ! +! + PMM = ONE ! + FACT = ONE ! + SOMX2 = DSQRT(ONE - X*X) ! + FACT = ONE ! +! + DO I=1,M ! + PMM = -PMM * FACT * SOMX2 ! + FACT = FACT+TWO ! + END DO ! +! + PMMP1 = X* FACT * PMM ! + PLMM(M,M) = PMM ! + PLMM(M+1,M) = PMMP1 ! +! + IF(M < NC-1) THEN ! +! + DO L=M+2,NC ! + PLL=( X*DFLOAT(L+L-1) * PMMP1 - & ! + DFLOAT(L+M-1) * PMM & ! + ) / DFLOAT(L-M) ! + PMM = PMMP1 ! + PMMP1 = PLL ! + PLMM(L,M) = PLL ! +! + END DO ! +! + END IF ! +! + END DO ! +! + END SUBROUTINE PLM +! +!======================================================================= +! + SUBROUTINE LQMN(MM,M,N,X,QM,QD) +! +! +! ========================================================== +! Purpose: Compute the associated Legendre functions of the +! second kind, Qmn(x) and Qmn'(x) +! Input : x --- Argument of Qmn(x) +! m --- Order of Qmn(x) ( m = 0,1,2,...) +! n --- Degree of Qmn(x) ( n = 0,1,2,...) +! mm --- Physical dimension of QM and QD +! Output: QM(m,n) --- Qmn(x) +! QD(m,n) --- Qmn'(x) +! ========================================================== +! +! From the book "Computation of Special Functions" +! by Shanjie Zhang and Jianming Jin +! Copyright 1996 by John Wiley & Sons, Inc. +! +! The authors state: +! "However, we give permission to the reader who purchases this book +! to incorporate any of these programs into his or her programs +! provided that the copyright is acknowledged." +! +! +! Last modified (DS) : 14 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,HALF,INF +! + IMPLICIT NONE +! + INTEGER :: MM,M,N + INTEGER :: LS,I,J,K,KM +! + REAL (WP) :: X + REAL (WP) :: QM(0:MM,0:N),QD(0:MM,0:N) + REAL (WP) :: XS,XQ,Q0,Q1,Q10,QF + REAL (WP) :: XI,XJ,XK + REAL (WP) :: QF0,QF1,QF2 +! +! Trivial cas X = 1: +! + IF (DABS(X) == ONE) THEN ! +! + DO I=0,M ! + DO J=0,N + QM(I,J) = INF ! + QD(I,J) = INF ! + END DO ! + END DO ! +! + RETURN ! +! + END IF ! +! + LS = 1 ! + IF(DABS(X) > ONE) LS = -1 ! + XS = LS * (ONE - X*X) ! + XQ = DSQRT(XS) ! + Q0 = HALF * DLOG(DABS((X+ONE) / (X-ONE))) ! +! + IF(DABS(X) < 1.0001E0_WP) THEN ! + QM(0,0) = Q0 ! + QM(0,1) = X * Q0 - ONE ! + QM(1,0) = -ONE / XQ ! + QM(1,1) = -XQ * (Q0 + X / (ONE - X*X)) ! +! + DO I=0,1 ! + XI = DFLOAT(I) ! + DO J=2,N ! + XJ = DFLOAT(J) ! + QM(I,J )= ( (TWO*XJ-ONE) * X * QM(I,J-1) & ! + -(XJ+XI-ONE)*QM(I,J-2) & ! + ) / (XJ-XI) ! + END DO ! + END DO ! +! + DO J=0,N + XJ = DFLOAT(J) ! + DO I=2,M + XI = DFLOAT(I) ! + QM(I,J) = -TWO*(XI-ONE) * X / XQ * QM(I-1,J) - LS * & ! + (XJ+XI-ONE) * (XJ-XI+TWO) * QM(I-2,J) ! + END DO ! + END DO ! +! + ELSE ! +! + IF(DABS(X) > 1.1E0_WP) THEN ! + KM = 40 + M + N + ELSE + KM = (40 + M + N) * INT(- ONE - 1.8E0_WP * DLOG(X-ONE)) ! + END IF ! +! + QF2 = ZERO ! + QF1 = ONE ! +! + DO K=KM,0,-1 ! + XK = DFLOAT(K) ! + QF0 = ( (XK + XK + THREE)*X*QF1-(XK+TWO)*QF2 ) / (XK+ONE) ! + IF(K <= N) QM(0,K) = QF0 ! + QF2 = QF1 ! + QF1 = QF0 ! + END DO ! +! + DO K=0,N ! + QM(0,K) = Q0 * QM(0,K) / QF0 ! + END DO ! +! + QF2 = ZERO ! + QF1 = ONE ! +! + DO K=KM,0,-1 + XK = DFLOAT(K) ! + QF0 = ( (XK + XK + THREE)*X*QF1-(XK+ONE)*QF2 ) / (XK+TWO) ! + IF(K <= N) QM(1,K) = QF0 ! + QF2 = QF1 ! + QF1 = QF0 ! + END DO ! +! + Q10 = -ONE / XQ ! +! + DO K=0,N ! + QM(1,K) = Q10 * QM(1,K) / QF0 ! + END DO ! +! + DO J=0,N ! + XJ = DFLOAT(J) ! + Q0 = QM(0,J) ! + Q1 = QM(1,J) ! + DO I=0,M-2 ! + XI = DFLOAT(I) ! + QF = -TWO*(XI+1)*X/XQ*Q1+(XJ-XI)*(XJ+XI+ONE)*Q0 ! + QM(I+2,J) = QF ! + Q0 = Q1 ! + Q1 = QF ! + END DO ! + END DO ! +! + END IF ! +! + QD(0,0) = DFLOAT(LS) / XS ! + DO J=1,N ! + QD(0,J) = LS * J * ( QM(0,J-1) - X * QM(0,J) ) / XS ! + END DO ! + DO J=0,N ! + XJ = DFLOAT(J) ! + DO I=1,M ! + XI = DFLOAT(I) ! + QD(I,J) = LS*XI*X/XS*QM(I,J) + (XI+XJ)*(XJ-XI+ONE) / & ! + XQ*QM(I-1,J) ! + END DO ! + END DO ! +! + END SUBROUTINE LQMN +! +END MODULE LEGENDRE_FUNCTIONS diff --git a/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/Lindhard_function.f90 b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/Lindhard_function.f90 new file mode 100644 index 0000000..568206d --- /dev/null +++ b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/Lindhard_function.f90 @@ -0,0 +1,384 @@ +! +!======================================================================= +! +MODULE LINDHARD_FUNCTION +! +! This module provides the static and dynamic Lindhard functions +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE LINDHARD_S(X,DMN,LR,LI) +! +! This subroutine calculates the (RPA) static Lindhard function F(x) +! for x = q / 2 k_F +! +! References: (1) J. Solyom, "Fundamental of the Physics of Solids", Vol3, Chap. 29 +! p. 61-138, Springer +! +! Note: The Lindhard function L(x) is defined as +! +! eps = 1 + q^2_TF / q^ 2 * L(x) (3D) +! +! eps = 1 + q_TF / q * L(x) (2D) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * DMN : problem dimension +! +! Output parameters: +! +! * LR : real part of the Lindhard function +! * LI : imaginary part of the Lindhard function +! +! +! Author : D. Sébilleau +! +! Last modified : 3 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,HALF,FOURTH,SMALL +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP), INTENT(IN) :: X + REAL (WP), INTENT(OUT) :: LR,LI + REAL (WP) :: X_INV,X2_INV,COEF +! + REAL (WP) :: LOG,ABS,SQRT +! + X_INV = ONE / X ! + X2_INV = X_INV * X_INV ! + COEF = FOURTH * X_INV ! 1 / (4 * X) +! + IF(X < SMALL) THEN ! +! + LR = ONE ! + LI = ZERO ! +! + ELSE ! +! + IF(DMN == '3D') THEN ! +! +!.......... 3D case .......... +! + LR = HALF + COEF * (ONE - X * X) * & ! + LOG(ABS((X + ONE) / (X - ONE))) ! equation (29.2.53) + LI = ZERO ! +! + ELSE IF(DMN == '2D') THEN ! +! +!.......... 2D case .......... +! + IF(X <= ONE) THEN ! + LR = ONE ! + LI = ZERO ! + ELSE + LR = ONE - SQRT(ONE - X2_INV) ! equation (29.5.15) + LI = ZERO ! + END IF ! +! + ELSE IF(DMN == '1D') THEN ! +! +!.......... 1D case .......... +! + LR = HALF * X_INV * LOG(ABS((X + ONE) / (X - ONE))) ! equation (29.5.22) + LI = ZERO ! +! + END IF ! +! + END IF ! +! + END SUBROUTINE LINDHARD_S +! +!======================================================================= +! + SUBROUTINE LINDHARD_D(X,Z,DMN,LR,LI) +! +! This subroutine computes the (RPA) dynamic Lindhard function. +! The real part LR and the imaginary part LI are +! computed separately. +! +! References: (1) J. Solyom, "Fundamental of the Physics of Solids", +! Vol3, Chap. 29, p. 61-138, Springer +! +! +! Note: The Lindhard function L(x) is defined as +! +! eps = 1 + q^2_TF / q^ 2 * L(q,omega) (3D) +! +! eps = 1 + q_TF / q * L(q,omega) (2D) +! +! +! Notation: hbar omega_q = hbar^2 q^2 / 2m +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! * Z : dimensionless factor --> Z = omega / omega_q +! * DMN : problem dimension +! +! Output parameters: +! +! * LR : real part of the Lindhard function +! * LI : imaginary part of the Lindhard function +! +! Intermediate parameters: +! +! * X_INV : q * v_F / omega_q = 2 * k_F / q = 1 / X +! * U = X * Z: omega / (q * v_F) +! +! Warning note: The real part of the Lindhard function is not +! always computable. Noting a = U +/- X, the +! pathological cases are +! +! (U + X - 1) = 0 --> (1 - a^2) Log| (a + 1)/(a - 1)| = 0 +! +! (U - X - 1) = 0 --> (1 - a^2) Log| (a - 1)/(a + 1)| = 0 +! +! (U - X + 1) = 0 --> (1 - a^2) Log| (a - 1)/(a + 1)| = 0 +! +! +! Author : D. Sébilleau +! +! Last modified : 19 Oct 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,HALF,EIGHTH,LARGE + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + CHARACTER (LEN = 2) :: DMN +! + REAL (WP), INTENT(IN) :: X,Z + REAL (WP), INTENT(OUT) :: LR,LI + REAL (WP) :: Y,U,X_INV,X2_INV,COEF + REAL (WP) :: A1,A2,A1L1,A2L2 + REAL (WP) :: DIFF1,DIFF2,DIFF3 + REAL (WP) :: NUM,DEN + REAL (WP) :: GP,GM,FP,FM,RP,RM + REAL (WP) :: SMALL +! + REAL (WP) :: ABS,LOG,SQRT +! + SMALL = 1.0E-30_WP +! + Y = X + X ! q / k_F + X_INV = ONE / X ! q * v_F / omega_q = 1 / X + X2_INV = X_INV * X_INV ! 1/ X^2 + COEF = EIGHTH * X_INV ! 1 / (8 * X) + U = X * Z ! omega / q * v_F) +! +! 3D case +! + IF(DMN == '3D') THEN ! ref. pp. 81-82 +! + A1 = ONE - (U + X) * (U + X) ! + A2 = ONE - (U - X) * (U - X) ! +! +! Checking the pathological cases for the real part +! + DIFF1 = ABS(U + X - ONE) ! |U + X - 1| + DIFF2 = ABS(U - X - ONE) ! |U - X - 1| + DIFF3 = ABS(U - X + ONE) ! |U - X + 1| +! + IF(DIFF1 < SMALL) THEN ! + A1L1 = ZERO ! <-- pathological case: U + X = 1 + ELSE ! + A1L1 = A1 * LOG(ABS((U + X + ONE) / (U + X - ONE))) ! + END IF ! + IF(DIFF2 < SMALL .OR. DIFF3 < SMALL) THEN ! + IF(DIFF2 < SMALL) THEN ! + A2L2 = ZERO ! <-- pathological case: U - X = 1 + END IF ! + IF(DIFF3 < SMALL) THEN ! + A2L2 = LARGE**5 ! <-- pathological case: U - X = -1 + END IF ! + ELSE ! + A2L2 = A2 * LOG(ABS((U - X - ONE) / (U - X + ONE))) ! + END IF ! +! +!.......... Real part .......... +! + LR = HALF + COEF * (A1L1 + A2L2) ! equation (29.2.52) +! +!.......... Imaginary part .......... +! + IF(X < ONE) THEN ! q < 2 k_F --> equation (29.2.56) +! ! + IF(U < (ONE - X)) THEN ! OMEGA < Q * V_F - OMEGA_Q + LI = PI * HALF *U ! equation (29.2.56a) + ELSE ! + IF(U <= (ONE + X)) THEN ! OMEGA < or = Q * V_F + OMEGA_Q + LI = PI * COEF * A2 ! equation (29.2.56b) + ELSE ! + LI = ZERO ! equation (29.2.56c) + END IF ! + END IF ! +! + ELSE ! q > 2 k_F --> equation (29.2.57) +! ! + IF(U < (X - ONE)) THEN ! OMEGA < OMEGA_Q - Q * V_F + LI = ZERO ! equation (29.2.57a) + ELSE ! + IF(U <= (X + ONE)) THEN ! OMEGA < or = Q * V_F + OMEGA_Q + LI = PI * COEF * A2 ! equation (29.2.57b) + ELSE ! + LI = ZERO ! equation (29.2.57c) + END IF ! + END IF ! +! + END IF ! +! +! 2D case +! + ELSE IF(DMN == '2D') THEN ! ref. pp. 98-99 +! + IF(X < ONE) THEN ! q < 2 k_F +! ! + IF(U <= (ONE - X)) THEN ! OMEGA < or = Q * V_F - OMEGA_Q +! ! + A1 = HALF * SQRT(ONE - (X - U) * (X - U)) / X ! + A2 = HALF * SQRT(ONE - (X + U) * (X + U)) / X ! +! ! + LR = ONE ! equation (29.5.3) + LI = A1 - A2 ! equation (29.5.4) +! ! + ELSE ! +! ! + IF(U <= (ONE + X)) THEN ! OMEGA < or = Q * V_F + OMEGA_Q +! ! + A1 = HALF * SQRT((X + U) * (X + U) - ONE) / X ! + A2 = HALF * SQRT(ONE - (X - U) * (X - U)) / X ! +! ! + LR = ONE - A1 ! equation (29.5.5) + LI = A2 ! equation (29.5.6) +! ! + ELSE ! +! ! + A1 = HALF * SQRT((X + U) * (X + U) - ONE) / X ! + A2 = HALF * SQRT((U - X) * (U - X) - ONE) / X ! +! ! + LR = ONE - A1 + A2 ! equation (29.5.7) + LI = ZERO ! equation (29.5.8) +! ! + END IF ! +! ! + END IF ! +! + ELSE ! q > 2 k_F +! ! + IF(U <= (X - ONE)) THEN ! OMEGA < or = Q * V_F - OMEGA_Q +! ! + A1 = HALF * SQRT((X + U) * (X + U) - ONE) / X ! + A2 = HALF * SQRT((X - U) * (X - U) - ONE) / X ! +! ! + LR = ONE - A1 - A2 ! equation (29.5.9) +! + IF(Z < SMALL) LR = ONE ! + LI = ZERO ! equation (29.5.10) +! ! + ELSE ! +! ! + IF(U <= (X + ONE)) THEN ! OMEGA < or = Q * V_F + OMEGA_Q +! ! + A1 = HALF * SQRT((X + U) * (X + U) - ONE) / X ! + A2 = HALF * SQRT(ONE - (X - U) * (X - U)) / X ! +! ! + LR = ONE - A1 ! equation (29.5.11) + LI = A2 ! equation (29.5.12) +! ! + ELSE ! +! ! + A1 = HALF * SQRT((X + U) * (X + U) - ONE) / X ! + A2 = HALF * SQRT((X - U) * (X - U) - ONE) / X ! +! ! + LR = ONE - A1 + A2 ! equation (29.5.13) + LI = ZERO ! equation (29.5.14) +! ! + END IF ! +! ! + END IF ! +! ! + END IF ! +! + ELSE IF(DMN == 'D2') THEN ! Isihara's approach +! + GP = X + U ! + GM = X - U ! + FP = ONE - GP * GP ! + FM = ONE - GM * GM ! + RP = (ONE - GP) / (ONE + GP) ! + RM = (ONE - GM) / (ONE + GM) ! +! + IF(FP >= ZERO .AND. FM >= ZERO) THEN ! +! + LR = ONE ! + LI = (SQRT(FM) - SQRT(FP)) / Y ! ref. (2) eq. (2.1.14a) +! + ELSE IF(FP <= ZERO .AND. FM >= ZERO) THEN ! +! + LR = ONE - SQRT(-FP) / Y ! ref. (2) eq. (2.1.14b) + LI = SQRT( FM) / Y ! +! + ELSE IF(FP >= ZERO .AND. FM <= ZERO) THEN ! +! + LR = ONE - (GM + ONE) * SQRT(ABS(RM)) / Y ! ref. (2) eq. (2.1.14c) + LI = - (ONE + GP) * SQRT(ABS(RP)) / Y ! +! + ELSE IF(FP <= ZERO .AND. FM <= ZERO) THEN ! +! + LR = ONE - ( (ONE + GM)* SQRT(ABS(RM)) - & ! + (ONE + GP)* SQRT(ABS(RP)) & ! ref. (2) eq. (2.1.14d) + ) / Y ! + LI = ZERO +! + END IF ! +! +! 1D case +! + ELSE IF(DMN == '1D') THEN ! ref. p. 100 +! + IF(X < ONE) THEN ! q < 2 k_F +! + NUM = (ONE + X) * (ONE + X) - U * U ! + DEN = (ONE - X) * (ONE - X) - U * U ! +! ! + LR = HALF * HALF * LOG(ABS(NUM / DEN)) / X ! equation (29.5.16) + LI = ZERO ! +! + ELSE ! q > 2 k_F +! ! + NUM = (ONE + X) * (ONE + X) - U * U ! + DEN = (ONE - X) * (ONE - X) - U * U ! +! ! + LR = HALF * HALF * LOG(ABS(NUM / DEN)) / X ! equation (29.5.21) +! ! Q * V_F - OMEGA_Q + IF( U <= (ONE + X) .AND. Z >= (ONE - X) ) THEN ! < or = OMEGA < or = +! ! Q * V_F + OMEGA_Q + IF(DIFF1 > SMALL) THEN ! + LI = HALF * PI ! equation (29.5.18) + ELSE ! + LI = ZERO ! + END IF ! +! ! + END IF ! +! ! + END IF ! +! + END IF ! +! + 10 RETURN +! + END SUBROUTINE LINDHARD_D + +! +END MODULE LINDHARD_FUNCTION diff --git a/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/basic_functions.f90 b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/basic_functions.f90 new file mode 100644 index 0000000..1888547 --- /dev/null +++ b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/basic_functions.f90 @@ -0,0 +1,240 @@ +! +!--------------------------------------------------------------------- +! +MODULE BASIC_FUNCTIONS +! +! This module contains basic functions of general use: +! +! * Lorentzian +! * Gaussian +! * Numerical Dirac Delta +! * Slater-type and Gaussian-type orbitals +! +! Modules used: ACCURACY_REAL +! PI_ETC +! SQUARE_ROOTS +! REAL_NUMBERS +! FACTORIALS +! + USE ACCURACY_REAL + USE PI_ETC + USE SQUARE_ROOTS + USE REAL_NUMBERS + USE FACTORIALS +! +CONTAINS +! +!--------------------------------------------------------------------- +! + FUNCTION LORENTZIAN(X,X0,GAMMA) +! +! This function computes the Lorentzian function L(x) normalized to unity: +! +! L(x) = 1/pi * gamma / ([x - x0]^2 + gamma^2) +! +! Input parameters: +! +! X : value at which the function is computed +! X0 : center paramameter +! GAMMA : half width at half maximum +! +! Output parameter: +! +! LORENTZIAN : value of the function at X +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Aug 2020 +! +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,X0,GAMMA + REAL (WP) :: LORENTZIAN +! + LORENTZIAN = PI_INV * GAMMA / ( (X-X0)*(X-X0) + GAMMA*GAMMA )! +! + END FUNCTION LORENTZIAN +! +!--------------------------------------------------------------------- +! + FUNCTION GAUSSIAN(X,X0,SIGMA) +! +! This function computes the Gaussian function G(x) normalized to unity: +! +! G(x) = (1/sigma sqrt(2 pi)) * exp[ -1/2 * (x-x0)^2 / sigma^2 ] +! +! +! Input parameters: +! +! X : value at which the function is computed +! X0 : expected value +! SIGMA : variance +! +! Output parameter: +! +! GAUSSIAN : value of the function at X +! +! Note: the half width at half maximum is given by sigma * sqrt[2 Ln(2)] +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Aug 2020 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X,X0,SIGMA + REAL (WP) :: GAUSSIAN +! + REAL (WP) :: EXP +! + GAUSSIAN = PI_INV * EXP(-HALF * (X - X0) * (X - X0) / & ! + (SIGMA * SIGMA) ) / (SIGMA * SQR2) ! +! + END FUNCTION GAUSSIAN +! +!--------------------------------------------------------------------- +! + FUNCTION DELTA(X,I_D,EPSI) +! +! This function computes the numerical Dirac Delta function +! +! +! Input parameters: +! +! X : value at which the function is computed +! I_D : type of numerical approximation used +! +! = 1 : lim [ eps -> 0 ] 1/pi eps/(x^2 + eps^2) +! = 2 : lim [ eps -> 0 ] 1/(pi*x) sin(x/eps) +! = 3 : lim [ eps -> 0 ] 1/2 eps |x|^{eps-1} +! = 4 : lim [ eps -> 0 ] 1/(2*sqrt(pi eps}) e^{- x^2/(4 eps)} +! = 5 : lim [ eps -> 0 ] 1/(2 eps) e^{- |x|/eps) +! = 6 : lim [ eps -> 0 ] 1/eps Ai(x/eps) +! = 7 : lim [ eps -> 0 ] 1/eps J_{1/eps}([x+1]/eps) +! = 8 : lim [ eps -> 0 ] | 1/eps e^{- x^2/eps} Ln(2x/eps) +! EPSI : small eps value +! +! Output parameter: +! +! DELTA : value of the function at X +! +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Aug 2020 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: DELTA + REAL (WP) :: EPSI +! + REAL (WP) :: SIN,ABS,EXP,SQRT +! + INTEGER, INTENT(IN) :: I_D +! + IF(I_D == 1) THEN ! + DELTA = PI_INV * EPSI / ( X * X + EPSI * EPSI) ! + ELSE IF(I_D == 2) THEN ! + DELTA = PI_INV * SIN( X / EPSI) / X ! + ELSE IF(I_D == 3) THEN ! + DELTA = HALF * EPSI * ABS(X)**(EPSI-1) ! + ELSE IF(I_D == 4) THEN ! + DELTA = HALF * EXP( - FOURTH * X * X / EPSI) / & ! + (SQR_PI * SQRT(EPSI)) ! + ELSE IF(I_D == 5) THEN ! + DELTA = HALF * EXP(- ABS(X) / EPSI) /EPSI ! + END IF +! + END FUNCTION DELTA +! +!--------------------------------------------------------------------- +! + FUNCTION STO(N,ALPHA,R) +! +! This function computes Slater-type orbitals normalized to unity:: +! +! STO = A * r^{n-1} * e^{- zeta r} +! +! +! Input parameters: +! +! N : principal quantum number +! ALPHA : function parameter +! R : value at which the function is computed +! +! Output parameter: +! +! STO : value of the function at R +! +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Aug 2020 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: ALPHA,R + REAL (WP) :: STO + REAL (WP) :: A,TWOZ +! + REAL (WP) :: SQRT,EXP +! + INTEGER, INTENT(IN) :: N +! + TWOZ = TWO * ALPHA ! + A = TWOZ**N * SQRT(TWOZ / FAC(2*N)) ! + STO = A * R**(N-1) * EXP(-ALPHA * R) ! normalisation constant +! + END FUNCTION STO +! +!--------------------------------------------------------------------- +! + FUNCTION GTO(N,ALPHA,R) +! +! This function computes Gaussian-type orbitals normalized to unity:: +! +! GTO = A * r^{n-1} * e^{- zeta r^2} +! +! +! Input parameters: +! +! N : principal quantum number +! ALPHA : function parameter +! R : value at which the function is computed +! +! Output parameter: +! +! GTO : value of the function at R +! +! +! +! Author : D. Sébilleau +! +! Last modified : 5 Aug 2020 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: ALPHA,R + REAL (WP) :: GTO + REAL (WP) :: A,TWOZ,NN + REAL (WP) :: GAMMA +! + REAL (WP) :: SQRT,EXP +! + INTEGER, INTENT(IN) :: N +! + TWOZ = TWO * ALPHA ! + NN = N + HALF ! + GAMMA = SQR_PI * FAC(2*N) / (FOUR**N * FAC(N)) ! + A = SQRT(TWO * TWOZ**NN / GAMMA) ! normalisation constant + GTO = A * R**(N-1) * EXP(-ALPHA * R * R) ! +! + END FUNCTION GTO +! +END MODULE BASIC_FUNCTIONS diff --git a/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/bessel.f90 b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/bessel.f90 new file mode 100644 index 0000000..88b645f --- /dev/null +++ b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/bessel.f90 @@ -0,0 +1,932 @@ +! +!======================================================================= +! +MODULE BESSEL +! +! This module provides the standard Bessel functions and the +! exponential integral +! +! It contains the following functions: +! +! * FUNCTION BESSJ0(X) --> J_0(X) +! * FUNCTION BESSJ1(X) --> J_1(X) +! * FUNCTION BESSY0(X) --> Y_0(X) +! * FUNCTION BESSY1(X) --> Y_1(X) +! * FUNCTION BESSI0(X) --> I_0(X) +! * FUNCTION BESSI1(X) --> I_1(X) +! * FUNCTION BESSK0(X) --> K_0(X) +! * FUNCTION BESSK1(X) --> K_1(X) +! * FUNCTION BESSJ(N,X) --> J_N(x) +! * FUNCTION BESSY(N,X) --> Y_N(x) +! * FUNCTION BESSK(N,X) --> K_N(x) +! * FUNCTION BESSI(N,X) --> I_N(x) +! * FUNCTION EXPINT(N,X) --> E_N(X) +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + FUNCTION BESSJ0(X) +! +! This function calculates the first kind Bessel function of order 0 +! J0(x), for any real number x. The polynomial approximation by +! a series of Chebyshev polynomials is used for 0 < X < 8 and 0 < 8/X < 1 +! +! References: +! +! M. Abramowitz, I.A. Stegun, Handbook of MathematicaL Functions, 1965. +! C.W. Clenshaw, National Physical Laboratory Mathematical Tables, +! Vol.5, 1962. +! +! Authors: From Numath Library by Tuan Dang Trong. F90 release 1.0 By J-P Moreau +! +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: BESSJ0 + REAL (WP) :: AX,Y,FR,FS,Z,XX,FP,FQ + REAL (WP) :: P1,P2,P3,P4,P5 + REAL (WP) :: R1,R2,R3,R4,R5,R6 + REAL (WP) :: Q1,Q2,Q3,Q4,Q5 + REAL (WP) :: S1,S2,S3,S4,S5,S6 +! + REAL (WP) :: DABS,DSQRT,DCOS,DSIN +! + DATA P1,P2,P3,P4,P5 / 1.0E0_WP, & + -0.1098628627E-2_WP, 0.2734510407E-4_WP, & + -0.2073370639E-5_WP, 0.2093887211E-6_WP / + DATA Q1,Q2,Q3,Q4,Q5 /-0.1562499995E-1_WP, 0.1430488765E-3_WP, & + -0.6911147651E-5_WP, 0.7621095161E-6_WP, & + -0.9349451520E-7_WP / + DATA R1,R2,R3,R4,R5,R6 / 57568490574.E0_WP,-13362590354.E0_WP, & + 651619640.7E0_WP, -11214424.18E0_WP, & + 77392.33017E0_WP, -184.9052456E0_WP / + DATA S1,S2,S3,S4,S5,S6 / 57568490411.E0_WP, 1029532985.E0_WP, & + 9494680.718E0_WP, 59272.64853E0_WP, & + 267.8532712E0_WP, 1.0E0_WP / +! + IF(X == 0.E0_WP) GO TO 1 ! +! + AX = DABS (X) ! +! + IF (AX < 8.0E0_WP) THEN ! + Y = X*X + FR = R1 + Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6)))) ! + FS = S1 + Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*S6)))) ! + BESSJ0 = FR/FS ! + ELSE ! + Z = 8.E0_WP/AX ! + Y = Z*Z ! + XX = AX - 0.785398164E0_WP ! + FP = P1 + Y*(P2+Y*(P3+Y*(P4+Y*P5))) ! + FQ = Q1 + Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5))) ! + BESSJ0 = DSQRT(0.636619772E0_WP/AX) * & ! + (FP*DCOS(XX)-Z*FQ*DSIN(XX)) ! + END IF +! + RETURN +! + 1 BESSJ0 = 1.E0_WP ! +! + RETURN +! + END FUNCTION BESSJ0 +! +!======================================================================= +! + FUNCTION BESSJ1(X) +! +! This function calculates the first kind Bessel function of order 1 +! J1(x), for any real number x. The polynomial approximation by +! a series of Chebyshev polynomials is used for 0 < X < 8 and 0 < 8/X < 1 +! +! References: +! +! M. Abramowitz, I.A. Stegun, Handbook of MathematicaL Functions, 1965. +! C.W. Clenshaw, National Physical Laboratory Mathematical Tables, +! Vol.5, 1962. +! +! Authors: From Numath Library by Tuan Dang Trong. F90 release 1.0 By J-P Moreau +! +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: BESSJ1 + REAL (WP) :: AX,Y,FR,FS,Z,XX,FP,FQ + REAL (WP) :: P1,P2,P3,P4,P5,P6 + REAL (WP) :: R1,R2,R3,R4,R5,R6 + REAL (WP) :: Q1,Q2,Q3,Q4,Q5 + REAL (WP) :: S1,S2,S3,S4,S5,S6 +! + REAL (WP) :: SIGN,DSQRT,DCOS,DSIN,DABS +! + DATA P1,P2,P3,P4,P5,P6 /1.0E0_WP, & + 0.183105E-2_WP, -0.3516396496E-4_WP, & + 0.2457520174E-5_WP, -0.240337019E-6_WP, & + 0.636619772E0_WP / + DATA Q1,Q2,Q3,Q4,Q5 /0.04687499995E0_WP,-0.2002690873E-3_WP, & + 0.8449199096E-5_WP,-0.88228987E-6_WP, & + 0.105787412E-6_WP / + DATA R1,R2,R3,R4,R5,R6 /72362614232.E0_WP, -7895059235.E0_WP, & + 242396853.1E0_WP, -2972611.439E0_WP, & + 15704.48260E0_WP, -30.16036606E0_WP / + DATA S1,S2,S3,S4,S5,S6 /144725228442.E0_WP, 2300535178.E0_WP, & + 18583304.74E0_WP, 99447.43394E0_WP, & + 376.9991397E0_WP, 1.0E0_WP / +! + AX = DABS(X) ! +! + IF (AX < 8.0E0_WP) THEN ! +! + Y = X*X ! + FR = R1 + Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6)))) ! + FS = S1 + Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*S6)))) ! + BESSJ1 = X*(FR/FS) ! + ELSE ! + Z = 8.0E0_WP / AX ! + Y = Z*Z ! + XX = AX - 2.35619491E0_WP ! + FP = P1 + Y*(P2+Y*(P3+Y*(P4+Y*P5))) ! + FQ = Q1 + Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5))) ! + BESSJ1 = DSQRT(P6/AX)*(DCOS(XX)*FP-Z*DSIN(XX)*FQ)*SIGN(S6,X)! + END IF ! +! + END FUNCTION BESSJ1 +! +!======================================================================= +! + FUNCTION BESSY0(X) +! +! This function calculates the second kind Bessel function of order 0 +! Y0(x), for any real number x. The polynomial approximation by +! a series of Chebyshev polynomials is used for 0 < X < 8 and 0 < 8/X < 1 +! +! References: +! +! M. Abramowitz, I.A. Stegun, Handbook of MathematicaL Functions, 1965. +! C.W. Clenshaw, National Physical Laboratory Mathematical Tables, +! Vol.5, 1962. +! +! Authors: From Numath Library by Tuan Dang Trong. F90 release 1.0 By J-P Moreau +! +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: BESSY0 + REAL (WP) :: AX,Y,FR,FS,Z,XX,FP,FQ + REAL (WP) :: P1,P2,P3,P4,P5 + REAL (WP) :: R1,R2,R3,R4,R5,R6 + REAL (WP) :: Q1,Q2,Q3,Q4,Q5 + REAL (WP) :: S1,S2,S3,S4,S5,S6 +! + REAL (WP) :: DLOG,DSQRT,DCOS,DSIN +! + DATA P1,P2,P3,P4,P5 / 1.0E0_WP, & + -0.1098628627E-2_WP, 0.2734510407E-4_WP, & + -0.2073370639E-5_WP, 0.2093887211E-6_WP / + DATA Q1,Q2,Q3,Q4,Q5 / -0.1562499995E-1_WP, 0.1430488765E-3_WP, & + -0.6911147651E-5_WP, 0.7621095161E-6_WP, & + -0.9349451520E-7_WP / + DATA R1,R2,R3,R4,R5,R6 / -2957821389.E0_WP, 7062834065.E0_WP, & + -512359803.6E0_WP, 10879881.29E0_WP, & + -86327.92757E0_WP, 228.4622733E0_WP / + DATA S1,S2,S3,S4,S5,S6 / 40076544269.E0_WP, 745249964.8E0_WP, & + 7189466.438E0_WP, 47447.26470E0_WP, & + 226.1030244E0_WP, 1.0E0_WP / +! + IF (X == 0.0E0_WP) THEN ! + BESSY0 = -1.0E30_WP ! + RETURN ! + END IF ! +! + IF (X < 8.0E0_WP) THEN ! + Y = X*X ! + FR = R1 + Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6)))) ! + FS = S1 + Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*S6)))) ! + BESSY0 = FR/FS + 0.636619772E0_WP*BESSJ0(X)*DLOG(X) ! + ELSE ! + Z = 8.0E0_WP/X ! + Y = Z*Z ! + XX = X - 0.785398164E0_WP ! + FP = P1 + Y*(P2+Y*(P3+Y*(P4+Y*P5))) ! + FQ = Q1 + Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5))) ! + BESSY0 = DSQRT(0.636619772E0_WP/X) * & ! + (FP*DSIN(XX)+Z*FQ*DCOS(XX)) ! + END IF +! + RETURN +! + END FUNCTION BESSY0 +! +!======================================================================= +! + FUNCTION BESSY1(X) +! +! This function calculates the second kind Bessel function of order 1 +! Y1(x), for any real number x. The polynomial approximation by +! a series of Chebyshev polynomials is used for 0 < X < 8 and 0 < 8/X < 1 +! +! References: +! +! M. Abramowitz, I.A. Stegun, Handbook of MathematicaL Functions, 1965. +! C.W. Clenshaw, National Physical Laboratory Mathematical Tables, +! Vol.5, 1962. +! +! Authors: From Numath Library by Tuan Dang Trong. F90 release 1.0 By J-P Moreau +! +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: BESSY1 + REAL (WP) :: AX,Y,FR,FS,Z,XX,FP,FQ + REAL (WP) :: P1,P2,P3,P4,P5 + REAL (WP) :: R1,R2,R3,R4,R5,R6 + REAL (WP) :: Q1,Q2,Q3,Q4,Q5 + REAL (WP) :: S1,S2,S3,S4,S5,S6,S7 +! + REAL (WP) :: DLOG,DSQRT,DCOS,DSIN +! + DATA P1,P2,P3,P4,P5 / 1.0E0_WP, & + 0.183105E-2_WP, -0.3516396496E-4_WP, & + 0.2457520174E-5_WP, -0.240337019E-6_WP / + DATA Q1,Q2,Q3,Q4,Q5 / 0.04687499995E0_WP, -0.2002690873E-3_WP, & + 0.8449199096E-5_WP, -0.88228987E-6_WP, & + 0.105787412E-6_WP / + DATA R1,R2,R3,R4,R5,R6 / -0.4900604943E13_WP, 0.1275274390E13_WP, & + -0.5153438139E11_WP, 0.7349264551E9_WP, & + -0.4237922726E7_WP, 0.8511937935E4_WP / + DATA S1,S2,S3,S4,S5,S6,S7 / 0.2499580570E14_WP, 0.4244419664E12_WP, & + 0.3733650367E10_WP, 0.2245904002E8_WP, & + 0.1020426050E6_WP, 0.3549632885E3_WP, & + 1.0E0_WP / +! + IF (X == 0.0E0_WP) THEN ! + BESSY1 = -1.E30_WP ! + RETURN ! + END IF ! +! + IF (X < 8.0E0_WP) THEN ! + Y = X*X ! + FR = R1 + Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6)))) ! + FS = S1 + Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*(S6+Y*S7))))) ! + BESSY1 = X*(FR/FS)+0.636619772E0_WP*(BESSJ1(X)*DLOG(X)-1./X)! + ELSE ! + Z = 8.0E0_WP/X ! + Y = Z*Z ! + XX = X - 2.356194491E0_WP ! + FP = P1 + Y*(P2+Y*(P3+Y*(P4+Y*P5))) ! + FQ = Q1 + Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5))) ! + BESSY1 = DSQRT(0.636619772E0_WP/X) * & ! + (DSIN(XX)*FP+Z*DCOS(XX)*FQ) ! + END IF +! + RETURN +! + END FUNCTION BESSY1 +! +!======================================================================= +! + FUNCTION BESSI0(X) +! +! This function calculates the first kind modified Bessel function of order 0 +! Y1(x), for any real number x. The polynomial approximation by +! a series of Chebyshev polynomials is used for 0 < X < 8 and 0 < 8/X < 1 +! +! References: +! +! M. Abramowitz, I.A. Stegun, Handbook of MathematicaL Functions, 1965. +! C.W. Clenshaw, National Physical Laboratory Mathematical Tables, +! Vol.5, 1962. +! +! Authors: From Numath Library by Tuan Dang Trong. F90 release 1.0 By J-P Moreau +! +! +! Input parameters: +! +! * X : argument of the Bessel function I0 +! +! +! Output : +! +! * BESSI0 : I0(x) +! +! +! +! Last modified : 5 Jun 2020 +! + IMPLICIT NONE +! + REAL (WP) :: BESSI0,X,Y,AX + REAL (WP) :: P1,P2,P3,P4,P5,P6,P7 + REAL (WP) :: Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9 + REAL (WP) :: CMP +! + REAL (WP) :: DABS,DEXP,DSQRT +! + DATA P1,P2,P3,P4,P5,P6,P7 / 1.0E0_WP, 3.5156229E0_WP, & ! + 3.0899424E0_WP, 1.2067492E0_WP, & ! + 0.2659732E0_WP, 0.360768E-1_WP, & ! + 0.45813E-02_WP / ! + DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9 / 0.39894228E0_WP, & ! + 0.1328592E-1_WP,0.225319E-02_WP, & ! + -0.157565E-02_WP,0.916281E-02_WP, & ! + -0.2057706E-1_WP,0.2635537E-1_WP, & ! + -0.1647633E-1_WP,0.392377E-02_WP / ! +! + CMP = 3.750E0_WP ! +! + IF (DABS(X) < CMP) THEN ! + Y = (X/CMP)**2 ! + BESSI0 = P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7))))) ! + ELSE ! + AX = DABS(X) ! + Y = CMP/AX ! + BESSI0 = (DEXP(AX)/DSQRT(AX))*(Q1+Y*(Q2+Y*(Q3+Y*(Q4 & ! + +Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))) ! + END IF ! +! + END FUNCTION BESSI0 +! +!======================================================================= +! + FUNCTION BESSI1(X) +! +! This function calculates the first kind modified Bessel function of order 1 +! Y1(x), for any real number x. The polynomial approximation by +! a series of Chebyshev polynomials is used for 0 < X < 8 and 0 < 8/X < 1 +! +! References: +! +! M. Abramowitz, I.A. Stegun, Handbook of MathematicaL Functions, 1965. +! C.W. Clenshaw, National Physical Laboratory Mathematical Tables, +! Vol.5, 1962. +! +! Authors: From Numath Library by Tuan Dang Trong. F90 release 1.0 By J-P Moreau +! +! +! Input parameters: +! +! * X : argument of the Bessel function I1 +! +! +! Output : +! +! * BESSI1 : I1(x) +! +! +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO +! + IMPLICIT NONE +! + REAL (WP) :: BESSI1,X,Y,AX + REAL (WP) :: P1,P2,P3,P4,P5,P6,P7 + REAL (WP) :: Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9 + REAL (WP) :: CMP +! + REAL (WP) :: DABS,DEXP,DSQRT +! + DATA P1,P2,P3,P4,P5,P6,P7 / 0.5E0_WP, 0.87890594E0_WP, & ! + 0.51498869E0_WP, 0.15084934E0_WP, & ! + 0.2658733E-1_WP, 0.301532E-02_WP, & ! + 0.32411E-003_WP / ! + DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9 / 0.39894228E0_WP, & ! + -0.3988024E-1_WP, -0.362018E-02_WP, & ! + 0.163801E-02_WP, -0.1031555E-1_WP, & ! + 0.2282967E-1_WP, -0.2895312E-1_WP, & ! + 0.1787654E-1_WP, -0.420059E-02_WP / ! +! + CMP = 3.750E0_WP ! +! + IF (DABS(X) < CMP) THEN ! polynomial fit + Y=(X/CMP)**2 ! + BESSI1=X*(P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7)))))) ! + ELSE ! + AX=DABS(X) ! + Y=CMP/AX ! + BESSI1=(DEXP(AX)/DSQRT(AX))*(Q1+Y*(Q2+Y*(Q3+Y*(Q4+ &! + Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))) ! + IF(X < ZERO) BESSI1 = -BESSI1 ! + END IF ! +! + END FUNCTION BESSI1 +! +!======================================================================= +! + FUNCTION BESSK0(X) +! +! This function calculates the third kind modified Bessel function of order 0 +! Y1(x), for any real number x. The polynomial approximation by +! a series of Chebyshev polynomials is used for 0 < X < 8 and 0 < 8/X < 1 +! +! References: +! +! M. Abramowitz, I.A. Stegun, Handbook of MathematicaL Functions, 1965. +! C.W. Clenshaw, National Physical Laboratory Mathematical Tables, +! Vol.5, 1962. +! +! Authors: From Numath Library by Tuan Dang Trong. F90 release 1.0 By J-P Moreau +! +! +! Input parameters: +! +! * X : argument of the Bessel function K0 (X > 0) +! +! +! Output : +! +! * BESSK0 : K0(x) +! +! +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO,FOUR +! + IMPLICIT NONE +! + REAL (WP) :: BESSK0,X,Y + REAL (WP) :: P1,P2,P3,P4,P5,P6,P7 + REAL (WP) :: Q1,Q2,Q3,Q4,Q5,Q6,Q7 +! + REAL (WP) :: DLOG,DEXP,DSQRT +! + DATA P1,P2,P3,P4,P5,P6,P7 / -0.57721566E0_WP,0.42278420E0_WP,&! + 0.23069756E0_WP,0.3488590E-1_WP,&! + 0.262698E-02_WP,0.10750E-003_WP,&! + 0.74E-5_WP / ! + DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7/1.25331414E0_WP,-0.7832358E-1_WP, &! + 0.2189568E-1_WP,-0.1062446E-1_WP, &! + 0.587872E-02_WP,-0.251540E-02_WP, &! + 0.53208E-003_WP / ! +! + IF (X <= TWO) THEN ! polynomial fit + Y=X*X/FOUR ! + BESSK0=(-DLOG(X/TWO)*BESSI0(X))+(P1+Y*(P2+Y*(P3+ &! + Y*(P4+Y*(P5+Y*(P6+Y*P7)))))) ! + ELSE ! + Y=(TWO/X) ! + BESSK0=(DEXP(-X)/DSQRT(X))*(Q1+Y*(Q2+Y*(Q3+ &! + Y*(Q4+Y*(Q5+Y*(Q6+Y*Q7)))))) ! + END IF ! +! + END FUNCTION BESSK0 +! +!======================================================================= +! + FUNCTION BESSK1(X) +! +! This function calculates the third kind modified Bessel function of order 1 +! Y1(x), for any real number x. The polynomial approximation by +! a series of Chebyshev polynomials is used for 0 < X < 8 and 0 < 8/X < 1 +! +! References: +! +! M. Abramowitz, I.A. Stegun, Handbook of MathematicaL Functions, 1965. +! C.W. Clenshaw, National Physical Laboratory Mathematical Tables, +! Vol.5, 1962. +! +! Authors: From Numath Library by Tuan Dang Trong. F90 release 1.0 By J-P Moreau +! +! +! Input parameters: +! +! * X : argument of the Bessel function K1 +! +! +! Output : +! +! * BESSK1 : K1(x) +! +! +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR +! + IMPLICIT NONE +! + REAL (WP) :: BESSK1,X,Y + REAL (WP) :: P1,P2,P3,P4,P5,P6,P7 + REAL (WP) :: Q1,Q2,Q3,Q4,Q5,Q6,Q7 +! + REAL (WP) :: DLOG,DEXP,DSQRT +! + DATA P1,P2,P3,P4,P5,P6,P7 / 1.0E0_WP, 0.15443144E0_WP,&! + -0.67278579E0_WP,-0.18156897E0_WP,&! + -0.1919402E-1_WP,-0.110404E-02_WP,&! + -0.4686E-4_WP / ! + DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7 / 1.25331414E0_WP, 0.23498619E0_WP,&! + -0.3655620E-1_WP, 0.1504268E-1_WP,&! + -0.780353E-02_WP, 0.325614E-02_WP,&! + -0.68245E-003_WP / ! +! + IF (X <= TWO) THEN ! polynomial fit + Y=X*X/FOUR ! + BESSK1=(DLOG(X/TWO)*BESSI1(X))+(ONE/X)*(P1+Y*(P2+ &! + Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7)))))) ! + ELSE ! + Y=TWO/X ! + BESSK1=(DEXP(-X)/DSQRT(X))*(Q1+Y*(Q2+Y*(Q3+ &! + Y*(Q4+Y*(Q5+Y*(Q6+Y*Q7)))))) ! + END IF ! +! + END FUNCTION BESSK1 +! +!======================================================================= +! + FUNCTION BESSJ (N,X) + +! This subroutine calculates the first kind modified Bessel function +! of integer order N, for any REAL X. We use here the classical +! recursion formula, when X > N. For X < N, the Miller's algorithm +! is used to avoid overflows. +! +! References: +! +! M. Abramowitz, I.A. Stegun, Handbook of MathematicaL Functions, 1965. +! C.W. Clenshaw, National Physical Laboratory Mathematical Tables, +! Vol.5, 1962. +! +! Authors: From Numath Library by Tuan Dang Trong. F90 release 1.0 By J-P Moreau +! +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: BESSJ,TOX,BJM,BJ,BJP,SUM +! + REAL (WP) :: DFLOAT,DSQRT,DABS +! + REAL*8, PARAMETER :: BIGNO = 1.E10_WP, BIGNI = 1.E-10_WP +! + INTEGER :: M,N,J,JSUM +! + INTEGER :: INT +! + INTEGER, PARAMETER :: IACC = 40 +! + IF (N == 0) THEN ! + BESSJ = BESSJ0(X) ! + RETURN ! + END IF ! +! + IF (N == 1) THEN ! + BESSJ = BESSJ1(X) ! + RETURN ! + END IF ! +! + IF (X == 0.0E0_WP) THEN ! + BESSJ = 0.0E0_WP ! + RETURN ! + END IF ! +! + TOX = 2.0E0_WP/X ! + IF (X > DFLOAT(N)) THEN ! +! + BJM = BESSJ0(X) ! + BJ = BESSJ1(X) ! +! + DO J = 1,N-1 ! + BJP = J*TOX*BJ-BJM ! + BJM = BJ ! + BJ = BJP ! + END DO ! + BESSJ = BJ ! +! + ELSE +! + M = 2*((N+INT(DSQRT(DFLOAT(IACC*N))))/2) ! + BESSJ = 0.0E0_WP ! + JSUM = 0 ! + SUM = 0.0E0_WP ! + BJP = 0.0E0_WP ! + BJ = 1.0E0_WP ! +! + DO J = M,1,-1 ! + BJM = J*TOX*BJ-BJP ! + BJP = BJ ! + BJ = BJM ! + IF (DABS(BJ) > BIGNO) THEN ! + BJ = BJ*BIGNI ! + BJP = BJP*BIGNI ! + BESSJ = BESSJ*BIGNI ! + SUM = SUM*BIGNI ! + END IF ! + IF (JSUM /= 0) SUM = SUM+BJ ! + JSUM = 1-JSUM ! + IF (J.EQ.N) BESSJ = BJP ! + END DO +! + SUM = 2.0E0_WP *SUM-BJ ! + BESSJ = BESSJ/SUM ! +! + END IF ! +! + RETURN ! +! + END FUNCTION BESSJ +! +!======================================================================= +! + FUNCTION BESSY (N,X) +! ------------------------------------------------------------------ +! +! This subroutine calculates the second kind Bessel Function of +! integer order N, for any real X. We use here the classical +! recursive formula. +! ------------------------------------------------------------------ +! +! References: +! +! M. Abramowitz, I.A. Stegun, Handbook of MathematicaL Functions, 1965. +! C.W. Clenshaw, National Physical Laboratory Mathematical Tables, +! Vol.5, 1962. +! +! Authors: From Numath Library by Tuan Dang Trong. F90 release 1.0 By J-P Moreau +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: BESSY,TOX,BY,BYM,BYP +! + INTEGER :: N,J +! + IF (N == 0) THEN ! + BESSY = BESSY0(X) ! + RETURN ! + END IF ! +! + IF (N == 1) THEN ! + BESSY = BESSY1(X) ! + RETURN ! + END IF ! +! + IF (X == 0.0E0_WP) THEN ! + BESSY = -1.E30_WP ! + RETURN ! + END IF ! +! + TOX = 2.0E0_WP/X ! + BY = BESSY1(X) ! + BYM = BESSY0(X) ! +! + DO J = 1,N-1 ! + BYP = J*TOX*BY-BYM ! + BYM = BY ! + BY = BYP ! + END DO ! +! + BESSY = BY ! +! + RETURN ! +! + END FUNCTION BESSY +! +!======================================================================= +! + FUNCTION BESSK(N,X) +! +! This function computes the modified Bessel function Kn(x) for +! any real x positive and n >= 2. Taken from "Numerical Recipes" +! +! +! Input parameters: +! +! * N : order of the Bessel function Kn +! * X : argument of the Bessel function Kn +! +! +! Output : +! +! * BESSK : Kn(x) +! +! +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : TWO +! + IMPLICIT NONE +! + INTEGER :: N,J,LOGF +! + REAL (WP) :: BESSK,X + REAL (WP) :: BK,BKM,BKP,TOX +! + LOGF=6 ! +! + IF(N < 2) THEN ! + WRITE(LOGF,10) ! + STOP ! + ENDIF ! +! + TOX=TWO/X ! upward + BKM=BESSK0(X) ! recurrence + BK=BESSK1(X) ! for all x +! + DO J=1,N-1 ! + BKP=BKM+J*TOX*BK ! + BKM=BK ! + BK=BKP ! + END DO ! +! + BESSK=BK ! +! +! Format +! + 10 FORMAT(5X,'<<<<< Bad argument N in BESSK >>>>>',//) +! + END FUNCTION BESSK +! +!======================================================================= +! + FUNCTION BESSI(N,X) +! +! This function computes the modified Bessel function Kn(x) for +! any real x positive and n >=2. Taken from "Numerical Recipes" +! +! +! Input parameters: +! +! * N : order of the Bessel function In +! * X : argument of the Bessel function In +! +! +! Output : +! +! * BESSK : In(x) +! +! +! +! Last modified : 5 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO +! + IMPLICIT NONE +! + INTEGER :: N,IACC,J,M,K,LOGF +! + INTEGER :: INT +! + REAL (WP) :: BESSI,X,BIGNO,BIGNI + REAL (WP) :: BI,BIM,BIP,TOX +! + REAL (WP) :: DABS,DSQRT,DFLOAT +! + PARAMETER(IACC=40,BIGNO=1.0E10_WP,BIGNI=1.0E10_WP) ! +! + LOGF=6 ! +! + IF(N < 2) THEN ! + WRITE(LOGF,10) ! + STOP ! + ENDIF +! + IF(X == ZERO) THEN ! + BESSI=ZERO ! + ELSE ! + TOX=TWO/DABS(X) ! + BIP=ZERO ! + BI=ONE ! + BESSI=ZERO ! + K=INT(DSQRT(DFLOAT(IACC*N))) ! + M=2*(N+K) ! downward recurrence from even m + DO J=M,1,-1 ! make IACC larger to increase accuracy + BIM=BIP+DFLOAT(J)*TOX*BI ! the downward recurrence. + BIP=BI ! + BI=BIM ! + IF(DABS(BI) > BIGNO) THEN ! renormalize to prevent overflows + BESSI=BESSI*BIGNI ! + BI=BI*BIGNI ! + BIP=BIP*BIGNI ! + END IF ! + IF(J == N) BESSI=BIP ! + END DO ! +! + BESSI=BESSI*BESSI0(X)/BI ! normalize with bessi0 +! + IF(X < ZERO .AND. MOD(N,2) == 1) BESSI=-BESSI ! + END IF ! +! +! Format +! + 10 FORMAT(5X,'<<<<< Bad argument N in BESSI >>>>>',//) +! + END FUNCTION BESSI +! +!======================================================================= +! + FUNCTION EXPINT(N,X) +! +! This function computes the exponential integral function E_n(x) +! . Taken from "Numerical Recipes" +! +! +! Input parameters: +! +! * N : order of the Bessel function In +! * X : argument of the Bessel function In +! +! +! Output : +! +! * EXPINT : expint(x) +! +! +! +! Last modified : 23 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO + USE EULER_CONST, ONLY : EUMAS +! + IMPLICIT NONE +! + INTEGER :: N,MAXIT + INTEGER :: I,II,NM1,LOGF +! + REAL (WP) :: EXPINT,X,EPS,FPMIN + REAL (WP) :: A,B,C,D,DEL,FACT,H,PSI +! + REAL (WP) :: DEXP,DABS,DLOG +! + PARAMETER(MAXIT=100,EPS=1.0E-7_WP,FPMIN=1.0E-30_WP) ! +! + LOGF=6 ! +! + NM1=N-1 ! + IF( N.LT.0 .OR. X.LT.ZERO .OR. & ! + ( X.EQ.ZERO .AND. (N.EQ.0 .OR. N.EQ.1) ) & ! + ) THEN ! + WRITE(LOGF,10) ! + STOP ! + ELSE IF(N == 0) THEN ! + EXPINT=DEXP(-X)/X ! + ELSE IF(X == ZERO) THEN ! + EXPINT=ONE/NM1 ! + ELSE IF(X > ONE) THEN ! + B=X+N ! + C=ONE/FPMIN ! + D=ONE/B ! + H=D ! + DO I=1,MAXIT ! + A=-I*(NM1+I) ! + B=B+TWO ! + D=ONE/(A*D+B) ! + C=B+A/C ! + DEL=C*D ! + H=H*DEL ! + IF(DABS(DEL-ONE) < EPS) THEN ! + EXPINT=H*DEXP(-X) ! + RETURN ! + END IF ! + END DO ! + WRITE(LOGF,20) ! + ELSE ! + IF(NM1 /= 0) THEN ! + EXPINT=ONE/NM1 ! + ELSE ! + EXPINT=-DLOG(X)-EUMAS ! + END IF ! + FACT=ONE ! + DO I=1,MAXIT ! + FACT=-FACT*X/I ! + IF(I /= NM1) THEN ! + DEL=-FACT/(I-NM1) ! + ELSE ! + PSI=-EUMAS ! + DO II=1,NM1 ! + PSI=PSI+ONE/II ! + END DO ! + DEL=FACT*(-DLOG(X)+PSI) ! + END IF ! + EXPINT=EXPINT+DEL ! + IF(DABS(DEL) < DABS(EXPINT)*EPS) RETURN ! + ENDDO ! + WRITE(LOGF,30) ! + END IF ! +! +! Format +! + 10 FORMAT(5X,'<<<<< Bad argument N in EXPINT >>>>>',//) + 20 FORMAT(5X,'<<<<< Continued fraction failed in EXPINT >>>>>',//) + 30 FORMAT(5X,'<<<<< Series failed in EXPINT >>>>>',//) +! + END FUNCTION EXPINT +! +END MODULE BESSEL diff --git a/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/coulomb_log.f90 b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/coulomb_log.f90 new file mode 100644 index 0000000..b87536e --- /dev/null +++ b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/coulomb_log.f90 @@ -0,0 +1,199 @@ +! +!======================================================================= +! +MODULE COULOMB_LOG +! +! This module provides Coulomb logarithms +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + FUNCTION COU_LOG(I_CL,DMN,T,RS) +! +! This function computes the Coulomb logarithm Log(Gamma) +! +! References: (1) F. L. Hinton, chapter 1.5, in "Handbook of Plasma Physics", +! Eds. M. N. Rosenbluth and R. Z. Sagdeev, +! Vol.1 (1983) +! (2) https://ocw.mit.edu/courses/nuclear-engineering/ +! 22-611j-introduction-to-plasma-physics-i-fall-2006/ +! readings/chap3.pdf +! (3) http://homepages.cae.wisc.edu/~callen/chap2.pdf +! (4) https://www.nrl.navy.mil/ppd/sites/www.nrl.navy.mil.ppd/ +! files/pdfs/NRL_FORMULARY_18.pdf +! +! Input parameters: +! +! * I_CL : Switch to compute the Coulomb logarithm +! I_CL = 1 --> using reference (1) +! I_CL = 2 --> using reference (2) +! I_CL = 3 --> using reference (3) +! I_CL = 4 --> using reference (4) +! I_CL = 5 --> using reference (5) +! * DMN : dimension of the system +! DMN = '3D' +! DMN = '2D' +! DMN = '1D' +! * T : system temperature in SI +! * RS : Wigner-Seitz radius (in units of a_0) +! +! +! Output parameters: +! +! * COU_LOG : Coulomb logarithm Log(Gamma) +! +! +! Author : D. Sébilleau +! +! Last modified : 11 Jun 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THIRD + USE CONSTANTS_P1, ONLY : H_BAR,M_E,E,EPS_0,COULOMB,K_B + USE PI_ETC, ONLY : PI_INV + USE SCREENING_VEC, ONLY : DEBYE_VECTOR + USE ENE_CHANGE, ONLY : EV +! + IMPLICIT NONE +! + CHARACTER*2 DMN +! + INTEGER I_CL +! + REAL*8 T,RS + REAL*8 COU_LOG,G,LG + REAL*8 KD_SI,V_TH,T_TH,LD,B0,B1,B2,BM,N0 +! +! Computing the Debye vector +! + CALL DEBYE_VECTOR(DMN,T,RS,KD_SI) ! +! + V_TH=DSQRT(TWO*K_B*T/M_E) ! thermal velocity in 3D + T_TH=K_B*T/EV ! temperature in eV +! + IF(I_CL.EQ.1) THEN ! +! + LD=ONE/KD_SI ! Spitzer value + B0=E*E*THIRD/(K_B*T) ! + COU_LOG=DLOG(LD/B0) ! ref. (2) eq. (5) +! + ELSE IF(I_CL.EQ.2) THEN ! +! + G=DSQRT(EPS_0*T/(N0*E*E))*M_E*V_TH*V_TH/COULOMB ! ref. (2) eq. (3.63) + COU_LOG=DLOG(G) ! +! + ELSE IF(I_CL.EQ.3) THEN ! +! + B1=KD_SI*KD_SI*PI_INV/(12.0E0_WP*N0) ! + B2=H_BAR/(TWO*M_E*V_TH) ! + BM=MAX(B1,B2) ! ref. (3) eq. (2.11) + G=KD_SI/BM ! + COU_LOG=DLOG(G) ! +! + ELSE IF(I_CL.EQ.4) THEN ! +! + LG=23.5E0_WP - DLOG(DSQRT(N0)*(T_TH**(-1.25E0_WP))) - & ! + DSQRT(1.0E-5_WP + (DLOG(T_TH)-TWO)**2 / 16.0E0_WP) ! + COU_LOG=LG ! +! + ELSE IF(I_CL.EQ.5) THEN ! +! + CONTINUE +! + END IF ! +! + END FUNCTION COU_LOG +! +! +!======================================================================= +! + FUNCTION DALI_CL_3D(X) +! +! This function computes Daligault' expression of the Coulomb logarithm +! +! +! Reference: (1) J. Daligault, Phys. Rev. Lett. 119, 045002 (2017) +! +! +! Input parameters: +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! +! Note: It is defined as +! +! / A 3 +! | q +! CL = | ---------------- dq with q the screening vector +! | 2 2 2 s +! / 0 ( q + q ) +! s +! _____________ +! / +! and A ~ k \ / 4 Theta / 3 with Theta the degeneracy parameter +! F \/ +! +! +! We use here the fact that CL writes +! _ _ +! | 2 | A +! | q | +! 1 | s ( 2 2 ) | +! --- | ----------- + Log( q + q ) | +! 2 | 2 2 ( s ) | +! | q + q | +! |_ s _| 0 +! +! +! Author : D. Sébilleau +! +! +! Last modified : 12 Oct 2020 +! +! + USE MATERIAL_PROP, ONLY : RS + USE EXT_FIELDS, ONLY : T +! + USE REAL_NUMBERS, ONLY : ONE,FOUR,HALF,THIRD + USE FERMI_SI, ONLY : KF_SI +! + USE PLASMON_SCALE_P, ONLY : NONID + USE SCREENING_TYPE + USE SCREENING_VEC +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: DALI_CL_3D + REAL (WP) :: TH + REAL (WP) :: KS,DQT2,NUM,DEN + REAL (WP) :: INT_0,INT_A +! + REAL (WP) :: LOG +! + TH = ONE / NONID ! Theta + DQT2 = KF_SI * KF_SI * FOUR * THIRD * TH ! (upper integration bound)^2 +! +! Computing the screening vector +! + IF(SC_TYPE == 'NO') THEN ! + CALL SCREENING_VECTOR('TF','3D',X,RS,T,KS) ! + ELSE ! + CALL SCREENING_VECTOR(SC_TYPE,'3D',X,RS,T,KS) ! in SI + END IF ! +! + NUM = KS * KS ! + DEN = NUM + DQT2 ! +! + INT_0 = HALF * ( ONE + LOG(NUM) ) ! + INT_A = HALF * ( NUM / DEN + LOG(DEN) ) ! +! + DALI_CL_3D = INT_A - INT_0 ! +! + END FUNCTION DALI_CL_3D +! +END MODULE COULOMB_LOG diff --git a/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/digamma.f90 b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/digamma.f90 new file mode 100644 index 0000000..9002522 --- /dev/null +++ b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/digamma.f90 @@ -0,0 +1,144 @@ +! +!======================================================================= +! +MODULE DIGAMMA_FUNCTION +! +! This module provides different subroutine/functions +! to compute the Digamma function, namely: +! +! +! +! 3) SUBROUTINE PSI(X,PS) <-- x real +! +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + SUBROUTINE PSI(X,PS) +! +!*********************************************************************72 +! +! PSI computes the Psi function. +! +! 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: +! +! 22 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. +! +! ============================================ +! +! Purpose: Compute Psi function +! +! Input : X --- Argument of psi(x) +! +! Output: PS --- psi(x) +! +! ============================================ +! +! +! Last modified (DS) : 1 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,TEN, & + HALF,INF + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + INTEGER :: K,N +! + REAL (WP), INTENT(IN) :: X +! + REAL (WP), INTENT(OUT) :: PS +! + REAL (WP) :: A1,A2,A3,A4,A5,A6,A7,A8 + REAL (WP) :: S,X2,XA +! + REAL (WP), PARAMETER :: EL = 0.5772156649015329E+00_WP +! + XA = DABS(X) ! + S = ZERO ! +! + IF(X == INT(X) .AND. X <= ZERO) THEN ! +! + PS = INF ! + RETURN ! +! + ELSE IF(XA == INT(XA)) THEN ! +! + N = INT(XA) ! + DO K = 1, N - 1 ! + S = S + ONE / K ! + END DO ! + PS = - EL + S ! +! + ELSE IF(XA + HALF == INT(XA + HALF)) THEN ! +! + N = INT(XA - HALF) ! + DO K = 1, N ! + S = S + ONE / (TWO * K - ONE) ! + END DO + PS = - EL + TWO * S - 1.386294361119891E+00_WP ! +! + ELSE ! +! + IF(XA < TEN) THEN ! + N = 10 - INT(XA) ! + DO K = 0, N - 1 ! + S = S + ONE / (XA + K) ! + END DO ! + XA = XA + N ! + END IF ! +! + X2 = ONE / (XA * XA) ! + A1 = -0.8333333333333E-01_WP ! + A2 = 0.83333333333333333E-02_WP ! + A3 = -0.39682539682539683E-02_WP ! + A4 = 0.41666666666666667E-02_WP ! + A5 = -0.75757575757575758E-02_WP ! + A6 = 0.21092796092796093E-01_WP ! + A7 = -0.83333333333333333E-01_WP ! + A8 = 0.4432598039215686E+00_WP ! +! + PS = DLOG(XA) - HALF / XA + X2 * ((((((( & ! + A8 * X2 & ! + + A7) * X2 & ! + + A6) * X2 & ! + + A5) * X2 & ! + + A4) * X2 & ! + + A3) * X2 & ! + + A2) * X2 & ! + + A1) ! + PS = PS - S ! +! + END IF ! +! + IF(X < ZERO) THEN ! + PS = PS - PI * DCOS(PI * X) / DSIN(PI * X) - ONE / X ! + END IF ! +! + RETURN ! +! + END SUBROUTINE PSI +! +END MODULE DIGAMMA_FUNCTION diff --git a/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/external_functions.f90 b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/external_functions.f90 new file mode 100644 index 0000000..8dc29ce --- /dev/null +++ b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/external_functions.f90 @@ -0,0 +1,5419 @@ +! +!======================================================================= +! +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 + diff --git a/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/gamma.f90 b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/gamma.f90 new file mode 100644 index 0000000..a8c8ce9 --- /dev/null +++ b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/gamma.f90 @@ -0,0 +1,1739 @@ +! +!======================================================================= +! +MODULE GAMMA_FUNCTION +! +! This module provides different subroutine/functions +! to compute the Gamma function, namely: +! +! +! 1) FUNCTION DLGAMA(X) <-- Log(Gamma(x)); x real +! +! 2) FUNCTION LNGAMMA(X) <-- Log(Gamma(x)); x real +! +! 3) FUNCTION DGAMLN(Z,IERR) <-- Log(Gamma(x)); x real +! +! 4) SUBROUTINE GAMMA(X,GA) <-- Gamma(x); x real +! +! 5) SUBROUTINE CGAMA(X,Y,KF,GR,GI) <-- Gamma(z); z = x + iy +! or Log (Gamma(z)) +! +! 6) SUBROUTINE CGAMMA(MO,Z,W) <-- Gamma(z); z = x + iy +! or Log (Gamma(z)) +! +! 7) FUNCTION ZGAMMA(ARG,LNPFQ) <-- Gamma(z) +! +! 8) SUBROUTINE ZGAM(CARG,CANS,ERREST,MODE) <-- Gamma(z); z = x + iy +! or Log (Gamma(z)) +! or Log (Gamma(z)) +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + 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) : 20 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: DLGAMA +! + REAL (WP), PARAMETER :: SMALL = 1.0E-7_WP + REAL (WP), PARAMETER :: CRIT = 13.0E0_WP + REAL (WP), PARAMETER :: BIG = 1.0E9_WP + REAL (WP), PARAMETER :: TOOBIG = 2.0E36_WP +! + REAL (WP) :: C0,C1,C2,C3,C4,C5,C6,C7 + REAL (WP) :: S1,S2 + REAL (WP) :: XX,SUM1,SUM2 + REAL (WP) :: Y,Z +! +! C0 IS 0.5*LOG(2*PI) +! C1...C7 are the coeffts of the asymptotic expansion of DLGAMA +! + DATA C0,C1,C2,C3,C4,C5,C6,C7/ & + 0.918938533204672742E0_WP , 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 ! +! + 7000 FORMAT(' *** ERROR *** ROUTINE DLGAMA :', & + ' ARGUMENT OUT OF RANGE :',D24.16) +! + END FUNCTION DLGAMA +! +!======================================================================= +! + FUNCTION LNGAMMA(Z) RESULT(LANCZOS) +! +! Uses Lanczos-type approximation to ln(gamma) for z > 0. +! Reference: +! Lanczos, C. 'A precision approximation of the gamma +! function', J. SIAM Numer. Anal., B, 1, 86-96, 1964. +! Accuracy: About 14 significant digits except for small regions +! in the vicinity of 1 and 2. + +! Programmer: Alan Miller +! 1 Creswick Street, Brighton, Vic. 3187, Australia +! e-mail: amiller @ bigpond.net.au +! Latest revision - 14 October 1996 +! +! +! Last modified (DS) : 24 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,SEVEN,HALF +! + IMPLICIT NONE +! + INTEGER :: J +! + REAL (WP), INTENT(IN) :: Z + REAL (WP) :: LANCZOS +! + REAL (WP), PARAMETER :: LNSQRT2PI = 0.9189385332046727E0_WP + REAL (WP), PARAMETER :: SIXPT5 = 6.5E0_WP +! + REAL (WP) :: TMP + +! Local variables + + REAL (WP) :: A(9) = (/ & + 0.9999999999995183E0_WP, & + 676.5203681218835E0_WP, & + -1259.139216722289E0_WP, & + 771.3234287757674E0_WP, & + -176.6150291498386E0_WP, & + 12.50734324009056E0_WP, & + -0.1385710331296526E0_WP, & + 0.9934937113930748E-05_WP, & + 0.1659470187408462E-06_WP & + /) +! + IF(Z <= ZERO) THEN ! + WRITE(6,10) ! + RETURN ! + END IF ! +! + LANCZOS = ZERO ! + TMP = Z + SEVEN ! + DO J = 9, 2, -1 ! + LANCZOS = LANCZOS + A(J) / TMP ! + TMP = TMP - ONE ! + END DO ! + LANCZOS = LANCZOS + A(1) + LANCZOS = LOG(LANCZOS) + LNSQRT2PI - (Z + SIXPT5) + & ! + (Z - HALF) * LOG(Z + SIXPT5) ! +! + RETURN +! +! Format: +! + 10 FORMAT('Error: zero or -ve argument for lngamma') +! + END FUNCTION LNGAMMA +! +!======================================================================= +! + FUNCTION DGAMLN(Z,IERR) +! +!***BEGIN PROLOGUE DGAMLN +!***SUBSIDIARY +!***PURPOSE Compute the logarithm of the Gamma function +!***LIBRARY SLATEC +!***CATEGORY C7A +!***TYPE DOUBLE PRECISION (GAMLN-S, DGAMLN-D) +!***KEYWORDS LOGARITHM OF GAMMA FUNCTION +!***AUTHOR Amos, D. E., (SNL) +!***DESCRIPTION +! +! **** A DOUBLE PRECISION ROUTINE **** +! DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR +! Z>0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES +! GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION +! G(Z+1)=Z*G(Z) FOR Z<=ZMIN. THE FUNCTION WAS MADE AS +! PORTABLE AS POSSIBLE BY COMPUTING ZMIN FROM THE NUMBER OF BASE +! 10 DIGITS IN A WORD, RLN=MAX(-ALOG10(R1MACH(4)),0.5E-18) +! LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY. +! +! SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100 +! VALUES IS USED FOR SPEED OF EXECUTION. +! +! DESCRIPTION OF ARGUMENTS +! +! INPUT Z IS D0UBLE PRECISION +! Z - ARGUMENT, Z>0.0D0 +! +! OUTPUT DGAMLN IS DOUBLE PRECISION +! DGAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0 +! IERR - ERROR FLAG +! IERR=0, NORMAL RETURN, COMPUTATION COMPLETED +! IERR=1, Z<=0.0D0, NO COMPUTATION +! +! +!***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +! BY D. E. AMOS, SAND83-0083, MAY, 1983. +!***ROUTINES CALLED D1MACH, I1MACH +!***REVISION HISTORY (YYMMDD) +! 830501 DATE WRITTEN +! 830501 REVISION DATE from Version 3.2 +! 910415 Prologue converted to Version 4.0 format. (BAB) +! 920128 Category corrected. (WRB) +! 921215 DGAMLN defined for Z negative. (WRB) +!***END PROLOGUE DGAMLN +! +! Last modified (DS) : 25 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,THREE,HALF + USE MACHINE_ACCURACY, ONLY : D1MACH,I1MACH +! + IMPLICIT NONE +! + INTEGER, INTENT(OUT) :: IERR +! + REAL (WP), INTENT(IN) :: Z +! + INTEGER :: I,I1M,K,MZ,NZ +! + REAL (WP) :: DGAMLN + REAL (WP) :: FLN,FZ,RLN,S + REAL (WP) :: CF(22) + REAL (WP) :: GLN(100) + REAL (WP) :: TLG,TRM,TST,T1,WDTOL + REAL (WP) :: ZDMY,ZINC,ZM,ZMIN,ZP,ZSQ +! + REAL (WP), PARAMETER :: CON = 1.83787706640934548356066E0_WP ! Ln(2 pi) +! +! LNGAMMA(N), N = 1,100 +! + DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7), & + GLN(8), GLN(9),GLN(10),GLN(11),GLN(12),GLN(13),GLN(14), & + GLN(15),GLN(16),GLN(17),GLN(18),GLN(19),GLN(20),GLN(21), & + GLN(22) / & + 0.00000000000000000E+00_WP, 0.00000000000000000E+00_WP, & + 6.93147180559945309E-01_WP, 1.79175946922805500E+00_WP, & + 3.17805383034794562E+00_WP, 4.78749174278204599E+00_WP, & + 6.57925121201010100E+00_WP, 8.52516136106541430E+00_WP, & + 1.06046029027452502E+01_WP, 1.28018274800814696E+01_WP, & + 1.51044125730755153E+01_WP, 1.75023078458738858E+01_WP, & + 1.99872144956618861E+01_WP, 2.25521638531234229E+01_WP, & + 2.51912211827386815E+01_WP, 2.78992713838408916E+01_WP, & + 3.06718601060806728E+01_WP, 3.35050734501368889E+01_WP, & + 3.63954452080330536E+01_WP, 3.93398841871994940E+01_WP, & + 4.23356164607534850E+01_WP, 4.53801388984769080E+01_WP / +! + DATA GLN(23),GLN(24),GLN(25),GLN(26),GLN(27),GLN(28), & + GLN(29),GLN(30),GLN(31),GLN(32),GLN(33),GLN(34), & + GLN(35),GLN(36),GLN(37),GLN(38),GLN(39),GLN(40), & + GLN(41),GLN(42),GLN(43),GLN(44) / & + 4.84711813518352239E+01_WP, 5.16066755677643736E+01_WP, & + 5.47847293981123192E+01_WP, 5.80036052229805199E+01_WP, & + 6.12617017610020020E+01_WP, 6.45575386270063311E+01_WP, & + 6.78897431371815350E+01_WP, 7.12570389671680090E+01_WP, & + 7.46582363488301644E+01_WP, 7.80922235533153106E+01_WP, & + 8.15579594561150372E+01_WP, 8.50544670175815174E+01_WP, & + 8.85808275421976788E+01_WP, 9.21361756036870925E+01_WP, & + 9.57196945421432025E+01_WP, 9.93306124547874269E+01_WP, & + 1.02968198614513813E+02_WP, 1.06631760260643459E+02_WP, & + 1.10320639714757395E+02_WP, 1.14034211781461703E+02_WP, & + 1.17771881399745072E+02_WP, 1.21533081515438634E+02_WP / +! + DATA GLN(45),GLN(46),GLN(47),GLN(48),GLN(49),GLN(50), & + GLN(51),GLN(52),GLN(53),GLN(54),GLN(55),GLN(56), & + GLN(57),GLN(58),GLN(59),GLN(60),GLN(61),GLN(62), & + GLN(63),GLN(64),GLN(65),GLN(66) / & + 1.25317271149356895E+02_WP, 1.29123933639127215E+02_WP, & + 1.32952575035616310E+02_WP, 1.36802722637326368E+02_WP, & + 1.40673923648234259E+02_WP, 1.44565743946344886E+02_WP, & + 1.48477766951773032E+02_WP, 1.52409592584497358E+02_WP, & + 1.56360836303078785E+02_WP, 1.60331128216630907E+02_WP, & + 1.64320112263195181E+02_WP, 1.68327445448427652E+02_WP, & + 1.72352797139162802E+02_WP, 1.76395848406997352E+02_WP, & + 1.80456291417543771E+02_WP, 1.84533828861449491E+02_WP, & + 1.88628173423671591E+02_WP, 1.92739047287844902E+02_WP, & + 1.96866181672889994E+02_WP, 2.01009316399281527E+02_WP, & + 2.05168199482641199E+02_WP, 2.09342586752536836E+02_WP / +! + DATA GLN(67),GLN(68),GLN(69),GLN(70),GLN(71),GLN(72), & + GLN(73),GLN(74),GLN(75),GLN(76),GLN(77),GLN(78), & + GLN(79),GLN(80),GLN(81),GLN(82),GLN(83),GLN(84), & + GLN(85),GLN(86),GLN(87),GLN(88) / & + 2.13532241494563261E+02_WP, 2.17736934113954227E+02_WP, & + 2.21956441819130334E+02_WP, 2.26190548323727593E+02_WP, & + 2.30439043565776952E+02_WP, 2.34701723442818268E+02_WP, & + 2.38978389561834323E+02_WP, 2.43268849002982714E+02_WP, & + 2.47572914096186884E+02_WP, 2.51890402209723194E+02_WP, & + 2.56221135550009525E+02_WP, 2.60564940971863209E+02_WP, & + 2.64921649798552801E+02_WP, 2.69291097651019823E+02_WP, & + 2.73673124285693704E+02_WP, 2.78067573440366143E+02_WP, & + 2.82474292687630396E+02_WP, 2.86893133295426994E+02_WP, & + 2.91323950094270308E+02_WP, 2.95766601350760624E+02_WP, & + 3.00220948647014132E+02_WP, 3.04686856765668715E+02_WP / +! + DATA GLN(89),GLN(90),GLN(91),GLN(92),GLN(93), GLN(94), & + GLN(95),GLN(96),GLN(97),GLN(98),GLN(99),GLN(100) / & + 3.09164193580146922E+02_WP, 3.13652829949879062E+02_WP, & + 3.18152639620209327E+02_WP, 3.22663499126726177E+02_WP, & + 3.27185287703775217E+02_WP, 3.31717887196928473E+02_WP, & + 3.36261181979198477E+02_WP, 3.40815058870799018E+02_WP, & + 3.45379407062266854E+02_WP, 3.49954118040770237E+02_WP, & + 3.54539085519440809E+02_WP, 3.59134205369575399E+02_WP / +! +! Coefficients of asymptotic expansion +! + DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8), & + CF(9),CF(10),CF(11),CF(12),CF(13),CF(14),CF(15), & + CF(16),CF(17),CF(18),CF(19),CF(20),CF(21),CF(22) / & + 8.33333333333333333E-02_WP, -2.77777777777777778E-03_WP, & + 7.93650793650793651E-04_WP, -5.95238095238095238E-04_WP, & + 8.41750841750841751E-04_WP, -1.91752691752691753E-03_WP, & + 6.41025641025641026E-03_WP, -2.95506535947712418E-02_WP, & + 1.79644372368830573E-01_WP, -1.39243221690590112E+00_WP, & + 1.34028640441683920E+01_WP, -1.56848284626002017E+02_WP, & + 2.19310333333333333E+03_WP, -3.61087712537249894E+04_WP, & + 6.91472268851313067E+05_WP, -1.52382215394074162E+07_WP, & + 3.82900751391414141E+08_WP, -1.08822660357843911E+10_WP, & + 3.47320283765002252E+11_WP, -1.23696021422692745E+13_WP, & + 4.88788064793079335E+14_WP, -2.13203339609193739E+16_WP / +! +!***First executable statement DGAMLN +! + IERR = 0 ! + IF(Z <= ZERO) GO TO 70 ! + IF(Z > 101.0E0_WP) GO TO 10 ! + NZ = INT(Z) ! + FZ = Z - NZ ! + IF(FZ > ZERO) GO TO 10 ! + IF(NZ > 100) GO TO 10 ! + DGAMLN = GLN(NZ) ! + RETURN ! + 10 CONTINUE ! + WDTOL = D1MACH(4) ! + WDTOL = MAX(WDTOL,0.5E-18_WP) ! + I1M = I1MACH(14) ! + RLN = D1MACH(5) * I1M ! + FLN = MIN(RLN,20.0E0_WP) ! + FLN = MAX(FLN,THREE) ! + FLN = FLN - THREE ! + ZM = 1.8000E0_WP + 0.3875E0_WP * FLN ! + MZ = INT(ZM) + 1 ! + ZMIN = MZ ! + ZDMY = Z ! + ZINC = ZERO ! + IF(Z >= ZMIN) GO TO 20 ! + ZINC = ZMIN - NZ ! + ZDMY = Z + ZINC ! + 20 CONTINUE ! + ZP = ONE / ZDMY ! + T1 = CF(1) * ZP ! + S = T1 ! + IF(ZP < WDTOL) GO TO 40 ! + ZSQ = ZP * ZP ! + TST = T1 * WDTOL ! + DO K = 2,22 ! + ZP = ZP * ZSQ ! + TRM = CF(K) * ZP ! + IF(ABS(TRM) < TST) GO TO 40 ! + S = S + TRM ! + END DO ! + 40 CONTINUE ! + IF(ZINC /= ZERO) GO TO 50 ! + TLG = LOG(Z) ! + DGAMLN = Z * (TLG - ONE) + HALF * (CON - TLG) + S ! + RETURN ! + 50 CONTINUE ! + ZP = ONE ! + NZ = INT(ZINC) ! + DO I = 1,NZ ! + ZP = ZP * (Z + (I - 1)) ! + END DO ! + TLG = LOG(ZDMY) ! + DGAMLN = ZDMY * (TLG - ONE) - LOG(ZP) + HALF * (CON - TLG) + S! + RETURN ! +! + 70 CONTINUE ! + DGAMLN = D1MACH(2) ! + IERR = 1 ! +! + RETURN ! +! + END FUNCTION DGAMLN +! +!======================================================================= +! + SUBROUTINE GAMMA(X,GA) +! +!*********************************************************************72 +! +! GAMMA computes the Gamma function. +! +! 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: +! +! 14 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. +! +! ======================================================== +! +! Purpose: Compute gamma function Gamma(x) +! +! Input : X --- Argument of Gamma(x) +! ( x is not equal to 0,-1,-2,úúú) +! +! Output: GA --- Gamma(x) +! +! ======================================================== +! +! +! Last modified (DS) : 1 Sep 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,INF + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + INTEGER :: K,M,M1 +! + REAL (WP), INTENT(IN) :: X +! + REAL (WP), INTENT(OUT) :: GA +! + REAL (WP) :: G(26) + REAL (WP) :: GR + REAL (WP) :: R,Z +! + SAVE G +! + DATA G / & ! + 1.0E+00_WP , & ! + 0.5772156649015329E+00_WP, & ! + -0.6558780715202538E+00_WP, & ! + -0.420026350340952E-01_WP , & ! + 0.1665386113822915E+00_WP, & ! + -0.421977345555443E-01_WP , & ! + -0.96219715278770E-02_WP , & ! + 0.72189432466630E-02_WP , & ! + -0.11651675918591E-02_WP , & ! + -0.2152416741149E-03_WP , & ! + 0.1280502823882E-03_WP , & ! + -0.201348547807E-04_WP , & ! + -0.12504934821E-05_WP , & ! + 0.11330272320E-05_WP , & ! + -0.2056338417E-06_WP , & ! + 0.61160950E-08_WP , & ! + 0.50020075E-08_WP , & ! + -0.11812746E-08_WP , & ! + 0.1043427E-09_WP , & ! + 0.77823E-11_WP , & ! + -0.36968E-11_WP , & ! + 0.51E-12_WP , & ! + -0.206E-13_WP , & ! + -0.54E-14_WP , & ! + 0.14E-14_WP , & ! + 0.1E-15_WP / +! + IF(X == INT(X)) THEN ! +! + IF(ZERO < X) THEN ! + GA = ONE ! + M1 = INT(X) - 1 ! + DO K = 2, M1 ! + GA = GA * K ! + END DO ! + ELSE ! + GA = INF ! + END IF ! +! + ELSE ! +! + IF(ONE < DABS(X) ) THEN ! + Z = DABS(X) ! + M = INT(Z) ! + R = ONE ! + DO K = 1, M ! + R = R * (Z - K) ! + END DO ! + Z = Z - M ! + ELSE ! + Z = X ! + END IF ! +! + GR = G(26) ! + DO K = 25, 1, -1 ! + GR = GR * Z + G(K) ! + END DO ! + GA = ONE / (GR * Z) +! + IF(ONE < DABS(X)) THEN ! + GA = GA * R ! + IF(X < ZERO) THEN ! + GA = - PI / (X * GA * DSIN(PI * X)) ! + END IF ! + END IF ! +! + END IF ! +! + RETURN ! +! + END SUBROUTINE GAMMA +! +!======================================================================= +! + SUBROUTINE CGAMA(X,Y,KF,GR,GI) +! +! ----------------------------------------------------------- +! +! Purpose: Compute the gamma function G(z) or Ln[G(z)] +! for a complex argument +! +! Input : x --- Real part of z +! y --- Imaginary part of z +! KF --- Function code +! KF=0 for Ln[G(z)] +! KF=1 for G(z) +! +! Output: GR --- Real part of Ln[G(z)] or G(z) +! GI --- Imaginary part of Ln[G(z)] or G(z) +! +! ----------------------------------------------------------- +! +!* REFERENCE: * +!* "Fortran Routines for Computation of Special Functions, * +!* jin.ece.uiuc.edu/routines/routines.html". * +!* * +!* F90 Release By J-P Moreau, Paris. * +!* (www.jpmoreau.fr) * +! +! ----------------------------------------------------------- +! +! +! Last modified (DS) : 24 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,SEVEN,HALF,INF + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: KF + INTEGER :: NA,J,K +! + REAL (WP), INTENT(IN OUT) :: X,Y + REAL (WP), INTENT(OUT) :: GR,GI + REAL (WP) :: A(10) + REAL (WP) :: X1,Y1 + REAL (WP) :: X0,Z1,Z2,TH,TH1,TH2,T + REAL (WP) :: GR1,GI1 + REAL (WP) :: SR,SI,G0,XK +! + DATA A / 8.333333333333333E-02_WP,-2.777777777777778E-03_WP, & + 7.936507936507937E-04_WP,-5.952380952380952E-04_WP, & + 8.417508417508418E-04_WP,-1.917526917526918E-03_WP, & + 6.410256410256410E-03_WP,-2.955065359477124E-02_WP, & + 1.796443723688307E-01_WP,-1.39243221690590E+00_WP / +! + IF(Y == ZERO .AND. X==INT(X) .AND. X <= ZERO) THEN ! +! + GR = INF ! + GI = ZERO ! + RETURN ! +! + ELSE IF(X < ZERO) THEN ! +! + X1 = X ! + Y1 = Y ! + X = - X ! + Y = - Y ! +! + END IF ! +! + X0 = X ! +! + IF(X <= SEVEN) THEN ! +! + NA=INT(7-X) ! + X0=X+NA ! +! + END IF ! + + Z1 = DSQRT(X0 * X0 + Y * Y) ! + TH = DATAN(Y / X0) ! + GR = (X0 - HALF) * DLOG(Z1) - TH * Y - X0 + & ! + HALF * DLOG(TWO * PI) ! + GI = TH * (X0 - HALF) + Y * DLOG(Z1) - Y ! +! + DO K = 1,10 ! + XK = DFLOAT(K) ! + T = Z1**(1 - 2 * K) ! + GR = GR + A(K) * T *DCOS((TWO * XK - ONE) * TH) ! + GI = GI - A(K) * T *DSIN((TWO * XK - ONE) * TH) ! + END DO ! +! + IF(X <= SEVEN) THEN ! +! + GR1 = ZERO ! + GI1 = ZERO ! + DO J = 0,NA-1 ! + GR1 = GR1 + HALF * DLOG((X + J)**2 + Y * Y) ! + GI1 = GI1 + DATAN(Y / (X + J)) ! + END DO ! + GR = GR - GR1 ! + GI = GI - GI1 ! +! + END IF ! +! + IF(X1 < ZERO) THEN ! +! + Z1 = DSQRT(X * X + Y * Y) ! + TH1 = DATAN(Y / X) ! + SR = - DSIN(PI * X) * DCOSH(PI * Y) ! + SI = - DCOS(PI * X) * DSINH(PI * Y) ! + Z2 = DSQRT(SR * SR + SI * SI) ! + TH2 = DATAN(SI / SR) ! + IF(SR < ZERO) TH2 = PI + TH2 ! + GR = DLOG(PI / (Z1 * Z2)) - GR ! + GI = - TH1 - TH2 - GI ! + X = X1 ! + Y = Y1 ! +! + END IF ! +! + IF(KF == 1) THEN ! +! + G0 = DEXP(GR) ! + GR = G0 * DCOS(GI) ! + GI = G0 * DSIN(GI) ! +! + END IF ! + + RETURN ! + + END SUBROUTINE CGAMA +! +!======================================================================= +! + SUBROUTINE CGAMMA(MO,Z,W) +!----------------------------------------------------------------------- +! +! EVALUATION OF THE COMPLEX GAMMA AND LOGGAMMA FUNCTIONS +! +! --------------- +! +! MO IS AN INTEGER, Z A COMPLEX ARGUMENT, AND W A COMPLEX VARIABLE. +! +! W = GAMMA(Z) IF MO = 0 +! W = LN(GAMMA(Z)) OTHERWISE +! +!----------------------------------------------------------------------- +! +! WRITTEN BY ALFRED H. MORRIS, JR. +! NAVAL SURFACE WARFARE CENTER +! DAHLGREN, VIRGINIA +! +! This version, in a subset of Fortran 90, prepared by +! Alan.Miller @ vic.cmis.csiro.au +! http://www.ozemail.com.au/~milleraj +! +! This version is accurate to within 5 in the 14th significant +! decimal digit. +! +!----------------------------------------------------------------------- +! +! +! Last modified (DS) : 20 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + INTEGER, INTENT(IN) :: MO +! + COMPLEX (WP), INTENT(IN) :: Z + COMPLEX (WP), INTENT(OUT) :: W +! +! Local variables +! + COMPLEX (WP) :: ETA,ETA2,SUM +! + REAL (WP), PARAMETER :: C0(12) = (/ & + .833333333333333E-01_WP, & + -.277777777777778E-02_WP, .793650793650794E-03_WP, & + -.595238095238095E-03_WP, .841750841750842E-03_WP, & + -.191752691752692E-02_WP, .641025641025641E-02_WP, & + -.295506535947712E-01_WP, .179644372368831_WP, & + -1.39243221690590_WP, 13.4028640441684_WP, & + -156.848284626002_WP /) +! + REAL (WP), PARAMETER :: PI2 = 6.28318530717959_WP + REAL (WP), PARAMETER :: ALPI = 1.14472988584940_WP + REAL (WP), PARAMETER :: HL2P = .918938533204673_WP +! + REAL (WP) :: A,A1,A2,C,CN,CUT,D,EPS + REAL (WP) :: ET,E2T,H1,H2,S,SN + REAL (WP) :: S1,S2,T,T1,T2,U,U1,U2 + REAL (WP) :: V1,V2,W1,W2,X,Y,Y2 +! + INTEGER :: J,K,L,M,MAX,N,NM1 +!--------------------------- +! ALPI = LOG(PI) +! HL2P = 0.5 * LOG(2*PI) +!--------------------------- + +! ****** MAX and EPS are machine dependent constants. +! MAX is the largest positive integer that may +! be used, and EPS is the smallest real number +! such that 1.0 + EPS > 1.0. + +! MAX = IPMPAR(3) + MAX = HUGE(3) ! + EPS = EPSILON(ONE) ! +! +!--------------------------- +! + X = REAL(Z, KIND=WP) ! + Y = AIMAG(Z) ! + IF(X < ZERO) THEN ! +! +!----------------------------------------------------------------------- +! Case when the real part of Z is negative +!----------------------------------------------------------------------- +! + Y = ABS(Y) ! + T = - PI * Y ! + ET = EXP(T) ! + E2T = ET * ET ! + +! set A1 = (1 + E2T)/2 AND A2 = (1 - E2T)/2 + + A1 = HALF * (ONE + E2T) ! + T2 = T + T ! + IF(T2 >= -0.15E0_WP) THEN ! + A2 = -HALF * REXP(T2) ! + ELSE ! + A2 = HALF * (HALF + (HALF - E2T)) ! + END IF ! +! +! Compute SIN(PI*X) and COS(PI*X) +! + IF(ABS(X) >= MIN(REAL(MAX),ONE/EPS)) GO TO 70 ! + K = ABS(X) ! + U = X + K ! + K = MOD(K,2) ! + IF(U <= -HALF) THEN ! + U = HALF + (HALF + U) ! + K = K + 1 ! + END IF ! + U = PI * U ! + SN = SIN(U) ! + CN = COS(U) ! + IF(K == 1) THEN ! + SN = - SN ! + CN = - CN ! + END IF ! +! +! Set H1 + H2*I to PI/SIN(PI*Z) or LOG(PI/SIN(PI*Z)) +! + A1 = SN * A1 ! + A2 = CN * A2 ! + A = A1 * A1 + A2 * A2 ! + IF(A == ZERO) GO TO 70 ! + IF(MO == 0) THEN ! + H1 = A1 / A ! + H2 = -A2 / A ! + C = PI * ET ! + H1 = C * H1 ! + H2 = C * H2 ! + ELSE ! + H1 = (ALPI+T) - HALF * LOG(A) ! + H2 = - ATAN2(A2,A1) ! + END IF ! + IF(AIMAG(Z) >= ZERO) THEN ! + X = ONE - X ! + Y = - Y ! + ELSE ! + H2 = - H2 ! + X = ONE - X ! + END IF ! +! + END IF ! +! +!----------------------------------------------------------------------- +! Case when the real part of Z is nonnegative +!----------------------------------------------------------------------- +! + W1 = ZERO ! + W2 = ZERO ! + N = 0 ! + T = X ! + Y2 = Y * Y ! + A = T * T + Y2 ! + CUT = 36.0E0_WP ! + IF(EPS > 1.E-8_WP) CUT = 16.0E0_WP ! + IF(A < CUT) THEN ! + IF(A == ZERO) GO TO 70 ! + 10 N = N + 1 ! + T = T + ONE ! + A = T * T + Y2 ! + IF(A < CUT) GO TO 10 ! +! +! Let S1 + S2*I be the product of the terms (Z+J)/(Z+N) +! + U1 = (X * T + Y2) / A ! + U2 = Y / A ! + S1 = U1 ! + S2 = N * U2 ! + IF(N >= 2) THEN ! + U = T / A ! + NM1 = N - 1 ! + DO J = 1, NM1 ! + V1 = U1 + J * U ! + V2 = (N - J) * U2 ! + C = S1 * V1 - S2 * V2 ! + D = S1 * V2 + S2 * V1 ! + S1 = C ! + S2 = D ! + END DO ! + END IF ! +! +! Set W1 + W2*I = LOG(S1 + S2*I) when MO is nonzero +! + S = S1 * S1 + S2 * S2 ! + IF(MO /= 0) THEN ! + W1 = HALF * LOG(S) ! + W2 = ATAN2(S2,S1) ! + END IF ! + END IF ! +! +! Set V1 + V2*I = (Z - 0.5) * LOG(Z + N) - Z +! + T1 = HALF * LOG(A) - ONE ! + T2 = ATAN2(Y,T) ! + U = X - HALF ! + V1 = (U * T1 - HALF) - Y * T2 ! + V2 = U * T2 + Y * T1 ! +! +! Let A1 + A2*I be the asymptotic sum +! + ETA = CMPLX(T/A,-Y/A,KIND=WP) ! + ETA2 = ETA * ETA ! + M = 12 ! + IF(A >= 289.0E0_DP) M = 6 ! + IF(EPS > 1.E-8_WP) M = M / 2 ! + SUM = CMPLX(C0(M), 0.0_DP, KIND=WP) ! + L = M ! + DO J = 2, M ! + L = L - 1 ! + SUM = CMPLX(C0(L),ZERO,KIND=WP) + SUM * ETA2 ! + END DO ! + SUM = SUM * ETA ! + A1 = REAL(SUM,KIND=WP) ! + A2 = AIMAG(SUM) ! +! +!----------------------------------------------------------------------- +! Gathering together the results +!----------------------------------------------------------------------- +! + W1 = (((A1 + HL2P) - W1) + V1) - N ! + W2 = (A2 - W2) + V2 ! + IF(REAL(Z,KIND=DP) < ZERO) GO TO 50 ! + IF(MO == 0) THEN ! +! +! Case when the real part of Z is nonnegative and MO = 0 +! + A = EXP(W1) ! + W1 = A * COS(W2) ! + W2 = A * SIN(W2) ! + IF(N == 0) GO TO 60 ! + C = (S1 * W1 + S2 * W2) / S ! + D = (S1 * W2 - S2 *W1) / S ! + W1 = C ! + W2 = D ! + GO TO 60 ! + END IF ! +! +! Case when the real part of z is nonnegative and MO is nonzero. +! The angle W2 is reduced to the interval -PI < W2 <= PI. +! + 40 IF(W2 <= PI) THEN ! + K = HALF - W2 / PI2 ! + W2 = W2 + PI2 * K ! + GO TO 60 ! + END IF ! + K = W2 / PI2 - HALF ! + W2 = W2 - PI2 * REAL(K+1) ! + IF(W2 <= - PI) W2 = PI ! + GO TO 60 ! +! +! Case when the real part of Z is negative and MO is nonzero +! + 50 IF(MO /= 0) THEN ! + W1 = H1 - W1 ! + W2 = H2 - W2 ! + GO TO 40 ! + END IF ! +! +! Case when the real part of Z is negative and MO = 0 +! + A = EXP(-W1) ! + T1 = A * COS(-W2) ! + T2 = A * SIN(-W2) ! + W1 = H1 * T1 - H2 * T2 ! + W2 = H1 * T2 + H2 * T1 ! + IF(N /= 0) THEN ! + C = W1 * S1 - W2 * S2 ! + D = W1 * S2 + W2 * S1 ! + W1 = C ! + W2 = D ! + END IF ! +! +! Termination +! + 60 W = CMPLX(W1,W2,KIND=WP) ! + RETURN ! +! +!----------------------------------------------------------------------- +! The requested value cannot be computed +!----------------------------------------------------------------------- +! + 70 W = (ZERO,ZERO) ! + RETURN ! +! +CONTAINS +! + FUNCTION REXP(X) RESULT(FN_VAL) +! +!----------------------------------------------------------------------- +! Evaluation of the function EXP(X) - 1 +!----------------------------------------------------------------------- +! +! +! Last modified (DS) : 24 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,HALF +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: FN_VAL +! +! Local variables +! + REAL (WP), PARAMETER :: P1 = .914041914819518E-09_WP + REAL (WP), PARAMETER :: P2 = .238082361044469E-01_WP + REAL (WP), PARAMETER :: Q1 = -.499999999085958_WP + REAL (WP), PARAMETER :: Q2 = .107141568980644_WP + REAL (WP), PARAMETER :: Q3 = -.119041179760821E-01_WP + REAL (WP), PARAMETER :: Q4 = .595130811860248E-03_WP +! + REAL (WP) :: E +! +!----------------------- +! + IF(ABS(X) <= 0.15E0_WP) THEN ! + FN_VAL = X * ( ((P2*X + P1)*X + ONE) / & ! + ((((Q4*X + Q3)*X + Q2)*X + Q1)*X + ONE) ) ! + RETURN ! + END IF ! +! + IF(X >= ZERO) THEN ! + E = EXP(X) ! + FN_VAL = E * (HALF + (HALF - ONE / E)) ! + RETURN ! + END IF ! +! + IF(X >= -37.0E0_WP) THEN ! + FN_VAL = (EXP(X) - HALF) - HALF ! + RETURN ! + END IF ! +! + FN_VAL = - ONE ! + RETURN ! +! + END FUNCTION REXP +! + END SUBROUTINE CGAMMA +! +!======================================================================= +! + FUNCTION ZGAMMA(ARG,LNPFQ) +! +! **************************************************************** +! * * +! * FUNCTION ZGAMMA * +! * * +! * * +! * Description : Calculates the complex gamma function. Based * +! * on a program written by F.A. Parpia published in Computer* +! * Physics Communications as the `GRASP2' program (public * +! * domain). * +! * * +! * * +! * Subprograms called: none. * +! * * +! **************************************************************** +! +! +! Note : This function was originally called CGAMMA +! in the hypergeometric function code pFq written by +! by W.F. Perger, M. Nardin and A. Bhalla +! +! +! Last modified (DS) : 28 Aug 2020 +! +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,TEN, & + HALF,TENTH + USE PI_ETC, ONLY : PI +! + IMPLICIT NONE +! + COMPLEX (WP) :: ZGAMMA,ARG +! + REAL (WP) :: FN(7),FD(7) + REAL (WP) :: ARGR,ARGI + REAL (WP) :: DNUM,TENMAX,EXPMAX + REAL (WP) :: PRECIS,HLNTPI,TWOI + REAL (WP) :: DIFF,CLNGI,CLNGR + REAL (WP) :: FACNEG,ARGUM + REAL (WP) :: OBASQ,OVLFAC,FAC + REAL (WP) :: ARGUI,ARGUI2 + REAL (WP) :: ARGUR,ARGUR2 + REAL (WP) :: OVLFR,OVLFI + REAL (WP) :: TERMR,TERMI + REAL (WP) :: OBASQR,OBASQI + REAL (WP) :: ZFACR,ZFACI + REAL (WP) :: RESR,RESI +! + LOGICAL :: FIRST,NEGARG +! + INTEGER :: LNPFQ + INTEGER :: ITNMAX + INTEGER :: I +! +!---------------------------------------------------------------------- +! +! These are the Bernoulli numbers B02, B04, ..., B14, expressed as +! rational numbers. From Abramowitz and Stegun, P. 810. +! + DATA FN / 1.0E00_WP, -1.0E00_WP, 1.0E00_WP, & + -1.0E00_WP, 5.0E00_WP, -691.0E00_WP, & + 7.0E00_WP / + DATA FD/ 6.0E00_WP, 30.0E00_WP, 42.0E00_WP, & + 30.0E00_WP, 66.0E00_WP, 2730.0E00_WP, & + 6.0E00_WP / +! +!---------------------------------------------------------------------- +! + DATA HLNTPI /1.0E00_WP/ +! + DATA FIRST/.TRUE./ +! + ARGR = DREAL(ARG) ! + ARGI = DIMAG(ARG) ! +! +! On the first entry to this routine, set up the constants required +! for the reflection formula (CF. Abramowitz and Stegun 6.1.17) and +! Stirling's approximation (CF. Abramowitz and Stegun 6.1.40). +! + IF(FIRST) THEN ! +! +! Set the machine-dependent parameters: +! +! TENMAX - maximum size of exponent of 10 +! + ITNMAX = 1 ! + DNUM = TENTH ! + 10 ITNMAX = ITNMAX+1 ! + DNUM = DNUM * TENTH ! + IF(DNUM > ZERO) GO TO 10 ! + ITNMAX = ITNMAX - 1 ! + TENMAX = DFLOAT(ITNMAX) ! +! +! EXPMAX - maximum size of exponent of E +! + DNUM = TENTH**ITNMAX ! + EXPMAX = - LOG(DNUM) ! +! +! PRECIS - machine precision +! + PRECIS = ONE ! + 20 PRECIS = PRECIS / TWO ! + DNUM = PRECIS + ONE ! + IF(DNUM > ONE) GO TO 20 ! + PRECIS = TWO * PRECIS ! +! + HLNTPI = HALF * LOG(TWO*PI) ! +! + DO I = 1,7 ! + FN(I) = FN(I) / FD(I) ! + TWOI = TWO * DBLE(I) ! + FN(I) = FN(I) / (TWOI * (TWOI - ONE)) ! + END DO ! +! + FIRST = .FALSE. ! +! + END IF ! +! +! Cases where the argument is real +! + IF(ARGI == ZERO) THEN ! +! +! Cases where the argument is real and negative +! + IF(ARGR <= ZERO) THEN ! +! +! Stop with an error message if the argument is too near a pole +! + DIFF = ABS(DBLE(NINT(ARGR))-ARGR) ! + IF(DIFF <= TWO*PRECIS) THEN ! + WRITE(6,300) ! + WRITE(6,301) ARGR,ARGI ! + STOP '010801' ! + ELSE ! +! +! Otherwise use the reflection formula (Abramowitz and Stegun 6.1.17) +! to ensure that the argument is suitable for Stirling's +! formula +! + ARGUM = PI/(-ARGR*SIN(PI*ARGR)) ! + IF(ARGUM < ZERO) THEN ! + ARGUM = - ARGUM ! + CLNGI = PI ! + ELSE ! + CLNGI = ZERO ! + END IF + FACNEG = LOG(ARGUM) ! + ARGUR = - ARGR ! + NEGARG = .TRUE. ! +! + END IF +! +! Cases where the argument is real and positive +! + ELSE ! +! + CLNGI = ZERO ! + ARGUR = ARGR ! + NEGARG = .FALSE. ! +! + END IF +! +! Use Abramowitz and Stegun formula 6.1.15 to ensure that +! the argument in Stirling's formula is greater than 10 +! + OVLFAC = ONE ! + 40 IF(ARGUR < TEN) THEN ! + OVLFAC = OVLFAC * ARGUR ! + ARGUR = ARGUR + ONE ! + GO TO 40 ! + END IF ! +! +! Now use Stirling's formula to compute LOG(GAMMA(ARGUM)) +! + CLNGR = (ARGUR - HALF) * LOG(ARGUR) - ARGUR + HLNTPI ! + FAC = ARGUR ! + OBASQ = ONE / (ARGUR * ARGUR) ! + DO I = 1,7 + FAC = FAC * OBASQ ! + CLNGR = CLNGR + FN(I) * FAC ! + END DO ! +! +! Include the contributions from the recurrence and reflection +! formulae +! + CLNGR = CLNGR - LOG(OVLFAC) ! + IF(NEGARG) CLNGR = FACNEG - CLNGR ! +! + ELSE ! +! +! Cases where the argument is complex +! + ARGUR = ARGR ! + ARGUI = ARGI ! + ARGUI2 = ARGUI * ARGUI ! +! +! Use the recurrence formula (Abramowitz and Stegun 6.1.15) +! to ensure that the magnitude of the argument in Stirling's +! formula is greater than 10 +! + OVLFR = ONE ! + OVLFI = ZERO ! + 60 ARGUM = SQRT(ARGUR * ARGUR + ARGUI2) ! + IF(ARGUM < TEN) THEN ! + TERMR = OVLFR * ARGUR - OVLFI * ARGUI ! + TERMI = OVLFR * ARGUI + OVLFI * ARGUR ! + OVLFR = TERMR ! + OVLFI = TERMI ! + ARGUR = ARGUR + ONE ! + GO TO 60 ! + END IF ! +! +! Now use Stirling's formula to compute LOG(GAMMA(ARGUM)) +! + ARGUR2 = ARGUR * ARGUR ! + TERMR = HALF * LOG(ARGUR2 + ARGUI2) ! + TERMI = ATAN2(ARGUI,ARGUR) ! + CLNGR = (ARGUR - HALF) *TERMR - ARGUI * TERMI - ARGUR & ! + + HLNTPI ! + CLNGI = (ARGUR - HALF) *TERMI + ARGUI * TERMR - ARGUI ! + FAC = (ARGUR2 + ARGUI2)**(-2) ! + OBASQR = (ARGUR2 - ARGUI2) * FAC ! + OBASQI = - TWO * ARGUR * ARGUI * FAC ! + ZFACR = ARGUR ! + ZFACI = ARGUI ! + DO I = 1,7 ! + TERMR = ZFACR * OBASQR - ZFACI * OBASQI ! + TERMI = ZFACR * OBASQI + ZFACI * OBASQR ! + FAC = FN(I) ! + CLNGR = CLNGR + TERMR * FAC ! + CLNGI = CLNGI + TERMI * FAC ! + ZFACR = TERMR ! + ZFACI = TERMI ! + END DO ! +! +! Add in the relevant pieces from the recurrence formula +! + CLNGR = CLNGR - HALF * LOG(OVLFR * OVLFR + OVLFI * OVLFI) ! + CLNGI = CLNGI - ATAN2(OVLFI,OVLFR) ! +! + END IF ! +! + IF(LNPFQ == 1) THEN ! + ZGAMMA = DCMPLX(CLNGR,CLNGI) ! + RETURN ! + END IF ! +! +! Now exponentiate the complex Log Gamma Function to get +! the complex Gamma function +! + IF( (CLNGR <= EXPMAX) .AND. (CLNGR >= -EXPMAX) ) THEN ! + FAC = EXP(CLNGR) ! + ELSE ! + WRITE(6,300) ! + WRITE(6,302) CLNGR ! + STOP '010802' ! + END IF ! + RESR = FAC * COS(CLNGI) ! + RESI = FAC * SIN(CLNGI) ! + ZGAMMA = DCMPLX(RESR,RESI) ! +! + RETURN +! + 300 FORMAT (///' ***** ERROR IN SUBROUTINE ZGAMMA *****') + 301 FORMAT (' ARGUMENT (',1P,1D14.7,',',1D14.7,') TOO CLOSE TO A',& + ' POLE.') + 302 FORMAT (' ARGUMENT TO EXPONENTIAL FUNCTION (',1P,1D14.7, & + ') OUT OF RANGE.') +! + END FUNCTION ZGAMMA +! +!======================================================================= +! + SUBROUTINE ZGAM(CARG,CANS,ERREST,MODE) +! +! Copyright (c) 1996 California Institute of Technology, Pasadena, CA. +! ALL RIGHTS RESERVED. +! Based on Government Sponsored Research NAS7-03001. +!>> 1996-03-30 ZGAM Krogh Added external statement. +!>> 1995-11-20 ZGAM Krogh Set up so M77CON converts between "Z" and "C". +!>> 1994-08-17 CLL Add tests on BIGINT to allow easier conversion to C. +!>> 1994-05-25 ZGAM WVS generate COEF using PARAMETER +!>> 1994-04-20 ZGAM CLL Make DP and SP versions similar. +!>> 1993-04-13 ZGAM CLL Edit for conversion to C. +!>> 1992-04-20 ZGAM CLL Edited comments. +!>> 1991-11-11 ZGAM CLL Made [Z/C]GAM from CDLGAM +!>> 1991-01-16 CDLGAM Lawson Removing use of subr D2MACH. +!>> 1985-08-02 CDLGAM Lawson Initial code. +! +! *** COMPLEX GAMMA AND LOGGAMMA FUNCTIONS WITH ERROR ESTIMATE +! +! ----------------------------------------------------------------- +! SUBROUTINE ARGUMENTS +! -------------------- +! CARG() A complex argument, given as an array of 2 floating-point +! elements consisting of the real component +! followed by the imaginary component. +! +! CANS() The complex answer, stored as an array of 2 +! floating-point numbers, representing the real and +! imaginary parts. +! +! ERREST On output ERREST gives an estimate of the absolute +! (for LOGGAMMA) or the relative (for GAMMA) error +! of the answer. +! +! MODE Selects function to be computed. set it to 0 for +! LOGGAMMA, and 1 for GAMMA. +! ----------------------------------------------------------------- +! MACHINE DEPENDANT PARAMETERS +! If the fraction part of a floating point number +! contains T digits using base B then +! EPS3 = B ** (-T) +! EPS4 = B ** (-T+1) +! OMEGA = overflow limit +! DESET = 5.0 on a binary machine +! = 2.0 on a base 16 machine +! ----------------------------------------------------------------- +! REFERENCE: H.KUKI, Comm.ACM, Vol.15, (1972), +! pp.262-267, 271-272. Subroutine name was CDLGAM. +! Code developed for UNIVAC 1108 by E.W.NG, JPL, 1969. +! Modified for FORTRAN 77 portability by C.L.LAWSON & +! S.CHAN, JPL, 1983. +! ----------------------------------------------------------------- +!--Z replaces "?": ?GAM +!--D (type)replaces "?": ?ERM1, ?ERV1 +! Also uses I1MACH, and D1MACH +! ----------------------------------------------------------------- +! +! Last modified (DS) : 1 Sep 2020 +! +! + USE MACHINE_ACCURACY + USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FIVE,SIX,TEN, & + HALF,TENTH + USE PI_ETC, ONLY : PI + USE ERROR_CALTECH +! + IMPLICIT NONE +! + INTEGER :: ITEMP,J,K + INTEGER :: LF1,LF2,LF3 + INTEGER :: MODE,N +! + REAL (WP) :: A,AL1,AL2,B,BIGINT + REAL (WP) :: CARG(2),CANS(2),COEF(7),CUT1 + REAL (WP) :: DE0,DE1,DELTA,DESET,DN + REAL (WP) :: ELIMIT,EPS3,EPS4,ERREST + REAL (WP) :: H,H1,H2,OMEGA + REAL (WP) :: REPS3,T1,T2 + REAL (WP) :: U,U1,U2,UU1,UU2,UUU1,UUU2 + REAL (WP) :: V1,V2,VV1,VV2 + REAL (WP) :: W1,W2,W3,Y1,Z1,Z2,ZZ1 +! + REAL (WP), PARAMETER :: F0 = 840.07385296052619E0_WP + REAL (WP), PARAMETER :: F1 = 20.001230821894200E0_WP + REAL (WP), PARAMETER :: G0 = 1680.1477059210524E0_WP + REAL (WP), PARAMETER :: G1 = 180.01477047052042E0_WP + REAL (WP), PARAMETER :: TWOPI = 6.283185307179586476925E0_WP + REAL (WP), PARAMETER :: HL2P = 0.918938533204672742E0_WP + REAL (WP), PARAMETER :: AL2P = 1.83787706640934548E0_WP +! + REAL (WP), PARAMETER :: C1 = +1.0e0_WP / 156.0e0_WP + REAL (WP), PARAMETER :: C2 = -691.0e0_WP / 360360.0e0_WP + REAL (WP), PARAMETER :: C3 = +1.0e0_WP / 1188.0e0_WP + REAL (WP), PARAMETER :: C4 = -1.0e0_WP / 1680.0e0_WP + REAL (WP), PARAMETER :: C5 = +1.0e0_WP / 1260.0e0_WP + REAL (WP), PARAMETER :: C6 = -1.0e0_WP / 360.0e0_WP + REAL (WP), PARAMETER :: C7 = +1.0e0_WP / 12.0e0_WP +! + LOGICAL :: FIRST +! + SAVE FIRST,BIGINT,COEF,OMEGA,EPS4,EPS3,REPS3,CUT1,DESET,ELIMIT + +! +! COEF(8-i) = bernoulli(2i)/(2i*(2i-1)). +! + DATA COEF /C1,C2,C3,C4,C5,C6,C7/ +! + DATA FIRST /.TRUE./ +! +! ------------------------------------------------------------------ +! + IF (FIRST) THEN ! + FIRST = .FALSE. ! + OMEGA = D1MACH(2) ! + EPS3 = D1MACH(3) ! + EPS4 = D1MACH(4) ! + REPS3 = ONE / EPS3 ! + ELIMIT = LOG(OMEGA) ! + CUT1 = LOG(EPS3) ! + BIGINT = I1MACH(9) - 2 ! + IF (I1MACH(10) == 2) THEN ! + DESET = FIVE ! + ELSE ! + DESET = TWO ! + END IF ! + END IF ! + DE0 = DESET ! + DE1 = ZERO ! + Z1 = CARG(1) ! + Z2 = CARG(2) ! +! +! *** Setting DELTA = estimate of uncertainty level of +! argument data. +! + DELTA = EPS4 * (ABS(Z1) + ABS(Z2)) ! + IF(DELTA == ZERO) DELTA = EPS4 ! +! +! *** Force sign of imaginary part of ARG to non-negative +! + LF1 = 0 ! + IF (Z2 < ZERO) THEN ! + LF1 = 1 ! + Z2 = - Z2 ! + END IF ! + LF2 = 0 ! + IF (Z1 >= ZERO) GO TO 100 ! +! +! *** Case when real part of ARG is negative +! + LF2 = 1 ! + LF1 = LF1 - 1 ! + T1 = AL2P - PI * Z2 ! + T2 = PI * (HALF - Z1) ! + U = - TWOPI * Z2 ! + IF (U < -0.1054E0_WP) THEN ! + A = ZERO ! +! +! *** If EXP(U) .LE. EPS3, ignore it to save time and to avoid +! irrelevant underflow +! + IF (U > CUT1) THEN ! + A = EXP(U) ! + END IF ! + H1 = ONE - A ! + ELSE ! + U2 = U * U ! + A = - U * (F1 * U2 + F0) ! + H1 = (A + A) /((U2 + G1) * U2 + G0 + A) ! + A = ONE - H1 ! + END IF ! +! +! Here Z1 is negative. +! + IF(Z1 < -BIGINT) THEN ! + CALL DERM1('ZGAM',3,0,'Require CARG(1) >= -BIGINT', & ! + 'CARG(1)', Z1, ',') ! + CALL DERV1('-BIGINT',-BIGINT,'.') ! + GO TO 700 ! + END IF ! +! +! Truncate to integer: ITEMP +! + ITEMP = Z1 - HALF ! + B = Z1 - ITEMP ! + H2 = A*SIN(TWOPI * B) ! + B = SIN(PI * B) ! + H1 = H1 + (B + B) * B * A ! + H = ABS(H2) + H1 - TWOPI * A * DELTA ! + IF(H <= ZERO) GO TO 500 ! + DE0 = DE0 + ABS(T1) + T2 ! + DE1 = PI + TWOPI * A / H ! + Z1 = ONE - Z1 ! +! +! *** CASE when neither real part nor imaginary part of ARG is +! negative. Define threshold curve to be the broken lines +! connecting points 10F0*I, 10F4.142*I, 0.1F14.042*I,and +! 0.1FOMEGA*I +! + 100 LF3 = 0 ! + Y1 = Z1 - HALF ! + W1 = ZERO ! + W2 = ZERO ! + K = 0 ! + B = MAX(TENTH, MIN(TEN, 14.142E0_WP-Z2)) - Z1 ! + IF(B <= ZERO) GO TO 200 ! +! +! *** Case when real part of ARG is between 0 and threshold +! + LF3 = 1 ! + ZZ1 = Z1 ! + N = B + ONE ! + DN = N ! + Z1 = Z1 + DN ! + A = Z1 * Z1 + Z2 * Z2 ! + V1 = Z1 / A ! + V2 = - Z2 / A ! +! +! *** Initialize U1+U2*I as the rightmost factor 1-1/(Z+N) +! + U1 = ONE - V1 ! + U2 = - V2 ! + K = SIX - Z2*0.6E0_WP - ZZ1 ! + IF(K > 0) THEN ! +! +! *** Forward assembly of factors (Z+J-1)/(Z+N) +! + N = N - K ! + UU1 = (ZZ1 * Z1 + Z2 * Z2) / A ! + UU2 = DN * Z2 / A ! + VV1 = ZERO ! + VV2 = ZERO ! + DO J = 1,K ! + B = U1 * (UU1 + VV1) - U2 * (UU2 + VV2) ! + U2 = U1 * (UU2 + VV2) + U2 * (UU1 + VV1) ! + U1 = B ! + VV1 = VV1 + V1 ! + VV2 = VV2 + V2 ! + END DO ! + END IF ! + IF(N >= 2) THEN ! +! +! *** Backward assembly of factors 1-J/(Z+N) +! + VV1 = V1 ! + VV2 = V2 ! + DO J = 2,N ! + VV1 = VV1 + V1 ! + VV2 = VV2 + V2 ! + B = U1 * (ONE - VV1) + U2 * VV2 ! + U2 = - U1 * VV2 + U2 * (ONE - VV1) ! + U1 = B ! + END DO ! + END IF ! + U = U1 * U1 + U2 * U2 ! + IF(U == ZERO) GO TO 500 ! + IF(MODE /= 0) THEN ! + IF(K <= 0) GO TO 200 ! + END IF ! + AL1 = LOG(U) * HALF ! + IF(MODE == 0) THEN ! + W1 = AL1 ! + W2 = ATAN2(U2,U1) ! + IF(W2 < ZERO) W2 = W2 + TWOPI ! + IF(K <= 0) GO TO 200 ! + END IF ! + A = ZZ1 + Z2 - DELTA ! + IF(A <= ZERO) GO TO 500 ! + DE0 = DE0 - AL1 ! + DE1 = DE1 + TWO + ONE / A ! +! +! *** CAse when real part of ARG is greater than threshold +! + 200 A = Z1 * Z1 + Z2 * Z2 ! + AL1 = LOG(A) * HALF ! + AL2 = ATAN2(Z2,Z1) ! + V1 = Y1 * AL1 - Z2 * AL2 ! + V2 = Y1 * AL2 + Z2 * AL1 ! +! +! *** Evaluate asymptotic terms. Ignore this term, +! if ABS(ARG)**2 .GT. REPS3, to save time and +! to avoid irrelevant underflow. +! + VV1 = ZERO ! + VV2 = ZERO ! + IF(A > REPS3) GO TO 220 ! + UU1 = Z1 / A ! + UU2 = - Z2 / A ! + UUU1 = UU1 * UU1 - UU2 * UU2 ! + UUU2 = UU1 * UU2 * TWO ! + VV1 = COEF(1) ! + DO J = 2,7 ! + B = VV1 * UUU1 - VV2 * UUU2 ! + VV2 = VV1 * UUU2 + VV2 * UUU1 ! + VV1 = B + COEF(J) ! + END DO ! + B = VV1 * UU1 - VV2 * UU2 ! + VV2 = VV1 * UU2 + VV2 * UU1 ! + VV1 = B ! + 220 W1 = (((VV1 + HL2P) - W1) - Z1) + V1 ! + W2 = ((VV2 - W2) - Z2) + V2 ! + DE0 = DE0 + ABS(V1) + ABS(V2) ! + IF (K <= 0) DE1 = DE1 + AL1 ! +! +! Final assembly +! + IF(LF2 == 0) THEN ! + IF(MODE /= 0) THEN ! + IF(W1 > ELIMIT) GO TO 550 ! + A = EXP(W1) ! + W1 = A * COS(W2) ! + W2 = A * SIN(W2) ! + IF(LF3 /= 0) THEN ! + B = (W1 * U1 + W2 * U2) / U ! + W2 = (W2 * U1 - W1 * U2) / U ! + W1 = B ! + END IF ! + END IF ! + GO TO 400 ! + END IF + H = H1 * H1 + H2 * H2 ! + IF(H == ZERO) GO TO 500 ! + IF(MODE == 0 .OR. H <= 1.0E-2_WP) THEN ! + A = LOG(H) * HALF ! + IF(H <= 1.0E-2_WP) DE0 = DE0 - A ! + IF(MODE == 0) THEN ! + W1 = (T1 - A) - W1 ! + W2 = (T2 - ATAN2(H2,H1)) - W2 ! + GO TO 400 ! + END IF ! + END IF ! +! +! Here we have MODE .ne. 0 and LF2 .ne. 0. +! + T1 = T1 - W1 ! + T2 = T2 - W2 ! + IF(T1 > ELIMIT) GO TO 550 ! + A = EXP(T1) ! + T1 = A * COS(T2) ! + T2 = A * SIN(T2) ! + W1 = (T1 * H1 + T2 * H2) / H ! + W2 = (T2 * H1 - T1 * H2) / H ! + IF(LF3 /= 0) THEN ! + B = W1 * U1 - W2 * U2 ! + W2 = W1 * U2 + W2 * U1 ! + W1 = B ! + END IF ! + 400 CONTINUE ! + IF(LF1 /= 0) W2 = -W2 ! +! +! *** Truncation errest of Stirlings formula is up to EPS3. +! + DE1 = DE0 * EPS4 + EPS3 + DE1 * DELTA ! + +! +! Normal termination. +! +! The imaginary part of the log of a complex number is nonunique +! to within multiples of 2*Pi. We prefer a result for loggamma +! having its imaginary part .gt. -Pi and .le. +Pi. The result at +! this point is usually in this range. If not we will move it +! into this range. -- CLL 11/11/91 +! + IF(MODE == 0) THEN ! + IF(W2 <= -PI .OR. W2 > PI) THEN ! + W3 = ABS(W2) ! + T1 = W3 /PI + ONE ! + IF(ABS(T1) > BIGINT) THEN ! + CALL DERM1('ZGAM',4,0,'Argument out of range.', & ! + 'CARG(1)',CARG(1),',') ! + CALL DERV1('CARG(2)',CARG(2),'.') ! + GO TO 700 ! + END IF ! + T2 = INT(T1) / 2 ! + W3 = W3 - T2 * TWOPI ! + IF(W2 >= ZERO) THEN ! + W2 = W3 ! + ELSE ! + W2 = - W3 ! + END IF ! + IF(W2 <= -PI) THEN ! + W2 = W2 + TWOPI ! + ELSE IF(W2 > PI) THEN ! + W2 = W2 - TWOPI ! + END IF ! + END IF ! + END IF ! + CANS(1) = W1 ! + CANS(2) = W2 ! + ERREST = DE1 ! + RETURN ! +! +! Error termination. +! +! *** Case when argument is too close to a singularity +! + 500 CONTINUE ! + CALL DERM1('ZGAM',1,0,'Z TOO CLOSE TO A SINGULARITY', & ! + 'Z(1)',CARG(1),',') ! + CALL DERV1('Z(2)',CARG(2),'.') ! + GO TO 700 ! +! + 550 CONTINUE ! + CALL DERM1('ZGAM',2,0,'ARG TOO LARGE. EXP FUNCTION OVERFLOW',&! + 'Z(1)',CARG(1),',') ! + CALL DERV1('Z(2)',CARG(2),'.') ! + 700 CONTINUE ! + CANS(1) = OMEGA ! + CANS(2) = OMEGA ! + ERREST = OMEGA ! +! + RETURN ! +! + END SUBROUTINE ZGAM +! +END MODULE GAMMA_FUNCTION diff --git a/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/mod_mlf_garrappa.f90 b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/mod_mlf_garrappa.f90 new file mode 100644 index 0000000..caef020 --- /dev/null +++ b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/mod_mlf_garrappa.f90 @@ -0,0 +1,1838 @@ +!======================================================================= +! +! 1) The following Fortran code is developed mainly from the Matlab +! code of Prof. Robert Garrappa with a minor modification. Feel free +! to use or modify it. In doing so, please cite the following +! references: +! +! [1] https://www.mathworks.com/matlabcentral/fileexchange/ +! 48154-the-mittag-leffler-function +! (the Matlab code) +! +! [2] R. Garrappa, Numerical evaluation of two and three parameter +! Mittag-Leffler functions, SIAM Journal of Numerical Analysis, +! 2015, 53(3), 1350-1369 +! (Theoretical background) +! +! [3] Gorenflo, Rudolf, Joulia Loutchko, and Yuri Luchko. +! "Computation of the Mittag-Leffler function E alpha, beta (z) +! and its derivative." Fract. Calc. Appl. Anal. 2002. +! (For calculation of derivative of the Mittag-Leffler function) +! +! [4] "An Overview of Software Development for Special Functions", +! W. J. Cody, Lecture Notes in Mathematics, 506, Numerical +! Analysis Dundee, 1975, G. A. Watson (ed.), Springer Verlag, +! Berlin, 1976. +! (For a portable gamma function with under/overflow trapping.) +! +! 2) Please report on this Fortran code to viet204@gmail.com. +! +!======================================================================= +! Version 02, dated Tue May 1 2018 (current version) +! +! + passed more than 70 test cases fantastically. The test cases +! are released together with this code, however, with a rough +! explanation. I'm going to update more testcases. +! +! + compiler for the test cases: gfortran version 4.9.2, ifort +! version 18.0.0. Later versions should work as well. +! +! + several comments of the Matlab code are still remained in this +! version. Most of them are marked by !@. +! +! + there are lots of irrelevant comments inside this version. I +! don't have time to clean. So just ignore or clean them by +! yourself :D (No longer. I did, except this) +! +! + I have packed everything into only one module to not conflict +! with other package. Now the code is really portable and safe. +! But, +! +! + You should check the code by yourself. +! +! + what's else? ... +! +!======================================================================= +! gfortran -O3 -c mod_mlf_garrappa.f90 +! + module mod_mlf_garrappa +! + implicit none +! + private +! +!----------------------------------------------------------------------- +! +! group 1: fixed +! + integer,parameter :: r4 = kind(1.0e0), r8 = kind(1.0d0) + integer,parameter :: i4 = selected_int_kind(9) + integer,parameter :: i8 = selected_int_kind(18) +! +! group 2: choose precision +! + integer,parameter :: rk = r8 ! double precision +! integer,parameter :: rk = r4 ! single precision (not available) + integer,parameter :: ik = i4 ! integers with 4 bytes, common use +! +! group 3: machine dependent constants +! + integer(ik),parameter :: iinf = huge(iinf) + real(rk),parameter :: rinf = huge(rinf) + real(rk),parameter :: rtin = tiny(rtin) + real(rk),parameter :: reps = epsilon(reps) + real(rk),parameter :: lnep = log(reps) + real(rk),parameter :: xbig = 171.624_rk ! if rk=r8 +! real(rk),parameter :: xbig = 35.040_rk ! if rk=r4 +! + real(rk),parameter :: &! + picons= 3.141592653589793238462643383279502884197e+0_rk,&!pi + piinve= 3.183098861837906715377675267450287240689e-1_rk,&!1/pi + pidiv2= 1.570796326794896619231321691639751442099e+0_rk,&!pi/2 + pipow2= 9.869604401089358618834490999876151135314e+0_rk,&!pi^2 + pimul2= 6.283185307179586476925286766559005768394e+0_rk,&!pi*2 + sqrtpi= 1.772453850905516027298167483341145182798e+0_rk,&!pi^0.5 + loge10= 2.302585092994045684017991454684364207601e+0_rk !ln10 +! + complex(rk),parameter :: iz = cmplx(0.0_rk,1.0_rk,rk) +! + real(rk),parameter :: default_epsilon = 1.0e-15_rk + real(rk),save :: present_epsilon = default_epsilon +! +!----------------------------------------------------------------------- +! +! To reset the prepenst_epsilon above on demand. If we do not call +! this, present_epsilon is set to default_epsilon = 10^(-15). +! + public :: mlf_set_epsilon +!---------------------------------------------------------------------- +! +! General Mittag Leffler function for various kinds of input: +! + public :: genmlf + interface genmlf + module procedure genmlf_garrappa_01 + module procedure genmlf_garrappa_02 + module procedure genmlf_garrappa_03 + module procedure genmlf_garrappa_04 + end interface +! +! Usage: +! +! E = genmlf ( afa, bta, gma, z ) +! +! for z and E are defined as scalar (0D) or arrays (1D, 2D, or 3D). +! +!---------------------------------------------------------------------- +! +! Mittag Leffler function for various shapes of input: +! + public :: mlf_garrappa + interface mlf_garrappa + module procedure mlf_garrappa_01 + module procedure mlf_garrappa_02 + module procedure mlf_garrappa_03 + module procedure mlf_garrappa_04 + end interface +! +! Usage: +! +! E = mlf_garrappa ( afa, bta, z ) +! +! for z and E are defined as scalar (0D) or arrays (1D, 2D, or 3D). +! +!---------------------------------------------------------------------- +! +! Derivative of Mittag Leffler function for shapes of input: +! + public :: mld_garrappa + interface mld_garrappa + module procedure mld_garrappa_01 + module procedure mld_garrappa_02 + module procedure mld_garrappa_03 + module procedure mld_garrappa_04 + end interface +! +!---------------------------------------------------------------------- + contains +!====================================================================== + function mlf_garrappa_01 ( afa, bta, z ) result(E) +! + implicit none +! + complex(rk),intent(in) :: z + real(rk),intent(in) :: afa, bta + complex(rk) :: E +! +! Dependencies: +! +! external :: sub_genmlf_multishot +! +! Local variables: +! + complex(rk) :: zloc(2) +! + zloc(1) = z +! + call sub_genmlf_multishot ( & + afa, bta, 1.0_rk, 1, 1, zloc(1), 1, zloc(2) ) +! + e = zloc(2) +! + return + end function +!===== +! +! 1D input +! + function mlf_garrappa_02 ( afa, bta, z ) result(E) +! + implicit none +! + real(rk),intent(in) :: afa, bta + complex(rk),dimension(:),intent(in) :: z + complex(rk),dimension(size(z)) :: E +! +! Dependencies: +! +! external :: sub_genmlf_multishot +! + call sub_genmlf_multishot (afa,bta,1.0_rk,size(z),1,z,1,E) +! + return + end function +!===== +! +! 2D input +! + function mlf_garrappa_03 ( afa, bta, z ) result(E) +! + implicit none +! + real(rk),intent(in) :: afa, bta + complex(rk),dimension(:,:),intent(in) :: z + complex(rk),dimension(size(z,1),size(z,2)) :: E +! +! Dependencies: +! +! external :: sub_genmlf_multishot +! + call sub_genmlf_multishot ( & + afa, bta, 1.0_rk, & + size(z,1)*size(z,2), 1, z(:,1), 1, E(:,1) ) +! + return + end function +!===== +! 3D input +! + function mlf_garrappa_04 ( afa, bta, z ) result(E) +! + implicit none +! + real(rk),intent(in) :: afa, bta + complex(rk),dimension(:,:,:),intent(in) :: z + complex(rk),dimension(size(z,1),size(z,2),size(z,3)) :: E +! +! Dependencies: +! +! external :: sub_genmlf_multishot +! + call sub_genmlf_multishot ( & + afa, bta, 1.0_rk, & + size(z,1)*size(z,2)*size(z,3), 1, z(:,1,1), 1, E(:,1,1) ) +! + return + end function +!====================================================================== +! +! General ML function: +! + function genmlf_garrappa_01 ( afa, bta, gma, z ) result(E) +! + implicit none +! + complex(rk),intent(in) :: z + real(rk),intent(in) :: afa, bta, gma + complex(rk) :: E +! +! Dependencies: +! +! external :: sub_genmlf_multishot +! +! Local variables: +! + complex(rk) :: zloc(2) +! + zloc(1) = z +! + call sub_genmlf_multishot ( & + afa, bta, gma, 1, 1, zloc(1), 1, zloc(2) ) +! + e = zloc(2) +! + return + end function +!===== +! +! 1D input +! + function genmlf_garrappa_02 ( afa, bta, gma, z ) result(E) +! + implicit none +! + real(rk),intent(in) :: afa, bta, gma + complex(rk),dimension(:),intent(in) :: z + complex(rk),dimension(size(z)) :: E +! +! Dependencies: +! +! external :: sub_genmlf_multishot +! + call sub_genmlf_multishot (afa,bta,gma,size(z),1,z,1,E) +! + return + end function +!===== +! +! 2D input +! + function genmlf_garrappa_03 ( afa, bta, gma, z ) result(E) +! + implicit none +! + real(rk),intent(in) :: afa, bta, gma + complex(rk),dimension(:,:),intent(in) :: z + complex(rk),dimension(size(z,1),size(z,2)) :: E +! +! Dependencies: +! +! external :: sub_genmlf_multishot +! + call sub_genmlf_multishot ( & + afa, bta, gma, & + size(z,1)*size(z,2), 1, z(:,1), 1, E(:,1) ) +! + return + end function +!===== +! 3D input +! + function genmlf_garrappa_04 ( afa, bta, gma, z ) result(E) +! + implicit none +! + real(rk),intent(in) :: afa, bta, gma + complex(rk),dimension(:,:,:),intent(in) :: z + complex(rk),dimension(size(z,1),size(z,2),size(z,3)) :: E +! +! Dependencies: +! +! external :: sub_genmlf_multishot +! + call sub_genmlf_multishot ( & + afa, bta, gma, & + size(z,1)*size(z,2)*size(z,3), 1, z(:,1,1), 1, E(:,1,1) ) +! + return + end function +!======================================================================= +! +! Derivative of Mittag-Leffer function with two parameters. +! +! Applying THEOREM 4.1 of the Gorenflo's paper [3] +! +!===== + function mld_garrappa_01 ( afa, bta, z ) result(f) +! + implicit none +! + real(rk),intent(in) :: afa, bta + complex(rk),intent(in) :: z + complex(rk) :: f +! +! Dependencies: +! +! external :: sub_dermlf_multishot +! +! Local variables: +! + complex(rk) :: zloc(2) +! +! Check if the arguments afa>0. Otherwise, do nothing and report. +! + if ( afa .le. 0.0_rk ) then + write(*,'(a,1pe10.3)') & + 'ERROR: Wrong input to mld_garrappa_01, afa<=0,',afa + return + endif +! + zloc(1) = z +! + call sub_dermlf_multishot ( & + afa, bta, 1, 1, zloc(1), 1, zloc(2) ) +! + f = zloc(2) +! + return + end function +!===== + function mld_garrappa_02 ( afa, bta, z ) result(f) +! + implicit none +! + real(rk),intent(in) :: afa, bta + complex(rk),dimension(:),intent(in) :: z + complex(rk),dimension(size(z)) :: f +! +! Dependencies: +! +! external :: sub_dermlf_multishot +! +! Check if the arguments afa>0. Otherwise, do nothing and report. +! + if ( afa .le. 0.0_rk ) then + write(*,'(a,1pe10.3)') & + 'ERROR: Wrong input to mld_garrappa_02, afa<=0,',afa + return + endif +! + call sub_dermlf_multishot ( afa, bta, size(z), 1, z, 1, f ) +! + return + end function +!===== + function mld_garrappa_03 ( afa, bta, z ) result(f) +! + implicit none +! + real(rk),intent(in) :: afa, bta + complex(rk),dimension(:,:),intent(in) :: z + complex(rk),dimension(size(z,1),size(z,2)) :: f +! +! Dependencies: +! +! external :: sub_dermlf_multishot +! +! Check if the arguments afa>0. Otherwise, do nothing and report. +! + if ( afa .le. 0.0_rk ) then + write(*,'(a,1pe10.3)') & + 'ERROR: Wrong input to mld_garrappa_03, afa<=0,',afa + return + endif +! + call sub_dermlf_multishot ( & + afa, bta, size(z,1)*size(z,2), 1, z(:,1), 1, f(:,1) ) +! + return + end function +!===== + function mld_garrappa_04 ( afa, bta, z ) result(f) +! + implicit none +! + real(rk),intent(in) :: afa, bta + complex(rk),dimension(:,:,:),intent(in) :: z + complex(rk),dimension(size(z,1),size(z,2),size(z,3)) :: f +! +! Dependencies: +! +! external :: sub_dermlf_multishot +! +! Check if the arguments afa>0. Otherwise, do nothing and report. +! + if ( afa .le. 0.0_rk ) then + write(*,'(a,1pe10.3)') & + 'ERROR: Wrong input to mld_garrappa_03, afa<=0,',afa + return + endif +! + call sub_dermlf_multishot ( & + afa, bta, & + size(z,1)*size(z,2)*size(z,3), 1, z(:,1,1), 1, f(:,1,1) ) +! + return + end function + +!====================================================================== +! +! Set the value of epsilon in the range: 4.44e-16 < eps < 1.0e-1 +! +!===== + subroutine mlf_set_epsilon (eps) + real(rk),intent(in) :: eps +! + if ( 2*reps .lt. eps .and. eps .lt. 1.0e-1_rk ) then + present_epsilon = eps + endif +! + return + end subroutine +!====================================================================== +! +! Description coppied from the Matlab code of Prof. R. Garrappa: +! +! Evaluation of the Mittag-Leffler (ML) function with 1, 2 or 3 parameters +! by means of the OPC algorithm [1]. The routine evaluates an approximation +! Et of the ML function E such that |E-Et|/(1+|E|) approx 1.0e-15 +! +! +! E = ML(z,afa) evaluates the ML function with one parameter afa for +! the corresponding elements of z; afa must be a real and positive +! scalar. The one parameter ML function is defined as +! +! E = sum_{k=0}^{infty} z^k/Gamma(afa*k+1) +! +! with Gamma the Euler's gamma function. +! +! +! E = ML(z,afa,bta) evaluates the ML function with two parameters afa +! and bta for the corresponding elements of z; afa must be a real and +! positive scalar and bta a real scalar. The two parameters ML function is +! defined as +! +! E = sum_{k=0}^{infty} z^k/Gamma(afa*k+bta) +! +! +! E = ML(z,afa,bta,gma) evaluates the ML function with three parameters +! afa, bta and gma for the corresponding elements of z; afa must be a +! real scalar such that 0 afa*pi. The +! three parameters ML function is defined as +! +! E = sum_{k=0}^{infty} Gamma(gma+k)*z^k/Gamma(gma)/k!/Gamma(afa*k+bta) +! +! +! NOTE: +! This routine implements the optimal parabolic contour (OPC) algorithm +! described in [1] and based on the inversion of the Laplace transform on a +! parabolic contour suitably choosen in one of the regions of analyticity +! of the Laplace transform. +! +! +! REFERENCES +! +! [1] R. Garrappa, Numerical evaluation of two and three parameter +! Mittag-Leffler functions, SIAM Journal of Numerical Analysis, 2015, +! 53(3), 1350-1369 +! +! +! Please, report any problem or comment to : +! roberto dot garrappa at uniba dot it +! +! Copyright (c) 2015, Roberto Garrappa, University of Bari, Italy +! roberto dot garrappa at uniba dot it +! Homepage: http://www.dm.uniba.it/Members/garrappa +! Revision: 1.4 - Date: October 8 2015 +! +!====================================================================== +! +! Here we are! This is the steersman. +! +!===== +! + subroutine sub_genmlf_multishot ( & + afa, bta, gma, n, incz, z, ince, e ) +! +! use mod_mlf_garrappa +! + implicit none +! +! Input & Output: +! + real(rk),intent(in) :: afa, bta, gma + integer(ik),intent(in) :: n, incz, ince + complex(rk),dimension(incz,n),intent(in) :: z + complex(rk),dimension(ince,n),intent(out) :: e +! +! Dependencies: +! +! external :: worksub_ltinv_multishot +! real(rk) :: specfun_gamma +! external :: auxisub_initrandom +! +! work-space: +! + complex(rk),dimension(:),allocatable :: zws ! length = 2*m + real(rk),dimension(:),allocatable :: rws ! length = 6*m+1 + integer(ik),dimension(:),allocatable :: iws ! length = 2*m +! + integer(ik) :: m +! +! Local variables: +! + complex(rk) :: zinp, eout + real(rk) :: eps, log_eps, epsmul10 + real(rk) :: t, absz, argz, aagz + integer(ik) :: j + logical :: gma_is_not_one +! +! HERE WE GO +! + if ( afa .le. 0.0_rk .or. gma .le. 0.0_rk ) then + write(*,907) + return + endif +! + gma_is_not_one = abs(gma-1) .gt. reps +! + if ( gma_is_not_one .and. (afa > 1.0_rk) ) then + write(*,908) + return + endif +! +! afa=bta=gma=1 +! + if ( (.not. gma_is_not_one) .and. & + abs(afa-1) .lt. reps .and. & + abs(bta-1) .lt. reps ) then + do j = 1,n + e(1,j) = exp(z(1,j)) + enddo + return + endif +! +! Initializing RNG for the quick sort: +! + call auxisub_initrandom +! +! User defines epsilon or just use default values, i.e. 1.0e-15. +! This epsilon_value variable is maintained in the module above. +! Its value can be reset by, e.g., call mlf_set_epsilon( 1.0d-10 ) +! + eps = present_epsilon +! +! eps = 1.0e-15_rk ! The most accurate setting. +! eps = reps * 2 ! Values that are smaller than reps will give error +! eps = 1.0e-07_rk ! For larger values of eps, the code runs faster. +! + log_eps = log(eps) + epsmul10 = eps * 10 +! +! Other values of t=1 may not work. Hence, let us fix t=1. +! + t = 1.0_rk +! +! Preparing for work-space: +! + m = int(afa) + 2 +! + allocate( zws(1:2*m), rws(1:6*m+1), iws(1:2*m) ) +! +! Let's fly +! + do j = 1,n +! +! Input z(*): +! + zinp = z(1,j) +! + absz = abs( zinp ) + argz = atan2( aimag(zinp), real(zinp) ) + aagz = abs( argz ) +! +! Check parameters and arguments for the three parameter case +! + if ( gma_is_not_one .and. ( aagz <= afa*picons ) ) then + write(*,909) + return + endif +! +! Inversion of the LT for each element of z +! + if ( absz .lt. eps ) then +! + eout = 1.0_rk / specfun_gamma(bta) +! + else +! + zws(:) = cmplx(0.0_rk,0.0_rk,rk) + rws(:) = 0.0_rk + iws(:) = 0 +! + call worksub_ltinv_multishot ( & + t, zinp, afa, bta, gma, & + absz, argz, & + eps, log_eps, epsmul10, m, & + zws(1), zws(m+1), rws(1), rws(m+1), & + rws(2*m+2), rws(3*m+2), & + rws(4*m+2), rws(5*m+2), iws(1), & + iws(m+1), eout ) +! + endif +! +! Output: +! + e(1,j) = eout +! + enddo +! +! Dismiss: +! + deallocate( zws, rws, iws ) +! + return +! +907 format('ERROR: ml requires afa>0 and gma>0' ) +908 format('ERROR: |gma-1|>eps, ml requires 0 < ALPHA < 1' ) +909 format('ERROR: |gma-1|>eps, ml requires |Arg(z)| > afa*pi.') +! + end subroutine +! +!====================================================================== +! + subroutine worksub_ltinv_multishot ( & + t, z, afa, bta, gma, & + absz, argz, & + eps, log_eps, epsmul10, m, & + ztmp, s_star, rtmp, phi_s_star, & + p, q, array_mu, array_h, array_n, & + admissible_regions, E ) +! +! use mod_mlf_garrappa +! + implicit none +! +! Input & Output: +! + complex(rk),intent(out) :: E + real(rk),intent(in) :: t + complex(rk),intent(in) :: z + real(rk),intent(in) :: afa, bta, gma + real(rk),intent(in) :: absz, argz + real(rk),intent(in) :: eps, log_eps, epsmul10 +! +! Workspace: +! + integer,intent(in) :: m + complex(rk),dimension(m) :: ztmp + complex(rk),dimension(m) :: s_star + real(rk),dimension(m) :: rtmp + real(rk),dimension(m+1) :: phi_s_star + real(rk),dimension(m) :: p, q + real(rk),dimension(m) :: array_mu + real(rk),dimension(m) :: array_h + integer(ik),dimension(m) :: array_n + integer(ik),dimension(m) :: admissible_regions +! +! Dependencies: +! +! external :: primsub_optimalparam_rb +! +! Local variables: +! + complex(rk) :: e_integral, e_residues + complex(rk) :: zk, zd, fk + real(rk) :: rtm1, uk, muj, hj, mu, h, local_logeps + integer(ik) :: jj1, j1, nj, n, idmin, klp1 + integer(ik) :: kmin, kmax, k_vett + integer(ik) :: j, k, klen, n_admissible_regions + integer(ik) :: len_s_star, len_s_star_p1 + logical :: not_found_region +! +! GO +! + kmin = ceiling(-afa/2 - argz/pimul2 ) + kmax = floor ( afa/2 - argz/pimul2 ) +! + klen = kmax-kmin+1 + klp1 = klen+1 +! +! NOTE on the workspace: +! +! Most of actual workspaces require the length klen+1, except +! the array phi_s_star, which needs the length klen+2. +! +! Most of the provided workspaces have length m, except the +! array of the phi_s_star that is coming with length m+1. +! +! What is m ? +! +! m = int(afa) + 2 +! +! PROOF of the inequality m+1 >= klen+2: +! +! For any x in R, we have +! +! kmin = ceiling(-afa/2 - x ) >= -afa/2 - x +! kmax = floor ( afa/2 - x ) <= afa/2 - x +! +! Hence +! +! kmax-kmin <= afa/2 - x - (-afa/2 - x) = afa < int(afa) + 1 +! +! holds for any afa in R. Note that the inequality afa < int(afa)+1 +! does not allow the equality "=" to be happened. Hence, we have +! +! kmax-kmin < int(afa) + 1 +! +! Looking into both the sides, they all are integers. Therefore we +! conclude that +! +! kmax-kmin <= int(afa) holds for any afa in R. +! +! Wow ... so far, we conclude that +! +! klen = kmax-kmin+1 <= int(afa)+1 +! and +! klp1 = klen+1 <= int(afa)+2 = m (As defined above) +! +! Or, m+1 >= klen+2 (DONE). +! +! In this case, the longest workspace phi_s_star should have length +! of m+1, while others have that of m, where m = int(afa) + 2. For +! each input afa, we have the workspaces to works with an array of +! input z(:). +! +! +!@Evaluation of phi(s_star) for each pole +! + rtm1 = absz**(1.0_rk/afa) +! + do k = 1, klen + k_vett = kmin - 1 + k + s_star(k+1) = rtm1 * exp(iz*( argz + pimul2*k_vett )/afa) + phi_s_star(k+1) = (real(s_star(k+1),rk) + abs(s_star(k+1)))/2 + enddo +! +!@Sorting of the poles according to the value of phi(s_star) +! +! + if ( klen .gt. 1 ) then +! + call primsub_qsort_r8_idx ( klen, phi_s_star(2), array_n(1) ) +! +! Then, phi_s_star is sorted only by its indices. To get the task +! to be done, we perform +! + do k = 1,klen + rtmp(k) = phi_s_star(array_n(k)+1) + enddo +! + do k = 1,klen + phi_s_star(k+1) = rtmp(k) + enddo +! +! Then we arrange the s_star(:) according to the order of +! phi_s_star(:). +! + do k = 1,klen + ztmp(k) = s_star(array_n(k)+1) + enddo +! + do k = 1,klen + s_star(k+1) = ztmp(k) + enddo +! + endif +! +!@Deleting possible poles with phi_s_star=0 ... +! + len_s_star = 0 +! + do while ( phi_s_star(2) .le. eps .and. len_s_star .lt. klen ) +! + len_s_star = len_s_star + 1 +! +! Shift the arrays from-right-to-left for one index +! + do k = 2,klen + phi_s_star(k) = phi_s_star(k+1) + s_star(k) = s_star(k+1) + enddo +! +! until the fisrt element phi_s_star(1) > eps. In this case, +! we have phi_s_star(k) >= phi_s_star(1) > eps, for k>1, +! since phi_s_star(:) is increased. +! + enddo +! + len_s_star = klen - len_s_star +! + len_s_star_p1 = len_s_star + 1 +! + phi_s_star(1) = 0.0_rk + s_star(1) = cmplx(0.0_rk,0.0_rk,rk) +! +!@Strength of the singularities ... +! +! Now the effective length of phi_s_star = len_s_star+2, because +! phi_s_star = [ 0, phi_s_star, +Inf] ; +! + p(1) = max( 0.0_rk, -2*(afa*gma-bta+1) ) +! + do k = 2,len_s_star_p1 + p(k) = gma + enddo +! + do k = 1,len_s_star + q(k) = gma + enddo +! + q(len_s_star_p1) = rinf +! + phi_s_star(len_s_star_p1+1) = rinf +! +! So far, length(phi_s_star) must be >= len_s_star_p1 + 1 = klen+2 +! +!@Looking for the admissible regions with respect to round-off errors +! + do j = 1,klp1 + array_n(j) = -1 + enddo + + local_logeps = log_eps + + rtm1 = ( local_logeps - lnep ) / t +! + n_admissible_regions = 0 +! + do k = 1, len_s_star_p1 + if ( phi_s_star(k) .lt. rtm1 .and. & + phi_s_star(k) .lt. phi_s_star(k+1) ) then + array_n(k) = k + n_admissible_regions = n_admissible_regions + 1 + endif + enddo +! + if ( n_admissible_regions .gt. 0 ) then + + j = 0 + + do k = 1, len_s_star_p1 + if ( array_n(k) .gt. 0 ) then + j = j + 1 + admissible_regions(j) = array_n(k) + endif + enddo +! + jj1 = admissible_regions( n_admissible_regions ) +! + else +! + n_admissible_regions = 1 + jj1 = 1 +! + endif +! + do j = 1,klp1 + array_mu(j) = rinf + array_h(j) = rinf + array_n(j) = iinf + enddo +! +!@Evaluation of parameters for inversion of LT in each admissible region +! + not_found_region = .true. + + do while ( not_found_region ) + + do j = 1, n_admissible_regions + + j1 = admissible_regions (j) + + if ( j1 < len_s_star_p1 ) then + call primsub_optimalparam_rb ( & + t, phi_s_star(j1), phi_s_star(j1+1), & + p(j1), q(j1), local_logeps, epsmul10, & + muj, hj, nj ) + + else + call primsub_optimalparam_ru ( & + t, phi_s_star(j1), & + p(j1), local_logeps, epsmul10, & + muj, hj, nj ) + + endif + + array_mu(j1) = muj + array_h (j1) = hj + array_n (j1) = nj + + enddo +! + n = minval(array_n) +! + if ( n > 200 ) then + local_logeps = local_logeps + log(10.0_rk) + else + not_found_region = .false. + endif + + enddo +! +!@Selection of the admissible region for integration which involves the +! minimum number of nodes +! + idmin = 0 + n = iinf +! + do k = 1, jj1 + if ( n .gt. array_n (k) ) then + n = array_n (k) + idmin = k + endif + enddo +! + mu = array_mu(idmin) + h = array_h (idmin) +! +! Alright, from now on everything is transparent. +! +!@Evaluation of the inverse Laplace transform (herein z:=lambda) +! + e_integral = cmplx(0.0_rk,0.0_rk,rk) +! + do k = -n, n +! + uk = h*k + zk = mu*(iz*uk + 1)**2 + zd = 2*mu*(iz-uk) +! + fk = ( zk**(afa*gma-bta) / ((zk**afa - z)**gma) )*zd +! + e_integral = e_integral + fk*exp(zk*t) +! + enddo +! + e_integral = h* e_integral / pimul2 / iz +! +!@Evaluation of residues +! + e_residues = cmplx(0.0_rk,0.0_rk,rk) + + do k = idmin+1, len_s_star_p1 + e_residues = e_residues + & + (1/afa)*( s_star(k)**(1-bta) )*exp(t*s_star(k)) + enddo +! +!@Evaluation of the ML function +! + E = e_integral + e_residues +! + if (aimag(z) .eq. 0.0_rk) E = cmplx(real(E,rk),0.0_rk,rk) +! + return + end subroutine +!======================================================================= +! +! This routine sorts the array only by its index, i.e. idord. +! After calling, the ARRAY IS STILL UNCHANGED. To sort it, swap +! array(j) <-> array(idord(j)) for all j. +! +!===== +! + subroutine primsub_qsort_r8_idx ( n, array, idord ) +! +! use mod_mlf_garrappa +! + implicit none +! + integer(ik),intent(in) :: n + real(rk),dimension(n) :: array + integer(ik),dimension(n) :: idord +! +! Dependence: +! +! external :: primsub_r8_quick_sort +! +! local variables: +! + integer(ik) :: i +! + if ( n .lt. 2 ) return +! + do i = 1, n + idord(i) = i + enddo +! + call primsub_r8_quick_sort ( n, array, idord, 1, n ) +! + return + end subroutine +!===== + recursive subroutine primsub_r8_quick_sort ( & + n, array, idord, left, right ) +! +! use mod_mlf_garrappa +! + implicit none +! + integer(ik),intent(in) :: n + real(rk),dimension(n) :: array + integer(ik),dimension(n) :: idord + integer(ik),intent(in) :: left + integer(ik),intent(in) :: right +! +! Dependence: +! +! real(4) :: auxifun_uniran +! +! local variables: +! + integer(ik) :: i, last, itmp + integer(ik) :: ichoose +! +! GO +! + if ( left .ge. right ) return +! +! ichoose returns an integer ramdomly in the set +! of integers {left,left+1,...,right} +! (Make sure that we have initialized the RNG in advance) +! + ichoose = left + int(real(right-left+1)*auxifun_uniran()) +! + itmp = idord(left) + idord(left) = idord(ichoose) + idord(ichoose) = itmp +! + last = left +! + do i = left+1, right + if ( array(idord(i)) .lt. array(idord(left)) ) then + last = last + 1 + itmp = idord(last) + idord(last) = idord(i) + idord(i) = itmp + endif + enddo +! + itmp = idord(left) + idord(left) = idord(last) + idord(last) = itmp +! + call primsub_r8_quick_sort( n, array, idord, left, last-1 ) + call primsub_r8_quick_sort( n, array, idord, last+1, right ) +! + end subroutine +!====================================================================== +! + subroutine auxisub_initrandom + implicit none + integer,dimension(:),allocatable :: gieo + integer :: i, n + logical,save :: rng_not_yet_init = .true. +! + if (rng_not_yet_init) then + call random_seed(size=n) + allocate( gieo(n) ) + call system_clock(count=gieo(1)) + do i = 2,n + gieo(i) = gieo(i-1) + iand(gieo(i-1),31) + 1 + enddo + call random_seed(put=gieo) + deallocate( gieo ) + rng_not_yet_init = .false. + endif + return + end subroutine +!===== + function auxifun_uniran() result(r) + implicit none + real(4) :: r +! + call random_number( r ) +! + return + end function +!====================================================================== + function specfun_gamma (x) result(f) +! +! use mod_mlf_garrappa +! +!---------------------------------------------------------------------- +! +! This routine calculates the GAMMA function for a real argument X. +! Computation is based on an algorithm outlined in reference 1. +! The program uses rational functions that approximate the GAMMA +! function to at least 20 significant decimal digits. Coefficients +! for the approximation over the interval (1,2) are unpublished. +! Those for the approximation for X .GE. 12 are from reference 2. +! The accuracy achieved depends on the arithmetic system, the +! compiler, the intrinsic functions, and proper selection of the +! machine-dependent constants. +! +!******************************************************************* +!******************************************************************* +! +! Explanation of machine-dependent constants. Let +! +! BETA - radix for the floating-point representation +! MAXEXP - the smallest positive power of beta that overflows +! +! Then the following machine-dependent constants must be declared +! in DATA statements. IEEE values are provided as a default. +! +! XBIG - the largest argument for which GAMMA(X) is representable +! in the machine, i.e., the solution to the equation +! GAMMA(XBIG) = BETA**MAXEXP +! XINF - the largest machine representable floating-point number; +! approximately BETA**MAXEXP, XINF = huge(XINF) +! EPS - the smallest positive floating-point number such that +! 1.0+EPS .GT. 1.0, EPS = epsilon(EPS) +! XMININ - the smallest positive floating-point number such that +! 1/XMININ is machine representable, XMININ = tiny(XMININ) +! +! Approximate values for some important machines are: +! +! beta maxexp XBIG +! +! CRAY-1 (S.P.) 2 8191 966.961 +! Cyber 180/855 +! under NOS (S.P.) 2 1070 177.803 +! IEEE (IBM/XT, +! SUN, etc.) (S.P.) 2 128 35.040 +! IEEE (IBM/XT, +! SUN, etc.) (D.P.) 2 1024 171.624 <--* +! IBM 3033 (D.P.) 16 63 57.574 +! VAX D-Format (D.P.) 2 127 34.844 +! VAX G-Format (D.P.) 2 1023 171.489 +! +! +!*** huge(.) epsilon(.) tiny(.) +! +! XINF EPS XMININ +! +! CRAY-1 (S.P.) 5.45E+2465 7.11E-15 1.84E-2466 +! Cyber 180/855 +! under NOS (S.P.) 1.26E+322 3.55E-15 3.14E-294 +! IEEE (IBM/XT, +! SUN, etc.) (S.P.) 3.40E+38 1.19E-7 1.18E-38 +! IEEE (IBM/XT, +! SUN, etc.) (D.P.) 1.79D+308 2.22D-16 2.23D-308 +! IBM 3033 (D.P.) 7.23D+75 2.22D-16 1.39D-76 +! VAX D-Format (D.P.) 1.70D+38 1.39D-17 5.88D-39 +! VAX G-Format (D.P.) 8.98D+307 1.11D-16 1.12D-308 +! +!******************************************************************* +!******************************************************************* +! +! Error returns (This is what I need: ERROR TRAPPING) +! +! The program returns the value XINF for singularities or +! when overflow would occur. The computation is believed +! to be free of underflow and overflow. +! +! +! Intrinsic functions required are: +! +! INT, DBLE, EXP, LOG, REAL, SIN +! +! +! References: "An Overview of Software Development for Special +! Functions", W. J. Cody, Lecture Notes in Mathematics, +! 506, Numerical Analysis Dundee, 1975, G. A. Watson +! (ed.), Springer Verlag, Berlin, 1976. +! +! Computer Approximations, Hart, Et. Al., Wiley and +! sons, New York, 1968. +! +! Latest modification: March 12, 1992 +! +! Authors: W. J. Cody and L. Stoltz +! Applied Mathematics Division +! Argonne National Laboratory +! Argonne, IL 60439 +! +! Modified by Tran Quoc Viet, viet204@gmail.com +! Sat Apr 28 17:13:38 +07 2018 +! Hey. We actually have an intrinsic gamma function in Fortran +! (for version >= 90). But I like some portable thing. +! +!---------------------------------------------------------------------- +! +! Input & Output: +! + real(rk) :: f + real(rk),intent(in) :: x +! +! Local variables: +! + integer(ik) :: i, n + logical :: logipar + real(rk) :: fact, res, sss, xden, xnum, y, y1, ysq, z +! +!---------------------------------------------------------------------- +! Mathematical constants (CLEANED) +!---------------------------------------------------------------------- +!s data one,half,twelve,two,zero/1.0e0,0.5e0,12.0e0,2.0e0,0.0e0/, & +!s sqrtpi/0.9189385332046727417803297e0/, & +!s pi/3.1415926535897932384626434e0/ +! +! real(rk),parameter :: & +! picons= 3.141592653589793238462643383279502884197e+0_rk, &!pi +! sqrtpi= 1.772453850905516027298167483341145182798e+0_rk !pi^0.5 +! +!---------------------------------------------------------------------- +! Machine dependent parameters (DEFINED ABOVE) +!---------------------------------------------------------------------- +!s data xbig,xminin,eps/35.040e0,1.18e-38,1.19e-7/, & +!s xinf/3.4e38/ +! +!d data xbig,xminin,eps/171.624_rk,2.23d-308,2.22d-16/, & +!d xinf/1.79d308/ +!---------------------------------------------------------------------- +! Numerator and denominator coefficients for rational minimax +! approximation over (1,2). +!---------------------------------------------------------------------- +!S DATA P/-1.71618513886549492533811E+0,2.47656508055759199108314E+1, +!S 1 -3.79804256470945635097577E+2,6.29331155312818442661052E+2, +!S 2 8.66966202790413211295064E+2,-3.14512729688483675254357E+4, +!S 3 -3.61444134186911729807069E+4,6.64561438202405440627855E+4/ +!S DATA Q/-3.08402300119738975254353E+1,3.15350626979604161529144E+2, +!S 1 -1.01515636749021914166146E+3,-3.10777167157231109440444E+3, +!S 2 2.25381184209801510330112E+4,4.75584627752788110767815E+3, +!S 3 -1.34659959864969306392456E+5,-1.15132259675553483497211E+5/ +! + real(rk),dimension(8),parameter :: & + p = (/ -1.71618513886549492533811e+0_rk, & + 2.47656508055759199108314e+1_rk, & + -3.79804256470945635097577e+2_rk, & + 6.29331155312818442661052e+2_rk, & + 8.66966202790413211295064e+2_rk, & + -3.14512729688483675254357e+4_rk, & + -3.61444134186911729807069e+4_rk, & + 6.64561438202405440627855e+4_rk /), & + q = (/ -3.08402300119738975254353e+1_rk, & + 3.15350626979604161529144e+2_rk, & + -1.01515636749021914166146e+3_rk, & + -3.10777167157231109440444e+3_rk, & + 2.25381184209801510330112e+4_rk, & + 4.75584627752788110767815e+3_rk, & + -1.34659959864969306392456e+5_rk, & + -1.15132259675553483497211e+5_rk /) +! +!---------------------------------------------------------------------- +! Coefficients for minimax approximation over (12, INF). +!---------------------------------------------------------------------- +!s data c/-1.910444077728e-03,8.4171387781295e-04, +!s 1 -5.952379913043012e-04,7.93650793500350248e-04, +!s 2 -2.777777777777681622553e-03,8.333333333333333331554247e-02, +!s 3 5.7083835261e-03/ +! + real(rk),dimension(7),parameter :: & + c = (/ -1.910444077728e-03_rk, & + 8.4171387781295e-04_rk, & + -5.952379913043012e-04_rk, & + 7.93650793500350248e-04_rk, & + -2.777777777777681622553e-03_rk, & + 8.333333333333333331554247e-02_rk, & + 5.7083835261e-03_rk /) +! +!---------------------------------------------------------------------- +! GO +! + logipar = .false. + fact = 1.0_rk + n = 0 + y = x +! + if (y .le. 0.0_rk ) then +! +! Argument is negative +! + y = -x + y1 = aint(y,kind=rk) + res = y - y1 + if (res .ne. 0.0_rk) then + if (y1 .ne. aint(y1*0.5_rk,kind=rk)*2.0_rk) logipar = .true. + fact = -picons / sin(picons*res) + y = y + 1.0_rk + else + res = rinf + goto 900 + endif + endif +! +! Argument is positive +! + if ( y .lt. reps ) then +! +! Argument .LT. EPS +! + if ( y .ge. rtin ) then + res = 1.0_rk / y + else + res = rinf + goto 900 + endif + else if (y .lt. 12.0_rk ) then + y1 = y + if (y .lt. 1.0_rk ) then +! +! 0.0 .LT. argument .LT. 1.0 +! + z = y + y = y + 1.0_rk + else +! +! 1.0 .LT. argument .LT. 12.0, reduce argument if necessary +! + n = int(y) - 1 + y = y - dble(n) ! conv + z = y - 1.0_rk + endif +! +! Evaluate approximation for 1.0 .LT. argument .LT. 2.0 +! + xnum = 0.0_rk + xden = 1.0_rk + do i = 1, 8 + xnum = (xnum + p(i)) * z + xden = xden * z + q(i) + enddo + res = xnum / xden + 1.0_rk + if (y1 .lt. y) then +! +! Adjust result for case 0.0 .LT. argument .LT. 1.0 +! + res = res / y1 + else if (y1 .gt. y) then +! +! Adjust result for case 2.0 .LT. argument .LT. 12.0 +! + do i = 1, n + res = res * y + y = y + 1.0_rk + enddo + endif + else +! +! Evaluate for argument .GE. 12.0, +! + if ( y .le. xbig ) then + ysq = y * y + sss = c(7) + do i = 1, 6 + sss = sss / ysq + c(i) + enddo + sss = sss/y - y + sqrtpi + sss = sss + (y-0.5_rk)*log(y) + res = exp(sss) + else + res = rinf + goto 900 + endif + endif +! +! Final adjustments and return +! + if ( logipar ) res = -res + if ( fact .ne. 1.0_rk ) res = fact / res +! + 900 f = res +! + return + end function specfun_gamma +!======================================================================= +! +! Finding optimal parameters in a right-bounded region +! +!===== +! + subroutine primsub_optimalparam_rb ( & + t, phi_s_star_j, phi_s_star_j1, & + pj, qj, log_eps, epsmul10, & + muj, hj, nj ) +! +! use mod_mlf_garrappa +! + implicit none +! +! Input & Output: +! + real(rk),intent(in) :: t, phi_s_star_j, phi_s_star_j1, pj, qj + real(rk),intent(in) :: log_eps, epsmul10 + real(rk),intent(out) :: muj, hj + integer(ik),intent(out) :: nj +! +! Local variables: +! We shall copy value of the input log_eps to a local variable, +! say local_logeps. Since we shall correct this value internally. +! The value of log_eps outside this scope is unchanged. +! + real(rk) :: local_logeps + real(rk) :: fac, f_max, f_min, f_bar, fq, fp, den, w + logical :: conservative_error_analysis + real(rk) :: sq_phi_star_j, threshold, sq_phi_star_j1 + real(rk) :: sq_phibar_star_j, sq_phibar_star_j1 + logical :: adm_region +! +! GO +! + local_logeps = log_eps + + fac = 1.01_rk + + conservative_error_analysis = .true. + +!@Maximum value of fbar as the ration between tolerance and round-off unit + + f_max = exp(local_logeps - lnep) + +!@Evaluation of the starting values for sq_phi_star_j and sq_phi_star_j1 + + sq_phi_star_j = sqrt(phi_s_star_j) + threshold = 2*sqrt((local_logeps - lnep)/t) + sq_phi_star_j1 = min(sqrt(phi_s_star_j1), threshold-sq_phi_star_j) + +!@Zero or negative values of pj and qj + + if ( pj < epsmul10 ) then +! + if ( qj < epsmul10 ) then +! + sq_phibar_star_j = sq_phi_star_j + sq_phibar_star_j1 = sq_phi_star_j1 + adm_region = .true. +! + else +! + sq_phibar_star_j = sq_phi_star_j +! + if ( sq_phi_star_j > 0.0_rk ) then + f_min = fac*( sq_phi_star_j / & + (sq_phi_star_j1 - sq_phi_star_j) )**qj + else + f_min = fac + endif +! + if ( f_min < f_max ) then + f_bar = f_min + (f_min/f_max)*(f_max-f_min) + fq = f_bar**(-1.0_rk/qj) + sq_phibar_star_j1 = ( 2 *sq_phi_star_j1 - & + fq*sq_phi_star_j ) / (2+fq) + adm_region = .true. + else + adm_region = .false. + endif +! + endif +! + else +! + if ( qj < epsmul10 ) then +! + sq_phibar_star_j1 = sq_phi_star_j1 + f_min = fac*( sq_phi_star_j1 / & + (sq_phi_star_j1-sq_phi_star_j) )**pj +! + if ( f_min < f_max ) then + f_bar = f_min + (f_min/f_max)*(f_max-f_min) + fp = f_bar**(-1.0_rk/pj) + sq_phibar_star_j = ( 2 *sq_phi_star_j + & + fp*sq_phi_star_j1 )/(2-fp) + adm_region = .true. + else + adm_region = .false. + endif +! + else +! + f_min = fac * (sq_phi_star_j+sq_phi_star_j1) / ( & + (sq_phi_star_j1-sq_phi_star_j)**max(pj,qj) ) +! + if ( f_min < f_max ) then +! + f_min = max(f_min,1.5_rk) + f_bar = f_min + (f_min/f_max)*(f_max-f_min) +! + fp = f_bar**(-1.0_rk/pj) + fq = f_bar**(-1.0_rk/qj) +! + if ( conservative_error_analysis ) then + w = -phi_s_star_j1 * t / local_logeps + else + w =-2*phi_s_star_j1*t/(local_logeps-phi_s_star_j1*t) + endif +! + den = 2 + w - (1+w)*fp + fq +! + sq_phibar_star_j = ( (2+w+fq)*sq_phi_star_j + & + fp *sq_phi_star_j1 )/den + sq_phibar_star_j1 = (-(1+w)*fq *sq_phi_star_j + & + (2+w-(1+w)*fp)*sq_phi_star_j1 )/den +! + adm_region = .true. +! + else + adm_region = .false. + endif +! + endif +! + endif +! +! +! + if ( adm_region ) then +! + local_logeps = local_logeps - log(f_bar) +! + if ( conservative_error_analysis ) then + w = -sq_phibar_star_j1**2 * ( t/local_logeps ) + else + w = -2*sq_phibar_star_j1**2 * t /( & + local_logeps - sq_phibar_star_j1**2 * t ) + endif +! + muj = ( ( (1+w)*sq_phibar_star_j + & + sq_phibar_star_j1 )/(2+w) )**2 +! + hj = -( pimul2/local_logeps ) * ( & + sq_phibar_star_j1 - sq_phibar_star_j ) / ( & + (1+w)*sq_phibar_star_j + sq_phibar_star_j1 ) +! + nj = ceiling( sqrt(1.0_rk-local_logeps/t/muj)/hj ) +! + else +! + muj = 0.0_rk + hj = 0.0_rk + nj = iinf +! + endif +! + return + end subroutine primsub_optimalparam_rb +! +!======================================================================= +! +! Finding optimal parameters in a right-unbounded region +! +!===== +! + subroutine primsub_optimalparam_ru ( & + t, phi_s_star_j, & + pj, log_eps, epsmul10, & + muj, hj, nj ) +! +! use mod_mlf_garrappa +! + implicit none +! +! Input & Output: +! + real(rk),intent(in) :: t, phi_s_star_j, pj + real(rk),intent(in) :: log_eps, epsmul10 + real(rk),intent(out) :: muj, hj + integer(ik),intent(out) :: nj +! +! Local varaibles: +! + logical :: istop + real(rk) :: f_min, f_max, f_tar, fbar, A, Q, w, u + real(rk) :: sq_muj, log_eps_phi_t, phi_t, threshold + real(rk) :: sq_phi_s_star_j, sq_phibar_star_j, phibar_star_j +! +! GO +! +!@Evaluation of the starting values for sq_phi_star_j +! + sq_phi_s_star_j = sqrt(phi_s_star_j) + + if ( phi_s_star_j > 0.0_rk ) then + phibar_star_j = phi_s_star_j*1.01_rk + else + phibar_star_j = 1.0e-02_rk + endif + + sq_phibar_star_j = sqrt(phibar_star_j) + +!@Definition of some constants + + f_min = 1.0_rk + f_max = 10.0_rk + f_tar = 5.0_rk + +!@Iterative process to look for fbar in [f_min,f_max] + + istop = .false. + do + + phi_t = phibar_star_j * t + log_eps_phi_t = log_eps / phi_t + + nj = ceiling((phi_t/picons)*( 1 - 1.5_rk*log_eps_phi_t + & + sqrt(1-2*log_eps_phi_t) ) ) + A = picons * nj / phi_t + + sq_muj = sq_phibar_star_j * abs(4-A) / abs(7-sqrt(1+12*A)) + fbar = ((sq_phibar_star_j-sq_phi_s_star_j)/sq_muj)**(-pj) + istop = (pj < epsmul10) .or. (f_min < fbar .and. fbar < f_max) + + if ( istop ) then + exit + else + sq_phibar_star_j = f_tar**(-1.0_rk/pj) * sq_muj + & + sq_phi_s_star_j + phibar_star_j = sq_phibar_star_j**2 + endif + + enddo + + muj = sq_muj**2 + hj = ( -3*A - 2 + 2*sqrt(1+12*A) )/(4-A)/real(nj,rk) + +!@Adjusting integration parameters to keep round-off errors under control + + threshold = (log_eps - lnep) / t +! + if ( muj > threshold ) then +! + if ( abs(pj) < epsmul10 ) then + Q = 0.0_rk + else + Q = f_tar**(-1.0_rk/pj) * sqrt(muj) + endif +! + phibar_star_j = ( Q + sqrt(phi_s_star_j) )**2 +! + if ( phibar_star_j < threshold ) then +! + w = sqrt(lnep/(lnep-log_eps)) + u = sqrt(-phibar_star_j*t/lnep) +! + muj = threshold + nj = ceiling( w*log_eps/ pimul2 / (u*w-1.0_rk) ) + hj = sqrt(lnep/(lnep - log_eps))/real(nj,rk) +! + else +! + nj = iinf + hj = 0 +! + endif +! + endif +! + return + end subroutine primsub_optimalparam_ru +!======================================================================= +! +! Derivative of Mittag-Leffer function with two parameters. +! +! Applying THEOREM 4.1 of the Gorenflo's paper. Make sure that afa>0 +! +!===== + subroutine sub_dermlf_multishot ( & + afa, bta, n, incz, z, ince, f ) +! +! use mod_mlf_garrappa +! + implicit none +! +! Input & Output: using explicit-shape array +! + real(rk),intent(in) :: afa, bta + integer(ik),intent(in) :: n, incz, ince + complex(rk),dimension(incz,n),intent(in) :: z + complex(rk),dimension(ince,n),intent(out) :: f +! +! Dependencies: +! +! external :: sub_genmlf_multishot +! real(rk) :: specfun_gamma +! +! Local varaibles: +! + real(rk),parameter :: qconst = 0.99e0_rk + complex(rk) :: zloc(4) + real(rk) :: d, w, absz, rho + integer :: k, k0, k1, nz, j +! +! Check if the arguments afa>0. Otherwise, do nothing and report. +! +! if ( afa .le. 0.0_rk ) then +! write(012,'(a)') 'ERROR: Input to fmld1 wrong, afa<=0,',afa +! return +! endif +! + do j = 1,n +! + zloc(1) = z(1,j) + absz = abs(zloc(1)) +! + if ( absz .eq. 0.0_rk ) then +! +! For |z|=0: use Eq. (38) only for k=0, the remainder +! as k>0 is zero +! + zloc(2) = 1.0_rk / specfun_gamma( afa + bta ) + + else if ( absz .le. qconst ) then +! +! Applying THEOREM 4.1 exactly: +! +! For 0<|z|<=q, where we choose q=qconst, +! +! + Calculating k1 from (40) for cases of afa and D: +! + if ( afa .le. 1.0_rk ) then +! +! For afa<=1: from (40) +! + d = afa*(afa - 4.0_rk*bta + 6.0_rk) + 1.0_rk +! + if ( d .gt. 0.0_rk ) then + w = afa + bta - 1.5_rk + k1 = max( floor((3.0_rk - afa - bta)/afa) + 1, & + floor((1.0_rk - 2.0_rk*w*afa + sqrt(d) & + )/(2.0_rk*afa*afa)) + 1 ) + else + k1 = floor( (3.0_rk-afa-bta)/afa ) + 1 + endif + + else +! +! For afa>1: from (40) +! + k1 = floor( (2.0_rk-afa-bta)/(afa-1.0_rk) ) + 1 + + endif +! +! + Calculating k0 from k1, for computing (39): +! +!Hint: You may want to edit something right below here to estimate +! the truncation errors by the relative error estimate, +! instead of the absolute error estimate. Check, plz! +! + rho = present_epsilon + k0 = max( k1, floor(log(rho*(1.0_rk-absz))/log(absz)) ) +! +! + Calculating E' from (39): summing up directly for k=0,k0 +! + zloc(2) = 1/ specfun_gamma( afa + bta ) +! + do k = 1,k0 + zloc(2) = zloc(2) + (k+1)*zloc(1)**k / & + specfun_gamma(afa+bta+afa*k) + enddo +! + else +! +! For |z|>q, where q=0.1, use (43) with Mittag-Leffler +! function +! + call sub_genmlf_multishot ( & + afa, bta-1.0_rk, 1.0_rk, 1, 1, zloc(1), 1, zloc(3) ) +! + call sub_genmlf_multishot ( & + afa, bta, 1.0_rk, 1, 1, zloc(1), 1, zloc(4) ) +! + zloc(2) = ( zloc(3) - zloc(4)*(bta-1.0_rk) )/(afa*zloc(1)) +! + endif +! + f(1,j) = zloc(2) +! + enddo + return + end subroutine +!======================================================================= + end module mod_mlf_garrappa +!====================================================================== + +! __END__ diff --git a/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/phi_function.f90 b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/phi_function.f90 new file mode 100644 index 0000000..46b9573 --- /dev/null +++ b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/phi_function.f90 @@ -0,0 +1,247 @@ +! +!======================================================================= +! +MODULE PHI_FUNCTION +! + USE ACCURACY_REAL +! +CONTAINS +! +! +!======================================================================= +! + FUNCTION PHI(X,THETA) +! +! This function compute the phi(x,theta) function +! defined in reference (1) +! +! +! References: (1) R. G. Dandrea, N. W. Ashcroft and A. E. Carlsson, +! Phys. Rev. B 34, 2097-2111 (1986) +! +! Input parameters: +! +! * X : input parameter +! * THETA : dimensionless temperature k_B T / E_F +! +! +! Author : D. Sébilleau +! +! Last modified : 21 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,SIX,SEVEN,EIGHT,TEN, & + HALF + USE PI_ETC, ONLY : PI2,SQR_PI + USE SQUARE_ROOTS, ONLY : SQR2 +! + IMPLICIT NONE +! + REAL (WP) :: X,THETA,PHI,PHI_TILDE + REAL (WP) :: S_NUM,S_DEN +! + REAL (WP) :: A2,A4,A6,A8 + REAL (WP) :: B2,B4,B6,B8,B10 + REAL (WP) :: NUM,DEN,JJ,KK + REAL (WP) :: A(5),B(6),C(6),D(6) + REAL (WP) :: J(5),K(5) + REAL (WP) :: T,TS,T2,T3,T4,T5,T6,T7,T8,T9,T10 + REAL (WP) :: X2,X4,X6,X8,X10 +! + DATA A / -0.2280E0_WP, 0.4222E0_WP, -0.6466E0_WP, & ! coef. eq. (A21) + 0.70572E0_WP, 5.88200E0_WP / ! + DATA B / -3.0375E0_WP, 64.646E0_WP , 19.608E0_WP, & ! coef. eq. (A22) + -96.978E0_WP, 423.66E0_WP, -331.01E0_WP / ! + DATA C / -0.1900E0_WP, 0.36538E0_WP, -2.2575E0_WP, & ! coef. eq. (A23) + 22.942E0_WP, -43.492E0_WP, 106.40E0_WP / ! + DATA D / -7.1316E0_WP, 22.725E0_WP, 58.092E0_WP, & ! coef. eq. (A24) + -436.02E0_WP, -826.51E0_WP, 4912.9E0_WP / ! +! + DATA J / 3248.8E0_WP, -691.47E0_WP,-3207700.E0_WP, & ! coef. eq. (A19) + -4535.6E0_WP,-462400.0E0_WP / ! + DATA K / -4.8780E0_WP, 473.25E0_WP, -2337.5E0_WP, & ! coef. eq. (A20) + 348.31E0_WP, 1517.3E0_WP / ! +! +! Powers of theta +! + T =THETA ! + T2 =T*T ! + T3 =T2*T ! + T4 =T3*T ! + T5 =T4*T ! + T6 =T5*T ! + T7 =T6*T ! + T8 =T7*T ! + T9 =T8*T ! + T10=T9*T ! +! +! Powers of x +! + X2 =X*X ! + X4 =X2*X2 ! + X6 =X4*X2 ! + X8 =X6*X2 ! + X10=X8*X2 ! +! + NUM=A(1)+T ! + DEN=A(2) + A(3)*T**A(4) + A(5)*T2 ! + A2=NUM/DEN ! eq. (A21) +! + NUM=ONE+B(1)*T+B(2)*T2 ! + DEN=B(3)+B(4)*T+B(5)*T2+B(6)*T3+20.833E0_WP*B(2)*T4 ! + A4=NUM/DEN ! eq. (A22) +! + NUM=C(1)+T ! + DEN=C(2)+C(3)*T+C(4)*T2+C(5)*T3+C(6)*T4 ! + A6=NUM/DEN ! eq. (A23) +! + NUM=0.91E0_WP-6.4453E0_WP*T+12.2324E0_WP*T2 ! + DEN=ONE+D(1)*T+D(2)*T2+D(3)*T3+D(4)*T4+D(5)*T5+D(6)*T6 ! + A8=NUM/DEN ! eq. (A24) +! + NUM=ONE+J(1)*T2+J(2)*T4+J(3)*T7 ! + DEN=ONE+ (J(1)-PI2/SIX)*T2 + J(4)*T4 + J(5)*T6 + & ! + (0.75E0_WP*SQR2*J(3)/SQR_PI)*T7*TS + & ! + 0.75E0_WP*J(3)*T9 ! + JJ=NUM/DEN ! eq. (A19) +! + NUM=ONE+K(1)*T2+K(2)*T4+K(3)*T7 ! + DEN=ONE+ (K(1)-0.75E0_WP*PI2)*T2 + K(4)*T4 + K(5)*T7 - & ! + (SEVEN*SQR2*K(3)/(EIGHT*SQR_PI))*T8*TS - & ! + (THREE*K(3)/EIGHT)*T10 ! + KK=NUM/DEN ! eq. (A20) +! + B10=1.5E0_WP*TS*FD_APP(THETA,'M1_2')*A8 ! eq. (A12) + B8 =1.5E0_WP*TS*FD_APP(THETA,'M1_2')*A6 - & ! eq. (A13) + HALF*TS*T2*FD_APP(THETA,'P3_2')*B10 ! + B6 =1.5E0_WP*TS*FD_APP(THETA,'M1_2')*A4 - & ! eq. (A14) + HALF*TS*T2*FD_APP(THETA,'P3_2')*B8 - & ! + THREE*TS*T3*FD_APP(THETA,'P5_2')*B10 /TEN ! + B2 =A2+TWO*JJ/(THREE*TS*FD_APP(THETA,'M1_2')) ! eq. (A15) + B4 =B2*B2-A2*B2+A4+TWO*KK/(15.0E0_WP*TS*FD_APP(THETA,'M1_2')) ! eq. (A16) +! +! Calculation of PHI_TILDE +! + S_NUM=ONE+A2*X2+A4*X4+A6*X6+A8*X8 ! + S_DEN=ONE+B2*X2+B4*X4+B6*X6+B8*X8+B10*X10 ! +! + PHI_TILDE=S_NUM/S_DEN ! eq. (4.8b) +! + PHI=TS*FD_APP(THETA,'M1_2')*X*PHI_TILDE ! eq. (4.8a) +! + END FUNCTION PHI +! +!======================================================================= +! + FUNCTION FD_APP(THETA,TYP) +! +! This function compute the Padé approximants for the Fermi integrals, +! as defined in reference (1) +! +! +! References: (1) R. G. Dandrea, N. W. Ashcroft and A. E. Carlsson, +! Phys. Rev. B 34, 2097-2111 (1986) +! +! Input parameters: +! +! * THETA : dimensionless temperature k_B T / E_F +! * TYP : type of Fermi integral +! TYP = 'M1_2' --> eq. (A1) +! TYP = 'D1_2' --> eq. (A2) +! TYP = 'P3_2' --> eq. (A3) +! TYP = 'P5_2' --> eq. (A4) +! +! +! Author : D. Sébilleau +! +! Last modified : 21 Jul 2020 +! +! + USE REAL_NUMBERS, ONLY : ONE,TWO,THREE,FOUR,FIVE,SIX,SEVEN,& + HALF,FOURTH,FIFTH,SIXTH + USE PI_ETC, ONLY : PI2,SQR_PI + USE SQUARE_ROOTS, ONLY : SQR2 +! + IMPLICIT NONE +! + CHARACTER (LEN = 4) :: TYP +! + REAL (WP) :: THETA + REAL (WP) :: FD_APP + REAL (WP) :: T,T2,T3,T4,T5,T6,T7,T8,T9,SQR_T + REAL (WP) :: C1,C2,C3,C4,C5 + REAL (WP) :: COEF,NUM,DEN +! +! Powers of theta +! + T =THETA ! + T2 =T*T ! + T3 =T2*T ! + T4 =T3*T ! + T5 =T4*T ! + T6 =T5*T ! + T7 =T6*T ! + T8 =T7*T ! + T9 =T8*T ! + SQR_T=DSQRT(T) ! +! + IF(TYP == 'M1_2') THEN ! +! + C1=41.775E0_WP ! + C2=27.390E0_WP ! + C3=4287.2E0_WP ! table I. + C4=50.605E0_WP ! + COEF=TWO/SQR_T ! + NUM=ONE + C1*T2 + C2*T4 + C3*T6 ! + DEN=ONE + (C1 + PI2/12.0E0_WP)*T2 + C4*T4 + & ! + (C3 / (SQR2*SQR_PI))*T5*SQR_T + (THREE*HALF*C3)*T7! +! + FD_APP=COEF*NUM/DEN ! ref. (1) eq. (A1) +! + ELSEIF(TYP == 'D1_2') THEN ! +! + C1=2.2277E0_WP ! + C2=126.92E0_WP ! + C3=5248.0E0_WP ! + C4=97.720E0_WP ! table I. + C5=861.30E0_WP ! + COEF=SQR_T ! + NUM=ONE + C1*T2 + C2*T4 + C3*T7 ! + DEN=ONE + (C1 - PI2/SIXTH)*T2 + C4*T4 + C5*T6 + & ! + (THREE*SQR2*FOURTH*C3/SQR_PI)*T7*SQR_T + & ! + (THREE*FOURTH*C3)*T9 ! +! + FD_APP=COEF*NUM/DEN ! ref. (1) eq. (A2) +! + ELSEIF(TYP == 'P3_2') THEN ! +! + C1= 5.3588E0_WP ! + C2=-2.5433E0_WP ! + C3= 432.89E0_WP ! + C4= 1.8800E0_WP ! table I. + COEF=TWO / (FIVE*T2*SQR_T) ! + NUM=ONE + C1*T2 + C2*T4 + C3*T8 ! + DEN=ONE + (C1 - FIVE*PI2/12.0E0_WP)*T2 + C4*T4 - & ! + (TWO*C3 / (15.0E0_WP*SQR2*SQR_PI))*T5*SQR_T + & ! + (TWO*FIFTH*C3)*T7 ! +! + FD_APP=COEF*NUM/DEN ! ref. (1) eq. (A3) +! + ELSEIF(TYP == 'P5_2') THEN ! +! + C1=-8.61640E0_WP ! + C2=-357.410E0_WP ! table I. + C3= 5711.10E0_WP ! + COEF=TWO / (SEVEN*T3*SQR_T) ! + NUM=ONE + C1*T2 + C2*T4 + C3*T7*SQR_T ! + DEN=ONE + (C1-SEVEN*PI2*SIXTH)*T2 - & ! + (SQR2*C3 / (35.0E0_WP*SQR_PI))*T4 + & ! + (FOUR*C3*FIFTH)*T5*SQR_T ! +! + FD_APP=COEF*NUM/DEN ! ref. (1) eq. (A4) +! + END IF ! +! + END FUNCTION FD_APP +! +END MODULE PHI_FUNCTION diff --git a/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/sph_bessel.f90 b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/sph_bessel.f90 new file mode 100644 index 0000000..14e0b77 --- /dev/null +++ b/New_libraries/DFM_library/VARIOUS_FUNCTIONS_LIBRARY/sph_bessel.f90 @@ -0,0 +1,169 @@ +! +!======================================================================= +! +MODULE SPH_BESSEL +! +! This module provides the spherical Bessel functions +! +! It contains the following functions: +! +! * FUNCTION SPH_BESSJ0(X) --> j_0(X) +! * FUNCTION SPH_BESSJ1(X) --> j_1(X) +! * FUNCTION SPH_BESSN0(X) --> n_0(X) +! * FUNCTION SPH_BESSN1(X) --> n_1(X) +! * FUNCTION SPH_BESSI0(X) --> i_0(X) +! * FUNCTION SPH_BESSI1(X) --> i_1(X) +! * FUNCTION SPH_BESSK0(X) --> k_0(X) +! * FUNCTION SPH_BESSK1(X) --> k_1(X) +! +! Modules used: ACCURACY_REAL +! + USE ACCURACY_REAL +! +CONTAINS +! +!======================================================================= +! + FUNCTION SPH_BESSJ0(X) +! +! This function calculates the first kind spherical Bessel function +! of order 0 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: SPH_BESSJ0 +! + REAL (WP) :: DSIN +! + SPH_BESSJ0 = DSIN(X) / X ! +! + END FUNCTION SPH_BESSJ0 +! +!======================================================================= +! + FUNCTION SPH_BESSJ1(X) +! +! This function calculates the first kind spherical Bessel function +! of order 1 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: SPH_BESSJ1 +! + REAL (WP) :: DSIN,DCOS +! + SPH_BESSJ1 = DSIN(X) / (X*X) - DCOS(X) / X ! +! + END FUNCTION SPH_BESSJ1 +! +!======================================================================= +! + FUNCTION SPH_BESSN0(X) +! +! This function calculates the second kind spherical Bessel function +! of order 0 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: SPH_BESSN0 +! + REAL (WP) :: DCOS +! + SPH_BESSN0 = - DCOS(X) / X ! +! + END FUNCTION SPH_BESSN0 +! +!======================================================================= +! + FUNCTION SPH_BESSN1(X) +! +! This function calculates the second kind spherical Bessel function +! of order 1 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: SPH_BESSN1 +! + REAL (WP) :: DSIN,DCOS +! + SPH_BESSN1 = - DCOS(X) / (X*X) - DSIN(X) / X ! +! + END FUNCTION SPH_BESSN1 +! +!======================================================================= +! + FUNCTION SPH_BESSI0(X) +! +! This function calculates the first kind modified spherical Bessel function +! of order 0 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: SPH_BESSI0 +! + REAL (WP) :: DSINH +! + SPH_BESSI0 = DSINH(X) / X ! +! + END FUNCTION SPH_BESSI0 +! +!======================================================================= +! + FUNCTION SPH_BESSI1(X) +! +! This function calculates the first kind modified spherical Bessel function +! of order 1 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: SPH_BESSI1 +! + REAL (WP) :: DSINH,DCOSH +! + SPH_BESSI1 = (X*DCOSH(X) - DSINH(X)) / (X*X) ! +! + END FUNCTION SPH_BESSI1 +! +!======================================================================= +! + FUNCTION SPH_BESSK0(X) +! +! This function calculates the second kind modified spherical Bessel function +! of order 0 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: SPH_BESSK0 +! + REAL (WP) :: DEXP +! + SPH_BESSK0 = DEXP(-X) / X ! +! + END FUNCTION SPH_BESSK0 +! +!======================================================================= +! + FUNCTION SPH_BESSK1(X) +! +! This function calculates the second kind modified spherical Bessel function +! of order 1 +! + IMPLICIT NONE +! + REAL (WP), INTENT(IN) :: X + REAL (WP) :: SPH_BESSK1 +! + REAL (WP) :: DEXP +! + SPH_BESSK1 = (DEXP(-X)*(X + 1.0E0_WP)) / (X*X) ! +! + END FUNCTION SPH_BESSK1 +! +END MODULE SPH_BESSEL diff --git a/New_libraries/Data/epsilon.dat b/New_libraries/Data/epsilon.dat new file mode 100644 index 0000000..8f6054c --- /dev/null +++ b/New_libraries/Data/epsilon.dat @@ -0,0 +1,1492 @@ + ****************************************************************************** + * MsSpec DIELECTRIC FUNCTION MODULE * + ****************************************************************************** + *=======+=========+=========+=========+=========+============================* + * GENERAL PARAMETERS : * + *=======+=========+=========+=========+=========+============================* + * (q,omega,r) : * + *-------+---------+---------+---------+---------+----------------------------* + * 0.010 4.000 1000 Q_MIN,Q_MAX,N_Q * in units of k_F + * 0.010 4.000 2000 E_MIN,E_MAX,N_E * in units of E_F + * 0.010 4.000 2000 R_MIN,R_MAX,N_R * in units of 1/k_F + *-------+---------+---------+---------+---------+----------------------------* + * Material's properties : * + *-------+---------+---------+---------+---------+----------------------------* + * 2.079 1.000 SCHRO 1.000 RS,MSOM,MAT_TYP,EPS_B * + *-------+---------+---------+---------+---------+----------------------------* + * External fields : * + *-------+---------+---------+---------+---------+----------------------------* + * 1.00 0.000 0.000 NO T,E,H,FLD * + *-------+---------+---------+---------+---------+----------------------------* + * System's dimension : * + *-------+---------+---------+---------+---------+----------------------------* + * 3D DIM * + *-------+---------+---------+---------+---------+----------------------------* + * Confinement : * + *-------+---------+---------+---------+---------+----------------------------* + * 0.000 0.000 0.00 NO-CONF R0,L,OM0,CONFIN * + *-------+---------+---------+---------+---------+----------------------------* + * Multilayer structure : * + *-------+---------+---------+---------+---------+----------------------------* + * 0.000 0.000 0.00 0.00 DL,D1,N_DEP,N_INV * --- EPS_1 --- + * NONE 12.000 12.000 H_TYPE,EPS_1,EPS_2 * EPS_2 + *-------+---------+---------+---------+---------+----------------------------* --- EPS_1 --- + * Units : * + *-------+---------+---------+---------+---------+----------------------------* + * SIU SI UNIT,UNIK * + *-------+---------+---------+---------+---------+----------------------------* + * Screening : * + *-------+---------+---------+---------+---------+----------------------------* + * NO SC_TYPE * + *-------+---------+---------+---------+---------+----------------------------* + * Plasma type : * + *-------+---------+---------+---------+---------+----------------------------* + * OCP 1.000 0.000 PL_TYPE,ZION,ZION2 * + *-------+---------+---------+---------+---------+----------------------------* + * Calculation type : * + *-------+---------+---------+---------+---------+----------------------------* + * QUANTUM CAL_TYPE * + *=======+=========+=========+=========+=========+============================* + * DIELECTRIC FUNCTION : * + *=======+=========+=========+=========+=========+============================* + * DYNAMIC LONG NEV3 0 ESTDY,EPS_T,D_FUNC,I_T * + * STA2 COCO 0.500 0.600 NEV_TYPE,MEM_TYPE,ALPHA,BETA * + *-------+---------+---------+---------+---------+----------------------------* + * Analytical plasmon dispersion : * + *-------+---------+---------+---------+---------+----------------------------* + * RP2_MOD PL_DISP * + *-------+---------+---------+---------+---------+----------------------------* + * Local-field corrections * + *-------+---------+---------+---------+---------+----------------------------* + * STATIC ICUT IKP GSTDY,GQ_TYPE,IQ_TYPE * + * NONE NONE EC EC LANDAU,GQO_TYPE,G0_TYPE,GI_TYPE* + *-------+---------+---------+---------+---------+----------------------------* + * Damping : * + *-------+---------+---------+---------+---------+----------------------------* + * RELA NONE EX1 DAMPING,LT_TYPE,RT_TYPE * + * NONE EXTE NONE DR_TYPE,DC_TYPE,VI_TYPE * + * NONE NONE NONE EE_TYPE,EP_TYPE,EI_TYPE * + * NONE NONE LORE 1.250 IP_TYPE,PD_TYPE,QD_TYPE,ZETA * + * 0.500 FEMTO 50.00 D_VALUE_1,POWER_1,EK * + * 5.000 FEMTO 0.80 D_VALUE_2,POWER_2,PCT * + *-------+---------+---------+---------+---------+----------------------------* + * Electron-electron interaction : * + *-------+---------+---------+---------+---------+----------------------------* + * COULO 2.590 470.000 1.500 INT_POT,S,EPS,DELTA * + * 1.500 5.000 7 28 RC,ALF,M,N * + * 1.000 1.000 1.000 1.000 A1,A2,A3,A4 * + *-------+---------+---------+---------+---------+----------------------------* + * Electron-phonon interaction : * + *-------+---------+---------+---------+---------+----------------------------* + * 1500.000 1500.000 EP_C,DEBYE_T * + * 12.000 0.000 0.000 NA,MA,RA * + *-------+---------+---------+---------+---------+----------------------------* + * Electron-impurity interaction : * + *-------+---------+---------+---------+---------+----------------------------* + * 0.000 0.000 NI,EI_C * + *-------+---------+---------+---------+---------+----------------------------* + * Classical fluid parameters : * + *-------+---------+---------+---------+---------+----------------------------* + * SHS HSM HSP CF_TYPE,PF_TYPE,SL_TYPE * + *=======+=========+=========+=========+=========+============================* + * STRUCTURE FACTOR : * + *=======+=========+=========+=========+=========+============================* + * DYNAMIC PKA EPS SSTDY,SQ_TYPE,SQO_TYPE * + *=======+=========+=========+=========+=========+============================* + * PAIR CORRELATION FUNCTION : * + *=======+=========+=========+=========+=========+============================* + * SHA KIMB GR_TYPE,GR0_MODE * + *=======+=========+=========+=========+=========+============================* + * PAIR DISTRIBUTION FUNCTION : * + *=======+=========+=========+=========+=========+============================* + * CEG RH_TYPE * + *=======+=========+=========+=========+=========+============================* + * SPECTRAL FUNCTION : * + *=======+=========+=========+=========+=========+============================* + * NAIC SPF_TYPE * + *=======+=========+=========+=========+=========+============================* + * ENERGY CALCULATIONS : * + *=======+=========+=========+=========+=========+============================* + * GGSB_G NO NO EC_TYPE,FXC_TYPE,EXC_TYPE * + * HEG HEG EX_TYPE,EK_TYPE * + *=======+=========+=========+=========+=========+============================* + * SPIN POLARIZATION : * + *=======+=========+=========+=========+=========+============================* + * 1 0.000 IMODE,XI * + *=======+=========+=========+=========+=========+============================* + * THERMODYNAMIC PROPERTIES : * + *=======+=========+=========+=========+=========+============================* + * QUAN IK0 TH_PROP,GP_TYPE * + *=======+=========+=========+=========+=========+============================* + * ELECTRON MEAN FREE PATH : * + *=======+=========+=========+=========+=========+============================* + * 150.00 200.00 EK_INI,EK_FIN * + *=======+=========+=========+=========+=========+============================* + * CALCULATION OF MOMENTS : * + *=======+=========+=========+=========+=========+============================* + * 1 SQO N_M,M_TYPE * + *=======+=========+=========+=========+=========+============================* + * INCOMING ION BEAM : * + *=======+=========+=========+=========+=========+============================* + * 1.00 15000.00 Z_BEAM,EK_BEAM * + *=======+=========+=========+=========+=========+============================* + * OUTPUT CALCULATIONS/PRINTING : * + *=======+=========+=========+=========+=========+============================* + * 1 0 0 0 I_DF,I_PZ,I_SU,I_CD * + *-------+---------+---------+---------+---------+----------------------------* + * 1 1 0 0 I_PD,I_EH,I_E2,I_CK * + * 0 0 I_CR,I_PK * + *-------+---------+---------+---------+---------+----------------------------* + * 0 0 0 0 I_LF,I_IQ,I_SF,I_PC * + * 0 0 0 0 I_P2,I_VX,I_DC,I_MD * + * 0 0 0 0 I_LD,I_DP,I_LT,I_BR * + * 0 0 0 0 I_PE,I_QC,I_RL,I_KS * + * 0 0 0 0 I_OQ,I_ME,I_MS,I_ML * + * 0 0 0 0 I_MC,I_DE,I_ZE,I_SR * + * 0 0 0 0 I_CW,I_CF,I_EM,I_MF * + * 0 0 0 0 I_SP,I_SE,I_SB,I_ES * + * 0 0 0 0 I_GR,I_FD,I_BE,I_MX * + * 0 0 0 0 I_SC,I_DS,I_NV,I_MT * + *-------+---------+---------+---------+---------+----------------------------* + * 0 0 0 0 I_GP,I_PR,I_CO,I_CP * + * 0 0 0 0 I_BM,I_SH,I_S0,I_S1 * + * 0 0 0 0 I_DT,I_PS,I_IE,I_EI * + * 0 0 I_FH,I_EY * + *-------+---------+---------+---------+---------+----------------------------* + * 1 1 1 1 I_EF,I_KF,I_VF,I_TE * + * 1 I_DL * + *-------+---------+---------+---------+---------+----------------------------* + * 0 0 0 I_TW,I_VT,I_TC * + *-------+---------+---------+---------+---------+----------------------------* + * 0 0 0 0 I_EG,I_EX,I_XC,I_EC * + * 0 0 0 I_HF,I_EK,I_EP * + *-------+---------+---------+---------+---------+----------------------------* + * 0 0 I_VI,I_DI * + *-------+---------+---------+---------+---------+----------------------------* + * 0 0 0 0 I_FP,I_EL,I_PO,I_RF * + * 0 I_VC * + *-------+---------+---------+---------+---------+----------------------------* + * 0 2 0 I_FN,I_WR,I_TI * + *=======+=========+=========+=========+=========+============================* + * INPUT FILES : * + *----------------------------------------------------------------------------* + * NAME UNIT TYPE * + *=======+======================+======+=========+============================* + * epsilon.dat 5 INPUT DATA FILE * + *=======+======================+======+=========+============================* + * OUTPUT FILES : * + *----------------------------------------------------------------------------* + * NAME UNIT TYPE * + *=======+======================+======+=========+============================* + * epsilon.lis 6 CHECK FILE * + *=======+======================+======+=========+============================* + * END OF THE DATA FILE * + *============================================================================* + ****************************************************************************** + +! +! Description of the calculation parameters: +! +! *=======+=========+=========+=========+=========+===========================* +! * GENERAL PARAMETERS : * +! *=======+=========+=========+=========+=========+===========================* +! +! * Q_MIN : minimum value of q (in units of k_F) +! * Q_MAX : maximum value of q (in units of k_F) +! * N_Q : number of q-points +! +! * E_MIN : minimum value of energy (in units of E_F) +! * E_MAX : maximum value of energy (in units of E_F) +! * N_E : number of E-points +! +! * R_MIN : minimum value of distance r (in units of 1/k_F) +! * R_MAX : maximum value of distance r (in units of 1/k_F)) +! * N_R : number of r-points +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * RS : average distance between 2 electrons (in units of a0) +! ~ +! * MSOM : m*/m (for semiconductors) +! ~ +! * MAT_TYP : type of material +! MAT_TYPE = 'SCHRO' standard solid +! MAT_TYPE = 'DIRAC' massless Fermions +! MAT_TYPE = 'NEUTR' neutral classical liquid +! MAT_TYPE = 'POLAR' polar classical liquid +! ~ +! * EPS_B : material's dielectric constant +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * T : temperature (in SI) +! ~ +! * E : external electric field (in SI) +! ~ +! * H : external magnetic field (in SI) +! ~ +! * FLD : strength of the magnetic field +! FLD = 'NO' no field +! FLD = 'WF' weak field +! FLD = 'IF' intermediate field +! FLD = 'LF' large field +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * DIM : dimension of the system +! DIM = '3D' +! DIM = '2D' +! DIM = '1D' +! DIM = 'Q0' quasi-0D +! DIM = 'Q1' quasi-1D +! DIM = 'Q2' quasi-2D +! DIM = 'BL' bilayer +! DIM = 'ML' multilayer +! DIM = 'ML' multilayer +! +! ~ +! +! * R0 : wire radius +! ~ +! * L : length of quantum well +! ~ +! * OM0 : frequency of the confinement potential (SI) +! ~ +! * CONFIN : type of confinement +! CONFIN = 'NO-CONF' no confinement +! CONFIN = 'DSEPLAY' layer within a stacking of layers +! CONFIN = 'CC-1111' cylindrical within subband 1 +! CONFIN = 'CC-1122' cylindrical between subbands 1 and 2 +! CONFIN = 'CC-1221' cylindrical between subbands 1 and 2 +! CONFIN = 'CC-2222' cylindrical within subband 2 +! CONFIN = 'HC-1111' harmonic within subband 1 +! CONFIN = 'HC-1122' harmonic between subbands 1 and 2 +! CONFIN = 'HC-1221' harmonic between subbands 1 and 2 +! CONFIN = 'HC-2222' harmonic within subband 2 +! CONFIN = 'INVLAYE' inversion layer in semiconductor +! CONFIN = 'IQWE_LB' square well with an infinite barrier +! CONFIN = 'PC1_QWI' parabolic +! CONFIN = 'PC2_QWI' parabolic +! CONFIN = 'SOFTCOR' soft-core potential +! CONFIN = 'SWC_QWI' square well with an infinite barrier +! +! ~ +! +! * DL : interlayer distance +! ~ +! * D1 : distance between the two layers in the unit cell +! ~ +! * N_DEP : electron concentration in depletion layer (SI) +! ~ +! * N_INV : electron concentration in inversion layer (SI) +! +! ~ +! +! * H_TYPE : heterostructure type +! H_TYPE = 'SSL1' semiconductor superlattice of type I +! H_TYPE = 'SSL2' semiconductor superlattice of type II +! H_TYPE = 'BILA' bilayer +! H_TYPE = 'MLA1' multilayer with with one layer / unit cell +! H_TYPE = 'MLA2' multilayer with with two layers / unit cell +! ~ +! * EPS_1 : background/layer dielectric constant +! ~ +! * EPS_2 : interlayer dielectric constant +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * UNIT : system unit +! UNIT = 'SIU' international system +! UNIT = 'CGS' CGS system +! UNIT = 'ATU' atomic units +! +! * UNIK : K unit +! UNIK = 'SI' international system +! UNIK = 'AU' atomic units +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * SC_TYPE : type of screeening +! SC_TYPE = 'NO' no screening +! SC_TYPE = 'DH' Debye-Hückel +! SC_TYPE = 'IS' Tago-Utsumi-Ichimaru +! SC_TYPE = 'KL' Kleinman +! SC_TYPE = 'OC' one-component plasma +! SC_TYPE = 'RP' RPA +! SC_TYPE = 'ST' Streitenberger +! SC_TYPE = 'TF' Thomas-Fermi +! SC_TYPE = 'UI' Utsumi-Ichimaru +! SC_TYPE = 'YT' Yasuhara-Takada +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * PL_TYPE : type of plasma considered +! PL_TYPE = 'OCP' --> one-component plasma (~ electron gas) +! PL_TYPE = 'DCP' --> two-component plasma +! +! * ZION : atomic number of (first) ion +! +! * ZION2 : atomic number of second ion +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * CAL_TYPE : type of calculation +! CAL_TYPE = 'QUANTUM' --> quantum fluid +! CAL_TYPE = 'CLASSIC' --> classical fluid +! +! *=======+=========+=========+=========+=========+===========================* +! * DIELECTRIC FUNCTION : * +! *=======+=========+=========+=========+=========+===========================* +! +! +! * ESTDY : static vs dynamic dielectric function +! STDY = ' STATIC' +! STDY = 'DYNAMIC' +! +! * EPS_T : type of dielcectric function +! EPS_T = 'LONG' longitudinal --> D_FUNCL +! EPS_T = 'TRAN' transverse --> D_FUNCT +! +! * D_FUNC : model of dielectric function : +! +! 1) Static: +! +! ---> longitudinal: +! +! D_FUNCL = 'LRPA' random phase approximation (3D,2D,1D) +! D_FUNCL = 'THFE' Thomas-Fermi approximation (3D,2D,1D) +! +! 2) Dynamic: +! +! ---> transverse: +! +! D_FUNCT = 'RPA1' random phase approximation (3D,2D) +! D_FUNCT = 'RPA2' random phase approximation (3D) +! D_FUNCT = 'LVLA' linearized Vlasov (3D) +! D_FUNCT = 'MER1' Mermin (3D) +! D_FUNCT = 'BLTZ' Boltzmann (3D) +! +! ---> longitudinal: +! +! D_FUNCL = 'ARBR' Arista-Brandt 1 <-- T-dependent +! D_FUNCL = 'ATAS' Atwal-Ashcroft <-- T-dependent +! D_FUNCL = 'BLZ1' Boltzmann +! D_FUNCL = 'BLZ2' damped Boltzmann +! D_FUNCL = 'DACA' Arista-Brandt 2 <-- T-dependent +! D_FUNCL = 'GOTZ' Götze memory function +! D_FUNCL = 'HEAP' Hertel-Appel +! D_FUNCL = 'HAFO' Hartree-Fock +! D_FUNCL = 'HUCO' Hu-O'Connell <-- damping (3D,2D,Q1) +! D_FUNCL = 'HYDR' hydrodynamic <-- damping +! D_FUNCL = 'KLEI' Kleinman <-- T-dependent +! D_FUNCL = 'KLKD' Klimontovich-Kraeft <-- T-dependent +! D_FUNCL = 'KLKN' Klimontovich-Kraeft <-- T-dependent +! D_FUNCL = 'LAND' Landau parameters-based +! D_FUNCL = 'LVL1' linearized Vlasov (weak coupling) <-- T-dependent +! D_FUNCL = 'LVL2' linearized Vlasov (strong coupling) <-- T-dependent +! D_FUNCL = 'MEM2' Two-moment memory function <-- T-dependent +! D_FUNCL = 'MEM3' Three-moment memory function <-- T-dependent +! D_FUNCL = 'MEM4' Four-moment memory function <-- T-dependent +! D_FUNCL = 'MER1' Mermin 1 <-- damping (3D,2D) +! D_FUNCL = 'MER2' Lindhard-Mermin <-- T-dependent +! D_FUNCL = 'MER+' Mermin with Local Field Corrections <-- damping +! D_FUNCL = 'MSAP' mean spherical approximation +! D_FUNCL = 'NEV2' Two-moment Nevanlinna <-- T-dependent +! D_FUNCL = 'NEV3' Three-moment Nevanlinna <-- T-dependent +! D_FUNCL = 'NEV4' Four-moment Nevanlinna <-- T-dependent +! D_FUNCL = 'PLPO' plasmon pole +! D_FUNCL = 'RDF1' Altshuler et al <-- damping +! D_FUNCL = 'RDF2' Altshuler et al <-- damping +! D_FUNCL = 'RPA1' RPA +! D_FUNCL = 'RPA2' RPA <-- T-dependent +! D_FUNCL = 'RPA+' RPA + static local field corrections +! D_FUNCL = 'RPA3' random phase approximation <-- magnetic field (2D) +! D_FUNCL = 'SO2E' computed from S(q,omega) +! D_FUNCL = 'UTIC' Utsumi-Ichimaru <-- T-dependent +! D_FUNCL = 'VLFP' Vlasov-Fokker-Planck <-- damping +! +! * I_T : way to incorporate temperature dependence +! I_T = 0 --> no temperature (T = 0) +! I_T = 1 --> analytical models used +! I_T = 2 --> temperature convolution +! +! ~ +! +! * NEV_TYPE : type of Nevalinna function used (only for D_FUNCL = 'NEVn') +! NEV_TYPE = 'NONE' --> no function +! NEV_TYPE = 'RELA' --> static value h(q) = i / tau +! NEV_TYPE = 'STA1' --> static value h(q) +! NEV_TYPE = 'STA2' --> static value h(q) +! NEV_TYPE = 'STA3' --> static value h(q) +! NEV_TYPE = 'STA4' --> static value h(q) +! NEV_TYPE = 'PEEL' --> Perel'-Eliashberg function +! NEV_TYPE = 'PE76' --> Perel'-Eliashberg by Arkhipov et al +! NEV_TYPE = 'CCP1' --> +! NEV_TYPE = 'CCP2' --> +! NEV_TYPE = 'CCP3' --> +! NEV_TYPE = 'CCP4' --> +! NEV_TYPE = 'PST1' --> +! +! * MEM_TYPE : type of memory function used (only for D_FUNCL = 'MEMn') +! MEM_TYPE = 'NONE' --> no function +! MEM_TYPE = 'DELT' --> delta function +! MEM_TYPE = 'DGAU' --> double Gaussian functions +! MEM_TYPE = 'EXPO' --> exponential function +! MEM_TYPE = 'GAUS' --> Gaussian function +! MEM_TYPE = 'LORE' --> Lorentzian function +! MEM_TYPE = 'SINC' --> sinc function +! MEM_TYPE = 'BES0' --> J_0(t) function +! MEM_TYPE = 'BES1' --> J_1(t)/t function +! MEM_TYPE = 'SEC2' --> sech^2(t) function +! MEM_TYPE = 'COCO' --> Cole-Cole function +! MEM_TYPE = 'CODA' --> Cole-Davidson function +! MEM_TYPE = 'HANE' --> Habriliak-Negami function +! MEM_TYPE = 'RAYI' --> Raganathan-Yip function +! MEM_TYPE = 'LIHY' --> linearized hydrodynamic function +! +! * ALPHA : value of the Habriliak-Negami first parameter (in ]0,1]) +! +! * BETA : value of the Habriliak-Negami second parameter (in ]0,1]) +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * PL_DISP : method used to compute the plasmon dispersion (3D real case) +! PL_DISP = 'HYDRODY' hydrodynamic model +! PL_DISP = 'RP1_MOD' RPA model up to q^2 +! PL_DISP = 'RP2_MOD' RPA model up to q^4 +! PL_DISP = 'GOA_MOD' Gorobchenko model +! PL_DISP = 'HER_APP' Hertel-Appel model <-- T-dependent +! PL_DISP = 'HUBBARD' Hubbard model +! PL_DISP = 'ELASTIC' elastic model +! PL_DISP = ' EXACT' computed from the dielectric function +! PL_DISP = 'SGBBN_M' SGBBN model +! PL_DISP = 'AL0_MOD' gamma_0 limit +! PL_DISP = 'ALI_MOD' gamma_inf limit +! PL_DISP = 'NOP_MOD' Nozières-Pines model +! PL_DISP = 'UTI_MOD' Utsumi-Ichimaru model +! PL_DISP = 'TWA_MOD' Toigo-Woodruff model +! PL_DISP = 'SUM_RU2' f-sum_rule +! PL_DISP = 'SUM_RU3' 3rd-frequency sum_rule +! * PL_DISP : method used to compute the plasmon dispersion (2D real case) +! PL_DISP = 'HYDRODY' hydrodynamic model +! PL_DISP = 'RPA_MOD' RPA model +! PL_DISP = 'RAJAGOP' Rajagopal formula +! * PL_DISP : method used to compute the plasmon dispersion (1D real case) +! PL_DISP = 'HYDRODY' hydrodynamic model +! PL_DISP = 'RPA_MOD' RPA model +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * GSTDY : static vs dynamic local-field corrections +! GSTDY = ' STATIC' --> GQ_TYPE +! GSTDY = 'DYNAMIC' --> GQO_TYPE +! +! * GQ_TYPE : local-field correction type (3D) static +! GQ_TYPE = 'NONE' no local field correction +! GQ_TYPE = 'ALDA' adiabatic local density +! GQ_TYPE = 'ALFL' Alvarellos-Flores +! GQ_TYPE = 'BEBR' Bedell-Brown +! GQ_TYPE = 'CDOP' TDDFT Corradini et al correction +! GQ_TYPE = 'GEV2' Geldart-Vosko 2 +! GQ_TYPE = 'GEVO' Geldart-Vosko correction +! GQ_TYPE = 'GOCA' Gold-Calmels +! temperature-dep. --> GQ_TYPE = 'HNCA' hypernetted chain +! GQ_TYPE = 'HORA' Holas-Rahman +! GQ_TYPE = 'HUBB' Hubbard correction (only exchange) +! GQ_TYPE = 'ICUT' Ichimaru-Utsumi correction +! GQ_TYPE = 'IKPA' Iwamoto-Krotscheck-Pines +! GQ_TYPE = 'IWA1' Iwamoto G_{-1} +! GQ_TYPE = 'IWA2' Iwamoto G_{3} approx. +! temperature-dep. --> GQ_TYPE = 'IWA3' Iwamoto G_{-1} +! GQ_TYPE = 'IWA4' Iwamoto G_{3} exact +! GQ_TYPE = 'JGDG' Jung-Garcia-Gonzalez-Dobson-Godby +! GQ_TYPE = 'KLLA' Kleinman-Langreth correction +! GQ_TYPE = 'LDAC' LDA correction +! GQ_TYPE = 'MCSC' Moroni-Ceperley-Senatore correction +! GQ_TYPE = 'NAGY' Nagy correction +! GQ_TYPE = 'NEV1' Nevalinna two-moment approximation +! GQ_TYPE = 'PGGA' Petersilka-Gossmann-Gross +! GQ_TYPE = 'PVHF' Pavas-Vashishta Hartree-Fock correction +! GQ_TYPE = 'RICE' Rice correction +! GQ_TYPE = 'SHAW' Shaw correction +! GQ_TYPE = 'SLAT' Slater correction +! GQ_TYPE = 'STLS' Singwi et al correction +! temperature-dep. --> GQ_TYPE = 'TKAC' Tkachenko correction +! GQ_TYPE = 'TOUL' Toulouse parametrization of CDOP +! GQ_TYPE = 'TRMA' Tripathy-Mandal +! GQ_TYPE = 'VASI' Vashishta-Singwi correction +! GQ_TYPE = 'UTI1' Utsumi-Ichimaru correction (only exchange) +! +! * GQ_TYPE : local-field correction type (2D) static +! GQ_TYPE = 'NONE' no local field correction +! GQ_TYPE = 'BUTO' Bulutay-Tomak +! GQ_TYPE = 'DPGT' Davoudi-Giuliani-Giuliani-Tosi +! GQ_TYPE = 'GOCA' Gold-Calmels +! GQ_TYPE = 'HUBB' Hubbard correction (only exchange) +! GQ_TYPE = 'IWA1' Iwamoto G_{-1} +! GQ_TYPE = 'IWA2' Iwamoto G_{3} +! GQ_TYPE = 'SAIC' Sato-Ichimaru correction +! +! * GQ_TYPE : local-field correction type (1D) static +! GQ_TYPE = 'NONE' no local field correction +! GQ_TYPE = 'GOCA' Gold-Calmels +! GQ_TYPE = 'HUBB' Hubbard correction (only exchange) +! +! * IQ_TYPE : type of approximation for I(q) +! IQ_TYPE = 'NON' I(q) = 0 +! IQ_TYPE = 'GKM' Gorobchenko-Kohn-Maksimov +! IQ_TYPE = 'HKA' Hong-Kim +! IQ_TYPE = 'IKP' Iwamoto-Krotscheck-Pines parametrization +! IQ_TYPE = 'KU1' Kugler 1 +! IQ_TYPE = 'KU2' Kugler 1 +! +! ~ +! +! * LANDAU : model chosen for the calculation of the Landau parameters (3D) +! LANDAU = 'NONE' Landau's theory not used +! LANDAU = 'CHEN' Chen's approach +! LANDAU = 'RASC' Rayleigh-Schrödinger expansion +! LANDAU = 'ANBR' Anderson-Brinkman model +! LANDAU = 'GUTZ' Gutzwiller model +! LANDAU = 'IWPI' Iwamoto-Pines model (hard-sphere) +! LANDAU = 'GCYO' Giuliani-Vignale parametrization of +! Yasuhara-Ousaka approach +! LANDAU = 'SBOH' slave-boson one-band Hubbard model +! +! * LANDAU : model chosen for the calculation of the Landau parameters (2D) +! LANDAU = 'NONE' Landau's theory not used +! LANDAU = 'ERZA' Engelbrecht-Randeria-Zhang approach +! LANDAU = 'GVYO' Giuliani-Vignale parametrization of +! Yasuhara-Ousaka approach +! LANDAU = 'KCMP' Kwoon-Ceperley-Martin parametrization +! * GQO_TYPE : local-field correction type (3D) +! GQO_TYPE = 'NONE' no local field correction +! GQO_TYPE = 'ALFL' Alvarellos-Flores correction +! GQO_TYPE = 'BACA' Barriga-Carrasco correction +! GQO_TYPE = 'BBSA' Bachlechner-Böhm-Schinner +! GQO_TYPE = 'COPI' Constantin-Pitarke +! GQO_TYPE = 'DABR' Dabrowski +! GQO_TYPE = 'FWRA' Forstmann-Wierling-Röpke +! GQO_TYPE = 'HOK1' Hong-Kim correction +! GQO_TYPE = 'HOK2' Hong-Kim correction +! GQO_TYPE = 'JEWS' Jewsbury approximation +! GQO_TYPE = 'KUG1' Kugler q --> 0 approximation +! GQO_TYPE = 'KUG2' Kugler approximation +! GQO_TYPE = 'MDGA' Mithen-Daligault-Gregori +! GQO_TYPE = 'NEV2' Nevalinna three-moment approximation +! GQO_TYPE = 'NLGA' Nagy-Laszlo-Giber approximation +! GQO_TYPE = 'RIA1' Richardson-Ashcroft G_s +! GQO_TYPE = 'RIA2' Richardson-Ashcroft G_n +! GQO_TYPE = 'RIA3' Richardson-Ashcroft G_a +! GQO_TYPE = 'SHMU' Shah-Mukhopadhyay +! GQO_TYPE = 'STGU' Sturm-Gusarov +! GQO_TYPE = 'TOWO' Toigo-Woodruff +! GQO_TYPE = 'UTI2' Utsumi-Ichimaru approximation +! GQO_TYPE = 'VISC' viscosity approximation +! +! * G0_TYPE : type of calculation of gamma_0 +! G0_TYPE = 'SQ' from the static structure factor S(q) +! G0_TYPE = 'EC' from the correlation energy E_c +! +! * GI_TYPE : type of calculation of gamma_inf +! GI_TYPE = 'SQ' from the static strcuture factor S(q) +! GI_TYPE = 'EC' from the correlation energy E_c +! +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * DAMPING : type of damping used +! DAMPING = 'NONE' no damping +! DAMPING = 'LFTM' lifetime +! DAMPING = 'RELA' relaxation time +! DAMPING = 'DECA' decay rate +! DAMPING = 'DIFF' diffusion coefficient +! DAMPING = 'VISC' viscosity +! +! * LT_TYPE : approximation used for lifetime (3D) +! LT_TYPE = 'EXTE' given externally (D_VALUE,POWER) +! LT_TYPE = 'DAVI' Davies formula +! LT_TYPE = 'GALI' Galitskii formula +! LT_TYPE = 'GIQU' Giuliani-Quinn formula +! LT_TYPE = 'GIVI' Giuliani-Vignale formula +! LT_TYPE = 'INPE' Inogamov-Petrov formula +! LT_TYPE = 'LUBR' Lugovskoy-Bray formula +! LT_TYPE = 'NAEC' Nagy-Echenique formula +! LT_TYPE = 'QIVI' Qian-Vignale formula +! LT_TYPE = 'EXTE' given externally (D_VALUE,POWER) +! LT_TYPE = 'QUFE' Quinn-Ferrell formula +! +! * LT_TYPE : approximation used for lifetime (2D) +! LT_TYPE = 'GIQ1' Giuliani-Quinn formula for e-h loss +! LT_TYPE = 'GIQ2' Giuliani-Quinn formula for plasmon loss +! LT_TYPE = 'GIVI' Giuliani-Vignale formula +! LT_TYPE = 'HAWR' Hawrylak formula +! LT_TYPE = 'MELA' Menashe-Laikhtman formula +! LT_TYPE = 'QIVI' Qian-Vignale formula +! +! * RT_TYPE : relaxation time +! RT_TYPE = ' NO' --> no relaxation time +! RT_TYPE = 'EX1' --> given externally (D_VALUE_1,POWER_1) +! RT_TYPE = 'EX2' --> given externally (D_VALUE_1,POWER_1,D_VALUE_2,POWER_2) +! RT_TYPE = 'E-E' --> electron-electron interaction +! RT_TYPE = 'E-P' --> electron-phonon interaction +! RT_TYPE = 'E-I' --> electron-phonon impurity +! RT_TYPE = 'ALL' --> all three taken into account +! +! ~ +! +! * DR_TYPE : decay rate in 3D +! DR_TYPE = 'EXTE' given externally (D_VALUE,POWER) +! DR_TYPE = 'UTIC' --> Utsumi-Ichimaru approximation +! DR_TYPE = 'VLAS' --> Vlasov approximation +! +! * DC_TYPE : diffusion coefficient in 3D +! DC_TYPE = 'EXTE' given externally (D_VALUE,POWER) +! DC_TYPE = 'ASHO' --> Ashurst-Hoover +! +! * VI_TYPE : viscosity in 3D +! VI_TYPE = 'EXTE' given externally (D_VALUE,POWER) +! VI_TYPE = 'AMPP' Angilella et al hard-sphere fluid --> T-dependent +! VI_TYPE = 'DRBA' Daligault-Rasmussen-Baalrud (plasmas) --> T-dependent +! VI_TYPE = 'KHRA' Khrapak for Yukawa fluid --> T-dependent +! VI_TYPE = 'LHPO' Longuet-Higgins-Pope --> T-dependent +! VI_TYPE = 'LLPA' Landau-Lifshitz-Pitaevskii--> T-dependent +! VI_TYPE = 'SCHA' Schäfer --> T-dependent +! VI_TYPE = 'SCHD' Schäfer (dynamic) --> T-dependent +! VI_TYPE = 'SHTE' Shternin --> T-dependent +! VI_TYPE = 'STEI' Steinberg low-temperature --> T-dependent +! +! * VI_TYPE : viscosity in 2D +! VI_TYPE = 'EXTE' given externally (D_VALUE,POWER) +! VI_TYPE = 'SCHA' Schäfer --> T-dependent +! graphene <-- VI_TYPE = 'KISC' Kiselev-Schmalian (dynamic) --> T-dependent +! graphene <-- VI_TYPE = 'MSFA' Müller-Schmalian-Fritz --> T-dependent +! +! ~ +! +! * EE_TYPE : e-e relaxation time in 3D +! EE_TYPE = 'ALAR' --> Al'tshuler-Aronov (e-e + impurities) +! EE_TYPE = 'ALA2' --> Al'tshuler-Aronov (e-e + impurities) +! EE_TYPE = 'BACA' --> Barriga-Carrasco approximation (e-e) +! EE_TYPE = 'FSTB' --> Fann et al approximation (e-e) +! EE_TYPE = 'PIN1' --> Pines-Nozières 1st approx. (e-e) +! EE_TYPE = 'PIN2' --> Pines-Nozières 2nd approx. (e-e) +! EE_TYPE = 'QIV2' --> Qian-Vignale high-density limit(e-e) +! EE_TYPE = 'QIVI' --> Qian-Vignale (e-e) +! EE_TYPE = 'RASM' --> Rammer-Smith (e-e) +! EE_TYPE = 'TAI0' --> Tanaka-Ichimaru approximation (e-e) --> q = 0 +! EE_TYPE = 'TAIQ' --> Tanaka-Ichimaru approximation (e-e) --> q-dependent +! EE_TYPE = 'UTIC' --> Utsumi-Ichimaru approximation (e-e) +! +! +! * EE_TYPE : relaxation time in 2D +! EE_TYPE = 'ALA2' --> Al'tshuler-Aronov (e-e + impurities) +! EE_TYPE = 'FUAB' --> Fukuyama-Abrahams (disordered metals) +! graphene <-- EE_TYPE = 'LUFO' --> Lucas-Fong (e-e) +! EE_TYPE = 'QIVI' --> Qian-Vignale (e-e) +! EE_TYPE = 'RASM' --> Rammer-Smith (e-e) +! heterostructures <-- EE_TYPE = 'REWI' --> Reizer-Wilkins (e-e) +! EI_TYPE = 'SHAS' --> Sharma-Ashraf (e-e + impurities) +! EE_TYPE = 'ZHDA' --> Zhang-Das Sarma (e-e) +! +! * EE_TYPE : relaxation time in 1D +! EE_TYPE = 'ALA2' --> Al'tshuler-Aronov (e-e + impurities) +! EE_TYPE = 'SHAS' --> Sharma-Ashraf (e-e + impurities) +! +! * EP_TYPE : e-phonon relaxation time in 3D +! EP_TYPE = 'STEL' --> Steinberg low-temperature +! EP_TYPE = 'STEH' --> Steinberg High-temperature +! +! * EI_TYPE : e-impurit relaxation time in 3D +! EI_TYPE = 'HEAP' --> Hertel-Appel approximation +! +! ~ +! +! * IP_TYPE : ion plasma relaxation time in 3D +! IP_TYPE = 'SEMO' --> Selchow-Morawetz approximation +! IP_TYPE = 'SPIT' --> Spitzer approximation +! +! * PD_TYPE : method used to compute the plasmon damping (3D) +! PD_TYPE = 'NONE' --> no plasmon damping +! PD_TYPE = 'CALL' --> Callen approximation +! PD_TYPE = 'DGKA' --> DuBois-Gilinsky-Kivelson approximation +! PD_TYPE = 'FEWA' --> Fetter and Walecka approximation +! PD_TYPE = 'JEWS' --> Jewsbury approximation +! PD_TYPE = 'LITI' --> Giuliani-Quinn lifetime approximation +! PD_TYPE = 'MOPE' --> Molinari-Peerani approximation +! PD_TYPE = 'NPSA' --> Ninham-Powel-Swanson approximation +! PD_TYPE = 'SGAA' --> Segui-Gervasoni-Arista approximation +! +! * QD_TYPE : method used to compute q-dependent relaxation time +! QD_TYPE = 'NONE' --> no q-dependence +! QD_TYPE = 'GAUS' --> Gaussian +! QD_TYPE = 'LORE' --> Lorentzian +! +! * ZETA : Value of Tanaka-Ichimaru parameter +! +! ~ +! +! * D_VALUE_1: Value of the 1st damping coefficient (between 0 and 999.999) +! +! * POWER_1 : power of ten to multiply D_VALUE_1 by +! POWER = ' KILO' +! POWER = ' MEGA' +! POWER = ' GIGA' +! POWER = ' TERA' +! POWER = ' PETA' +! POWER = ' EXA' +! POWER = 'ZETTA' +! POWER = 'MILLI' +! POWER = 'MICRO' +! POWER = ' NANO' +! POWER = ' PICO' +! POWER = 'FEMTO' +! POWER = ' ATTO' +! POWER = 'ZEPTO' +! POWER = 'YOCTO' +! +! * EK : kinetic energy of electron considered (in eV) +! with respect to vacuum level +! +! ~ +! +! * D_VALUE_2: Value of the 2nd damping coefficient (between 0 and 999.999) +! +! * POWER_2 : power of ten to multiply D_VALUE_2 by +! POWER = ' KILO' +! POWER = ' MEGA' +! POWER = ' GIGA' +! POWER = ' TERA' +! POWER = ' PETA' +! POWER = ' EXA' +! POWER = 'ZETTA' +! POWER = 'MILLI' +! POWER = 'MICRO' +! POWER = ' NANO' +! POWER = ' PICO' +! POWER = 'FEMTO' +! POWER = ' ATTO' +! POWER = 'ZEPTO' +! POWER = 'YOCTO' +! +! * PCT : weight of first memory function (relaxation time D_VALUE_1) +! 0.00 <= PCT <= 1.00 +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * INT_POT : type of interaction potential (3D) +! INT_POT = 'COULO' Coulomb interaction +! INT_POT= 'YUKAW' Yukawa interaction +! INT_POT= 'SOFTS' soft sphere +! INT_POT= 'LNJNS' Lennard-Jones +! INT_POT= 'HCLNJ' hard-core Lennard-Jones +! INT_POT= 'KIHAR' Kihara +! INT_POT= 'MIE_P' Mie +! INT_POT= 'VANDW' Van der Waals +! INT_POT= 'MORSE' Morse +! INT_POT= 'G_EXP' generalised exponential +! INT_POT= 'EXP_6' exp-6 +! INT_POT= 'MBUCK' modified Buckingham +! INT_POT= 'N_COU' neutralised Coulomb +! INT_POT= 'H_COR' hard-core +! INT_POT= 'P_SPH' penetrable sphere +! INT_POT= 'ST-JO' Starkloff-Joannopoulos soft-core +! INT_POT= 'LR_OS' long-range oscillatory +! INT_POT= 'STOCK' Stockmayer +! INT_POT= 'RPAPO' RPA interaction +! INT_POT = 'OVER1' Overhauser interaction +! INT_POT = 'OVER2' modified Overhauser interaction +! INT_POT = 'DEUTS' Deutsch interaction +! INT_POT = 'PHOLE' particle-hole interaction +! INT_POT = 'KELBG' Kelbg interaction +! +! * S : length scale parameter of the potential (in Angström) +! +! * EPS : depth of the potential (in units of k_B, i.e. in Kelvin) +! +! * DELTA : polarisation of the fluid (dimensionless) +! +! ~ +! +! * RC : potential core radius (in Angström) +! * ALF : potential stiffness +! * M : \ exponents for Kihara +! * N : / and Mie potentials +! +! ~ +! +! * A1 : \ +! * A2 : \ parameters for +! * A3 : / long-range oscillatory potentials +! * A4 : / +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * EP_C : electron-phonon coupling +! * DEBYE_T : material Debye temperature +! +! ~ +! +! * NA : number of atoms per unit volume +! * MA : mass of the atoms +! * RA : radius of the atoms +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * NI : impurity concentration +! * EI_C : strength of impurity scattering +! +! *-------+---------+---------+---------+---------+---------------------------* +! + +! * CF_TYPE : type of classical fluid calculation --> 3D +! CF_TYPE = 'SHS' smooth hard spheres +! CF_TYPE = 'RH1' rough hard spheres (Pidduck) +! CF_TYPE = 'RH2' rough hard spheres (Condiff-Lu-Dahler) +! CF_TYPE = 'RH3' rough hard spheres (McCoy-Sandler-Dahler) +! CF_TYPE = 'DCE' dilute Chapman-Enskog +! CF_TYPE = 'HCE' heavy (i.e. dense) Chapman-Enskog +! CF_TYPE = 'LJF' Lennard-Jones fluid + +! CF_TYPE = 'DHD' dense hard disks --> 2D + +! * PF_TYPE : type of packing fraction --> 2D +! PF_TYPE = 'HDM' --> hard disk model +! +! --> 3D +! PF_TYPE = 'HSM' --> hard sphere model +! PF_TYPE = 'RCP' --> random closed-packed +! PF_TYPE = 'FCC' --> FCC closed-packed +! PF_TYPE = 'FRE' --> freezing +! PF_TYPE = 'MEL' --> melting +! +! * SL_TYPE : type of scattering length calculation +! SL_TYPE = 'HSP' --> hard sphere potential +! SL_TYPE = 'ASW' --> attractive square well (without bound state) +! SL_TYPE = 'RSW' --> repulsive square well +! SL_TYPE = 'DSP' --> delta-shell potential +! SL_TYPE = 'AYP' --> attractive Yukawa potential +! SL_TYPE = 'CCO' --> Coulomb cut-off potential +! SL_TYPE = 'HUL' --> Hulthén potential +! +! *=======+=========+=========+=========+=========+===========================* +! * STRUCTURE FACTOR : * +! *=======+=========+=========+=========+=========+===========================* +! +! +! * SSTDY : static vs dynamic local-field corrections +! SSTDY = ' STATIC' --> SQ_TYPE +! SSTDY = 'DYNAMIC' --> SQO_TYPE +! +! * SQ_TYPE : structure factor approximation (3D) --> static +! SQ_TYPE = 'DEH' Debye-Hückel approximation +! SQ_TYPE = 'GEA' generalized approximation +! SQ_TYPE = 'GOR' Gorobchenko approximation +! SQ_TYPE = 'GR2' computed from g(r) (GR_TO_SQ.f90 code) +! SQ_TYPE = 'GSB' Gori-Giorgi-Sacchetti-Bachelet approximation +! SQ_TYPE = 'HFA' Hartree-Fock approximation (only exchange) +! SQ_TYPE = 'HUB' Hubbard approximation +! SQ_TYPE = 'ICH' Ichimaru approximation +! SQ_TYPE = 'LEE' Lee ideal Fermi gas +! SQ_TYPE = 'MSA' mean spherical approximation +! SQ_TYPE = 'PKA' Pietiläinen-Kallio +! SQ_TYPE = 'RPA' RPA approximation +! SQ_TYPE = 'SHA' Shaw approximation +! SQ_TYPE = 'SIN' Singh +! SQ_TYPE = 'SPA' Singh-Pathak +! SQ_TYPE = 'TWA' Toigo-Woodruff approximation +!! +! * SQO_TYPE : structure factor approximation (3D) --> dynamic +! SQO_TYPE = 'ABA' Arista-Brandt approximation +! SQO_TYPE = 'EPS' computed from dielectric function +! SQO_TYPE = 'HFA' Hartree-Fock approximation +! SQO_TYPE = 'HYD' hydrodynamic approximation +! SQO_TYPE = 'IGA' ideal gas approximation +! SQO_TYPE = 'ITA' Ichimaru-Tanaka approximation +! SQO_TYPE = 'MFA' Hansen-McDonald-Pollock approximation +! SQO_TYPE = 'MFD' memory function model +! SQO_TYPE = 'NIC' Nakano-Ichimaru approximation +! SQO_TYPE = 'UTI' Utsumi-Ichimaru approximation (3D) +! SQO_TYPE = 'VLA' linearized Vlasov approximation +! +! *=======+=========+=========+=========+=========+===========================* +! * PAIR CORRELATION FUNCTION : * +! *=======+=========+=========+=========+=========+===========================* +! +! * GR_TYPE : pair correlation function approximation g(r) (3D) +! GR_TYPE = 'CDF' from chain diagram formula of PDF (long distance) +! GR_TYPE = 'DHA' Debye-Hückel approximation +! GR_TYPE = 'DWA' DeWitt approximation +! GR_TYPE = 'FBA' Frieman-Book approximation +! GR_TYPE = 'HFA' Hartree-Fock approximation (only exchange) +! GR_TYPE = 'HUB' Hubbard approximation +! GR_TYPE = 'LLA' Lee-Long approximation +! GR_TYPE = 'ORB' Ortiz-Ballone approximation +! GR_TYPE = 'PDF' from pair distribution function +! GR_TYPE = 'SHA' Shaw approximation +! GR_TYPE = 'SQ2' computed from S(q) (SQ_TO_GR.f90 code) +! GR_TYPE = 'WIG' Wigner approximation +! +! * GR0_MODE : g(0) (3D) +! GR0_MODE = 'CAGO' --> Calmels-Gold +! GR0_MODE = 'DPGT' --> Davoudi-Polini-Giuliani-Tosi +! GR0_MODE = 'HASA' --> Holas-Aravind-Singwi (small r_s) +! GR0_MODE = 'ICHI' --> Ichimaru +! GR0_MODE = 'KIMB' --> Kimball +! GR0_MODE = 'OVE1' --> Overhauser 1 +! GR0_MODE = 'OVE2' --> Overhauser 2 +! GR0_MODE = 'QIAN' --> Qian +! * GR0_MODE : g(0) (2D) +! GR0_MODE = 'CAGO' --> Calmels-Gold +! GR0_MODE = 'HAFO' --> Hartree-Fock +! GR0_MODE = 'MOMA' --> Moreno-Marinescu +! GR0_MODE = 'NSOA' --> Nagano-Singwi-Ohnishi +! GR0_MODE = 'QIAN' --> Qian +! +! *=======+=========+=========+=========+=========+===========================* +! * PAIR DISTRIBUTION FUNCTION : * +! *=======+=========+=========+=========+=========+===========================* +! +! * RH_TYPE : pair distribution function approximation (3D) +! RH_TYPE = 'CDI' chain diagram improved +! RH_TYPE = 'CEG' classical electron gas +! RH_TYPE = 'DEB' Debye electron gas +! RH_TYPE = 'FUA' correct to order 2 in epsilon +! RH_TYPE = 'SDC' short-distance correlations +! RH_TYPE = 'WDA' watermelon diagrams summed +! +! *=======+=========+=========+=========+=========+===========================* +! * SPECTRAL FUNCTION : * +! *=======+=========+=========+=========+=========+===========================* +! +! SPF_TYPE = 'NAIC' Nakano-Ichimaru approximation +! + *=======+=========+=========+=========+=========+============================* + * ENERGY CALCULATIONS : * + *=======+=========+=========+=========+=========+============================* +! +! * EC_TYPE : type of correlation energy functional (3D) +! EC_TYPE = 'GEBR_W' --> Gell-Mann and Brueckner +! EC_TYPE = 'CAMA_W' --> Carr and Maradudin +! EC_TYPE = 'EHTY_G' --> Endo-Horiuchi-Takada-Yasuhara +! EC_TYPE = 'HELU_G' --> Hedin and Lundqvist +! EC_TYPE = 'VBHE_G' --> von Barth and Hedin +! EC_TYPE = 'PEZU_G' --> Perdew and Zunger +! EC_TYPE = 'WIGN_G' --> Wigner +! EC_TYPE = 'NOPI_G' --> Nozières and Pines +! EC_TYPE = 'LIRO_G' --> Lindgren and Rosen +! EC_TYPE = 'PEZU_G' --> Perdew and Zunger +! EC_TYPE = 'REHI_G' --> Rebei and Hitchon +! EC_TYPE = 'GGSB_G' --> Gori-Giorgi-Sacchetti-Bachelet +! EC_TYPE = 'PRKO_G' --> Proynov and Kong +! EC_TYPE = 'GGSB_G' --> Vosko, Wilk and Nusair +! EC_TYPE = 'VWNU_G' --> Perdew and Wang +! EC_TYPE = 'HUBB_G' --> Hubbard +! EC_TYPE = 'CHAC_G' --> Chachiyo +! EC_TYPE = 'ISKO_T' --> Isihara and Kojima +! * EC_TYPE : type of correlation energy functional (2D) +! EC_TYPE = 'TACE_G' --> Tanatar-Ceperley +! EC_TYPE = 'CPPA_G' --> Seidl-Perdew_Levy +! EC_TYPE = 'AMGB_G' --> Attaccalite-Moroni-Gori-Giorgi-Bachelet +! EC_TYPE = 'SEID_G' --> Seidl +! EC_TYPE = 'LOOS_W' --> Loos +! EC_TYPE = 'WIGN_G' --> Wigner +! EC_TYPE = 'ISTO_T' --> Isihara-Toyoda +! * EC_TYPE : type of correlation energy functional (1D) +! EC_TYPE = 'LOOS_W' --> Loos +! EC_TYPE = 'WIGN_G' --> Wigner +! +! +! * FXC_TYPE : type of XC free energy functional --> 3D +! FXC_TYPE = 'NO' --> None +! FXC_TYPE = 'EB' --> Ebeling et al +! FXC_TYPE = 'IC' --> Ichimaru et al +! FXC_TYPE = 'KS' --> Karasiev et al +! FXC_TYPE = 'VS' --> Vashishta and Singwi +! FXC_TYPE = 'PD' --> Perrot and Dharma-Wardana +! FXC_TYPE = 'EK' --> Ebeling-Kraeft-Kremp-Röpke + +! * EXC_TYPE : type of exchange-correlation energy functional --> 3D +! EXC_TYPE = 'NO' --> None +! EXC_TYPE = 'GT' --> Goedeker-Tetter-Hutter +! EXC_TYPE = 'ST' --> +! EXC_TYPE = 'BD' --> Brown-DuBois-Holzmann-Ceperley +! +! ~ +! +! + *=======+=========+=========+=========+=========+============================* + * SPIN POLARIZATION : * + *=======+=========+=========+=========+=========+============================* +! +! * IMODE : choice of spin parameters +! IMODE = 1 : no spin polarization +! IMODE = 2 : fully spin-polarized +! +! * XI : spin polarization : (n+ - n-) / n +! +! *=======+=========+=========+=========+=========+===========================* +! * THERMODYNAMIC PROPERTIES : * +! *=======+=========+=========+=========+=========+===========================* +! +! * TH_PROP : type of calculation --> thermodynamic properties +! TH_PROP = 'CLAS' : classical approximation +! TH_PROP = 'QUAN' : quantum approximation +! +! * GP_TYPE : grand partition function type (3D) +! GP_TYPE = 'IK0' Isihara-Kojima formulation +! GP_TYPE = 'RH0' Rebei-Hitchon formulation +! GP_TYPE = 'IKM' Isihara-Kojima with magnetic field +! +! * GP_TYPE : grand partition function type (2D) +! GP_TYPE = 'I20' Isihara-Kojima formulation +! GP_TYPE = 'I2M' Isihara-Kojima with magnetic field +! +! *=======+=========+=========+=========+=========+===========================* +! * ELECTRON MEAN FREE PATH : * +! *=======+=========+=========+=========+=========+===========================* +! +! * EK_INI : starting kinetic energy of electron in eV +! * EK_FIN : final kinetic energy of electron in eV +! +! *=======+=========+=========+=========+=========+===========================* +! * CALCULATION OF MOMENTS : * +! *=======+=========+=========+=========+=========+===========================* +! +! * N : order of moment +! * M_TYPE : way S(q,omega) is computed +! M_TYPE = 'EPS' from epsilon(q,omega) +! M_TYPE = 'SQO' from S(q,omega) +! +! *=======+=========+=========+=========+=========+===========================* +! * INCOMING ION BEAM : * +! *=======+=========+=========+=========+=========+===========================* +! +! * Z_BEAM : charge of ions in incoming beam +! * EK_BEAM : kinetic energy of incoming beam ions (eV) +! +! *=======+=========+=========+=========+=========+===========================* +! * OUTPUT CALCULATIONS : * +! *=======+=========+=========+=========+=========+===========================* +! +! * I_DF : switch for dielectric function printing +! I_DF = 0 : dielectric function not printed +! I_DF = 1 : dielectric function printed in file 'diel_func.dat' +! +! * I_PZ : switch for polarization function printing +! I_PZ = 0 : polarization function not printed +! I_PZ = 1 : polarization function printed in file 'pola_func.dat' +! +! * I_SU : switch for susceptibility function printing +! I_SU = 0 : susceptibility function not printed +! I_SU = 1 : susceptibility function printed in file 'susc_func.dat' +! +! * I_CD : switch for electrical conductivity printing +! I_CD = 0 : electrical conductivity not printed +! I_CD = 1 : electrical conductivity printed in file 'cond_func.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_PD : switch for plasmon dispersion printing +! I_PD = 0 : plasmon dispersion not calculated +! I_PD = 1 : plasmon dispersion printed in file 'plas_disp.dat' +! +! * I_EH : switch for electron-hole dispersion printing +! I_EH = 0 : electron-hole dispersion not calculated +! I_EH = 1 : electron-hole dispersion printed in file 'elec_hole.dat' +! +! * I_E2 : switch for two-electron-hole dispersion printing +! I_E2 = 0 : two-electron-hole dispersion not calculated +! I_E2 = 1 : two-electron-hole dispersion printed in file 'elec_hol2.dat' +! +! * I_CK : switch for k-space e-e interaction potential printing +! I_CK = 0 : potential not calculated +! I_CK = 1 : potential printed in file 'int_pot_k.dat' +! +! * I_CR : switch for real-space e-e interaction potential printing +! I_CR = 0 : potential not calculated +! I_CR = 1 : potential printed in file 'int_pot_r.dat' +! +! * I_PK : switch for plasmon kinetic energy printing +! I_PK = 0 : plasmon kinetic energy not calculated +! I_PK = 1 : plasmon kinetic energy printed in file 'plas_kine.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_LF : switch for local-field corrections G(q,omega) printing +! I_LF = 0 : local-field corrections not calculated +! I_LF = 1 : local-field corrections printed in file 'loca_fiel.dat' +! +! * I_IQ : switch for G(q,inf) printing +! I_IQ = 0 : G(q,inf) not calculated +! I_IQ = 1 : G(q,inf) printed in file 'ginf_fiel.dat' +! +! * I_SF : switch for structure factor S(q,omega) printing +! I_SF = 0 : structure factor not calculated +! I_SF = 1 : structure factor printed in file 'stru_fact.dat' +! +! * I_PC : switch for pair correlation function g(r) printing +! I_PC = 0 : pair correlation function not calculated +! I_PC = 1 : pair correlation function printed in file 'pair_corr.dat' +! +! ~ +! +! * I_P2 : switch for pair distribution rho2(r) printing +! I_P2 = 0 : pair distribution function not calculated +! I_P2 = 1 : pair distribution function printed in file 'pair_dist.dat' +! +! * I_VX : switch for vertex function Gamma(q,omega) printing +! I_VX = 0 : vertex function not calculated +! I_VX = 1 : vertex function printed in file 'vertex_fu.dat' +! +! * I_DC : switch for plasmon damping coefficient Im[eps]/q^2 printing +! I_DC = 0 : plasmon damping not calculated +! I_DC = 1 : plasmon damping printed in file 'plas_damp.dat' +! +! * I_MD : switch for momentum distribution printing +! I_MD = 0 : momentum distribution not calculated +! I_MD = 1 : momentum distribution printed in file 'mome_dist.dat' +! +! ~ +! +! * I_LD : switch for Landau parameters printing +! I_LD = 0 : Landau parameters not calculated +! I_LD = 1 : Landau parameters printed in file 'landau_pa.dat' +! +! * I_DP : switch for damping printing +! I_DP = 0 : damping not calculated +! I_DP = 1 : damping printed in file 'damp_file.dat' +! +! * I_LT : switch for plasmon lifetime printing +! I_LT = 0 : plasmon lifetime not calculated +! I_LT = 1 : plasmon lifetime printed in file 'life_time.dat' +! +! * I_BR : switch for plasmon broadening printing +! I_BR = 0 : plasmon broadening not calculated +! I_BR = 1 : plasmon broadening printed in file 'broadenin.dat' +! +! ~ +! +! * I_PE : switch for plasmon energy printing +! I_PE = 0 : plasmon energy not calculated +! I_PE = 1 : plasmon energy printed in file 'plas_ener.dat' +! +! * I_QC : switch for plasmon q-bounds printing +! I_QC = 0 : plasmon q-bounds not calculated +! I_QC = 1 : plasmon q-bounds printed in file 'qc_bounds.dat' +! +! * I_RL : switch for relaxation time printing +! I_RL = 0 : relaxation time not calculated +! I_RL = 1 : relaxation time printed in file 'rela_time.dat' +! +! * I_KS : switch for screening wave vector printing +! I_KS = 0 : screening wave vector not calculated +! I_KS = 1 : screening wave vector printed in file 'screen_wv.dat' +! +! ~ +! +! * I_OQ : switch for omega = q * v_F printing +! I_DY = 0 : omega = q * v_F not calculated +! I_DY = 1 : omega = q * v_F printed in file 'omega_qvf.dat' +! +! * I_ME : switch for moments of epsilon(q,omega) printing +! I_ME = 0 : moments of epsilon not calculated +! I_ME = 1 : moments of epsilon printed in file 'moments_e.dat' +! +! * I_MS : switch for moments of S(q,omega) printing +! I_MS = 0 : moments of structure factor not calculated +! I_MS = 1 : moments of structure factor printed in file 'moments_s.dat' +! +! * I_ML : switch for moments of loss function printing +! I_ML = 0 : moments of loss function not calculated +! I_ML = 1 : moments of loss function printed in file 'moments_l.dat' +! +! ~ +! +! * I_MC : switch for moments of conductivity printing +! I_MC = 0 : moments of conductivity not calculated +! I_MC = 1 : moments of conductivity printed in file 'moments_c.dat' +! +! * I_DE : switch for derivative of Re[ dielectric function ] printing +! I_DE = 0 : derivative not calculated +! I_DE = 1 : derivative printed in file 'deri_epsi.dat' +! +! * I_ZE : switch for Re[ dielectric function ] = 0 printing +! I_ZE = 0 : function not calculated +! I_ZE = 1 : function printed in file 'ree0_file.dat' +! +! * I_SR : switch for sum rules for epsilon printing +! I_SR = 0 : sum rules not calculated +! I_SR = 1 : sum rules printed in file 'sum_rules.dat' +! +! ~ +! +! * I_CW : switch for confinement wave function printing +! I_CW = 0 : confinement wave function not calculated +! I_CW = 1 : confinement wave function printed in file 'confin_wf.dat' +! +! * I_CF : switch for confinement potential printing +! I_CF = 0 : confinement potential not calculated +! I_CF = 1 : confinement potential printed in file 'confin_pt.dat' +! +! * I_EM : switch for effective mass printing +! I_EM = 0 : effective mass not calculated +! I_EM = 1 : effective mass printed in file 'effe_mass.dat' +! +! * I_MF : switch for mean free path printing +! I_MF = 0 : mean free path not calculated +! I_MF = 1 : mean free path printed in file 'mean_path.dat' +! +! ~ +! +! * I_SP : switch for spectral function printing +! I_SP = 0 : spectral function not calculated +! I_SP = 1 : spectral function printed in file 'spec_func.dat' +! +! * I_SE : switch for self-energy printing +! I_SE = 0 : self-energy not calculated +! I_SE = 1 : self-energy printed in file 'self_ener.dat' +! +! * I_SB : switch for subband energies printing +! I_SB = 0 : subband energies not calculated +! I_SB = 1 : subband energies printed in file 'subb_ener.dat' +! +! * I_ES : switch for Eliashberg function printing +! I_ES = 0 : Eliashberg function not calculated +! I_ES = 1 : Eliashberg function printed in file 'elia_func.dat' +! +! ~ +! +! * I_GR : switch for Grüneisen parameter printing +! I_GR = 0 : Grüneisen parameter not calculated +! I_GR = 1 : Grüneisen parameter printed in file 'grune_par.dat' +! +! * I_FD : switch for Fermi-Dirac distribution printing +! I_FD = 0 : Fermi-Dirac distribution not calculated +! I_FD = 1 : Fermi-Dirac distribution printed in file 'fermi_dir.dat' +! +! * I_BE : switch for Bose-Einstein distribution printing +! I_BE = 0 : Bose-Einstein distribution not calculated +! I_BE = 1 : Bose-Einstein distribution printed in file 'bose_eins.dat' +! +! * I_MX : switch for Maxwell distribution printing +! I_MX = 0 : Maxwell distribution not calculated +! I_MX = 1 : Maxwell distribution printed in file 'maxwell_d.dat' +! +! ~ +! +! * I_SC : switch for scale parameters printing +! I_SC = 0 : scale parameters not calculated +! I_SC = 1 : scale parameters printed in file 'scale_par.dat' +! +! * I_DS : switch for density of states printing +! I_DS = 0 : density of states not calculated +! I_DS = 1 : density of states printed in file 'dens_stat.dat' +! +! * I_NV : switch for Fourier domain Nevanlinaa/memory function printing +! I_NV = 0 : Nevanlinaa function not calculated +! I_NV = 1 : Nevanlinaa function printed in file 'neva_four.dat' +! +! * I_MT : switch for time domain memory function printing +! I_MT = 0 : memory function not calculated +! I_MT = 1 : memory function printed in file 'memo_time.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_GP : switch for grand partition function printing +! I_GP = 0 : grand partition function not calculated +! I_GP = 1 : grand partition function printed in file 'gran_part.dat' +! +! * I_PR : switch for electronic pressure printing +! I_PR = 0 : electronic pressure not calculated +! I_PR = 1 : electronic pressure printed in file 'epressure.dat' +! +! * I_CO : switch for compressibility printing +! I_CO = 0 : compressibility not calculated +! I_CO = 1 : compressibility printed in file 'comp_file.dat' +! +! * I_CP : switch for chemical potential printing +! I_CP = 0 : chemical potential not calculated +! I_CP = 1 : chemical potential printed in file 'chem_pote.dat' +! +! ~ +! +! * I_BM : switch for bulk modulus printing +! I_BM = 0 : bulk modulus not calculated +! I_BM = 1 : bulk modulus printed in file 'bulk_modu.dat' +! +! * I_SH : switch for shear modulus printing +! I_SH = 0 : shear modulus not calculated +! I_SH = 1 : shear modulus printed in file 'shear_mod.dat' +! +! * I_S0 : switch for zero sound velocity printing +! I_S0 = 0 : zero sound velocity not calculated +! I_S0 = 1 : zero sound velocity printed in file 'zero_soun.dat' +! +! * I_S1 : switch for first sound velocity printing +! I_S1 = 0 : first sound velocity not calculated +! I_S1 = 1 : first sound velocity printed in file 'firs_soun.dat' +! +! ~ +! +! * I_DT : switch for Debye temperature printing +! I_DT = 0 : Debye temperature not calculated +! I_DT = 1 : Debye temperature printed in file 'Debye_tmp.dat' +! +! * I_PS : switch for Pauli paramagnetic susceptibility printing +! I_PS = 0 : Pauli paramagnetic susceptibility not calculated +! I_PS = 1 : Pauli paramagnetic susceptibility printed in file 'para_susc.dat' +! +! * I_IE : switch for internal energy printing +! I_IE = 0 : internal energy not calculated +! I_IE = 1 : internal energy printed in file 'inter_ene.dat' +! +! * I_EI : switch for excess internal energy printing +! I_EI = 0 : excess internal energy not calculated +! I_EI = 1 : excess internal energy printed in file 'exces_ene.dat' +! +! ~ +! +! * I_FH : switch for Helmholtz free energy printing +! I_FH = 0 : Helmholtz free energy not calculated +! I_FH = 1 : Helmholtz free energy printed in file 'helm_free.dat' +! +! * I_EY : switch for entropy printing +! I_EY = 0 : entropy not calculated +! I_EY = 1 : entropy printed in file 'entropy_f.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_EF : switch for Fermi energy printing +! I_EF = 0 : Fermi energy not calculated +! I_EF = 1 : Fermi energy printed in file 'fermi_ene.dat' +! +! * I_KF : switch for Fermi momentum printing +! I_KF = 0 : Fermi momentum not calculated +! I_KF = 1 : Fermi momentum printed in file 'fermi_vec.dat' +! +! * I_VF : switch for Fermi velocity printing +! I_VF = 0 : Fermi velocity not calculated +! I_VF = 1 : Fermi velocity printed in file 'fermi_vel.dat' +! +! * I_TE : switch for Fermi temperature printing +! I_TE = 0 : Fermi temperature not calculated +! I_TE = 1 : Fermi temperature printed in file 'fermi_tmp.dat' +! +! ~ +! +! * I_DL : switch for density of states at Fermi level printing +! I_DL = 0 : density of states at Fermi level not calculated +! I_DL = 1 : density of states at Fermi level printed in file 'fermi_dos.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_TW : switch for thermal De Broglie wavelength printing +! I_TW = 0 : thermal De Broglie wavelength not calculated +! I_TW = 1 : thermal De Broglie wavelength printed in file 'thermal_w.dat' +! +! * I_VT : switch for thermal velocity printing +! I_VT = 0 : thermal velocity not calculated +! I_VT = 1 : thermal velocity printed in file 'thermal_v.dat' +! +! * I_TC : switch for thermal conductivity printing +! I_TC = 0 : thermal conductivity not calculated +! I_TC = 1 : thermal conductivity printed in file 'thermal_c.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_EG : switch for ground state energy printing +! I_EG = 0 : ground state energy not calculated +! I_EG = 1 : ground state energy printed in file 'ground_st.dat' +! +! * I_EX : switch for exchange energy printing +! I_EX = 0 : exchange energy not calculated +! I_EX = 1 : exchange energy printed in file 'ex_energy.dat' +! +! * I_XC : switch for exchange correlation energy printing +! I_XC = 0 : exchange correlation energy not calculated +! I_XC = 1 : exchange correlation energy printed in file 'xc_energy.dat' +! +! * I_EC : switch for correlation energy printing +! I_EC = 0 : correlation energy not calculated +! I_EC = 1 : correlation energy printed in file 'corr_ener.dat' +! +! ~ +! +! * I_HF : switch for Hartree-Fock energy printing +! I_HF = 0 : Hartree-Fock energy not calculated +! I_HF = 1 : Hartree-Fock energy printed in file 'hf_energy.dat' +! +! * I_EK : switch for kinetic energy printing +! I_EK = 0 : kinetic energy not calculated +! I_EK = 1 : kinetic energy printed in file 'kine_ener.dat' +! +! * I_EP : switch for potential energy printing +! I_EP = 0 : potential energy not calculated +! I_EP = 1 : potential energy printed in file 'pote_ener.dat +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_VI : switch for shear viscosity printing +! I_VI = 0 : shear viscosity not calculated +! I_VI = 1 : shear viscosity printed in file 'visc_coef.dat' +! +! * I_DI : switch for diffusion coefficient printing +! I_DI = 0 : diffusion coefficient not calculated +! I_DI = 1 : diffusion coefficient printed in file 'diff_coef.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_FP : switch for fluctuation potential calculation +! I_FP = 0 : fluctuation potential not calculated +! +! I_FP = 1 : fluctuation potential printed in file 'fluct_pot.dat' (function of q) \ exact +! I_FP = 2 : fluctuation potential printed in file 'fluct_pot.dat' (function of q and r) / dispersion +! +! I_FP = 3 : fluctuation potential printed in file 'fluct_pot.dat' (function of q) \ PL_DISP +! I_FP = 4 : fluctuation potential printed in file 'fluct_pot.dat' (function of q and r) / dispersion +! +! * I_EL : switch for loss function calculation +! I_EL = 0 : loss function not calculated +! I_EL = 1 : loss function printed in file 'ener_loss.dat' +! +! * I_PO : switch for stopping power calculation +! I_PO = 0 : stopping power not calculated +! I_PO = 1 : stopping power printed in file 'stop_powe.dat' +! +! * I_RF : switch for refractive index calculation +! I_RF = 0 : refractive index not calculated +! I_RF = 1 : refractive index printed in file 'refrac_in.dat' +! +! ~ +! +! * I_VC : switch for dynamic screened Coulomb potential V(q,omega) calculation +! I_VC = 0 : dynamic screened Coulomb potential not calculated +! I_VC = 1 : dynamic screened Coulomb potential printed in file 'dyna_coul.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_FN : switch for appending the calculation type string +! to the output filename +! I_FN = 0 : standard output filename +! I_FN = 1 : parameter added to filename +! +! * I_WR : switch for writing physical properties into the log file +! I_WR = 0 : does not write +! I_WR = 1 : writes +! I_WR = 2 : writes only for first q-index +! +! * I_TI : switch for writing integration tests into the log file +! I_TI = -1 : writes all the tests +! I_TI = 0 : does not write +! I_TI = 1 : writes test for MODULE SPECIFIC_INT_1 +! I_TI = 2 : writes test for MODULE SPECIFIC_INT_2 +! I_TI = 3 : writes test for MODULE SPECIFIC_INT_3 +! I_TI = 4 : writes test for MODULE SPECIFIC_INT_4 +! I_TI = 5 : writes test for MODULE SPECIFIC_INT_5 +! I_TI = 6 : writes test for MODULE SPECIFIC_INT_6 +! I_TI = 7 : writes test for MODULE SPECIFIC_INT_7 +! I_TI = 8 : writes test for MODULE SPECIFIC_INT_8 +! I_TI = 9 : writes test for MODULE SPECIFIC_INT_9 +! I_TI = 10 : writes test for MODULE TEST_INT_HUBBARD +! diff --git a/New_libraries/Data/replace.sh b/New_libraries/Data/replace.sh new file mode 100644 index 0000000..f8b3b13 --- /dev/null +++ b/New_libraries/Data/replace.sh @@ -0,0 +1,15 @@ +#!/bin/bash +# +# Replaces STRING1 by STRING2 in all the files +# named FILENAME*.dat +# +# +# Usage: replace STRING1 STRING2 FILENAME +# +# +name=$3*.dat +# +sed -i "s/`echo $1`/`echo $2`/g" `echo $name` +# +exit + diff --git a/New_libraries/Makefile b/New_libraries/Makefile new file mode 100644 index 0000000..79a5250 --- /dev/null +++ b/New_libraries/Makefile @@ -0,0 +1,243 @@ +# +# Makefile for the MsSpec-DFM epsilon.f90 program +# +# by S. Tricot and D. Sébilleau +# +# Last version: 21 Apr 2021 +# +# Compiler +# +FC=gfortran +# +# Compile flags +# +#FFLAGS= +FFLAGS=-g -fbounds-check -fbacktrace -ffpe-trap=zero,overflow,underflow,invalid,denormal +#FFLAGS=-ffast-math -O3 +# +# Link flags +# +LDFLAGS= +LDLIBS= +# +# Executable name +# +EXE=eps +# +# Building directory +# +BUILDDIR:=build2 + +.PHONY: clean + +cmn_DEPS:=DFM_library/ACCURACY_LIBRARY/accuracy.f90 \ + DFM_library/INPUT_OUTPUT_LIBRARY/input_values.f90 \ + DFM_library/DIMENSIONS_LIBRARY/dimensions.f90 \ + DFM_library/UTILITIES_LIBRARY/simple_numbers.f90 \ + DFM_library/UTILITIES_LIBRARY/powers_of_ten.f90 \ + DFM_library/UTILITIES_LIBRARY/mathematical_constants.f90 \ + DFM_library/UTILITIES_LIBRARY/physical_constants.f90 \ + DFM_library/UTILITIES_LIBRARY/factorials.f90 \ + DFM_library/ERROR_HANDLING_LIBRARY/error_caltech.f90 \ + DFM_library/PRINT_LIBRARY/printfiles.f90 \ + DFM_library/STRUCTURE_FACTOR_LIBRARY/utic_values.f90 \ + DFM_library/DAMPING_LIBRARY/external_damping.f90 \ + DFM_library/PHYSICAL_PROPERTIES_LIBRARY/Fermi_values.f90 +cmn_OBJS:=$(patsubst %.f90,%.o, $(cmn_DEPS)) + +tool_SRCS:=$(cmn_DEPS) \ + DFM_library/VARIOUS_FUNCTIONS_LIBRARY/external_functions.f90 \ + DFM_library/VARIOUS_FUNCTIONS_LIBRARY/Lindhard_function.f90 \ + DFM_library/VARIOUS_FUNCTIONS_LIBRARY/gamma.f90 \ + DFM_library/VARIOUS_FUNCTIONS_LIBRARY/digamma.f90 \ + DFM_library/VARIOUS_FUNCTIONS_LIBRARY/2F1_real.f90 \ + DFM_library/VARIOUS_FUNCTIONS_LIBRARY/mod_mlf_garrappa.f90 \ + DFM_library/UTILITIES_LIBRARY/derivation.f90 \ + DFM_library/UTILITIES_LIBRARY/smoothing.f90 \ + DFM_library/UTILITIES_LIBRARY/interpolation.f90 \ + DFM_library/UTILITIES_LIBRARY/integration.f90 \ + DFM_library/UTILITIES_LIBRARY/integration4.f90 \ + DFM_library/UTILITIES_LIBRARY/transforms.f90 \ + DFM_library/VARIOUS_FUNCTIONS_LIBRARY/basic_functions.f90 \ + DFM_library/VARIOUS_FUNCTIONS_LIBRARY/bessel.f90 +util_SRCS:=$(cmn_DEPS) \ + DFM_library/UTILITIES_LIBRARY/utilities_1.f90 \ + DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_1.f90 \ + DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_4.f90 \ + DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_6.f90 \ + DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_7.f90 \ + DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_8.f90 \ + DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_9.f90 \ + DFM_library/UTILITIES_LIBRARY/find_zero.f90 \ + DFM_library/UTILITIES_LIBRARY/polynomial_equations.f90 +prop_SRCS:=$(cmn_DEPS) \ + DFM_library/PHYSICAL_PROPERTIES_LIBRARY/calc_Fermi.f90 \ + DFM_library/PLASMON_LIBRARY/plasmon_ene.f90 \ + DFM_library/SCALE_PARAMETERS_LIBRARY/scale_parameters.f90 \ + DFM_library/ENERGIES_LIBRARY/correlation_energies.f90 \ + DFM_library/ENERGIES_LIBRARY/delta_t.f90 \ + DFM_library/PHYSICAL_PROPERTIES_LIBRARY/thermodynamic_properties.f90 \ + DFM_library/SCREENING_LIBRARY/screening_vec1.f90 \ + DFM_library/CONFINEMENT_LIBRARY/confinement_ff.f90 \ + DFM_library/CONFINEMENT_LIBRARY/coulomb.f90 \ + DFM_library/UTILITIES_LIBRARY/utilities_3.f90 \ + DFM_library/PHYSICAL_PROPERTIES_LIBRARY/material_properties.f90 \ + DFM_library/THERMAL_PROPERTIES_LIBRARY/thermal_properties.f90 \ + DFM_library/ENERGIES_LIBRARY/xc_energies.f90 \ + DFM_library/ENERGIES_LIBRARY/exchange_energies.f90 \ + DFM_library/ENERGIES_LIBRARY/kinetic_energies.f90 \ + DFM_library/PHYSICAL_PROPERTIES_LIBRARY/thermodynamic_quantities.f90 \ + DFM_library/THERMAL_PROPERTIES_LIBRARY/chemical_potential.f90 \ + DFM_library/UTILITIES_LIBRARY/utilities_4.f90 \ + DFM_library/PHYSICAL_PROPERTIES_LIBRARY/calc_energies.f90 +# +# Read input data file: +# +read_SRCS:=DFM_library/INPUT_OUTPUT_LIBRARY/read_data.f90 +read_OBJS:=$(patsubst %.f90,%.o, $(tool_SRCS) $(util_SRCS) $(prop_SRCS) $(read_SRCS)) + +io_SRCS:=DFM_library/INPUT_OUTPUT_LIBRARY/filenames.f90 \ + DFM_library/INPUT_OUTPUT_LIBRARY/outfiles.f90 \ + DFM_library/INPUT_OUTPUT_LIBRARY/change_filenames.f90 \ + DFM_library/INPUT_OUTPUT_LIBRARY/store_coef.f90 \ + DFM_library/INPUT_OUTPUT_LIBRARY/open_files.f90 \ + DFM_library/PRINT_LIBRARY/print_headers.f90 \ + DFM_library/PRINT_LIBRARY/print_calc_type.f90 \ + DFM_library/PRINT_LIBRARY/print_Fermi.f90 \ + DFM_library/PRINT_LIBRARY/print_plasmons.f90 \ + DFM_library/PRINT_LIBRARY/print_scale_param.f90 \ + DFM_library/PRINT_LIBRARY/print_material_lengths.f90 \ + DFM_library/PRINT_LIBRARY/print_thermal.f90 \ + DFM_library/PRINT_LIBRARY/print_thermodynamics.f90 \ + DFM_library/PRINT_LIBRARY/print_energies.f90 \ + DFM_library/INPUT_OUTPUT_LIBRARY/close_files.f90 +io_OBJS:=$(patsubst %.f90,%.o, $(io_SRCS)) + +calc_DEPS:=$(cmn_DEPS) \ + DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_static.f90 \ + DFM_library/ASYMPTOTIC_VALUES_LIBRARY/gr_asymptotic.f90 \ + DFM_library/ASYMPTOTIC_VALUES_LIBRARY/sq_asymptotic.f90 \ + DFM_library/CONFINEMENT_LIBRARY/confinement_wf.f90 \ + DFM_library/LOCAL_FIELD_LIBRARY/iq_functions_1.f90 \ + DFM_library/MOMENTS_LIBRARY/loss_moments.f90 \ + DFM_library/PAIR_DISTRIBUTION_FUNCTION/pair_distribution.f90 \ + DFM_library/PAIR_CORRELATION_LIBRARY/pair_correlation.f90 \ + DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_static.f90 \ + DFM_library/LOCAL_FIELD_LIBRARY/iq_functions_2.f90 \ + DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_2.f90 \ + DFM_library/ASYMPTOTIC_VALUES_LIBRARY/gamma_asymptotic.f90 \ + DFM_library/ASYMPTOTIC_VALUES_LIBRARY/calc_asymptotic.f90 \ + DFM_library/LOCAL_FIELD_LIBRARY/local_field_static.f90 \ + DFM_library/LOCAL_FIELD_LIBRARY/local_field_static_2.f90 \ + DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_static_2.f90 \ + DFM_library/NEVANLINNA_FUNCTIONS_LIBRARY/Nevanlinna_functions.f90 \ + DFM_library/MEMORY_FUNCTIONS_LIBRARY/memory_functions.f90 \ + DFM_library/SCREENING_LIBRARY/screening_vec2.f90 \ + DFM_library/UTILITIES_LIBRARY/velocities.f90 \ + DFM_library/SCALE_PARAMETERS_LIBRARY/scale_parameters.f90 \ + DFM_library/MOMENTS_LIBRARY/moments.f90 \ + DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_3.f90 \ + DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_10.f90 \ + DFM_library/VARIOUS_FUNCTIONS_LIBRARY/coulomb_log.f90 \ + DFM_library/DAMPING_LIBRARY/packing_fraction.f90 \ + DFM_library/DAMPING_LIBRARY/classical_fluid.f90 \ + DFM_library/DAMPING_LIBRARY/diffusion_coefficient.f90 \ + DFM_library/DAMPING_LIBRARY/electron_phonon_int.f90 \ + DFM_library/DAMPING_LIBRARY/scattering_length.f90 \ + DFM_library/DAMPING_LIBRARY/lifetime.f90 \ + DFM_library/DAMPING_LIBRARY/viscosity.f90 \ + DFM_library/DAMPING_LIBRARY/relaxation_time_static.f90 \ + DFM_library/UTILITIES_LIBRARY/utic_parameters.f90 \ + DFM_library/DAMPING_LIBRARY/decay_rate.f90 \ + DFM_library/DAMPING_LIBRARY/calc_damping.f90 \ + DFM_library/DAMPING_LIBRARY/diffusion_coefficient_2.f90 \ + DFM_library/PLASMON_LIBRARY/plasmon_dispersion.f90 \ + DFM_library/PLASMON_LIBRARY/q_bounds.f90 \ + DFM_library/DAMPING_LIBRARY/plasmon_damping.f90 \ + DFM_library/PHYSICAL_PROPERTIES_LIBRARY/calc_energies.f90 \ + DFM_library/PHYSICAL_PROPERTIES_LIBRARY/grand_partition.f90 \ + DFM_library/UTILITIES_LIBRARY/utilities_2.f90 \ + DFM_library/LANDAU_PARAMETERS_LIBRARY/landau.f90 \ + DFM_library/VARIOUS_FUNCTIONS_LIBRARY/phi_function.f90 \ + DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_stan_dynamic.f90 \ + DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_magn_dynamic.f90 \ + DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfunct_dynamic.f90 \ + DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_dynamic_2.f90 \ + DFM_library/INTERACTION_POTENTIALS_LIBRARY/interaction_potentials_r.f90 \ + DFM_library/INTERACTION_POTENTIALS_LIBRARY/interaction_potentials_k.f90 \ + DFM_library/DAMPING_LIBRARY/decay_rate.f90 \ + DFM_library/STRUCTURE_FACTOR_LIBRARY/structure_factor_dynamic.f90 \ + DFM_library/DIELECTRIC_FUNCTIONS_LIBRARY/dfuncl_stan_dynamic_2.f90 \ + DFM_library/DAMPING_LIBRARY/mean_free_path.f90 \ + DFM_library/SPECTRAL_FUNCTION_LIBRARY/spectral_function.f90 \ + DFM_library/LOCAL_FIELD_LIBRARY/local_field_dynamic.f90 \ + DFM_library/PRINT_LIBRARY/print_asymptotic.f90 \ + DFM_library/POST_PROCESSING_LIBRARY/re_eps_0_treatment.f90 \ + DFM_library/MOMENTS_LIBRARY/moments_loss.f90 \ + DFM_library/SPECIFIC_INTEGRALS_LIBRARY/specific_int_5.f90 +# +# Calculators: +# +calc_SRCS:=DFM_library/CALCULATORS_LIBRARY/calculators_1.f90 \ + DFM_library/CALCULATORS_LIBRARY/calculators_2.f90 \ + DFM_library/CALCULATORS_LIBRARY/calculators_3.f90 \ + DFM_library/CALCULATORS_LIBRARY/calculators_5.f90 \ + DFM_library/CALCULATORS_LIBRARY/calculators_7.f90 \ + DFM_library/CALCULATORS_LIBRARY/calculators_8.f90 \ + DFM_library/CALCULATORS_LIBRARY/calculators_9.f90 \ + DFM_library/CALCULATORS_LIBRARY/call_calc_1.f90 \ + DFM_library/CALCULATORS_LIBRARY/call_calc_2.f90 \ + DFM_library/CALCULATORS_LIBRARY/call_calc_3.f90 \ + DFM_library/CALCULATORS_LIBRARY/call_calc_5.f90 \ + DFM_library/CALCULATORS_LIBRARY/call_calc_7.f90 \ + DFM_library/CALCULATORS_LIBRARY/call_calc_8.f90 \ + DFM_library/CALCULATORS_LIBRARY/call_calc_9.f90 +# +# Test_integrals: +# +calc_TEST:=DFM_library/TEST_LIBRARY/test_integrals_2.f90 \ + DFM_library/TEST_LIBRARY/test_integrals_3.f90 \ + DFM_library/TEST_LIBRARY/test_integrals_8.f90 \ + DFM_library/TEST_LIBRARY/test_int_Hubbard.f90 +# +# Post-processing: +# +calc_POST:=DFM_library/PLASMON_LIBRARY/plasmon_dispersion_2.f90 \ + DFM_library/CALCULATORS_LIBRARY/calculators_p.f90 \ + DFM_library/CALCULATORS_LIBRARY/call_calc_p.f90 + +calc_OBJS:=$(patsubst %.f90,%.o, $(calc_DEPS) $(calc_SRCS) $(calc_TEST) $(calc_POST)) + + + +SRCS:= $(patsubst %.o,%.f90,$(read_OBJS) $(io_OBJS) $(calc_OBJS)) +OBJS:= $(addprefix $(BUILDDIR)/,$(notdir $(read_OBJS) $(io_OBJS) $(calc_OBJS))) + + +all: obj $(EXE) + + +obj: src $(OBJS) + + +$(EXE): $(OBJS) $(BUILDDIR)/epsilon.f90 + @echo "building main $@..." + @$(FC) $(FFLAGS) $(LDFLAGS) $(LDLIBS) -J $(BUILDDIR) -o $@ $^ + + +%.o: %.f90 + @echo "Compiling $@..." + @$(FC) $(FFLAGS) -J $(BUILDDIR) -I. -o $@ -c $^ + + +src: $(SRCS) epsilon.f90 + @echo "updating source tree..." + @mkdir -p $(BUILDDIR) + @rsync -av $^ $(BUILDDIR) + + +clean: + @echo "Cleaning..." + @rm -rf $(BUILDDIR) + @rm -rf $(EXE) + diff --git a/New_libraries/epsilon.f90 b/New_libraries/epsilon.f90 new file mode 100644 index 0000000..4db39ee --- /dev/null +++ b/New_libraries/epsilon.f90 @@ -0,0 +1,337 @@ +! +!======================================================================= +! +PROGRAM EPSILON +! +! This program computes model dielectric functions for many type +! of materials. These dielectric functions are essentially based +! on the Fermi liquid theory. +! +! Several other physical quantities, based on the +! dielectric function can also be computed, namely: +! +! * the loss function +! * the EELS cross-section +! * the plasmon fluctuation potential +! * the stopping power +! * the optical properties +! +! +! Lead developer: Didier Sébilleau +! +! Co-developers : Aditi Mandal, Sylvain Tricot +! +! +! +! Main notations : +! +! * X : dimensionless factor --> X = q / (2 * k_F) +! +! * Y : dimensionless factor --> Y = q / k_F +! +! * Z : dimensionless factor --> Z = omega / omega_q = V / (4 * X * X) +! +! * U : dimensionless factor --> U = omega / (q * v_F) = X * Z = V / (4 * X) +! +! * V : dimensionless factor --> V = omega / omega_{k_F} = Z * Y^2 = 4 U * X +! +! +! +! +! Last modified : 6 Aug 2021 +! +! + USE ACCURACY_REAL + USE DIMENSION_CODE, ONLY : NSIZE +! + USE SF_VALUES, ONLY : SQO_TYPE +! + USE REAL_NUMBERS, ONLY : ZERO,ONE,HALF,SMALL + USE MATERIAL_PROP, ONLY : RS,DMN + USE EXT_FIELDS, ONLY : H +! + USE Q_GRID +! + USE FERMI_VALUES + USE FERMI_VALUES_M + USE PLASMON_ENE + USE PLASMA_SCALE + USE CALC_ASYMPT +! + USE PRINT_CALC_TYPE + USE PRINT_HEADERS + USE PRINT_FERMI + USE PRINT_PLASMONS + USE PRINT_ASYMPTOTIC + USE PRINT_SCALE_PARAM + USE PRINT_MAT_LENGTHS + USE PRINT_THERMAL + USE PRINT_THERMODYNAMICS + USE PRINT_ENERGIES_EL +! + USE DAMPING_COEF + USE PLASMON_DISPERSION +! + USE CALL_CALC_1 + USE CALL_CALC_2 + USE CALL_CALC_3 + USE CALL_CALC_5 + USE CALL_CALC_7 + USE CALL_CALC_9 + USE CALL_CALC_P +! + USE TEST_INTEGRALS_2 + USE TEST_INTEGRALS_3 + USE TEST_INTEGRALS_8 + USE TEST_INT_HUBBARD +! + USE RE_EPS_0_TREATMENT +! + USE INPUT_DATA +! + USE OUT_VALUES_10 +! + USE OUT_CALC +! + USE CHANGE_FILENAMES +! + USE OPEN_OUTFILES + USE CLOSE_OUTFILES +! + IMPLICIT NONE +! + INTEGER :: N_IF,JF + INTEGER :: IQ,IE +! + REAL (WP) :: Q,X + REAL (WP) :: EPSR(NSIZE),EPSI(NSIZE),EN(NSIZE) +! + CHARACTER (LEN = 100) :: INPDATA(999) + CHARACTER (LEN = 100) :: LOGFILE(999) +! +! Loop on the input data files +! +! N_IF = 11 + N_IF = 1 +! READ(*,15) N_IF ! +! DO JF = 1,N_IF ! +! READ(*,25) INPDATA(JF) ! +! END DO ! + INPDATA(1) = 'Data/epsilon.dat' +! INPDATA(1) = 'Data/epsilon_00.dat' +! INPDATA(2) = 'Data/epsilon_01.dat' +! INPDATA(3) = 'Data/epsilon_02.dat' +! INPDATA(4) = 'Data/epsilon_03.dat' +! INPDATA(5) = 'Data/epsilon_04.dat' +! INPDATA(6) = 'Data/epsilon_05.dat' +! INPDATA(7) = 'Data/epsilon_06.dat' +! INPDATA(8) = 'Data/epsilon_07.dat' +! INPDATA(9) = 'Data/epsilon_08.dat' +! INPDATA(10) = 'Data/epsilon_09.dat' +! INPDATA(11) = 'Data/epsilon_10.dat' +! +! +! Name of the corresponding log files +! + CALL LOGFILE_NAMES(N_IF,LOGFILE) ! +! + DO JF = 1,N_IF ! start loop on files +! +! Initialization of the arrays +! + DO IE=1,NSIZE ! + EN(IE) = ZERO ! + EPSR(IE) = ZERO ! + EPSI(IE) = ZERO ! + END DO ! +! +! Opening input/log data files +! + OPEN(UNIT=5,FILE=TRIM(INPDATA(JF)),STATUS='OLD') ! + OPEN(UNIT=6,FILE=TRIM(LOGFILE(JF)),STATUS='UNKNOWN') ! +! +! Printing the headers +! + CALL PRINT_ASCII ! +! +! Reading the input data file +! + CALL READ_DATA ! +! + IF(SQO_TYPE == 'UTI') THEN ! + OPEN(UNIT = 1, FILE = 'Results/utic_para.dat', & ! + STATUS = 'unknown') ! + END IF ! +! +! Opening result files +! + CALL OPEN_OUTPUT_FILES(N_IF,JF) ! +! +! Post-processing: +! + IF(PL_DISP == ' EXACT') THEN ! + I_PP = I_FP + I_PD ! + ELSE ! + I_PP = I_FP ! + END IF ! +! +! Printing the information on the calculations to be performed +! +! CALL PRINT_CALC_INFO ! +! +! Computation of the Fermi values and storage +! + WRITE(6,10) ! +! + IF(H < SMALL) THEN ! + CALL CALC_FERMI(DMN,RS) ! + CALL PRINT_FERMI_SI ! + ELSE ! + CALL CALC_FERMI_M(DMN,RS) ! + CALL PRINT_FERMI_SI_M ! + END IF ! +! +! Test of the integrals +! + IF(I_TI /= 0) THEN ! + IF(I_TI == 2) CALL CALC_TEST_INT_2 ! + IF(I_TI == 3) CALL CALC_TEST_INT_3 ! + IF(I_TI == 8) CALL CALC_TEST_INT_8 ! + IF(I_TI == 10) CALL CALC_TEST_HUBBARD ! + END IF ! +! +! Computation of the plasmon properties and storage +! + CALL CALC_PLASMON_ENE ! + CALL CALC_PLASMA_SCALE ! +! +! Computation of the asymptotic values and storage +! +! CALL CALC_ASYMPT_VALUES ! +! +! Selective printing of physical properties (log file) +! + IF(I_WR == 1) THEN ! +! +! Printing the plasma properties +! + WRITE(6,10) ! + CALL PRINT_PLASMA ! +! +! Printing the asymptotic values +! + WRITE(6,10) ! + CALL PRINT_ASYMPT_VALUES ! +! +! Printing the scale parameters +! + WRITE(6,10) ! + CALL PRINT_SCALE_PARAMETERS ! +! +! Printing the material's characteristic lengths +! + WRITE(6,10) ! + CALL PRINT_CHAR_LENGTHS ! +! +! Printing the thermal properties +! + WRITE(6,10) ! + CALL PRINT_THERMAL_PROP ! +! +! Printing the thermodynamics properties +! + WRITE(6,10) ! + CALL PRINT_THERMODYNAMICS_PROP ! +! +! Printing the energies at q = 0 +! + WRITE(6,10) ! + CALL PRINT_ENERGIES(ZERO,0,ZERO,ONE) ! +! + END IF ! +! +! Calling calculator 5 (Fermi properties) +! + IF(I_C5 > 0) CALL USE_CALC_5 ! +! +! Starting the loop on q +! (the loop on energy is inside the calculators) +! +! +!.......... Loop on plasmon momentum Q .......... +! + DO IQ = 1,N_Q ! +! + Q = Q_MIN + FLOAT(IQ - 1) * Q_STEP ! Q = q/k_F +! + X = HALF * Q ! X = q/(2k_f) +! +! Computing and printing the damping (if any) +! + CALL CALC_DAMPING(IQ,X) +! +! Calling calculator 1 (eps, pi, chi, sigma) +! + IF(I_C1 > 0) CALL USE_CALC_1(X,EN,EPSR,EPSI) ! +! +! Calling calculator 2 +! + IF(I_C2 > 0) CALL USE_CALC_2(IQ,X) ! +! +! Calling calculator 3 +! + IF(I_C3 > 0) CALL USE_CALC_3(IQ,X) ! +! +! Calling calculator 9 +! + IF(I_C9 > 0) CALL USE_CALC_9(X) ! +! +! Calling test calculator +! +! CALL CALC_TEST(IQ,X) +! +!.......... End of loop on plasmon momentum Q .......... +! + END DO ! +! +! Calling calculator 7 (Energies) +! + IF(I_C7 > 0) CALL USE_CALC_7 ! +! +! Post-processing whenever requested +! + IF(I_PP > 0) CALL USE_CALC_P ! +! + IF(I_ZE == 1) THEN ! + CALL REORDER_EPS0_PRINT ! + END IF ! +! +! Closing input/log data files +! + CLOSE(5) ! + CLOSE(6) ! +! + IF(SQO_TYPE == 'UTI') THEN ! + CLOSE(1) ! + END IF ! + +! +! Closing the indexed result files +! + CALL CLOSE_OUTPUT_FILES(0) ! +! +! End of input data files loop +! + END DO ! +! +! Closing the other result files +! + CALL CLOSE_OUTPUT_FILES(1) ! +! +! Formats: +! + 10 FORMAT(' ') + 15 FORMAT(I3) + 25 FORMAT(A50) +! +END PROGRAM EPSILON diff --git a/README b/README new file mode 100644 index 0000000..de2fba8 --- /dev/null +++ b/README @@ -0,0 +1,1102 @@ +! +! Description of the calculation parameters: +! +! *=======+=========+=========+=========+=========+===========================* +! * GENERAL PARAMETERS : * +! *=======+=========+=========+=========+=========+===========================* +! +! * Q_MIN : minimum value of q (in units of k_F) +! * Q_MAX : maximum value of q (in units of k_F) +! * N_Q : number of q-points +! +! * E_MIN : minimum value of energy (in units of E_F) +! * E_MAX : maximum value of energy (in units of E_F) +! * N_E : number of E-points +! +! * R_MIN : minimum value of distance r (in units of 1/k_F) +! * R_MAX : maximum value of distance r (in units of 1/k_F)) +! * N_R : number of r-points +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * RS : average distance between 2 electrons (in units of a0) +! ~ +! * MSOM : m*/m (for semiconductors) +! ~ +! * MAT_TYP : type of material +! MAT_TYPE = 'SCHRO' standard solid +! MAT_TYPE = 'DIRAC' massless Fermions +! MAT_TYPE = 'WATER' liquid water +! ~ +! * EPS_B : material's dielectric constant +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * T : temperature (in SI) +! ~ +! * E : external electric field (in SI) +! ~ +! * H : external magnetic field (in SI) +! ~ +! * FLD : strength of the magnetic field +! FLD = 'NO' no field +! FLD = 'WF' weak field +! FLD = 'IF' intermediate field +! FLD = 'LF' large field +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * DIM : dimension of the system +! DIM = '3D' +! DIM = '2D' +! DIM = '1D' +! DIM = 'Q0' quasi-0D +! DIM = 'Q1' quasi-1D +! DIM = 'Q2' quasi-2D +! DIM = 'BL' bilayer +! DIM = 'ML' multilayer +! DIM = 'ML' multilayer +! +! ~ +! +! * R0 : wire radius +! ~ +! * L : length of quantum well +! ~ +! * OM0 : frequency of the confinement potential (SI) +! ~ +! * CONFIN : type of confinement +! CONFIN = 'NO-CONF' no confinement +! CONFIN = 'DSEPLAY' layer within a stacking of layers +! CONFIN = 'CC-1111' cylindrical within subband 1 +! CONFIN = 'CC-1122' cylindrical between subbands 1 and 2 +! CONFIN = 'CC-1221' cylindrical between subbands 1 and 2 +! CONFIN = 'CC-2222' cylindrical within subband 2 +! CONFIN = 'HC-1111' harmonic within subband 1 +! CONFIN = 'HC-1122' harmonic between subbands 1 and 2 +! CONFIN = 'HC-1221' harmonic between subbands 1 and 2 +! CONFIN = 'HC-2222' harmonic within subband 2 +! CONFIN = 'INVLAYE' inversion layer in semiconductor +! CONFIN = 'IQWE_LB' square well with an infinite barrier +! CONFIN = 'PC1_QWI' parabolic +! CONFIN = 'PC2_QWI' parabolic +! CONFIN = 'SOFTCOR' soft-core potential +! CONFIN = 'SWC_QWI' square well with an infinite barrier +! +! ~ +! +! * DL : interlayer distance +! ~ +! * D1 : distance between the two layers in the unit cell +! ~ +! * N_DEP : electron concentration in depletion layer (SI) +! ~ +! * N_INV : electron concentration in inversion layer (SI) +! +! ~ +! +! * H_TYPE : heterostructure type +! H_TYPE = 'SSL1' semiconductor superlattice of type I +! H_TYPE = 'SSL2' semiconductor superlattice of type II +! H_TYPE = 'BILA' bilayer +! H_TYPE = 'MLA1' multilayer with with one layer / unit cell +! H_TYPE = 'MLA2' multilayer with with two layers / unit cell +! ~ +! * EPS_1 : background/layer dielectric constant +! ~ +! * EPS_2 : interlayer dielectric constant +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * UNIT : system unit +! UNIT = 'SIU' international system +! UNIT = 'CGS' CGS system +! UNIT = 'ATU' atomic units +! +! * UNIK : K unit +! UNIK = 'SI' international system +! UNIK = 'AU' atomic units +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * SC_TYPE : type of screeening +! SC_TYPE = 'NO' no screening +! SC_TYPE = 'DH' Debye-Hückel +! SC_TYPE = 'KL' Kleinman +! SC_TYPE = 'ST' Streitenberger +! SC_TYPE = 'TF' Thomas-Fermi +! SC_TYPE = 'UI' Utsumi-Ichimaru +! SC_TYPE = 'YT' Yasuhara-Takada +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * PL_TYPE : type of plasma considered +! PL_TYPE = 'OCP' --> one-component plasma (~ electron gas) +! PL_TYPE = 'DCP' --> two-component plasma +! +! * ZION : atomic number of (first) ion +! +! * ZION2 : atomic number of second ion +! +! *=======+=========+=========+=========+=========+===========================* +! * DIELECTRIC FUNCTION : * +! *=======+=========+=========+=========+=========+===========================* +! +! +! * ESTDY : static vs dynamic dielectric function +! STDY = ' STATIC' +! STDY = 'DYNAMIC' +! +! * EPS_T : type of dielcectric function +! EPS_T = 'LONG' longitudinal --> D_FUNCL +! EPS_T = 'TRAN' transverse --> D_FUNCT +! +! * D_FUNC : model of dielectric function : +! +! 1) Static: +! +! ---> longitudinal: +! +! D_FUNCL = 'LRPA' random phase approximation (3D,2D,1D) +! D_FUNCL = 'THFE' Thomas-Fermi approximation (3D,2D,1D) +! +! 2) Dynamic: +! +! ---> transverse: +! +! D_FUNCT = 'RPA1' random phase approximation (3D,2D) +! D_FUNCT = 'RPA2' random phase approximation (3D) +! D_FUNCT = 'LVLA' linearized Vlasov (3D) +! D_FUNCT = 'MER1' Mermin (3D) +! D_FUNCT = 'BLTZ' Boltzmann (3D) +! +! ---> longitudinal: +! +! D_FUNCL = 'ATAS' Atwal-Ashcroft <-- T-dependent +! D_FUNCL = 'BLZ1' Boltzmann +! D_FUNCL = 'BLZ2' damped Boltzmann +! D_FUNCL = 'DACA' Arista-Brandt <-- T-dependent +! D_FUNCL = 'HEAP' Hertel-Appel +! D_FUNCL = 'HAFO' Hartree-Fock +! D_FUNCL = 'HUCO' Hu-O'Connell <-- damping (3D,2D,Q1) +! D_FUNCL = 'HYDR' hydrodynamic <-- damping +! D_FUNCL = 'KLEI' Kleinman <-- T-dependent +! D_FUNCL = 'KLKD' Klimontovich-Kraeft <-- T-dependent +! D_FUNCL = 'KLKN' Klimontovich-Kraeft <-- T-dependent +! D_FUNCL = 'LAND' Landau parameters-based +! D_FUNCL = 'LVL1' linearized Vlasov (weak coupling) <-- T-dependent +! D_FUNCL = 'LVL2' linearized Vlasov (strong coupling) <-- T-dependent +! D_FUNCL = 'MER1' Mermin 1 <-- damping +! D_FUNCL = 'MER2' Mermin 2 <-- T-dependent +! D_FUNCL = 'MSAP' mean spherical approximation +! D_FUNCL = 'NEVA' Nevanlinna <-- T-dependent +! D_FUNCL = 'PLPO' plasmon pole +! D_FUNCL = 'RDF1' Altshuler et al <-- damping +! D_FUNCL = 'RDF2' Altshuler et al <-- damping +! D_FUNCL = 'RPA1' RPA +! D_FUNCL = 'RPA2' RPA <-- T-dependent +! D_FUNCL = 'RPA3' random phase approximation <-- magnetic field (2D) +! D_FUNCL = 'UTIC' Utsumi-Ichimaru <-- T-dependent +! D_FUNCL = 'VLFP' Vlasov-Fokker-Planck <-- damping +! +! * NEV_TYPE : type of Nevalinna function used (only for D_FUNCL = 'NEVA') +! NEV_TYPE = 'NONE' --> no function +! NEV_TYPE = 'STA1' --> static value h(q) +! NEV_TYPE = 'STA2' --> static value h(q) +! NEV_TYPE = 'CLCO' --> Classical Coulomb OCP +! NEV_TYPE = 'AMTA' --> Adamjan-Meyer-Tkachenko +! NEV_TYPE = 'PEEL' --> Perel'-Eliashberg function +! NEV_TYPE = 'PE76' --> Perel'-Eliashberg by Arkhipov et al +! +! ~ +! +! * I_T : way to incorporate temperature dependence +! I_T = 0 --> no temperature (T = 0) +! I_T = 1 --> analytical models used +! I_T = 2 --> temperature convolution +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * PL_DISP : method used to compute the plasmon dispersion (3D real case) +! PL_DISP = 'HYDRODY' hydrodynamic model +! PL_DISP = 'RPA_MOD' RPA model +! PL_DISP = 'TWA_MOD' Toigo-Woodruff model +! PL_DISP = 'GOA_MOD' Gorobchenko model +! PL_DISP = 'HUBBARD' Hubbard model +! PL_DISP = 'ELASTIC' elastic model +! PL_DISP = 'SGBBN_M' SGBBN model +! PL_DISP = 'UTI_MOD' Utsumi-Ichimaru model +! * PL_DISP : method used to compute the plasmon dispersion (2D real case) +! PL_DISP = 'HYDRODY' hydrodynamic model +! PL_DISP = 'RPA_MOD' RPA model +! * PL_DISP : method used to compute the plasmon dispersion (1D real case) +! PL_DISP = 'HYDRODY' hydrodynamic model +! PL_DISP = 'RPA_MOD' RPA model +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * GSTDY : static vs dynamic local-field corrections +! GSTDY = ' STATIC' --> GQ_TYPE +! GSTDY = 'DYNAMIC' --> GQO_TYPE +! +! * GQ_TYPE : local-field correction type (3D) static +! GQ_TYPE = 'NONE' no local field correction +! GQ_TYPE = 'ALDA' adiabatic local density +! GQ_TYPE = 'ALFL' Alvarellos-Flores +! GQ_TYPE = 'BEBR' Bedell-Brown +! GQ_TYPE = 'CDOP' TDDFT Corradini et al correction +! GQ_TYPE = 'GEV2' Geldart-Vosko 2 +! GQ_TYPE = 'GEVO' Geldart-Vosko correction +! GQ_TYPE = 'GOCA' Gold-Calmels +! temperature-dep. --> GQ_TYPE = 'HNCA' hypernetted chain +! GQ_TYPE = 'HORA' Holas-Rahman +! GQ_TYPE = 'HUBB' Hubbard correction (only exchange) +! GQ_TYPE = 'ICUT' Ichimaru-Utsumi correction +! GQ_TYPE = 'IKPA' Iwamoto-Krotscheck-Pines +! GQ_TYPE = 'IWA1' Iwamoto G_{-1} +! GQ_TYPE = 'IWA2' Iwamoto G_{3} approx. +! temperature-dep. --> GQ_TYPE = 'IWA3' Iwamoto G_{-1} +! GQ_TYPE = 'IWA4' Iwamoto G_{3} exact +! GQ_TYPE = 'JGDG' Jung-Garcia-Gonzalez-Dobson-Godby +! GQ_TYPE = 'KLLA' Kleinman-Langreth correction +! GQ_TYPE = 'LDAC' LDA correction +! GQ_TYPE = 'MCSC' Moroni-Ceperley-Senatore correction +! GQ_TYPE = 'NAGY' Nagy correction +! GQ_TYPE = 'PAVA' Pavas-Vashishta correction +! GQ_TYPE = 'PGGA' Petersilka-Gossmann-Gross +! GQ_TYPE = 'RICE' Rice correction +! GQ_TYPE = 'SHAW' Shaw correction +! GQ_TYPE = 'SLAT' Slater correction +! GQ_TYPE = 'STLS' Singwi et al correction +! temperature-dep. --> GQ_TYPE = 'TKAC' Tkachenko correction +! GQ_TYPE = 'TRMA' Tripathy-Mandal +! GQ_TYPE = 'VASI' Vashishta-Singwi correction +! GQ_TYPE = 'UTI1' Utsumi-Ichimaru correction (only exchange) +! +! * GQ_TYPE : local-field correction type (2D) static +! GQ_TYPE = 'NONE' no local field correction +! GQ_TYPE = 'BUTO' Bulutay-Tomak +! GQ_TYPE = 'DPGT' Davoudi-Giuliani-Giuliani-Tosi +! GQ_TYPE = 'GOCA' Gold-Calmels +! GQ_TYPE = 'HUBB' Hubbard correction (only exchange) +! GQ_TYPE = 'IWA1' Iwamoto G_{-1} +! GQ_TYPE = 'IWA2' Iwamoto G_{3} +! GQ_TYPE = 'SAIC' Sato-Ichimaru correction +! +! * GQ_TYPE : local-field correction type (1D) static +! GQ_TYPE = 'NONE' no local field correction +! GQ_TYPE = 'GOCA' Gold-Calmels +! GQ_TYPE = 'HUBB' Hubbard correction (only exchange) +! +! * IQ_TYPE : type of approximation for I(q) +! IQ_TYPE = 'GKM' Gorobchenko-Kohn-Maksimov +! IQ_TYPE = 'HKA' Hong-Kim +! IQ_TYPE = 'IKP' Iwamoto-Krotscheck-Pines parametrization +! IQ_TYPE = 'KU1' Kugler 1 +! IQ_TYPE = 'KU2' Kugler 1 +! +! ~ +! +! * LANDAU : model chosen for the calculation of the Landau parameters (3D) +! LANDAU = 'NONE' Landau's theory not used +! LANDAU = 'CHEN' Chen's approach +! LANDAU = 'RASC' Rayleigh-Schrödinger expansion +! LANDAU = 'ANBR' Anderson-Brinkman model +! LANDAU = 'GUTZ' Gutzwiller model +! LANDAU = 'IWPI' Iwamoto-Pines model (hard-sphere) +! LANDAU = 'GCYO' Giuliani-Vignale parametrization of +! Yasuhara-Ousaka approach +! LANDAU = 'SBOH' slave-boson one-band Hubbard model +! +! * LANDAU : model chosen for the calculation of the Landau parameters (2D) +! LANDAU = 'NONE' Landau's theory not used +! LANDAU = 'ERZA' Engelbrecht-Randeria-Zhang approach +! LANDAU = 'GVYO' Giuliani-Vignale parametrization of +! Yasuhara-Ousaka approach +! LANDAU = 'KCMP' Kwoon-Ceperley-Martin parametrization +! * GQO_TYPE : local-field correction type (3D) +! GQO_TYPE = 'NONE' no local field correction +! GQO_TYPE = 'ALFL' Alvarellos-Flores correction +! GQO_TYPE = 'BACA' Barriga-Carrasco correction +! GQO_TYPE = 'BBSA' Bachlechner-Böhm-Schinner +! GQO_TYPE = 'COPI' Constantin-Pitarke +! GQO_TYPE = 'DABR' Dabrowski +! GQO_TYPE = 'FWRA' Forstmann-Wierling-Röpke +! GQO_TYPE = 'HOK1' Hong-Kim correction +! GQO_TYPE = 'HOK2' Hong-Kim correction +! GQO_TYPE = 'JEWS' Jewsbury approximation +! GQO_TYPE = 'KUG1' Kugler q --> 0 approximation +! GQO_TYPE = 'KUG2' Kugler approximation +! GQO_TYPE = 'MDGA' Mithen-Daligault-Gregori +! GQO_TYPE = 'NLGA' Nagy-Laszlo-Giber approximation +! GQO_TYPE = 'RIA1' Richardson-Ashcroft G_s +! GQO_TYPE = 'RIA2' Richardson-Ashcroft G_n +! GQO_TYPE = 'RIA3' Richardson-Ashcroft G_a +! GQO_TYPE = 'SHMU' Shah-Mukhopadhyay +! GQO_TYPE = 'TOWO' Toigo-Woodruff +! GQO_TYPE = 'UTI2' Utsumi-Ichimaru approximation +! GQO_TYPE = 'VISC' viscosity approximation +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * DAMPING : type of damping used +! DAMPING = 'NONE' no damping +! DAMPING = 'LFTM' lifetime +! DAMPING = 'RELA' relaxation time +! DAMPING = 'DECA' decay rate +! DAMPING = 'DIFF' diffusion coefficient +! DAMPING = 'VISC' viscosity +! +! * LT_TYPE : approximation used for lifetime (3D) +! LT_TYPE = 'DAVI' Davies formula +! LT_TYPE = 'GALI' Galitskii formula +! LT_TYPE = 'GIQU' Giuliani-Quinn formula +! LT_TYPE = 'GIVI' Giuliani-Vignale formula +! LT_TYPE = 'INPE' Inogamov-Petrov formula +! LT_TYPE = 'LUBR' Lugovskoy-Bray formula +! LT_TYPE = 'NAEC' Nagy-Echenique formula +! LT_TYPE = 'QIVI' Qian-Vignale formula +! LT_TYPE = 'QUFE' Quinn-Ferrell formula +! +! * LT_TYPE : approximation used for lifetime (2D) +! LT_TYPE = 'GIQ1' Giuliani-Quinn formula for e-h loss +! LT_TYPE = 'GIQ2' Giuliani-Quinn formula for plasmon loss +! LT_TYPE = 'GIVI' Giuliani-Vignale formula +! LT_TYPE = 'HAWR' Hawrylak formula +! LT_TYPE = 'MELA' Menashe-Laikhtman formula +! LT_TYPE = 'QIVI' Qian-Vignale formula +! +! * RT_TYPE : relaxation time +! RT_TYPE = ' NO' --> no relaxation time +! RT_TYPE = 'E-E' --> electron-electron interaction +! RT_TYPE = 'E-P' --> electron-phonon interaction +! RT_TYPE = 'E-I' --> electron-phonon impurity +! RT_TYPE = 'ALL' --> all three taken into account +! +! ~ +! +! * DR_TYPE : decay rate in 3D +! DR_TYPE = 'UTIC' --> Utsumi-Ichimaru approximation +! DR_TYPE = 'VLAS' --> Vlasov approximation +! +! * DC_TYPE : diffusion coefficient in 3D +! DC_TYPE = 'ASHO' --> Ashurst-Hoover +! +! * VI_TYPE : viscosity in 3D +! VI_TYPE = 'AMPP' Angilella et al hard-sphere fluid --> T-dependent +! VI_TYPE = 'DRBA' Daligault-Rasmussen-Baalrud (plasmas) --> T-dependent +! VI_TYPE = 'KHRA' Khrapak for Yukawa fluid --> T-dependent +! VI_TYPE = 'LHPO' Longuet-Higgins-Pope --> T-dependent +! VI_TYPE = 'SCHA' Schäfer --> T-dependent +! VI_TYPE = 'SCHD' Schäfer (dynamic) --> T-dependent +! VI_TYPE = 'SHTE' Shternin --> T-dependent +! VI_TYPE = 'STEI' Steinberg low-temperature --> T-dependent +! +! * VI_TYPE : viscosity in 2D +! VI_TYPE = 'SCHA' Schäfer --> T-dependent +! graphene <-- VI_TYPE = 'KISC' Kiselev-Schmalian (dynamic) --> T-dependent +! graphene <-- VI_TYPE = 'MSFA' Müller-Schmalian-Fritz --> T-dependent +! +! ~ +! +! * EE_TYPE : e-e relaxation time in 3D +! RT_TYPE = 'ALAR' --> Al'tshuler-Aronov (e-e + impurities) +! RT_TYPE = 'BACA' --> Barriga-Carrasco approximation (e-e) +! RT_TYPE = 'FSTB' --> Fann et al approximation (e-e) +! RT_TYPE = 'QIVI' --> Qian-Vignale (e-e) +! RT_TYPE = 'RASM' --> Rammer-Smith (e-e) +! RT_TYPE = 'UTIC' --> Utsumi-Ichimaru approximation (e-e) +! RT_TYPE = 'TAIC' --> Tanaka-Ichimaru approximation (e-e) +! +! +! * EE_TYPE : relaxation time in 2D +! EE_TYPE = 'FUAB' --> Fukuyama-Abrahams (disordered metals) +! graphene <-- EE_TYPE = 'LUFO' --> Lucas-Fong (e-e) +! EE_TYPE = 'QIVI' --> Qian-Vignale (e-e) +! EE_TYPE = 'RASM' --> Rammer-Smith (e-e) +! heterostructures <-- EE_TYPE = 'REWI' --> Reizer-Wilkins (e-e) +! EI_TYPE = 'SHAS' --> Sharma-Ashraf (e-e + impurities) +! EE_TYPE = 'ZHDA' --> Zhang-Das Sarma (e-e) +! +! * EE_TYPE : relaxation time in 1D +! EI_TYPE = 'SHAS' --> Sharma-Ashraf (e-e + impurities) +! +! * EP_TYPE : e-phonon relaxation time in 3D +! EP_TYPE = 'STEL' --> Steinberg low-temperature +! EP_TYPE = 'STEH' --> Steinberg High-temperature +! +! * EI_TYPE : e-impurit relaxation time in 3D +! EI_TYPE = 'HEAP' --> Hertel-Appel approximation +! +! ~ +! +! * IP_TYPE : ion plasma relaxation time in 3D +! IP_TYPE = 'SEMO' --> Selchow-Morawetz approximation +! IP_TYPE = 'SPIT' --> Spitzer approximation +! +! * PD_TYPE : method used to compute the plasmon damping (3D) +! PD_TYPE = 'NONE' --> no plasmon damping +! PD_TYPE = 'CALL' --> Callen approximation +! PD_TYPE = 'DGKA' --> DuBois-Gilinsky-Kivelson approximation +! PD_TYPE = 'FEWA' --> Fetter and Walecka approximation +! PD_TYPE = 'JEWS' --> Jewsbury approximation +! PD_TYPE = 'LITI' --> Giuliani-Quinn lifetime approximation +! PD_TYPE = 'MOPE' --> Molinari-Peerani approximation +! PD_TYPE = 'NPSA' --> Ninham-Powel-Swanson approximation +! PD_TYPE = 'SGAA' --> Segui-Gervasoni-Arista approximation +! +! ~ +! +! * QD_TYPE : method used to compute q-dependent relaxation time +! QD_TYPE = 'NONE' --> no q-dependence +! QD_TYPE = 'GAUS' --> Gaussian +! QD_TYPE = 'LORE' --> Lorentzian +! +! * ZETA : Value of Tanaka-Ichimaru parameter +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * INT_POT : type of interaction potential (3D) +! INT_POT = 'COULO' Coulomb interaction +! INT_POT= 'YUKAW' Yukawa interaction +! INT_POT= 'RPAPO' RPA interaction +! INT_POT = 'OVER1' Overhauser interaction +! INT_POT = 'OVER2' modified Overhauser interaction +! INT_POT = 'DEUTS' Deutsch interaction +! INT_POT = 'PHOLE' particle-hole interaction +! INT_POT = 'KELBG' Kelbg interaction +! +! * S : +! +! * EPS : +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * EK : electron kinetic energy (eV) +! * EP_C : electron-phonon coupling +! * DEBYE_T : material Debye temperature +! +! ~ +! +! * NA : number of atoms per unit volume +! * MA : mass of the atoms +! * RA : radius of the atoms +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * NI : impurity concentration +! * EI_C : strength of impurity scattering +! +! *-------+---------+---------+---------+---------+---------------------------* +! + +! * CF_TYPE : type of classical fluid calculation --> 3D +! CF_TYPE = 'SHS' smooth hard spheres +! CF_TYPE = 'RH1' rough hard spheres (Pidduck) +! CF_TYPE = 'RH2' rough hard spheres (Condiff-Lu-Dahler) +! CF_TYPE = 'RH3' rough hard spheres (McCoy-Sandler-Dahler) +! CF_TYPE = 'DCE' dilute Chapman-Enskog +! CF_TYPE = 'HCE' heavy (i.e. dense) Chapman-Enskog +! CF_TYPE = 'LJF' Lennard-Jones fluid + +! CF_TYPE = 'DHD' dense hard disks --> 2D + +! * PF_TYPE : type of packing fraction --> 2D +! PF_TYPE = 'HDM' --> hard disk model +! +! --> 3D +! PF_TYPE = 'HSM' --> hard sphere model +! PF_TYPE = 'RCP' --> random closed-packed +! PF_TYPE = 'FCC' --> FCC closed-packed +! PF_TYPE = 'FRE' --> freezing +! PF_TYPE = 'MEL' --> melting +! +! * SL_TYPE : type of scattering length calculation +! SL_TYPE = 'HSP' --> hard sphere potential +! SL_TYPE = 'ASW' --> attractive square well (without bound state) +! SL_TYPE = 'RSW' --> repulsive square well +! SL_TYPE = 'DSP' --> delta-shell potential +! SL_TYPE = 'AYP' --> attractive Yukawa potential +! SL_TYPE = 'CCO' --> Coulomb cut-off potential +! SL_TYPE = 'HUL' --> Hulthén potential +! +! *=======+=========+=========+=========+=========+===========================* +! * STRUCTURE FACTOR : * +! *=======+=========+=========+=========+=========+===========================* +! +! +! * SSTDY : static vs dynamic local-field corrections +! SSTDY = ' STATIC' --> SQ_TYPE +! SSTDY = 'DYNAMIC' --> SQO_TYPE +! +! * SQ_TYPE : structure factor approximation (3D) --> static +! SQ_TYPE = 'DEH' Debye-Hückel approximation +! SQ_TYPE = 'GEA' generalized approximation +! SQ_TYPE = 'GOR' Gorobchenko approximation +! SQ_TYPE = 'GR2' computed from g(r) (GR_TO_SQ.f code) +! SQ_TYPE = 'GSB' Gori-Giorgi-Sacchetti-Bachelet approximation +! SQ_TYPE = 'HFA' Hartree-Fock approximation (only exchange) +! SQ_TYPE = 'HUB' Hubbard approximation +! SQ_TYPE = 'ICH' Ichimaru approximation +! SQ_TYPE = 'MSA' mean spherical approximation +! SQ_TYPE = 'PKA' Pietiläinen-Kallio +! SQ_TYPE = 'RPA' RPA approximation +! SQ_TYPE = 'SHA' Shaw approximation +! SQ_TYPE = 'SIN' Singh +! SQ_TYPE = 'SPA' Singh-Pathak +! SQ_TYPE = 'TWA' Toigo-Woodruff approximation +!! +! * SQO_TYPE : structure factor approximation (3D) --> dynamic +! SQO_TYPE = 'ABA' Arista-Brandt approximation +! SQO_TYPE = 'HFA' Hartree-Fock approximation +! SQO_TYPE = 'HYD' hyrodynamic approximation +! SQO_TYPE = 'IGA' ideal gas approximation +! SQO_TYPE = 'ITA' Ichimaru-Tanaka approximation +! SQO_TYPE = 'MFA' Hansen-McDonald-Pollock approximation +! SQO_TYPE = 'NIC' Nakano-Ichimaru approximation +! SQO_TYPE = 'UTI' Utsumi-Ichimaru approximation (3D) +! SQO_TYPE = 'VLA' linearized Vlasov approximation +! +! *=======+=========+=========+=========+=========+===========================* +! * PAIR CORRELATION FUNCTION : * +! *=======+=========+=========+=========+=========+===========================* +! +! * GR_TYPE : pair correlation function approximation g(r) (3D) +! GR_TYPE = 'CDF' from chain diagram formula of PDF (long distance) +! GR_TYPE = 'DHA' Debye-Hückel approximation +! GR_TYPE = 'DWA' DeWitt approximation +! GR_TYPE = 'FBA' Frieman-Book approximation +! GR_TYPE = 'HFA' Hartree-Fock approximation (only exchange) +! GR_TYPE = 'HUB' Hubbard approximation +! GR_TYPE = 'LLA' Lee-Long approximation +! GR_TYPE = 'ORB' Ortiz-Ballone approximation +! GR_TYPE = 'PDF' from pair distribution function +! GR_TYPE = 'SHA' Shaw approximation +! GR_TYPE = 'SQ2' computed from S(q) (SQ_TO_GR.f code) +! GR_TYPE = 'WIG' Wigner approximation +! +! * GR0_MODE : g(0) (3D) +! GR0_MODE = 'CAGO' --> Calmels-Gold +! GR0_MODE = 'DPGT' --> Davoudi-Polini-Giuliani-Tosi +! GR0_MODE = 'HASA' --> Holas-Aravind-Singwi (small r_s) +! GR0_MODE = 'ICHI' --> Ichimaru +! GR0_MODE = 'KIMB' --> Kimball +! GR0_MODE = 'OVE1' --> Overhauser 1 +! GR0_MODE = 'OVE2' --> Overhauser 2 +! GR0_MODE = 'QIAN' --> Qian +! * GR0_MODE : g(0) (2D) +! GR0_MODE = 'CAGO' --> Calmels-Gold +! GR0_MODE = 'HAFO' --> Hartree-Fock +! GR0_MODE = 'MOMA' --> Moreno-Marinescu +! GR0_MODE = 'NSOA' --> Nagano-Singwi-Ohnishi +! GR0_MODE = 'QIAN' --> Qian +! +! *=======+=========+=========+=========+=========+===========================* +! * PAIR DISTRIBUTION FUNCTION : * +! *=======+=========+=========+=========+=========+===========================* +! +! * RH_TYPE : pair distribution function approximation (3D) +! RH_TYPE = 'CDI' chain diagram improved +! RH_TYPE = 'CEG' classical electron gas +! RH_TYPE = 'DEB' Debye electron gas +! RH_TYPE = 'FUA' correct to order 2 in epsilon +! RH_TYPE = 'SDC' short-distance correlations +! RH_TYPE = 'WDA' watermelon diagrams summed +! + *=======+=========+=========+=========+=========+============================* + * ENERGY CALCULATIONS : * + *=======+=========+=========+=========+=========+============================* +! +! * EC_TYPE : type of correlation energy functional (3D) +! EC_TYPE = 'GEBR_W' --> Gell-Mann and Brueckner +! EC_TYPE = 'CAMA_W' --> Carr and Maradudin +! EC_TYPE = 'EHTY_S' --> Endo-Horiuchi-Takada-Yasuhara +! EC_TYPE = 'HELU_W' --> Hedin and Lundqvist +! EC_TYPE = 'VBHE_W' --> von Barth and Hedin +! EC_TYPE = 'PEZU_W' --> Perdew and Zunger +! EC_TYPE = 'WIGN_S' --> Wigner +! EC_TYPE = 'NOPI_S' --> Nozières and Pines +! EC_TYPE = 'LIRO_S' --> Lindgren and Rosen +! EC_TYPE = 'PEZU_S' --> Perdew and Zunger +! EC_TYPE = 'REHI_S' --> Rebei and Hitchon +! EC_TYPE = 'GGSB_G' --> Gori-Giorgi-Sacchetti-Bachelet +! EC_TYPE = 'PRKO_G' --> Proynov and Kong +! EC_TYPE = 'VWNU_G' --> Vosko, Wilk and Nusair +! EC_TYPE = 'PEWA_G' --> Perdew and Wang +! EC_TYPE = 'HUBB_G' --> Hubbard +! EC_TYPE = 'CHAC_G' --> Chachiyo +! EC_TYPE = 'ISKO_T' --> Isihara and Kojima +! * EC_TYPE : type of correlation energy functional (2D) +! EC_TYPE = 'TACE_G' --> Tanatar-Ceperley +! EC_TYPE = 'CPPA_G' --> Seidl-Perdew_Levy +! EC_TYPE = 'AMGB_G' --> Attaccalite-Moroni-Gori-Giorgi-Bachelet +! EC_TYPE = 'SEID_G' --> Seidl +! EC_TYPE = 'LOOS_W' --> Loos +! EC_TYPE = 'WIGN_S' --> Wigner +! EC_TYPE = 'ISTO_T' --> Isihara-Toyoda +! * EC_TYPE : type of correlation energy functional (1D) +! EC_TYPE = 'LOOS_W' --> Loos +! EC_TYPE = 'WIGN_S' --> Wigner +! +! +! * FXC_TYPE : type of XC free energy functional --> 3D +! FXC_TYPE = 'NO' --> None +! FXC_TYPE = 'EB' --> Ebeling et al +! FXC_TYPE = 'IC' --> Ichimaru et al +! FXC_TYPE = 'KS' --> Karasiev et al +! FXC_TYPE = 'VS' --> Vashishta and Singwi +! FXC_TYPE = 'PD' --> Perrot and Dharma-Wardana +! FXC_TYPE = 'EK' --> Ebeling-Kraeft-Kremp-Röpke + +! * EXC_TYPE : type of exchange-correlation energy functional --> 3D +! EXC_TYPE = 'NO' --> None +! EXC_TYPE = 'GT' --> Goedeker-Tetter-Hutter +! EXC_TYPE = 'ST' --> +! EXC_TYPE = 'BD' --> Brown-DuBois-Holzmann-Ceperley +! +! ~ +! +! + *=======+=========+=========+=========+=========+============================* + * SPIN POLARIZATION : * + *=======+=========+=========+=========+=========+============================* +! +! * IMODE : choice of spin parameters +! IMODE = 1 : no spin polarization +! IMODE = 2 : fully spin-polarized +! +! * XI : spin polarization : (n+ - n-) / n +! +! *=======+=========+=========+=========+=========+===========================* +! * THERMODYNAMIC PROPERTIES : * +! *=======+=========+=========+=========+=========+===========================* +! +! * TH_PROP : type of calculation --> thermodynamic properties +! TH_PROP = 'CLAS' : classical approximation +! TH_PROP = 'QUAN' : quantum approximation +! +! * GP_TYPE : grand partition function type (3D) +! GP_TYPE = 'IK0' Isihara-Kojima formulation +! GP_TYPE = 'RH0' Rebei-Hitchon formulation +! GP_TYPE = 'IKM' Isihara-Kojima with magnetic field +! +! * GP_TYPE : grand partition function type (2D) +! GP_TYPE = 'I20' Isihara-Kojima formulation +! GP_TYPE = 'I2M' Isihara-Kojima with magnetic field +! +! *=======+=========+=========+=========+=========+===========================* +! * INCOMING ION BEAM : * +! *=======+=========+=========+=========+=========+===========================* +! +! * Z_BEAM : charge of ions in incoming beam +! * EK_BEAM : kinetic energy of incoming beam ions (eV) +! +! *=======+=========+=========+=========+=========+===========================* +! * OUTPUT CALCULATIONS : * +! *=======+=========+=========+=========+=========+===========================* +! +! * I_DF : switch for dielectric function printing +! I_DF = 0 : dielectric function not printed +! I_DF = 1 : dielectric function printed in file 'diel_func.dat' +! +! * I_PZ : switch for polarization function printing +! I_PZ = 0 : polarization function not printed +! I_PZ = 1 : polarization function printed in file 'pola_func.dat' +! +! * I_SU : switch for susceptibility function printing +! I_SU = 0 : susceptibility function not printed +! I_SU = 1 : susceptibility function printed in file 'susc_func.dat' +! +! * I_CD : switch for electrical conductivity printing +! I_CD = 0 : electrical conductivity not printed +! I_CD = 1 : electrical conductivity printed in file 'cond_func.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_PD : switch for plasmon dispersion printing +! I_PD = 0 : plasmon dispersion not calculated +! I_PD = 1 : plasmon dispersion printed in file 'plas_disp.dat' +! +! * I_EH : switch for electron-hole dispersion printing +! I_EH = 0 : electron-hole dispersion not calculated +! I_EH = 1 : electron-hole dispersion printed in file 'elec_hole.dat' +! +! * I_E2 : switch for two-electron-hole dispersion printing +! I_E2 = 0 : two-electron-hole dispersion not calculated +! I_E2 = 1 : two-electron-hole dispersion printed in file 'elec_hol2.dat' +! +! * I_CK : switch for k-space e-e interaction potential printing +! I_CK = 0 : potential not calculated +! I_CK = 1 : potential printed in file 'int_pot_k.dat' +! +! * I_CR : switch for real-space e-e interaction potential printing +! I_CR = 0 : potential not calculated +! I_CR = 1 : potential printed in file 'int_pot_r.dat' +! +! * I_SA : switch for scattering amplitude printing +! I_SA = 0 : scattering amplitude not calculated +! I_SA = 1 : scattering amplitude printed in file 'scat_ampl.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_LF : switch for local-field corrections G(q,omega) printing +! I_LF = 0 : local-field corrections not calculated +! I_LF = 1 : local-field corrections printed in file 'loca_fiel.dat' +! +! * I_IQ : switch for G(q,inf) printing +! I_IQ = 0 : G(q,inf) not calculated +! I_IQ = 1 : G(q,inf) printed in file 'ginf_fiel.dat' +! +! * I_SF : switch for structure factor S(q,omega) printing +! I_SF = 0 : structure factor not calculated +! I_SF = 1 : structure factor printed in file 'stru_fact.dat' +! +! * I_PC : switch for pair correlation function g(r) printing +! I_PC = 0 : pair correlation function not calculated +! I_PC = 1 : pair correlation function printed in file 'pair_corr.dat' +! +! ~ +! +! * I_P2 : switch for pair distribution rho2(r) printing +! I_P2 = 0 : pair distribution function not calculated +! I_P2 = 1 : pair distribution function printed in file 'pair_dist.dat' +! +! * I_VX : switch for vertex function Gamma(q,omega) printing +! I_VX = 0 : vertex function not calculated +! I_VX = 1 : vertex function printed in file 'vertex_fu.dat' +! +! * I_DC : switch for plasmon damping coefficient Im[eps]/q^2 printing +! I_DC = 0 : plasmon damping not calculated +! I_DC = 1 : plasmon damping printed in file 'plas_damp.dat' +! +! * I_MD : switch for momentum distribution printing +! I_MD = 0 : momentum distribution not calculated +! I_MD = 1 : momentum distribution printed in file 'mome_dist.dat' +! +! ~ +! +! * I_LD : switch for Landau parameters printing +! I_LD = 0 : Landau parameters not calculated +! I_LD = 1 : Landau parameters printed in file 'landau_pa.dat' +! +! * I_DP : switch for damping printing +! I_DP = 0 : damping not calculated +! I_DP = 1 : damping printed in file 'damp_file.dat' +! +! * I_LT : switch for plasmon lifetime printing +! I_LT = 0 : plasmon lifetime not calculated +! I_LT = 1 : plasmon lifetime printed in file 'life_time.dat' +! +! * I_BR : switch for plasmon broadening printing +! I_BR = 0 : plasmon broadening not calculated +! I_BR = 1 : plasmon broadening printed in file 'broadenin.dat' +! +! ~ +! +! * I_PE : switch for plasmon energy printing +! I_PE = 0 : plasmon energy not calculated +! I_PE = 1 : plasmon energy printed in file 'plas_ener.dat' +! +! * I_QC : switch for plasmon q-bounds printing +! I_QC = 0 : plasmon q-bounds not calculated +! I_QC = 1 : plasmon q-bounds printed in file 'qc_bounds.dat' +! +! * I_RL : switch for relaxation time printing +! I_RL = 0 : relaxation time not calculated +! I_RL = 1 : relaxation time printed in file 'rela_time.dat' +! +! * I_TF : switch for Thomas-Fermi wave vector printing +! I_TF = 0 : Thomas-Fermi wave vector not calculated +! I_TF = 1 : Thomas-Fermi wave vector printed in file 'thomas-fe.dat' +! +! ~ +! +! * I_DY : switch for Debye wave vector printing +! I_DY = 0 : Debye wave vector not calculated +! I_DY = 1 : Debye wave vector printed in file 'debye_wav.dat' +! +! * I_ME : switch for moments of epsilon(q,omega) printing +! I_ME = 0 : moments of epsilon not calculated +! I_ME = 1 : moments of epsilon printed in file 'moments_e.dat' +! +! * I_MS : switch for moments of S(q,omega) printing +! I_MS = 0 : moments of structure factor not calculated +! I_MS = 1 : moments of structure factor printed in file 'moments_s.dat' +! +! * I_ML : switch for moments of loss function printing +! I_ML = 0 : moments of loss function not calculated +! I_ML = 1 : moments of loss function printed in file 'moments_l.dat' +! +! ~ +! +! * I_MC : switch for moments of conductivity printing +! I_MC = 0 : moments of conductivity not calculated +! I_MC = 1 : moments of conductivity printed in file 'moments_c.dat' +! +! * I_DE : switch for derivative of Re[ dielectric function ] printing +! I_DE = 0 : derivative not calculated +! I_DE = 1 : derivative printed in file 'deri_epsi.dat' +! +! * I_ZE : switch for Re[ dielectric function ] = 0 printing +! I_ZE = 0 : function not calculated +! I_ZE = 1 : function printed in file 'ree0_file.dat' +! +! * I_SR : switch for sum rules for epsilon printing +! I_SR = 0 : sum rules not calculated +! I_ST = 1 : sum rules printed in file 'sum_rules.dat' +! +! ~ +! +! * I_CW : switch for confinement wave function printing +! I_CW = 0 : confinement wave function not calculated +! I_CW = 1 : confinement wave function printed in file 'confin_wf.dat' +! +! * I_CF : switch for confinement potential printing +! I_CF = 0 : confinement potential not calculated +! I_CF = 1 : confinement potential printed in file 'confin_pt.dat' +! +! * I_EM : switch for effective mass printing +! I_EM = 0 : effective mass not calculated +! I_EM = 1 : effective mass printed in file 'effe_mass.dat' +! +! * I_MF : switch for mean free path printing +! I_MF = 0 : mean free path not calculated +! I_MF = 1 : mean free path printed in file 'mean_path.dat' +! +! ~ +! +! * I_SP : switch for spectral function printing +! I_SP = 0 : spectral function not calculated +! I_SP = 1 : spectral function printed in file 'spec_func.dat' +! +! * I_SE : switch for self-energy printing +! I_SE = 0 : self-energy not calculated +! I_SE = 1 : self-energy printed in file 'self_ener.dat' +! +! * I_NV : switch for Nevanlinaa function printing +! I_NV = 0 : Nevanlinaa function not calculated +! I_NV = 1 : Nevanlinaa function printed in file 'nevanlina.dat' +! +! * I_ES : switch for Eliashberg function printing +! I_ES = 0 : Eliashberg function not calculated +! I_ES = 1 : Eliashberg function printed in file 'elia_func.dat' +! +! ~ +! +! * I_GR : switch for Grüneisen parameter printing +! I_GR = 0 : Grüneisen parameter not calculated +! I_GR = 1 : Grüneisen parameter printed in file 'grune_par.dat' +! +! * I_FD : switch for Fermi-Dirac distribution printing +! I_FD = 0 : Fermi-Dirac distribution not calculated +! I_FD = 1 : Fermi-Dirac distribution printed in file 'fermi_dir.dat' +! +! * I_BE : switch for Bose-Einstein distribution printing +! I_BE = 0 : Bose-Einstein distribution not calculated +! I_BE = 1 : Bose-Einstein distribution printed in file 'bose_eins.dat' +! +! * I_MX : switch for Maxwell distribution printing +! I_MX = 0 : Maxwell distribution not calculated +! I_MX = 1 : Maxwell distribution printed in file 'maxwell_d.dat' +! +! ~ +! +! * I_SC : switch for scale parameters printing +! I_SC = 0 : scale parameters not calculated +! I_SC = 1 : scale parameters printed in file 'scale_par.dat' +! +! * I_DS : switch for density of states printing +! I_DS = 0 : density of states not calculated +! I_DS = 1 : density of states printed in file 'dens_stat.dat' +! +! * I_SB : switch for subband energies printing +! I_SB = 0 : subband energies not calculated +! I_SB = 1 : subband energies printed in file 'subb_ener.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_GP : switch for grand partition function printing +! I_GP = 0 : grand partition function not calculated +! I_GP = 1 : grand partition function printed in file 'gran_part.dat' +! +! * I_PR : switch for electronic pressure printing +! I_PR = 0 : electronic pressure not calculated +! I_PR = 1 : electronic pressure printed in file 'epressure.dat' +! +! * I_CO : switch for compressibility printing +! I_CO = 0 : compressibility not calculated +! I_CO = 1 : compressibility printed in file 'comp_file.dat' +! +! * I_CP : switch for chemical potential printing +! I_CP = 0 : chemical potential not calculated +! I_CP = 1 : chemical potential printed in file 'chem_pote.dat' +! +! ~ +! +! * I_BM : switch for bulk modulus printing +! I_BM = 0 : bulk modulus not calculated +! I_BM = 1 : bulk modulus printed in file 'bulk_modu.dat' +! +! * I_SH : switch for shear modulus printing +! I_SH = 0 : shear modulus not calculated +! I_SH = 1 : shear modulus printed in file 'shear_mod.dat' +! +! * I_S0 : switch for zero sound velocity printing +! I_S0 = 0 : zero sound velocity not calculated +! I_S0 = 1 : zero sound velocity printed in file 'zero_soun.dat' +! +! * I_S1 : switch for first sound velocity printing +! I_S1 = 0 : first sound velocity not calculated +! I_S1 = 1 : first sound velocity printed in file 'firs_soun.dat' +! +! ~ +! +! * I_DT : switch for Debye temperature printing +! I_DT = 0 : Debye temperature not calculated +! I_DT = 1 : Debye temperature printed in file 'Debye_tmp.dat' +! +! * I_PS : switch for Pauli paramagnetic susceptibility printing +! I_PS = 0 : Pauli paramagnetic susceptibility not calculated +! I_PS = 1 : Pauli paramagnetic susceptibility printed in file 'para_susc.dat' +! +! * I_IE : switch for internal energy printing +! I_IE = 0 : internal energy not calculated +! I_IE = 1 : internal energy printed in file 'inter_ene.dat' +! +! * I_EI : switch for excess internal energy printing +! I_EI = 0 : excess internal energy not calculated +! I_EI = 1 : excess internal energy printed in file 'exces_ene.dat' +! +! ~ +! +! * I_FH : switch for Helmholtz free energy printing +! I_FH = 0 : Helmholtz free energy not calculated +! I_FH = 1 : Helmholtz free energy printed in file 'helm_free.dat' +! +! * I_EY : switch for entropy printing +! I_EY = 0 : entropy not calculated +! I_EY = 1 : entropy printed in file 'entropy_f.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_EF : switch for Fermi energy printing +! I_EF = 0 : Fermi energy not calculated +! I_EF = 1 : Fermi energy printed in file 'fermi_ene.dat' +! +! * I_KF : switch for Fermi momentum printing +! I_KF = 0 : Fermi momentum not calculated +! I_KF = 1 : Fermi momentum printed in file 'fermi_vec.dat' +! +! * I_VF : switch for Fermi velocity printing +! I_VF = 0 : Fermi velocity not calculated +! I_VF = 1 : Fermi velocity printed in file 'fermi_vel.dat' +! +! * I_TE : switch for Fermi temperature printing +! I_TE = 0 : Fermi temperature not calculated +! I_TE = 1 : Fermi temperature printed in file 'fermi_tmp.dat' +! +! ~ +! +! * I_DL : switch for density of states at Fermi level printing +! I_DL = 0 subband energies: density of states at Fermi level not calculated +! I_DL = 1 : density of states at Fermi level printed in file 'fermi_dos.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_TW : switch for thermal De Broglie wavelength printing +! I_TW = 0 : thermal De Broglie wavelength not calculated +! I_TW = 1 : thermal De Broglie wavelength printed in file 'thermal_w.dat' +! +! * I_VT : switch for thermal velocity printing +! I_VT = 0 : thermal velocity not calculated +! I_VT = 1 : thermal velocity printed in file 'thermal_v.dat' +! +! * I_TC : switch for thermal conductivity printing +! I_TC = 0 : thermal conductivity not calculated +! I_TC = 1 : thermal conductivity printed in file 'thermal_c.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_EG : switch for ground state energy printing +! I_EG = 0 : ground state energy not calculated +! I_EG = 1 : ground state energy printed in file 'ground_st.dat' +! +! * I_EX : switch for exchange energy printing +! I_EX = 0 : exchange energy not calculated +! I_EX = 1 : exchange energy printed in file 'ex_energy.dat' +! +! * I_XC : switch for exchange correlation energy printing +! I_XC = 0 : exchange correlation energy not calculated +! I_XC = 1 : exchange correlation energy printed in file 'xc_energy.dat' +! +! * I_EC : switch for correlation energy printing +! I_EC = 0 : correlation energy not calculated +! I_EC = 1 : correlation energy printed in file 'corr_ener.dat' +! +! ~ +! +! * I_HF : switch for Hartree-Fock energy printing +! I_HF = 0 : Hartree-Fock energy not calculated +! I_HF = 1 : Hartree-Fock energy printed in file 'hf_energy.dat' +! +! * I_EK : switch for kinetic energy printing +! I_EK = 0 : kinetic energy not calculated +! I_EK = 1 : kinetic energy printed in file 'kine_ener.dat' +! +! * I_EP : switch for potential energy printing +! I_EP = 0 : potential energy not calculated +! I_EP = 1 : potential energy printed in file 'pote_ener.dat +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_VI : switch for shear viscosity printing +! I_VI = 0 : shear viscosity not calculated +! I_VI = 1 : shear viscosity printed in file 'visc_coef.dat' +! +! * I_DI : switch for diffusion coefficient printing +! I_DI = 0 : diffusion coefficient not calculated +! I_DI = 1 : diffusion coefficient printed in file 'diff_coef.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_FP : switch for fluctuation potential calculation +! I_FP = 0 : fluctuation potential not calculated +! I_FP = 1 : fluctuation potential printed in file 'fluct_pot.dat' +! +! * I_EL : switch for loss function calculation +! I_EL = 0 : loss function not calculated +! I_EL = 1 : loss function printed in file 'ener_loss.dat' +! +! * I_PO : switch for stopping power calculation +! I_PO = 0 : stopping power not calculated +! I_PO = 1 : stopping power printed in file 'stop_powe.dat' +! +! * I_RF : switch for refractive index calculation +! I_RF = 0 : refractive index not calculated +! I_RF = 1 : refractive index printed in file 'refrac_in.dat' +! +! ~ +! +! * I_VC : switch for dynamic screened Coulomb potential V(q,omega) calculation +! I_RF = 0 : dynamic screened Coulomb potential not calculated +! I_RF = 1 : dynamic screened Coulomb potential printed in file 'dyna_coul.dat' +! +! *-------+---------+---------+---------+---------+---------------------------* +! +! * I_FN : switch for appending the calculation type string +! to the output filename +! I_FN = 0 : standard output filename +! I_FN = 1 : parameter added to filename +! +! * I_WR : switch for writing physical properties into the log file +! I_WR = 0 : does not write +! I_WR = 1 : writes +! + + + + + + + +