diff --git a/GoDuck b/GoDuck deleted file mode 100755 index ea8d08a..0000000 Binary files a/GoDuck and /dev/null differ diff --git a/include/parameters.h b/include/parameters.h index d504995..d0e1202 100644 --- a/include/parameters.h +++ b/include/parameters.h @@ -1,7 +1,7 @@ integer,parameter :: ncart = 3 integer,parameter :: nspin = 2 integer,parameter :: nsp = 3 - integer,parameter :: maxEns = 10 + integer,parameter :: maxEns = 3 integer,parameter :: maxShell = 512 integer,parameter :: maxL = 7 integer,parameter :: n1eInt = 3 @@ -17,7 +17,6 @@ double precision,parameter :: BoToAn = 0.529177249d0 double precision,parameter :: auToD = 2.5415802529d0 - double precision,parameter :: CxLDA = - (3d0/4d0)*(3d0/pi)**(1d0/3d0) - double precision,parameter :: Cx0 = - (4d0/3d0)*(1d0/pi)**(1d0/3d0) - double precision,parameter :: Cx1 = - (176d0/105d0)*(1d0/pi)**(1d0/3d0) + double precision,parameter :: CxLDA = - (3d0/4d0)*(3d0/pi)**(1d0/3d0) + double precision,parameter :: CxLSDA = - (3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) diff --git a/input/dft b/input/dft index 709e75b..f123932 100644 --- a/input/dft +++ b/input/dft @@ -1,38 +1,38 @@ # Restricted or unrestricted KS calculation eDFT-UKS # exchange rung: -# Hartree = 0 -# LDA = 1: RS51,RMFL20 -# GGA = 2: RB88 -# Hybrid = 4 -# Hartree-Fock = 666 - 1 S51 +# Hartree = 0: H +# LDA = 1: S51,CC-S51 +# GGA = 2: B88,G96,PBE +# MGGA = 3: +# Hybrid = 4: HF,B3LYP,PBE + 1 S51 # correlation rung: -# Hartree = 0 -# LDA = 1: RVWN5,RMFL20 -# GGA = 2: -# Hybrid = 4: -# Hartree-Fock = 666 - 0 H +# Hartree = 0: H +# LDA = 1: PW92,VWN3,VWN5,eVWN5 +# GGA = 2: LYP,PBE +# MGGA = 3: +# Hybrid = 4: HF,B3LYP,PBE + 0 H # quadrature grid SG-n 1 # Number of states in ensemble (nEns) - 3 -# occupation numbers of orbitals nO and nO+1 - 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 1 +# occupation numbers + 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 - 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 # Ensemble weights: wEns(1),...,wEns(nEns-1) - 0.00 1.00 + 0.0 0.0 # N-centered? - T + F # Parameters for CC weight-dependent exchange functional -0.445525 0.0901503 -0.286898 -0.191734 -0.0364788 -0.017035 +0.0 0.0 0.0 +0.0 0.0 0.0 # choice of UCC exchange coefficient : 1 for Cx1, 2 for Cx2, 3 for Cx1*Cx2 2 diff --git a/input/methods b/input/methods index 7326f23..444f417 100644 --- a/input/methods +++ b/input/methods @@ -1,17 +1,17 @@ -# RHF UHF KS MOM - T F F F +# RHF UHF KS MOM + F F T F # MP2* MP3 MP2-F12 F F F # CCD DCD CCSD CCSD(T) F F F F # drCCD rCCD lCCD pCCD - F F F T -# CIS* CIS(D) CID CISD - F F F F + F F F F +# CIS* CIS(D) CID CISD FCI + F F F F F # RPA* RPAx* ppRPA F F F -# G0F2 evGF2 G0F3 evGF3 - F F F F +# G0F2* evGF2* qsGF2* G0F3 evGF3 + F F F F F # G0W0* evGW* qsGW* F F F # G0T0 evGT qsGT diff --git a/input/options b/input/options index 9678329..6b70026 100644 --- a/input/options +++ b/input/options @@ -1,17 +1,17 @@ -# HF: maxSCF thresh DIIS n_diis guess_type ortho_type mix_guess - 128 0.0000001 T 5 1 1 T +# HF: maxSCF thresh DIIS n_diis guess_type ortho_type mix_guess stability + 1024 0.00001 F 5 1 1 F F # MP: # CC: maxSCF thresh DIIS n_diis - 64 0.00001 T 5 + 64 0.0000000001 T 5 # spin: TDA singlet triplet spin_conserved spin_flip - F T T T F + T T T T T # GF: maxSCF thresh DIIS n_diis lin eta renorm - 256 0.00001 T 5 T 0.0 3 + 256 0.00001 T 5 T 0.0 3 # GW/GT: maxSCF thresh DIIS n_diis lin eta COHSEX SOSEX TDA_W G0W GW0 - 256 0.0000001 T 5 T 0.00367493 F F F F F + 256 0.00001 T 5 T 0.0 F F T F F # ACFDT: AC Kx XBS - F F T + T F T # BSE: BSE dBSE dTDA evDyn T F T F # MCMP2: nMC nEq nWalk dt nPrint iSeed doDrift diff --git a/mol/benzene.xyz b/mol/benzene.xyz index 4b49a6a..08d5f47 100644 --- a/mol/benzene.xyz +++ b/mol/benzene.xyz @@ -1,5 +1,5 @@ 12 -Benzene,^1A_{1g},CC3,aug-cc-pVTZ + C 0.00000000 1.39250319 0.00000000 C -1.20594314 0.69625160 0.00000000 C -1.20594314 -0.69625160 0.00000000 @@ -11,4 +11,4 @@ H -2.14171677 -1.23652075 0.00000000 H 0.00000000 -2.47304151 0.00000000 H 2.14171677 -1.23652075 0.00000000 H 2.14171677 1.23652075 0.00000000 -H 0.00000000 2.47304151 0.00000000 \ No newline at end of file +H 0.00000000 2.47304151 0.00000000 diff --git a/mol/butadiene.xyz b/mol/butadiene.xyz index f2069d8..8bbbc73 100644 --- a/mol/butadiene.xyz +++ b/mol/butadiene.xyz @@ -1,5 +1,5 @@ 10 -Butadiene,^1A_g,CC3,aug-cc-pVTZ + C 0.60673471 0.00000000 0.39936380 C -0.60673471 0.00000000 -0.39936380 C 1.84223863 0.00000000 -0.11897388 @@ -9,4 +9,4 @@ H -0.48033933 0.00000000 -1.47579018 H 1.99778057 0.00000000 -1.19009558 H -1.99778057 0.00000000 1.19009558 H 2.71819794 0.00000000 0.51257105 -H -2.71819794 0.00000000 -0.51257105 \ No newline at end of file +H -2.71819794 0.00000000 -0.51257105 diff --git a/mol/ethylene.xyz b/mol/ethylene.xyz index aab62c8..aeb24b4 100644 --- a/mol/ethylene.xyz +++ b/mol/ethylene.xyz @@ -1,8 +1,8 @@ 6 -Ethylene,^1A_g,CC3,aug-cc-pVTZ + C 0.00000000 0.66690396 0.00000000 C 0.00000000 -0.66690396 0.00000000 H 0.00000000 1.22952195 0.92229064 H 0.00000000 -1.22952195 0.92229064 H 0.00000000 1.22952195 -0.92229064 -H 0.00000000 -1.22952195 -0.92229064 \ No newline at end of file +H 0.00000000 -1.22952195 -0.92229064 diff --git a/mol/h2.xyz b/mol/h2.xyz index 4185b54..6a4e902 100644 --- a/mol/h2.xyz +++ b/mol/h2.xyz @@ -1,4 +1,4 @@ 2 H 0.0 0.0 0.0 -H 0.0 0.0 0.740848 +H 0.0 0.0 0.7 diff --git a/mol/water.xyz b/mol/water.xyz index c768808..aca599c 100644 --- a/mol/water.xyz +++ b/mol/water.xyz @@ -1,5 +1,5 @@ 3 -Water,^1A_1,CC3,aug-cc-pVTZ + O 0.00000000 0.00000000 -0.06990256 H 0.00000000 0.75753241 0.51843495 -H 0.00000000 -0.75753241 0.51843495 \ No newline at end of file +H 0.00000000 -0.75753241 0.51843495 diff --git a/src/AOtoMO/exchange_matrix_AO_basis.f90 b/src/AOtoMO/exchange_matrix_AO_basis.f90 index 2f0f1d2..8a38c0e 100644 --- a/src/AOtoMO/exchange_matrix_AO_basis.f90 +++ b/src/AOtoMO/exchange_matrix_AO_basis.f90 @@ -1,4 +1,4 @@ -subroutine exchange_matrix_AO_basis(nBas,P,G,K) +subroutine exchange_matrix_AO_basis(nBas,P,ERI,K) ! Compute exchange matrix in the AO basis @@ -9,7 +9,7 @@ subroutine exchange_matrix_AO_basis(nBas,P,G,K) integer,intent(in) :: nBas double precision,intent(in) :: P(nBas,nBas) - double precision,intent(in) :: G(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) ! Local variables @@ -24,7 +24,7 @@ subroutine exchange_matrix_AO_basis(nBas,P,G,K) do si=1,nBas do la=1,nBas do mu=1,nBas - K(mu,nu) = K(mu,nu) - P(la,si)*G(mu,la,si,nu) + K(mu,nu) = K(mu,nu) - P(la,si)*ERI(mu,la,si,nu) enddo enddo enddo diff --git a/src/CI/FCI.f90 b/src/CI/FCI.f90 new file mode 100644 index 0000000..1fcabbd --- /dev/null +++ b/src/CI/FCI.f90 @@ -0,0 +1,31 @@ +subroutine FCI(nBas,nC,nO,nV,nR,ERI,e) + +! Perform a full configuration interaction calculation + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR + double precision,intent(in) :: e(nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + +! Hello world + + write(*,*) + write(*,*)'**********************************' + write(*,*)'| Full Configuration Interaction |' + write(*,*)'**********************************' + write(*,*) + +! Form FCI vector + +! Form FCI matrix + +! Diagonalize FCI matrix + + +end subroutine FCI diff --git a/src/MBPT/BSE2.f90 b/src/GF/BSE2.f90 similarity index 91% rename from src/MBPT/BSE2.f90 rename to src/GF/BSE2.f90 index 123cfea..25bc56c 100644 --- a/src/MBPT/BSE2.f90 +++ b/src/GF/BSE2.f90 @@ -56,6 +56,9 @@ subroutine BSE2(TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI, call linear_response(ispin,.false.,TDA,.false.,eta,nBas,nC,nO,nV,nR,nS,1d0,eGF,ERI, & OmBSE(:,ispin),rho,EcBSE(ispin),OmBSE(:,ispin),XpY(:,:,ispin),XmY(:,:,ispin)) call print_excitation('BSE2 ',ispin,nS,OmBSE(:,ispin)) + call print_transition_vectors(.true.,nBas,nC,nO,nV,nR,nS,dipole_int, & + OmBSE(:,ispin),XpY(:,:,ispin),XmY(:,:,ispin)) + ! Compute dynamic correction for BSE via perturbation theory @@ -90,6 +93,8 @@ subroutine BSE2(TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI, call linear_response(ispin,.false.,TDA,.false.,eta,nBas,nC,nO,nV,nR,nS,1d0,eGF(:),ERI(:,:,:,:), & OmBSE(:,ispin),rho,EcBSE(ispin),OmBSE(:,ispin),XpY(:,:,ispin),XmY(:,:,ispin)) call print_excitation('BSE2 ',ispin,nS,OmBSE(:,ispin)) + call print_transition_vectors(.false.,nBas,nC,nO,nV,nR,nS,dipole_int, & + OmBSE(:,ispin),XpY(:,:,ispin),XmY(:,:,ispin)) ! Compute dynamic correction for BSE via perturbation theory diff --git a/src/MBPT/BSE2_A_matrix_dynamic.f90 b/src/GF/BSE2_A_matrix_dynamic.f90 similarity index 100% rename from src/MBPT/BSE2_A_matrix_dynamic.f90 rename to src/GF/BSE2_A_matrix_dynamic.f90 diff --git a/src/MBPT/BSE2_B_matrix_dynamic.f90 b/src/GF/BSE2_B_matrix_dynamic.f90 similarity index 100% rename from src/MBPT/BSE2_B_matrix_dynamic.f90 rename to src/GF/BSE2_B_matrix_dynamic.f90 diff --git a/src/MBPT/BSE2_dynamic_perturbation.f90 b/src/GF/BSE2_dynamic_perturbation.f90 similarity index 100% rename from src/MBPT/BSE2_dynamic_perturbation.f90 rename to src/GF/BSE2_dynamic_perturbation.f90 diff --git a/src/MBPT/BSE2_dynamic_perturbation_iterative.f90 b/src/GF/BSE2_dynamic_perturbation_iterative.f90 similarity index 100% rename from src/MBPT/BSE2_dynamic_perturbation_iterative.f90 rename to src/GF/BSE2_dynamic_perturbation_iterative.f90 diff --git a/src/MBPT/G0F2.f90 b/src/GF/G0F2.f90 similarity index 51% rename from src/MBPT/G0F2.f90 rename to src/GF/G0F2.f90 index 8204ad1..cfc7750 100644 --- a/src/MBPT/G0F2.f90 +++ b/src/GF/G0F2.f90 @@ -1,5 +1,4 @@ -subroutine G0F2(BSE,TDA,dBSE,dTDA,evDyn,singlet_manifold,triplet_manifold, & - linearize,eta,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI,dipole_int,eHF) +subroutine G0F2(BSE,TDA,dBSE,dTDA,evDyn,singlet,triplet,linearize,eta,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI,dipole_int,eHF) ! Perform a one-shot second-order Green function calculation @@ -13,8 +12,8 @@ subroutine G0F2(BSE,TDA,dBSE,dTDA,evDyn,singlet_manifold,triplet_manifold, & logical,intent(in) :: dBSE logical,intent(in) :: dTDA logical,intent(in) :: evDyn - logical,intent(in) :: singlet_manifold - logical,intent(in) :: triplet_manifold + logical,intent(in) :: singlet + logical,intent(in) :: triplet logical,intent(in) :: linearize double precision,intent(in) :: eta integer,intent(in) :: nBas @@ -31,15 +30,12 @@ subroutine G0F2(BSE,TDA,dBSE,dTDA,evDyn,singlet_manifold,triplet_manifold, & ! Local variables - double precision :: eps - double precision :: V + double precision :: Ec double precision :: EcBSE(nspin) double precision,allocatable :: eGF2(:) - double precision,allocatable :: Sig(:) + double precision,allocatable :: SigC(:) double precision,allocatable :: Z(:) - integer :: i,j,a,b,p - ! Hello world write(*,*) @@ -50,7 +46,7 @@ subroutine G0F2(BSE,TDA,dBSE,dTDA,evDyn,singlet_manifold,triplet_manifold, & ! Memory allocation - allocate(Sig(nBas),Z(nBas),eGF2(nBas)) + allocate(SigC(nBas),Z(nBas),eGF2(nBas)) if(linearize) then @@ -61,62 +57,28 @@ subroutine G0F2(BSE,TDA,dBSE,dTDA,evDyn,singlet_manifold,triplet_manifold, & ! Frequency-dependent second-order contribution - Sig(:) = 0d0 - Z(:) = 0d0 - - do p=nC+1,nBas-nR - do i=nC+1,nO - do j=nC+1,nO - do a=nO+1,nBas-nR - - eps = eHF(p) + eHF(a) - eHF(i) - eHF(j) - V = (2d0*ERI(p,a,i,j) - ERI(p,a,j,i))*ERI(p,a,i,j) - - Sig(p) = Sig(p) + V*eps/(eps**2 + eta**2) - Z(p) = Z(p) - V*(eps**2 - eta**2)/(eps**2 + eta**2)**2 - - end do - end do - end do - end do - - do p=nC+1,nBas-nR - do i=nC+1,nO - do a=nO+1,nBas-nR - do b=nO+1,nBas-nR - - eps = eHF(p) + eHF(i) - eHF(a) - eHF(b) - V = (2d0*ERI(p,i,a,b) - ERI(p,i,b,a))*ERI(p,i,a,b) - - Sig(p) = Sig(p) + V*eps/(eps**2 + eta**2) - Z(p) = Z(p) - V*(eps**2 - eta**2)/(eps**2 + eta**2)**2 - - end do - end do - end do - end do - - Z(:) = 1d0/(1d0 - Z(:)) + call self_energy_GF2_diag(eta,nBas,nC,nO,nV,nR,nS,eHF,eHF,ERI,SigC,Z) if(linearize) then - eGF2(:) = eHF(:) + Z(:)*Sig(:) + eGF2(:) = eHF(:) + Z(:)*SigC(:) else - eGF2(:) = eHF(:) + Sig(:) + eGF2(:) = eHF(:) + SigC(:) end if ! Print results - call print_G0F2(nBas,nO,eHF,Sig,eGF2,Z) + call MP2(nBas,nC,nO,nV,nR,ERI,ENuc,EHF,eGF2,Ec) + call print_G0F2(nBas,nO,eHF,SigC,eGF2,Z,ENuc,ERHF,Ec) ! Perform BSE2 calculation if(BSE) then - call BSE2(TDA,dBSE,dTDA,evDyn,singlet_manifold,triplet_manifold,eta,nBas,nC,nO,nV,nR,nS,ERI,dipole_int,eHF,eGF2,EcBSE) + call BSE2(TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI,dipole_int,eHF,eGF2,EcBSE) end if diff --git a/src/MBPT/G0F3.f90 b/src/GF/G0F3.f90 similarity index 100% rename from src/MBPT/G0F3.f90 rename to src/GF/G0F3.f90 diff --git a/src/GF/UG0F2.f90 b/src/GF/UG0F2.f90 new file mode 100644 index 0000000..0389f93 --- /dev/null +++ b/src/GF/UG0F2.f90 @@ -0,0 +1,122 @@ +subroutine UG0F2(BSE,TDA,dBSE,dTDA,evDyn,spin_conserved,spin_flip,linearize,eta,nBas,nC,nO,nV,nR,nS,ENuc,EUHF, & + S,ERI,ERI_aaaa,ERI_aabb,ERI_bbbb,dipole_int_aa,dipole_int_bb,eHF) + +! Perform unrestricted G0W0 calculation + + implicit none + include 'parameters.h' + include 'quadrature.h' + +! Input variables + + logical,intent(in) :: BSE + logical,intent(in) :: TDA + logical,intent(in) :: dBSE + logical,intent(in) :: dTDA + logical,intent(in) :: evDyn + logical,intent(in) :: spin_conserved + logical,intent(in) :: spin_flip + logical,intent(in) :: linearize + double precision,intent(in) :: eta + + integer,intent(in) :: nBas + integer,intent(in) :: nC(nspin) + integer,intent(in) :: nO(nspin) + integer,intent(in) :: nV(nspin) + integer,intent(in) :: nR(nspin) + integer,intent(in) :: nS(nspin) + double precision,intent(in) :: ENuc + double precision,intent(in) :: EUHF + double precision,intent(in) :: S(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_aaaa(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_aabb(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_bbbb(nBas,nBas,nBas,nBas) + double precision,intent(in) :: dipole_int_aa(nBas,nBas,ncart) + double precision,intent(in) :: dipole_int_bb(nBas,nBas,ncart) + double precision,intent(in) :: eHF(nBas,nspin) + +! Local variables + + integer :: is + integer :: ispin + double precision :: Ec(nsp) + double precision :: EcBSE(nspin) + double precision,allocatable :: SigC(:,:) + double precision,allocatable :: Z(:,:) + integer :: nS_aa,nS_bb,nS_sc + + double precision,allocatable :: eGF2lin(:,:) + double precision,allocatable :: eGF2(:,:) + +! Output variables + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| One-shot G0F2 calculation |' + write(*,*)'| *** Unrestricted version *** |' + write(*,*)'************************************************' + write(*,*) + +! TDA + + if(TDA) then + write(*,*) 'Tamm-Dancoff approximation activated!' + write(*,*) + end if + +! Memory allocation + + nS_aa = nS(1) + nS_bb = nS(2) + nS_sc = nS_aa + nS_bb + + allocate(SigC(nBas,nspin),Z(nBas,nspin),eGF2(nBas,nspin),eGF2lin(nBas,nspin)) + +!---------------------! +! Compute self-energy ! +!---------------------! + + call unrestricted_self_energy_GF2_diag(nBas,nC,nO,nV,nR,eta,ERI_aaaa,ERI_aabb,ERI_bbbb,eHF,eHF,SigC,Z) + +!-----------------------------------! +! Solve the quasi-particle equation ! +!-----------------------------------! + + eGF2lin(:,:) = eHF(:,:) + Z(:,:)*SigC(:,:) + + if(linearize) then + + write(*,*) ' *** Quasiparticle energies obtained by linearization *** ' + write(*,*) + + eGF2(:,:) = eGF2lin(:,:) + + else + + ! Find graphical solution of the QP equation + + print*,'!!! Graphical solution NYI for UG0F2 !!!' + stop + + end if + +! Compute MP2 correlation energy + + call UMP2(nBas,nC,nO,nV,nR,ERI_aaaa,ERI_aabb,ERI_bbbb,ENuc,EUHF,eGF2,Ec) + +! Dump results + + call print_UG0F2(nBas,nO,eHF,ENuc,EUHF,SigC,Z,eGF2,Ec) + +! Perform BSE calculation + + if(BSE) then + + print*,'!!! BSE2 NYI for UG0F2 !!!' + + end if + +end subroutine UG0F2 diff --git a/src/MBPT/evGF2.f90 b/src/GF/evGF2.f90 similarity index 68% rename from src/MBPT/evGF2.f90 rename to src/GF/evGF2.f90 index 168a762..2203533 100644 --- a/src/MBPT/evGF2.f90 +++ b/src/GF/evGF2.f90 @@ -1,4 +1,4 @@ -subroutine evGF2(BSE,TDA,dBSE,dTDA,evDyn,maxSCF,thresh,max_diis,singlet_manifold,triplet_manifold, & +subroutine evGF2(BSE,TDA,dBSE,dTDA,evDyn,maxSCF,thresh,max_diis,singlet,triplet, & linearize,eta,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI,dipole_int,eHF) ! Perform eigenvalue self-consistent second-order Green function calculation @@ -16,8 +16,8 @@ subroutine evGF2(BSE,TDA,dBSE,dTDA,evDyn,maxSCF,thresh,max_diis,singlet_manifold integer,intent(in) :: maxSCF double precision,intent(in) :: thresh integer,intent(in) :: max_diis - logical,intent(in) :: singlet_manifold - logical,intent(in) :: triplet_manifold + logical,intent(in) :: singlet + logical,intent(in) :: triplet logical,intent(in) :: linearize double precision,intent(in) :: eta integer,intent(in) :: nBas @@ -36,20 +36,17 @@ subroutine evGF2(BSE,TDA,dBSE,dTDA,evDyn,maxSCF,thresh,max_diis,singlet_manifold integer :: nSCF integer :: n_diis + double precision :: Ec double precision :: EcBSE(nspin) - double precision :: num - double precision :: eps double precision :: Conv double precision :: rcond double precision,allocatable :: eGF2(:) double precision,allocatable :: eOld(:) - double precision,allocatable :: Sig(:) + double precision,allocatable :: SigC(:) double precision,allocatable :: Z(:) double precision,allocatable :: error_diis(:,:) double precision,allocatable :: e_diis(:,:) - integer :: i,j,a,b,p - ! Hello world write(*,*) @@ -60,7 +57,7 @@ subroutine evGF2(BSE,TDA,dBSE,dTDA,evDyn,maxSCF,thresh,max_diis,singlet_manifold ! Memory allocation - allocate(Sig(nBas),Z(nBas),eGF2(nBas),eOld(nBas),error_diis(nBas,max_diis),e_diis(nBas,max_diis)) + allocate(SigC(nBas),Z(nBas),eGF2(nBas),eOld(nBas),error_diis(nBas,max_diis),e_diis(nBas,max_diis)) ! Initialization @@ -80,50 +77,15 @@ subroutine evGF2(BSE,TDA,dBSE,dTDA,evDyn,maxSCF,thresh,max_diis,singlet_manifold ! Frequency-dependent second-order contribution - Sig(:) = 0d0 - Z(:) = 0d0 - - do p=nC+1,nBas-nR - do i=nC+1,nO - do j=nC+1,nO - do a=nO+1,nBas-nR - - eps = eGF2(p) + eHF(a) - eHF(i) - eHF(j) - num = (2d0*ERI(p,a,i,j) - ERI(p,a,j,i))*ERI(p,a,i,j) - - Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) - Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 - - end do - end do - end do - end do - - do p=nC+1,nBas-nR - do i=nC+1,nO - do a=nO+1,nBas-nR - do b=nO+1,nBas-nR - - eps = eGF2(p) + eHF(i) - eHF(a) - eHF(b) - num = (2d0*ERI(p,i,a,b) - ERI(p,i,b,a))*ERI(p,i,a,b) - - Sig(p) = Sig(p) + num*eps/(eps**2 + eta**2) - Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 - - end do - end do - end do - end do - - Z(:) = 1d0/(1d0 - Z(:)) + call self_energy_GF2_diag(eta,nBas,nC,nO,nV,nR,nS,eHF,eGF2,ERI,SigC,Z) if(linearize) then - eGF2(:) = eHF(:) + Z(:)*Sig(:) + eGF2(:) = eHF(:) + Z(:)*SigC(:) else - eGF2(:) = eHF(:) + Sig(:) + eGF2(:) = eHF(:) + SigC(:) end if @@ -131,7 +93,8 @@ subroutine evGF2(BSE,TDA,dBSE,dTDA,evDyn,maxSCF,thresh,max_diis,singlet_manifold ! Print results - call print_evGF2(nBas,nO,nSCF,Conv,eHF,Sig,Z,eGF2) + call MP2(nBas,nC,nO,nV,nR,ERI,ENuc,EHF,eGF2,Ec) + call print_evGF2(nBas,nO,nSCF,Conv,eHF,SigC,Z,eGF2,ENuc,ERHF,Ec) ! DIIS extrapolation @@ -169,7 +132,7 @@ subroutine evGF2(BSE,TDA,dBSE,dTDA,evDyn,maxSCF,thresh,max_diis,singlet_manifold if(BSE) then - call BSE2(TDA,dBSE,dTDA,evDyn,singlet_manifold,triplet_manifold,eta,nBas,nC,nO,nV,nR,nS,ERI,dipole_int,eHF,eGF2,EcBSE) + call BSE2(TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI,dipole_int,eHF,eGF2,EcBSE) end if diff --git a/src/MBPT/evGF3.f90 b/src/GF/evGF3.f90 similarity index 100% rename from src/MBPT/evGF3.f90 rename to src/GF/evGF3.f90 diff --git a/src/GF/evUGF2.f90 b/src/GF/evUGF2.f90 new file mode 100644 index 0000000..5f4d0f3 --- /dev/null +++ b/src/GF/evUGF2.f90 @@ -0,0 +1,194 @@ +subroutine evUGF2(maxSCF,thresh,max_diis,BSE,TDA,dBSE,dTDA,evDyn,spin_conserved,spin_flip, & + eta,nBas,nC,nO,nV,nR,nS,ENuc,EUHF,S,ERI_AO,ERI_aaaa,ERI_aabb,ERI_bbbb, & + dipole_int_aa,dipole_int_bb,cHF,eHF) + +! Perform self-consistent eigenvalue-only GW calculation + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: maxSCF + integer,intent(in) :: max_diis + double precision,intent(in) :: thresh + double precision,intent(in) :: ENuc + double precision,intent(in) :: EUHF + logical,intent(in) :: BSE + logical,intent(in) :: TDA + logical,intent(in) :: dBSE + logical,intent(in) :: dTDA + logical,intent(in) :: evDyn + logical,intent(in) :: spin_conserved + logical,intent(in) :: spin_flip + double precision,intent(in) :: eta + + integer,intent(in) :: nBas + integer,intent(in) :: nC(nspin) + integer,intent(in) :: nO(nspin) + integer,intent(in) :: nV(nspin) + integer,intent(in) :: nR(nspin) + integer,intent(in) :: nS(nspin) + + double precision,intent(in) :: eHF(nBas,nspin) + double precision,intent(in) :: cHF(nBas,nBas,nspin) + double precision,intent(in) :: S(nBas,nBas) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_aaaa(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_aabb(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_bbbb(nBas,nBas,nBas,nBas) + double precision,intent(in) :: dipole_int_aa(nBas,nBas,ncart) + double precision,intent(in) :: dipole_int_bb(nBas,nBas,ncart) + +! Local variables + + logical :: linear_mixing + integer :: is + integer :: ispin + integer :: nSCF + integer :: n_diis + double precision :: rcond(nspin) + double precision :: Conv + double precision :: Ec(nsp) + double precision :: EcBSE(nspin) + double precision :: EcAC(nspin) + double precision :: alpha + double precision,allocatable :: error_diis(:,:,:) + double precision,allocatable :: e_diis(:,:,:) + double precision,allocatable :: eGF2(:,:) + double precision,allocatable :: eOld(:,:) + double precision,allocatable :: Z(:,:) + integer :: nS_aa,nS_bb,nS_sc + double precision,allocatable :: SigC(:,:) + +! Hello world + + write(*,*) + write(*,*)'**************************************************' + write(*,*)'| Self-consistent unrestricted evGF2 calculation |' + write(*,*)'**************************************************' + write(*,*) + +! TDA + + if(TDA) then + write(*,*) 'Tamm-Dancoff approximation activated!' + write(*,*) + end if + +! Linear mixing + + linear_mixing = .false. + alpha = 0.2d0 + +! Memory allocation + + nS_aa = nS(1) + nS_bb = nS(2) + nS_sc = nS_aa + nS_bb + + allocate(eGF2(nBas,nspin),eOld(nBas,nspin),Z(nBas,nspin),SigC(nBas,nspin), & + error_diis(nBas,max_diis,nspin),e_diis(nBas,max_diis,nspin)) + +! Initialization + + nSCF = 0 + ispin = 1 + n_diis = 0 + Conv = 1d0 + e_diis(:,:,:) = 0d0 + error_diis(:,:,:) = 0d0 + eGF2(:,:) = eHF(:,:) + eOld(:,:) = eHF(:,:) + Z(:,:) = 1d0 + +!------------------------------------------------------------------------ +! Main loop +!------------------------------------------------------------------------ + + do while(Conv > thresh .and. nSCF <= maxSCF) + + !------------------------------------------------! + ! Compute self-energy and renormalization factor ! + !------------------------------------------------! + + call unrestricted_self_energy_GF2_diag(nBas,nC,nO,nV,nR,eta,ERI_aaaa,ERI_aabb,ERI_bbbb,eHF,eGF2,SigC,Z) + + !-----------------------------------! + ! Solve the quasi-particle equation ! + !-----------------------------------! + + eGF2(:,:) = eHF(:,:) + SigC(:,:) + + ! Convergence criteria + + Conv = maxval(abs(eGF2(:,:) - eOld(:,:))) + + ! Compute MP2 correlation energy + + call UMP2(nBas,nC,nO,nV,nR,ERI_aaaa,ERI_aabb,ERI_bbbb,ENuc,EUHF,eGF2,Ec) + + ! Print results + + call print_evUGF2(nBas,nO,nSCF,Conv,eHF,ENuc,EUHF,SigC,Z,eGF2,Ec) + + ! Linear mixing or DIIS extrapolation + + if(linear_mixing) then + + eGF2(:,:) = alpha*eGF2(:,:) + (1d0 - alpha)*eOld(:,:) + + else + + n_diis = min(n_diis+1,max_diis) + do is=1,nspin + call DIIS_extrapolation(rcond(ispin),nBas,nBas,n_diis,error_diis(:,1:n_diis,is), & + e_diis(:,1:n_diis,is),eGF2(:,is)-eOld(:,is),eGF2(:,is)) + end do + +! Reset DIIS if required + + if(minval(rcond(:)) < 1d-15) n_diis = 0 + + endif + + ! Save quasiparticles energy for next cycle + + eOld(:,:) = eGF2(:,:) + + ! Increment + + nSCF = nSCF + 1 + + enddo +!------------------------------------------------------------------------ +! End main loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + endif + +! Deallocate memory + + deallocate(eOld,Z,SigC,error_diis,e_diis) + +! Perform BSE calculation + + if(BSE) then + + print*,'!!! BSE2 NYI for evUGF2 !!!' + + endif + +end subroutine evUGF2 diff --git a/src/MBPT/print_G0F2.f90 b/src/GF/print_G0F2.f90 similarity index 71% rename from src/MBPT/print_G0F2.f90 rename to src/GF/print_G0F2.f90 index e560db8..87b545b 100644 --- a/src/MBPT/print_G0F2.f90 +++ b/src/GF/print_G0F2.f90 @@ -1,4 +1,4 @@ -subroutine print_G0F2(nBas,nO,eHF,Sig,eGF2,Z) +subroutine print_G0F2(nBas,nO,eHF,Sig,eGF2,Z,ENuc,ERHF,Ec) ! Print one-electron energies and other stuff for G0F2 @@ -11,6 +11,9 @@ subroutine print_G0F2(nBas,nO,eHF,Sig,eGF2,Z) double precision,intent(in) :: Sig(nBas) double precision,intent(in) :: eGF2(nBas) double precision,intent(in) :: Z(nBas) + double precision,intent(in) :: ENuc + double precision,intent(in) :: ERHF + double precision,intent(in) :: Ec integer :: p integer :: HOMO @@ -38,10 +41,13 @@ subroutine print_G0F2(nBas,nO,eHF,Sig,eGF2,Z) enddo write(*,*)'--------------------------------------------------------------------------' - write(*,'(2X,A27,F15.6)') 'G0F2 HOMO energy (eV):',eGF2(HOMO)*HaToeV - write(*,'(2X,A27,F15.6)') 'G0F2 LUMO energy (eV):',eGF2(LUMO)*HaToeV - write(*,'(2X,A27,F15.6)') 'G0F2 HOMO-LUMO gap (eV):',Gap*HaToeV + write(*,'(2X,A30,F15.6)') 'G0F2 HOMO energy (eV):',eGF2(HOMO)*HaToeV + write(*,'(2X,A30,F15.6)') 'G0F2 LUMO energy (eV):',eGF2(LUMO)*HaToeV + write(*,'(2X,A30,F15.6)') 'G0F2 HOMO-LUMO gap (eV):',Gap*HaToeV write(*,*)'--------------------------------------------------------------------------' + write(*,'(2X,A30,F15.6,A3)') 'G0F2 total energy :',ENuc + ERHF + Ec,' au' + write(*,'(2X,A30,F15.6,A3)') 'G0F2 correlation energy:',Ec,' au' + write(*,*)'-------------------------------------------------------------------------------' write(*,*) end subroutine print_G0F2 diff --git a/src/MBPT/print_G0F3.f90 b/src/GF/print_G0F3.f90 similarity index 100% rename from src/MBPT/print_G0F3.f90 rename to src/GF/print_G0F3.f90 diff --git a/src/GF/print_UG0F2.f90 b/src/GF/print_UG0F2.f90 new file mode 100644 index 0000000..1495401 --- /dev/null +++ b/src/GF/print_UG0F2.f90 @@ -0,0 +1,73 @@ +subroutine print_UG0F2(nBas,nO,eHF,ENuc,EUHF,SigC,Z,eGF2,Ec) + +! Print one-electron energies and other stuff for G0W0 + + implicit none + include 'parameters.h' + + integer,intent(in) :: nBas + integer,intent(in) :: nO(nspin) + double precision,intent(in) :: ENuc + double precision,intent(in) :: EUHF + double precision,intent(in) :: Ec(nsp) + double precision,intent(in) :: eHF(nBas,nspin) + double precision,intent(in) :: SigC(nBas,nspin) + double precision,intent(in) :: Z(nBas,nspin) + double precision,intent(in) :: eGF2(nBas,nspin) + + integer :: p + integer :: ispin + double precision :: HOMO(nspin) + double precision :: LUMO(nspin) + double precision :: Gap(nspin) + +! HOMO and LUMO + + do ispin=1,nspin + if(nO(ispin) > 0) then + HOMO(ispin) = eGF2(nO(ispin),ispin) + LUMO(ispin) = eGF2(nO(ispin)+1,ispin) + Gap(ispin) = LUMO(ispin) - HOMO(ispin) + else + HOMO(ispin) = 0d0 + LUMO(ispin) = eGF2(1,ispin) + Gap(ispin) = 0d0 + end if + end do + +! Dump results + + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + write(*,*)' Unrestricted one-shot G0F2 calculation (eV)' + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + write(*,'(A1,A3,A1,A30,A1,A30,A1,A30,A1,A30,A1)') & + '|',' ','|','e_HF ','|','Sig_c ','|','Z ','|','e_QP ','|' + write(*,'(A1,A3,A1,2A15,A1,2A15,A1,2A15,A1,2A15,A1)') & + '|','#','|','up ','dw ','|','up ','dw ','|','up ','dw ','|','up ','dw ','|' + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + + do p=1,nBas + write(*,'(A1,I3,A1,2F15.6,A1,2F15.6,A1,2F15.6,A1,2F15.6,A1)') & + '|',p,'|',eHF(p,1)*HaToeV,eHF(p,2)*HaToeV,'|',SigC(p,1)*HaToeV,SigC(p,2)*HaToeV,'|', & + Z(p,1),Z(p,2),'|',eGF2(p,1)*HaToeV,eGF2(p,2)*HaToeV,'|' + enddo + + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + write(*,'(2X,A30,F15.6,A3)') 'UG0F2 HOMO energy:',maxval(HOMO(:))*HaToeV,' eV' + write(*,'(2X,A30,F15.6,A3)') 'UG0F2 LUMO energy:',minval(LUMO(:))*HaToeV,' eV' + write(*,'(2X,A30,F15.6,A3)') 'UG0F2 HOMO-LUMO gap :',(minval(LUMO(:))-maxval(HOMO(:)))*HaToeV,' eV' + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + write(*,'(2X,A30,F15.6,A3)') ' UG0F2 total energy :',ENuc + EUHF + sum(Ec(:)),' au' + write(*,'(2X,A30,F15.6,A3)') ' UG0F2 correlation energy:',sum(Ec(:)),' au' + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + write(*,*) + +end subroutine print_UG0F2 + + diff --git a/src/MBPT/print_evGF2.f90 b/src/GF/print_evGF2.f90 similarity index 74% rename from src/MBPT/print_evGF2.f90 rename to src/GF/print_evGF2.f90 index fdab254..07c8b42 100644 --- a/src/MBPT/print_evGF2.f90 +++ b/src/GF/print_evGF2.f90 @@ -1,4 +1,4 @@ -subroutine print_evGF2(nBas,nO,nSCF,Conv,eHF,Sig,Z,eGF2) +subroutine print_evGF2(nBas,nO,nSCF,Conv,eHF,Sig,Z,eGF2,ENuc,ERHF,Ec) ! Print one-electron energies and other stuff for G0F2 @@ -13,6 +13,9 @@ subroutine print_evGF2(nBas,nO,nSCF,Conv,eHF,Sig,Z,eGF2) double precision,intent(in) :: Sig(nBas) double precision,intent(in) :: eGF2(nBas) double precision,intent(in) :: Z(nBas) + double precision,intent(in) :: ENuc + double precision,intent(in) :: ERHF + double precision,intent(in) :: Ec integer :: p integer :: HOMO @@ -44,10 +47,13 @@ subroutine print_evGF2(nBas,nO,nSCF,Conv,eHF,Sig,Z,eGF2) write(*,'(2X,A14,F15.5)')'Convergence = ',Conv write(*,*)'--------------------------------------------------------------------------' - write(*,'(2X,A27,F15.6)') 'evGF2 HOMO energy (eV):',eGF2(HOMO)*HaToeV - write(*,'(2X,A27,F15.6)') 'evGF2 LUMO energy (eV):',eGF2(LUMO)*HaToeV - write(*,'(2X,A27,F15.6)') 'evGF2 HOMO-LUMO gap (eV):',Gap*HaToeV + write(*,'(2X,A30,F15.6)') 'evGF2 HOMO energy (eV):',eGF2(HOMO)*HaToeV + write(*,'(2X,A30,F15.6)') 'evGF2 LUMO energy (eV):',eGF2(LUMO)*HaToeV + write(*,'(2X,A30,F15.6)') 'evGF2 HOMO-LUMO gap (eV):',Gap*HaToeV write(*,*)'--------------------------------------------------------------------------' + write(*,'(2X,A30,F15.6,A3)') 'evGF2 total energy :',ENuc + ERHF + Ec,' au' + write(*,'(2X,A30,F15.6,A3)') 'evGF2 correlation energy:',Ec,' au' + write(*,*)'-------------------------------------------------------------------------------' write(*,*) end subroutine print_evGF2 diff --git a/src/MBPT/print_evGF3.f90 b/src/GF/print_evGF3.f90 similarity index 100% rename from src/MBPT/print_evGF3.f90 rename to src/GF/print_evGF3.f90 diff --git a/src/GF/print_evUGF2.f90 b/src/GF/print_evUGF2.f90 new file mode 100644 index 0000000..f04f6f3 --- /dev/null +++ b/src/GF/print_evUGF2.f90 @@ -0,0 +1,81 @@ +subroutine print_evUGF2(nBas,nO,nSCF,Conv,eHF,ENuc,EUHF,SigC,Z,eGF2,Ec) + +! Print one-electron energies and other stuff for evGF2 + + implicit none + include 'parameters.h' + + integer,intent(in) :: nBas + integer,intent(in) :: nO(nspin) + integer,intent(in) :: nSCF + double precision,intent(in) :: ENuc + double precision,intent(in) :: EUHF + double precision,intent(in) :: Ec(nsp) + double precision,intent(in) :: Conv + double precision,intent(in) :: eHF(nBas,nspin) + double precision,intent(in) :: SigC(nBas,nspin) + double precision,intent(in) :: Z(nBas,nspin) + double precision,intent(in) :: eGF2(nBas,nspin) + + integer :: p + integer :: ispin + double precision :: HOMO(nspin) + double precision :: LUMO(nspin) + double precision :: Gap(nspin) + +! HOMO and LUMO + + do ispin=1,nspin + if(nO(ispin) > 0) then + HOMO(ispin) = eGF2(nO(ispin),ispin) + LUMO(ispin) = eGF2(nO(ispin)+1,ispin) + Gap(ispin) = LUMO(ispin) - HOMO(ispin) + else + HOMO(ispin) = 0d0 + LUMO(ispin) = eGF2(1,ispin) + Gap(ispin) = 0d0 + end if + end do + +! Dump results + + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + if(nSCF < 10) then + write(*,'(1X,A21,I1,A2,A12)')' Self-consistent evG',nSCF,'F2',' calculation' + else + write(*,'(1X,A21,I2,A2,A12)')' Self-consistent evG',nSCF,'F2',' calculation' + endif + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + write(*,'(A1,A3,A1,A30,A1,A30,A1,A30,A1,A30,A1)') & + '|',' ','|','e_HF ','|','Sig_c ','|','Z ','|','e_QP ','|' + write(*,'(A1,A3,A1,2A15,A1,2A15,A1,2A15,A1,2A15,A1)') & + '|','#','|','up ','dw ','|','up ','dw ','|','up ','dw ','|','up ','dw ','|' + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + + do p=1,nBas + write(*,'(A1,I3,A1,2F15.6,A1,2F15.6,A1,2F15.6,A1,2F15.6,A1)') & + '|',p,'|',eHF(p,1)*HaToeV,eHF(p,2)*HaToeV,'|',SigC(p,1)*HaToeV,SigC(p,2)*HaToeV,'|', & + Z(p,1),Z(p,2),'|',eGF2(p,1)*HaToeV,eGF2(p,2)*HaToeV,'|' + enddo + + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + write(*,'(2X,A10,I3)') 'Iteration ',nSCF + write(*,'(2X,A14,F15.5)')'Convergence = ',Conv + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + write(*,'(2X,A30,F15.6,A3)') 'evGF2 HOMO energy:',maxval(HOMO(:))*HaToeV,' eV' + write(*,'(2X,A30,F15.6,A3)') 'evGF2 LUMO energy:',minval(LUMO(:))*HaToeV,' eV' + write(*,'(2X,A30,F15.6,A3)') 'evGF2 HOMO-LUMO gap :',(minval(LUMO(:))-maxval(HOMO(:)))*HaToeV,' eV' + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + write(*,'(2X,A30,F15.6,A3)') ' evGF2 total energy :',ENuc + EUHF + sum(Ec(:)),' au' + write(*,'(2X,A30,F15.6,A3)') ' evGF2 correlation energy:',sum(Ec(:)),' au' + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + write(*,*) + +end subroutine print_evUGF2 diff --git a/src/GF/print_qsGF2.f90 b/src/GF/print_qsGF2.f90 new file mode 100644 index 0000000..1462e70 --- /dev/null +++ b/src/GF/print_qsGF2.f90 @@ -0,0 +1,119 @@ +subroutine print_qsGF2(nBas,nO,nSCF,Conv,thresh,eHF,eGF2,c,P,T,V,J,K,F,SigC,Z, & + ENuc,ET,EV,EJ,Ex,Ec,EqsGF2,dipole) + +! Print one-electron energies and other stuff for qsGF2 + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + integer,intent(in) :: nO + integer,intent(in) :: nSCF + double precision,intent(in) :: ENuc + double precision,intent(in) :: Conv + double precision,intent(in) :: thresh + double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: eGF2(nBas) + double precision,intent(in) :: c(nBas) + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: T(nBas,nBas),V(nBas,nBas) + double precision,intent(in) :: J(nBas,nBas),K(nBas,nBas),F(nBas,nBas) + double precision,intent(in) :: Z(nBas),SigC(nBas,nBas) + double precision,intent(in) :: ET + double precision,intent(in) :: EV + double precision,intent(in) :: EJ + double precision,intent(in) :: Ex + double precision,intent(in) :: Ec + double precision,intent(in) :: EqsGF2 + double precision,intent(in) :: dipole(ncart) + +! Local variables + + integer :: q,ixyz,HOMO,LUMO + double precision :: Gap + double precision,external :: trace_matrix + +! Output variables + +! HOMO and LUMO + + HOMO = nO + LUMO = HOMO + 1 + Gap = eGF2(LUMO)-eGF2(HOMO) + +! Dump results + + write(*,*)'-------------------------------------------------------------------------------' + if(nSCF < 10) then + write(*,'(1X,A21,I1,A2,A12)')' Self-consistent qsG',nSCF,'F2',' calculation' + else + write(*,'(1X,A21,I2,A2,A12)')' Self-consistent qsG',nSCF,'F2',' calculation' + endif + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X,A15,1X,A1,1X)') & + '|','#','|','e_HF (eV)','|','Sig_c (eV)','|','Z','|','e_QP (eV)','|' + write(*,*)'-------------------------------------------------------------------------------' + + do q=1,nBas + write(*,'(1X,A1,1X,I3,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X,F15.6,1X,A1,1X)') & + '|',q,'|',eHF(q)*HaToeV,'|',SigC(q,q)*HaToeV,'|',Z(q),'|',eGF2(q)*HaToeV,'|' + enddo + + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A10,I3)') 'Iteration ',nSCF + write(*,'(2X,A14,F15.5)')'Convergence = ',Conv + write(*,*)'-------------------------------------------' + write(*,'(2X,A30,F15.6,A3)') 'qsGF2 HOMO energy:',eGF2(HOMO)*HaToeV,' eV' + write(*,'(2X,A30,F15.6,A3)') 'qsGF2 LUMO energy:',eGF2(LUMO)*HaToeV,' eV' + write(*,'(2X,A30,F15.6,A3)') 'qsGF2 HOMO-LUMO gap :',Gap*HaToeV,' eV' + write(*,*)'-------------------------------------------' + write(*,'(2X,A30,F15.6,A3)') ' qsGF2 total energy:',ENuc + EqsGF2,' au' + write(*,'(2X,A30,F15.6,A3)') ' qsGF2 exchange energy:',Ex,' au' + write(*,'(2X,A30,F15.6,A3)') ' qsGF2 correlation energy:',Ec,' au' + write(*,*)'-------------------------------------------' + write(*,*) + +! Dump results for final iteration + + if(Conv < thresh) then + + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' Summary ' + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10,A3)') ' One-electron energy: ',ET + EV,' au' + write(*,'(A32,1X,F16.10,A3)') ' Kinetic energy: ',ET,' au' + write(*,'(A32,1X,F16.10,A3)') ' Potential energy: ',EV,' au' + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10,A3)') ' Two-electron energy: ',EJ + Ex + Ec,' au' + write(*,'(A32,1X,F16.10,A3)') ' Hartree energy: ',EJ,' au' + write(*,'(A32,1X,F16.10,A3)') ' Exchange energy: ',Ex,' au' + write(*,'(A32,1X,F16.10,A3)') ' Correlation energy: ',Ec,' au' + write(*,'(A50)') '---------------------------------------' + write(*,'(A32,1X,F16.10,A3)') ' Electronic energy: ',EqsGF2,' au' + write(*,'(A32,1X,F16.10,A3)') ' Nuclear repulsion: ',ENuc,' au' + write(*,'(A32,1X,F16.10,A3)') ' qsGF2 energy: ',ENuc + EqsGF2,' au' + write(*,'(A50)') '---------------------------------------' + write(*,'(A35)') ' Dipole moment (Debye) ' + write(*,'(10X,4A10)') 'X','Y','Z','Tot.' + write(*,'(10X,4F10.6)') (dipole(ixyz)*auToD,ixyz=1,ncart),norm2(dipole)*auToD + write(*,'(A50)') '-----------------------------------------' + write(*,*) + + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' qsGF2 MO coefficients' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,nBas,c) + write(*,*) + write(*,'(A50)') '---------------------------------------' + write(*,'(A32)') ' qsGF2 MO energies' + write(*,'(A50)') '---------------------------------------' + call matout(nBas,1,eGF2) + write(*,*) + + endif + + +end subroutine print_qsGF2 diff --git a/src/GF/print_qsUGF2.f90 b/src/GF/print_qsUGF2.f90 new file mode 100644 index 0000000..f87a9d5 --- /dev/null +++ b/src/GF/print_qsUGF2.f90 @@ -0,0 +1,178 @@ +subroutine print_qsUGF2(nBas,nO,nSCF,Conv,thresh,eHF,eGF2,cGF2,PGF2,Ov,T,V,J,K, & + ENuc,ET,EV,EJ,Ex,Ec,EqsGF2,SigC,Z,dipole) + +! Print one-electron energies and other stuff for qsUGF2 + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + integer,intent(in) :: nO(nspin) + integer,intent(in) :: nSCF + double precision,intent(in) :: ENuc + double precision,intent(in) :: ET(nspin) + double precision,intent(in) :: EV(nspin) + double precision,intent(in) :: EJ(nsp) + double precision,intent(in) :: Ex(nspin) + double precision,intent(in) :: Ec(nsp) + double precision,intent(in) :: EqsGF2 + double precision,intent(in) :: Conv + double precision,intent(in) :: thresh + double precision,intent(in) :: eHF(nBas,nspin) + double precision,intent(in) :: eGF2(nBas,nspin) + double precision,intent(in) :: cGF2(nBas,nBas,nspin) + double precision,intent(in) :: PGF2(nBas,nBas,nspin) + double precision,intent(in) :: Ov(nBas,nBas) + double precision,intent(in) :: T(nBas,nBas) + double precision,intent(in) :: V(nBas,nBas) + double precision,intent(in) :: J(nBas,nBas,nspin) + double precision,intent(in) :: K(nBas,nBas,nspin) + double precision,intent(in) :: SigC(nBas,nBas,nspin) + double precision,intent(in) :: Z(nBas,nspin) + double precision,intent(in) :: dipole(ncart) + +! Local variables + + integer :: p + integer :: ispin,ixyz + double precision :: HOMO(nspin) + double precision :: LUMO(nspin) + double precision :: Gap(nspin) + double precision :: S_exact,S2_exact + double precision :: S,S2 + double precision,external :: trace_matrix + +! HOMO and LUMO + + do ispin=1,nspin + if(nO(ispin) > 0) then + HOMO(ispin) = eGF2(nO(ispin),ispin) + LUMO(ispin) = eGF2(nO(ispin)+1,ispin) + Gap(ispin) = LUMO(ispin) - HOMO(ispin) + else + HOMO(ispin) = 0d0 + LUMO(ispin) = eGF2(1,ispin) + Gap(ispin) = 0d0 + end if + end do + + S2_exact = dble(nO(1) - nO(2))/2d0*(dble(nO(1) - nO(2))/2d0 + 1d0) + S2 = S2_exact + nO(2) - sum(matmul(transpose(cGF2(:,1:nO(1),1)),matmul(Ov,cGF2(:,1:nO(2),2)))**2) + + S_exact = 0.5d0*dble(nO(1) - nO(2)) + S = -0.5d0 + 0.5d0*sqrt(1d0 + 4d0*S2) + +! Dump results + + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + if(nSCF < 10) then + write(*,'(1X,A21,I1,A2,A12)')' Self-consistent qsG',nSCF,'F2',' calculation' + else + write(*,'(1X,A21,I2,A2,A12)')' Self-consistent qsG',nSCF,'F2',' calculation' + endif + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + write(*,'(A1,A3,A1,A30,A1,A30,A1,A30,A1,A30,A1)') & + '|',' ','|','e_HF ','|','Sig_c ','|','Z ','|','e_QP ','|' + write(*,'(A1,A3,A1,2A15,A1,2A15,A1,2A15,A1,2A15,A1)') & + '|','#','|','up ','dw ','|','up ','dw ','|','up ','dw ','|','up ','dw ','|' + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + + do p=1,nBas + write(*,'(A1,I3,A1,2F15.6,A1,2F15.6,A1,2F15.6,A1,2F15.6,A1)') & + '|',p,'|',eHF(p,1)*HaToeV,eHF(p,2)*HaToeV,'|',SigC(p,p,1)*HaToeV,SigC(p,p,2)*HaToeV,'|', & + Z(p,1),Z(p,2),'|',eGF2(p,1)*HaToeV,eGF2(p,2)*HaToeV,'|' + enddo + + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + write(*,'(2X,A10,I3)') 'Iteration ',nSCF + write(*,'(2X,A14,F15.5)')'Convergence = ',Conv + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + write(*,'(2X,A30,F15.6,A3)') 'qsUGF2 HOMO energy:',maxval(HOMO(:))*HaToeV,' eV' + write(*,'(2X,A30,F15.6,A3)') 'qsUGF2 LUMO energy:',minval(LUMO(:))*HaToeV,' eV' + write(*,'(2X,A30,F15.6,A3)') 'qsUGF2 HOMO-LUMO gap :',(minval(LUMO(:))-maxval(HOMO(:)))*HaToeV,' eV' + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + write(*,'(2X,A30,F15.6,A3)') ' qsUGF2 total energy:',ENuc + EqsGF2,' au' + write(*,'(2X,A30,F15.6,A3)') ' qsUGF2 exchange energy:',sum(Ex(:)),' au' + write(*,'(2X,A30,F15.6,A3)') ' qsUGF2 correlation energy:',sum(Ec(:)),' au' + write(*,*)'-------------------------------------------------------------------------------& + -------------------------------------------------' + write(*,*) + +! Dump results for final iteration + + if(Conv < thresh) then + + write(*,*) + write(*,'(A60)') '-------------------------------------------------' + write(*,'(A40)') ' Summary ' + write(*,'(A60)') '-------------------------------------------------' + write(*,'(A40,1X,F16.10,A3)') ' One-electron energy: ',sum(ET(:)) + sum(EV(:)),' au' + write(*,'(A40,1X,F16.10,A3)') ' One-electron a energy: ',ET(1) + EV(1),' au' + write(*,'(A40,1X,F16.10,A3)') ' One-electron b energy: ',ET(2) + EV(2),' au' + write(*,*) + write(*,'(A40,1X,F16.10,A3)') ' Kinetic energy: ',sum(ET(:)),' au' + write(*,'(A40,1X,F16.10,A3)') ' Kinetic a energy: ',ET(1),' au' + write(*,'(A40,1X,F16.10,A3)') ' Kinetic b energy: ',ET(2),' au' + write(*,*) + write(*,'(A40,1X,F16.10,A3)') ' Potential energy: ',sum(EV(:)),' au' + write(*,'(A40,1X,F16.10,A3)') ' Potential a energy: ',EV(1),' au' + write(*,'(A40,1X,F16.10,A3)') ' Potential b energy: ',EV(2),' au' + write(*,'(A60)') '-------------------------------------------------' + write(*,'(A40,1X,F16.10,A3)') ' Two-electron energy: ',sum(EJ(:)) + sum(Ex(:)) + sum(Ec(:)),' au' + write(*,'(A40,1X,F16.10,A3)') ' Two-electron aa energy: ',EJ(1) + Ex(1) + Ec(1),' au' + write(*,'(A40,1X,F16.10,A3)') ' Two-electron ab energy: ',EJ(2) + Ec(2),' au' + write(*,'(A40,1X,F16.10,A3)') ' Two-electron bb energy: ',EJ(3) + Ex(2) + Ec(3),' au' + write(*,*) + write(*,'(A40,1X,F16.10,A3)') ' Hartree energy: ',sum(EJ(:)),' au' + write(*,'(A40,1X,F16.10,A3)') ' Hartree aa energy: ',EJ(1),' au' + write(*,'(A40,1X,F16.10,A3)') ' Hartree ab energy: ',EJ(2),' au' + write(*,'(A40,1X,F16.10,A3)') ' Hartree bb energy: ',EJ(3),' au' + write(*,*) + write(*,'(A40,1X,F16.10,A3)') ' Exchange energy: ',sum(Ex(:)),' au' + write(*,'(A40,1X,F16.10,A3)') ' Exchange a energy: ',Ex(1),' au' + write(*,'(A40,1X,F16.10,A3)') ' Exchange b energy: ',Ex(2),' au' + write(*,*) + write(*,'(A40,1X,F16.10,A3)') ' Correlation energy: ',sum(Ec(:)),' au' + write(*,'(A40,1X,F16.10,A3)') ' Correlation aa energy: ',Ec(1),' au' + write(*,'(A40,1X,F16.10,A3)') ' Correlation ab energy: ',Ec(2),' au' + write(*,'(A40,1X,F16.10,A3)') ' Correlation bb energy: ',Ec(3),' au' + write(*,'(A60)') '-------------------------------------------------' + write(*,'(A40,1X,F16.10,A3)') ' Electronic energy: ',EqsGF2,' au' + write(*,'(A40,1X,F16.10,A3)') ' Nuclear repulsion: ',ENuc,' au' + write(*,'(A40,1X,F16.10,A3)') ' qsUGF2 energy: ',ENuc + EqsGF2,' au' + write(*,'(A60)') '-------------------------------------------------' + write(*,'(A40,F13.6)') ' S (exact) :',2d0*S_exact + 1d0 + write(*,'(A40,F13.6)') ' S :',2d0*S + 1d0 + write(*,'(A40,F13.6)') ' (exact) :',S2_exact + write(*,'(A40,F13.6)') ' :',S2 + write(*,'(A60)') '-------------------------------------------------' + write(*,'(A45)') ' Dipole moment (Debye) ' + write(*,'(19X,4A10)') 'X','Y','Z','Tot.' + write(*,'(19X,4F10.6)') (dipole(ixyz)*auToD,ixyz=1,ncart),norm2(dipole)*auToD + write(*,'(A60)') '-------------------------------------------------' + write(*,*) + + ! Print orbitals + + write(*,'(A50)') '-----------------------------------------' + write(*,'(A50)') 'qsUGF2 spin-up orbital coefficients ' + write(*,'(A50)') '-----------------------------------------' + call matout(nBas,nBas,cGF2(:,:,1)) + write(*,*) + write(*,'(A50)') '-----------------------------------------' + write(*,'(A50)') 'qsUGF2 spin-down orbital coefficients ' + write(*,'(A50)') '-----------------------------------------' + call matout(nBas,nBas,cGF2(:,:,2)) + write(*,*) + + endif + +end subroutine print_qsUGF2 diff --git a/src/GF/qsGF2.f90 b/src/GF/qsGF2.f90 new file mode 100644 index 0000000..db8e50d --- /dev/null +++ b/src/GF/qsGF2.f90 @@ -0,0 +1,267 @@ +subroutine qsGF2(maxSCF,thresh,max_diis,BSE,TDA,dBSE,dTDA,evDyn,singlet,triplet, & + eta,nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,ERHF, & + S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) + +! Perform a quasiparticle self-consistent GF2 calculation + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: maxSCF + integer,intent(in) :: max_diis + double precision,intent(in) :: thresh + logical,intent(in) :: BSE + logical,intent(in) :: TDA + logical,intent(in) :: dBSE + logical,intent(in) :: dTDA + logical,intent(in) :: evDyn + logical,intent(in) :: singlet + logical,intent(in) :: triplet + double precision,intent(in) :: eta + + integer,intent(in) :: nNuc + double precision,intent(in) :: ZNuc(nNuc) + double precision,intent(in) :: rNuc(nNuc,ncart) + double precision,intent(in) :: ENuc + + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: ERHF + double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: cHF(nBas,nBas) + double precision,intent(in) :: PHF(nBas,nBas) + double precision,intent(in) :: S(nBas,nBas) + double precision,intent(in) :: T(nBas,nBas) + double precision,intent(in) :: V(nBas,nBas) + double precision,intent(in) :: Hc(nBas,nBas) + double precision,intent(in) :: X(nBas,nBas) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(inout):: ERI_MO(nBas,nBas,nBas,nBas) + double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) + double precision,intent(in) :: dipole_int_MO(nBas,nBas,ncart) + +! Local variables + + integer :: nSCF + integer :: nBasSq + integer :: ispin + integer :: n_diis + double precision :: EqsGF2 + double precision :: Conv + double precision :: rcond + double precision,external :: trace_matrix + double precision :: dipole(ncart) + double precision :: ET + double precision :: EV + double precision :: EJ + double precision :: Ex + double precision :: Ec + double precision :: EcBSE(nspin) + + double precision,allocatable :: error_diis(:,:) + double precision,allocatable :: F_diis(:,:) + double precision,allocatable :: c(:,:) + double precision,allocatable :: cp(:,:) + double precision,allocatable :: eGF2(:) + double precision,allocatable :: eOld(:) + double precision,allocatable :: P(:,:) + double precision,allocatable :: F(:,:) + double precision,allocatable :: Fp(:,:) + double precision,allocatable :: J(:,:) + double precision,allocatable :: K(:,:) + double precision,allocatable :: SigC(:,:) + double precision,allocatable :: SigCp(:,:) + double precision,allocatable :: SigCm(:,:) + double precision,allocatable :: Z(:) + double precision,allocatable :: error(:,:) + +! Hello world + + write(*,*) + write(*,*)'************************************************' + write(*,*)'| Self-consistent qsGF2 calculation |' + write(*,*)'************************************************' + write(*,*) + +! Warning + + write(*,*) '!! ERIs in MO basis will be overwritten in qsGF2 !!' + write(*,*) + +! Stuff + + nBasSq = nBas*nBas + +! TDA + + if(TDA) then + write(*,*) 'Tamm-Dancoff approximation activated!' + write(*,*) + end if + +! Memory allocation + + allocate(eGF2(nBas),eOld(nbas),c(nBas,nBas),cp(nBas,nBas),P(nBas,nBas),F(nBas,nBas),Fp(nBas,nBas), & + J(nBas,nBas),K(nBas,nBas),SigC(nBas,nBas),SigCp(nBas,nBas),SigCm(nBas,nBas),Z(nBas), & + error(nBas,nBas),error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + +! Initialization + + nSCF = -1 + n_diis = 0 + ispin = 1 + Conv = 1d0 + P(:,:) = PHF(:,:) + eOld(:) = eHF(:) + eGF2(:) = eHF(:) + c(:,:) = cHF(:,:) + F_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + rcond = 1d0 + +!------------------------------------------------------------------------ +! Main loop +!------------------------------------------------------------------------ + + do while(Conv > thresh .and. nSCF <= maxSCF) + + ! Increment + + nSCF = nSCF + 1 + + ! Buid Coulomb matrix + + call Coulomb_matrix_AO_basis(nBas,P,ERI_AO,J) + + ! Compute exchange part of the self-energy + + call exchange_matrix_AO_basis(nBas,P,ERI_AO,K) + + ! AO to MO transformation of two-electron integrals + + call AOtoMO_integral_transform(1,1,1,1,nBas,c,ERI_AO,ERI_MO) + + ! Compute self-energy and renormalization factor + + call self_energy_GF2(eta,nBas,nC,nO,nV,nR,nS,eHF,eGF2,ERI_MO,SigC,Z) + + ! Make correlation self-energy Hermitian and transform it back to AO basis + + SigCp = 0.5d0*(SigC + transpose(SigC)) + SigCm = 0.5d0*(SigC - transpose(SigC)) + + call MOtoAO_transform(nBas,S,c,SigCp) + + ! Solve the quasi-particle equation + + F(:,:) = Hc(:,:) + J(:,:) + 0.5d0*K(:,:) + SigCp(:,:) + + ! Compute commutator and convergence criteria + + error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + + ! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + if(abs(rcond) > 1d-7) then + call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + else + n_diis = 0 + end if + + ! Diagonalize Hamiltonian in AO basis + + Fp = matmul(transpose(X),matmul(F,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,eGF2) + c = matmul(X,cp) + SigCp = matmul(transpose(c),matmul(SigCp,c)) + + ! Compute new density matrix in the AO basis + + P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + + ! Save quasiparticles energy for next cycle + + Conv = maxval(abs(eGF2 - eOld)) + eOld(:) = eGF2(:) + + !------------------------------------------------------------------------ + ! Compute total energy + !------------------------------------------------------------------------ + + ! Kinetic energy + + ET = trace_matrix(nBas,matmul(P,T)) + + ! Potential energy + + EV = trace_matrix(nBas,matmul(P,V)) + + ! Coulomb energy + + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + + ! Exchange energy + + Ex = 0.25d0*trace_matrix(nBas,matmul(P,K)) + + ! Correlation energy + + call MP2(nBas,nC,nO,nV,nR,ERI_MO,ENuc,EqsGF2,eGF2,Ec) + + ! Total energy + + EqsGF2 = ET + EV + EJ + Ex + Ec + + + !------------------------------------------------------------------------ + ! Print results + !------------------------------------------------------------------------ + + call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) + call print_qsGF2(nBas,nO,nSCF,Conv,thresh,eHF,eGF2,c,P,T,V,J,K,F,SigCp,Z, & + ENuc,ET,EV,EJ,Ex,Ec,EqsGF2,dipole) + + enddo +!------------------------------------------------------------------------ +! End main loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF+1) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + endif + +! Deallocate memory + + deallocate(c,cp,P,F,Fp,J,K,SigC,SigCp,SigCm,Z,error,error_diis,F_diis) + +! Perform BSE calculation + + if(BSE) then + + call BSE2(TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int_MO,eHF,eGF2,EcBSE) + + write(*,*) + write(*,*)'-------------------------------------------------------------------------------' + write(*,'(2X,A50,F20.10)') 'Tr@BSE@qsGF2 correlation energy (singlet) =',EcBSE(1) + write(*,'(2X,A50,F20.10)') 'Tr@BSE@qsGF2 correlation energy (triplet) =',EcBSE(2) + write(*,'(2X,A50,F20.10)') 'Tr@BSE@qsGF2 correlation energy =',sum(EcBSE(:)) + write(*,'(2X,A50,F20.10)') 'Tr@BSE@qsGF2 total energy =',ENuc + EqsGF2 + sum(EcBSE(:)) + write(*,*)'-------------------------------------------------------------------------------' + write(*,*) + + end if + +end subroutine qsGF2 diff --git a/src/GF/qsUGF2.f90 b/src/GF/qsUGF2.f90 new file mode 100644 index 0000000..3295f6f --- /dev/null +++ b/src/GF/qsUGF2.f90 @@ -0,0 +1,331 @@ +subroutine qsUGF2(maxSCF,thresh,max_diis,BSE,TDA,dBSE,dTDA,evDyn,spin_conserved,spin_flip,eta, & + nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,EUHF,S,X,T,V,Hc,ERI_AO, & + ERI_aaaa,ERI_aabb,ERI_bbbb,dipole_int_AO,dipole_int_aa,dipole_int_bb,PHF,cHF,eHF) + +! Perform an unrestricted quasiparticle self-consistent GF2 calculation + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: maxSCF + integer,intent(in) :: max_diis + double precision,intent(in) :: thresh + logical,intent(in) :: BSE + logical,intent(in) :: TDA + logical,intent(in) :: dBSE + logical,intent(in) :: dTDA + logical,intent(in) :: evDyn + logical,intent(in) :: spin_conserved + logical,intent(in) :: spin_flip + double precision,intent(in) :: eta + + integer,intent(in) :: nNuc + double precision,intent(in) :: ZNuc(nNuc) + double precision,intent(in) :: rNuc(nNuc,ncart) + double precision,intent(in) :: ENuc + + integer,intent(in) :: nBas + integer,intent(in) :: nC(nspin) + integer,intent(in) :: nO(nspin) + integer,intent(in) :: nV(nspin) + integer,intent(in) :: nR(nspin) + integer,intent(in) :: nS(nspin) + + double precision,intent(in) :: EUHF + double precision,intent(in) :: eHF(nBas,nspin) + double precision,intent(in) :: cHF(nBas,nBas,nspin) + double precision,intent(in) :: PHF(nBas,nBas,nspin) + double precision,intent(in) :: S(nBas,nBas) + double precision,intent(in) :: T(nBas,nBas) + double precision,intent(in) :: V(nBas,nBas) + double precision,intent(in) :: Hc(nBas,nBas) + double precision,intent(in) :: X(nBas,nBas) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(inout):: ERI_aaaa(nBas,nBas,nBas,nBas) + double precision,intent(inout):: ERI_aabb(nBas,nBas,nBas,nBas) + double precision,intent(inout):: ERI_bbbb(nBas,nBas,nBas,nBas) + double precision,intent(in) :: dipole_int_AO(nBas,nBas,ncart) + double precision,intent(in) :: dipole_int_aa(nBas,nBas,ncart) + double precision,intent(in) :: dipole_int_bb(nBas,nBas,ncart) + +! Local variables + + integer :: nSCF + integer :: nBasSq + integer :: ispin + integer :: is + integer :: n_diis + integer :: nS_aa,nS_bb,nS_sc + double precision :: dipole(ncart) + + double precision :: ET(nspin) + double precision :: EV(nspin) + double precision :: EJ(nsp) + double precision :: Ex(nspin) + double precision :: Ec(nsp) + double precision :: EqsGF2 + double precision :: EcBSE(nspin) + double precision :: EcAC(nspin) + double precision :: Conv + double precision :: rcond(nspin) + double precision,external :: trace_matrix + double precision,allocatable :: error_diis(:,:,:) + double precision,allocatable :: F_diis(:,:,:) + double precision,allocatable :: c(:,:,:) + double precision,allocatable :: cp(:,:,:) + double precision,allocatable :: eOld(:,:) + double precision,allocatable :: eGF2(:,:) + double precision,allocatable :: P(:,:,:) + double precision,allocatable :: F(:,:,:) + double precision,allocatable :: Fp(:,:,:) + double precision,allocatable :: J(:,:,:) + double precision,allocatable :: K(:,:,:) + double precision,allocatable :: SigC(:,:,:) + double precision,allocatable :: SigCp(:,:,:) + double precision,allocatable :: SigCm(:,:,:) + double precision,allocatable :: Z(:,:) + double precision,allocatable :: error(:,:,:) + +! Hello world + + write(*,*) + write(*,*)'**************************************************' + write(*,*)'| Self-consistent unrestricted qsGF2 calculation |' + write(*,*)'**************************************************' + write(*,*) + +! Warning + + write(*,*) '!! ERIs in MO basis will be overwritten in qsUGF2 !!' + write(*,*) + +! Stuff + + nBasSq = nBas*nBas + +! TDA + + if(TDA) then + write(*,*) 'Tamm-Dancoff approximation activated!' + write(*,*) + end if + +! Memory allocation + + nS_aa = nS(1) + nS_bb = nS(2) + nS_sc = nS_aa + nS_bb + + allocate(eGF2(nBas,nspin),eOld(nBas,nspin),c(nBas,nBas,nspin),cp(nBas,nBas,nspin),P(nBas,nBas,nspin),F(nBas,nBas,nspin), & + Fp(nBas,nBas,nspin),J(nBas,nBas,nspin),K(nBas,nBas,nspin),SigC(nBas,nBas,nspin),SigCp(nBas,nBas,nspin), & + SigCm(nBas,nBas,nspin),Z(nBas,nspin),error(nBas,nBas,nspin),error_diis(nBasSq,max_diis,nspin), & + F_diis(nBasSq,max_diis,nspin)) + +! Initialization + + nSCF = -1 + n_diis = 0 + ispin = 1 + Conv = 1d0 + P(:,:,:) = PHF(:,:,:) + eGF2(:,:) = eHF(:,:) + c(:,:,:) = cHF(:,:,:) + F_diis(:,:,:) = 0d0 + error_diis(:,:,:) = 0d0 + rcond = 1d0 + +!------------------------------------------------------------------------ +! Main loop +!------------------------------------------------------------------------ + + do while(Conv > thresh .and. nSCF < maxSCF) + + ! Increment + + nSCF = nSCF + 1 + + ! Buid Coulomb matrix + + do is=1,nspin + call Coulomb_matrix_AO_basis(nBas,P(:,:,is),ERI_AO(:,:,:,:),J(:,:,is)) + end do + + ! Compute exchange part of the self-energy + + do is=1,nspin + call exchange_matrix_AO_basis(nBas,P(:,:,is),ERI_AO(:,:,:,:),K(:,:,is)) + end do + + !-------------------------------------------------- + ! AO to MO transformation of two-electron integrals + !-------------------------------------------------- + + ! 4-index transform for (aa|aa) block + + call AOtoMO_integral_transform(1,1,1,1,nBas,c,ERI_AO,ERI_aaaa) + + ! 4-index transform for (aa|bb) block + + call AOtoMO_integral_transform(1,1,2,2,nBas,c,ERI_AO,ERI_aabb) + + ! 4-index transform for (bb|bb) block + + call AOtoMO_integral_transform(2,2,2,2,nBas,c,ERI_AO,ERI_bbbb) + + !------------------------------------------------! + ! Compute self-energy and renormalization factor ! + !------------------------------------------------! + + call unrestricted_self_energy_GF2(nBas,nC,nO,nV,nR,eta,ERI_aaaa,ERI_aabb,ERI_bbbb,eHF,eGF2,SigC,Z) + + ! Make correlation self-energy Hermitian and transform it back to AO basis + + do is=1,nspin + SigCp(:,:,is) = 0.5d0*(SigC(:,:,is) + transpose(SigC(:,:,is))) + SigCm(:,:,is) = 0.5d0*(SigC(:,:,is) - transpose(SigC(:,:,is))) + end do + + do is=1,nspin + call MOtoAO_transform(nBas,S,c(:,:,is),SigCp(:,:,is)) + end do + + ! Solve the quasi-particle equation + + do is=1,nspin + F(:,:,is) = Hc(:,:) + J(:,:,is) + J(:,:,mod(is,2)+1) + K(:,:,is) + SigCp(:,:,is) + end do + + ! Check convergence + + do is=1,nspin + error(:,:,is) = matmul(F(:,:,is),matmul(P(:,:,is),S(:,:))) - matmul(matmul(S(:,:),P(:,:,is)),F(:,:,is)) + end do + + if(nSCF > 1) conv = maxval(abs(error(:,:,:))) + + ! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + if(minval(rcond(:)) > 1d-7) then + do is=1,nspin + if(nO(is) > 1) call DIIS_extrapolation(rcond(is),nBasSq,nBasSq,n_diis,error_diis(:,1:n_diis,is), & + F_diis(:,1:n_diis,is),error(:,:,is),F(:,:,is)) + end do + else + n_diis = 0 + end if + + ! Transform Fock matrix in orthogonal basis + + do is=1,nspin + Fp(:,:,is) = matmul(transpose(X(:,:)),matmul(F(:,:,is),X(:,:))) + end do + + ! Diagonalize Fock matrix to get eigenvectors and eigenvalues + + cp(:,:,:) = Fp(:,:,:) + do is=1,nspin + call diagonalize_matrix(nBas,cp(:,:,is),eGF2(:,is)) + end do + + ! Back-transform eigenvectors in non-orthogonal basis + + do is=1,nspin + c(:,:,is) = matmul(X(:,:),cp(:,:,is)) + end do + + ! Back-transform self-energy + + do is=1,nspin + SigCp(:,:,is) = matmul(transpose(c(:,:,is)),matmul(SigCp(:,:,is),c(:,:,is))) + end do + + ! Compute density matrix + + do is=1,nspin + P(:,:,is) = matmul(c(:,1:nO(is),is),transpose(c(:,1:nO(is),is))) + end do + + ! Save quasiparticles energy for next cycle + + Conv = maxval(abs(eGF2(:,:) - eOld(:,:))) + eOld(:,:) = eGF2(:,:) + + !------------------------------------------------------------------------ + ! Compute total energy + !------------------------------------------------------------------------ + + ! Kinetic energy + + do is=1,nspin + ET(is) = trace_matrix(nBas,matmul(P(:,:,is),T(:,:))) + end do + + ! Potential energy + + do is=1,nspin + EV(is) = trace_matrix(nBas,matmul(P(:,:,is),V(:,:))) + end do + + ! Coulomb energy + + EJ(1) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,1),J(:,:,1))) + EJ(2) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,1),J(:,:,2))) & + + 0.5d0*trace_matrix(nBas,matmul(P(:,:,2),J(:,:,1))) + EJ(3) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,2),J(:,:,2))) + + ! Exchange energy + + do is=1,nspin + Ex(is) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,is),K(:,:,is))) + end do + + ! Correlation energy + + call UMP2(nBas,nC,nO,nV,nR,ERI_aaaa,ERI_aabb,ERI_bbbb,ENuc,EqsGF2,eGF2,Ec) + + ! Total energy + + EqsGF2 = sum(ET(:)) + sum(EV(:)) + sum(EJ(:)) + sum(Ex(:)) + sum(Ec(:)) + + !------------------------------------------------------------------------ + ! Print results + !------------------------------------------------------------------------ + + call dipole_moment(nBas,P(:,:,1)+P(:,:,2),nNuc,ZNuc,rNuc,dipole_int_AO,dipole) + call print_qsUGF2(nBas,nO,nSCF,Conv,thresh,eHF,eGF2,c,P,S,T,V,J,K,ENuc,ET,EV,EJ,Ex,Ec,EqsGF2,SigCp,Z,dipole) + + enddo +!------------------------------------------------------------------------ +! End main loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + endif + +! Deallocate memory + + deallocate(cp,P,F,Fp,J,K,SigC,SigCp,SigCm,Z,error,error_diis,F_diis) + +! Perform BSE calculation + + if(BSE) then + + print*,'!!! BSE2 NYI for qsUGF2 !!!' + + end if + +end subroutine qsUGF2 diff --git a/src/GF/self_energy_GF2.f90 b/src/GF/self_energy_GF2.f90 new file mode 100644 index 0000000..f4b8e90 --- /dev/null +++ b/src/GF/self_energy_GF2.f90 @@ -0,0 +1,73 @@ +subroutine self_energy_GF2(eta,nBas,nC,nO,nV,nR,nS,eHF,eGF2,ERI,SigC,Z) + +! Compute GF2 self-energy and its renormalization factor + + implicit none + include 'parameters.h' + +! Input variables + + double precision,intent(in) :: eta + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: eGF2(nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: i,j,a,b + integer :: p,q + double precision :: eps + double precision :: num + +! Output variables + + double precision,intent(out) :: SigC(nBas,nBas) + double precision,intent(out) :: Z(nBas) + +! Initialize + + SigC(:,:) = 0d0 + Z(:) = 0d0 + +! Compute GF2 self-energy and renormalization factor + + do p=nC+1,nBas-nR + do q=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + + eps = eGF2(p) + eHF(a) - eHF(i) - eHF(j) + num = (2d0*ERI(p,a,i,j) - ERI(p,a,j,i))*ERI(q,a,i,j) + + SigC(p,q) = SigC(p,q) + num*eps/(eps**2 + eta**2) + if(p == q) Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + end do + end do + end do + end do + end do + + do p=nC+1,nBas-nR + do q=nC+1,nBas-nR + do i=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps = eGF2(p) + eHF(i) - eHF(a) - eHF(b) + num = (2d0*ERI(p,i,a,b) - ERI(p,i,b,a))*ERI(q,i,a,b) + + SigC(p,q) = SigC(p,q) + num*eps/(eps**2 + eta**2) + if(p == q) Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + end do + end do + end do + end do + end do + + Z(:) = 1d0/(1d0 - Z(:)) + +end subroutine self_energy_GF2 diff --git a/src/GF/self_energy_GF2_diag.f90 b/src/GF/self_energy_GF2_diag.f90 new file mode 100644 index 0000000..c64d507 --- /dev/null +++ b/src/GF/self_energy_GF2_diag.f90 @@ -0,0 +1,69 @@ +subroutine self_energy_GF2_diag(eta,nBas,nC,nO,nV,nR,nS,eHF,eGF2,ERI,SigC,Z) + +! Compute diagonal part of the GF2 self-energy and its renormalization factor + + implicit none + include 'parameters.h' + +! Input variables + + double precision,intent(in) :: eta + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: eGF2(nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: i,j,a,b + integer :: p + double precision :: eps + double precision :: num + +! Output variables + + double precision,intent(out) :: SigC(nBas) + double precision,intent(out) :: Z(nBas) + +! Initialize + + SigC(:) = 0d0 + Z(:) = 0d0 + +! Compute GF2 self-energy + + do p=nC+1,nBas-nR + do i=nC+1,nO + do j=nC+1,nO + do a=nO+1,nBas-nR + + eps = eGF2(p) + eHF(a) - eHF(i) - eHF(j) + num = (2d0*ERI(p,a,i,j) - ERI(p,a,j,i))*ERI(p,a,i,j) + + SigC(p) = SigC(p) + num*eps/(eps**2 + eta**2) + Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + end do + end do + end do + end do + + do p=nC+1,nBas-nR + do i=nC+1,nO + do a=nO+1,nBas-nR + do b=nO+1,nBas-nR + + eps = eGF2(p) + eHF(i) - eHF(a) - eHF(b) + num = (2d0*ERI(p,i,a,b) - ERI(p,i,b,a))*ERI(p,i,a,b) + + SigC(p) = SigC(p) + num*eps/(eps**2 + eta**2) + Z(p) = Z(p) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + end do + end do + end do + end do + + Z(:) = 1d0/(1d0 - Z(:)) + +end subroutine self_energy_GF2_diag diff --git a/src/GF/unrestricted_self_energy_GF2.f90 b/src/GF/unrestricted_self_energy_GF2.f90 new file mode 100644 index 0000000..cce6adf --- /dev/null +++ b/src/GF/unrestricted_self_energy_GF2.f90 @@ -0,0 +1,195 @@ +subroutine unrestricted_self_energy_GF2(nBas,nC,nO,nV,nR,eta,ERI_aa,ERI_ab,ERI_bb,eHF,eGF2,SigC,Z) + +! Perform unrestricted GF2 self-energy and its renormalization factor + + implicit none + include 'parameters.h' + + +! Input variables + + integer,intent(in) :: nBas + integer,intent(in) :: nC(nspin) + integer,intent(in) :: nO(nspin) + integer,intent(in) :: nV(nspin) + integer,intent(in) :: nR(nspin) + double precision,intent(in) :: eta + double precision,intent(in) :: ERI_aa(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_ab(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_bb(nBas,nBas,nBas,nBas) + double precision,intent(in) :: eHF(nBas,nspin) + double precision,intent(in) :: eGF2(nBas,nspin) + +! Local variables + + integer :: p,q + integer :: i,j,a,b + double precision :: eps,num + +! Output variables + + double precision,intent(out) :: SigC(nBas,nBas,nspin) + double precision,intent(out) :: Z(nBas,nspin) + +!---------------------! +! Compute self-energy | +!---------------------! + + SigC(:,:,:) = 0d0 + Z(:,:) = 0d0 + + !----------------! + ! Spin-up sector + !----------------! + + do p=nC(1)+1,nBas-nR(1) + do q=nC(1)+1,nBas-nR(1) + + ! Addition part: aa + + do i=nC(1)+1,nO(1) + do a=nO(1)+1,nBas-nR(1) + do b=nO(1)+1,nBas-nR(1) + + eps = eGF2(p,1) + eHF(i,1) - eHF(a,1) - eHF(b,1) + num = ERI_aa(i,q,a,b)*ERI_aa(a,b,i,p) & + - ERI_aa(i,q,a,b)*ERI_aa(a,b,p,i) + + SigC(p,q,1) = SigC(p,q,1) + num*eps/(eps**2 + eta**2) + if(p == q) Z(p,1) = Z(p,1) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + ! Addition part: ab + + do i=nC(2)+1,nO(2) + do a=nO(2)+1,nBas-nR(2) + do b=nO(1)+1,nBas-nR(1) + + eps = eGF2(p,1) + eHF(i,2) - eHF(a,2) - eHF(b,1) + num = ERI_ab(q,i,b,a)*ERI_ab(b,a,p,i) + + SigC(p,q,1) = SigC(p,q,1) + num*eps/(eps**2 + eta**2) + if(p == q) Z(p,1) = Z(p,1) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + ! Removal part: aa + + do i=nC(1)+1,nO(1) + do a=nO(1)+1,nBas-nR(1) + do j=nC(1)+1,nO(1) + + eps = eGF2(p,1) + eHF(a,1) - eHF(i,1) - eHF(j,1) + num = ERI_aa(a,q,i,j)*ERI_aa(i,j,a,p) & + - ERI_aa(a,q,i,j)*ERI_aa(i,j,p,a) + + SigC(p,q,1) = SigC(p,q,1) + num*eps/(eps**2 + eta**2) + if(p == q) Z(p,1) = Z(p,1) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + ! Removal part: ab + + do i=nC(2)+1,nO(2) + do a=nO(2)+1,nBas-nR(2) + do j=nC(1)+1,nO(1) + + eps = eGF2(p,1) + eHF(a,2) - eHF(i,2) - eHF(j,1) + num = ERI_ab(q,a,j,i)*ERI_ab(j,i,p,a) + + SigC(p,q,1) = SigC(p,q,1) + num*eps/(eps**2 + eta**2) + if(p == q) Z(p,1) = Z(p,1) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + enddo + enddo + + !------------------! + ! Spin-down sector ! + !------------------! + + do p=nC(2)+1,nBas-nR(2) + do q=nC(2)+1,nBas-nR(2) + + ! Addition part: bb + + do i=nC(2)+1,nO(2) + do a=nO(2)+1,nBas-nR(2) + do b=nO(2)+1,nBas-nR(2) + + eps = eGF2(p,2) + eHF(i,2) - eHF(a,2) - eHF(b,2) + num = ERI_bb(i,q,a,b)*ERI_bb(a,b,i,p) & + - ERI_bb(i,q,a,b)*ERI_bb(a,b,p,i) + + SigC(p,q,2) = SigC(p,q,2) + num*eps/(eps**2 + eta**2) + if(p == q) Z(p,2) = Z(p,2) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + ! Addition part: ab + + do i=nC(1)+1,nO(1) + do a=nO(1)+1,nBas-nR(1) + do b=nO(2)+1,nBas-nR(2) + + eps = eGF2(p,2) + eHF(i,1) - eHF(a,1) - eHF(b,2) + num = ERI_ab(i,q,a,b)*ERI_ab(a,b,i,p) + + SigC(p,q,2) = SigC(p,q,2) + num*eps/(eps**2 + eta**2) + if(p == q) Z(p,2) = Z(p,2) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + ! Removal part: bb + + do i=nC(2)+1,nO(2) + do a=nO(2)+1,nBas-nR(2) + do j=nC(2)+1,nO(2) + + eps = eGF2(p,2) + eHF(a,2) - eHF(i,2) - eHF(j,2) + num = ERI_bb(a,q,i,j)*ERI_bb(i,j,a,p) & + - ERI_bb(a,q,i,j)*ERI_bb(i,j,p,a) + + SigC(p,q,2) = SigC(p,q,2) + num*eps/(eps**2 + eta**2) + if(p == q) Z(p,2) = Z(p,2) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + ! Removal part: ab + + do i=nC(1)+1,nO(1) + do a=nO(1)+1,nBas-nR(1) + do j=nC(2)+1,nO(2) + + eps = eGF2(p,2) + eHF(a,1) - eHF(i,1) - eHF(j,2) + num = ERI_ab(a,q,i,j)*ERI_ab(i,j,a,p) + + SigC(p,q,2) = SigC(p,q,2) + num*eps/(eps**2 + eta**2) + if(p == q) Z(p,2) = Z(p,2) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + enddo + enddo + + Z(:,:) = 1d0/(1d0 - Z(:,:)) + +end subroutine unrestricted_self_energy_GF2 diff --git a/src/GF/unrestricted_self_energy_GF2_diag.f90 b/src/GF/unrestricted_self_energy_GF2_diag.f90 new file mode 100644 index 0000000..6f06010 --- /dev/null +++ b/src/GF/unrestricted_self_energy_GF2_diag.f90 @@ -0,0 +1,190 @@ +subroutine unrestricted_self_energy_GF2_diag(nBas,nC,nO,nV,nR,eta,ERI_aa,ERI_ab,ERI_bb,eHF,eGF2,SigC,Z) + +! Perform unrestricted GF2 self-energy and its renormalization factor + + implicit none + include 'parameters.h' + + +! Input variables + + integer,intent(in) :: nBas + integer,intent(in) :: nC(nspin) + integer,intent(in) :: nO(nspin) + integer,intent(in) :: nV(nspin) + integer,intent(in) :: nR(nspin) + double precision,intent(in) :: eta + double precision,intent(in) :: ERI_aa(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_ab(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_bb(nBas,nBas,nBas,nBas) + double precision,intent(in) :: eHF(nBas,nspin) + double precision,intent(in) :: eGF2(nBas,nspin) + +! Local variables + + integer :: p + integer :: i,j,a,b + double precision :: eps,num + +! Output variables + + double precision,intent(out) :: SigC(nBas,nspin) + double precision,intent(out) :: Z(nBas,nspin) + +!---------------------! +! Compute self-energy | +!---------------------! + + SigC(:,:) = 0d0 + + !----------------! + ! Spin-up sector + !----------------! + + do p=nC(1)+1,nBas-nR(1) + + ! Addition part: aa + + do i=nC(1)+1,nO(1) + do a=nO(1)+1,nBas-nR(1) + do b=nO(1)+1,nBas-nR(1) + + eps = eGF2(p,1) + eHF(i,1) - eHF(a,1) - eHF(b,1) + num = ERI_aa(i,p,a,b)*ERI_aa(a,b,i,p) & + - ERI_aa(i,p,a,b)*ERI_aa(a,b,p,i) + + SigC(p,1) = SigC(p,1) + num*eps/(eps**2 + eta**2) + Z(p,1) = Z(p,1) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + ! Addition part: ab + + do i=nC(2)+1,nO(2) + do a=nO(2)+1,nBas-nR(2) + do b=nO(1)+1,nBas-nR(1) + + eps = eGF2(p,1) + eHF(i,2) - eHF(a,2) - eHF(b,1) + num = ERI_ab(p,i,b,a)*ERI_ab(b,a,p,i) + + SigC(p,1) = SigC(p,1) + num*eps/(eps**2 + eta**2) + Z(p,1) = Z(p,1) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + ! Removal part: aa + + do i=nC(1)+1,nO(1) + do a=nO(1)+1,nBas-nR(1) + do j=nC(1)+1,nO(1) + + eps = eGF2(p,1) + eHF(a,1) - eHF(i,1) - eHF(j,1) + num = ERI_aa(a,p,i,j)*ERI_aa(i,j,a,p) & + - ERI_aa(a,p,i,j)*ERI_aa(i,j,p,a) + + SigC(p,1) = SigC(p,1) + num*eps/(eps**2 + eta**2) + Z(p,1) = Z(p,1) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + ! Removal part: ab + + do i=nC(2)+1,nO(2) + do a=nO(2)+1,nBas-nR(2) + do j=nC(1)+1,nO(1) + + eps = eGF2(p,1) + eHF(a,2) - eHF(i,2) - eHF(j,1) + num = ERI_ab(p,a,j,i)*ERI_ab(j,i,p,a) + + SigC(p,1) = SigC(p,1) + num*eps/(eps**2 + eta**2) + Z(p,1) = Z(p,1) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + enddo + + !------------------! + ! Spin-down sector ! + !------------------! + + do p=nC(2)+1,nBas-nR(2) + + ! Addition part: bb + + do i=nC(2)+1,nO(2) + do a=nO(2)+1,nBas-nR(2) + do b=nO(2)+1,nBas-nR(2) + + eps = eGF2(p,2) + eHF(i,2) - eHF(a,2) - eHF(b,2) + num = ERI_bb(i,p,a,b)*ERI_bb(a,b,i,p) & + - ERI_bb(i,p,a,b)*ERI_bb(a,b,p,i) + + SigC(p,2) = SigC(p,2) + num*eps/(eps**2 + eta**2) + Z(p,2) = Z(p,2) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + ! Addition part: ab + + do i=nC(1)+1,nO(1) + do a=nO(1)+1,nBas-nR(1) + do b=nO(2)+1,nBas-nR(2) + + eps = eGF2(p,2) + eHF(i,1) - eHF(a,1) - eHF(b,2) + num = ERI_ab(i,p,a,b)*ERI_ab(a,b,i,p) + + SigC(p,2) = SigC(p,2) + num*eps/(eps**2 + eta**2) + Z(p,2) = Z(p,2) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + ! Removal part: bb + + do i=nC(2)+1,nO(2) + do a=nO(2)+1,nBas-nR(2) + do j=nC(2)+1,nO(2) + + eps = eGF2(p,2) + eHF(a,2) - eHF(i,2) - eHF(j,2) + num = ERI_bb(a,p,i,j)*ERI_bb(i,j,a,p) & + - ERI_bb(a,p,i,j)*ERI_bb(i,j,p,a) + + SigC(p,2) = SigC(p,2) + num*eps/(eps**2 + eta**2) + Z(p,2) = Z(p,2) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + ! Removal part: ab + + do i=nC(1)+1,nO(1) + do a=nO(1)+1,nBas-nR(1) + do j=nC(2)+1,nO(2) + + eps = eGF2(p,2) + eHF(a,1) - eHF(i,1) - eHF(j,2) + num = ERI_ab(a,p,i,j)*ERI_ab(i,j,a,p) + + SigC(p,2) = SigC(p,2) + num*eps/(eps**2 + eta**2) + Z(p,2) = Z(p,2) - num*(eps**2 - eta**2)/(eps**2 + eta**2)**2 + + enddo + enddo + enddo + + enddo + + Z(:,:) = 1d0/(1d0 - Z(:,:)) + +end subroutine unrestricted_self_energy_GF2_diag diff --git a/src/HF/RHF.f90 b/src/HF/RHF.f90 index a907154..05499a5 100644 --- a/src/HF/RHF.f90 +++ b/src/HF/RHF.f90 @@ -1,4 +1,4 @@ -subroutine RHF(maxSCF,thresh,max_diis,guess_type,nNuc,ZNuc,rNuc,ENuc,nBas,nO,S,T,V,Hc,ERI,dipole_int,X,ERHF,e,c,P) +subroutine RHF(maxSCF,thresh,max_diis,guess_type,nNuc,ZNuc,rNuc,ENuc,nBas,nO,S,T,V,Hc,ERI,dipole_int,X,ERHF,e,c,P,Vx) ! Perform restricted Hartree-Fock calculation @@ -55,6 +55,7 @@ subroutine RHF(maxSCF,thresh,max_diis,guess_type,nNuc,ZNuc,rNuc,ENuc,nBas,nO,S,T double precision,intent(out) :: e(nBas) double precision,intent(out) :: c(nBas,nBas) double precision,intent(out) :: P(nBas,nBas) + double precision,intent(out) :: Vx(nBas) ! Hello world @@ -126,11 +127,11 @@ subroutine RHF(maxSCF,thresh,max_diis,guess_type,nNuc,ZNuc,rNuc,ENuc,nBas,nO,S,T ! DIIS extrapolation n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) - -! Reset DIIS if required - - if(abs(rcond) < 1d-15) n_diis = 0 + if(abs(rcond) > 1d-7) then + call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + else + n_diis = 0 + end if ! Diagonalize Fock matrix @@ -196,7 +197,13 @@ subroutine RHF(maxSCF,thresh,max_diis,guess_type,nNuc,ZNuc,rNuc,ENuc,nBas,nO,S,T EK = 0.25d0*trace_matrix(nBas,matmul(P,K)) ERHF = ET + EV + EJ + EK +! Compute dipole moments + call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int,dipole) call print_RHF(nBas,nO,e,C,ENuc,ET,EV,EJ,EK,ERHF,dipole) +! Compute Vx for post-HF calculations + + call exchange_potential(nBas,c,K,Vx) + end subroutine RHF diff --git a/src/HF/RHF_stability.f90 b/src/HF/RHF_stability.f90 new file mode 100644 index 0000000..bade757 --- /dev/null +++ b/src/HF/RHF_stability.f90 @@ -0,0 +1,147 @@ +subroutine RHF_stability(nBas,nC,nO,nV,nR,nS,eHF,ERI) + +! Perform a stability analysis of the RHF solution + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + integer,intent(in) :: nC + integer,intent(in) :: nO + integer,intent(in) :: nV + integer,intent(in) :: nR + integer,intent(in) :: nS + + double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + integer,parameter :: maxS = 20 + integer :: ia + integer :: ispin + + double precision,allocatable :: A(:,:) + double precision,allocatable :: B(:,:) + double precision,allocatable :: AB(:,:) + double precision,allocatable :: Om(:) + +! Memory allocation + + allocate(A(nS,nS),B(nS,nS),AB(nS,nS),Om(nS)) + +!-------------------------------------------------------------! +! Stability analysis: Real RHF -> Real RHF +!-------------------------------------------------------------! + + ispin = 1 + + call linear_response_A_matrix(ispin,.false.,nBas,nC,nO,nV,nR,nS,1d0,eHF,ERI,A) + call linear_response_B_matrix(ispin,.false.,nBas,nC,nO,nV,nR,nS,1d0,ERI,B) + + AB(:,:) = A(:,:) + B(:,:) + + call diagonalize_matrix(nS,AB,Om) + + write(*,*)'-------------------------------------------------------------' + write(*,*)'| Stability analysis: Real RHF -> Real RHF |' + write(*,*)'-------------------------------------------------------------' + write(*,'(1X,A1,1X,A5,1X,A1,1X,A23,1X,A1,1X,A23,1X,A1,1X)') & + '|','State','|',' Excitation energy (au) ','|',' Excitation energy (eV) ','|' + write(*,*)'-------------------------------------------------------------' + do ia=1,min(nS,maxS) + write(*,'(1X,A1,1X,I5,1X,A1,1X,F23.6,1X,A1,1X,F23.6,1X,A1,1X)') & + '|',ia,'|',Om(ia),'|',Om(ia)*HaToeV,'|' + enddo + write(*,*)'-------------------------------------------------------------' + + if(minval(Om(:)) < 0d0) then + + write(*,'(1X,A40,1X)') 'Too bad, RHF solution is unstable!' + write(*,'(1X,A40,1X,F15.10,A3)') 'Largest negative eigenvalue: ',Om(1),' au' + + else + + write(*,'(1X,A40,1X)') 'Well done, RHF solution is stable!' + write(*,'(1X,A40,1X,F15.10,A3)') 'Smallest eigenvalue: ',Om(1),' au' + + end if + write(*,*)'-------------------------------------------------------------' + write(*,*) + +!-------------------------------------------------------------! +! Stability analysis: Real RHF -> Complex RHF +!-------------------------------------------------------------! + + AB(:,:) = A(:,:) - B(:,:) + + call diagonalize_matrix(nS,AB,Om) + + write(*,*)'-------------------------------------------------------------' + write(*,*)'| Stability analysis: Real RHF -> Complex RHF |' + write(*,*)'-------------------------------------------------------------' + write(*,'(1X,A1,1X,A5,1X,A1,1X,A23,1X,A1,1X,A23,1X,A1,1X)') & + '|','State','|',' Excitation energy (au) ','|',' Excitation energy (eV) ','|' + write(*,*)'-------------------------------------------------------------' + do ia=1,min(nS,maxS) + write(*,'(1X,A1,1X,I5,1X,A1,1X,F23.6,1X,A1,1X,F23.6,1X,A1,1X)') & + '|',ia,'|',Om(ia),'|',Om(ia)*HaToeV,'|' + enddo + write(*,*)'-------------------------------------------------------------' + + if(minval(Om(:)) < 0d0) then + + write(*,'(1X,A40,1X)') 'Too bad, RHF solution is unstable!' + write(*,'(1X,A40,1X,F15.10,A3)') 'Largest negative eigenvalue: ',Om(1),' au' + + else + + write(*,'(1X,A40,1X)') 'Well done, RHF solution is stable!' + write(*,'(1X,A40,1X,F15.10,A3)') 'Smallest eigenvalue: ',Om(1),' au' + + end if + write(*,*)'-------------------------------------------------------------' + write(*,*) + +!-------------------------------------------------------------! +! Stability analysis: Real RHF -> Real UHF +!-------------------------------------------------------------! + + ispin = 2 + + call linear_response_A_matrix(ispin,.false.,nBas,nC,nO,nV,nR,nS,1d0,eHF,ERI,A) + call linear_response_B_matrix(ispin,.false.,nBas,nC,nO,nV,nR,nS,1d0,ERI,B) + + AB(:,:) = A(:,:) + B(:,:) + + call diagonalize_matrix(nS,AB,Om) + + write(*,*)'-------------------------------------------------------------' + write(*,*)'| Stability analysis: Real RHF -> Real UHF |' + write(*,*)'-------------------------------------------------------------' + write(*,'(1X,A1,1X,A5,1X,A1,1X,A23,1X,A1,1X,A23,1X,A1,1X)') & + '|','State','|',' Excitation energy (au) ','|',' Excitation energy (eV) ','|' + write(*,*)'-------------------------------------------------------------' + do ia=1,min(nS,maxS) + write(*,'(1X,A1,1X,I5,1X,A1,1X,F23.6,1X,A1,1X,F23.6,1X,A1,1X)') & + '|',ia,'|',Om(ia),'|',Om(ia)*HaToeV,'|' + enddo + write(*,*)'-------------------------------------------------------------' + + if(minval(Om(:)) < 0d0) then + + write(*,'(1X,A40,1X)') 'Too bad, RHF solution is unstable!' + write(*,'(1X,A40,1X,F15.10,A3)') 'Largest negative eigenvalue: ',Om(1),' au' + + else + + write(*,'(1X,A40,1X)') 'Well done, RHF solution is stable!' + write(*,'(1X,A40,1X,F15.10,A3)') 'Smallest eigenvalue: ',Om(1),' au' + + end if + write(*,*)'-------------------------------------------------------------' + write(*,*) + +end subroutine RHF_stability diff --git a/src/HF/RMOM.f90 b/src/HF/RMOM.f90 new file mode 100644 index 0000000..c086b36 --- /dev/null +++ b/src/HF/RMOM.f90 @@ -0,0 +1,209 @@ +subroutine RMOM(maxSCF,thresh,max_diis,guess_type,nNuc,ZNuc,rNuc,ENuc,nBas,nO,S,T,V,Hc,ERI,dipole_int,X,ERHF,e,c,P,Vx) + +! Perform restricted Hartree-Fock calculation with MOM algorithm + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: maxSCF,max_diis,guess_type + double precision,intent(in) :: thresh + + integer,intent(in) :: nBas + integer,intent(in) :: nO + integer,intent(in) :: nNuc + double precision,intent(in) :: ZNuc(nNuc) + double precision,intent(in) :: rNuc(nNuc,ncart) + double precision,intent(in) :: ENuc + double precision,intent(in) :: S(nBas,nBas) + double precision,intent(in) :: T(nBas,nBas) + double precision,intent(in) :: V(nBas,nBas) + double precision,intent(in) :: Hc(nBas,nBas) + double precision,intent(in) :: X(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: dipole_int(nBas,nBas,ncart) + +! Local variables + + integer :: nSCF + integer :: nBasSq + integer :: n_diis + double precision :: ET + double precision :: EV + double precision :: EJ + double precision :: EK + double precision :: dipole(ncart) + + double precision :: Conv + double precision :: Gap + double precision :: rcond + double precision,external :: trace_matrix + double precision,allocatable :: error(:,:) + double precision,allocatable :: error_diis(:,:) + double precision,allocatable :: F_diis(:,:) + double precision,allocatable :: J(:,:) + double precision,allocatable :: K(:,:) + double precision,allocatable :: cp(:,:) + double precision,allocatable :: F(:,:) + double precision,allocatable :: Fp(:,:) + double precision,allocatable :: ON(:) + +! Output variables + + double precision,intent(out) :: ERHF + double precision,intent(out) :: e(nBas) + double precision,intent(out) :: c(nBas,nBas) + double precision,intent(out) :: P(nBas,nBas) + double precision,intent(out) :: Vx(nBas) + +! Hello world + + write(*,*) + write(*,*)'*********************************************' + write(*,*)'| Restricted Maximum Overlap Method |' + write(*,*)'*********************************************' + write(*,*) + +! Useful quantities + + nBasSq = nBas*nBas + +! Memory allocation + + allocate(J(nBas,nBas),K(nBas,nBas),error(nBas,nBas), & + cp(nBas,nBas),Fp(nBas,nBas),F(nBas,nBas),ON(nBas), & + error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) + +! Guess coefficients and eigenvalues + + call mo_guess(nBas,nO,guess_type,S,Hc,ERI,J,K,X,cp,F,Fp,e,c,P) + +! ON(:) = 0d0 +! do i=1,nO +! ON(i) = 1d0 +! ON(i) = dble(2*i-1) +! end do + +! call density_matrix(nBas,ON,c,P) + +! Initialization + + n_diis = 0 + F_diis(:,:) = 0d0 + error_diis(:,:) = 0d0 + Conv = 1d0 + nSCF = 0 + +!------------------------------------------------------------------------ +! Main SCF loop +!------------------------------------------------------------------------ + write(*,*) + write(*,*)'----------------------------------------------------' + write(*,*)'| RHF calculation |' + write(*,*)'----------------------------------------------------' + write(*,'(1X,A1,1X,A3,1X,A1,1X,A16,1X,A1,1X,A10,1X,A1,1X,A10,1X,A1,1X)') & + '|','#','|','HF energy','|','Conv','|','HL Gap','|' + write(*,*)'----------------------------------------------------' + + do while(Conv > thresh .and. nSCF < maxSCF) + +! Increment + + nSCF = nSCF + 1 + +! Build Fock matrix + + call Coulomb_matrix_AO_basis(nBas,P,ERI,J) + call exchange_matrix_AO_basis(nBas,P,ERI,K) + + F(:,:) = Hc(:,:) + J(:,:) + 0.5d0*K(:,:) + +! Check convergence + + error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) + Conv = maxval(abs(error)) + +! DIIS extrapolation + + n_diis = min(n_diis+1,max_diis) + if(abs(rcond) > 1d-7) then + call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + else + n_diis = 0 + end if + +! Diagonalize Fock matrix + + Fp = matmul(transpose(X),matmul(F,X)) + cp(:,:) = Fp(:,:) + call diagonalize_matrix(nBas,cp,e) + c = matmul(X,cp) + +! Density matrix + + P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + +! call density_matrix(nBas,ON,c,P) + +! Compute HF energy + + ERHF = trace_matrix(nBas,matmul(P,Hc)) & + + 0.5d0*trace_matrix(nBas,matmul(P,J)) & + + 0.25d0*trace_matrix(nBas,matmul(P,K)) + +! Compute HOMO-LUMO gap + + if(nBas > nO) then + + Gap = e(nO+1) - e(nO) + + else + + Gap = 0d0 + + endif + +! Dump results + + write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & + '|',nSCF,'|',ERHF+ENuc,'|',Conv,'|',Gap,'|' + + enddo + write(*,*)'----------------------------------------------------' +!------------------------------------------------------------------------ +! End of SCF loop +!------------------------------------------------------------------------ + +! Did it actually converge? + + if(nSCF == maxSCF) then + + write(*,*) + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*)' Convergence failed ' + write(*,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' + write(*,*) + + stop + + endif + +! Compute HF energy + + ET = trace_matrix(nBas,matmul(P,T)) + EV = trace_matrix(nBas,matmul(P,V)) + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + EK = 0.25d0*trace_matrix(nBas,matmul(P,K)) + ERHF = ET + EV + EJ + EK + +! Compute dipole moments + + call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int,dipole) + call print_RHF(nBas,nO,e,C,ENuc,ET,EV,EJ,EK,ERHF,dipole) + +! Compute Vx for post-HF calculations + + call exchange_potential(nBas,c,K,Vx) + +end subroutine RMOM diff --git a/src/HF/UHF.f90 b/src/HF/UHF.f90 index 4123dd5..9443924 100644 --- a/src/HF/UHF.f90 +++ b/src/HF/UHF.f90 @@ -1,4 +1,4 @@ -subroutine UHF(maxSCF,thresh,max_diis,guess_type,mix,nNuc,ZNuc,rNuc,ENuc,nBas,nO,S,T,V,Hc,ERI,dipole_int,X,EUHF,e,c,P) +subroutine UHF(maxSCF,thresh,max_diis,guess_type,mix,nNuc,ZNuc,rNuc,ENuc,nBas,nO,S,T,V,Hc,ERI,dipole_int,X,EUHF,e,c,P,Vx) ! Perform unrestricted Hartree-Fock calculation @@ -59,6 +59,7 @@ subroutine UHF(maxSCF,thresh,max_diis,guess_type,mix,nNuc,ZNuc,rNuc,ENuc,nBas,nO double precision,intent(out) :: e(nBas,nspin) double precision,intent(out) :: c(nBas,nBas,nspin) double precision,intent(out) :: P(nBas,nBas,nspin) + double precision,intent(out) :: Vx(nBas,nspin) ! Hello world @@ -178,14 +179,14 @@ subroutine UHF(maxSCF,thresh,max_diis,guess_type,mix,nNuc,ZNuc,rNuc,ENuc,nBas,nO ! DIIS extrapolation n_diis = min(n_diis+1,max_diis) - do ispin=1,nspin - if(nO(ispin) > 1) call DIIS_extrapolation(rcond(ispin),nBasSq,nBasSq,n_diis,err_diis(:,1:n_diis,ispin), & + if(minval(rcond(:)) > 1d-7) then + do ispin=1,nspin + if(nO(ispin) > 1) call DIIS_extrapolation(rcond(ispin),nBasSq,nBasSq,n_diis,err_diis(:,1:n_diis,ispin), & F_diis(:,1:n_diis,ispin),err(:,:,ispin),F(:,:,ispin)) - end do - -! Reset DIIS if required - - if(minval(rcond(:)) < 1d-15) n_diis = 0 + end do + else + n_diis = 0 + end if !------------------------------------------------------------------------ ! Compute UHF energy @@ -249,4 +250,10 @@ subroutine UHF(maxSCF,thresh,max_diis,guess_type,mix,nNuc,ZNuc,rNuc,ENuc,nBas,nO call dipole_moment(nBas,P(:,:,1)+P(:,:,2),nNuc,ZNuc,rNuc,dipole_int,dipole) call print_UHF(nBas,nO,S,e,c,ENuc,ET,EV,EJ,Ex,EUHF,dipole) +! Compute Vx for post-HF calculations + + do ispin=1,nspin + call exchange_potential(nBas,c(:,:,ispin),K(:,:,ispin),Vx(:,ispin)) + end do + end subroutine UHF diff --git a/src/HF/UHF_stability.f90 b/src/HF/UHF_stability.f90 new file mode 100644 index 0000000..db77387 --- /dev/null +++ b/src/HF/UHF_stability.f90 @@ -0,0 +1,174 @@ +subroutine UHF_stability(nBas,nC,nO,nV,nR,nS,eHF,ERI_aaaa,ERI_aabb,ERI_bbbb) + +! Perform a stability analysis of the UHF solution + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + integer,intent(in) :: nC(nspin) + integer,intent(in) :: nO(nspin) + integer,intent(in) :: nV(nspin) + integer,intent(in) :: nR(nspin) + integer,intent(in) :: nS(nspin) + + double precision,intent(in) :: eHF(nBas,nspin) + double precision,intent(in) :: ERI_aaaa(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_aabb(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_bbbb(nBas,nBas,nBas,nBas) + +! Local variables + + integer,parameter :: maxS = 20 + integer :: ia + integer :: ispin + + integer :: nS_aa,nS_bb,nS_sc + double precision,allocatable :: Om_sc(:) + double precision,allocatable :: A_sc(:,:) + double precision,allocatable :: B_sc(:,:) + double precision,allocatable :: AB_sc(:,:) + + integer :: nS_ab,nS_ba,nS_sf + double precision,allocatable :: Om_sf(:) + double precision,allocatable :: A_sf(:,:) + double precision,allocatable :: B_sf(:,:) + double precision,allocatable :: AB_sf(:,:) + +! Menory allocation + + nS_aa = nS(1) + nS_bb = nS(2) + nS_sc = nS_aa + nS_bb + + allocate(Om_sc(nS_sc),A_sc(nS_sc,nS_sc),B_sc(nS_sc,nS_sc),AB_sc(nS_sc,nS_sc)) + +!-------------------------------------------------------------! +! Stability analysis: Real UHF -> Real UHF +!-------------------------------------------------------------! + + ispin = 1 + + call unrestricted_linear_response_A_matrix(ispin,.false.,nBas,nC,nO,nV,nR,nS_aa,nS_bb,nS_sc,1d0,eHF, & + ERI_aaaa,ERI_aabb,ERI_bbbb,A_sc) + call unrestricted_linear_response_B_matrix(ispin,.false.,nBas,nC,nO,nV,nR,nS_aa,nS_bb,nS_sc,1d0, & + ERI_aaaa,ERI_aabb,ERI_bbbb,B_sc) + + AB_sc(:,:) = A_sc(:,:) + B_sc(:,:) + + call diagonalize_matrix(nS_sc,AB_sc,Om_sc) + + write(*,*)'-------------------------------------------------------------' + write(*,*)'| Stability analysis: Real UHF -> Real UHF |' + write(*,*)'-------------------------------------------------------------' + write(*,'(1X,A1,1X,A5,1X,A1,1X,A23,1X,A1,1X,A23,1X,A1,1X)') & + '|','State','|',' Excitation energy (au) ','|',' Excitation energy (eV) ','|' + write(*,*)'-------------------------------------------------------------' + do ia=1,min(nS_sc,maxS) + write(*,'(1X,A1,1X,I5,1X,A1,1X,F23.6,1X,A1,1X,F23.6,1X,A1,1X)') & + '|',ia,'|',Om_sc(ia),'|',Om_sc(ia)*HaToeV,'|' + enddo + write(*,*)'-------------------------------------------------------------' + + if(minval(Om_sc(:)) < 0d0) then + + write(*,'(1X,A40,1X)') 'Too bad, UHF solution is unstable!' + write(*,'(1X,A40,1X,F15.10,A3)') 'Largest negative eigenvalue: ',Om_sc(1),' au' + + else + + write(*,'(1X,A40,1X)') 'Well done, UHF solution is stable!' + write(*,'(1X,A40,1X,F15.10,A3)') 'Smallest eigenvalue: ',Om_sc(1),' au' + + end if + write(*,*)'-------------------------------------------------------------' + write(*,*) + +!-------------------------------------------------------------! +! Stability analysis: Real UHF -> Complex UHF +!-------------------------------------------------------------! + + AB_sc(:,:) = A_sc(:,:) - B_sc(:,:) + + call diagonalize_matrix(nS_sc,AB_sc,Om_sc) + + write(*,*)'-------------------------------------------------------------' + write(*,*)'| Stability analysis: Real UHF -> Complex UHF |' + write(*,*)'-------------------------------------------------------------' + write(*,'(1X,A1,1X,A5,1X,A1,1X,A23,1X,A1,1X,A23,1X,A1,1X)') & + '|','State','|',' Excitation energy (au) ','|',' Excitation energy (eV) ','|' + write(*,*)'-------------------------------------------------------------' + do ia=1,min(nS_sc,maxS) + write(*,'(1X,A1,1X,I5,1X,A1,1X,F23.6,1X,A1,1X,F23.6,1X,A1,1X)') & + '|',ia,'|',Om_sc(ia),'|',Om_sc(ia)*HaToeV,'|' + enddo + write(*,*)'-------------------------------------------------------------' + + if(minval(Om_sc(:)) < 0d0) then + + write(*,'(1X,A40,1X)') 'Too bad, UHF solution is unstable!' + write(*,'(1X,A40,1X,F15.10,A3)') 'Largest negative eigenvalue: ',Om_sc(1),' au' + + else + + write(*,'(1X,A40,1X)') 'Well done, UHF solution is stable!' + write(*,'(1X,A40,1X,F15.10,A3)') 'Smallest eigenvalue: ',Om_sc(1),' au' + + end if + write(*,*)'-------------------------------------------------------------' + write(*,*) + +! Menory (de)allocation + + + nS_ab = (nO(1) - nC(1))*(nV(2) - nR(2)) + nS_ba = (nO(2) - nC(2))*(nV(1) - nR(1)) + nS_sf = nS_ab + nS_ba + + deallocate(Om_sc,A_sc,B_sc,AB_sc) + allocate(Om_sf(nS_sf),A_sf(nS_sf,nS_sf),B_sf(nS_sf,nS_sf),AB_sf(nS_sf,nS_sf)) + +!-------------------------------------------------------------! +! Stability analysis: Real UHF -> Real GHF +!-------------------------------------------------------------! + + ispin = 2 + + call unrestricted_linear_response_A_matrix(ispin,.false.,nBas,nC,nO,nV,nR,nS_ab,nS_ba,nS_sf,1d0,eHF, & + ERI_aaaa,ERI_aabb,ERI_bbbb,A_sf) + call unrestricted_linear_response_B_matrix(ispin,.false.,nBas,nC,nO,nV,nR,nS_ab,nS_ba,nS_sf,1d0, & + ERI_aaaa,ERI_aabb,ERI_bbbb,B_sf) + + AB_sf(:,:) = A_sf(:,:) + B_sf(:,:) + + call diagonalize_matrix(nS_sf,AB_sf,Om_sf) + + write(*,*)'-------------------------------------------------------------' + write(*,*)'| Stability analysis: Real UHF -> Real GHF |' + write(*,*)'-------------------------------------------------------------' + write(*,'(1X,A1,1X,A5,1X,A1,1X,A23,1X,A1,1X,A23,1X,A1,1X)') & + '|','State','|',' Excitation energy (au) ','|',' Excitation energy (eV) ','|' + write(*,*)'-------------------------------------------------------------' + do ia=1,min(nS_sf,maxS) + write(*,'(1X,A1,1X,I5,1X,A1,1X,F23.6,1X,A1,1X,F23.6,1X,A1,1X)') & + '|',ia,'|',Om_sf(ia),'|',Om_sf(ia)*HaToeV,'|' + enddo + write(*,*)'-------------------------------------------------------------' + + if(minval(Om_sf(:)) < 0d0) then + + write(*,'(1X,A40,1X)') 'Too bad, UHF solution is unstable!' + write(*,'(1X,A40,1X,F15.10,A3)') 'Largest negative eigenvalue: ',Om_sf(1),' au' + + else + + write(*,'(1X,A40,1X)') 'Well done, UHF solution is stable!' + write(*,'(1X,A40,1X,F15.10,A3)') 'Smallest eigenvalue: ',Om_sf(1),' au' + + end if + write(*,*)'-------------------------------------------------------------' + write(*,*) + +end subroutine UHF_stability diff --git a/src/HF/exchange_potential.f90 b/src/HF/exchange_potential.f90 new file mode 100644 index 0000000..9f72ce7 --- /dev/null +++ b/src/HF/exchange_potential.f90 @@ -0,0 +1,34 @@ +subroutine exchange_potential(nBas,c,Fx,Vx) + +! Compute the exchange potential in the MO basis + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: c(nBas,nBas) + double precision,intent(in) :: Fx(nBas,nBas) + +! Local variables + + integer :: mu,nu + integer :: p + +! Output variables + + double precision,intent(out) :: Vx(nBas) + +! Compute Vx + + Vx(:) = 0d0 + do p=1,nBas + do mu=1,nBas + do nu=1,nBas + Vx(p) = Vx(p) + c(mu,p)*Fx(mu,nu)*c(nu,p) + end do + end do + end do + +end subroutine exchange_potential diff --git a/src/LR/linear_response.f90 b/src/LR/linear_response.f90 index e2a65fc..831be12 100644 --- a/src/LR/linear_response.f90 +++ b/src/LR/linear_response.f90 @@ -95,10 +95,10 @@ subroutine linear_response(ispin,dRPA,TDA,BSE,eta,nBas,nC,nO,nV,nR,nS,lambda,e,E XpY = matmul(transpose(Z),AmBSq) call DA(nS,1d0/sqrt(Omega),XpY) - + XmY = matmul(transpose(Z),AmBIv) call DA(nS,1d0*sqrt(Omega),XmY) - + end if ! Compute the RPA correlation energy diff --git a/src/LR/linear_response_B_pp.f90 b/src/LR/linear_response_B_pp.f90 index fe2515d..7644897 100644 --- a/src/LR/linear_response_B_pp.f90 +++ b/src/LR/linear_response_B_pp.f90 @@ -86,4 +86,7 @@ subroutine linear_response_B_pp(ispin,nBas,nC,nO,nV,nR,nOO,nVV,e,ERI,B_pp) end if +! print*,'B pp-matrix' +! call matout(nVV,nOO,B_pp) + end subroutine linear_response_B_pp diff --git a/src/LR/linear_response_C_pp.f90 b/src/LR/linear_response_C_pp.f90 index 82f00f7..a8b391d 100644 --- a/src/LR/linear_response_C_pp.f90 +++ b/src/LR/linear_response_C_pp.f90 @@ -96,4 +96,7 @@ subroutine linear_response_C_pp(ispin,nBas,nC,nO,nV,nR,nOO,nVV,e,ERI,C_pp) end if +! print*,'C pp-matrix' +! call matout(nVV,nVV,C_pp) + end subroutine linear_response_C_pp diff --git a/src/LR/linear_response_D_pp.f90 b/src/LR/linear_response_D_pp.f90 index 4257795..04a2960 100644 --- a/src/LR/linear_response_D_pp.f90 +++ b/src/LR/linear_response_D_pp.f90 @@ -96,4 +96,7 @@ subroutine linear_response_D_pp(ispin,nBas,nC,nO,nV,nR,nOO,nVV,e,ERI,D_pp) end if +! print*,'D pp-matrix' +! call matout(nOO,nOO,D_pp) + end subroutine linear_response_D_pp diff --git a/src/MBPT/Bethe_Salpeter.f90 b/src/MBPT/Bethe_Salpeter.f90 index 8ca6757..4d8621d 100644 --- a/src/MBPT/Bethe_Salpeter.f90 +++ b/src/MBPT/Bethe_Salpeter.f90 @@ -88,7 +88,7 @@ subroutine Bethe_Salpeter(TDA_W,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC, OmBSE(:,ispin),XpY_BSE(:,:,ispin),XmY_BSE(:,:,ispin)) else - call Bethe_Salpeter_dynamic_perturbation(dTDA,eta,nBas,nC,nO,nV,nR,nS,eGW,dipole_int,OmRPA,rho_RPA, & + call Bethe_Salpeter_dynamic_perturbation(dTDA,eta,nBas,nC,nO,nV,nR,nS,eW,eGW,dipole_int,OmRPA,rho_RPA, & OmBSE(:,ispin),XpY_BSE(:,:,ispin),XmY_BSE(:,:,ispin)) end if @@ -127,7 +127,7 @@ subroutine Bethe_Salpeter(TDA_W,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC, OmBSE(:,ispin),XpY_BSE(:,:,ispin),XmY_BSE(:,:,ispin)) else - call Bethe_Salpeter_dynamic_perturbation(dTDA,eta,nBas,nC,nO,nV,nR,nS,eGW,dipole_int,OmRPA,rho_RPA, & + call Bethe_Salpeter_dynamic_perturbation(dTDA,eta,nBas,nC,nO,nV,nR,nS,eW,eGW,dipole_int,OmRPA,rho_RPA, & OmBSE(:,ispin),XpY_BSE(:,:,ispin),XmY_BSE(:,:,ispin)) end if diff --git a/src/MBPT/Bethe_Salpeter_A_matrix.f90 b/src/MBPT/Bethe_Salpeter_A_matrix.f90 index 82f968d..28dc945 100644 --- a/src/MBPT/Bethe_Salpeter_A_matrix.f90 +++ b/src/MBPT/Bethe_Salpeter_A_matrix.f90 @@ -36,6 +36,7 @@ subroutine Bethe_Salpeter_A_matrix(eta,nBas,nC,nO,nV,nR,nS,lambda,ERI,Omega,rho, chi = 0d0 do kc=1,nS eps = Omega(kc)**2 + eta**2 +! chi = chi + lambda*rho(i,j,kc)*rho(a,b,kc)*Omega(kc)/eps chi = chi + rho(i,j,kc)*rho(a,b,kc)*Omega(kc)/eps enddo diff --git a/src/MBPT/Bethe_Salpeter_B_matrix.f90 b/src/MBPT/Bethe_Salpeter_B_matrix.f90 index 7e000ee..97f60d5 100644 --- a/src/MBPT/Bethe_Salpeter_B_matrix.f90 +++ b/src/MBPT/Bethe_Salpeter_B_matrix.f90 @@ -36,6 +36,7 @@ subroutine Bethe_Salpeter_B_matrix(eta,nBas,nC,nO,nV,nR,nS,lambda,ERI,OmRPA,rho_ chi = 0d0 do kc=1,nS eps = OmRPA(kc)**2 + eta**2 +! chi = chi + lambda*rho_RPA(i,b,kc)*rho_RPA(a,j,kc)*OmRPA(kc)/eps chi = chi + rho_RPA(i,b,kc)*rho_RPA(a,j,kc)*OmRPA(kc)/eps enddo diff --git a/src/MBPT/Bethe_Salpeter_dynamic_perturbation.f90 b/src/MBPT/Bethe_Salpeter_dynamic_perturbation.f90 index c960a75..88dcc08 100644 --- a/src/MBPT/Bethe_Salpeter_dynamic_perturbation.f90 +++ b/src/MBPT/Bethe_Salpeter_dynamic_perturbation.f90 @@ -1,4 +1,4 @@ -subroutine Bethe_Salpeter_dynamic_perturbation(dTDA,eta,nBas,nC,nO,nV,nR,nS,eGW,dipole_int,OmRPA,rho_RPA,OmBSE,XpY,XmY) +subroutine Bethe_Salpeter_dynamic_perturbation(dTDA,eta,nBas,nC,nO,nV,nR,nS,eW,eGW,dipole_int,OmRPA,rho_RPA,OmBSE,XpY,XmY) ! Compute dynamical effects via perturbation theory for BSE @@ -16,6 +16,7 @@ subroutine Bethe_Salpeter_dynamic_perturbation(dTDA,eta,nBas,nC,nO,nV,nR,nS,eGW, integer,intent(in) :: nR integer,intent(in) :: nS + double precision,intent(in) :: eW(nBas) double precision,intent(in) :: eGW(nBas) double precision,intent(in) :: dipole_int(nBas,nBas,ncart) double precision,intent(in) :: OmRPA(nS) diff --git a/src/MBPT/G0T0.f90 b/src/MBPT/G0T0.f90 index 7aa3dca..2e1b5a1 100644 --- a/src/MBPT/G0T0.f90 +++ b/src/MBPT/G0T0.f90 @@ -1,5 +1,5 @@ subroutine G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,singlet,triplet, & - linearize,eta,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI,dipole_int,eHF,eG0T0) + linearize,eta,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_AO,ERI_MO,dipole_int,PHF,cHF,eHF,Vxc,eG0T0) ! Perform one-shot calculation with a T-matrix self-energy (G0T0) @@ -30,8 +30,12 @@ subroutine G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,sing integer,intent(in) :: nS double precision,intent(in) :: ENuc double precision,intent(in) :: ERHF + double precision,intent(in) :: Vxc(nBas) double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: cHF(nBas,nBas) + double precision,intent(in) :: PHF(nBas,nBas) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_MO(nBas,nBas,nBas,nBas) double precision,intent(in) :: dipole_int(nBas,nBas,ncart) ! Local variables @@ -54,6 +58,7 @@ subroutine G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,sing double precision,allocatable :: X2s(:,:),X2t(:,:) double precision,allocatable :: Y2s(:,:),Y2t(:,:) double precision,allocatable :: rho2s(:,:,:),rho2t(:,:,:) + double precision,allocatable :: SigX(:) double precision,allocatable :: SigT(:) double precision,allocatable :: Z(:) @@ -90,7 +95,7 @@ subroutine G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,sing Omega1t(nVVt),X1t(nVVt,nVVt),Y1t(nOOt,nVVt), & Omega2t(nOOt),X2t(nVVt,nOOt),Y2t(nOOt,nOOt), & rho1t(nBas,nO,nVVt),rho2t(nBas,nV,nOOt), & - SigT(nBas),Z(nBas)) + SigX(nBas),SigT(nBas),Z(nBas)) !---------------------------------------------- ! alpha-beta block @@ -101,7 +106,7 @@ subroutine G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,sing ! Compute linear response - call linear_response_pp(iblock,.true.,.false.,nBas,nC,nO,nV,nR,nOOs,nVVs,eHF(:),ERI(:,:,:,:), & + call linear_response_pp(iblock,.true.,.false.,nBas,nC,nO,nV,nR,nOOs,nVVs,eHF(:),ERI_MO(:,:,:,:), & Omega1s(:),X1s(:,:),Y1s(:,:),Omega2s(:),X2s(:,:),Y2s(:,:),EcRPA(ispin)) ! EcRPA(ispin) = 1d0*EcRPA(ispin) @@ -118,7 +123,7 @@ subroutine G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,sing ! Compute linear response - call linear_response_pp(iblock,.true.,.false.,nBas,nC,nO,nV,nR,nOOt,nVVt,eHF(:),ERI(:,:,:,:), & + call linear_response_pp(iblock,.true.,.false.,nBas,nC,nO,nV,nR,nOOt,nVVt,eHF(:),ERI_MO(:,:,:,:), & Omega1t(:),X1t(:,:),Y1t(:,:),Omega2t(:),X2t(:,:),Y2t(:,:),EcRPA(ispin)) ! EcRPA(ispin) = 2d0*EcRPA(ispin) @@ -139,7 +144,7 @@ subroutine G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,sing xERI = +0d0 alpha = +1d0 - call excitation_density_Tmatrix(iblock,dERI,xERI,nBas,nC,nO,nV,nR,nOOs,nVVs,ERI(:,:,:,:), & + call excitation_density_Tmatrix(iblock,dERI,xERI,nBas,nC,nO,nV,nR,nOOs,nVVs,ERI_MO(:,:,:,:), & X1s(:,:),Y1s(:,:),rho1s(:,:,:),X2s(:,:),Y2s(:,:),rho2s(:,:,:)) call self_energy_Tmatrix_diag(alpha,eta,nBas,nC,nO,nV,nR,nOOs,nVVs,eHF(:), & @@ -153,7 +158,7 @@ subroutine G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,sing xERI = -1d0 alpha = +1d0 - call excitation_density_Tmatrix(iblock,dERI,xERI,nBas,nC,nO,nV,nR,nOOt,nVVt,ERI(:,:,:,:), & + call excitation_density_Tmatrix(iblock,dERI,xERI,nBas,nC,nO,nV,nR,nOOt,nVVt,ERI_MO(:,:,:,:), & X1t(:,:),Y1t(:,:),rho1t(:,:,:),X2t(:,:),Y2t(:,:),rho2t(:,:,:)) call self_energy_Tmatrix_diag(alpha,eta,nBas,nC,nO,nV,nR,nOOt,nVVt,eHF(:), & @@ -164,17 +169,24 @@ subroutine G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,sing Z(:) = 1d0/(1d0 - Z(:)) + +!---------------------------------------------- +! Compute the exchange part of the self-energy +!---------------------------------------------- + + call self_energy_exchange_diag(nBas,cHF,PHF,ERI_AO,SigX) + !---------------------------------------------- ! Solve the quasi-particle equation !---------------------------------------------- if(linearize) then - eG0T0(:) = eHF(:) + Z(:)*SigT(:) + eG0T0(:) = eHF(:) + Z(:)*(SigX(:) + SigT(:) - Vxc(:)) else - eG0T0(:) = eHF(:) + SigT(:) + eG0T0(:) = eHF(:) + SigX(:) + SigT(:) - Vxc(:) end if @@ -188,11 +200,11 @@ subroutine G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,sing ispin = 1 iblock = 3 - call linear_response_pp(iblock,.false.,.false.,nBas,nC,nO,nV,nR,nOOs,nVVs,eG0T0(:),ERI(:,:,:,:), & + call linear_response_pp(iblock,.false.,.false.,nBas,nC,nO,nV,nR,nOOs,nVVs,eG0T0(:),ERI_MO(:,:,:,:), & Omega1s(:),X1s(:,:),Y1s(:,:),Omega2s(:),X2s(:,:),Y2s(:,:),EcRPA(ispin)) ispin = 2 iblock = 4 - call linear_response_pp(iblock,.false.,.false.,nBas,nC,nO,nV,nR,nOOt,nVVt,eG0T0(:),ERI(:,:,:,:), & + call linear_response_pp(iblock,.false.,.false.,nBas,nC,nO,nV,nR,nOOt,nVVt,eG0T0(:),ERI_MO(:,:,:,:), & Omega1t(:),X1t(:,:),Y1t(:,:),Omega2t(:),X2t(:,:),Y2t(:,:),EcRPA(ispin)) EcRPA(1) = EcRPA(1) - EcRPA(2) EcRPA(2) = 3d0*EcRPA(2) @@ -211,7 +223,7 @@ subroutine G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,sing if(BSE) then call Bethe_Salpeter(TDA_W,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta, & - nBas,nC,nO,nV,nR,nS,ERI,dipole_int,eHF,eG0T0,EcBSE) + nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int,eHF,eG0T0,EcBSE) if(exchange_kernel) then @@ -246,7 +258,7 @@ subroutine G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,sing end if call ACFDT(exchange_kernel,doXBS,.true.,TDA_W,TDA,BSE,singlet,triplet,eta, & - nBas,nC,nO,nV,nR,nS,ERI,eHF,eG0T0,EcAC) + nBas,nC,nO,nV,nR,nS,ERI_MO,eHF,eG0T0,EcAC) if(exchange_kernel) then diff --git a/src/MBPT/G0W0.f90 b/src/MBPT/G0W0.f90 index f629708..8b0c01a 100644 --- a/src/MBPT/G0W0.f90 +++ b/src/MBPT/G0W0.f90 @@ -1,6 +1,6 @@ subroutine G0W0(doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA, & dBSE,dTDA,evDyn,singlet,triplet,linearize,eta, & - nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI,dipole_int,eHF,eGW) + nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_AO,ERI_MO,dipole_int,PHF,cHF,eHF,Vxc,eG0W0) ! Perform G0W0 calculation @@ -29,9 +29,13 @@ subroutine G0W0(doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA, & integer,intent(in) :: nBas,nC,nO,nV,nR,nS double precision,intent(in) :: ENuc double precision,intent(in) :: ERHF - double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_MO(nBas,nBas,nBas,nBas) double precision,intent(in) :: dipole_int(nBas,nBas,ncart) + double precision,intent(in) :: Vxc(nBas) double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: cHF(nBas,nBas) + double precision,intent(in) :: PHF(nBas,nBas) ! Local variables @@ -41,6 +45,7 @@ subroutine G0W0(doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA, & double precision :: EcBSE(nspin) double precision :: EcAC(nspin) double precision :: EcGM + double precision,allocatable :: SigX(:) double precision,allocatable :: SigC(:) double precision,allocatable :: Z(:) double precision,allocatable :: OmRPA(:) @@ -48,11 +53,11 @@ subroutine G0W0(doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA, & double precision,allocatable :: XmY_RPA(:,:) double precision,allocatable :: rho_RPA(:,:,:) - double precision,allocatable :: eGWlin(:) + double precision,allocatable :: eG0W0lin(:) ! Output variables - double precision :: eGW(nBas) + double precision :: eG0W0(nBas) ! Hello world @@ -100,14 +105,14 @@ subroutine G0W0(doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA, & ! Memory allocation - allocate(SigC(nBas),Z(nBas),OmRPA(nS),XpY_RPA(nS,nS),XmY_RPA(nS,nS),rho_RPA(nBas,nBas,nS),eGWlin(nBas)) + allocate(SigC(nBas),SigX(nBas),Z(nBas),OmRPA(nS),XpY_RPA(nS,nS),XmY_RPA(nS,nS),rho_RPA(nBas,nBas,nS),eG0W0lin(nBas)) !-------------------! ! Compute screening ! !-------------------! call linear_response(ispin,.true.,TDA_W,.false.,eta,nBas,nC,nO,nV,nR,nS,1d0, & - eHF,ERI,OmRPA,rho_RPA,EcRPA,OmRPA,XpY_RPA,XmY_RPA) + eHF,ERI_MO,OmRPA,rho_RPA,EcRPA,OmRPA,XpY_RPA,XmY_RPA) if(print_W) call print_excitation('RPA@HF ',ispin,nS,OmRPA) @@ -115,12 +120,13 @@ subroutine G0W0(doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA, & ! Compute spectral weights ! !--------------------------! - call excitation_density(nBas,nC,nO,nR,nS,ERI,XpY_RPA,rho_RPA) + call excitation_density(nBas,nC,nO,nR,nS,ERI_MO,XpY_RPA,rho_RPA) !------------------------! ! Compute GW self-energy ! !------------------------! + call self_energy_exchange_diag(nBas,cHF,PHF,ERI_AO,SigX) call self_energy_correlation_diag(COHSEX,eta,nBas,nC,nO,nV,nR,nS,eHF,OmRPA,rho_RPA,EcGM,SigC) !--------------------------------! @@ -133,7 +139,7 @@ subroutine G0W0(doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA, & ! Solve the quasi-particle equation ! !-----------------------------------! - eGWlin(:) = eHF(:) + Z(:)*SigC(:) + eG0W0lin(:) = eHF(:) + Z(:)*(SigX(:) + SigC(:) - Vxc(:)) ! Linearized or graphical solution? @@ -142,14 +148,14 @@ subroutine G0W0(doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA, & write(*,*) ' *** Quasiparticle energies obtained by linearization *** ' write(*,*) - eGW(:) = eGWlin(:) + eG0W0(:) = eG0W0lin(:) else write(*,*) ' *** Quasiparticle energies obtained by root search (experimental) *** ' write(*,*) - call QP_graph(nBas,nC,nO,nV,nR,nS,eta,eHF,OmRPA,rho_RPA,eGWlin,eGW) + call QP_graph(nBas,nC,nO,nV,nR,nS,eta,eHF,SigX,Vxc,OmRPA,rho_RPA,eG0W0lin,eG0W0) ! Find all the roots of the QP equation if necessary @@ -159,18 +165,18 @@ subroutine G0W0(doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA, & ! Compute the RPA correlation energy - call linear_response(ispin,.true.,TDA_W,.false.,eta,nBas,nC,nO,nV,nR,nS,1d0,eGW,ERI,OmRPA, & + call linear_response(ispin,.true.,TDA_W,.false.,eta,nBas,nC,nO,nV,nR,nS,1d0,eG0W0,ERI_MO,OmRPA, & rho_RPA,EcRPA,OmRPA,XpY_RPA,XmY_RPA) !--------------! ! Dump results ! !--------------! - call print_G0W0(nBas,nO,eHF,ENuc,ERHF,SigC,Z,eGW,EcRPA,EcGM) + call print_G0W0(nBas,nO,eHF,ENuc,ERHF,SigC,Z,eG0W0,EcRPA,EcGM) ! Deallocate memory - deallocate(SigC,Z,OmRPA,XpY_RPA,XmY_RPA,rho_RPA,eGWlin) + deallocate(SigC,Z,OmRPA,XpY_RPA,XmY_RPA,rho_RPA,eG0W0lin) ! Plot stuff @@ -180,7 +186,7 @@ subroutine G0W0(doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA, & if(BSE) then - call Bethe_Salpeter(TDA_W,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI,dipole_int,eHF,eGW,EcBSE) + call Bethe_Salpeter(TDA_W,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int,eHF,eG0W0,EcBSE) if(exchange_kernel) then @@ -202,9 +208,9 @@ subroutine G0W0(doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA, & if(doACFDT) then - write(*,*) '--------------------------------------------------------------' - write(*,*) ' Adiabatic connection version of BSE@UG0W0 correlation energy ' - write(*,*) '--------------------------------------------------------------' + write(*,*) '-------------------------------------------------------------' + write(*,*) ' Adiabatic connection version of BSE@G0W0 correlation energy ' + write(*,*) '-------------------------------------------------------------' write(*,*) if(doXBS) then @@ -214,14 +220,14 @@ subroutine G0W0(doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA, & end if - call ACFDT(exchange_kernel,doXBS,.true.,TDA_W,TDA,BSE,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI,eHF,eGW,EcAC) + call ACFDT(exchange_kernel,doXBS,.true.,TDA_W,TDA,BSE,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,eHF,eG0W0,EcAC) write(*,*) write(*,*)'-------------------------------------------------------------------------------' - write(*,'(2X,A50,F20.10)') 'AC@BSE@UG0W0 correlation energy (singlet) =',EcAC(1) - write(*,'(2X,A50,F20.10)') 'AC@BSE@UG0W0 correlation energy (triplet) =',EcAC(2) - write(*,'(2X,A50,F20.10)') 'AC@BSE@UG0W0 correlation energy =',EcAC(1) + EcAC(2) - write(*,'(2X,A50,F20.10)') 'AC@BSE@UG0W0 total energy =',ENuc + ERHF + EcAC(1) + EcAC(2) + write(*,'(2X,A50,F20.10)') 'AC@BSE@G0W0 correlation energy (singlet) =',EcAC(1) + write(*,'(2X,A50,F20.10)') 'AC@BSE@G0W0 correlation energy (triplet) =',EcAC(2) + write(*,'(2X,A50,F20.10)') 'AC@BSE@G0W0 correlation energy =',EcAC(1) + EcAC(2) + write(*,'(2X,A50,F20.10)') 'AC@BSE@G0W0 total energy =',ENuc + ERHF + EcAC(1) + EcAC(2) write(*,*)'-------------------------------------------------------------------------------' write(*,*) diff --git a/src/MBPT/QP_graph.f90 b/src/MBPT/QP_graph.f90 index bc6ae48..69628e8 100644 --- a/src/MBPT/QP_graph.f90 +++ b/src/MBPT/QP_graph.f90 @@ -1,4 +1,4 @@ -subroutine QP_graph(nBas,nC,nO,nV,nR,nS,eta,eHF,Omega,rho,eGWlin,eGW) +subroutine QP_graph(nBas,nC,nO,nV,nR,nS,eta,eHF,SigX,Vxc,Omega,rho,eGWlin,eGW) ! Compute the graphical solution of the QP equation @@ -15,6 +15,8 @@ subroutine QP_graph(nBas,nC,nO,nV,nR,nS,eta,eHF,Omega,rho,eGWlin,eGW) integer,intent(in) :: nS double precision,intent(in) :: eta double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: SigX(nBas) + double precision,intent(in) :: Vxc(nBas) double precision,intent(in) :: Omega(nS) double precision,intent(in) :: rho(nBas,nBas,nS) @@ -27,7 +29,7 @@ subroutine QP_graph(nBas,nC,nO,nV,nR,nS,eta,eHF,Omega,rho,eGWlin,eGW) integer,parameter :: maxIt = 64 double precision,parameter :: thresh = 1d-6 double precision,external :: SigmaC,dSigmaC - double precision :: sig,dsig + double precision :: sigC,dsigC double precision :: f,df double precision :: w @@ -52,14 +54,14 @@ subroutine QP_graph(nBas,nC,nO,nV,nR,nS,eta,eHF,Omega,rho,eGWlin,eGW) nIt = nIt + 1 - sig = SigmaC(p,w,eta,nBas,nC,nO,nV,nR,nS,eHF,Omega,rho) - dsig = dSigmaC(p,w,eta,nBas,nC,nO,nV,nR,nS,eHF,Omega,rho) - f = w - eHF(p) - sig - df = 1d0 - dsig + sigC = SigmaC(p,w,eta,nBas,nC,nO,nV,nR,nS,eHF,Omega,rho) + dsigC = dSigmaC(p,w,eta,nBas,nC,nO,nV,nR,nS,eHF,Omega,rho) + f = w - eHF(p) - SigX(p) - sigC + Vxc(p) + df = 1d0 - dsigC w = w - f/df - write(*,'(A3,I3,A1,1X,3F15.9)') 'It.',nIt,':',w*HaToeV,f,sig + write(*,'(A3,I3,A1,1X,3F15.9)') 'It.',nIt,':',w*HaToeV,f,sigC end do diff --git a/src/MBPT/UG0W0.f90 b/src/MBPT/UG0W0.f90 index 5f8b8b9..90d4ab1 100644 --- a/src/MBPT/UG0W0.f90 +++ b/src/MBPT/UG0W0.f90 @@ -1,6 +1,6 @@ subroutine UG0W0(doACFDT,exchange_kernel,doXBS,COHSEX,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,spin_conserved,spin_flip, & - linearize,eta,nBas,nC,nO,nV,nR,nS,ENuc,EUHF,S,ERI_aaaa,ERI_aabb,ERI_bbbb, & - dipole_int_aa,dipole_int_bb,PHF,cHF,eHF,eGW) + linearize,eta,nBas,nC,nO,nV,nR,nS,ENuc,EUHF,S,ERI,ERI_aaaa,ERI_aabb,ERI_bbbb, & + dipole_int_aa,dipole_int_bb,PHF,cHF,eHF,Vxc,eGW) ! Perform unrestricted G0W0 calculation @@ -34,6 +34,7 @@ subroutine UG0W0(doACFDT,exchange_kernel,doXBS,COHSEX,BSE,TDA_W,TDA,dBSE,dTDA,ev double precision,intent(in) :: ENuc double precision,intent(in) :: EUHF double precision,intent(in) :: S(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) double precision,intent(in) :: ERI_aaaa(nBas,nBas,nBas,nBas) double precision,intent(in) :: ERI_aabb(nBas,nBas,nBas,nBas) double precision,intent(in) :: ERI_bbbb(nBas,nBas,nBas,nBas) @@ -42,6 +43,7 @@ subroutine UG0W0(doACFDT,exchange_kernel,doXBS,COHSEX,BSE,TDA_W,TDA,dBSE,dTDA,ev double precision,intent(in) :: eHF(nBas,nspin) double precision,intent(in) :: cHF(nBas,nBas,nspin) double precision,intent(in) :: PHF(nBas,nBas,nspin) + double precision,intent(in) :: Vxc(nBas,nspin) ! Local variables @@ -52,6 +54,7 @@ subroutine UG0W0(doACFDT,exchange_kernel,doXBS,COHSEX,BSE,TDA_W,TDA,dBSE,dTDA,ev double precision :: EcGM(nspin) double precision :: EcBSE(nspin) double precision :: EcAC(nspin) + double precision,allocatable :: SigX(:,:) double precision,allocatable :: SigC(:,:) double precision,allocatable :: Z(:,:) integer :: nS_aa,nS_bb,nS_sc @@ -106,8 +109,8 @@ subroutine UG0W0(doACFDT,exchange_kernel,doXBS,COHSEX,BSE,TDA_W,TDA,dBSE,dTDA,ev nS_bb = nS(2) nS_sc = nS_aa + nS_bb - allocate(SigC(nBas,nspin),Z(nBas,nspin),OmRPA(nS_sc),XpY_RPA(nS_sc,nS_sc),XmY_RPA(nS_sc,nS_sc), & - rho_RPA(nBas,nBas,nS_sc,nspin),eGWlin(nBas,nspin)) + allocate(SigX(nBas,nspin),SigC(nBas,nspin),Z(nBas,nspin),eGWlin(nBas,nspin), & + OmRPA(nS_sc),XpY_RPA(nS_sc,nS_sc),XmY_RPA(nS_sc,nS_sc),rho_RPA(nBas,nBas,nS_sc,nspin)) !-------------------! ! Compute screening ! @@ -132,6 +135,10 @@ subroutine UG0W0(doACFDT,exchange_kernel,doXBS,COHSEX,BSE,TDA_W,TDA,dBSE,dTDA,ev ! Compute self-energy ! !---------------------! + do is=1,nspin + call self_energy_exchange_diag(nBas,cHF(:,:,is),PHF(:,:,is),ERI,SigX(:,is)) + end do + call unrestricted_self_energy_correlation_diag(eta,nBas,nC,nO,nV,nR,nS_sc,eHF,OmRPA,rho_RPA,SigC,EcGM) !--------------------------------! @@ -144,7 +151,7 @@ subroutine UG0W0(doACFDT,exchange_kernel,doXBS,COHSEX,BSE,TDA_W,TDA,dBSE,dTDA,ev ! Solve the quasi-particle equation ! !-----------------------------------! - eGWlin(:,:) = eHF(:,:) + Z(:,:)*SigC(:,:) + eGWlin(:,:) = eHF(:,:) + Z(:,:)*(SigX(:,:) + SigC(:,:) - Vxc(:,:)) if(linearize) then @@ -157,10 +164,10 @@ subroutine UG0W0(doACFDT,exchange_kernel,doXBS,COHSEX,BSE,TDA_W,TDA,dBSE,dTDA,ev ! Find graphical solution of the QP equation - do is=1,nspin - call unrestricted_QP_graph(nBas,nC(is),nO(is),nV(is),nR(is),nS_sc,eta,eHF(:,is),OmRPA, & - rho_RPA(:,:,:,is),eGWlin(:,is),eGW(:,is)) - end do + do is=1,nspin + call unrestricted_QP_graph(nBas,nC(is),nO(is),nV(is),nR(is),nS_sc,eta,eHF(:,is),SigX(:,is),Vxc(:,is), & + OmRPA,rho_RPA(:,:,:,is),eGWlin(:,is),eGW(:,is)) + end do end if @@ -187,8 +194,12 @@ subroutine UG0W0(doACFDT,exchange_kernel,doXBS,COHSEX,BSE,TDA_W,TDA,dBSE,dTDA,ev if(exchange_kernel) then EcBSE(1) = 0.5d0*EcBSE(1) - EcBSE(2) = 1.5d0*EcBSE(1) + EcBSE(2) = 0.5d0*EcBSE(2) + else + + EcBSE(2) = 0.0d0 + end if write(*,*) @@ -204,9 +215,9 @@ subroutine UG0W0(doACFDT,exchange_kernel,doXBS,COHSEX,BSE,TDA_W,TDA,dBSE,dTDA,ev if(doACFDT) then - write(*,*) '------------------------------------------------------' - write(*,*) 'Adiabatic connection version of BSE correlation energy' - write(*,*) '------------------------------------------------------' + write(*,*) '------------------------------------------------------------' + write(*,*) 'Adiabatic connection version of BSE@UG0W0 correlation energy' + write(*,*) '------------------------------------------------------------' write(*,*) if(doXBS) then diff --git a/src/MBPT/evGT.f90 b/src/MBPT/evGT.f90 index c923a20..814db63 100644 --- a/src/MBPT/evGT.f90 +++ b/src/MBPT/evGT.f90 @@ -1,6 +1,6 @@ subroutine evGT(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, & - BSE,TDA_W,TDA,dBSE,dTDA,evDyn,singlet,triplet, & - eta,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI,dipole_int,eHF,eG0T0) + BSE,TDA_W,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas, & + nC,nO,nV,nR,nS,ENuc,ERHF,ERI_AO,ERI_MO,dipole_int,PHF,cHF,eHF,Vxc,eG0T0) ! Perform eigenvalue self-consistent calculation with a T-matrix self-energy (evGT) @@ -33,8 +33,12 @@ subroutine evGT(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, & integer,intent(in) :: nS double precision,intent(in) :: ENuc double precision,intent(in) :: ERHF + double precision,intent(in) :: PHF(nBas,nBas) double precision,intent(in) :: eHF(nBas) - double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: cHF(nBas,nBas) + double precision,intent(in) :: Vxc(nBas) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_MO(nBas,nBas,nBas,nBas) double precision,intent(in) :: dipole_int(nBas,nBas,ncart) double precision,intent(in) :: eG0T0(nBas) @@ -68,6 +72,7 @@ subroutine evGT(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, & double precision,allocatable :: X2s(:,:),X2t(:,:) double precision,allocatable :: Y2s(:,:),Y2t(:,:) double precision,allocatable :: rho2s(:,:,:),rho2t(:,:,:) + double precision,allocatable :: SigX(:) double precision,allocatable :: SigT(:) double precision,allocatable :: Z(:) @@ -96,15 +101,19 @@ subroutine evGT(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, & ! Memory allocation - allocate(Omega1s(nVVs),X1s(nVVs,nVVs),Y1s(nOOs,nVVs), & - Omega2s(nOOs),X2s(nVVs,nOOs),Y2s(nOOs,nOOs), & - rho1s(nBas,nO,nVVs),rho2s(nBas,nV,nOOs), & - Omega1t(nVVt),X1t(nVVt,nVVt),Y1t(nOOt,nVVt), & - Omega2t(nOOt),X2t(nVVt,nOOt),Y2t(nOOt,nOOt), & - rho1t(nBas,nO,nVVt),rho2t(nBas,nV,nOOt), & - eGT(nBas),eOld(nBas),Z(nBas),SigT(nBas), & + allocate(Omega1s(nVVs),X1s(nVVs,nVVs),Y1s(nOOs,nVVs), & + Omega2s(nOOs),X2s(nVVs,nOOs),Y2s(nOOs,nOOs), & + rho1s(nBas,nO,nVVs),rho2s(nBas,nV,nOOs), & + Omega1t(nVVt),X1t(nVVt,nVVt),Y1t(nOOt,nVVt), & + Omega2t(nOOt),X2t(nVVt,nOOt),Y2t(nOOt,nOOt), & + rho1t(nBas,nO,nVVt),rho2t(nBas,nV,nOOt), & + eGT(nBas),eOld(nBas),Z(nBas),SigX(nBas),SigT(nBas), & error_diis(nBas,max_diis),e_diis(nBas,max_diis)) +! Compute the exchange part of the self-energy + + call self_energy_exchange_diag(nBas,cHF,PHF,ERI_AO,SigX) + ! Initialization nSCF = 0 @@ -131,7 +140,7 @@ subroutine evGT(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, & ! Compute linear response - call linear_response_pp(iblock,.true.,.false.,nBas,nC,nO,nV,nR,nOOs,nVVs,eHF(:),ERI(:,:,:,:), & + call linear_response_pp(iblock,.true.,.false.,nBas,nC,nO,nV,nR,nOOs,nVVs,eGT(:),ERI_MO(:,:,:,:), & Omega1s(:),X1s(:,:),Y1s(:,:),Omega2s(:),X2s(:,:),Y2s(:,:),EcRPA(ispin)) ! EcRPA(ispin) = 1d0*EcRPA(ispin) @@ -148,7 +157,7 @@ subroutine evGT(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, & ! Compute linear response - call linear_response_pp(iblock,.true.,.false.,nBas,nC,nO,nV,nR,nOOt,nVVt,eHF(:),ERI(:,:,:,:), & + call linear_response_pp(iblock,.true.,.false.,nBas,nC,nO,nV,nR,nOOt,nVVt,eGT(:),ERI_MO(:,:,:,:), & Omega1t(:),X1t(:,:),Y1t(:,:),Omega2t(:),X2t(:,:),Y2t(:,:),EcRPA(ispin)) ! EcRPA(ispin) = 2d0*EcRPA(ispin) @@ -169,7 +178,7 @@ subroutine evGT(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, & xERI = +0d0 alpha = +1d0 - call excitation_density_Tmatrix(iblock,dERI,xERI,nBas,nC,nO,nV,nR,nOOs,nVVs,ERI(:,:,:,:), & + call excitation_density_Tmatrix(iblock,dERI,xERI,nBas,nC,nO,nV,nR,nOOs,nVVs,ERI_MO(:,:,:,:), & X1s(:,:),Y1s(:,:),rho1s(:,:,:),X2s(:,:),Y2s(:,:),rho2s(:,:,:)) call self_energy_Tmatrix_diag(alpha,eta,nBas,nC,nO,nV,nR,nOOs,nVVs,eGT(:), & @@ -183,7 +192,7 @@ subroutine evGT(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, & xERI = -1d0 alpha = +1d0 - call excitation_density_Tmatrix(iblock,dERI,xERI,nBas,nC,nO,nV,nR,nOOt,nVVt,ERI(:,:,:,:), & + call excitation_density_Tmatrix(iblock,dERI,xERI,nBas,nC,nO,nV,nR,nOOt,nVVt,ERI_MO(:,:,:,:), & X1t(:,:),Y1t(:,:),rho1t(:,:,:),X2t(:,:),Y2t(:,:),rho2t(:,:,:)) call self_energy_Tmatrix_diag(alpha,eta,nBas,nC,nO,nV,nR,nOOt,nVVt,eGT(:), & @@ -200,7 +209,7 @@ subroutine evGT(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, & ! Solve the quasi-particle equation !---------------------------------------------- - eGT(:) = eHF(:) + SigT(:) + eGT(:) = eHF(:) + SigX(:) + SigT(:) - Vxc(:) ! Convergence criteria @@ -238,11 +247,11 @@ subroutine evGT(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, & ispin = 1 iblock = 3 - call linear_response_pp(iblock,.false.,.false.,nBas,nC,nO,nV,nR,nOOs,nVVs,eGT(:),ERI(:,:,:,:), & + call linear_response_pp(iblock,.false.,.false.,nBas,nC,nO,nV,nR,nOOs,nVVs,eGT(:),ERI_MO(:,:,:,:), & Omega1s(:),X1s(:,:),Y1s(:,:),Omega2s(:),X2s(:,:),Y2s(:,:),EcRPA(ispin)) ispin = 2 iblock = 4 - call linear_response_pp(iblock,.false.,.false.,nBas,nC,nO,nV,nR,nOOt,nVVt,eGT(:),ERI(:,:,:,:), & + call linear_response_pp(iblock,.false.,.false.,nBas,nC,nO,nV,nR,nOOt,nVVt,eGT(:),ERI_MO(:,:,:,:), & Omega1t(:),X1t(:,:),Y1t(:,:),Omega2t(:),X2t(:,:),Y2t(:,:),EcRPA(ispin)) EcRPA(1) = EcRPA(1) - EcRPA(2) EcRPA(2) = 3d0*EcRPA(2) @@ -262,7 +271,7 @@ subroutine evGT(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, & if(BSE) then call Bethe_Salpeter(TDA_W,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta, & - nBas,nC,nO,nV,nR,nS,ERI,dipole_int,eGT,eGT,EcRPA,EcBSE) + nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int,eGT,eGT,EcRPA,EcBSE) if(exchange_kernel) then @@ -297,7 +306,7 @@ subroutine evGT(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS, & end if call ACFDT(exchange_kernel,doXBS,.true.,TDA_W,TDA,BSE,singlet,triplet,eta, & - nBas,nC,nO,nV,nR,nS,ERI,eGT,eGT,EcAC) + nBas,nC,nO,nV,nR,nS,ERI_MO,eGT,eGT,EcAC) if(exchange_kernel) then diff --git a/src/MBPT/evGW.f90 b/src/MBPT/evGW.f90 index d471d70..85998eb 100644 --- a/src/MBPT/evGW.f90 +++ b/src/MBPT/evGW.f90 @@ -1,6 +1,6 @@ subroutine evGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA, & - G0W,GW0,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI, & - dipole_int,eHF,eG0W0) + G0W,GW0,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ENuc,ERHF, & + ERI_AO,ERI_MO,dipole_int,PHF,cHF,eHF,Vxc,eG0W0) ! Perform self-consistent eigenvalue-only GW calculation @@ -31,9 +31,13 @@ subroutine evGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE logical,intent(in) :: triplet double precision,intent(in) :: eta integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: PHF(nBas,nBas) double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: cHF(nBas,nBas) + double precision,intent(in) :: Vxc(nBas) double precision,intent(in) :: eG0W0(nBas) - double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) + double precision,intent(in) :: ERI_MO(nBas,nBas,nBas,nBas) double precision,intent(in) :: dipole_int(nBas,nBas,ncart) ! Local variables @@ -54,6 +58,7 @@ subroutine evGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE double precision,allocatable :: eGW(:) double precision,allocatable :: eOld(:) double precision,allocatable :: Z(:) + double precision,allocatable :: SigX(:) double precision,allocatable :: SigC(:) double precision,allocatable :: OmRPA(:) double precision,allocatable :: XpY_RPA(:,:) @@ -117,9 +122,13 @@ subroutine evGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE ! Memory allocation - allocate(eGW(nBas),eOld(nBas),Z(nBas),SigC(nBas),OmRPA(nS),XpY_RPA(nS,nS),XmY_RPA(nS,nS), & + allocate(eGW(nBas),eOld(nBas),Z(nBas),SigX(nBas),SigC(nBas),OmRPA(nS),XpY_RPA(nS,nS),XmY_RPA(nS,nS), & rho_RPA(nBas,nBas,nS),error_diis(nBas,max_diis),e_diis(nBas,max_diis)) +! Compute the exchange part of the self-energy + + call self_energy_exchange_diag(nBas,cHF,PHF,ERI_AO,SigX) + ! Initialization nSCF = 0 @@ -142,14 +151,14 @@ subroutine evGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE if(.not. GW0 .or. nSCF == 0) then - call linear_response(ispin,.true.,TDA_W,.false.,eta,nBas,nC,nO,nV,nR,nS,1d0,eGW,ERI,OmRPA, & + call linear_response(ispin,.true.,TDA_W,.false.,eta,nBas,nC,nO,nV,nR,nS,1d0,eGW,ERI_MO,OmRPA, & rho_RPA,EcRPA,OmRPA,XpY_RPA,XmY_RPA) endif ! Compute spectral weights - call excitation_density(nBas,nC,nO,nR,nS,ERI,XpY_RPA,rho_RPA) + call excitation_density(nBas,nC,nO,nR,nS,ERI_MO,XpY_RPA,rho_RPA) ! Compute correlation part of the self-energy @@ -167,7 +176,7 @@ subroutine evGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE ! Solve the quasi-particle equation - eGW(:) = eHF(:) + SigC(:) + eGW(:) = eHF(:) + SigX(:) + SigC(:) - Vxc(:) ! Convergence criteria @@ -186,11 +195,11 @@ subroutine evGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE else n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,nBas,nBas,n_diis,error_diis,e_diis,eGW-eOld,eGW) - -! Reset DIIS if required - - if(abs(rcond) < 1d-15) n_diis = 0 + if(abs(rcond) > 1d-7) then + call DIIS_extrapolation(rcond,nBas,nBas,n_diis,error_diis,e_diis,eGW-eOld,eGW) + else + n_diis = 0 + endif endif @@ -233,7 +242,7 @@ subroutine evGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE if(BSE) then - call Bethe_Salpeter(TDA_W,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI,dipole_int,eGW,eGW,EcBSE) + call Bethe_Salpeter(TDA_W,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,dipole_int,eGW,eGW,EcBSE) if(exchange_kernel) then @@ -267,7 +276,7 @@ subroutine evGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE end if - call ACFDT(exchange_kernel,doXBS,.true.,TDA_W,TDA,BSE,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI,eGW,eGW,EcAC) + call ACFDT(exchange_kernel,doXBS,.true.,TDA_W,TDA,BSE,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI_MO,eGW,eGW,EcAC) write(*,*) write(*,*)'-------------------------------------------------------------------------------' diff --git a/src/MBPT/evUGW.f90 b/src/MBPT/evUGW.f90 index 5379763..ece48d8 100644 --- a/src/MBPT/evUGW.f90 +++ b/src/MBPT/evUGW.f90 @@ -1,6 +1,6 @@ subroutine evUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,BSE,TDA_W,TDA, & G0W,GW0,dBSE,dTDA,evDyn,spin_conserved,spin_flip,eta,nBas,nC,nO,nV,nR,nS,ENuc, & - EUHF,S,ERI_aaaa,ERI_aabb,ERI_bbbb,dipole_int_aa,dipole_int_bb,cHF,eHF,eG0W0) + EUHF,S,ERI_AO,ERI_aaaa,ERI_aabb,ERI_bbbb,dipole_int_aa,dipole_int_bb,PHF,cHF,eHF,Vxc,eG0W0) ! Perform self-consistent eigenvalue-only GW calculation @@ -37,10 +37,13 @@ subroutine evUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,BSE integer,intent(in) :: nR(nspin) integer,intent(in) :: nS(nspin) + double precision,intent(in) :: PHF(nBas,nBas,nspin) double precision,intent(in) :: eHF(nBas,nspin) double precision,intent(in) :: cHF(nBas,nBas,nspin) + double precision,intent(in) :: Vxc(nBas,nspin) double precision,intent(in) :: eG0W0(nBas,nspin) double precision,intent(in) :: S(nBas,nBas) + double precision,intent(in) :: ERI_AO(nBas,nBas,nBas,nBas) double precision,intent(in) :: ERI_aaaa(nBas,nBas,nBas,nBas) double precision,intent(in) :: ERI_aabb(nBas,nBas,nBas,nBas) double precision,intent(in) :: ERI_bbbb(nBas,nBas,nBas,nBas) @@ -67,6 +70,7 @@ subroutine evUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,BSE double precision,allocatable :: eOld(:,:) double precision,allocatable :: Z(:,:) integer :: nS_aa,nS_bb,nS_sc + double precision,allocatable :: SigX(:,:) double precision,allocatable :: SigC(:,:) double precision,allocatable :: OmRPA(:) double precision,allocatable :: XpY_RPA(:,:) @@ -127,8 +131,15 @@ subroutine evUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,BSE nS_bb = nS(2) nS_sc = nS_aa + nS_bb - allocate(eGW(nBas,nspin),eOld(nBas,nspin),Z(nBas,nspin),SigC(nBas,nspin),OmRPA(nS_sc),XpY_RPA(nS_sc,nS_sc), & - XmY_RPA(nS_sc,nS_sc),rho_RPA(nBas,nBas,nS_sc,nspin),error_diis(nBas,max_diis,nspin),e_diis(nBas,max_diis,nspin)) + allocate(eGW(nBas,nspin),eOld(nBas,nspin),Z(nBas,nspin),SigX(nBas,nspin),SigC(nBas,nspin), & + OmRPA(nS_sc),XpY_RPA(nS_sc,nS_sc),XmY_RPA(nS_sc,nS_sc),rho_RPA(nBas,nBas,nS_sc,nspin), & + error_diis(nBas,max_diis,nspin),e_diis(nBas,max_diis,nspin)) + +! Compute the exchange part of the self-energy + + do is=1,nspin + call self_energy_exchange_diag(nBas,cHF(:,:,is),PHF(:,:,is),ERI_AO,SigX(:,is)) + end do ! Initialization @@ -182,7 +193,7 @@ subroutine evUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,BSE ! Solve the quasi-particle equation ! !-----------------------------------! - eGW(:,:) = eHF(:,:) + SigC(:,:) + eGW(:,:) = eHF(:,:) + SigX(:,:) + SigC(:,:) - Vxc(:,:) ! Convergence criteria @@ -257,7 +268,11 @@ subroutine evUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,BSE if(exchange_kernel) then EcBSE(1) = 0.5d0*EcBSE(1) - EcBSE(2) = 1.5d0*EcBSE(2) + EcBSE(2) = 0.5d0*EcBSE(2) + + else + + EcBSE(2) = 0.0d0 end if diff --git a/src/MBPT/print_qsGW.f90 b/src/MBPT/print_qsGW.f90 index df854d6..52702be 100644 --- a/src/MBPT/print_qsGW.f90 +++ b/src/MBPT/print_qsGW.f90 @@ -1,4 +1,4 @@ -subroutine print_qsGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,ENuc,P,T,V,J,K,F,SigC,Z,EcRPA,EqsGW,dipole) +subroutine print_qsGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigC,Z,ENuc,ET,EV,EJ,Ex,EcGM,EcRPA,EqsGW,dipole) ! Print one-electron energies and other stuff for qsGW @@ -7,18 +7,29 @@ subroutine print_qsGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,ENuc,P,T,V,J,K,F,SigC,Z ! Input variables - integer,intent(in) :: nBas,nO,nSCF - double precision,intent(in) :: ENuc,EcRPA,Conv,thresh - double precision,intent(in) :: eHF(nBas),eGW(nBas),c(nBas),P(nBas,nBas) - double precision,intent(in) :: T(nBas,nBas),V(nBas,nBas) - double precision,intent(in) :: J(nBas,nBas),K(nBas,nBas),F(nBas,nBas) - double precision,intent(in) :: Z(nBas),SigC(nBas,nBas) + integer,intent(in) :: nBas + integer,intent(in) :: nO + integer,intent(in) :: nSCF + double precision,intent(in) :: ENuc + double precision,intent(in) :: ET + double precision,intent(in) :: EV + double precision,intent(in) :: EJ + double precision,intent(in) :: Ex + double precision,intent(in) :: EcGM + double precision,intent(in) :: EcRPA + double precision,intent(in) :: Conv + double precision,intent(in) :: thresh + double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: eGW(nBas) + double precision,intent(in) :: c(nBas) + double precision,intent(in) :: SigC(nBas,nBas) + double precision,intent(in) :: Z(nBas) double precision,intent(in) :: dipole(ncart) ! Local variables integer :: x,ixyz,HOMO,LUMO - double precision :: Gap,ET,EV,EJ,Ex,Ec + double precision :: Gap double precision,external :: trace_matrix ! Output variables @@ -33,14 +44,6 @@ subroutine print_qsGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,ENuc,P,T,V,J,K,F,SigC,Z ! Compute energies - ET = trace_matrix(nBas,matmul(P,T)) - EV = trace_matrix(nBas,matmul(P,V)) - EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) - Ex = 0.25d0*trace_matrix(nBas,matmul(P,K)) - Ec = 0d0 -! Ec = -0.50d0*trace_matrix(nBas,matmul(P,SigC)) - EqsGW = ET + EV + EJ + Ex + Ec - ! Dump results write(*,*)'-------------------------------------------------------------------------------' @@ -61,15 +64,15 @@ subroutine print_qsGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,ENuc,P,T,V,J,K,F,SigC,Z write(*,*)'-------------------------------------------------------------------------------' write(*,'(2X,A10,I3)') 'Iteration ',nSCF - write(*,'(2X,A19,F15.5)')'max(|FPS - SPF|) = ',Conv + write(*,'(2X,A14,F15.5)')'Convergence = ',Conv write(*,*)'-------------------------------------------' write(*,'(2X,A30,F15.6,A3)') 'qsGW HOMO energy:',eGW(HOMO)*HaToeV,' eV' write(*,'(2X,A30,F15.6,A3)') 'qsGW LUMO energy:',eGW(LUMO)*HaToeV,' eV' write(*,'(2X,A30,F15.6,A3)') 'qsGW HOMO-LUMO gap :',Gap*HaToeV,' eV' write(*,*)'-------------------------------------------' - write(*,'(2X,A30,F15.6,A3)') ' qsGW total energy:',EqsGW + ENuc,' au' + write(*,'(2X,A30,F15.6,A3)') ' qsGW total energy:',ENuc + EqsGW,' au' write(*,'(2X,A30,F15.6,A3)') ' qsGW exchange energy:',Ex,' au' -! write(*,'(2X,A30,F15.6,A3)') ' qsGW correlation energy:',Ec,' au' + write(*,'(2X,A30,F15.6,A3)') ' GM@qsGW correlation energy:',EcGM,' au' write(*,'(2X,A30,F15.6,A3)') 'RPA@qsGW correlation energy:',EcRPA,' au' write(*,*)'-------------------------------------------' write(*,*) @@ -89,7 +92,7 @@ subroutine print_qsGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,ENuc,P,T,V,J,K,F,SigC,Z write(*,'(A32,1X,F16.10,A3)') ' Two-electron energy: ',EJ + Ex,' au' write(*,'(A32,1X,F16.10,A3)') ' Hartree energy: ',EJ,' au' write(*,'(A32,1X,F16.10,A3)') ' Exchange energy: ',Ex,' au' -! write(*,'(A32,1X,F16.10,A3)') ' Correlation energy: ',Ec,' au' + write(*,'(A32,1X,F16.10,A3)') ' Correlation energy: ',EcGM,' au' write(*,'(A50)') '---------------------------------------' write(*,'(A32,1X,F16.10,A3)') ' Electronic energy: ',EqsGW,' au' write(*,'(A32,1X,F16.10,A3)') ' Nuclear repulsion: ',ENuc,' au' diff --git a/src/MBPT/print_qsUGW.f90 b/src/MBPT/print_qsUGW.f90 index d753e0e..983e148 100644 --- a/src/MBPT/print_qsUGW.f90 +++ b/src/MBPT/print_qsUGW.f90 @@ -1,5 +1,5 @@ subroutine print_qsUGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,cGW,PGW,Ov,T,V,J,K, & - ENuc,ET,EV,EJ,Ex,Ec,EcRPA,EqsGW,SigC,Z,dipole) + ENuc,ET,EV,EJ,Ex,EcGM,EcRPA,EqsGW,SigC,Z,dipole) ! Print one-electron energies and other stuff for qsUGW @@ -16,7 +16,7 @@ subroutine print_qsUGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,cGW,PGW,Ov,T,V,J,K, & double precision,intent(in) :: EV(nspin) double precision,intent(in) :: EJ(nsp) double precision,intent(in) :: Ex(nspin) - double precision,intent(in) :: Ec(nsp) + double precision,intent(in) :: EcGM(nspin) double precision,intent(in) :: EcRPA double precision,intent(in) :: EqsGW double precision,intent(in) :: Conv @@ -92,7 +92,7 @@ subroutine print_qsUGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,cGW,PGW,Ov,T,V,J,K, & write(*,*)'-------------------------------------------------------------------------------& -------------------------------------------------' write(*,'(2X,A10,I3)') 'Iteration ',nSCF - write(*,'(2X,A19,F15.5)')'max(|FPS - SPF|) = ',Conv + write(*,'(2X,A14,F15.5)')'Convergence = ',Conv write(*,*)'-------------------------------------------------------------------------------& -------------------------------------------------' write(*,'(2X,A30,F15.6,A3)') 'qsUGW HOMO energy:',maxval(HOMO(:))*HaToeV,' eV' @@ -100,9 +100,9 @@ subroutine print_qsUGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,cGW,PGW,Ov,T,V,J,K, & write(*,'(2X,A30,F15.6,A3)') 'qsUGW HOMO-LUMO gap :',(minval(LUMO(:))-maxval(HOMO(:)))*HaToeV,' eV' write(*,*)'-------------------------------------------------------------------------------& -------------------------------------------------' - write(*,'(2X,A30,F15.6,A3)') ' qsUGW total energy:',EqsGW + ENuc,' au' + write(*,'(2X,A30,F15.6,A3)') ' qsUGW total energy:',ENuc + EqsGW,' au' write(*,'(2X,A30,F15.6,A3)') ' qsUGW exchange energy:',sum(Ex(:)),' au' -! write(*,'(2X,A30,F15.6,A3)') ' qsUGW correlation energy:',sum(Ec(:)),' au' + write(*,'(2X,A30,F15.6,A3)') ' GM@qsUGW correlation energy:',sum(EcGM(:)),' au' write(*,'(2X,A30,F15.6,A3)') 'RPA@qsUGW correlation energy:',EcRPA,' au' write(*,*)'-------------------------------------------------------------------------------& -------------------------------------------------' @@ -141,15 +141,14 @@ subroutine print_qsUGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,cGW,PGW,Ov,T,V,J,K, & write(*,'(A40,1X,F16.10,A3)') ' Exchange energy: ',sum(Ex(:)),' au' write(*,'(A40,1X,F16.10,A3)') ' Exchange a energy: ',Ex(1),' au' write(*,'(A40,1X,F16.10,A3)') ' Exchange b energy: ',Ex(2),' au' -! write(*,*) -! write(*,'(A40,1X,F16.10,A3)') ' Correlation energy: ',sum(Ec(:)),' au' -! write(*,'(A40,1X,F16.10,A3)') ' Correlation aa energy: ',Ec(1),' au' -! write(*,'(A40,1X,F16.10,A3)') ' Correlation ab energy: ',Ec(2),' au' -! write(*,'(A40,1X,F16.10,A3)') ' Correlation bb energy: ',Ec(3),' au' + write(*,*) + write(*,'(A40,1X,F16.10,A3)') ' Correlation energy: ',sum(EcGM(:)),' au' + write(*,'(A40,1X,F16.10,A3)') ' Correlation aa energy: ',EcGM(1),' au' + write(*,'(A40,1X,F16.10,A3)') ' Correlation bb energy: ',EcGM(2),' au' write(*,'(A60)') '-------------------------------------------------' write(*,'(A40,1X,F16.10,A3)') ' Electronic energy: ',EqsGW,' au' write(*,'(A40,1X,F16.10,A3)') ' Nuclear repulsion: ',ENuc,' au' - write(*,'(A40,1X,F16.10,A3)') ' qsUGW energy: ',EqsGW + ENuc,' au' + write(*,'(A40,1X,F16.10,A3)') ' qsUGW energy: ',ENuc + EqsGW,' au' write(*,'(A60)') '-------------------------------------------------' write(*,'(A40,F13.6)') ' S (exact) :',2d0*S_exact + 1d0 write(*,'(A40,F13.6)') ' S :',2d0*S + 1d0 diff --git a/src/MBPT/qsGW.f90 b/src/MBPT/qsGW.f90 index e906391..60f2d09 100644 --- a/src/MBPT/qsGW.f90 +++ b/src/MBPT/qsGW.f90 @@ -55,6 +55,10 @@ subroutine qsGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE integer :: nBasSq integer :: ispin integer :: n_diis + double precision :: ET + double precision :: EV + double precision :: EJ + double precision :: Ex double precision :: EqsGW double precision :: EcRPA double precision :: EcBSE(nspin) @@ -65,6 +69,7 @@ subroutine qsGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE double precision,external :: trace_matrix double precision :: dipole(ncart) + logical :: print_W = .true. double precision,allocatable :: error_diis(:,:) double precision,allocatable :: F_diis(:,:) double precision,allocatable :: OmRPA(:) @@ -74,6 +79,7 @@ subroutine qsGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE double precision,allocatable :: c(:,:) double precision,allocatable :: cp(:,:) double precision,allocatable :: eGW(:) + double precision,allocatable :: eOld(:) double precision,allocatable :: P(:,:) double precision,allocatable :: F(:,:) double precision,allocatable :: Fp(:,:) @@ -132,9 +138,9 @@ subroutine qsGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE ! Memory allocation - allocate(eGW(nBas),c(nBas,nBas),cp(nBas,nBas),P(nBas,nBas),F(nBas,nBas),Fp(nBas,nBas), & - J(nBas,nBas),K(nBas,nBas),SigC(nBas,nBas),SigCp(nBas,nBas),SigCm(nBas,nBas),Z(nBas), & - OmRPA(nS),XpY_RPA(nS,nS),XmY_RPA(nS,nS),rho_RPA(nBas,nBas,nS), & + allocate(eGW(nBas),eOld(nBas),c(nBas,nBas),cp(nBas,nBas),P(nBas,nBas),F(nBas,nBas),Fp(nBas,nBas), & + J(nBas,nBas),K(nBas,nBas),SigC(nBas,nBas),SigCp(nBas,nBas),SigCm(nBas,nBas),Z(nBas), & + OmRPA(nS),XpY_RPA(nS,nS),XmY_RPA(nS,nS),rho_RPA(nBas,nBas,nS), & error(nBas,nBas),error_diis(nBasSq,max_diis),F_diis(nBasSq,max_diis)) ! Initialization @@ -145,9 +151,11 @@ subroutine qsGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE Conv = 1d0 P(:,:) = PHF(:,:) eGW(:) = eHF(:) + eOld(:) = eHF(:) c(:,:) = cHF(:,:) F_diis(:,:) = 0d0 error_diis(:,:) = 0d0 + rcond = 1d0 !------------------------------------------------------------------------ ! Main loop @@ -177,6 +185,7 @@ subroutine qsGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE call linear_response(ispin,.true.,TDA_W,.false.,eta,nBas,nC,nO,nV,nR,nS,1d0,eGW,ERI_MO, & OmRPA,rho_RPA,EcRPA,OmRPA,XpY_RPA,XmY_RPA) + if(print_W) call print_excitation('RPA@qsGW ',ispin,nS,OmRPA) endif @@ -210,16 +219,15 @@ subroutine qsGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE ! Compute commutator and convergence criteria error = matmul(F,matmul(P,S)) - matmul(matmul(S,P),F) - Conv = maxval(abs(error)) ! DIIS extrapolation n_diis = min(n_diis+1,max_diis) - call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) - -! Reset DIIS if required - - if(abs(rcond) < 1d-15) n_diis = 0 + if(abs(rcond) > 1d-7) then + call DIIS_extrapolation(rcond,nBasSq,nBasSq,n_diis,error_diis,F_diis,error,F) + else + n_diis = 0 + end if ! Diagonalize Hamiltonian in AO basis @@ -227,15 +235,45 @@ subroutine qsGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOSE cp(:,:) = Fp(:,:) call diagonalize_matrix(nBas,cp,eGW) c = matmul(X,cp) + SigCp = matmul(transpose(c),matmul(SigCp,c)) ! Compute new density matrix in the AO basis P(:,:) = 2d0*matmul(c(:,1:nO),transpose(c(:,1:nO))) + ! Save quasiparticles energy for next cycle + + Conv = maxval(abs(eGW - eOld)) + eOld(:) = eGW(:) + + !------------------------------------------------------------------------ + ! Compute total energy + !------------------------------------------------------------------------ + + ! Kinetic energy + + ET = trace_matrix(nBas,matmul(P,T)) + + ! Potential energy + + EV = trace_matrix(nBas,matmul(P,V)) + + ! Coulomb energy + + EJ = 0.5d0*trace_matrix(nBas,matmul(P,J)) + + ! Exchange energy + + Ex = 0.25d0*trace_matrix(nBas,matmul(P,K)) + + ! Total energy + + EqsGW = ET + EV + EJ + Ex + ! Print results call dipole_moment(nBas,P,nNuc,ZNuc,rNuc,dipole_int_AO,dipole) - call print_qsGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,ENuc,P,T,V,J,K,F,SigCp,Z,EcRPA,EqsGW,dipole) + call print_qsGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,SigCp,Z,ENuc,ET,EV,EJ,Ex,EcGM,EcRPA,EqsGW,dipole) enddo !------------------------------------------------------------------------ diff --git a/src/MBPT/qsUGW.f90 b/src/MBPT/qsUGW.f90 index 2128d0f..0718811 100644 --- a/src/MBPT/qsUGW.f90 +++ b/src/MBPT/qsUGW.f90 @@ -75,8 +75,8 @@ subroutine qsUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOS double precision :: EV(nspin) double precision :: EJ(nsp) double precision :: Ex(nspin) - double precision :: Ec(nsp) double precision :: EcRPA + double precision :: EcGM(nspin) double precision :: EqsGW double precision :: EcBSE(nspin) double precision :: EcAC(nspin) @@ -92,6 +92,7 @@ subroutine qsUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOS double precision,allocatable :: c(:,:,:) double precision,allocatable :: cp(:,:,:) double precision,allocatable :: eGW(:,:) + double precision,allocatable :: eOld(:,:) double precision,allocatable :: P(:,:,:) double precision,allocatable :: F(:,:,:) double precision,allocatable :: Fp(:,:,:) @@ -154,10 +155,11 @@ subroutine qsUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOS nS_bb = nS(2) nS_sc = nS_aa + nS_bb - allocate(eGW(nBas,nspin),c(nBas,nBas,nspin),cp(nBas,nBas,nspin),P(nBas,nBas,nspin),F(nBas,nBas,nspin),Fp(nBas,nBas,nspin), & - J(nBas,nBas,nspin),K(nBas,nBas,nspin),SigC(nBas,nBas,nspin),SigCp(nBas,nBas,nspin),SigCm(nBas,nBas,nspin), & - Z(nBas,nspin),OmRPA(nS_sc),XpY_RPA(nS_sc,nS_sc),XmY_RPA(nS_sc,nS_sc),rho_RPA(nBas,nBas,nS_sc,nspin), & - error(nBas,nBas,nspin),error_diis(nBasSq,max_diis,nspin),F_diis(nBasSq,max_diis,nspin)) + allocate(eGW(nBas,nspin),eOld(nBas,nspin),c(nBas,nBas,nspin),cp(nBas,nBas,nspin),P(nBas,nBas,nspin),F(nBas,nBas,nspin), & + Fp(nBas,nBas,nspin),J(nBas,nBas,nspin),K(nBas,nBas,nspin),SigC(nBas,nBas,nspin),SigCp(nBas,nBas,nspin), & + SigCm(nBas,nBas,nspin),Z(nBas,nspin),OmRPA(nS_sc),XpY_RPA(nS_sc,nS_sc),XmY_RPA(nS_sc,nS_sc), & + rho_RPA(nBas,nBas,nS_sc,nspin),error(nBas,nBas,nspin),error_diis(nBasSq,max_diis,nspin), & + F_diis(nBasSq,max_diis,nspin)) ! Initialization @@ -167,9 +169,11 @@ subroutine qsUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOS Conv = 1d0 P(:,:,:) = PHF(:,:,:) eGW(:,:) = eHF(:,:) + eOld(:,:) = eHF(:,:) c(:,:,:) = cHF(:,:,:) F_diis(:,:,:) = 0d0 error_diis(:,:,:) = 0d0 + rcond = 1d0 !------------------------------------------------------------------------ ! Main loop @@ -230,12 +234,12 @@ subroutine qsUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOS if(G0W) then - call unrestricted_self_energy_correlation(eta,nBas,nC,nO,nV,nR,nS_sc,eHF,OmRPA,rho_RPA,SigC) + call unrestricted_self_energy_correlation(eta,nBas,nC,nO,nV,nR,nS_sc,eHF,OmRPA,rho_RPA,SigC,EcGM) call unrestricted_renormalization_factor(eta,nBas,nC,nO,nV,nR,nS_sc,eHF,OmRPA,rho_RPA,Z) else - call unrestricted_self_energy_correlation(eta,nBas,nC,nO,nV,nR,nS_sc,eGW,OmRPA,rho_RPA,SigC) + call unrestricted_self_energy_correlation(eta,nBas,nC,nO,nV,nR,nS_sc,eGW,OmRPA,rho_RPA,SigC,EcGM) call unrestricted_renormalization_factor(eta,nBas,nC,nO,nV,nR,nS_sc,eGW,OmRPA,rho_RPA,Z) endif @@ -268,14 +272,14 @@ subroutine qsUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOS ! DIIS extrapolation n_diis = min(n_diis+1,max_diis) - do is=1,nspin - if(nO(is) > 1) call DIIS_extrapolation(rcond(is),nBasSq,nBasSq,n_diis,error_diis(:,1:n_diis,is), & - F_diis(:,1:n_diis,is),error(:,:,is),F(:,:,is)) - end do - - ! Reset DIIS if required - - if(minval(rcond(:)) < 1d-15) n_diis = 0 + if(minval(rcond(:)) > 1d-7) then + do is=1,nspin + if(nO(is) > 1) call DIIS_extrapolation(rcond(is),nBasSq,nBasSq,n_diis,error_diis(:,1:n_diis,is), & + F_diis(:,1:n_diis,is),error(:,:,is),F(:,:,is)) + end do + else + n_diis = 0 + end if ! Transform Fock matrix in orthogonal basis @@ -296,12 +300,23 @@ subroutine qsUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOS c(:,:,is) = matmul(X(:,:),cp(:,:,is)) end do + ! Back-transform self-energy + + do is=1,nspin + SigCp(:,:,is) = matmul(transpose(c(:,:,is)),matmul(SigCp(:,:,is),c(:,:,is))) + end do + ! Compute density matrix do is=1,nspin P(:,:,is) = matmul(c(:,1:nO(is),is),transpose(c(:,1:nO(is),is))) end do + ! Save quasiparticles energy for next cycle + + Conv = maxval(abs(eGW(:,:) - eOld(:,:))) + eOld(:,:) = eGW(:,:) + !------------------------------------------------------------------------ ! Compute total energy !------------------------------------------------------------------------ @@ -321,7 +336,8 @@ subroutine qsUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOS ! Coulomb energy EJ(1) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,1),J(:,:,1))) - EJ(2) = 1.0d0*trace_matrix(nBas,matmul(P(:,:,1),J(:,:,2))) + EJ(2) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,1),J(:,:,2))) & + + 0.5d0*trace_matrix(nBas,matmul(P(:,:,2),J(:,:,1))) EJ(3) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,2),J(:,:,2))) ! Exchange energy @@ -330,25 +346,16 @@ subroutine qsUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOS Ex(is) = 0.5d0*trace_matrix(nBas,matmul(P(:,:,is),K(:,:,is))) end do - ! Correlation energy - - Ec(:) = 0d0 - -! Ec(1) = - 0.25d0*trace_matrix(nBas,matmul(P(:,:,1),SigCp(:,:,1))) -! Ec(2) = - 0.25d0*trace_matrix(nBas,matmul(P(:,:,1),SigCp(:,:,2))) & -! - 0.25d0*trace_matrix(nBas,matmul(P(:,:,2),SigCp(:,:,1))) -! Ec(3) = - 0.25d0*trace_matrix(nBas,matmul(P(:,:,2),SigCp(:,:,2))) - ! Total energy - EqsGW = sum(ET(:)) + sum(EV(:)) + sum(EJ(:)) + sum(Ex(:)) + sum(Ec(:)) + EqsGW = sum(ET(:)) + sum(EV(:)) + sum(EJ(:)) + sum(Ex(:)) !------------------------------------------------------------------------ ! Print results !------------------------------------------------------------------------ call dipole_moment(nBas,P(:,:,1)+P(:,:,2),nNuc,ZNuc,rNuc,dipole_int_AO,dipole) - call print_qsUGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,P,S,T,V,J,K,ENuc,ET,EV,EJ,Ex,Ec,EcRPA,EqsGW,SigCp,Z,dipole) + call print_qsUGW(nBas,nO,nSCF,Conv,thresh,eHF,eGW,c,P,S,T,V,J,K,ENuc,ET,EV,EJ,Ex,EcGM,EcRPA,EqsGW,SigCp,Z,dipole) enddo !------------------------------------------------------------------------ @@ -375,19 +382,23 @@ subroutine qsUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOS ! Deallocate memory - deallocate(c,cp,P,F,Fp,J,K,SigC,SigCp,SigCm,Z,OmRPA,XpY_RPA,XmY_RPA,rho_RPA,error,error_diis,F_diis) + deallocate(cp,P,F,Fp,J,K,SigC,SigCp,SigCm,Z,OmRPA,XpY_RPA,XmY_RPA,rho_RPA,error,error_diis,F_diis) ! Perform BSE calculation if(BSE) then call unrestricted_Bethe_Salpeter(TDA_W,TDA,dBSE,dTDA,evDyn,spin_conserved,spin_flip,eta,nBas,nC,nO,nV,nR,nS, & - S,ERI_aaaa,ERI_aabb,ERI_bbbb,dipole_int_aa,dipole_int_bb,cHF,eGW,eGW,EcBSE) + S,ERI_aaaa,ERI_aabb,ERI_bbbb,dipole_int_aa,dipole_int_bb,c,eGW,eGW,EcBSE) if(exchange_kernel) then EcBSE(1) = 0.5d0*EcBSE(1) - EcBSE(2) = 1.5d0*EcBSE(2) + EcBSE(2) = 0.5d0*EcBSE(2) + + else + + EcBSE(2) = 0.0d0 end if @@ -396,7 +407,7 @@ subroutine qsUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOS write(*,'(2X,A50,F20.10)') 'Tr@BSE@qsUGW correlation energy (spin-conserved) =',EcBSE(1) write(*,'(2X,A50,F20.10)') 'Tr@BSE@qsUGW correlation energy (spin-flip) =',EcBSE(2) write(*,'(2X,A50,F20.10)') 'Tr@BSE@qsUGW correlation energy =',EcBSE(1) + EcBSE(2) - write(*,'(2X,A50,F20.10)') 'Tr@BSE@qsUGW total energy =',ENuc + EUHF + EcBSE(1) + EcBSE(2) + write(*,'(2X,A50,F20.10)') 'Tr@BSE@qsUGW total energy =',ENuc + EqsGW + EcBSE(1) + EcBSE(2) write(*,*)'-------------------------------------------------------------------------------' write(*,*) @@ -424,7 +435,7 @@ subroutine qsUGW(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,COHSEX,SOS write(*,'(2X,A50,F20.10)') 'AC@BSE@qsUGW correlation energy (spin-conserved) =',EcAC(1) write(*,'(2X,A50,F20.10)') 'AC@BSE@qsUGW correlation energy (spin-flip) =',EcAC(2) write(*,'(2X,A50,F20.10)') 'AC@BSE@qsUGW correlation energy =',EcAC(1) + EcAC(2) - write(*,'(2X,A50,F20.10)') 'AC@BSE@qsUGW total energy =',ENuc + EUHF + EcAC(1) + EcAC(2) + write(*,'(2X,A50,F20.10)') 'AC@BSE@qsUGW total energy =',ENuc + EqsGW + EcAC(1) + EcAC(2) write(*,*)'-------------------------------------------------------------------------------' write(*,*) diff --git a/src/MBPT/self_energy_correlation.f90 b/src/MBPT/self_energy_correlation.f90 index e47a9b4..369ee32 100644 --- a/src/MBPT/self_energy_correlation.f90 +++ b/src/MBPT/self_energy_correlation.f90 @@ -16,7 +16,9 @@ subroutine self_energy_correlation(COHSEX,eta,nBas,nC,nO,nV,nR,nS,e,Omega,rho,Ec ! Local variables - integer :: i,j,a,b,p,x,y,jb + integer :: i,j,a,b + integer :: p,q,r + integer :: jb double precision :: eps ! Output variables @@ -26,7 +28,7 @@ subroutine self_energy_correlation(COHSEX,eta,nBas,nC,nO,nV,nR,nS,e,Omega,rho,Ec ! Initialize - SigC = 0d0 + SigC(:,:) = 0d0 !-----------------------------! ! COHSEX static approximation ! @@ -36,32 +38,32 @@ subroutine self_energy_correlation(COHSEX,eta,nBas,nC,nO,nV,nR,nS,e,Omega,rho,Ec ! COHSEX: SEX of the COHSEX correlation self-energy - do x=nC+1,nBas-nR - do y=nC+1,nBas-nR + do p=nC+1,nBas-nR + do q=nC+1,nBas-nR do i=nC+1,nO do jb=1,nS - SigC(x,y) = SigC(x,y) + 4d0*rho(x,i,jb)*rho(y,i,jb)/Omega(jb) - enddo - enddo - enddo - enddo + SigC(p,q) = SigC(p,q) + 4d0*rho(p,i,jb)*rho(q,i,jb)/Omega(jb) + end do + end do + end do + end do ! COHSEX: COH part of the COHSEX correlation self-energy - do x=nC+1,nBas-nR - do y=nC+1,nBas-nR - do p=nC+1,nBas-nR + do p=nC+1,nBas-nR + do q=nC+1,nBas-nR + do r=nC+1,nBas-nR do jb=1,nS - SigC(x,y) = SigC(x,y) - 2d0*rho(x,p,jb)*rho(y,p,jb)/Omega(jb) - enddo - enddo - enddo - enddo + SigC(p,q) = SigC(p,q) - 2d0*rho(p,r,jb)*rho(q,r,jb)/Omega(jb) + end do + end do + end do + end do EcGM = 0d0 do i=nC+1,nO EcGM = EcGM + 0.5d0*SigC(i,i) - enddo + end do else @@ -71,30 +73,42 @@ subroutine self_energy_correlation(COHSEX,eta,nBas,nC,nO,nV,nR,nS,e,Omega,rho,Ec ! Occupied part of the correlation self-energy - do x=nC+1,nBas-nR - do y=nC+1,nBas-nR + do p=nC+1,nBas-nR + do q=nC+1,nBas-nR do i=nC+1,nO do jb=1,nS - eps = e(x) - e(i) + Omega(jb) - SigC(x,y) = SigC(x,y) + 2d0*rho(x,i,jb)*rho(y,i,jb)*eps/(eps**2 + eta**2) - enddo - enddo - enddo - enddo + eps = e(p) - e(i) + Omega(jb) + SigC(p,q) = SigC(p,q) + 2d0*rho(p,i,jb)*rho(q,i,jb)*eps/(eps**2 + eta**2) + end do + end do + end do + end do ! Virtual part of the correlation self-energy - do x=nC+1,nBas-nR - do y=nC+1,nBas-nR + do p=nC+1,nBas-nR + do q=nC+1,nBas-nR do a=nO+1,nBas-nR do jb=1,nS - eps = e(x) - e(a) - Omega(jb) - SigC(x,y) = SigC(x,y) + 2d0*rho(x,a,jb)*rho(y,a,jb)*eps/(eps**2 + eta**2) - enddo - enddo - enddo - enddo + eps = e(p) - e(a) - Omega(jb) + SigC(p,q) = SigC(p,q) + 2d0*rho(p,a,jb)*rho(q,a,jb)*eps/(eps**2 + eta**2) + end do + end do + end do + end do - endif + ! GM correlation energy + + EcGM = 0d0 + do i=nC+1,nO + do a=nO+1,nBas-nR + do jb=1,nS + eps = e(a) - e(i) + Omega(jb) + EcGM = EcGM - 4d0*rho(a,i,jb)*rho(a,i,jb)*eps/(eps**2 + eta**2) + end do + end do + end do + + end if end subroutine self_energy_correlation diff --git a/src/MBPT/self_energy_exchange.f90 b/src/MBPT/self_energy_exchange.f90 index 26db034..09653f6 100644 --- a/src/MBPT/self_energy_exchange.f90 +++ b/src/MBPT/self_energy_exchange.f90 @@ -1,4 +1,4 @@ -subroutine self_energy_exchange(nBas,c,P,G,SigmaX) +subroutine self_energy_exchange(nBas,c,P,ERI,SigX) ! Compute exchange part of the self-energy @@ -8,18 +8,18 @@ subroutine self_energy_exchange(nBas,c,P,G,SigmaX) ! Input variables integer,intent(in) :: nBas - double precision,intent(in) :: c(nBas,nBas),P(nBas,nBas),G(nBas,nBas,nBas,nBas) + double precision,intent(in) :: c(nBas,nBas),P(nBas,nBas),ERI(nBas,nBas,nBas,nBas) ! Output variables - double precision,intent(out) :: SigmaX(nBas,nBas) + double precision,intent(out) :: SigX(nBas,nBas) ! Compute exchange part of the self-energy in the AO basis - call exchange_matrix_AO_basis(nBas,P,G,SigmaX) + call exchange_matrix_AO_basis(nBas,P,ERI,SigX) ! Compute exchange part of the self-energy in the MO basis - SigmaX = matmul(transpose(c),matmul(SigmaX,c)) + SigX = matmul(transpose(c),matmul(SigX,c)) end subroutine self_energy_exchange diff --git a/src/MBPT/self_energy_exchange_diag.f90 b/src/MBPT/self_energy_exchange_diag.f90 new file mode 100644 index 0000000..0e305b7 --- /dev/null +++ b/src/MBPT/self_energy_exchange_diag.f90 @@ -0,0 +1,42 @@ +subroutine self_energy_exchange_diag(nBas,c,P,ERI,SigX) + +! Compute the diagonal elements of the exchange part of the self-energy + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: c(nBas,nBas) + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + +! Local variables + + integer :: q,mu,nu + double precision,allocatable :: Fx(:,:) + +! Output variables + + double precision,intent(out) :: SigX(nBas) + +! Compute exchange part of the self-energy in the AO basis + + allocate(Fx(nBas,nBas)) + call exchange_matrix_AO_basis(nBas,P,ERI,Fx) + +! Compute exchange part of the self-energy in the MO basis + + SigX(:) = 0d0 + do q=1,nBas + do mu=1,nBas + do nu=1,nBas + SigX(q) = SigX(q) + c(mu,q)*Fx(mu,nu)*c(nu,q) + end do + end do + end do + + deallocate(Fx) + +end subroutine self_energy_exchange_diag diff --git a/src/MBPT/static_screening_WA.f90 b/src/MBPT/static_screening_WA.f90 new file mode 100644 index 0000000..dff07d7 --- /dev/null +++ b/src/MBPT/static_screening_WA.f90 @@ -0,0 +1,53 @@ +subroutine static_screening_WA(eta,nBas,nC,nO,nV,nR,nS,lambda,ERI,Omega,rho,WA) + +! Compute the OOVV block of the static screening W for the resonant block + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: eta + double precision,intent(in) :: lambda + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: Omega(nS) + double precision,intent(in) :: rho(nBas,nBas,nS) + +! Local variables + + double precision :: chi + double precision :: eps + integer :: i,j,a,b,ia,jb,kc + +! Output variables + + double precision,intent(out) :: WA(nS,nS) + +! Initialize + + WA(:,:) = 0d0 + + ia = 0 + do i=nC+1,nO + do a=nO+1,nBas-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + + chi = 0d0 + do kc=1,nS + eps = Omega(kc)**2 + eta**2 + chi = chi + rho(i,j,kc)*rho(a,b,kc)*Omega(kc)/eps + enddo + + WA(ia,jb) = WA(ia,jb) + lambda*ERI(i,b,j,a) - 4d0*lambda*chi + + enddo + enddo + enddo + enddo + +end subroutine static_screening_WA diff --git a/src/MBPT/static_screening_WB.f90 b/src/MBPT/static_screening_WB.f90 new file mode 100644 index 0000000..4419660 --- /dev/null +++ b/src/MBPT/static_screening_WB.f90 @@ -0,0 +1,53 @@ +subroutine static_screening_WB(eta,nBas,nC,nO,nV,nR,nS,lambda,ERI,Omega,rho,WB) + +! Compute the static screening W for the coupling block + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas,nC,nO,nV,nR,nS + double precision,intent(in) :: eta + double precision,intent(in) :: lambda + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: Omega(nS) + double precision,intent(in) :: rho(nBas,nBas,nS) + +! Local variables + + double precision :: chi + double precision :: eps + integer :: i,j,a,b,ia,jb,kc + +! Output variables + + double precision,intent(out) :: WB(nS,nS) + +! Initialize + + WB(:,:) = 0d0 + + ia = 0 + do i=nC+1,nO + do a=nO+1,nBas-nR + ia = ia + 1 + jb = 0 + do j=nC+1,nO + do b=nO+1,nBas-nR + jb = jb + 1 + + chi = 0d0 + do kc=1,nS + eps = Omega(kc)**2 + eta**2 + chi = chi + rho(i,b,kc)*rho(a,j,kc)*Omega(kc)/eps + enddo + + WB(ia,jb) = WB(ia,jb) + lambda*ERI(i,j,b,a) - 4d0*lambda*chi + + enddo + enddo + enddo + enddo + +end subroutine static_screening_WB diff --git a/src/MBPT/unrestricted_Bethe_Salpeter.f90 b/src/MBPT/unrestricted_Bethe_Salpeter.f90 index 5b0436b..a483c0e 100644 --- a/src/MBPT/unrestricted_Bethe_Salpeter.f90 +++ b/src/MBPT/unrestricted_Bethe_Salpeter.f90 @@ -112,7 +112,7 @@ subroutine unrestricted_Bethe_Salpeter(TDA_W,TDA,dBSE,dTDA,evDyn,spin_conserved, if(dBSE) & call unrestricted_Bethe_Salpeter_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO,nV,nR,nS,nS_aa,nS_bb,nS_sc,nS_sc, & - eGW,ERI_aaaa,ERI_aabb,ERI_bbbb,dipole_int_aa,dipole_int_bb, & + eW,eGW,ERI_aaaa,ERI_aabb,ERI_bbbb,dipole_int_aa,dipole_int_bb, & OmRPA,rho_RPA,OmBSE_sc,XpY_BSE_sc,XmY_BSE_sc) deallocate(OmBSE_sc,XpY_BSE_sc,XmY_BSE_sc) @@ -148,7 +148,7 @@ subroutine unrestricted_Bethe_Salpeter(TDA_W,TDA,dBSE,dTDA,evDyn,spin_conserved, if(dBSE) & call unrestricted_Bethe_Salpeter_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO,nV,nR,nS,nS_ab,nS_ba,nS_sf,nS_sc, & - eGW,ERI_aaaa,ERI_aabb,ERI_bbbb,dipole_int_aa,dipole_int_bb, & + eW,eGW,ERI_aaaa,ERI_aabb,ERI_bbbb,dipole_int_aa,dipole_int_bb, & OmRPA,rho_RPA,OmBSE_sf,XpY_BSE_sf,XmY_BSE_sf) deallocate(OmBSE_sf,XpY_BSE_sf,XmY_BSE_sf) diff --git a/src/MBPT/unrestricted_Bethe_Salpeter_dynamic_perturbation.f90 b/src/MBPT/unrestricted_Bethe_Salpeter_dynamic_perturbation.f90 index 4bb3cd7..56a8ed9 100644 --- a/src/MBPT/unrestricted_Bethe_Salpeter_dynamic_perturbation.f90 +++ b/src/MBPT/unrestricted_Bethe_Salpeter_dynamic_perturbation.f90 @@ -1,5 +1,5 @@ -subroutine unrestricted_Bethe_Salpeter_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO,nV,nR,nS,nSa,nSb,nSt,nS_sc,eGW, & - ERI_aaaa,ERI_aabb,ERI_bbbb,dipole_int_aa,dipole_int_bb, & +subroutine unrestricted_Bethe_Salpeter_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO,nV,nR,nS,nSa,nSb,nSt,nS_sc,eW,eGW, & + ERI_aaaa,ERI_aabb,ERI_bbbb,dipole_int_aa,dipole_int_bb, & OmRPA,rho_RPA,OmBSE,XpY_BSE,XmY_BSE) ! Compute dynamical effects via perturbation theory for BSE @@ -23,6 +23,7 @@ subroutine unrestricted_Bethe_Salpeter_dynamic_perturbation(ispin,dTDA,eta,nBas, integer,intent(in) :: nSt integer,intent(in) :: nS_sc + double precision,intent(in) :: eW(nBas,nspin) double precision,intent(in) :: eGW(nBas,nspin) double precision,intent(in) :: ERI_aaaa(nBas,nBas,nBas,nBas) double precision,intent(in) :: ERI_aabb(nBas,nBas,nBas,nBas) diff --git a/src/MBPT/unrestricted_QP_graph.f90 b/src/MBPT/unrestricted_QP_graph.f90 index 96585a9..14b7653 100644 --- a/src/MBPT/unrestricted_QP_graph.f90 +++ b/src/MBPT/unrestricted_QP_graph.f90 @@ -1,4 +1,4 @@ -subroutine unrestricted_QP_graph(nBas,nC,nO,nV,nR,nS,eta,eHF,Omega,rho,eGWlin,eGW) +subroutine unrestricted_QP_graph(nBas,nC,nO,nV,nR,nS,eta,eHF,SigX,Vxc,Omega,rho,eGWlin,eGW) ! Compute the graphical solution of the QP equation @@ -15,6 +15,8 @@ subroutine unrestricted_QP_graph(nBas,nC,nO,nV,nR,nS,eta,eHF,Omega,rho,eGWlin,eG integer,intent(in) :: nS double precision,intent(in) :: eta double precision,intent(in) :: eHF(nBas) + double precision,intent(in) :: SigX(nBas) + double precision,intent(in) :: Vxc(nBas) double precision,intent(in) :: Omega(nS) double precision,intent(in) :: rho(nBas,nBas,nS,nspin) @@ -27,7 +29,7 @@ subroutine unrestricted_QP_graph(nBas,nC,nO,nV,nR,nS,eta,eHF,Omega,rho,eGWlin,eG integer,parameter :: maxIt = 10 double precision,parameter :: thresh = 1d-6 double precision,external :: USigmaC,dUSigmaC - double precision :: sig,dsig + double precision :: sigC,dsigC double precision :: f,df double precision :: w @@ -52,14 +54,14 @@ subroutine unrestricted_QP_graph(nBas,nC,nO,nV,nR,nS,eta,eHF,Omega,rho,eGWlin,eG nIt = nIt + 1 - sig = USigmaC(p,w,eta,nBas,nC,nO,nV,nR,nS,eHF,Omega,rho) - dsig = dUSigmaC(p,w,eta,nBas,nC,nO,nV,nR,nS,eHF,Omega,rho) - f = w - eHF(p) - sig - df = 1d0 - dsig + sigC = USigmaC(p,w,eta,nBas,nC,nO,nV,nR,nS,eHF,Omega,rho) + dsigC = dUSigmaC(p,w,eta,nBas,nC,nO,nV,nR,nS,eHF,Omega,rho) + f = w - eHF(p) - SigX(p) + Vxc(p) - sigC + df = 1d0 - dsigC w = w - f/df - write(*,'(A3,I3,A1,1X,3F15.9)') 'It.',nIt,':',w*HaToeV,f,sig + write(*,'(A3,I3,A1,1X,3F15.9)') 'It.',nIt,':',w*HaToeV,f,sigC end do diff --git a/src/MBPT/unrestricted_self_energy_correlation.f90 b/src/MBPT/unrestricted_self_energy_correlation.f90 index 1fa2f5b..d6c5f98 100644 --- a/src/MBPT/unrestricted_self_energy_correlation.f90 +++ b/src/MBPT/unrestricted_self_energy_correlation.f90 @@ -1,4 +1,4 @@ -subroutine unrestricted_self_energy_correlation(eta,nBas,nC,nO,nV,nR,nSt,e,Omega,rho,SigC) +subroutine unrestricted_self_energy_correlation(eta,nBas,nC,nO,nV,nR,nSt,e,Omega,rho,SigC,EcGM) ! Compute diagonal of the correlation part of the self-energy @@ -26,10 +26,12 @@ subroutine unrestricted_self_energy_correlation(eta,nBas,nC,nO,nV,nR,nSt,e,Omega ! Output variables double precision,intent(out) :: SigC(nBas,nBas,nspin) + double precision :: EcGM(nspin) ! Initialize SigC(:,:,:) = 0d0 + EcGM(:) = 0d0 !--------------! ! Spin-up part ! @@ -61,6 +63,17 @@ subroutine unrestricted_self_energy_correlation(eta,nBas,nC,nO,nV,nR,nSt,e,Omega end do end do + ! GM correlation energy + + do i=nC(1)+1,nO(1) + do a=nO(1)+1,nBas-nR(1) + do jb=1,nSt + eps = e(a,1) - e(i,1) + Omega(jb) + EcGM(1) = EcGM(1) - rho(a,i,jb,1)**2*eps/(eps**2 + eta**2) + end do + end do + end do + !----------------! ! Spin-down part ! !----------------! @@ -91,4 +104,15 @@ subroutine unrestricted_self_energy_correlation(eta,nBas,nC,nO,nV,nR,nSt,e,Omega end do end do + ! GM correlation energy + + do i=nC(2)+1,nO(2) + do a=nO(2)+1,nBas-nR(2) + do jb=1,nSt + eps = e(a,2) - e(i,2) + Omega(jb) + EcGM(2) = EcGM(2) - rho(a,i,jb,2)**2*eps/(eps**2 + eta**2) + end do + end do + end do + end subroutine unrestricted_self_energy_correlation diff --git a/src/MP/MP2.f90 b/src/MP/MP2.f90 index 2c6d75c..7dd921f 100644 --- a/src/MP/MP2.f90 +++ b/src/MP/MP2.f90 @@ -6,9 +6,15 @@ subroutine MP2(nBas,nC,nO,nV,nR,ERI,ENuc,EHF,e,EcMP2) ! Input variables - integer,intent(in) :: nBas,nC,nO,nV,nR - double precision,intent(in) :: ENuc,EHF - double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas),e(nBas) + integer,intent(in) :: nBas + integer,intent(in) :: nC + integer,intent(in) :: nO + integer,intent(in) :: nV + integer,intent(in) :: nR + double precision,intent(in) :: ENuc + double precision,intent(in) :: EHF + double precision,intent(in) :: e(nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) ! Local variables @@ -17,7 +23,7 @@ subroutine MP2(nBas,nC,nO,nV,nR,ERI,ENuc,EHF,e,EcMP2) ! Output variables - double precision,intent(out) :: EcMP2(3) + double precision,intent(out) :: EcMP2 ! Hello world @@ -51,20 +57,18 @@ subroutine MP2(nBas,nC,nO,nV,nR,ERI,ENuc,EHF,e,EcMP2) enddo enddo - EcMP2(2) = 2d0*E2a - EcMP2(3) = -E2b - EcMP2(1) = EcMP2(2) + EcMP2(3) + EcMP2 = 2d0*E2a - E2b write(*,*) write(*,'(A32)') '--------------------------' write(*,'(A32)') ' MP2 calculation ' write(*,'(A32)') '--------------------------' - write(*,'(A32,1X,F16.10)') ' MP2 correlation energy = ',EcMP2(1) - write(*,'(A32,1X,F16.10)') ' Direct part = ',EcMP2(2) - write(*,'(A32,1X,F16.10)') ' Exchange part = ',EcMP2(3) + write(*,'(A32,1X,F16.10)') ' MP2 correlation energy = ',EcMP2 + write(*,'(A32,1X,F16.10)') ' Direct part = ',2d0*E2a + write(*,'(A32,1X,F16.10)') ' Exchange part = ',-E2b write(*,'(A32)') '--------------------------' - write(*,'(A32,1X,F16.10)') ' MP2 electronic energy = ',EHF + EcMP2(1) - write(*,'(A32,1X,F16.10)') ' MP2 total energy = ',ENuc + EHF + EcMP2(1) + write(*,'(A32,1X,F16.10)') ' MP2 electronic energy = ',EHF + EcMP2 + write(*,'(A32,1X,F16.10)') ' MP2 total energy = ',ENuc + EHF + EcMP2 write(*,'(A32)') '--------------------------' write(*,*) diff --git a/src/MP/UMP2.f90 b/src/MP/UMP2.f90 index 674eae9..acdfbd2 100644 --- a/src/MP/UMP2.f90 +++ b/src/MP/UMP2.f90 @@ -32,7 +32,7 @@ subroutine UMP2(nBas,nC,nO,nV,nR,ERI_aa,ERI_ab,ERI_bb,ENuc,EHF,e,Ec) ! Output variables - double precision,intent(out) :: Ec + double precision,intent(out) :: Ec(nsp) ! Hello world @@ -72,6 +72,7 @@ subroutine UMP2(nBas,nC,nO,nV,nR,ERI_aa,ERI_ab,ERI_bb,ENuc,EHF,e,Ec) enddo Ecaa = Edaa + Exaa + Ec(1) = Ecaa ! aabb block @@ -97,6 +98,7 @@ subroutine UMP2(nBas,nC,nO,nV,nR,ERI_aa,ERI_ab,ERI_bb,ENuc,EHF,e,Ec) enddo Ecab = Edab + Exab + Ec(2) = Ecab ! bbbb block @@ -124,18 +126,18 @@ subroutine UMP2(nBas,nC,nO,nV,nR,ERI_aa,ERI_ab,ERI_bb,ENuc,EHF,e,Ec) enddo Ecbb = Edbb + Exbb + Ec(3) = Ecbb ! Final flush Ed = Edaa + Edab + Edbb Ex = Exaa + Exab + Exbb - Ec = Ed + Ex write(*,*) write(*,'(A32)') '--------------------------' write(*,'(A32)') ' MP2 calculation ' write(*,'(A32)') '--------------------------' - write(*,'(A32,1X,F16.10)') ' MP2 correlation energy = ',Ec + write(*,'(A32,1X,F16.10)') ' MP2 correlation energy = ',sum(Ec(:)) write(*,'(A32,1X,F16.10)') ' alpha-alpha = ',Ecaa write(*,'(A32,1X,F16.10)') ' alpha-beta = ',Ecab write(*,'(A32,1X,F16.10)') ' beta-beta = ',Ecbb @@ -150,8 +152,8 @@ subroutine UMP2(nBas,nC,nO,nV,nR,ERI_aa,ERI_ab,ERI_bb,ENuc,EHF,e,Ec) write(*,'(A32,1X,F16.10)') ' alpha-beta = ',Exab write(*,'(A32,1X,F16.10)') ' beta-beta = ',Exbb write(*,'(A32)') '--------------------------' - write(*,'(A32,1X,F16.10)') ' MP2 electronic energy = ', EHF + Ec - write(*,'(A32,1X,F16.10)') ' MP2 total energy = ',ENuc + EHF + Ec + write(*,'(A32,1X,F16.10)') ' MP2 electronic energy = ', EHF + sum(Ec(:)) + write(*,'(A32,1X,F16.10)') ' MP2 total energy = ',ENuc + EHF + sum(Ec(:)) write(*,'(A32)') '--------------------------' write(*,*) diff --git a/src/QuAcK/QuAcK.f90 b/src/QuAcK/QuAcK.f90 index e0a75d6..5ed4a55 100644 --- a/src/QuAcK/QuAcK.f90 +++ b/src/QuAcK/QuAcK.f90 @@ -6,14 +6,15 @@ program QuAcK logical :: doSph logical :: unrestricted = .false. logical :: doRHF,doUHF,doMOM + logical :: dostab logical :: doKS logical :: doMP2,doMP3,doMP2F12 logical :: doCCD,doDCD,doCCSD,doCCSDT logical :: do_drCCD,do_rCCD,do_lCCD,do_pCCD - logical :: doCIS,doCIS_D,doCID,doCISD + logical :: doCIS,doCIS_D,doCID,doCISD,doFCI logical :: doRPA,doRPAx,doppRPA logical :: doADC - logical :: doG0F2,doevGF2,doG0F3,doevGF3 + logical :: doG0F2,doevGF2,doqsGF2,doG0F3,doevGF3 logical :: doG0W0,doevGW,doqsGW logical :: doG0T0,doevGT,doqsGT logical :: doMCMP2,doMinMCMP2 @@ -32,6 +33,7 @@ program QuAcK double precision,allocatable :: ZNuc(:),rNuc(:,:) double precision,allocatable :: cHF(:,:,:),eHF(:,:),PHF(:,:,:) + double precision,allocatable :: Vxc(:,:) double precision,allocatable :: eG0W0(:,:) double precision,allocatable :: eG0T0(:,:) @@ -77,6 +79,7 @@ program QuAcK double precision :: start_QuAcK ,end_QuAcK ,t_QuAcK double precision :: start_int ,end_int ,t_int double precision :: start_HF ,end_HF ,t_HF + double precision :: start_stab ,end_stab ,t_stab double precision :: start_KS ,end_KS ,t_KS double precision :: start_MOM ,end_MOM ,t_MOM double precision :: start_AOtoMO ,end_AOtoMO ,t_AOtoMO @@ -86,6 +89,7 @@ program QuAcK double precision :: start_CIS ,end_CIS ,t_CIS double precision :: start_CID ,end_CID ,t_CID double precision :: start_CISD ,end_CISD ,t_CISD + double precision :: start_FCI ,end_FCI ,t_FCI double precision :: start_RPA ,end_RPA ,t_RPA double precision :: start_RPAx ,end_RPAx ,t_RPAx double precision :: start_ppRPA ,end_ppRPA ,t_ppRPA @@ -159,23 +163,24 @@ program QuAcK doMP2,doMP3,doMP2F12, & doCCD,doDCD,doCCSD,doCCSDT, & do_drCCD,do_rCCD,do_lCCD,do_pCCD, & - doCIS,doCIS_D,doCID,doCISD, & + doCIS,doCIS_D,doCID,doCISD,doFCI, & doRPA,doRPAx,doppRPA, & - doG0F2,doevGF2,doG0F3,doevGF3, & + doG0F2,doevGF2,doqsGF2, & + doG0F3,doevGF3, & doG0W0,doevGW,doqsGW, & doG0T0,doevGT,doqsGT, & doMCMP2) ! Read options for methods - call read_options(maxSCF_HF,thresh_HF,DIIS_HF,n_diis_HF,guess_type,ortho_type,mix, & - maxSCF_CC,thresh_CC,DIIS_CC,n_diis_CC, & - TDA,singlet,triplet,spin_conserved,spin_flip, & - maxSCF_GF,thresh_GF,DIIS_GF,n_diis_GF,linGF,eta_GF,renormGF, & - maxSCF_GW,thresh_GW,DIIS_GW,n_diis_GW,linGW,eta_GW, & - COHSEX,SOSEX,TDA_W,G0W,GW0, & - doACFDT,exchange_kernel,doXBS, & - BSE,dBSE,dTDA,evDyn, & + call read_options(maxSCF_HF,thresh_HF,DIIS_HF,n_diis_HF,guess_type,ortho_type,mix,dostab, & + maxSCF_CC,thresh_CC,DIIS_CC,n_diis_CC, & + TDA,singlet,triplet,spin_conserved,spin_flip, & + maxSCF_GF,thresh_GF,DIIS_GF,n_diis_GF,linGF,eta_GF,renormGF, & + maxSCF_GW,thresh_GW,DIIS_GW,n_diis_GW,linGW,eta_GW, & + COHSEX,SOSEX,TDA_W,G0W,GW0, & + doACFDT,exchange_kernel,doXBS, & + BSE,dBSE,dTDA,evDyn, & nMC,nEq,nWalk,dt,nPrint,iSeed,doDrift) ! Weird stuff @@ -236,7 +241,7 @@ program QuAcK allocate(cHF(nBas,nBas,nspin),eHF(nBas,nspin),eG0W0(nBas,nspin),eG0T0(nBas,nspin),PHF(nBas,nBas,nspin), & S(nBas,nBas),T(nBas,nBas),V(nBas,nBas),Hc(nBas,nBas),X(nBas,nBas),ERI_AO(nBas,nBas,nBas,nBas), & - dipole_int_AO(nBas,nBas,ncart),dipole_int_MO(nBas,nBas,ncart)) + dipole_int_AO(nBas,nBas,ncart),dipole_int_MO(nBas,nBas,ncart),Vxc(nBas,nspin)) ! Read integrals @@ -280,7 +285,7 @@ program QuAcK call cpu_time(start_HF) call RHF(maxSCF_HF,thresh_HF,n_diis_HF,guess_type,nNuc,ZNuc,rNuc,ENuc, & - nBas,nO,S,T,V,Hc,ERI_AO,dipole_int_AO,X,ERHF,eHF,cHF,PHF) + nBas,nO,S,T,V,Hc,ERI_AO,dipole_int_AO,X,ERHF,eHF,cHF,PHF,Vxc) call cpu_time(end_HF) t_HF = end_HF - start_HF @@ -300,7 +305,7 @@ program QuAcK call cpu_time(start_HF) call UHF(maxSCF_HF,thresh_HF,n_diis_HF,guess_type,mix,nNuc,ZNuc,rNuc,ENuc, & - nBas,nO,S,T,V,Hc,ERI_AO,dipole_int_AO,X,EUHF,eHF,cHF,PHF) + nBas,nO,S,T,V,Hc,ERI_AO,dipole_int_AO,X,EUHF,eHF,cHF,PHF,Vxc) call cpu_time(end_HF) t_HF = end_HF - start_HF @@ -315,10 +320,13 @@ program QuAcK if(doKS) then + ! Switch on the unrestricted flag + unrestricted = .true. + call cpu_time(start_KS) - call eDFT(maxSCF_HF,thresh_HF,n_diis_HF,guess_type,nNuc,ZNuc,rNuc,ENuc,nBas,nEl,nC, & - nO,nV,nR,nShell,TotAngMomShell,CenterShell,KShell,DShell,ExpShell, & - max_ang_mom,min_exponent,max_exponent,S,T,V,Hc,X,ERI_AO,dipole_int_AO) + call eDFT(maxSCF_HF,thresh_HF,n_diis_HF,guess_type,mix,nNuc,ZNuc,rNuc,ENuc,nBas,nEl,nC, & + nO,nV,nR,nShell,TotAngMomShell,CenterShell,KShell,DShell,ExpShell, & + max_ang_mom,min_exponent,max_exponent,S,T,V,Hc,X,ERI_AO,dipole_int_AO,EUHF,eHF,cHF,PHF,Vxc) call cpu_time(end_KS) @@ -335,8 +343,18 @@ program QuAcK if(doMOM) then call cpu_time(start_MOM) - call MOM(maxSCF_HF,thresh_HF,n_diis_HF, & - nBas,nO,S,T,V,Hc,ERI_AO,X,ENuc,ERHF,cHF,eHF,PHF) + + if(unrestricted) then + +! call UMOM() + + else + + call RMOM(maxSCF_HF,thresh_HF,n_diis_HF,guess_type,nNuc,ZNuc,rNuc,ENuc, & + nBas,nO,S,T,V,Hc,ERI_AO,dipole_int_AO,X,ERHF,eHF,cHF,PHF,Vxc) + + end if + call cpu_time(end_MOM) t_MOM = end_MOM - start_MOM @@ -435,6 +453,32 @@ program QuAcK write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for AO to MO transformation = ',t_AOtoMO,' seconds' write(*,*) +!------------------------------------------------------------------------ +! Stability analysis of HF solution +!------------------------------------------------------------------------ + + if(dostab) then + + call cpu_time(start_stab) + + if(unrestricted) then + + call UHF_stability(nBas,nC,nO,nV,nR,nS,eHF,ERI_MO_aaaa,ERI_MO_aabb,ERI_MO_bbbb) + + else + + call RHF_stability(nBas,nC,nO,nV,nR,nS,eHF,ERI_MO) + + end if + + call cpu_time(end_stab) + + t_stab = end_stab - start_stab + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for stability analysis = ',t_stab,' seconds' + write(*,*) + + end if + !------------------------------------------------------------------------ ! Compute MP2 energy !------------------------------------------------------------------------ @@ -779,8 +823,19 @@ program QuAcK if(doG0F2) then call cpu_time(start_GF2) - call G0F2(BSE,TDA,dBSE,dTDA,evDyn,singlet,triplet,linGF, & - eta_GF,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) + + if(unrestricted) then + + call UG0F2(BSE,TDA,dBSE,dTDA,evDyn,spin_conserved,spin_flip,linGF,eta_GF,nBas,nC,nO,nV,nR,nS,ENuc,EUHF, & + S,ERI_AO,ERI_MO_aaaa,ERI_MO_aabb,ERI_MO_bbbb,dipole_int_aa,dipole_int_bb,eHF) + + else + + call G0F2(BSE,TDA,dBSE,dTDA,evDyn,singlet,triplet,linGF, & + eta_GF,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF) + + end if + call cpu_time(end_GF2) t_GF2 = end_GF2 - start_GF2 @@ -796,9 +851,21 @@ program QuAcK if(doevGF2) then call cpu_time(start_GF2) - call evGF2(BSE,TDA,dBSE,dTDA,evDyn,maxSCF_GF,thresh_GF,n_diis_GF, & - singlet,triplet,linGF,eta_GF,nBas,nC,nO,nV,nR,nS,ENuc,ERHF, & - ERI_MO,dipole_int_MO,eHF) + + if(unrestricted) then + + call evUGF2(maxSCF_GF,thresh_GF,n_diis_GF,BSE,TDA,dBSE,dTDA,evDyn,spin_conserved,spin_flip, & + eta_GF,nBas,nC,nO,nV,nR,nS,ENuc,EUHF,S,ERI_AO,ERI_MO_aaaa,ERI_MO_aabb,ERI_MO_bbbb, & + dipole_int_aa,dipole_int_bb,cHF,eHF) + + else + + call evGF2(BSE,TDA,dBSE,dTDA,evDyn,maxSCF_GF,thresh_GF,n_diis_GF, & + singlet,triplet,linGF,eta_GF,nBas,nC,nO,nV,nR,nS,ENuc,ERHF, & + ERI_MO,dipole_int_MO,eHF) + + end if + call cpu_time(end_GF2) t_GF2 = end_GF2 - start_GF2 @@ -807,6 +874,35 @@ program QuAcK end if +!------------------------------------------------------------------------ +! Perform qsGF2 calculation +!------------------------------------------------------------------------ + + if(doqsGF2) then + + call cpu_time(start_GF2) + + if(unrestricted) then + + call qsUGF2(maxSCF_GF,thresh_GF,n_diis_GF,BSE,TDA,dBSE,dTDA,evDyn,spin_conserved,spin_flip,eta_GF, & + nNuc,ZNuc,rNuc,ENuc,nBas,nC,nO,nV,nR,nS,EUHF,S,X,T,V,Hc,ERI_AO, & + ERI_MO_aaaa,ERI_MO_aabb,ERI_MO_bbbb,dipole_int_AO,dipole_int_aa,dipole_int_bb,PHF,cHF,eHF) + + else + + call qsGF2(maxSCF_GF,thresh_GF,n_diis_GF,BSE,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta_GF,nNuc,ZNuc,rNuc,ENuc, & + nBas,nC,nO,nV,nR,nS,ERHF,S,X,T,V,Hc,ERI_AO,ERI_MO,dipole_int_AO,dipole_int_MO,PHF,cHF,eHF) + + end if + + call cpu_time(end_GF2) + + t_GF2 = end_GF2 - start_GF2 + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for qsGF2 = ',t_GF2,' seconds' + write(*,*) + + end if + !------------------------------------------------------------------------ ! Compute G0F3 electronic binding energies !------------------------------------------------------------------------ @@ -851,12 +947,12 @@ program QuAcK if(unrestricted) then call UG0W0(doACFDT,exchange_kernel,doXBS,COHSEX,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,spin_conserved,spin_flip, & - linGW,eta_GW,nBas,nC,nO,nV,nR,nS,ENuc,EUHF,S,ERI_MO_aaaa,ERI_MO_aabb,ERI_MO_bbbb, & - dipole_int_aa,dipole_int_bb,PHF,cHF,eHF,eG0W0) + linGW,eta_GW,nBas,nC,nO,nV,nR,nS,ENuc,EUHF,S,ERI_AO,ERI_MO_aaaa,ERI_MO_aabb,ERI_MO_bbbb, & + dipole_int_aa,dipole_int_bb,PHF,cHF,eHF,Vxc,eG0W0) else call G0W0(doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,singlet,triplet, & - linGW,eta_GW,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF,eG0W0) + linGW,eta_GW,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_AO,ERI_MO,dipole_int_MO,PHF,cHF,eHF,Vxc,eG0W0) end if @@ -879,14 +975,14 @@ program QuAcK call evUGW(maxSCF_GW,thresh_GW,n_diis_GW,doACFDT,exchange_kernel,doXBS,COHSEX,BSE,TDA_W,TDA, & G0W,GW0,dBSE,dTDA,evDyn,spin_conserved,spin_flip,eta_GW,nBas,nC,nO,nV,nR,nS,ENuc, & - EUHF,S,ERI_MO_aaaa,ERI_MO_aabb,ERI_MO_bbbb,dipole_int_aa,dipole_int_bb, & - cHF,eHF,eG0W0) + EUHF,S,ERI_AO,ERI_MO_aaaa,ERI_MO_aabb,ERI_MO_bbbb,dipole_int_aa,dipole_int_bb, & + PHF,cHF,eHF,Vxc,eG0W0) else call evGW(maxSCF_GW,thresh_GW,n_diis_GW,doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX, & BSE,TDA_W,TDA,G0W,GW0,dBSE,dTDA,evDyn,singlet,triplet,eta_GW, & - nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF,eG0W0) + nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_AO,ERI_MO,dipole_int_MO,PHF,cHF,eHF,Vxc,eG0W0) end if call cpu_time(end_evGW) @@ -936,9 +1032,9 @@ program QuAcK if(doG0T0) then call cpu_time(start_G0T0) - call G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA, & - dBSE,dTDA,evDyn,singlet,triplet,linGW,eta_GW, & - nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF,eG0T0) + call G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA,dBSE,dTDA,evDyn,singlet,triplet, & + linGW,eta_GW,nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_AO,ERI_MO,dipole_int_MO, & + PHF,cHF,eHF,Vxc,eG0T0) call cpu_time(end_G0T0) t_G0T0 = end_G0T0 - start_G0T0 @@ -956,7 +1052,8 @@ program QuAcK call cpu_time(start_evGT) call evGT(maxSCF_GW,thresh_GW,n_diis_GW,doACFDT,exchange_kernel,doXBS, & BSE,TDA_W,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta_GW, & - nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_MO,dipole_int_MO,eHF,eG0T0) + nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_AO,ERI_MO,dipole_int_MO, & + PHF,cHF,eHF,Vxc,eG0T0) call cpu_time(end_evGT) t_evGT = end_evGT - start_evGT @@ -1005,10 +1102,10 @@ program QuAcK if(doMCMP2) then call cpu_time(start_MCMP2) - call MCMP2(doDrift,nBas,nC,nO,nV,cHF,eHF,EcMP2, & - nMC,nEq,nWalk,dt,nPrint, & - nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & - Norm,EcMCMP2,Err_EcMCMP2,Var_EcMCMP2) +! call MCMP2(doDrift,nBas,nC,nO,nV,cHF,eHF,EcMP2, & +! nMC,nEq,nWalk,dt,nPrint, & +! nShell,CenterShell,TotAngMomShell,KShell,DShell,ExpShell, & +! Norm,EcMCMP2,Err_EcMCMP2,Var_EcMCMP2) call cpu_time(end_MCMP2) t_MCMP2 = end_MCMP2 - start_MCMP2 @@ -1040,59 +1137,59 @@ program QuAcK ! Range-separeted GT/GW !------------------------------------------------------------------------ - if(doGTGW) then +! if(doGTGW) then - ! Read and transform long-range two-electron integrals +! ! Read and transform long-range two-electron integrals - allocate(ERI_ERF_AO(nBas,nBas,nBas,nBas),ERI_ERF_MO(nBas,nBas,nBas,nBas)) - call read_LR(nBas,ERI_ERF_AO) +! allocate(ERI_ERF_AO(nBas,nBas,nBas,nBas),ERI_ERF_MO(nBas,nBas,nBas,nBas)) +! call read_LR(nBas,ERI_ERF_AO) - call cpu_time(start_AOtoMO) +! call cpu_time(start_AOtoMO) - write(*,*) - write(*,*) 'AO to MO transformation for long-range ERIs... Please be patient' - write(*,*) +! write(*,*) +! write(*,*) 'AO to MO transformation for long-range ERIs... Please be patient' +! write(*,*) - call AOtoMO_integral_transform(nBas,cHF,ERI_ERF_AO,ERI_ERF_MO) +! call AOtoMO_integral_transform(nBas,cHF,ERI_ERF_AO,ERI_ERF_MO) - call cpu_time(end_AOtoMO) +! call cpu_time(end_AOtoMO) - deallocate(ERI_ERF_AO) +! deallocate(ERI_ERF_AO) - t_AOtoMO = end_AOtoMO - start_AOtoMO +! t_AOtoMO = end_AOtoMO - start_AOtoMO - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for AO to MO transformation = ',t_AOtoMO,' seconds' - write(*,*) +! write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for AO to MO transformation = ',t_AOtoMO,' seconds' +! write(*,*) - ! Long-range G0W0 calculation +! ! Long-range G0W0 calculation - call cpu_time(start_G0W0) - call G0W0(doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA, & - dBSE,dTDA,evDyn,singlet,triplet,linGW,eta_GW, & - nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_ERF_MO,dipole_int_MO,eHF,eG0W0) - call cpu_time(end_G0W0) - - t_G0W0 = end_G0W0 - start_G0W0 - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for G0W0 = ',t_G0W0,' seconds' - write(*,*) +! call cpu_time(start_G0W0) +! call G0W0(doACFDT,exchange_kernel,doXBS,COHSEX,SOSEX,BSE,TDA_W,TDA, & +! dBSE,dTDA,evDyn,singlet,triplet,linGW,eta_GW, & +! nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_ERF_MO,dipole_int_MO,eHF,eG0W0) +! call cpu_time(end_G0W0) +! +! t_G0W0 = end_G0W0 - start_G0W0 +! write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for G0W0 = ',t_G0W0,' seconds' +! write(*,*) - ! Short-range G0T0 calculation +! ! Short-range G0T0 calculation - ERI_ERF_MO(:,:,:,:) = ERI_MO(:,:,:,:) - ERI_ERF_MO(:,:,:,:) +! ERI_ERF_MO(:,:,:,:) = ERI_MO(:,:,:,:) - ERI_ERF_MO(:,:,:,:) - call cpu_time(start_G0T0) - call G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA,dBSE,dTDA,evDyn, & - singlet,triplet,linGW,eta_GW, & - nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_ERF_MO,dipole_int_MO,eHF,eG0T0) - call cpu_time(end_G0T0) - - t_G0T0 = end_G0T0 - start_G0T0 - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for G0T0 = ',t_G0T0,' seconds' - write(*,*) +! call cpu_time(start_G0T0) +! call G0T0(doACFDT,exchange_kernel,doXBS,BSE,TDA_W,TDA,dBSE,dTDA,evDyn, & +! singlet,triplet,linGW,eta_GW, & +! nBas,nC,nO,nV,nR,nS,ENuc,ERHF,ERI_ERF_MO,dipole_int_MO,eHF,eG0T0) +! call cpu_time(end_G0T0) +! +! t_G0T0 = end_G0T0 - start_G0T0 +! write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for G0T0 = ',t_G0T0,' seconds' +! write(*,*) ! call matout(nBas,1,(eG0W0+eG0T0-eHF(:,1))*HaToeV) - end if +! end if !------------------------------------------------------------------------ ! Basis set correction @@ -1113,6 +1210,22 @@ program QuAcK end if +!------------------------------------------------------------------------ +! Compute FCI +!------------------------------------------------------------------------ + + if(doFCI) then + + call cpu_time(start_FCI) + call FCI(nBas,nC,nO,nV,nR,ERI_MO,eHF) + call cpu_time(end_FCI) + + t_FCI = end_FCI - start_FCI + write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for FCI = ',t_FCI,' seconds' + write(*,*) + + end if + !------------------------------------------------------------------------ ! End of QuAcK !------------------------------------------------------------------------ diff --git a/src/QuAcK/read_methods.f90 b/src/QuAcK/read_methods.f90 index ab0d2d6..5228e17 100644 --- a/src/QuAcK/read_methods.f90 +++ b/src/QuAcK/read_methods.f90 @@ -2,9 +2,10 @@ subroutine read_methods(doRHF,doUHF,doKS,doMOM, & doMP2,doMP3,doMP2F12, & doCCD,doDCD,doCCSD,doCCSDT, & do_drCCD,do_rCCD,do_lCCD,do_pCCD, & - doCIS,doCIS_D,doCID,doCISD, & + doCIS,doCIS_D,doCID,doCISD,doFCI, & doRPA,doRPAx,doppRPA, & - doG0F2,doevGF2,doG0F3,doevGF3, & + doG0F2,doevGF2,doqsGF2, & + doG0F3,doevGF3, & doG0W0,doevGW,doqsGW, & doG0T0,doevGT,doqsGT, & doMCMP2) @@ -19,9 +20,9 @@ subroutine read_methods(doRHF,doUHF,doKS,doMOM, & logical,intent(out) :: doMP2,doMP3,doMP2F12 logical,intent(out) :: doCCD,doDCD,doCCSD,doCCSDT logical,intent(out) :: do_drCCD,do_rCCD,do_lCCD,do_pCCD - logical,intent(out) :: doCIS,doCIS_D,doCID,doCISD + logical,intent(out) :: doCIS,doCIS_D,doCID,doCISD,doFCI logical,intent(out) :: doRPA,doRPAx,doppRPA - logical,intent(out) :: doG0F2,doevGF2,doG0F3,doevGF3 + logical,intent(out) :: doG0F2,doevGF2,doqsGF2,doG0F3,doevGF3 logical,intent(out) :: doG0W0,doevGW,doqsGW logical,intent(out) :: doG0T0,doevGT,doqsGT logical,intent(out) :: doMCMP2 @@ -59,6 +60,7 @@ subroutine read_methods(doRHF,doUHF,doKS,doMOM, & doCIS_D = .false. doCID = .false. doCISD = .false. + doFCI = .false. doRPA = .false. doRPAx = .false. @@ -66,6 +68,7 @@ subroutine read_methods(doRHF,doUHF,doKS,doMOM, & doG0F2 = .false. doevGF2 = .false. + doqsGF2 = .false. doG0F3 = .false. doevGF3 = .false. @@ -116,11 +119,12 @@ subroutine read_methods(doRHF,doUHF,doKS,doMOM, & ! Read excited state methods read(1,*) - read(1,*) answer1,answer2,answer3,answer4 + read(1,*) answer1,answer2,answer3,answer4,answer5 if(answer1 == 'T') doCIS = .true. if(answer2 == 'T') doCIS_D = .true. if(answer3 == 'T') doCID = .true. if(answer4 == 'T') doCISD = .true. + if(answer5 == 'T') doFCI = .true. if(doCIS_D) doCIS = .true. read(1,*) @@ -132,11 +136,12 @@ subroutine read_methods(doRHF,doUHF,doKS,doMOM, & ! Read Green function methods read(1,*) - read(1,*) answer1,answer2,answer3,answer4 + read(1,*) answer1,answer2,answer3,answer4,answer5 if(answer1 == 'T') doG0F2 = .true. if(answer2 == 'T') doevGF2 = .true. - if(answer3 == 'T') doG0F3 = .true. - if(answer4 == 'T') doevGF3 = .true. + if(answer3 == 'T') doqsGF2 = .true. + if(answer4 == 'T') doG0F3 = .true. + if(answer5 == 'T') doevGF3 = .true. ! Read GW methods diff --git a/src/QuAcK/read_options.f90 b/src/QuAcK/read_options.f90 index 1492197..2d7aa4f 100644 --- a/src/QuAcK/read_options.f90 +++ b/src/QuAcK/read_options.f90 @@ -1,11 +1,11 @@ -subroutine read_options(maxSCF_HF,thresh_HF,DIIS_HF,n_diis_HF,guess_type,ortho_type,mix, & - maxSCF_CC,thresh_CC,DIIS_CC,n_diis_CC, & - TDA,singlet,triplet,spin_conserved,spin_flip, & - maxSCF_GF,thresh_GF,DIIS_GF,n_diis_GF,linGF,eta_GF,renormGF, & - maxSCF_GW,thresh_GW,DIIS_GW,n_diis_GW,linGW,eta_GW, & - COHSEX,SOSEX,TDA_W,G0W,GW0, & - doACFDT,exchange_kernel,doXBS, & - BSE,dBSE,dTDA,evDyn, & +subroutine read_options(maxSCF_HF,thresh_HF,DIIS_HF,n_diis_HF,guess_type,ortho_type,mix,dostab, & + maxSCF_CC,thresh_CC,DIIS_CC,n_diis_CC, & + TDA,singlet,triplet,spin_conserved,spin_flip, & + maxSCF_GF,thresh_GF,DIIS_GF,n_diis_GF,linGF,eta_GF,renormGF, & + maxSCF_GW,thresh_GW,DIIS_GW,n_diis_GW,linGW,eta_GW, & + COHSEX,SOSEX,TDA_W,G0W,GW0, & + doACFDT,exchange_kernel,doXBS, & + BSE,dBSE,dTDA,evDyn, & nMC,nEq,nWalk,dt,nPrint,iSeed,doDrift) ! Read desired methods @@ -21,6 +21,7 @@ subroutine read_options(maxSCF_HF,thresh_HF,DIIS_HF,n_diis_HF,guess_type,ortho_t integer,intent(out) :: guess_type integer,intent(out) :: ortho_type logical,intent(out) :: mix + logical,intent(out) :: dostab integer,intent(out) :: maxSCF_CC double precision,intent(out) :: thresh_CC @@ -87,12 +88,14 @@ subroutine read_options(maxSCF_HF,thresh_HF,DIIS_HF,n_diis_HF,guess_type,ortho_t guess_type = 1 ortho_type = 1 mix = .false. + dostab = .false. read(1,*) - read(1,*) maxSCF_HF,thresh_HF,answer1,n_diis_HF,guess_type,ortho_type,answer2 + read(1,*) maxSCF_HF,thresh_HF,answer1,n_diis_HF,guess_type,ortho_type,answer2,answer3 if(answer1 == 'T') DIIS_HF = .true. if(answer2 == 'T') mix = .true. + if(answer3 == 'T') dostab = .true. if(.not.DIIS_HF) n_diis_HF = 1 diff --git a/src/RPA/ACFDT.f90 b/src/RPA/ACFDT.f90 index b3f52bc..24d9de0 100644 --- a/src/RPA/ACFDT.f90 +++ b/src/RPA/ACFDT.f90 @@ -97,6 +97,7 @@ subroutine ACFDT(exchange_kernel,doXBS,dRPA,TDA_W,TDA,BSE,singlet,triplet,eta,nB call linear_response(isp_W,.true.,TDA_W,.false.,eta,nBas,nC,nO,nV,nR,nS,lambda,eW,ERI,OmRPA, & rho_RPA,EcRPA,OmRPA,XpY_RPA,XmY_RPA) call excitation_density(nBas,nC,nO,nR,nS,ERI,XpY_RPA,rho_RPA) +! call print_excitation('W^lambda: ',isp_W,nS,OmRPA) end if diff --git a/src/RPA/RPAx.f90 b/src/RPA/RPAx.f90 index 34f1655..6b096e4 100644 --- a/src/RPA/RPAx.f90 +++ b/src/RPA/RPAx.f90 @@ -82,7 +82,7 @@ subroutine RPAx(TDA,doACFDT,exchange_kernel,singlet,triplet,eta,nBas,nC,nO,nV,nR ispin = 2 - call linear_response(ispin,.false.,TDA,.false.,eta,nBas,nC,nO,nV,nR,nS,1d0,eHF,ERI,rho,Omega(:,ispin), & + call linear_response(ispin,.false.,TDA,.false.,eta,nBas,nC,nO,nV,nR,nS,1d0,eHF,ERI,Omega(:,ispin),rho, & EcRPAx(ispin),Omega(:,ispin),XpY(:,:,ispin),XmY(:,:,ispin)) call print_excitation('RPAx@HF ',ispin,nS,Omega(:,ispin)) call print_transition_vectors(.false.,nBas,nC,nO,nV,nR,nS,dipole_int,Omega(:,ispin),XpY(:,:,ispin),XmY(:,:,ispin)) diff --git a/src/RPA/URPA.f90 b/src/RPA/URPA.f90 index 1a9f222..e08fb11 100644 --- a/src/RPA/URPA.f90 +++ b/src/RPA/URPA.f90 @@ -146,6 +146,13 @@ subroutine URPA(TDA,doACFDT,exchange_kernel,spin_conserved,spin_flip,eta,nBas,nC call unrestricted_ACFDT(exchange_kernel,.false.,.true.,.false.,TDA,.false.,spin_conserved,spin_flip,eta, & nBas,nC,nO,nV,nR,nS,ERI_aaaa,ERI_aabb,ERI_bbbb,e,e,EcAC) + if(exchange_kernel) then + + EcAC(1) = 0.5d0*EcAC(1) + EcAC(2) = 1.5d0*EcAC(2) + + end if + write(*,*) write(*,*)'-------------------------------------------------------------------------------' write(*,'(2X,A50,F20.10)') 'AC@URPA correlation energy (spin-conserved) =',EcAC(1) diff --git a/src/RPA/URPAx.f90 b/src/RPA/URPAx.f90 index 90f329c..450e913 100644 --- a/src/RPA/URPAx.f90 +++ b/src/RPA/URPAx.f90 @@ -122,7 +122,11 @@ subroutine URPAx(TDA,doACFDT,exchange_kernel,spin_conserved,spin_flip,eta,nBas,n if(exchange_kernel) then EcRPAx(1) = 0.5d0*EcRPAx(1) - EcRPAx(2) = 1.5d0*EcRPAx(2) + EcRPAx(2) = 0.5d0*EcRPAx(2) + + else + + EcRPAx(2) = 0d0 end if diff --git a/src/RPA/unrestricted_ACFDT.f90 b/src/RPA/unrestricted_ACFDT.f90 index ded29de..bdd9435 100644 --- a/src/RPA/unrestricted_ACFDT.f90 +++ b/src/RPA/unrestricted_ACFDT.f90 @@ -192,7 +192,7 @@ subroutine unrestricted_ACFDT(exchange_kernel,doXBS,dRPA,TDA_W,TDA,BSE,spin_cons EcAC(ispin) = 0.5d0*dot_product(wAC,Ec(:,ispin)) - if(exchange_kernel) EcAC(ispin) = 1.5d0*EcAC(ispin) + if(exchange_kernel) EcAC(ispin) = 0.5d0*EcAC(ispin) write(*,*) '-----------------------------------------------------------------------------------' write(*,'(2X,A50,1X,F15.6)') ' Ec(AC) via Gauss-Legendre quadrature:',EcAC(ispin) diff --git a/src/eDFT/GOK_UKS.f90 b/src/eDFT/GOK_UKS.f90 index 1b01a96..9e2f82b 100644 --- a/src/eDFT/GOK_UKS.f90 +++ b/src/eDFT/GOK_UKS.f90 @@ -210,7 +210,7 @@ subroutine GOK_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,nGrid,weight,aCC_w1,aCC_w rhow(:,:) = rhow(:,:) + wEns(iEns)*rho(:,:,iEns) end do - if(xc_rung > 1 .and. xc_rung /= 666) then + if(xc_rung > 1) then ! Ground state density diff --git a/src/eDFT/RB88_gga_exchange_energy.f90 b/src/eDFT/RB88_gga_exchange_energy.f90 index 04c87f6..596710d 100644 --- a/src/eDFT/RB88_gga_exchange_energy.f90 +++ b/src/eDFT/RB88_gga_exchange_energy.f90 @@ -16,7 +16,6 @@ subroutine RB88_gga_exchange_energy(nGrid,weight,rho,drho,Ex) ! Local variables integer :: iG - double precision :: alpha double precision :: beta double precision :: r,g,x @@ -26,7 +25,6 @@ subroutine RB88_gga_exchange_energy(nGrid,weight,rho,drho,Ex) ! Coefficients for B88 GGA exchange functional - alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) beta = 0.0042d0 ! Compute GGA exchange energy @@ -41,7 +39,7 @@ subroutine RB88_gga_exchange_energy(nGrid,weight,rho,drho,Ex) g = 0.25d0*(drho(1,iG)**2 + drho(2,iG)**2 + drho(3,iG)**2) x = sqrt(g)/r**(4d0/3d0) - Ex = Ex + weight(iG)*alpha*r**(4d0/3d0) & + Ex = Ex + weight(iG)*CxLDA*r**(4d0/3d0) & - weight(iG)*beta*x**2*r**(4d0/3d0)/(1d0 + 6d0*beta*x*asinh(x)) end if diff --git a/src/eDFT/RB88_gga_exchange_individual_energy.f90 b/src/eDFT/RB88_gga_exchange_individual_energy.f90 index 23c05bb..56c64bf 100644 --- a/src/eDFT/RB88_gga_exchange_individual_energy.f90 +++ b/src/eDFT/RB88_gga_exchange_individual_energy.f90 @@ -17,7 +17,6 @@ subroutine RB88_gga_exchange_individual_energy(nGrid,weight,rhow,drhow,rho,drho, ! Local variables integer :: iG - double precision :: alpha double precision :: beta double precision :: r,rI,g,x double precision :: ex_p,dexdr_p @@ -28,7 +27,6 @@ subroutine RB88_gga_exchange_individual_energy(nGrid,weight,rhow,drhow,rho,drho, ! Coefficients for B88 GGA exchange functional - alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) beta = 0.0042d0 ! Compute GGA exchange matrix in the AO basis @@ -45,11 +43,11 @@ subroutine RB88_gga_exchange_individual_energy(nGrid,weight,rhow,drhow,rho,drho, g = 0.25d0*(drho(1,iG)**2 + drho(2,iG)**2 + drho(3,iG)**2) x = sqrt(g)/r**(4d0/3d0) - dexdr_p = 4d0/3d0*r**(1d0/3d0)*(alpha - beta*g**(3d0/4d0)/r**2) & + dexdr_p = 4d0/3d0*r**(1d0/3d0)*(CxLDA - beta*g**(3d0/4d0)/r**2) & + 2d0*beta*g**(3d0/4d0)/r**(5d0/3d0) & - 2d0*3d0/4d0*beta*g**(-1d0/4d0)/r**(2d0/3d0) - ex_p = alpha*r**(4d0/3d0) & + ex_p = CxLDA*r**(4d0/3d0) & - weight(iG)*beta*x**2*r**(4d0/3d0)/(1d0 + 6d0*beta*x*asinh(x)) Ex = Ex + weight(iG)*(ex_p*rI + dexdr_p*r*rI - dexdr_p*r*r) diff --git a/src/eDFT/RB88_gga_exchange_potential.f90 b/src/eDFT/RB88_gga_exchange_potential.f90 index 1dca23b..6829644 100644 --- a/src/eDFT/RB88_gga_exchange_potential.f90 +++ b/src/eDFT/RB88_gga_exchange_potential.f90 @@ -18,7 +18,6 @@ subroutine RB88_gga_exchange_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fx) ! Local variables integer :: mu,nu,iG - double precision :: alpha double precision :: beta double precision :: r,g,vAO,gAO @@ -28,7 +27,6 @@ subroutine RB88_gga_exchange_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fx) ! Coefficients for B88 GGA exchange functional - alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) beta = 0.0042d0 ! Compute GGA exchange matrix in the AO basis @@ -46,7 +44,7 @@ subroutine RB88_gga_exchange_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fx) g = 0.25d0*(drho(1,iG)**2 + drho(2,iG)**2 + drho(3,iG)**2) vAO = weight(iG)*AO(mu,iG)*AO(nu,iG) Fx(mu,nu) = Fx(mu,nu) & - + vAO*(4d0/3d0*r**(1d0/3d0)*(alpha - beta*g**(3d0/4d0)/r**2) & + + vAO*(4d0/3d0*r**(1d0/3d0)*(CxLDA - beta*g**(3d0/4d0)/r**2) & + 2d0*beta*g**(3d0/4d0)/r**(5d0/3d0)) gAO = drho(1,iG)*(dAO(1,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(1,nu,iG)) & diff --git a/src/eDFT/RCC_lda_exchange_derivative_discontinuity.f90 b/src/eDFT/RCC_lda_exchange_derivative_discontinuity.f90 index 235407a..14d1083 100644 --- a/src/eDFT/RCC_lda_exchange_derivative_discontinuity.f90 +++ b/src/eDFT/RCC_lda_exchange_derivative_discontinuity.f90 @@ -84,12 +84,16 @@ subroutine RCC_lda_exchange_derivative_discontinuity(nEns,wEns,aCC_w1,aCC_w2,nGr dCxdw2 = (1d0 - w1*(1d0 - w1)*(a1 + b1*(w1 - 0.5d0) + c1*(w1 - 0.5d0)**2)) & * (0.5d0*b2 + (2d0*a2 + 0.5d0*c2)*(w2 - 0.5d0) - (1d0 - w2)*w2*(3d0*b2 + 4d0*c2*(w2 - 0.5d0))) + + case default + dCxdw1 = 0.d0 + dCxdw2 = 0.d0 + end select dCxdw1 = CxLDA*dCxdw1 dCxdw2 = CxLDA*dCxdw2 - dExdw(:) = 0d0 do iG=1,nGrid diff --git a/src/eDFT/RCC_lda_exchange_energy.f90 b/src/eDFT/RCC_lda_exchange_energy.f90 index 8fa5c6c..5f55d95 100644 --- a/src/eDFT/RCC_lda_exchange_energy.f90 +++ b/src/eDFT/RCC_lda_exchange_energy.f90 @@ -69,12 +69,19 @@ subroutine RCC_lda_exchange_energy(nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,rho,Ex,C Fx2 = 1d0 - w2*(1d0 - w2)*(a2 + b2*(w2 - 0.5d0) + c2*(w2 - 0.5d0)**2) select case (Cx_choice) - case(1) - Cx = CxLDA*Fx1 - case(2) - Cx = CxLDA*Fx2 - case(3) - Cx = CxLDA*Fx2*Fx1 + + case(1) + Cx = CxLDA*Fx1 + + case(2) + Cx = CxLDA*Fx2 + + case(3) + Cx = CxLDA*Fx2*Fx1 + + case default + Cx = CxLDA + end select ! Compute GIC-LDA exchange energy diff --git a/src/eDFT/RCC_lda_exchange_individual_energy.f90 b/src/eDFT/RCC_lda_exchange_individual_energy.f90 index 02f23f8..ade4f56 100644 --- a/src/eDFT/RCC_lda_exchange_individual_energy.f90 +++ b/src/eDFT/RCC_lda_exchange_individual_energy.f90 @@ -75,12 +75,19 @@ subroutine RCC_lda_exchange_individual_energy(nEns,wEns,aCC_w1,aCC_w2,nGrid,weig Fx2 = 1d0 - w2*(1d0 - w2)*(a2 + b2*(w2 - 0.5d0) + c2*(w2 - 0.5d0)**2) select case (Cx_choice) - case(1) - Cx = CxLDA*Fx1 - case(2) - Cx = CxLDA*Fx2 - case(3) - Cx = CxLDA*Fx2*Fx1 + + case(1) + Cx = CxLDA*Fx1 + + case(2) + Cx = CxLDA*Fx2 + + case(3) + Cx = CxLDA*Fx2*Fx1 + + case default + Cx = CxLDA + end select ! Compute LDA exchange matrix in the AO basis diff --git a/src/eDFT/RCC_lda_exchange_potential.f90 b/src/eDFT/RCC_lda_exchange_potential.f90 index d33017b..519dfa9 100644 --- a/src/eDFT/RCC_lda_exchange_potential.f90 +++ b/src/eDFT/RCC_lda_exchange_potential.f90 @@ -74,12 +74,19 @@ subroutine RCC_lda_exchange_potential(nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,nBas, Fx2 = 1d0 - w2*(1d0 - w2)*(a2 + b2*(w2 - 0.5d0) + c2*(w2 - 0.5d0)**2) select case (Cx_choice) - case(1) - Cx = CxLDA*Fx1 - case(2) - Cx = CxLDA*Fx2 - case(3) - Cx = CxLDA*Fx2*Fx1 + + case(1) + Cx = CxLDA*Fx1 + + case(2) + Cx = CxLDA*Fx2 + + case(3) + Cx = CxLDA*Fx2*Fx1 + + case default + Cx = CxLDA + end select diff --git a/src/eDFT/RMFL20_lda_exchange_derivative_discontinuity.f90 b/src/eDFT/RMFL20_lda_exchange_derivative_discontinuity.f90 index 15e1c3b..d3620c8 100644 --- a/src/eDFT/RMFL20_lda_exchange_derivative_discontinuity.f90 +++ b/src/eDFT/RMFL20_lda_exchange_derivative_discontinuity.f90 @@ -21,6 +21,9 @@ subroutine RMFL20_lda_exchange_derivative_discontinuity(nEns,wEns,nGrid,weight,r double precision :: dExdw(nEns) double precision,external :: Kronecker_delta + double precision,parameter :: Cx0 = - (4d0/3d0)*(1d0/pi)**(1d0/3d0) + double precision,parameter :: Cx1 = - (176d0/105d0)*(1d0/pi)**(1d0/3d0) + ! Output variables double precision,intent(out) :: ExDD(nEns) diff --git a/src/eDFT/RMFL20_lda_exchange_energy.f90 b/src/eDFT/RMFL20_lda_exchange_energy.f90 index c9ca09f..3d50004 100644 --- a/src/eDFT/RMFL20_lda_exchange_energy.f90 +++ b/src/eDFT/RMFL20_lda_exchange_energy.f90 @@ -15,6 +15,9 @@ subroutine RMFL20_lda_exchange_energy(LDA_centered,nEns,wEns,nGrid,weight,rho,Ex double precision,intent(in) :: weight(nGrid) double precision,intent(in) :: rho(nGrid) + double precision,parameter :: Cx0 = - (4d0/3d0)*(1d0/pi)**(1d0/3d0) + double precision,parameter :: Cx1 = - (176d0/105d0)*(1d0/pi)**(1d0/3d0) + ! Local variables integer :: iG diff --git a/src/eDFT/RMFL20_lda_exchange_individual_energy.f90 b/src/eDFT/RMFL20_lda_exchange_individual_energy.f90 index 75176b0..49a1299 100644 --- a/src/eDFT/RMFL20_lda_exchange_individual_energy.f90 +++ b/src/eDFT/RMFL20_lda_exchange_individual_energy.f90 @@ -22,6 +22,9 @@ subroutine RMFL20_lda_exchange_individual_energy(LDA_centered,nEns,wEns,nGrid,we double precision :: r,rI double precision :: e_p,dedr + double precision,parameter :: Cx0 = - (4d0/3d0)*(1d0/pi)**(1d0/3d0) + double precision,parameter :: Cx1 = - (176d0/105d0)*(1d0/pi)**(1d0/3d0) + ! Output variables double precision,intent(out) :: Ex diff --git a/src/eDFT/RMFL20_lda_exchange_potential.f90 b/src/eDFT/RMFL20_lda_exchange_potential.f90 index ce6cfca..4d0ca82 100644 --- a/src/eDFT/RMFL20_lda_exchange_potential.f90 +++ b/src/eDFT/RMFL20_lda_exchange_potential.f90 @@ -22,6 +22,9 @@ subroutine RMFL20_lda_exchange_potential(LDA_centered,nEns,wEns,nGrid,weight,nBa double precision :: Cxw double precision :: r,vAO + double precision,parameter :: Cx0 = - (4d0/3d0)*(1d0/pi)**(1d0/3d0) + double precision,parameter :: Cx1 = - (176d0/105d0)*(1d0/pi)**(1d0/3d0) + ! Output variables double precision,intent(out) :: Fx(nBas,nBas) diff --git a/src/eDFT/UB88_gga_exchange_energy.f90 b/src/eDFT/UB88_gga_exchange_energy.f90 index 2f6b14d..2ecf64d 100644 --- a/src/eDFT/UB88_gga_exchange_energy.f90 +++ b/src/eDFT/UB88_gga_exchange_energy.f90 @@ -16,7 +16,7 @@ subroutine UB88_gga_exchange_energy(nGrid,weight,rho,drho,Ex) ! Local variables integer :: iG - double precision :: alpha,beta + double precision :: b double precision :: r,g,x ! Output variables @@ -25,8 +25,7 @@ subroutine UB88_gga_exchange_energy(nGrid,weight,rho,drho,Ex) ! Coefficients for B88 GGA exchange functional - alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) - beta = 0.0042d0 + b = 0.0042d0 ! Compute GGA exchange energy @@ -40,8 +39,7 @@ subroutine UB88_gga_exchange_energy(nGrid,weight,rho,drho,Ex) g = drho(1,iG)**2 + drho(2,iG)**2 + drho(3,iG)**2 x = sqrt(g)/r**(4d0/3d0) - Ex = Ex + weight(iG)*alpha*r**(4d0/3d0) & - - weight(iG)*beta*x**2*r**(4d0/3d0)/(1d0 + 6d0*beta*x*asinh(x)) + Ex = Ex + weight(iG)*r**(4d0/3d0)*(CxLSDA - b*x**2/(1d0 + 6d0*b*x*asinh(x))) end if diff --git a/src/eDFT/UB88_gga_exchange_potential.f90 b/src/eDFT/UB88_gga_exchange_potential.f90 index 14244ff..fcec63c 100644 --- a/src/eDFT/UB88_gga_exchange_potential.f90 +++ b/src/eDFT/UB88_gga_exchange_potential.f90 @@ -18,8 +18,9 @@ subroutine UB88_gga_exchange_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fx) ! Local variables integer :: mu,nu,iG - double precision :: alpha,beta - double precision :: r,g,vAO,gAO + double precision :: b + double precision :: vAO,gAO + double precision :: r,g,x,dxdr,dxdg,f ! Output variables @@ -27,8 +28,7 @@ subroutine UB88_gga_exchange_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fx) ! Coefficients for B88 GGA exchange functional - alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) - beta = 0.0042d0 + b = 0.0042d0 ! Compute GGA exchange matrix in the AO basis @@ -42,19 +42,27 @@ subroutine UB88_gga_exchange_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fx) if(r > threshold) then - g = drho(1,iG)**2 + drho(2,iG)**2 + drho(3,iG)**2 vAO = weight(iG)*AO(mu,iG)*AO(nu,iG) - Fx(mu,nu) = Fx(mu,nu) & - + vAO*(4d0/3d0*r**(1d0/3d0)*(alpha - beta*g**(3d0/4d0)/r**2) & - + 2d0*beta*g**(3d0/4d0)/r**(5d0/3d0)) + + g = drho(1,iG)**2 + drho(2,iG)**2 + drho(3,iG)**2 + x = sqrt(g)/r**(4d0/3d0) + dxdr = - 4d0*sqrt(g)/(3d0*r**(7d0/3d0))/x + dxdg = + 1d0/(2d0*sqrt(g)*r**(4d0/3d0))/x + + f = b*x**2/(1d0 + 6d0*b*x*asinh(x)) + + Fx(mu,nu) = Fx(mu,nu) + vAO*( & + 4d0/3d0*r**(1d0/3d0)*(CxLSDA - f) & + - 2d0*r**(4d0/3d0)*dxdr*f & + + r**(4d0/3d0)*dxdr*(6d0*b*x*asinh(x) + 6d0*b*x**2/sqrt(1d0+x**2))*f/(1d0 + 6d0*b*x*asinh(x)) ) gAO = drho(1,iG)*(dAO(1,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(1,nu,iG)) & + drho(2,iG)*(dAO(2,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(2,nu,iG)) & + drho(3,iG)*(dAO(3,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(3,nu,iG)) - gAO = weight(iG)*gAO - Fx(mu,nu) = Fx(mu,nu) - 2d0*gAO*3d0/4d0*beta*g**(-1d0/4d0)/r**(2d0/3d0) + Fx(mu,nu) = Fx(mu,nu) + 2d0*gAO*r**(4d0/3d0)*dxdg*( & + - 2d0*f + (6d0*b*x*asinh(x) + 6d0*b*x**2/sqrt(1d0+x**2))*f/(1d0 + 6d0*b*x*asinh(x)) ) end if diff --git a/src/eDFT/UCC_lda_exchange_derivative_discontinuity.f90 b/src/eDFT/UCC_lda_exchange_derivative_discontinuity.f90 index 660e98b..dbe7cca 100644 --- a/src/eDFT/UCC_lda_exchange_derivative_discontinuity.f90 +++ b/src/eDFT/UCC_lda_exchange_derivative_discontinuity.f90 @@ -22,7 +22,7 @@ subroutine UCC_lda_exchange_derivative_discontinuity(nEns,wEns,aCC_w1,aCC_w2,nGr integer :: iEns,jEns integer :: iG - double precision :: r,alpha + double precision :: r double precision,allocatable :: dExdw(:) double precision,external :: Kronecker_delta @@ -30,9 +30,6 @@ subroutine UCC_lda_exchange_derivative_discontinuity(nEns,wEns,aCC_w1,aCC_w2,nGr double precision :: a2,b2,c2,w2 double precision :: dCxdw1,dCxdw2 - double precision :: nEli,nElw - - ! Output variables double precision,intent(out) :: ExDD(nEns) @@ -60,13 +57,6 @@ subroutine UCC_lda_exchange_derivative_discontinuity(nEns,wEns,aCC_w1,aCC_w2,nGr b2 = aCC_w2(2) c2 = aCC_w2(3) - nElw = electron_number(nGrid,weight,rhow) - - -! Cx coefficient for unrestricted Slater LDA exchange - - alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) - w1 = wEns(2) w2 = wEns(3) @@ -86,11 +76,15 @@ subroutine UCC_lda_exchange_derivative_discontinuity(nEns,wEns,aCC_w1,aCC_w2,nGr dCxdw2 = (1d0 - w1*(1d0 - w1)*(a1 + b1*(w1 - 0.5d0) + c1*(w1 - 0.5d0)**2)) & * (0.5d0*b2 + (2d0*a2 + 0.5d0*c2)*(w2 - 0.5d0) - (1d0 - w2)*w2*(3d0*b2 + 4d0*c2*(w2 - 0.5d0))) + + case default + dCxdw1 = 0d0 + dCxdw2 = 0d0 + end select - - dCxdw1 = alpha*dCxdw1 - dCxdw2 = alpha*dCxdw2 + dCxdw1 = CxLSDA*dCxdw1 + dCxdw2 = CxLSDA*dCxdw2 dExdw(:) = 0d0 diff --git a/src/eDFT/UCC_lda_exchange_energy.f90 b/src/eDFT/UCC_lda_exchange_energy.f90 index b3fcbaf..0964c15 100644 --- a/src/eDFT/UCC_lda_exchange_energy.f90 +++ b/src/eDFT/UCC_lda_exchange_energy.f90 @@ -19,7 +19,7 @@ subroutine UCC_lda_exchange_energy(nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,rho,Ex,C ! Local variables integer :: iG - double precision :: r,alpha + double precision :: r double precision :: a1,b1,c1,w1 double precision :: a2,b2,c2,w2 @@ -65,10 +65,6 @@ subroutine UCC_lda_exchange_energy(nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,rho,Ex,C b2 = aCC_w2(2) c2 = aCC_w2(3) -! Cx coefficient for unrestricted Slater LDA exchange - - alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) - ! Fx1 for states N and N-1 ! Fx2 for states N and N+1 @@ -79,21 +75,20 @@ subroutine UCC_lda_exchange_energy(nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,rho,Ex,C Fx2 = 1d0 - w2*(1d0 - w2)*(a2 + b2*(w2 - 0.5d0) + c2*(w2 - 0.5d0)**2) select case (Cx_choice) - case(1) - Cx = alpha*Fx1 - case(2) - Cx = alpha*Fx2 - case(3) - Cx = alpha*Fx2*Fx1 + + case(1) + Cx = CxLSDA*Fx1 + + case(2) + Cx = CxLSDA*Fx2 + + case(3) + Cx = CxLSDA*Fx2*Fx1 + + case default + Cx = CxLSDA + end select -! for two-weights ensemble -! Cx = alpha*Fx2*Fx1 - -! for left ensemble -! Cx = alpha*Fx1 - -! for right ensemble -! Cx = alpha*Fx2 ! Compute GIC-LDA exchange energy diff --git a/src/eDFT/UCC_lda_exchange_individual_energy.f90 b/src/eDFT/UCC_lda_exchange_individual_energy.f90 index 98072ca..a0a0df3 100644 --- a/src/eDFT/UCC_lda_exchange_individual_energy.f90 +++ b/src/eDFT/UCC_lda_exchange_individual_energy.f90 @@ -22,9 +22,8 @@ subroutine UCC_lda_exchange_individual_energy(nEns,wEns,aCC_w1,aCC_w2,nGrid,weig ! Local variables integer :: iG - double precision :: r,rI,alpha + double precision :: r,rI double precision :: e_p,dedr - double precision :: nEli,nElw double precision :: a1,b1,c1,w1 double precision :: a2,b2,c2,w2 @@ -51,10 +50,6 @@ subroutine UCC_lda_exchange_individual_energy(nEns,wEns,aCC_w1,aCC_w2,nGrid,weig b2 = aCC_w2(2) c2 = aCC_w2(3) -! Cx coefficient for unrestricted Slater LDA exchange - - alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) - w1 = wEns(2) Fx1 = 1d0 - w1*(1d0 - w1)*(a1 + b1*(w1 - 0.5d0) + c1*(w1 - 0.5d0)**2) @@ -64,21 +59,19 @@ subroutine UCC_lda_exchange_individual_energy(nEns,wEns,aCC_w1,aCC_w2,nGrid,weig select case (Cx_choice) case(1) - Cx = alpha*Fx1 + Cx = CxLSDA*Fx1 case(2) - Cx = alpha*Fx2 + Cx = CxLSDA*Fx2 case(3) - Cx = alpha*Fx2*Fx1 + Cx = CxLSDA*Fx2*Fx1 + + case default + Cx = CxLSDA end select - nEli = electron_number(nGrid,weight,rho) - - nElw = electron_number(nGrid,weight,rhow) - - ! Compute LDA exchange matrix in the AO basis Ex = 0d0 @@ -92,19 +85,12 @@ subroutine UCC_lda_exchange_individual_energy(nEns,wEns,aCC_w1,aCC_w2,nGrid,weig e_p = Cx*r**(1d0/3d0) dedr = 1d0/3d0*Cx*r**(-2d0/3d0) - if (doNcentered) then - Ex = Ex - weight(iG)*dedr*r*r*(nEli/nElw) - else - Ex = Ex - weight(iG)*dedr*r*r - end if + Ex = Ex - weight(iG)*dedr*r*r if(rI > threshold) then - if (doNcentered) then - Ex = Ex + weight(iG)*(e_p*rI + dedr*r*rI) - else - Ex = Ex + weight(iG)*((nEli/nElw)*e_p*rI + dedr*r*rI) - end if + Ex = Ex + weight(iG)*(e_p*rI + dedr*r*rI) + endif endif diff --git a/src/eDFT/UCC_lda_exchange_potential.f90 b/src/eDFT/UCC_lda_exchange_potential.f90 index dc14909..ecb027f 100644 --- a/src/eDFT/UCC_lda_exchange_potential.f90 +++ b/src/eDFT/UCC_lda_exchange_potential.f90 @@ -21,7 +21,7 @@ subroutine UCC_lda_exchange_potential(nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,nBas, ! Local variables integer :: mu,nu,iG - double precision :: r,vAO,alpha + double precision :: r,vAO double precision :: a1,b1,c1,w1 double precision :: a2,b2,c2,w2 @@ -67,10 +67,6 @@ subroutine UCC_lda_exchange_potential(nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,nBas, b2 = aCC_w2(2) c2 = aCC_w2(3) -! Cx coefficient for unrestricted Slater LDA exchange - - alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) - ! Fx1 for states N and N-1 ! Fx2 for states N and N+1 @@ -81,23 +77,21 @@ subroutine UCC_lda_exchange_potential(nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,nBas, Fx2 = 1d0 - w2*(1d0 - w2)*(a2 + b2*(w2 - 0.5d0) + c2*(w2 - 0.5d0)**2) select case (Cx_choice) - case(1) - Cx = alpha*Fx1 - case(2) - Cx = alpha*Fx2 - case(3) - Cx = alpha*Fx2*Fx1 + + case(1) + Cx = CxLSDA*Fx1 + + case(2) + Cx = CxLSDA*Fx2 + + case(3) + Cx = CxLSDA*Fx2*Fx1 + + case default + Cx = CxLSDA + end select -! for two-weight ensembles -! Cx = alpha*Fx2*Fx1 - -! for left ensemble -! Cx = alpha*Fx1 - -! for right ensemble -! Cx = alpha*Fx2 - ! Compute LDA exchange matrix in the AO basis Fx(:,:) = 0d0 diff --git a/src/eDFT/UG96_gga_exchange_energy.f90 b/src/eDFT/UG96_gga_exchange_energy.f90 index 48f0a8c..f09d2a7 100644 --- a/src/eDFT/UG96_gga_exchange_energy.f90 +++ b/src/eDFT/UG96_gga_exchange_energy.f90 @@ -11,12 +11,12 @@ subroutine UG96_gga_exchange_energy(nGrid,weight,rho,drho,Ex) integer,intent(in) :: nGrid double precision,intent(in) :: weight(nGrid) double precision,intent(in) :: rho(nGrid) - double precision,intent(in) :: drho(3,nGrid) + double precision,intent(in) :: drho(ncart,nGrid) ! Local variables integer :: iG - double precision :: alpha,beta + double precision :: beta double precision :: r,g ! Output variables @@ -25,7 +25,6 @@ subroutine UG96_gga_exchange_energy(nGrid,weight,rho,drho,Ex) ! Coefficients for G96 GGA exchange functional - alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) beta = 1d0/137d0 ! Compute GGA exchange energy @@ -40,7 +39,7 @@ subroutine UG96_gga_exchange_energy(nGrid,weight,rho,drho,Ex) g = drho(1,iG)**2 + drho(2,iG)**2 + drho(3,iG)**2 - Ex = Ex + weight(iG)*r**(4d0/3d0)*(alpha - beta*g**(3d0/4d0)/r**2) + Ex = Ex + weight(iG)*r**(4d0/3d0)*(CxLSDA - beta*g**(3d0/4d0)/r**2) end if diff --git a/src/eDFT/UG96_gga_exchange_potential.f90 b/src/eDFT/UG96_gga_exchange_potential.f90 index 2dd097b..4b28a3c 100644 --- a/src/eDFT/UG96_gga_exchange_potential.f90 +++ b/src/eDFT/UG96_gga_exchange_potential.f90 @@ -18,7 +18,7 @@ subroutine UG96_gga_exchange_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fx) ! Local variables integer :: mu,nu,iG - double precision :: alpha,beta + double precision :: beta double precision :: r,g,vAO,gAO ! Output variables @@ -27,9 +27,7 @@ subroutine UG96_gga_exchange_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fx) ! Coefficients for G96 GGA exchange functional - alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) beta = +1d0/137d0 - beta = 0d0 ! Compute GGA exchange matrix in the AO basis @@ -46,7 +44,7 @@ subroutine UG96_gga_exchange_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fx) vAO = weight(iG)*AO(mu,iG)*AO(nu,iG) Fx(mu,nu) = Fx(mu,nu) & - + vAO*(4d0/3d0*r**(1d0/3d0)*(alpha - beta*g**(3d0/4d0)/r**2) & + + vAO*(4d0/3d0*r**(1d0/3d0)*(CxLSDA - beta*g**(3d0/4d0)/r**2) & + 2d0*beta*g**(3d0/4d0)/r**(5d0/3d0)) gAO = drho(1,iG)*(dAO(1,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(1,nu,iG)) & diff --git a/src/eDFT/ULYP_gga_correlation_energy.f90 b/src/eDFT/ULYP_gga_correlation_energy.f90 new file mode 100644 index 0000000..e0788b8 --- /dev/null +++ b/src/eDFT/ULYP_gga_correlation_energy.f90 @@ -0,0 +1,73 @@ +subroutine ULYP_gga_correlation_energy(nGrid,weight,rho,drho,Ec) + +! Compute unrestricted LYP GGA correlation energy + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rho(nGrid,nspin) + double precision,intent(in) :: drho(ncart,nGrid,nspin) + +! Local variables + + integer :: iG + double precision :: ra,rb,r + double precision :: ga,gab,gb,g + + double precision :: a,b,c,d + double precision :: Cf,omega,delta + +! Output variables + + double precision :: Ec(nsp) + +! Parameters of the functional + + a = 0.04918d0 + b = 0.132d0 + c = 0.2533d0 + d = 0.349d0 + + Cf = 3d0/10d0*(3d0*pi**2)**(2d0/3d0) + +! Initialization + + Ec(:) = 0d0 + + do iG=1,nGrid + + ra = max(0d0,rho(iG,1)) + rb = max(0d0,rho(iG,2)) + r = ra + rb + + if(r > threshold) then + + ga = drho(1,iG,1)*drho(1,iG,1) + drho(2,iG,1)*drho(2,iG,1) + drho(3,iG,1)*drho(3,iG,1) + gb = drho(1,iG,2)*drho(1,iG,2) + drho(2,iG,2)*drho(2,iG,2) + drho(3,iG,2)*drho(3,iG,2) + gab = drho(1,iG,1)*drho(1,iG,2) + drho(2,iG,1)*drho(2,iG,2) + drho(3,iG,1)*drho(3,iG,2) + g = ga + 2d0*gab + gb + + omega = exp(-c*r**(-1d0/3d0))/(1d0 + d*r**(-1d0/3d0))*r**(-11d0/3d0) + delta = c*r**(-1d0/3d0) + d*r**(-1d0/3d0)/(1d0 + d*r**(-1d0/3d0)) + + Ec(2) = Ec(2) - weight(iG)*4d0*a/(1d0 + d*r**(-1d0/3d0))*ra*rb/r & + - weight(iG)*a*b*omega*ra*rb*( & + 2d0**(11d0/3d0)*Cf*(ra**(8d0/3d0) + rb**(8d0/3d0)) & + + (47d0/18d0 - 7d0*delta/18d0)*g & + - (5d0/2d0 - delta/18d0)*(ga + gb) & + - (delta - 11d0)/9d0*(ra/r*ga + rb/r*gb) ) & + - weight(iG)*a*b*omega*( & + - 2d0*r**2/3d0*g & + + (2d0*r**2/3d0 - ra**2)*gb & + + (2d0*r**2/3d0 - rb**2)*ga ) + + end if + + end do + +end subroutine ULYP_gga_correlation_energy diff --git a/src/eDFT/ULYP_gga_correlation_potential.f90 b/src/eDFT/ULYP_gga_correlation_potential.f90 new file mode 100644 index 0000000..702aba3 --- /dev/null +++ b/src/eDFT/ULYP_gga_correlation_potential.f90 @@ -0,0 +1,156 @@ +subroutine ULYP_gga_correlation_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fc) + +! Compute LYP correlation potential + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + integer,intent(in) :: nBas + double precision,intent(in) :: AO(nBas,nGrid) + double precision,intent(in) :: dAO(ncart,nBas,nGrid) + double precision,intent(in) :: rho(nGrid,nspin) + double precision,intent(in) :: drho(ncart,nGrid,nspin) + +! Local variables + + integer :: mu,nu,iG + double precision :: vAO,gaAO,gbAO + double precision :: ra,rb,r + double precision :: ga,gab,gb,g + double precision :: dfdra,dfdrb + double precision :: dfdga,dfdgab,dfdgb + double precision :: dodra,dodrb,dddra,dddrb + + double precision :: a,b,c,d + double precision :: Cf,omega,delta + +! Output variables + + double precision,intent(out) :: Fc(nBas,nBas,nspin) + +! Prameter of the functional + + a = 0.04918d0 + b = 0.132d0 + c = 0.2533d0 + d = 0.349d0 + + Cf = 3d0/10d0*(3d0*pi**2)**(2d0/3d0) + +! Compute matrix elements in the AO basis + + Fc(:,:,:) = 0d0 + + do mu=1,nBas + do nu=1,nBas + do iG=1,nGrid + + ra = max(0d0,rho(iG,1)) + rb = max(0d0,rho(iG,2)) + r = ra + rb + + if(r > threshold) then + + ga = drho(1,iG,1)*drho(1,iG,1) + drho(2,iG,1)*drho(2,iG,1) + drho(3,iG,1)*drho(3,iG,1) + gb = drho(1,iG,2)*drho(1,iG,2) + drho(2,iG,2)*drho(2,iG,2) + drho(3,iG,2)*drho(3,iG,2) + gab = drho(1,iG,1)*drho(1,iG,2) + drho(2,iG,1)*drho(2,iG,2) + drho(3,iG,1)*drho(3,iG,2) + g = ga + 2d0*gab + gb + + omega = exp(-c*r**(-1d0/3d0))/(1d0 + d*r**(-1d0/3d0))*r**(-11d0/3d0) + delta = c*r**(-1d0/3d0) + d*r**(-1d0/3d0)/(1d0 + d*r**(-1d0/3d0)) + + vAO = weight(iG)*AO(mu,iG)*AO(nu,iG) + + dodra = (d/(3d0*r**(4d0/3d0)*(1d0 + d*r**(-1d0/3d0))) + c/(3d0*r**(4d0/3d0)) - 11d0/(3d0*r))*omega + dodrb = dodra + + dddra = - c/3d0*r**(-4d0/3d0) & + + d**2/(3d0*(1d0 + d*r**(-1d0/3d0))**2)*r**(-5d0/3d0) & + - d/(3d0*(1d0 + d*r**(-1d0/3d0)))*r**(-4d0/3d0) + dddrb = dddra + + dfdra = - 4d0*a/(1d0 + d*r**(-1d0/3d0))*rb/r & + - 4d0/3d0*a*d/(1d0 + d*r**(-1d0/3d0))**2*ra*rb/r**(7d0/3d0) & + + 4d0*a/(1d0 + d*r**(-1d0/3d0))*ra*rb/r**2 & + - a*b*omega*rb*( & + + 2d0**(11d0/3d0)*Cf*(ra**(8d0/3d0) + rb**(8d0/3d0)) & + + (47d0/18d0 - 7d0*delta/18d0)*g & + - (5d0/2d0 - delta/18d0)*(ga + gb) & + - (delta - 11d0)/9d0*(ra/r*ga + rb/r*gb) & + - 4d0/3d0*r/rb*g & + + (4d0/3d0*r/rb - 2d0*ra/rb)*gb & + + 4d0/3d0*r/rb*ga ) & + - a*b*omega*ra*rb*( & + + 8d0/3d0*2d0**(11d0/3d0)*Cf*ra**(5d0/3d0) & + - 7d0*dddra/18d0*g & + + dddra/18d0*(ga + gb) & + - dddra/9d0*(ra/r*ga + rb/r*gb) & + - (delta - 11d0)/(9d0*r)*(-ra/r*ga - rb/r*gb + ga) ) & + - a*b*dodra*ra*rb*( & + + 2d0**(11d0/3d0)*Cf*(ra**(8d0/3d0) + rb**(8d0/3d0)) & + + (47d0/18d0 - 7d0*delta/18d0)*g & + - (5d0/2d0 - delta/18d0)*(ga + gb) & + - (delta - 11d0)/9d0*(ra/r*ga + rb/r*gb) ) & + - a*b*dodra*( & + - 2d0*r**2/3d0*g & + + (2d0*r**2/3d0 - ra**2)*gb & + + (2d0*r**2/3d0 - rb**2)*ga ) + + dfdrb = - 4d0*a/(1d0 + d*r**(-1d0/3d0))*ra/r & + - 4d0/3d0*a*d/(1d0 + d*r**(-1d0/3d0))**2*ra*rb/r**(7d0/3d0) & + + 4d0*a/(1d0 + d*r**(-1d0/3d0))*ra*rb/r**2 & + - a*b*omega*ra*( & + + 2d0**(11d0/3d0)*Cf*(ra**(8d0/3d0) + rb**(8d0/3d0)) & + + (47d0/18d0 - 7d0*delta/18d0)*g & + - (5d0/2d0 - delta/18d0)*(ga + gb) & + - (delta - 11d0)/9d0*(ra/r*ga + rb/r*gb) & + - 4d0/3d0*r/ra*g & + + (4d0/3d0*r/ra - 2d0*rb/ra)*ga & + + 4d0/3d0*r/ra*gb ) & + - a*b*omega*ra*rb*( & + + 8d0/3d0*2d0**(11d0/3d0)*Cf*rb**(5d0/3d0) & + - 7d0*dddrb/18d0*g & + + dddrb/18d0*(ga + gb) & + - dddrb/9d0*(ra/r*ga + rb/r*gb) & + - (delta - 11d0)/(9d0*r)*(-ra/r*ga - rb/r*gb + gb) ) & + - a*b*dodrb*ra*rb*( & + + 2d0**(11d0/3d0)*Cf*(ra**(8d0/3d0) + rb**(8d0/3d0)) & + + (47d0/18d0 - 7d0*delta/18d0)*g & + - (5d0/2d0 - delta/18d0)*(ga + gb) & + - (delta - 11d0)/9d0*(ra/r*ga + rb/r*gb) ) & + - a*b*dodrb*( & + - 2d0*r**2/3d0*g & + + (2d0*r**2/3d0 - ra**2)*gb & + + (2d0*r**2/3d0 - rb**2)*ga ) + + Fc(mu,nu,1) = Fc(mu,nu,1) + vAO*dfdra + Fc(mu,nu,2) = Fc(mu,nu,2) + vAO*dfdrb + + gaAO = drho(1,iG,1)*(dAO(1,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(1,nu,iG)) & + + drho(2,iG,1)*(dAO(2,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(2,nu,iG)) & + + drho(3,iG,1)*(dAO(3,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(3,nu,iG)) + gaAO = weight(iG)*gaAO + + gbAO = drho(1,iG,2)*(dAO(1,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(1,nu,iG)) & + + drho(2,iG,2)*(dAO(2,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(2,nu,iG)) & + + drho(3,iG,2)*(dAO(3,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(3,nu,iG)) + gbAO = weight(iG)*gbAO + + dfdga = -a*b*omega*(-rb**2 + ra*rb*(1d0/9d0 - (delta-11d0)/9d0*ra/r - delta/3d0)) + dfdgab = -a*b*omega*(-4d0/3d0*r**2 + 2d0*ra*rb*(47d0/18d0 - 7d0*delta/18d0)) + dfdgb = -a*b*omega*(-ra**2 + ra*rb*(1d0/9d0 - (delta-11d0)/9d0*rb/r - delta/3d0)) + + Fc(mu,nu,1) = Fc(mu,nu,1) + 2d0*gaAO*dfdga + gbAO*dfdgab + Fc(mu,nu,2) = Fc(mu,nu,2) + 2d0*gbAO*dfdgb + gaAO*dfdgab + + end if + + end do + end do + end do + +end subroutine ULYP_gga_correlation_potential diff --git a/src/eDFT/UPBE_gga_correlation_energy.f90 b/src/eDFT/UPBE_gga_correlation_energy.f90 new file mode 100644 index 0000000..461e2bb --- /dev/null +++ b/src/eDFT/UPBE_gga_correlation_energy.f90 @@ -0,0 +1,172 @@ +subroutine UPBE_gga_correlation_energy(nGrid,weight,rho,drho,Ec) + +! Compute unrestricted PBE GGA correlation energy + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rho(nGrid,nspin) + double precision,intent(in) :: drho(ncart,nGrid,nspin) + +! Local variables + + integer :: iG + double precision :: ra,rb,r,rs,z + double precision :: ga,gab,gb,g + + double precision :: a,b,c,d + double precision :: gam,beta + + double precision :: A_p,a1_p,b1_p,b2_p,b3_p,b4_p + double precision :: A_f,a1_f,b1_f,b2_f,b3_f,b4_f + double precision :: A_a,a1_a,b1_a,b2_a,b3_a,b4_a + + double precision :: ec_z,ec_p,ec_f,ec_a + double precision :: fz,d2fz + + double precision :: H,kf,ks,t,phi + +! Output variables + + double precision :: Ec(nsp) + +! Parameters for PW92 + + A_p = 0.031091d0 + a1_p = 0.21370d0 + b1_p = 7.5957d0 + b2_p = 3.5876d0 + b3_p = 1.6382d0 + b4_p = 0.49294d0 + + A_f = 0.015545d0 + a1_f = 0.20548d0 + b1_f = 14.1189d0 + b2_f = 6.1977d0 + b3_f = 3.3662d0 + b4_f = 0.62517d0 + + A_a = 0.016887d0 + a1_a = 0.11125d0 + b1_a = 10.357d0 + b2_a = 3.6231d0 + b3_a = 0.88026d0 + b4_a = 0.49671d0 + +! Parameters PBE + + gam = (1d0 - log(2d0))/pi**2 + beta = 0.066725d0 + +! Initialization + + Ec(:) = 0d0 + + do iG=1,nGrid + + ra = max(0d0,rho(iG,1)) + rb = max(0d0,rho(iG,2)) + r = ra + rb + z = (ra - rb)/r + +! alpha-alpha contribution + + if(ra > threshold) then + + rs = (4d0*pi*ra/3d0)**(-1d0/3d0) + + ec_f = b1_f*sqrt(rs) + b2_f*rs + b3_f*rs**(3d0/2d0) + b4_f*rs**2 + ec_f = -2d0*A_f*(1d0 + a1_f*rs)*log(1d0 + 1d0/(2d0*A_f*ec_f)) + + ga = drho(1,iG,1)*drho(1,iG,1) + drho(2,iG,1)*drho(2,iG,1) + drho(3,iG,1)*drho(3,iG,1) + + kf = (3d0*pi**2*ra)**(1d0/3d0) + ks = sqrt(4d0*kf/pi) + phi = 1d0 + t = sqrt(ga)/(2d0*phi*ks*ra) + + A = beta/gam/(exp(-ec_f/(gam*phi**3)) - 1d0) + + H = gam*phi**3*log(1d0 + beta/gam*t**2*((1d0 + A*t**2)/(1d0 + A*t**2 + A**2*t**4))) + + Ec(1) = Ec(1) + weight(iG)*(ec_f + H)*ra + + end if + + r = ra + rb + +! alpha-beta contribution + + if(r > threshold) then + + rs = (4d0*pi*r/3d0)**(-1d0/3d0) + + fz = (1d0 + z)**(4d0/3d0) + (1d0 - z)**(4d0/3d0) - 2d0 + fz = fz/(2d0*(2d0**(1d0/3d0) - 1d0)) + d2fz = 4d0/(9d0*(2**(1d0/3d0) - 1d0)) + + ec_p = b1_p*sqrt(rs) + b2_p*rs + b3_p*rs**(3d0/2d0) + b4_p*rs**2 + ec_p = -2d0*A_p*(1d0 + a1_p*rs)*log(1d0 + 1d0/(2d0*A_p*ec_p)) + + ec_f = b1_f*sqrt(rs) + b2_f*rs + b3_f*rs**(3d0/2d0) + b4_f*rs**2 + ec_f = -2d0*A_f*(1d0 + a1_f*rs)*log(1d0 + 1d0/(2d0*A_f*ec_f)) + + ec_a = b1_a*sqrt(rs) + b2_a*rs + b3_a*rs**(3d0/2d0) + b4_a*rs**2 + ec_a = +2d0*A_a*(1d0 + a1_a*rs)*log(1d0 + 1d0/(2d0*A_a*ec_a)) + + ec_z = ec_p + ec_a*fz/d2fz*(1d0-z**4) + (ec_f - ec_p)*fz*z**4 + + ga = drho(1,iG,1)*drho(1,iG,1) + drho(2,iG,1)*drho(2,iG,1) + drho(3,iG,1)*drho(3,iG,1) + gb = drho(1,iG,2)*drho(1,iG,2) + drho(2,iG,2)*drho(2,iG,2) + drho(3,iG,2)*drho(3,iG,2) + gab = drho(1,iG,1)*drho(1,iG,2) + drho(2,iG,1)*drho(2,iG,2) + drho(3,iG,1)*drho(3,iG,2) + g = ga + 2d0*gab + gb + + rs = (4d0*pi*r/3d0)**(-1d0/3d0) + kf = (3d0*pi**2*r)**(1d0/3d0) + ks = sqrt(4d0*kf/pi) + phi = ((1d0 + z)**(2d0/3d0) + (1d0 - z)**(2d0/3d0))/2d0 + t = sqrt(g)/(2d0*phi*ks*r) + + A = beta/gam/(exp(-ec_p/(gam*phi**3)) - 1d0) + + H = gam*phi**3*log(1d0 + beta/gam*t**2*((1d0 + A*t**2)/(1d0 + A*t**2 + A**2*t**4))) + + Ec(2) = Ec(2) - weight(iG)*(ec_p + H)*r + + end if + +! beta-beta contribution + + if(rb > threshold) then + + rs = (4d0*pi*rb/3d0)**(-1d0/3d0) + + ec_f = b1_f*sqrt(rs) + b2_f*rs + b3_f*rs**(3d0/2d0) + b4_f*rs**2 + ec_f = -2d0*A_f*(1d0 + a1_f*rs)*log(1d0 + 1d0/(2d0*A_f*ec_f)) + + gb = drho(1,iG,2)*drho(1,iG,2) + drho(2,iG,2)*drho(2,iG,2) + drho(3,iG,2)*drho(3,iG,2) + + kf = (3d0*pi**2*rb)**(1d0/3d0) + ks = sqrt(4d0*kf/pi) + phi = 1d0 + t = sqrt(gb)/(2d0*phi*ks*rb) + + A = beta/gam/(exp(-ec_f/(gam*phi**3)) - 1d0) + + H = gam*phi**3*log(1d0 + beta/gam*t**2*((1d0 + A*t**2)/(1d0 + A*t**2 + A**2*t**4))) + + Ec(3) = Ec(3) + weight(iG)*(ec_f + H)*rb + + end if + + end do + + Ec(2) = Ec(2) - Ec(1) - Ec(3) + + +end subroutine UPBE_gga_correlation_energy diff --git a/src/eDFT/UPBE_gga_correlation_potential.f90 b/src/eDFT/UPBE_gga_correlation_potential.f90 new file mode 100644 index 0000000..af8794a --- /dev/null +++ b/src/eDFT/UPBE_gga_correlation_potential.f90 @@ -0,0 +1,88 @@ +subroutine UPBE_gga_correlation_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fc) + +! Compute LYP correlation potential + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + integer,intent(in) :: nBas + double precision,intent(in) :: AO(nBas,nGrid) + double precision,intent(in) :: dAO(ncart,nBas,nGrid) + double precision,intent(in) :: rho(nGrid,nspin) + double precision,intent(in) :: drho(ncart,nGrid,nspin) + +! Local variables + + integer :: mu,nu,iG + double precision :: vAO,gaAO,gbAO + double precision :: ra,rb,r + double precision :: ga,gab,gb,g + double precision :: dfdra,dfdrb + double precision :: dfdga,dfdgab,dfdgb + double precision :: dodra,dodrb,dddra,dddrb + + double precision :: a,b,c,d + double precision :: Cf,omega,delta + +! Output variables + + double precision,intent(out) :: Fc(nBas,nBas,nspin) + +! Prameter of the functional + +! Compute matrix elements in the AO basis + + call UPW92_lda_correlation_potential(nGrid,weight,nBas,AO,rho,Fc) + + do mu=1,nBas + do nu=1,nBas + do iG=1,nGrid + + ra = max(0d0,rho(iG,1)) + rb = max(0d0,rho(iG,2)) + r = ra + rb + + if(r > threshold) then + + ga = drho(1,iG,1)*drho(1,iG,1) + drho(2,iG,1)*drho(2,iG,1) + drho(3,iG,1)*drho(3,iG,1) + gb = drho(1,iG,2)*drho(1,iG,2) + drho(2,iG,2)*drho(2,iG,2) + drho(3,iG,2)*drho(3,iG,2) + gab = drho(1,iG,1)*drho(1,iG,2) + drho(2,iG,1)*drho(2,iG,2) + drho(3,iG,1)*drho(3,iG,2) + g = ga + 2d0*gab + gb + + vAO = weight(iG)*AO(mu,iG)*AO(nu,iG) + + dfdra = 0d0 + dfdrb = 0d0 + + Fc(mu,nu,1) = Fc(mu,nu,1) + vAO*dfdra + Fc(mu,nu,2) = Fc(mu,nu,2) + vAO*dfdrb + + gaAO = drho(1,iG,1)*(dAO(1,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(1,nu,iG)) & + + drho(2,iG,1)*(dAO(2,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(2,nu,iG)) & + + drho(3,iG,1)*(dAO(3,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(3,nu,iG)) + gaAO = weight(iG)*gaAO + + gbAO = drho(1,iG,2)*(dAO(1,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(1,nu,iG)) & + + drho(2,iG,2)*(dAO(2,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(2,nu,iG)) & + + drho(3,iG,2)*(dAO(3,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(3,nu,iG)) + gbAO = weight(iG)*gbAO + + dfdga = 0d0 + dfdgab = 0d0 + dfdgb = 0d0 + + + Fc(mu,nu,1) = Fc(mu,nu,1) + 2d0*gaAO*dfdga + gbAO*dfdgab + Fc(mu,nu,2) = Fc(mu,nu,2) + 2d0*gbAO*dfdgb + gaAO*dfdgab + + end if + + end do + end do + end do + +end subroutine UPBE_gga_correlation_potential diff --git a/src/eDFT/UPBE_gga_exchange_energy.f90 b/src/eDFT/UPBE_gga_exchange_energy.f90 new file mode 100644 index 0000000..0cc35bd --- /dev/null +++ b/src/eDFT/UPBE_gga_exchange_energy.f90 @@ -0,0 +1,49 @@ +subroutine UPBE_gga_exchange_energy(nGrid,weight,rho,drho,Ex) + +! Compute PBE GGA exchange energy + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rho(nGrid) + double precision,intent(in) :: drho(3,nGrid) + +! Local variables + + integer :: iG + double precision :: mupbe,kappa + double precision :: r,g,s2 + +! Output variables + + double precision :: Ex + +! Coefficients for PBE exchange functional + + mupbe = ((1d0/2d0**(1d0/3d0))/(2d0*(3d0*pi**2)**(1d0/3d0)))**2*0.21951d0 + kappa = 0.804d0 + +! Compute GGA exchange energy + + Ex = 0d0 + + do iG=1,nGrid + + r = max(0d0,rho(iG)) + + if(r > threshold) then + g = drho(1,iG)**2 + drho(2,iG)**2 + drho(3,iG)**2 + s2 = g/r**(8d0/3d0) + + Ex = Ex + weight(iG)*CxLSDA*r**(4d0/3d0)*(1d0 + kappa - kappa/(1d0 + mupbe*s2/kappa)) + + end if + + end do + +end subroutine UPBE_gga_exchange_energy diff --git a/src/eDFT/UPBE_gga_exchange_potential.f90 b/src/eDFT/UPBE_gga_exchange_potential.f90 new file mode 100644 index 0000000..866b90a --- /dev/null +++ b/src/eDFT/UPBE_gga_exchange_potential.f90 @@ -0,0 +1,67 @@ +subroutine UPBE_gga_exchange_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fx) + +! Compute PBE GGA exchange potential + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + integer,intent(in) :: nBas + double precision,intent(in) :: AO(nBas,nGrid) + double precision,intent(in) :: dAO(3,nBas,nGrid) + double precision,intent(in) :: rho(nGrid) + double precision,intent(in) :: drho(3,nGrid) + +! Local variables + + integer :: mu,nu,iG + double precision :: mupbe,kappa + double precision :: r,g,s2,vAO,gAO + +! Output variables + + double precision,intent(out) :: Fx(nBas,nBas) + +! Coefficients for PBE exchange functional + + mupbe = ((1d0/2d0**(1d0/3d0))/(2d0*(3d0*pi**2)**(1d0/3d0)))**2*0.21951d0 + kappa = 0.804d0 + +! Compute GGA exchange matrix in the AO basis + + Fx(:,:) = 0d0 + + do mu=1,nBas + do nu=1,nBas + do iG=1,nGrid + + r = max(0d0,rho(iG)) + + if(r > threshold) then + + g = drho(1,iG)**2 + drho(2,iG)**2 + drho(3,iG)**2 + s2 = g/r**(8d0/3d0) + + vAO = weight(iG)*AO(mu,iG)*AO(nu,iG) + + Fx(mu,nu) = Fx(mu,nu) & + + vAO*4d0/3d0*CxLSDA*r**(1d0/3d0)*(1d0 + kappa - kappa/(1d0 + mupbe*s2/kappa)) & + - vAO*8d0/3d0*CxLSDA*r**(1d0/3d0)*mupbe*s2/(1d0 + mupbe*s2/kappa)**2 + + gAO = drho(1,iG)*(dAO(1,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(1,nu,iG)) & + + drho(2,iG)*(dAO(2,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(2,nu,iG)) & + + drho(3,iG)*(dAO(3,mu,iG)*AO(nu,iG) + AO(mu,iG)*dAO(3,nu,iG)) + gAO = weight(iG)*gAO + + Fx(mu,nu) = Fx(mu,nu) + 2d0*gAO*CxLSDA*r**(-4d0/3d0)*mupbe/(1d0 + mupbe*s2/kappa)**2 + + end if + + end do + end do + end do + +end subroutine UPBE_gga_exchange_potential diff --git a/src/eDFT/UPW92_lda_correlation_energy.f90 b/src/eDFT/UPW92_lda_correlation_energy.f90 new file mode 100644 index 0000000..9a70abc --- /dev/null +++ b/src/eDFT/UPW92_lda_correlation_energy.f90 @@ -0,0 +1,120 @@ +subroutine UPW92_lda_correlation_energy(nGrid,weight,rho,Ec) + +! Compute unrestricted PW92 LDA correlation energy + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rho(nGrid,nspin) + +! Local variables + + integer :: iG + double precision :: ra,rb,r,rs,z + double precision :: A_p,a1_p,b1_p,b2_p,b3_p,b4_p + double precision :: A_f,a1_f,b1_f,b2_f,b3_f,b4_f + double precision :: A_a,a1_a,b1_a,b2_a,b3_a,b4_a + + double precision :: ec_z,ec_p,ec_f,ec_a + double precision :: fz,d2fz + +! Output variables + + double precision :: Ec(nsp) + +! Parameters of the functional + + A_p = 0.031091d0 + a1_p = 0.21370d0 + b1_p = 7.5957d0 + b2_p = 3.5876d0 + b3_p = 1.6382d0 + b4_p = 0.49294d0 + + A_f = 0.015545d0 + a1_f = 0.20548d0 + b1_f = 14.1189d0 + b2_f = 6.1977d0 + b3_f = 3.3662d0 + b4_f = 0.62517d0 + + A_a = 0.016887d0 + a1_a = 0.11125d0 + b1_a = 10.357d0 + b2_a = 3.6231d0 + b3_a = 0.88026d0 + b4_a = 0.49671d0 + +! Initialization + + Ec(:) = 0d0 + + do iG=1,nGrid + + ra = max(0d0,rho(iG,1)) + rb = max(0d0,rho(iG,2)) + r = ra + rb + z = (ra - rb)/r + +! alpha-alpha contribution + + if(ra > threshold) then + + rs = (4d0*pi*ra/3d0)**(-1d0/3d0) + + ec_f = b1_f*sqrt(rs) + b2_f*rs + b3_f*rs**(3d0/2d0) + b4_f*rs**2 + ec_f = -2d0*A_f*(1d0 + a1_f*rs)*log(1d0 + 1d0/(2d0*A_f*ec_f)) + + Ec(1) = Ec(1) + weight(iG)*ec_f*ra + + end if + +! alpha-beta contribution + + if(r > threshold) then + + rs = (4d0*pi*r/3d0)**(-1d0/3d0) + + fz = (1d0 + z)**(4d0/3d0) + (1d0 - z)**(4d0/3d0) - 2d0 + fz = fz/(2d0*(2d0**(1d0/3d0) - 1d0)) + + d2fz = 4d0/(9d0*(2**(1d0/3d0) - 1d0)) + + ec_p = b1_p*sqrt(rs) + b2_p*rs + b3_p*rs**(3d0/2d0) + b4_p*rs**2 + ec_p = -2d0*A_p*(1d0 + a1_p*rs)*log(1d0 + 1d0/(2d0*A_p*ec_p)) + + ec_f = b1_f*sqrt(rs) + b2_f*rs + b3_f*rs**(3d0/2d0) + b4_f*rs**2 + ec_f = -2d0*A_f*(1d0 + a1_f*rs)*log(1d0 + 1d0/(2d0*A_f*ec_f)) + + ec_a = b1_a*sqrt(rs) + b2_a*rs + b3_a*rs**(3d0/2d0) + b4_a*rs**2 + ec_a = +2d0*A_a*(1d0 + a1_a*rs)*log(1d0 + 1d0/(2d0*A_a*ec_a)) + + ec_z = ec_p + ec_a*fz/d2fz*(1d0-z**4) + (ec_f - ec_p)*fz*z**4 + + Ec(2) = Ec(2) + weight(iG)*ec_z*r + + end if + +! beta-beta contribution + + if(rb > threshold) then + + rs = (4d0*pi*rb/3d0)**(-1d0/3d0) + + ec_f = b1_f*sqrt(rs) + b2_f*rs + b3_f*rs**(3d0/2d0) + b4_f*rs**2 + ec_f = -2d0*A_f*(1d0 + a1_f*rs)*log(1d0 + 1d0/(2d0*A_f*ec_f)) + + Ec(3) = Ec(3) + weight(iG)*ec_f*rb + + end if + + end do + + Ec(2) = Ec(2) - Ec(1) - Ec(3) + +end subroutine UPW92_lda_correlation_energy diff --git a/src/eDFT/UPW92_lda_correlation_potential.f90 b/src/eDFT/UPW92_lda_correlation_potential.f90 new file mode 100644 index 0000000..d63d9e4 --- /dev/null +++ b/src/eDFT/UPW92_lda_correlation_potential.f90 @@ -0,0 +1,185 @@ +subroutine UPW92_lda_correlation_potential(nGrid,weight,nBas,AO,rho,Fc) + +! Compute unrestricted PW92 LDA correlation potential + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + integer,intent(in) :: nBas + double precision,intent(in) :: AO(nBas,nGrid) + double precision,intent(in) :: rho(nGrid,nspin) + +! Local variables + + integer :: mu,nu,iG + double precision :: ra,rb,r,rs,z,t,dt + double precision :: A_p,a1_p,b1_p,b2_p,b3_p,b4_p + double precision :: A_f,a1_f,b1_f,b2_f,b3_f,b4_f + double precision :: A_a,a1_a,b1_a,b2_a,b3_a,b4_a + double precision :: dfzdz,decdrs_p,decdrs_f,decdrs_a + double precision :: dzdra,dfzdra,drsdra,decdra_p,decdra_f,decdra_a,decdra + double precision :: dzdrb,dfzdrb,drsdrb,decdrb_p,decdrb_f,decdrb_a,decdrb + + double precision :: ec_z,ec_p,ec_f,ec_a + double precision :: fz,d2fz + +! Output variables + + double precision :: Fc(nBas,nBas,nspin) + +! Parameters of the functional + + A_p = 0.031091d0 + a1_p = 0.21370d0 + b1_p = 7.5957d0 + b2_p = 3.5876d0 + b3_p = 1.6382d0 + b4_p = 0.49294d0 + + A_f = 0.015545d0 + a1_f = 0.20548d0 + b1_f = 14.1189d0 + b2_f = 6.1977d0 + b3_f = 3.3662d0 + b4_f = 0.62517d0 + + A_a = 0.016887d0 + a1_a = 0.11125d0 + b1_a = 10.357d0 + b2_a = 3.6231d0 + b3_a = 0.88026d0 + b4_a = 0.49671d0 + +! Initialization + + Fc(:,:,:) = 0d0 + + do mu=1,nBas + do nu=1,nBas + do iG=1,nGrid + + ra = max(0d0,rho(iG,1)) + rb = max(0d0,rho(iG,2)) + +! spin-up contribution + + if(ra > threshold) then + + r = ra + rb + rs = (4d0*pi*r/3d0)**(-1d0/3d0) + z = (ra - rb)/r + + fz = (1d0 + z)**(4d0/3d0) + (1d0 - z)**(4d0/3d0) - 2d0 + fz = fz/(2d0*(2d0**(1d0/3d0) - 1d0)) + + d2fz = 4d0/(9d0*(2**(1d0/3d0) - 1d0)) + + ec_p = b1_p*sqrt(rs) + b2_p*rs + b3_p*rs**(3d0/2d0) + b4_p*rs**2 + ec_p = -2d0*A_p*(1d0 + a1_p*rs)*log(1d0 + 1d0/(2d0*A_p*ec_p)) + + ec_f = b1_f*sqrt(rs) + b2_f*rs + b3_f*rs**(3d0/2d0) + b4_f*rs**2 + ec_f = -2d0*A_f*(1d0 + a1_f*rs)*log(1d0 + 1d0/(2d0*A_f*ec_f)) + + ec_a = b1_a*sqrt(rs) + b2_a*rs + b3_a*rs**(3d0/2d0) + b4_a*rs**2 + ec_a = +2d0*A_a*(1d0 + a1_a*rs)*log(1d0 + 1d0/(2d0*A_a*ec_a)) + + ec_z = ec_p + ec_a*fz/d2fz*(1d0-z**4) + (ec_f - ec_p)*fz*z**4 + + dzdra = (1d0 - z)/r + dfzdz = (4d0/3d0)*((1d0 + z)**(1d0/3d0) - (1d0 - z)**(1d0/3d0))/(2d0*(2d0**(1d0/3d0) - 1d0)) + dfzdra = dzdra*dfzdz + drsdra = - (36d0*pi)**(-1d0/3d0)*r**(-4d0/3d0) + + t = b1_p*sqrt(rs) + b2_p*rs + b3_p*rs**(3d0/2d0) + b4_p*rs**2 + dt = 0.5d0*b1_p*sqrt(rs) + b2_p*rs + 1.5d0*b3_p*rs**(3d0/2d0) + 2d0*b4_p*rs**2 + decdrs_p = (1d0 + a1_p*rs)/rs*dt/(t**2*(1d0 + 1d0/(2d0*A_p*t))) & + - 2d0*A_p*a1_p*log(1d0 + 1d0/(2d0*A_p*t)) + + t = b1_f*sqrt(rs) + b2_f*rs + b3_f*rs**(3d0/2d0) + b4_f*rs**2 + dt = 0.5d0*b1_f*sqrt(rs) + b2_f*rs + 1.5d0*b3_f*rs**(3d0/2d0) + 2d0*b4_f*rs**2 + decdrs_f = (1d0 + a1_f*rs)/rs*dt/(t**2*(1d0 + 1d0/(2d0*A_f*t))) & + - 2d0*A_f*a1_f*log(1d0 + 1d0/(2d0*A_f*t)) + + t = b1_a*sqrt(rs) + b2_a*rs + b3_a*rs**(3d0/2d0) + b4_a*rs**2 + dt = 0.5d0*b1_a*sqrt(rs) + b2_a*rs + 1.5d0*b3_a*rs**(3d0/2d0) + 2d0*b4_a*rs**2 + decdrs_a = (1d0 + a1_a*rs)/rs*dt/(t**2*(1d0 + 1d0/(2d0*A_a*t))) & + - 2d0*A_a*a1_a*log(1d0 + 1d0/(2d0*A_a*t)) + + decdra_p = drsdra*decdrs_p + decdra_f = drsdra*decdrs_f + decdra_a = drsdra*decdrs_a + + decdra = decdra_p + decdra_a*fz/d2fz*(1d0-z**4) + ec_a*dfzdra/d2fz*(1d0-z**4) - 4d0*ec_a*fz/d2fz*dzdra*z**3 & + + (decdra_f - decdra_p)*fz*z**4 + (ec_f - ec_p)*dfzdra*z**4 + 4d0*(ec_f - ec_p)*fz*dzdra*z**3 + + Fc(mu,nu,1) = Fc(mu,nu,1) + weight(iG)*AO(mu,iG)*AO(nu,iG)*(ec_z + decdra*r) + + end if + +! spin-down contribution + + if(rb > threshold) then + + r = ra + rb + rs = (4d0*pi*r/3d0)**(-1d0/3d0) + z = (ra - rb)/r + + fz = (1d0 + z)**(4d0/3d0) + (1d0 - z)**(4d0/3d0) - 2d0 + fz = fz/(2d0*(2d0**(1d0/3d0) - 1d0)) + + d2fz = 4d0/(9d0*(2**(1d0/3d0) - 1d0)) + + ec_p = b1_p*sqrt(rs) + b2_p*rs + b3_p*rs**(3d0/2d0) + b4_p*rs**2 + ec_p = -2d0*A_p*(1d0 + a1_p*rs)*log(1d0 + 1d0/(2d0*A_p*ec_p)) + + ec_f = b1_f*sqrt(rs) + b2_f*rs + b3_f*rs**(3d0/2d0) + b4_f*rs**2 + ec_f = -2d0*A_f*(1d0 + a1_f*rs)*log(1d0 + 1d0/(2d0*A_f*ec_f)) + + ec_a = b1_a*sqrt(rs) + b2_a*rs + b3_a*rs**(3d0/2d0) + b4_a*rs**2 + ec_a = +2d0*A_a*(1d0 + a1_a*rs)*log(1d0 + 1d0/(2d0*A_a*ec_a)) + + ec_z = ec_p + ec_a*fz/d2fz*(1d0-z**4) + (ec_f - ec_p)*fz*z**4 + + dzdrb = - (1d0 + z)/r + dfzdz = (4d0/3d0)*((1d0 + z)**(1d0/3d0) - (1d0 - z)**(1d0/3d0))/(2d0*(2d0**(1d0/3d0) - 1d0)) + dfzdrb = dzdrb*dfzdz + + drsdrb = - (36d0*pi)**(-1d0/3d0)*r**(-4d0/3d0) + + + t = b1_p*sqrt(rs) + b2_p*rs + b3_p*rs**(3d0/2d0) + b4_p*rs**2 + dt = 0.5d0*b1_p*sqrt(rs) + b2_p*rs + 1.5d0*b3_p*rs**(3d0/2d0) + 2d0*b4_p*rs**2 + decdrs_p = (1d0 + a1_p*rs)/rs*dt/(t**2*(1d0 + 1d0/(2d0*A_p*t))) & + - 2d0*A_p*a1_p*log(1d0 + 1d0/(2d0*A_p*t)) + + t = b1_f*sqrt(rs) + b2_f*rs + b3_f*rs**(3d0/2d0) + b4_f*rs**2 + dt = 0.5d0*b1_f*sqrt(rs) + b2_f*rs + 1.5d0*b3_f*rs**(3d0/2d0) + 2d0*b4_f*rs**2 + decdrs_f = (1d0 + a1_f*rs)/rs*dt/(t**2*(1d0 + 1d0/(2d0*A_f*t))) & + - 2d0*A_f*a1_f*log(1d0 + 1d0/(2d0*A_f*t)) + + t = b1_a*sqrt(rs) + b2_a*rs + b3_a*rs**(3d0/2d0) + b4_a*rs**2 + dt = 0.5d0*b1_a*sqrt(rs) + b2_a*rs + 1.5d0*b3_a*rs**(3d0/2d0) + 2d0*b4_a*rs**2 + decdrs_a = (1d0 + a1_a*rs)/rs*dt/(t**2*(1d0 + 1d0/(2d0*A_a*t))) & + - 2d0*A_a*a1_a*log(1d0 + 1d0/(2d0*A_a*t)) + + decdrb_p = drsdrb*decdrs_p + decdrb_f = drsdrb*decdrs_f + decdrb_a = drsdrb*decdrs_a + + decdrb = decdrb_p + decdrb_a*fz/d2fz*(1d0-z**4) + ec_a*dfzdrb/d2fz*(1d0-z**4) - 4d0*ec_a*fz/d2fz*dzdrb*z**3 & + + (decdrb_f - decdrb_p)*fz*z**4 + (ec_f - ec_p)*dfzdrb*z**4 + 4d0*(ec_f - ec_p)*fz*dzdrb*z**3 + + Fc(mu,nu,2) = Fc(mu,nu,2) + weight(iG)*AO(mu,iG)*AO(nu,iG)*(ec_z + decdrb*r) + + end if + + end do + end do + end do + +end subroutine UPW92_lda_correlation_potential diff --git a/src/eDFT/US51_lda_exchange_energy.f90 b/src/eDFT/US51_lda_exchange_energy.f90 index b21d673..5fe5d28 100644 --- a/src/eDFT/US51_lda_exchange_energy.f90 +++ b/src/eDFT/US51_lda_exchange_energy.f90 @@ -1,7 +1,5 @@ subroutine US51_lda_exchange_energy(nGrid,weight,rho,Ex) - use xc_f90_lib_m - ! Compute Slater's LDA exchange energy implicit none @@ -16,27 +14,12 @@ subroutine US51_lda_exchange_energy(nGrid,weight,rho,Ex) ! Local variables integer :: iG - double precision :: alpha,r,alphaw,a2,b2,c2,a1,b1,c1 + double precision :: r ! Output variables double precision :: Ex -! Cxw2 parameters for He N->N+1 -! a2 = 0.135068d0 -! b2 = -0.00774769d0 -! c2 = -0.0278205d0 - -! Cxw1 parameters for He N->N-1 -! a1 = 0.420243d0 -! b1 = 0.0700561d0 -! c1 = -0.288301d0 - -! Cx coefficient for Slater LDA exchange - - alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) - -! alphaw = alpha*(1d0 - wEns(2)*(1d0 - wEns(2))*(a1 + b1*(wEns(2) - 0.5d0) + c1*(wEns(2) - 0.5d0)**2)) ! Compute LDA exchange energy Ex = 0d0 @@ -46,7 +29,7 @@ subroutine US51_lda_exchange_energy(nGrid,weight,rho,Ex) if(r > threshold) then - Ex = Ex + weight(iG)*alpha*r**(4d0/3d0) + Ex = Ex + weight(iG)*CxLSDA*r**(4d0/3d0) endif diff --git a/src/eDFT/US51_lda_exchange_individual_energy.f90 b/src/eDFT/US51_lda_exchange_individual_energy.f90 index 36a8acf..f1541a5 100644 --- a/src/eDFT/US51_lda_exchange_individual_energy.f90 +++ b/src/eDFT/US51_lda_exchange_individual_energy.f90 @@ -17,7 +17,7 @@ subroutine US51_lda_exchange_individual_energy(nGrid,weight,rhow,rho,doNcentered ! Local variables integer :: iG - double precision :: r,rI,alpha + double precision :: r,rI double precision :: e,dedr double precision :: Exrr,ExrI,ExrrI @@ -27,8 +27,6 @@ subroutine US51_lda_exchange_individual_energy(nGrid,weight,rhow,rho,doNcentered ! Compute LDA exchange matrix in the AO basis - alpha = - (3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) - Exrr = 0d0 ExrI = 0d0 ExrrI = 0d0 @@ -40,8 +38,8 @@ subroutine US51_lda_exchange_individual_energy(nGrid,weight,rhow,rho,doNcentered if(r > threshold) then - e = alpha*r**(1d0/3d0) - dedr = 1d0/3d0*alpha*r**(-2d0/3d0) + e = CxLSDA*r**(1d0/3d0) + dedr = 1d0/3d0*CxLSDA*r**(-2d0/3d0) Exrr = Exrr - weight(iG)*dedr*r*r diff --git a/src/eDFT/US51_lda_exchange_potential.f90 b/src/eDFT/US51_lda_exchange_potential.f90 index 4066379..9c2bc0d 100644 --- a/src/eDFT/US51_lda_exchange_potential.f90 +++ b/src/eDFT/US51_lda_exchange_potential.f90 @@ -16,17 +16,12 @@ subroutine US51_lda_exchange_potential(nGrid,weight,nBas,AO,rho,Fx) ! Local variables integer :: mu,nu,iG - double precision :: alpha double precision :: r,vAO ! Output variables double precision,intent(out) :: Fx(nBas,nBas) -! Cx coefficient for Slater LDA exchange - - alpha = -(3d0/2d0)*(3d0/(4d0*pi))**(1d0/3d0) - ! Compute LDA exchange matrix in the AO basis Fx(:,:) = 0d0 @@ -39,7 +34,7 @@ subroutine US51_lda_exchange_potential(nGrid,weight,nBas,AO,rho,Fx) if(r > threshold) then vAO = weight(iG)*AO(mu,iG)*AO(nu,iG) - Fx(mu,nu) = Fx(mu,nu) + vAO*4d0/3d0*alpha*r**(1d0/3d0) + Fx(mu,nu) = Fx(mu,nu) + vAO*4d0/3d0*CxLSDA*r**(1d0/3d0) endif diff --git a/src/eDFT/UVWN3_lda_correlation_energy.f90 b/src/eDFT/UVWN3_lda_correlation_energy.f90 new file mode 100644 index 0000000..ff9d18e --- /dev/null +++ b/src/eDFT/UVWN3_lda_correlation_energy.f90 @@ -0,0 +1,137 @@ +subroutine UVWN3_lda_correlation_energy(nGrid,weight,rho,Ec) + +! Compute unrestricted VWN3 LDA correlation energy + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rho(nGrid,nspin) + +! Local variables + + integer :: iG + double precision :: ra,rb,r,rs,x,z + double precision :: a_p,x0_p,xx0_p,b_p,c_p,x_p,q_p + double precision :: a_f,x0_f,xx0_f,b_f,c_f,x_f,q_f + double precision :: a_a,x0_a,xx0_a,b_a,c_a,x_a,q_a + + double precision :: ec_z,ec_p,ec_f,ec_a + double precision :: fz,d2fz + +! Output variables + + double precision :: Ec(nsp) + +! Parameters of the functional + + a_p = +0.0621814d0/2d0 + x0_p = -0.409286d0 + b_p = +13.0720d0 + c_p = +42.7198d0 + + a_f = +0.0621814d0/4d0 + x0_f = -0.743294d0 + b_f = +20.1231d0 + c_f = +101.578d0 + + a_a = -1d0/(6d0*pi**2) + x0_a = -0.0047584D0 + b_a = 1.13107d0 + c_a = 13.0045d0 + +! Initialization + + Ec(:) = 0d0 + + do iG=1,nGrid + + ra = max(0d0,rho(iG,1)) + rb = max(0d0,rho(iG,2)) + r = ra + rb + z = (ra - rb)/r + +! alpha-alpha contribution + + if(ra > threshold) then + + rs = (4d0*pi*ra/3d0)**(-1d0/3d0) + x = sqrt(rs) + + x_f = x*x + b_f*x + c_f + xx0_f = x0_f*x0_f + b_f*x0_f + c_f + q_f = sqrt(4d0*c_f - b_f*b_f) + + ec_f = a_f*( log(x**2/x_f) + 2d0*b_f/q_f*atan(q_f/(2d0*x + b_f)) & + - b_f*x0_f/xx0_f*( log((x - x0_f)**2/x_f) + 2d0*(b_f + 2d0*x0_f)/q_f*atan(q_f/(2d0*x + b_f)) ) ) + + Ec(1) = Ec(1) + weight(iG)*ec_f*ra + + end if + +! alpha-beta contribution + + if(r > threshold) then + + rs = (4d0*pi*r/3d0)**(-1d0/3d0) + x = sqrt(rs) + + fz = (1d0 + z)**(4d0/3d0) + (1d0 - z)**(4d0/3d0) - 2d0 + fz = fz/(2d0*(2d0**(1d0/3d0) - 1d0)) + + d2fz = 4d0/(9d0*(2**(1d0/3d0) - 1d0)) + + x_p = x*x + b_p*x + c_p + x_f = x*x + b_f*x + c_f + x_a = x*x + b_a*x + c_a + + xx0_p = x0_p*x0_p + b_p*x0_p + c_p + xx0_f = x0_f*x0_f + b_f*x0_f + c_f + xx0_a = x0_a*x0_a + b_a*x0_a + c_a + + q_p = sqrt(4d0*c_p - b_p*b_p) + q_f = sqrt(4d0*c_f - b_f*b_f) + q_a = sqrt(4d0*c_a - b_a*b_a) + + ec_p = a_p*( log(x**2/x_p) + 2d0*b_p/q_p*atan(q_p/(2d0*x + b_p)) & + - b_p*x0_p/xx0_p*( log((x - x0_p)**2/x_p) + 2d0*(b_p + 2d0*x0_p)/q_p*atan(q_p/(2d0*x + b_p)) ) ) + + ec_f = a_f*( log(x**2/x_f) + 2d0*b_f/q_f*atan(q_f/(2d0*x + b_f)) & + - b_f*x0_f/xx0_f*( log((x - x0_f)**2/x_f) + 2d0*(b_f + 2d0*x0_f)/q_f*atan(q_f/(2d0*x + b_f)) ) ) + + ec_a = a_a*( log(x**2/x_a) + 2d0*b_a/q_a*atan(q_a/(2d0*x + b_a)) & + - b_a*x0_a/xx0_a*( log((x - x0_a)**2/x_a) + 2d0*(b_a + 2d0*x0_a)/q_a*atan(q_a/(2d0*x + b_a)) ) ) + + ec_z = ec_p + ec_a*fz/d2fz*(1d0-z**4) + (ec_f - ec_p)*fz*z**4 + + Ec(2) = Ec(2) + weight(iG)*ec_z*r + + end if + +! beta-beta contribution + + if(rb > threshold) then + + rs = (4d0*pi*rb/3d0)**(-1d0/3d0) + x = sqrt(rs) + + x_f = x*x + b_f*x + c_f + xx0_f = x0_f*x0_f + b_f*x0_f + c_f + q_f = sqrt(4d0*c_f - b_f*b_f) + + ec_f = a_f*( log(x**2/x_f) + 2d0*b_f/q_f*atan(q_f/(2d0*x + b_f)) & + - b_f*x0_f/xx0_f*( log((x - x0_f)**2/x_f) + 2d0*(b_f + 2d0*x0_f)/q_f*atan(q_f/(2d0*x + b_f)) ) ) + + Ec(3) = Ec(3) + weight(iG)*ec_f*rb + + end if + + end do + + Ec(2) = Ec(2) - Ec(1) - Ec(3) + +end subroutine UVWN3_lda_correlation_energy diff --git a/src/eDFT/UVWN3_lda_correlation_individual_energy.f90 b/src/eDFT/UVWN3_lda_correlation_individual_energy.f90 new file mode 100644 index 0000000..2448381 --- /dev/null +++ b/src/eDFT/UVWN3_lda_correlation_individual_energy.f90 @@ -0,0 +1,202 @@ +subroutine UVWN3_lda_correlation_individual_energy(nGrid,weight,rhow,rho,Ec) + +! Compute VWN3 LDA correlation potential + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rhow(nGrid,nspin) + double precision,intent(in) :: rho(nGrid,nspin) + +! Local variables + + integer :: iG + double precision :: ra,rb,r,raI,rbI,rI,rs,x,z + double precision :: a_p,x0_p,xx0_p,b_p,c_p,x_p,q_p + double precision :: a_f,x0_f,xx0_f,b_f,c_f,x_f,q_f + double precision :: a_a,x0_a,xx0_a,b_a,c_a,x_a,q_a + double precision :: dfzdz,dxdrs,dxdx_p,dxdx_f,dxdx_a,decdx_p,decdx_f,decdx_a + double precision :: dzdra,dfzdra,drsdra,decdra_p,decdra_f,decdra_a,decdra + double precision :: dzdrb,dfzdrb,drsdrb,decdrb_p,decdrb_f,decdrb_a,decdrb + double precision :: ec_z,ec_p,ec_f,ec_a + double precision :: fz,d2fz + +! Output variables + + double precision :: Ec(nsp) + +! Parameters of the functional + + a_p = +0.0621814d0/2d0 + x0_p = -0.409286d0 + b_p = +13.0720d0 + c_p = +42.7198d0 + + a_f = +0.0621814d0/4d0 + x0_f = -0.743294d0 + b_f = +20.1231d0 + c_f = +101.578d0 + + a_a = -1d0/(6d0*pi**2) + x0_a = -0.0047584D0 + b_a = +1.13107d0 + c_a = +13.0045d0 + +! Initialization + + Ec(:) = 0d0 + + do iG=1,nGrid + + ra = max(0d0,rhow(iG,1)) + rb = max(0d0,rhow(iG,2)) + + raI = max(0d0,rho(iG,1)) + rbI = max(0d0,rho(iG,2)) + +! spin-up contribution + + if(ra > threshold .or. raI > threshold) then + + r = ra + rI = raI + + rs = (4d0*pi*r/3d0)**(-1d0/3d0) + x = sqrt(rs) + + x_f = x*x + b_f*x + c_f + + xx0_f = x0_f*x0_f + b_f*x0_f + c_f + + q_f = sqrt(4d0*c_f - b_f*b_f) + + ec_f = a_f*( log(x**2/x_f) + 2d0*b_f/q_f*atan(q_f/(2d0*x + b_f)) & + - b_f*x0_f/xx0_f*( log((x - x0_f)**2/x_f) + 2d0*(b_f + 2d0*x0_f)/q_f*atan(q_f/(2d0*x + b_f)) ) ) + + drsdra = - (36d0*pi)**(-1d0/3d0)*r**(-4d0/3d0) + dxdrs = 0.5d0/sqrt(rs) + + dxdx_f = 2d0*x + b_f + + decdx_f = a_f*( 2d0/x - 4d0*b_f/( (b_f+2d0*x)**2 + q_f**2) - dxdx_f/x_f & + - b_f*x0_f/xx0_f*( 2/(x-x0_f) - 4d0*(b_f+2d0*x0_f)/( (b_f+2d0*x)**2 + q_f**2) - dxdx_f/x_f ) ) + + decdra_f = drsdra*dxdrs*decdx_f + + Ec(1) = Ec(1) + weight(iG)*(ec_f + decdra_f*r)*rI + + end if + +! up-down contribution + + if(ra > threshold .or. raI > threshold) then + + r = ra + rb + rI = raI + rbI + + rs = (4d0*pi*r/3d0)**(-1d0/3d0) + z = (ra - rb)/r + x = sqrt(rs) + + fz = (1d0 + z)**(4d0/3d0) + (1d0 - z)**(4d0/3d0) - 2d0 + fz = fz/(2d0*(2d0**(1d0/3d0) - 1d0)) + + d2fz = 4d0/(9d0*(2**(1d0/3d0) - 1d0)) + + x_p = x*x + b_p*x + c_p + x_f = x*x + b_f*x + c_f + x_a = x*x + b_a*x + c_a + + xx0_p = x0_p*x0_p + b_p*x0_p + c_p + xx0_f = x0_f*x0_f + b_f*x0_f + c_f + xx0_a = x0_a*x0_a + b_a*x0_a + c_a + + q_p = sqrt(4d0*c_p - b_p*b_p) + q_f = sqrt(4d0*c_f - b_f*b_f) + q_a = sqrt(4d0*c_a - b_a*b_a) + + ec_p = a_p*( log(x**2/x_p) + 2d0*b_p/q_p*atan(q_p/(2d0*x + b_p)) & + - b_p*x0_p/xx0_p*( log((x - x0_p)**2/x_p) + 2d0*(b_p + 2d0*x0_p)/q_p*atan(q_p/(2d0*x + b_p)) ) ) + + ec_f = a_f*( log(x**2/x_f) + 2d0*b_f/q_f*atan(q_f/(2d0*x + b_f)) & + - b_f*x0_f/xx0_f*( log((x - x0_f)**2/x_f) + 2d0*(b_f + 2d0*x0_f)/q_f*atan(q_f/(2d0*x + b_f)) ) ) + + ec_a = a_a*( log(x**2/x_a) + 2d0*b_a/q_a*atan(q_a/(2d0*x + b_a)) & + - b_a*x0_a/xx0_a*( log((x - x0_a)**2/x_a) + 2d0*(b_a + 2d0*x0_a)/q_a*atan(q_a/(2d0*x + b_a)) ) ) + + ec_z = ec_p + ec_a*fz/d2fz*(1d0-z**4) + (ec_f - ec_p)*fz*z**4 + + dzdra = (1d0 - z)/r + dfzdz = (4d0/3d0)*((1d0 + z)**(1d0/3d0) - (1d0 - z)**(1d0/3d0))/(2d0*(2d0**(1d0/3d0) - 1d0)) + dfzdra = dzdra*dfzdz + + drsdra = - (36d0*pi)**(-1d0/3d0)*r**(-4d0/3d0) + dxdrs = 0.5d0/sqrt(rs) + + dxdx_p = 2d0*x + b_p + dxdx_f = 2d0*x + b_f + dxdx_a = 2d0*x + b_a + + decdx_p = a_p*( 2d0/x - 4d0*b_p/( (b_p+2d0*x)**2 + q_p**2) - dxdx_p/x_p & + - b_p*x0_p/xx0_p*( 2/(x-x0_p) - 4d0*(b_p+2d0*x0_p)/( (b_p+2d0*x)**2 + q_p**2) - dxdx_p/x_p ) ) + + decdx_f = a_f*( 2d0/x - 4d0*b_f/( (b_f+2d0*x)**2 + q_f**2) - dxdx_f/x_f & + - b_f*x0_f/xx0_f*( 2/(x-x0_f) - 4d0*(b_f+2d0*x0_f)/( (b_f+2d0*x)**2 + q_f**2) - dxdx_f/x_f ) ) + + decdx_a = a_a*( 2d0/x - 4d0*b_a/( (b_a+2d0*x)**2 + q_a**2) - dxdx_a/x_a & + - b_a*x0_a/xx0_a*( 2/(x-x0_a) - 4d0*(b_a+2d0*x0_a)/( (b_a+2d0*x)**2 + q_a**2) - dxdx_a/x_a ) ) + + decdra_p = drsdra*dxdrs*decdx_p + decdra_f = drsdra*dxdrs*decdx_f + decdra_a = drsdra*dxdrs*decdx_a + + decdra = decdra_p + decdra_a*fz/d2fz*(1d0-z**4) + ec_a*dfzdra/d2fz*(1d0-z**4) - 4d0*ec_a*fz/d2fz*dzdra*z**3 & + + (decdra_f - decdra_p)*fz*z**4 + (ec_f - ec_p)*dfzdra*z**4 + 4d0*(ec_f - ec_p)*fz*dzdra*z**3 + + Ec(2) = Ec(2) + weight(iG)*(ec_z + decdra*r)*rI + + end if + +! spin-down contribution + + if(rb > threshold .or. rbI > threshold) then + + r = rb + rI = rbI + + rs = (4d0*pi*r/3d0)**(-1d0/3d0) + x = sqrt(rs) + + x_f = x*x + b_f*x + c_f + + xx0_f = x0_f*x0_f + b_f*x0_f + c_f + + q_f = sqrt(4d0*c_f - b_f*b_f) + + ec_f = a_f*( log(x**2/x_f) + 2d0*b_f/q_f*atan(q_f/(2d0*x + b_f)) & + - b_f*x0_f/xx0_f*( log((x - x0_f)**2/x_f) + 2d0*(b_f + 2d0*x0_f)/q_f*atan(q_f/(2d0*x + b_f)) ) ) + + drsdra = - (36d0*pi)**(-1d0/3d0)*r**(-4d0/3d0) + dxdrs = 0.5d0/sqrt(rs) + + dxdx_f = 2d0*x + b_f + + decdx_f = a_f*( 2d0/x - 4d0*b_f/( (b_f+2d0*x)**2 + q_f**2) - dxdx_f/x_f & + - b_f*x0_f/xx0_f*( 2/(x-x0_f) - 4d0*(b_f+2d0*x0_f)/( (b_f+2d0*x)**2 + q_f**2) - dxdx_f/x_f ) ) + + decdra_f = drsdra*dxdrs*decdx_f + + Ec(3) = Ec(3) + weight(iG)*(ec_f + decdra_f*r)*rI + + end if + + end do + + Ec(2) = Ec(2) - Ec(1) - Ec(3) + +end subroutine UVWN3_lda_correlation_individual_energy diff --git a/src/eDFT/UVWN3_lda_correlation_potential.f90 b/src/eDFT/UVWN3_lda_correlation_potential.f90 new file mode 100644 index 0000000..ce1c93a --- /dev/null +++ b/src/eDFT/UVWN3_lda_correlation_potential.f90 @@ -0,0 +1,196 @@ +subroutine UVWN3_lda_correlation_potential(nGrid,weight,nBas,AO,rho,Fc) + +! Compute unrestricted VWN3 LDA correlation potential + + implicit none + + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + integer,intent(in) :: nBas + double precision,intent(in) :: AO(nBas,nGrid) + double precision,intent(in) :: rho(nGrid,nspin) + +! Local variables + + integer :: mu,nu,iG + double precision :: ra,rb,r,rs,x,z + double precision :: a_p,x0_p,xx0_p,b_p,c_p,x_p,q_p + double precision :: a_f,x0_f,xx0_f,b_f,c_f,x_f,q_f + double precision :: a_a,x0_a,xx0_a,b_a,c_a,x_a,q_a + double precision :: dfzdz,dxdrs,dxdx_p,dxdx_f,dxdx_a,decdx_p,decdx_f,decdx_a + double precision :: dzdra,dfzdra,drsdra,decdra_p,decdra_f,decdra_a,decdra + double precision :: dzdrb,dfzdrb,drsdrb,decdrb_p,decdrb_f,decdrb_a,decdrb + + double precision :: ec_z,ec_p,ec_f,ec_a + double precision :: fz,d2fz + +! Output variables + + double precision :: Fc(nBas,nBas,nspin) + +! Parameters of the functional + + a_p = +0.0621814d0/2d0 + x0_p = -0.409286d0 + b_p = +13.0720d0 + c_p = +42.7198d0 + + a_f = +0.0621814d0/4d0 + x0_f = -0.743294d0 + b_f = +20.1231d0 + c_f = +101.578d0 + + a_a = -1d0/(6d0*pi**2) + x0_a = -0.0047584D0 + b_a = +1.13107d0 + c_a = +13.0045d0 + +! Initialization + + Fc(:,:,:) = 0d0 + + do mu=1,nBas + do nu=1,nBas + do iG=1,nGrid + + ra = max(0d0,rho(iG,1)) + rb = max(0d0,rho(iG,2)) + r = ra + rb + z = (ra - rb)/r + + fz = (1d0 + z)**(4d0/3d0) + (1d0 - z)**(4d0/3d0) - 2d0 + fz = fz/(2d0*(2d0**(1d0/3d0) - 1d0)) + + d2fz = 4d0/(9d0*(2**(1d0/3d0) - 1d0)) + + +! spin-up contribution + + if(ra > threshold) then + + rs = (4d0*pi*r/3d0)**(-1d0/3d0) + x = sqrt(rs) + + x_p = x*x + b_p*x + c_p + x_f = x*x + b_f*x + c_f + x_a = x*x + b_a*x + c_a + + xx0_p = x0_p*x0_p + b_p*x0_p + c_p + xx0_f = x0_f*x0_f + b_f*x0_f + c_f + xx0_a = x0_a*x0_a + b_a*x0_a + c_a + + q_p = sqrt(4d0*c_p - b_p*b_p) + q_f = sqrt(4d0*c_f - b_f*b_f) + q_a = sqrt(4d0*c_a - b_a*b_a) + + ec_p = a_p*( log(x**2/x_p) + 2d0*b_p/q_p*atan(q_p/(2d0*x + b_p)) & + - b_p*x0_p/xx0_p*( log((x - x0_p)**2/x_p) + 2d0*(b_p + 2d0*x0_p)/q_p*atan(q_p/(2d0*x + b_p)) ) ) + + ec_f = a_f*( log(x**2/x_f) + 2d0*b_f/q_f*atan(q_f/(2d0*x + b_f)) & + - b_f*x0_f/xx0_f*( log((x - x0_f)**2/x_f) + 2d0*(b_f + 2d0*x0_f)/q_f*atan(q_f/(2d0*x + b_f)) ) ) + + ec_a = a_a*( log(x**2/x_a) + 2d0*b_a/q_a*atan(q_a/(2d0*x + b_a)) & + - b_a*x0_a/xx0_a*( log((x - x0_a)**2/x_a) + 2d0*(b_a + 2d0*x0_a)/q_a*atan(q_a/(2d0*x + b_a)) ) ) + + ec_z = ec_p + ec_a*fz/d2fz*(1d0-z**4) + (ec_f - ec_p)*fz*z**4 + + dzdra = (1d0 - z)/r + dfzdz = (4d0/3d0)*((1d0 + z)**(1d0/3d0) - (1d0 - z)**(1d0/3d0))/(2d0*(2d0**(1d0/3d0) - 1d0)) + dfzdra = dzdra*dfzdz + + drsdra = - (36d0*pi)**(-1d0/3d0)*r**(-4d0/3d0) + dxdrs = 0.5d0/sqrt(rs) + + dxdx_p = 2d0*x + b_p + dxdx_f = 2d0*x + b_f + dxdx_a = 2d0*x + b_a + + decdx_p = a_p*( 2d0/x - 4d0*b_p/( (b_p+2d0*x)**2 + q_p**2) - dxdx_p/x_p & + - b_p*x0_p/xx0_p*( 2/(x-x0_p) - 4d0*(b_p+2d0*x0_p)/( (b_p+2d0*x)**2 + q_p**2) - dxdx_p/x_p ) ) + + decdx_f = a_f*( 2d0/x - 4d0*b_f/( (b_f+2d0*x)**2 + q_f**2) - dxdx_f/x_f & + - b_f*x0_f/xx0_f*( 2/(x-x0_f) - 4d0*(b_f+2d0*x0_f)/( (b_f+2d0*x)**2 + q_f**2) - dxdx_f/x_f ) ) + + decdx_a = a_a*( 2d0/x - 4d0*b_a/( (b_a+2d0*x)**2 + q_a**2) - dxdx_a/x_a & + - b_a*x0_a/xx0_a*( 2/(x-x0_a) - 4d0*(b_a+2d0*x0_a)/( (b_a+2d0*x)**2 + q_a**2) - dxdx_a/x_a ) ) + + decdra_p = drsdra*dxdrs*decdx_p + decdra_f = drsdra*dxdrs*decdx_f + decdra_a = drsdra*dxdrs*decdx_a + + decdra = decdra_p + decdra_a*fz/d2fz*(1d0-z**4) + ec_a*dfzdra/d2fz*(1d0-z**4) - 4d0*ec_a*fz/d2fz*dzdra*z**3 & + + (decdra_f - decdra_p)*fz*z**4 + (ec_f - ec_p)*dfzdra*z**4 + 4d0*(ec_f - ec_p)*fz*dzdra*z**3 + + Fc(mu,nu,1) = Fc(mu,nu,1) + weight(iG)*AO(mu,iG)*AO(nu,iG)*(ec_z + decdra*r) + + end if + +! spin-down contribution + + if(rb > threshold) then + + rs = (4d0*pi*r/3d0)**(-1d0/3d0) + x = sqrt(rs) + + x_p = x*x + b_p*x + c_p + x_f = x*x + b_f*x + c_f + x_a = x*x + b_a*x + c_a + + xx0_p = x0_p*x0_p + b_p*x0_p + c_p + xx0_f = x0_f*x0_f + b_f*x0_f + c_f + xx0_a = x0_a*x0_a + b_a*x0_a + c_a + + q_p = sqrt(4d0*c_p - b_p*b_p) + q_f = sqrt(4d0*c_f - b_f*b_f) + q_a = sqrt(4d0*c_a - b_a*b_a) + + ec_p = a_p*( log(x**2/x_p) + 2d0*b_p/q_p*atan(q_p/(2d0*x + b_p)) & + - b_p*x0_p/xx0_p*( log((x - x0_p)**2/x_p) + 2d0*(b_p + 2d0*x0_p)/q_p*atan(q_p/(2d0*x + b_p)) ) ) + + ec_f = a_f*( log(x**2/x_f) + 2d0*b_f/q_f*atan(q_f/(2d0*x + b_f)) & + - b_f*x0_f/xx0_f*( log((x - x0_f)**2/x_f) + 2d0*(b_f + 2d0*x0_f)/q_f*atan(q_f/(2d0*x + b_f)) ) ) + + ec_a = a_a*( log(x**2/x_a) + 2d0*b_a/q_a*atan(q_a/(2d0*x + b_a)) & + - b_a*x0_a/xx0_a*( log((x - x0_a)**2/x_a) + 2d0*(b_a + 2d0*x0_a)/q_a*atan(q_a/(2d0*x + b_a)) ) ) + + ec_z = ec_p + ec_a*fz/d2fz*(1d0-z**4) + (ec_f - ec_p)*fz*z**4 + + dzdrb = - (1d0 + z)/r + dfzdz = (4d0/3d0)*((1d0 + z)**(1d0/3d0) - (1d0 - z)**(1d0/3d0))/(2d0*(2d0**(1d0/3d0) - 1d0)) + dfzdrb = dzdrb*dfzdz + + drsdrb = - (36d0*pi)**(-1d0/3d0)*r**(-4d0/3d0) + dxdrs = 0.5d0/sqrt(rs) + + dxdx_p = 2d0*x + b_p + dxdx_f = 2d0*x + b_f + dxdx_a = 2d0*x + b_a + + decdx_p = a_p*( 2d0/x - 4d0*b_p/( (b_p+2d0*x)**2 + q_p**2) - dxdx_p/x_p & + - b_p*x0_p/xx0_p*( 2/(x-x0_p) - 4d0*(b_p+2d0*x0_p)/( (b_p+2d0*x)**2 + q_p**2) - dxdx_p/x_p ) ) + + decdx_f = a_f*( 2d0/x - 4d0*b_f/( (b_f+2d0*x)**2 + q_f**2) - dxdx_f/x_f & + - b_f*x0_f/xx0_f*( 2/(x-x0_f) - 4d0*(b_f+2d0*x0_f)/( (b_f+2d0*x)**2 + q_f**2) - dxdx_f/x_f ) ) + + decdx_a = a_a*( 2d0/x - 4d0*b_a/( (b_a+2d0*x)**2 + q_a**2) - dxdx_a/x_a & + - b_a*x0_a/xx0_a*( 2/(x-x0_a) - 4d0*(b_a+2d0*x0_a)/( (b_a+2d0*x)**2 + q_a**2) - dxdx_a/x_a ) ) + + decdrb_p = drsdrb*dxdrs*decdx_p + decdrb_f = drsdrb*dxdrs*decdx_f + decdrb_a = drsdrb*dxdrs*decdx_a + + decdrb = decdrb_p + decdrb_a*fz/d2fz*(1d0-z**4) + ec_a*dfzdrb/d2fz*(1d0-z**4) - 4d0*ec_a*fz/d2fz*dzdrb*z**3 & + + (decdrb_f - decdrb_p)*fz*z**4 + (ec_f - ec_p)*dfzdrb*z**4 + 4d0*(ec_f - ec_p)*fz*dzdrb*z**3 + Fc(mu,nu,2) = Fc(mu,nu,2) + weight(iG)*AO(mu,iG)*AO(nu,iG)*(ec_z + decdrb*r) + + end if + + end do + end do + end do + +end subroutine UVWN3_lda_correlation_potential diff --git a/src/eDFT/UVWN5_lda_correlation_energy.f90 b/src/eDFT/UVWN5_lda_correlation_energy.f90 index 8dadbc4..6ec7eaf 100644 --- a/src/eDFT/UVWN5_lda_correlation_energy.f90 +++ b/src/eDFT/UVWN5_lda_correlation_energy.f90 @@ -52,6 +52,8 @@ subroutine UVWN5_lda_correlation_energy(nGrid,weight,rho,Ec) ra = max(0d0,rho(iG,1)) rb = max(0d0,rho(iG,2)) + r = ra + rb + z = (ra - rb)/r ! alpha-alpha contribution @@ -73,11 +75,9 @@ subroutine UVWN5_lda_correlation_energy(nGrid,weight,rho,Ec) ! alpha-beta contribution - if(ra > threshold .or. rb > threshold) then + if(r > threshold) then - r = ra + rb rs = (4d0*pi*r/3d0)**(-1d0/3d0) - z = (ra - rb)/r x = sqrt(rs) fz = (1d0 + z)**(4d0/3d0) + (1d0 - z)**(4d0/3d0) - 2d0 diff --git a/src/eDFT/UVWN5_lda_correlation_individual_energy.f90 b/src/eDFT/UVWN5_lda_correlation_individual_energy.f90 index beb8031..d856c41 100644 --- a/src/eDFT/UVWN5_lda_correlation_individual_energy.f90 +++ b/src/eDFT/UVWN5_lda_correlation_individual_energy.f90 @@ -88,7 +88,7 @@ subroutine UVWN5_lda_correlation_individual_energy(nGrid,weight,rhow,rho,Ec) decdra_f = drsdra*dxdrs*decdx_f - Ec(1) = Ec(1) + weight(iG)*(ec_z + decdra_f*r)*rI + Ec(1) = Ec(1) + weight(iG)*(ec_f + decdra_f*r)*rI end if @@ -191,7 +191,7 @@ subroutine UVWN5_lda_correlation_individual_energy(nGrid,weight,rhow,rho,Ec) decdra_f = drsdra*dxdrs*decdx_f - Ec(3) = Ec(3) + weight(iG)*(ec_z + decdra_f*r)*rI + Ec(3) = Ec(3) + weight(iG)*(ec_f + decdra_f*r)*rI end if diff --git a/src/eDFT/UVWN5_lda_correlation_potential.f90 b/src/eDFT/UVWN5_lda_correlation_potential.f90 index d36e8a1..c40ea59 100644 --- a/src/eDFT/UVWN5_lda_correlation_potential.f90 +++ b/src/eDFT/UVWN5_lda_correlation_potential.f90 @@ -59,21 +59,21 @@ subroutine UVWN5_lda_correlation_potential(nGrid,weight,nBas,AO,rho,Fc) ra = max(0d0,rho(iG,1)) rb = max(0d0,rho(iG,2)) + r = ra + rb + z = (ra - rb)/r + + rs = (4d0*pi*r/3d0)**(-1d0/3d0) + x = sqrt(rs) + + fz = (1d0 + z)**(4d0/3d0) + (1d0 - z)**(4d0/3d0) - 2d0 + fz = fz/(2d0*(2d0**(1d0/3d0) - 1d0)) + + d2fz = 4d0/(9d0*(2**(1d0/3d0) - 1d0)) ! spin-up contribution if(ra > threshold) then - r = ra + rb - rs = (4d0*pi*r/3d0)**(-1d0/3d0) - z = (ra - rb)/r - x = sqrt(rs) - - fz = (1d0 + z)**(4d0/3d0) + (1d0 - z)**(4d0/3d0) - 2d0 - fz = fz/(2d0*(2d0**(1d0/3d0) - 1d0)) - - d2fz = 4d0/(9d0*(2**(1d0/3d0) - 1d0)) - x_p = x*x + b_p*x + c_p x_f = x*x + b_f*x + c_f x_a = x*x + b_a*x + c_a @@ -132,16 +132,6 @@ subroutine UVWN5_lda_correlation_potential(nGrid,weight,nBas,AO,rho,Fc) if(rb > threshold) then - r = ra + rb - rs = (4d0*pi*r/3d0)**(-1d0/3d0) - z = (ra - rb)/r - x = sqrt(rs) - - fz = (1d0 + z)**(4d0/3d0) + (1d0 - z)**(4d0/3d0) - 2d0 - fz = fz/(2d0*(2d0**(1d0/3d0) - 1d0)) - - d2fz = 4d0/(9d0*(2**(1d0/3d0) - 1d0)) - x_p = x*x + b_p*x + c_p x_f = x*x + b_f*x + c_f x_a = x*x + b_a*x + c_a diff --git a/src/eDFT/eDFT.f90 b/src/eDFT/eDFT.f90 index 2fa4513..f4a5b40 100644 --- a/src/eDFT/eDFT.f90 +++ b/src/eDFT/eDFT.f90 @@ -1,10 +1,10 @@ -subroutine eDFT(maxSCF,thresh,max_diis,guess_type,nNuc,ZNuc,rNuc,ENuc,nBas,nEl,nC,nO,nV,nR, & +subroutine eDFT(maxSCF,thresh,max_diis,guess_type,mix,nNuc,ZNuc,rNuc,ENuc,nBas,nEl,nC,nO,nV,nR, & nShell,TotAngMomShell,CenterShell,KShell,DShell,ExpShell, & - max_ang_mom,min_exponent,max_exponent,S,T,V,Hc,X,ERI,dipole_int) + max_ang_mom,min_exponent,max_exponent,S,T,V,Hc,X,ERI,dipole_int,Ew,eKS,cKS,PKS,Vxc) ! exchange-correlation density-functional theory calculations - use xc_f90_lib_m +! use xc_f90_lib_m implicit none include 'parameters.h' @@ -14,6 +14,7 @@ subroutine eDFT(maxSCF,thresh,max_diis,guess_type,nNuc,ZNuc,rNuc,ENuc,nBas,nEl,n integer,intent(in) :: maxSCF integer,intent(in) :: max_diis integer,intent(in) :: guess_type + logical,intent(in) :: mix double precision,intent(in) :: thresh integer,intent(in) :: nNuc @@ -49,9 +50,6 @@ subroutine eDFT(maxSCF,thresh,max_diis,guess_type,nNuc,ZNuc,rNuc,ENuc,nBas,nEl,n ! Local variables - double precision :: Ew - double precision,allocatable :: c(:,:) - character(len=8) :: method integer :: x_rung,c_rung character(len=12) :: x_DFA ,c_DFA @@ -81,6 +79,16 @@ subroutine eDFT(maxSCF,thresh,max_diis,guess_type,nNuc,ZNuc,rNuc,ENuc,nBas,nEl,n integer :: Cx_choice integer :: i,vmajor,vminor,vmicro + integer :: iBas,iEns,ispin + +! Output variables + + double precision,intent(out) :: Ew + double precision,intent(out) :: eKS(nBas,nspin) + double precision,intent(out) :: cKS(nBas,nBas,nspin) + double precision,intent(out) :: PKS(nBas,nBas,nspin) + double precision,intent(out) :: Vxc(nBas,nspin) + ! Hello World @@ -92,8 +100,8 @@ subroutine eDFT(maxSCF,thresh,max_diis,guess_type,nNuc,ZNuc,rNuc,ENuc,nBas,nEl,n ! Libxc version - call xc_f90_version(vmajor, vminor, vmicro) - write(*,'("Libxc version: ",I1,".",I1,".",I1)') vmajor, vminor, vmicro +! call xc_f90_version(vmajor, vminor, vmicro) +! write(*,'("Libxc version: ",I1,".",I1,".",I1)') vmajor, vminor, vmicro ! call xcinfo() @@ -103,7 +111,7 @@ subroutine eDFT(maxSCF,thresh,max_diis,guess_type,nNuc,ZNuc,rNuc,ENuc,nBas,nEl,n ! Allocate ensemble weights and MO coefficients - allocate(c(nBas,nspin),wEns(maxEns),occnum(nBas,nspin,maxEns)) + allocate(wEns(maxEns),occnum(nBas,nspin,maxEns)) call read_options_dft(nBas,method,x_rung,x_DFA,c_rung,c_DFA,SGn,nEns,wEns,aCC_w1,aCC_w2, & doNcentered,occnum,Cx_choice) @@ -132,66 +140,94 @@ subroutine eDFT(maxSCF,thresh,max_diis,guess_type,nNuc,ZNuc,rNuc,ENuc,nBas,nEl,n ! Compute GOK-RKS energy !------------------------------------------------------------------------ - if(method == 'GOK-RKS') then +! if(method == 'GOK-RKS') then - call cpu_time(start_KS) - call GOK_RKS(.false.,x_rung,x_DFA,c_rung,c_DFA,LDA_centered,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight, & - maxSCF,thresh,max_diis,guess_type,nBas,AO,dAO,nO(1),nV(1), & - S,T,V,Hc,ERI,X,ENuc,Ew,c,occnum,Cx_choice) - call cpu_time(end_KS) +! call cpu_time(start_KS) +! call GOK_RKS(.false.,x_rung,x_DFA,c_rung,c_DFA,LDA_centered,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight, & +! maxSCF,thresh,max_diis,guess_type,nBas,AO,dAO,nO(1),nV(1), & +! S,T,V,Hc,ERI,X,ENuc,Ew,c,occnum,Cx_choice) +! call cpu_time(end_KS) - t_KS = end_KS - start_KS - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GOK-RKS = ',t_KS,' seconds' - write(*,*) +! t_KS = end_KS - start_KS +! write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for GOK-RKS = ',t_KS,' seconds' +! write(*,*) - end if +!end if !------------------------------------------------------------------------ ! Compute LIM excitation energies !------------------------------------------------------------------------ - if(method == 'LIM-RKS') then +! if(method == 'LIM-RKS') then - call cpu_time(start_KS) - call LIM_RKS(x_rung,x_DFA,c_rung,c_DFA,LDA_centered,nEns,nGrid,weight(:), & - aCC_w1,aCC_w2,maxSCF,thresh,max_diis,guess_type,nBas,AO(:,:),dAO(:,:,:),nO(1),nV(1), & - S(:,:),T(:,:),V(:,:),Hc(:,:),ERI(:,:,:,:),X(:,:),ENuc,c(:,:),occnum,Cx_choice,doNcentered) - call cpu_time(end_KS) +! call cpu_time(start_KS) +! call LIM_RKS(x_rung,x_DFA,c_rung,c_DFA,LDA_centered,nEns,nGrid,weight(:), & +! aCC_w1,aCC_w2,maxSCF,thresh,max_diis,guess_type,nBas,AO(:,:),dAO(:,:,:),nO(1),nV(1), & +! S(:,:),T(:,:),V(:,:),Hc(:,:),ERI(:,:,:,:),X(:,:),ENuc,c(:,:),occnum,Cx_choice,doNcentered) +! call cpu_time(end_KS) - t_KS = end_KS - start_KS - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for LIM-RKS = ',t_KS,' seconds' - write(*,*) +! t_KS = end_KS - start_KS +! write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for LIM-RKS = ',t_KS,' seconds' +! write(*,*) - end if +! end if !------------------------------------------------------------------------ ! Compute MOM excitation energies !------------------------------------------------------------------------ - if(method == 'MOM-RKS') then +! if(method == 'MOM-RKS') then - call cpu_time(start_KS) - call MOM_RKS(x_rung,x_DFA,c_rung,c_DFA,LDA_centered,nEns,nGrid,weight(:), & - aCC_w1,aCC_w2,maxSCF,thresh,max_diis,guess_type,nBas,AO(:,:),dAO(:,:,:),nO(1),nV(1), & - S(:,:),T(:,:),V(:,:),Hc(:,:),ERI(:,:,:,:),X(:,:),ENuc,c(:,:),occnum,Cx_choice,doNcentered) - call cpu_time(end_KS) +! call cpu_time(start_KS) +! call MOM_RKS(x_rung,x_DFA,c_rung,c_DFA,LDA_centered,nEns,nGrid,weight(:), & +! aCC_w1,aCC_w2,maxSCF,thresh,max_diis,guess_type,nBas,AO(:,:),dAO(:,:,:),nO(1),nV(1), & +! S(:,:),T(:,:),V(:,:),Hc(:,:),ERI(:,:,:,:),X(:,:),ENuc,c(:,:),occnum,Cx_choice,doNcentered) +! call cpu_time(end_KS) - t_KS = end_KS - start_KS - write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MOM-RKS = ',t_KS,' seconds' - write(*,*) +! t_KS = end_KS - start_KS +! write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for MOM-RKS = ',t_KS,' seconds' +! write(*,*) - end if +! end if !------------------------------------------------------------------------ ! Compute GOK-UKS energy (BROKEN) !------------------------------------------------------------------------ - if(method == 'GOK-UKS') then +! if(method == 'GOK-UKS') then + +! call cpu_time(start_KS) +! call GOK_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns(:),nGrid,weight(:),aCC_w1,aCC_w2,maxSCF,thresh,max_diis,guess_type, & +! nBas,AO(:,:),dAO(:,:,:),nO(:),nV(:),S(:,:),T(:,:),V(:,:),Hc(:,:),ERI(:,:,:,:),X(:,:),ENuc,Ew,occnum, & +! Cx_choice,doNcentered) +! call cpu_time(end_KS) + +! t_KS = end_KS - start_KS +! write(*,'(A65,1X,F9.3,A8)') 'Total CPU time for UKS = ',t_KS,' seconds' +! write(*,*) + +! end if + +!------------------------------------------------------------------------ +! Compute UKS energy +!------------------------------------------------------------------------ + + if(method == 'UKS') then + + ! Reset occupation numbers for conventional UKS calculation + + occnum(:,:,:) = 0d0 + do ispin=1,nspin + do iBas=1,nO(ispin) + do iEns=1,nEns + occnum(iBas,ispin,iEns) = 1d0 + end do + end do + end do call cpu_time(start_KS) - call GOK_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns(:),nGrid,weight(:),aCC_w1,aCC_w2,maxSCF,thresh,max_diis,guess_type, & - nBas,AO(:,:),dAO(:,:,:),nO(:),nV(:),S(:,:),T(:,:),V(:,:),Hc(:,:),ERI(:,:,:,:),X(:,:),ENuc,Ew,occnum, & - Cx_choice,doNcentered) + call eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,maxSCF,thresh,max_diis,guess_type,mix, & + nNuc,ZNuc,rNuc,ENuc,nBas,AO,dAO,S,T,V,Hc,ERI,dipole_int,X,occnum,Cx_choice,doNcentered,Ew,eKS,cKS,PKS,Vxc) call cpu_time(end_KS) t_KS = end_KS - start_KS @@ -201,14 +237,14 @@ subroutine eDFT(maxSCF,thresh,max_diis,guess_type,nNuc,ZNuc,rNuc,ENuc,nBas,nEl,n end if !------------------------------------------------------------------------ -! Compute N-centered UKS energy (UNBROKEN) +! Compute UKS energy for ensembles !------------------------------------------------------------------------ if(method == 'eDFT-UKS') then call cpu_time(start_KS) - call eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight(:),maxSCF,thresh,max_diis,guess_type, & - nBas,AO,dAO,S,T,V,Hc,ERI,X,ENuc,Ew,occnum,Cx_choice,doNcentered) + call eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,maxSCF,thresh,max_diis,guess_type,mix, & + nNuc,ZNuc,rNuc,ENuc,nBas,AO,dAO,S,T,V,Hc,ERI,dipole_int,X,occnum,Cx_choice,doNcentered,Ew,eKS,cKS,PKS,Vxc) call cpu_time(end_KS) t_KS = end_KS - start_KS diff --git a/src/eDFT/eDFT_UKS.f90 b/src/eDFT/eDFT_UKS.f90 index 62588d4..2653787 100644 --- a/src/eDFT/eDFT_UKS.f90 +++ b/src/eDFT/eDFT_UKS.f90 @@ -1,5 +1,5 @@ -subroutine eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,maxSCF,thresh,max_diis,guess_type, & - nBas,AO,dAO,S,T,V,Hc,ERI,X,ENuc,Ew,occnum,Cx_choice,doNcentered) +subroutine eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,maxSCF,thresh,max_diis,guess_type,mix, & + nNuc,ZNuc,rNuc,ENuc,nBas,AO,dAO,S,T,V,Hc,ERI,dipole_int,X,occnum,Cx_choice,doNcentered,Ew,eps,c,Pw,Vxc) ! Perform unrestricted Kohn-Sham calculation for ensembles @@ -17,18 +17,24 @@ subroutine eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weig integer,intent(in) :: nGrid double precision,intent(in) :: weight(nGrid) integer,intent(in) :: maxSCF,max_diis,guess_type + logical,intent(in) :: mix double precision,intent(in) :: thresh integer,intent(in) :: nBas double precision,intent(in) :: AO(nBas,nGrid) double precision,intent(in) :: dAO(ncart,nBas,nGrid) + integer,intent(in) :: nNuc + double precision,intent(in) :: ZNuc(nNuc) + double precision,intent(in) :: rNuc(nNuc,ncart) + double precision,intent(in) :: ENuc + double precision,intent(in) :: S(nBas,nBas) double precision,intent(in) :: T(nBas,nBas) double precision,intent(in) :: V(nBas,nBas) double precision,intent(in) :: Hc(nBas,nBas) double precision,intent(in) :: X(nBas,nBas) double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) - double precision,intent(in) :: ENuc + double precision,intent(in) :: dipole_int(nBas,nBas,ncart) double precision,intent(in) :: occnum(nBas,nspin,nEns) integer,intent(in) :: Cx_choice logical,intent(in) :: doNcentered @@ -39,6 +45,7 @@ subroutine eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weig logical :: LDA_centered = .false. integer :: nSCF,nBasSq integer :: n_diis + integer :: nO(nspin) double precision :: conv double precision :: rcond(nspin) double precision :: ET(nspin) @@ -46,10 +53,8 @@ subroutine eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weig double precision :: EJ(nsp) double precision :: Ex(nspin) double precision :: Ec(nsp) - double precision :: Ew + double precision :: dipole(ncart) - double precision,allocatable :: eps(:,:) - double precision,allocatable :: c(:,:,:) double precision,allocatable :: cp(:,:,:) double precision,allocatable :: J(:,:,:) double precision,allocatable :: F(:,:,:) @@ -63,7 +68,6 @@ subroutine eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weig double precision,external :: trace_matrix double precision,external :: electron_number - double precision,allocatable :: Pw(:,:,:) double precision,allocatable :: rhow(:,:) double precision,allocatable :: drhow(:,:,:) double precision :: nEl(nspin) @@ -75,7 +79,15 @@ subroutine eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weig double precision :: E(nEns) double precision :: Om(nEns) - integer :: ispin,iEns + integer :: ispin,iEns,iBas + +! Output variables + + double precision,intent(out) :: Ew + double precision,intent(out) :: eps(nBas,nspin) + double precision,intent(out) :: Pw(nBas,nBas,nspin) + double precision,intent(out) :: c(nBas,nBas,nspin) + double precision,intent(out) :: Vxc(nBas,nspin) ! Hello world @@ -118,16 +130,19 @@ subroutine eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weig ! Memory allocation - allocate(eps(nBas,nspin),c(nBas,nBas,nspin),cp(nBas,nBas,nspin), & - J(nBas,nBas,nspin),F(nBas,nBas,nspin),Fp(nBas,nBas,nspin), & + allocate(cp(nBas,nBas,nspin),J(nBas,nBas,nspin),F(nBas,nBas,nspin),Fp(nBas,nBas,nspin), & Fx(nBas,nBas,nspin),FxHF(nBas,nBas,nspin),Fc(nBas,nBas,nspin),err(nBas,nBas,nspin), & - Pw(nBas,nBas,nspin),rhow(nGrid,nspin),drhow(ncart,nGrid,nspin), & - err_diis(nBasSq,max_diis,nspin),F_diis(nBasSq,max_diis,nspin), & + rhow(nGrid,nspin),drhow(ncart,nGrid,nspin), & + err_diis(nBasSq,max_diis,nspin),F_diis(nBasSq,max_diis,nspin), & P(nBas,nBas,nspin,nEns),rho(nGrid,nspin,nEns),drho(ncart,nGrid,nspin,nEns)) ! Guess coefficients and eigenvalues - + nO(:) = 0 + do ispin=1,nspin + nO(ispin) = int(sum(occnum(:,ispin,1))) + end do + if(guess_type == 1) then do ispin=1,nspin @@ -136,6 +151,10 @@ subroutine eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weig c(:,:,ispin) = matmul(X(:,:),cp(:,:,ispin)) end do + ! Mix guess to enforce symmetry breaking + + if(mix) call mix_guess(nBas,nO,c) + else if(guess_type == 2) then do ispin=1,nspin @@ -212,7 +231,7 @@ subroutine eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weig rhow(:,:) = rhow(:,:) + wEns(iEns)*rho(:,:,iEns) end do - if(xc_rung > 1 .and. xc_rung /= 666) then + if(xc_rung > 1) then ! Ground state density @@ -260,19 +279,19 @@ subroutine eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weig err(:,:,ispin) = matmul(F(:,:,ispin),matmul(Pw(:,:,ispin),S(:,:))) - matmul(matmul(S(:,:),Pw(:,:,ispin)),F(:,:,ispin)) end do - conv = maxval(abs(err(:,:,:))) + if(nSCF > 1) conv = maxval(abs(err(:,:,:))) ! DIIS extrapolation n_diis = min(n_diis+1,max_diis) - do ispin=1,nspin - call DIIS_extrapolation(rcond(ispin),nBasSq,nBasSq,n_diis, & - err_diis(:,:,ispin),F_diis(:,:,ispin),err(:,:,ispin),F(:,:,ispin)) - end do - -! Reset DIIS if required - - if(minval(rcond(:)) < 1d-15) n_diis = 0 + if(minval(rcond(:)) > 1d-7) then + do ispin=1,nspin + call DIIS_extrapolation(rcond(ispin),nBasSq,nBasSq,n_diis, & + err_diis(:,:,ispin),F_diis(:,:,ispin),err(:,:,ispin),F(:,:,ispin)) + end do + else + n_diis = 0 + end if ! Transform Fock matrix in orthogonal basis @@ -337,7 +356,6 @@ subroutine eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weig nEl(ispin) = electron_number(nGrid,weight,rhow(:,ispin)) end do - ! Dump results write(*,'(1X,A1,1X,I3,1X,A1,1X,F16.10,1X,A1,1X,F16.10,1X,A1,1X,F16.10,1X,A1,1X,F10.6,1X,A1,1X,F10.6,1X,A1,1X)') & @@ -364,24 +382,29 @@ subroutine eDFT_UKS(x_rung,x_DFA,c_rung,c_DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weig end if !!!!! - do iEns=1,nEns - print*,'occnum=',occnum(1,1,iEns),occnum(2,1,iEns),occnum(1,2,iEns),occnum(2,2,iEns) - print*,'nel up and down and total=', electron_number(nGrid,weight,& - rho(:,1,iEns)),electron_number(nGrid,weight,rho(:,2,iEns)),sum(nEl(:)) - - end do +! do iEns=1,nEns +! print*,'occnum=',occnum(1,1,iEns),occnum(2,1,iEns),occnum(1,2,iEns),occnum(2,2,iEns) +! print*,'nel up and down and total=', electron_number(nGrid,weight,& +! rho(:,1,iEns)),electron_number(nGrid,weight,rho(:,2,iEns)),sum(nEl(:)) +! end do !!!!! ! Compute final KS energy - call print_UKS(nBas,nEns,occnum,wEns,eps,c,ENuc,ET,EV,EJ,Ex,Ec,Ew) + call dipole_moment(nBas,Pw(:,:,1)+Pw(:,:,2),nNuc,ZNuc,rNuc,dipole_int,dipole) + call print_UKS(nBas,nEns,nO,S,wEns,eps,c,ENuc,ET,EV,EJ,Ex,Ec,Ew,dipole) + +! Compute Vxc for post-HF calculations + + call xc_potential(nBas,c,Fx,Fc,Vxc) !------------------------------------------------------------------------ ! Compute individual energies from ensemble energy !------------------------------------------------------------------------ - call unrestricted_individual_energy(x_rung,x_DFA,c_rung,c_DFA,LDA_centered,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,nBas, & - AO,dAO,T,V,ERI,ENuc,eps,Pw,rhow,drhow,J,Fx,FxHF,Fc,P,rho,drho,Ew,E,Om,occnum, & - Cx_choice,doNcentered) + if(nEns > 1) & + call unrestricted_individual_energy(x_rung,x_DFA,c_rung,c_DFA,LDA_centered,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,nBas, & + AO,dAO,T,V,ERI,ENuc,eps,Pw,rhow,drhow,J,Fx,FxHF,Fc,P,rho,drho,Ew,E,Om,occnum, & + Cx_choice,doNcentered) end subroutine eDFT_UKS diff --git a/src/eDFT/lda_exchange_potential.f90 b/src/eDFT/lda_exchange_potential.f90 deleted file mode 100644 index c486267..0000000 --- a/src/eDFT/lda_exchange_potential.f90 +++ /dev/null @@ -1,58 +0,0 @@ -subroutine lda_exchange_potential(DFA,LDA_centered,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,nBas,AO,rho,Fx) - -! Select LDA correlation potential - - implicit none - - include 'parameters.h' - -! Input variables - - logical,intent(in) :: LDA_centered - character(len=12),intent(in) :: DFA - integer,intent(in) :: nEns - double precision,intent(in) :: wEns(nEns) - double precision,intent(in) :: aCC_w1(3) - double precision,intent(in) :: aCC_w2(3) - integer,intent(in) :: nGrid - double precision,intent(in) :: weight(nGrid) - integer,intent(in) :: nBas - double precision,intent(in) :: AO(nBas,nGrid) - double precision,intent(in) :: rho(nGrid) - -! Output variables - - double precision,intent(out) :: Fx(nBas,nBas) - -! Select exchange functional - - select case (DFA) - - case ('RS51') - - call RS51_lda_exchange_potential(nGrid,weight,nBas,AO,rho,Fx) - - case ('US51') - - call US51_lda_exchange_potential(nGrid,weight,nBas,AO,rho,Fx) - - case ('RMFL20') - - call RMFL20_lda_exchange_potential(LDA_centered,nEns,wEns,nGrid,weight,nBas,AO,rho,Fx) - - case ('RCC') - - call RCC_lda_exchange_potential(nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,nBas,AO,rho,Fx) - - case ('UCC') - - call UCC_lda_exchange_potential(nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,nBas,AO,rho,Fx) - - case default - - call print_warning('!!! LDA exchange functional not available !!!') - stop - - end select - -end subroutine lda_exchange_potential diff --git a/src/eDFT/orthogonalization_matrix.f90 b/src/eDFT/orthogonalization_matrix.f90 deleted file mode 100644 index 15ea4ac..0000000 --- a/src/eDFT/orthogonalization_matrix.f90 +++ /dev/null @@ -1,120 +0,0 @@ -subroutine orthogonalization_matrix(ortho_type,nBas,S,X) - -! Compute the orthogonalization matrix X - - implicit none - -! Input variables - - integer,intent(in) :: nBas,ortho_type - double precision,intent(in) :: S(nBas,nBas) - -! Local variables - - logical :: debug - double precision,allocatable :: UVec(:,:),Uval(:) - double precision,parameter :: thresh = 1d-6 - - integer :: i - -! Output variables - - double precision,intent(out) :: X(nBas,nBas) - - debug = .false. - -! Type of orthogonalization ortho_type -! -! 1 = Lowdin -! 2 = Canonical -! 3 = SVD -! - - allocate(Uvec(nBas,nBas),Uval(nBas)) - - if(ortho_type == 1) then - - write(*,*) - write(*,*) ' Lowdin orthogonalization' - write(*,*) - - Uvec = S - call diagonalize_matrix(nBas,Uvec,Uval) - - do i=1,nBas - - if(Uval(i) > thresh) then - - Uval(i) = 1d0/sqrt(Uval(i)) - - else - - write(*,*) 'Eigenvalue',i,'too small for Lowdin orthogonalization' - - endif - - enddo - - call ADAt(nBas,Uvec,Uval,X) - - elseif(ortho_type == 2) then - - write(*,*) - write(*,*) 'Canonical orthogonalization' - write(*,*) - - Uvec = S - call diagonalize_matrix(nBas,Uvec,Uval) - - do i=1,nBas - - if(Uval(i) > thresh) then - - Uval(i) = 1d0/sqrt(Uval(i)) - - else - - write(*,*) ' Eigenvalue',i,'too small for canonical orthogonalization' - - endif - - enddo - - call AD(nBas,Uvec,Uval) - X = Uvec - - elseif(ortho_type == 3) then - - write(*,*) - write(*,*) ' SVD-based orthogonalization NYI' - write(*,*) - -! Uvec = S -! call diagonalize_matrix(nBas,Uvec,Uval) - -! do i=1,nBas -! if(Uval(i) > thresh) then -! Uval(i) = 1d0/sqrt(Uval(i)) -! else -! write(*,*) 'Eigenvalue',i,'too small for canonical orthogonalization' -! endif -! enddo -! -! call AD(nBas,Uvec,Uval) -! X = Uvec - - endif - -! Print results - - if(debug) then - - write(*,'(A28)') '----------------------' - write(*,'(A28)') 'Orthogonalization matrix' - write(*,'(A28)') '----------------------' - call matout(nBas,nBas,X) - write(*,*) - - endif - -end subroutine orthogonalization_matrix diff --git a/src/eDFT/print_UKS.f90 b/src/eDFT/print_UKS.f90 index f063849..be30958 100644 --- a/src/eDFT/print_UKS.f90 +++ b/src/eDFT/print_UKS.f90 @@ -1,4 +1,4 @@ -subroutine print_UKS(nBas,nEns,occnum,wEns,eps,c,ENuc,ET,EV,EJ,Ex,Ec,Ew) +subroutine print_UKS(nBas,nEns,nO,Ov,wEns,eps,c,ENuc,ET,EV,EJ,Ex,Ec,Ew,dipole) ! Print one- and two-electron energies and other stuff for KS calculation @@ -9,7 +9,8 @@ subroutine print_UKS(nBas,nEns,occnum,wEns,eps,c,ENuc,ET,EV,EJ,Ex,Ec,Ew) integer,intent(in) :: nBas integer,intent(in) :: nEns - double precision,intent(in) :: occnum(nBas,nspin,nEns) + integer,intent(in) :: nO(nspin) + double precision,intent(in) :: Ov(nBas,nBas) double precision,intent(in) :: wEns(nEns) double precision,intent(in) :: eps(nBas,nspin) double precision,intent(in) :: c(nBas,nBas,nspin) @@ -20,40 +21,39 @@ subroutine print_UKS(nBas,nEns,occnum,wEns,eps,c,ENuc,ET,EV,EJ,Ex,Ec,Ew) double precision,intent(in) :: Ex(nspin) double precision,intent(in) :: Ec(nsp) double precision,intent(in) :: Ew + double precision,intent(in) :: dipole(ncart) ! Local variables + integer :: ixyz integer :: ispin integer :: iEns integer :: iBas integer :: HOMO(nspin) integer :: LUMO(nspin) double precision :: Gap(nspin) - double precision :: nEl(nspin) - -! Number of electrons in the ensemble - - nEl(:) = 0d0 - do ispin=1,nspin - do iEns=1,nEns - do iBas=1,nBas - nEl(ispin) = nEl(ispin) + wEns(iEns)*occnum(iBas,ispin,iEns) - end do - end do - end do + double precision :: S_exact,S2_exact + double precision :: S,S2 ! HOMO and LUMO do ispin=1,nspin - HOMO(ispin) = ceiling(nEl(ispin)) + HOMO(ispin) = nO(ispin) LUMO(ispin) = HOMO(ispin) + 1 Gap(ispin) = eps(LUMO(ispin),ispin) - eps(HOMO(ispin),ispin) end do -! Dump results +! Spin comtamination + S2_exact = dble(nO(1) - nO(2))/2d0*(dble(nO(1) - nO(2))/2d0 + 1d0) + S2 = S2_exact + nO(2) - sum(matmul(transpose(c(:,1:nO(1),1)),matmul(Ov,c(:,1:nO(2),2)))**2) + + S_exact = 0.5d0*dble(nO(1) - nO(2)) + S = -0.5d0 + 0.5d0*sqrt(1d0 + 4d0*S2) + +! Dump results write(*,*) write(*,'(A60)') '-------------------------------------------------' @@ -97,6 +97,15 @@ subroutine print_UKS(nBas,nEns,occnum,wEns,eps,c,ENuc,ET,EV,EJ,Ex,Ec,Ew) write(*,'(A40,F13.6,A3)') ' KS LUMO b energy:',eps(LUMO(2),2)*HatoeV,' eV' write(*,'(A40,F13.6,A3)') ' KS HOMOb-LUMOb gap :',Gap(2)*HatoeV,' eV' write(*,'(A60)') '-------------------------------------------------' + write(*,'(A40,1X,F16.6)') ' S (exact) :',2d0*S_exact + 1d0 + write(*,'(A40,1X,F16.6)') ' S :',2d0*S + 1d0 + write(*,'(A40,1X,F16.6)') ' (exact) :',S2_exact + write(*,'(A40,1X,F16.6)') ' :',S2 + write(*,'(A60)') '-------------------------------------------------' + write(*,'(A45)') ' Dipole moment (Debye) ' + write(*,'(19X,4A10)') 'X','Y','Z','Tot.' + write(*,'(19X,4F10.6)') (dipole(ixyz)*auToD,ixyz=1,ncart),norm2(dipole)*auToD + write(*,'(A60)') '-------------------------------------------------' write(*,*) ! Print results diff --git a/src/eDFT/read_options_dft.f90 b/src/eDFT/read_options_dft.f90 index a9e14a1..8c0fbc0 100644 --- a/src/eDFT/read_options_dft.f90 +++ b/src/eDFT/read_options_dft.f90 @@ -96,7 +96,7 @@ subroutine read_options_dft(nBas,method,x_rung,x_DFA,c_rung,c_DFA,SGn,nEns,wEns, occnum(:,:,:) = 0d0 - do iEns=1,nEns + do iEns=1,maxEns read(1,*) read(1,*) (occnum(iBas,1,iEns),iBas=1,nBas) read(1,*) (occnum(iBas,2,iEns),iBas=1,nBas) @@ -114,17 +114,16 @@ subroutine read_options_dft(nBas,method,x_rung,x_DFA,c_rung,c_DFA,SGn,nEns,wEns, write(*,*) (int(occnum(iBas,2,iEns)),iBas=1,nBas) write(*,*) end do + ! Read ensemble weights for real physical (fractional number of electrons) ensemble (w1,w2) - allocate(nEl(nEns)) + allocate(nEl(maxEns)) nEl(:) = 0d0 - do iEns=1,nEns + do iEns=1,maxEns do iBas=1,nBas nEl(iEns) = nEl(iEns) + occnum(iBas,1,iEns) + occnum(iBas,2,iEns) end do end do - print*,'nEl' - print*,nEl doNcentered = .false. @@ -164,13 +163,13 @@ subroutine read_options_dft(nBas,method,x_rung,x_DFA,c_rung,c_DFA,SGn,nEns,wEns, read(1,*) Cx_choice write(*,*)'----------------------------------------------------------' - write(*,*)' parameters for w1-dependant exchange functional coefficient ' + write(*,*)' parameters for w1-dependent exchange functional coefficient ' write(*,*)'----------------------------------------------------------' call matout(3,1,aCC_w1) write(*,*) write(*,*)'----------------------------------------------------------' - write(*,*)' parameters for w2-dependant exchange functional coefficient ' + write(*,*)' parameters for w2-dependent exchange functional coefficient ' write(*,*)'----------------------------------------------------------' call matout(3,1,aCC_w2) write(*,*) diff --git a/src/eDFT/restricted_exchange_energy.f90 b/src/eDFT/restricted_exchange_energy.f90 index fc43d4e..d86421b 100644 --- a/src/eDFT/restricted_exchange_energy.f90 +++ b/src/eDFT/restricted_exchange_energy.f90 @@ -64,7 +64,7 @@ subroutine restricted_exchange_energy(rung,DFA,LDA_centered,nEns,wEns,aCC_w1,aCC aX = 0.72d0 aC = 0.81d0 - call restricted_lda_exchange_energy(DFA,nEns,wEns,nGrid,weight,rho,ExLDA,Cx_choice) + call restricted_lda_exchange_energy(DFA,LDA_centered,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,rho,ExLDA,Cx_choice) call restricted_gga_exchange_energy(DFA,nEns,wEns,nGrid,weight,rho,drho,ExGGA) call restricted_fock_exchange_energy(nBas,P,FxHF,ExHF) diff --git a/src/eDFT/restricted_exchange_potential.f90 b/src/eDFT/restricted_exchange_potential.f90 index ddcbb2b..fad526d 100644 --- a/src/eDFT/restricted_exchange_potential.f90 +++ b/src/eDFT/restricted_exchange_potential.f90 @@ -66,8 +66,8 @@ subroutine restricted_exchange_potential(rung,DFA,LDA_centered,nEns,wEns,aCC_w1, cX = 0.20d0 aX = 0.72d0 - call restricted_lda_exchange_potential(DFA,nGrid,weight,nBas,AO,rho,FxLDA,Cx_choice) - call restricted_gga_exchange_potential(DFA,nGrid,weight,nBas,AO,dAO,rho,drho,FxGGA) + call restricted_lda_exchange_potential(DFA,LDA_centered,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,nBas,AO,rho,FxLDA,Cx_choice) + call restricted_gga_exchange_potential(DFA,nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,FxGGA) call restricted_fock_exchange_potential(nBas,P,ERI,FxHF) Fx(:,:) = FxLDA(:,:) & diff --git a/src/eDFT/select_rung.f90 b/src/eDFT/select_rung.f90 index 2160590..9236764 100644 --- a/src/eDFT/select_rung.f90 +++ b/src/eDFT/select_rung.f90 @@ -32,10 +32,6 @@ subroutine select_rung(rung,DFA) case(4) write(*,*) "* 4th rung of Jacob's ladder: hybrid functional *" -! Hartree-Fock calculation - case(666) - write(*,*) "* rung 666: Hartree-Fock calculation *" - ! Default case default write(*,*) "!!! rung not available !!!" diff --git a/src/eDFT/unrestricted_correlation_derivative_discontinuity.f90 b/src/eDFT/unrestricted_correlation_derivative_discontinuity.f90 index e04ff0d..98e8841 100644 --- a/src/eDFT/unrestricted_correlation_derivative_discontinuity.f90 +++ b/src/eDFT/unrestricted_correlation_derivative_discontinuity.f90 @@ -42,23 +42,19 @@ subroutine unrestricted_correlation_derivative_discontinuity(rung,DFA,nEns,wEns, case(2) - call print_warning('!!! derivative discontinuity NYI for GGAs !!!') - stop + call unrestricted_gga_correlation_derivative_discontinuity(DFA,nEns,wEns,nGrid,weight,rhow,Ec) + +! MGGA functionals + + case(3) + + call unrestricted_mgga_correlation_derivative_discontinuity(DFA,nEns,wEns,nGrid,weight,rhow,Ec) ! Hybrid functionals case(4) - call print_warning('!!! derivative discontinuity NYI for hybrids !!!') - stop - - aC = 0.81d0 - -! Hartree-Fock calculation - - case(666) - - Ec(:,:) = 0d0 + call unrestricted_hybrid_correlation_derivative_discontinuity(DFA,nEns,wEns,nGrid,weight,rhow,Ec) end select diff --git a/src/eDFT/unrestricted_correlation_energy.f90 b/src/eDFT/unrestricted_correlation_energy.f90 index 578991f..fe53825 100644 --- a/src/eDFT/unrestricted_correlation_energy.f90 +++ b/src/eDFT/unrestricted_correlation_energy.f90 @@ -18,10 +18,6 @@ subroutine unrestricted_correlation_energy(rung,DFA,nEns,wEns,nGrid,weight,rho,d ! Local variables - double precision :: EcLDA(nsp) - double precision :: EcGGA(nsp) - double precision :: aC - ! Output variables double precision,intent(out) :: Ec(nsp) @@ -46,22 +42,17 @@ subroutine unrestricted_correlation_energy(rung,DFA,nEns,wEns,nGrid,weight,rho,d call unrestricted_gga_correlation_energy(DFA,nEns,wEns,nGrid,weight,rho,drho,Ec) +! MGGA functionals + + case(3) + + call unrestricted_mgga_correlation_energy(DFA,nEns,wEns,nGrid,weight,rho,drho,Ec) + ! Hybrid functionals case(4) - aC = 0.81d0 - - call unrestricted_lda_correlation_energy(DFA,nEns,wEns,nGrid,weight,rho,EcLDA) - call unrestricted_gga_correlation_energy(DFA,nEns,wEns,nGrid,weight,rho,drho,EcGGA) - - Ec(:) = EcLDA(:) + aC*(EcGGA(:) - EcLDA(:)) - -! Hartree-Fock calculation - - case(666) - - Ec(:) = 0d0 + call unrestricted_hybrid_correlation_energy(DFA,nEns,wEns,nGrid,weight,rho,drho,Ec) end select diff --git a/src/eDFT/unrestricted_correlation_individual_energy.f90 b/src/eDFT/unrestricted_correlation_individual_energy.f90 index a0431f4..860c955 100644 --- a/src/eDFT/unrestricted_correlation_individual_energy.f90 +++ b/src/eDFT/unrestricted_correlation_individual_energy.f90 @@ -48,22 +48,18 @@ subroutine unrestricted_correlation_individual_energy(rung,DFA,LDA_centered,nEns case(2) call print_warning('!!! Individual energies NYI for GGAs !!!') - stop + +! MGGA functionals + + case(3) + + call print_warning('!!! Individual energies NYI for MGGAs !!!') ! Hybrid functionals case(4) call print_warning('!!! Individual energies NYI for hybrids !!!') - stop - - aC = 0.81d0 - -! Hartree-Fock calculation - - case(666) - - Ec(:) = 0d0 end select diff --git a/src/eDFT/unrestricted_correlation_potential.f90 b/src/eDFT/unrestricted_correlation_potential.f90 index e847b28..d8e168e 100644 --- a/src/eDFT/unrestricted_correlation_potential.f90 +++ b/src/eDFT/unrestricted_correlation_potential.f90 @@ -51,24 +51,17 @@ subroutine unrestricted_correlation_potential(rung,DFA,nEns,wEns,nGrid,weight,nB call unrestricted_gga_correlation_potential(DFA,nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,Fc) +! MGGA functionals + + case(3) + + call unrestricted_mgga_correlation_potential(DFA,nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,Fc) + ! Hybrid functionals case(4) - allocate(FcLDA(nBas,nBas,nspin),FcGGA(nBas,nBas,nspin)) - - aC = 0.81d0 - - call unrestricted_lda_correlation_potential(DFA,nEns,wEns,nGrid,weight,nBas,AO,rho,FcLDA) - call unrestricted_gga_correlation_potential(DFA,nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,FcGGA) - - Fc(:,:,:) = FcLDA(:,:,:) + aC*(FcGGA(:,:,:) - FcLDA(:,:,:)) - -! Hartree-Fock calculation - - case(666) - - Fc(:,:,:) = 0d0 + call unrestricted_hybrid_correlation_potential(DFA,nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,Fc) end select diff --git a/src/eDFT/unrestricted_exchange_derivative_discontinuity.f90 b/src/eDFT/unrestricted_exchange_derivative_discontinuity.f90 index a52f093..0a5308a 100644 --- a/src/eDFT/unrestricted_exchange_derivative_discontinuity.f90 +++ b/src/eDFT/unrestricted_exchange_derivative_discontinuity.f90 @@ -43,25 +43,24 @@ subroutine unrestricted_exchange_derivative_discontinuity(rung,DFA,nEns,wEns,aCC call unrestricted_lda_exchange_derivative_discontinuity(DFA,nEns,wEns(:),aCC_w1,aCC_w2,nGrid,weight(:),& rhow(:),Cx_choice,doNcentered,kappa,ExDD(:)) - ! GGA functionals case(2) call unrestricted_gga_exchange_derivative_discontinuity(DFA,nEns,wEns(:),nGrid,weight(:),rhow(:),drhow(:,:),ExDD(:)) +! MGGA functionals + + case(3) + + call unrestricted_mgga_exchange_derivative_discontinuity(DFA,nEns,wEns(:),nGrid,weight(:),rhow(:),drhow(:,:),ExDD(:)) + ! Hybrid functionals case(4) - call print_warning('!!! exchange part of derivative discontinuity NYI for hybrids !!!') - stop - -! Hartree-Fock calculation - - case(666) - - ExDD(:) = 0d0 + call unrestricted_hybrid_exchange_derivative_discontinuity(DFA,nEns,wEns(:),aCC_w1,aCC_w2,nGrid,weight(:),& + rhow(:),Cx_choice,doNcentered,kappa,ExDD(:)) end select diff --git a/src/eDFT/unrestricted_exchange_energy.f90 b/src/eDFT/unrestricted_exchange_energy.f90 index 91c8e52..f579248 100644 --- a/src/eDFT/unrestricted_exchange_energy.f90 +++ b/src/eDFT/unrestricted_exchange_energy.f90 @@ -26,9 +26,6 @@ subroutine unrestricted_exchange_energy(rung,DFA,LDA_centered,nEns,wEns,aCC_w1,a ! Local variables - double precision :: ExLDA,ExGGA,ExHF - double precision :: cX,aX,aC - ! Output variables double precision,intent(out) :: Ex @@ -46,41 +43,26 @@ subroutine unrestricted_exchange_energy(rung,DFA,LDA_centered,nEns,wEns,aCC_w1,a case(1) call unrestricted_lda_exchange_energy(DFA,LDA_centered,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,& - rho,ExLDA,Cx_choice) - - Ex = ExLDA + rho,Ex,Cx_choice) ! GGA functionals case(2) - call unrestricted_gga_exchange_energy(DFA,nEns,wEns,nGrid,weight,rho,drho,ExGGA) + call unrestricted_gga_exchange_energy(DFA,nEns,wEns,nGrid,weight,rho,drho,Ex) - Ex = ExGGA +! MGGA functionals + + case(3) + + call unrestricted_mgga_exchange_energy(DFA,nEns,wEns,nGrid,weight,rho,drho,Ex) ! Hybrid functionals case(4) - cX = 0.20d0 - aX = 0.72d0 - aC = 0.81d0 - - call unrestricted_lda_exchange_energy(DFA,nEns,wEns,nGrid,weight,rho,ExLDA,Cx_choice) - call unrestricted_gga_exchange_energy(DFA,nEns,wEns,nGrid,weight,rho,drho,ExGGA) - call unrestricted_fock_exchange_energy(nBas,P,FxHF,ExHF) - - Ex = ExLDA & - + cX*(ExHF - ExLDA) & - + aX*(ExGGA - ExLDA) - -! Hartree-Fock calculation - - case(666) - - call unrestricted_fock_exchange_energy(nBas,P,FxHF,ExHF) - - Ex = ExHF + call unrestricted_hybrid_exchange_energy(DFA,LDA_centered,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,nBas,P,FxHF, & + rho,drho,Ex,Cx_choice) end select diff --git a/src/eDFT/unrestricted_exchange_individual_energy.f90 b/src/eDFT/unrestricted_exchange_individual_energy.f90 index 65263be..6ddf3d2 100644 --- a/src/eDFT/unrestricted_exchange_individual_energy.f90 +++ b/src/eDFT/unrestricted_exchange_individual_energy.f90 @@ -33,6 +33,7 @@ subroutine unrestricted_exchange_individual_energy(rung,DFA,LDA_centered,nEns,wE double precision :: ExLDA double precision :: ExGGA + double precision :: ExMGGA double precision :: ExHF ! Output variables @@ -64,20 +65,19 @@ subroutine unrestricted_exchange_individual_energy(rung,DFA,LDA_centered,nEns,wE Ex = ExGGA +! MGGA functionals + + case(3) + + call unrestricted_mgga_exchange_individual_energy(DFA,nEns,wEns,nGrid,weight,rhow,drhow,rho,drho,ExMGGA) + + Ex = ExMGGA + ! Hybrid functionals case(4) call print_warning('!!! Individual energies NYI for Hybrids !!!') - stop - -! Hartree-Fock calculation - - case(666) - - call unrestricted_fock_exchange_individual_energy(nBas,Pw,P,ERI,ExHF) - - Ex = ExHF end select diff --git a/src/eDFT/unrestricted_exchange_potential.f90 b/src/eDFT/unrestricted_exchange_potential.f90 index 487e5b4..31cecc9 100644 --- a/src/eDFT/unrestricted_exchange_potential.f90 +++ b/src/eDFT/unrestricted_exchange_potential.f90 @@ -57,30 +57,18 @@ subroutine unrestricted_exchange_potential(rung,DFA,LDA_centered,nEns,wEns,aCC_w call unrestricted_gga_exchange_potential(DFA,nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,Fx) +! MGGA functionals + + case(3) + + call unrestricted_mgga_exchange_potential(DFA,nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,Fx) + ! Hybrid functionals case(4) - allocate(FxLDA(nBas,nBas),FxGGA(nBas,nBas)) - - cX = 0.20d0 - aX = 0.72d0 - - call unrestricted_lda_exchange_potential(DFA,nGrid,weight,nBas,AO,rho,FxLDA,Cx_choice) - call unrestricted_gga_exchange_potential(DFA,nGrid,weight,nBas,AO,dAO,rho,drho,FxGGA) - call unrestricted_fock_exchange_potential(nBas,P,ERI,FxHF) - - Fx(:,:) = FxLDA(:,:) & - + cX*(FxHF(:,:) - FxLDA(:,:)) & - + aX*(FxGGA(:,:) - FxLDA(:,:)) - -! Hartree-Fock calculation - - case(666) - - call unrestricted_fock_exchange_potential(nBas,P,ERI,FxHF) - - Fx(:,:) = FxHF(:,:) + call unrestricted_hybrid_exchange_potential(DFA,LDA_centered,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,nBas,P, & + ERI,AO,dAO,rho,drho,Fx,FxHF,Cx_choice) end select diff --git a/src/eDFT/unrestricted_fock_exchange_energy.f90 b/src/eDFT/unrestricted_fock_exchange_energy.f90 index d312fa6..fca45fa 100644 --- a/src/eDFT/unrestricted_fock_exchange_energy.f90 +++ b/src/eDFT/unrestricted_fock_exchange_energy.f90 @@ -20,6 +20,6 @@ subroutine unrestricted_fock_exchange_energy(nBas,P,Fx,Ex) ! Compute HF exchange energy - Ex = trace_matrix(nBas,matmul(P,Fx)) + Ex = 0.5d0*trace_matrix(nBas,matmul(P,Fx)) end subroutine unrestricted_fock_exchange_energy diff --git a/src/eDFT/unrestricted_gga_correlation_derivative_discontinuity.f90 b/src/eDFT/unrestricted_gga_correlation_derivative_discontinuity.f90 new file mode 100644 index 0000000..6c83d30 --- /dev/null +++ b/src/eDFT/unrestricted_gga_correlation_derivative_discontinuity.f90 @@ -0,0 +1,44 @@ +subroutine unrestricted_gga_correlation_derivative_discontinuity(DFA,nEns,wEns,nGrid,weight,rhow,Ec) + +! Compute the correlation GGA part of the derivative discontinuity + + implicit none + include 'parameters.h' + +! Input variables + + character(len=12),intent(in) :: DFA + integer,intent(in) :: nEns + double precision,intent(in) :: wEns(nEns) + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rhow(nGrid,nspin) + +! Local variables + + double precision :: aC + +! Output variables + + double precision,intent(out) :: Ec(nsp,nEns) + +! Select correlation functional + + select case (DFA) + + case ('LYP') + + Ec(:,:) = 0d0 + + case ('PBE') + + Ec(:,:) = 0d0 + + case default + + call print_warning('!!! GGA correlation functional not available !!!') + stop + + end select + +end subroutine unrestricted_gga_correlation_derivative_discontinuity diff --git a/src/eDFT/unrestricted_gga_correlation_energy.f90 b/src/eDFT/unrestricted_gga_correlation_energy.f90 index 1ba444a..bcd3edd 100644 --- a/src/eDFT/unrestricted_gga_correlation_energy.f90 +++ b/src/eDFT/unrestricted_gga_correlation_energy.f90 @@ -1,6 +1,6 @@ subroutine unrestricted_gga_correlation_energy(DFA,nEns,wEns,nGrid,weight,rho,drho,Ec) -! Compute unrstricted GGA correlation energy +! Compute unrestricted GGA correlation energy implicit none include 'parameters.h' @@ -24,19 +24,21 @@ subroutine unrestricted_gga_correlation_energy(DFA,nEns,wEns,nGrid,weight,rho,dr double precision :: Ec(nsp) -! Coefficients for ??? GGA exchange functional + select case (DFA) -! Compute GGA exchange energy + case ('LYP') - Ec(:) = 0d0 + call ULYP_gga_correlation_energy(nGrid,weight,rho,drho,Ec) - do iG=1,nGrid + case ('PBE') - ra = rho(iG,1) - rb = rho(iG,2) - ga = drho(1,iG,1)**2 + drho(2,iG,1)**2 + drho(3,iG,1)**2 - gb = drho(1,iG,2)**2 + drho(2,iG,2)**2 + drho(3,iG,2)**2 + call UPBE_gga_correlation_energy(nGrid,weight,rho,drho,Ec) - enddo + case default + + call print_warning('!!! GGA correlation energy not available !!!') + stop + + end select end subroutine unrestricted_gga_correlation_energy diff --git a/src/eDFT/unrestricted_gga_correlation_potential.f90 b/src/eDFT/unrestricted_gga_correlation_potential.f90 index 0f49fb7..f52ebe9 100644 --- a/src/eDFT/unrestricted_gga_correlation_potential.f90 +++ b/src/eDFT/unrestricted_gga_correlation_potential.f90 @@ -24,8 +24,23 @@ subroutine unrestricted_gga_correlation_potential(DFA,nEns,wEns,nGrid,weight,nBa double precision,intent(out) :: Fc(nBas,nBas,nspin) -! Coefficients for GGA correlation functional +! Select GGA exchange functional -! Compute GGA correlation matrix in the AO basis + select case (DFA) + + case ('LYP') + + call ULYP_gga_correlation_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fc) + + case ('PBE') + + call UPBE_gga_correlation_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fc) + + case default + + call print_warning('!!! GGA correlation potential not available !!!') + stop + + end select end subroutine unrestricted_gga_correlation_potential diff --git a/src/eDFT/unrestricted_gga_exchange_derivative_discontinuity.f90 b/src/eDFT/unrestricted_gga_exchange_derivative_discontinuity.f90 index bb0c4a7..7f451c5 100644 --- a/src/eDFT/unrestricted_gga_exchange_derivative_discontinuity.f90 +++ b/src/eDFT/unrestricted_gga_exchange_derivative_discontinuity.f90 @@ -22,14 +22,22 @@ subroutine unrestricted_gga_exchange_derivative_discontinuity(DFA,nEns,wEns,nGri double precision,intent(out) :: ExDD(nEns) -! Select correlation functional +! Select exchange functional select case (DFA) + case ('G96') + + ExDD(:) = 0d0 + case ('B88') ExDD(:) = 0d0 + case ('PBE') + + ExDD(:) = 0d0 + case default call print_warning('!!! GGA exchange derivative discontinuity not available !!!') diff --git a/src/eDFT/unrestricted_gga_exchange_energy.f90 b/src/eDFT/unrestricted_gga_exchange_energy.f90 index b7d2679..f184555 100644 --- a/src/eDFT/unrestricted_gga_exchange_energy.f90 +++ b/src/eDFT/unrestricted_gga_exchange_energy.f90 @@ -30,6 +30,10 @@ subroutine unrestricted_gga_exchange_energy(DFA,nEns,wEns,nGrid,weight,rho,drho, call UB88_gga_exchange_energy(nGrid,weight,rho,drho,Ex) + case ('PBE') + + call UPBE_gga_exchange_energy(nGrid,weight,rho,drho,Ex) + case default call print_warning('!!! GGA exchange energy not available !!!') diff --git a/src/eDFT/unrestricted_gga_exchange_potential.f90 b/src/eDFT/unrestricted_gga_exchange_potential.f90 index 368a0e4..4c72163 100644 --- a/src/eDFT/unrestricted_gga_exchange_potential.f90 +++ b/src/eDFT/unrestricted_gga_exchange_potential.f90 @@ -34,6 +34,10 @@ subroutine unrestricted_gga_exchange_potential(DFA,nEns,wEns,nGrid,weight,nBas,A call UB88_gga_exchange_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fx) + case ('PBE') + + call UPBE_gga_exchange_potential(nGrid,weight,nBas,AO,dAO,rho,drho,Fx) + case default call print_warning('!!! GGA exchange potential not available !!!') diff --git a/src/eDFT/unrestricted_hybrid_correlation_derivative_discontinuity.f90 b/src/eDFT/unrestricted_hybrid_correlation_derivative_discontinuity.f90 new file mode 100644 index 0000000..ed74ddd --- /dev/null +++ b/src/eDFT/unrestricted_hybrid_correlation_derivative_discontinuity.f90 @@ -0,0 +1,48 @@ +subroutine unrestricted_hybrid_correlation_derivative_discontinuity(DFA,nEns,wEns,nGrid,weight,rhow,Ec) + +! Compute the correlation hybrid part of the derivative discontinuity + + implicit none + include 'parameters.h' + +! Input variables + + character(len=12),intent(in) :: DFA + integer,intent(in) :: nEns + double precision,intent(in) :: wEns(nEns) + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rhow(nGrid,nspin) + +! Local variables + + double precision :: aC + +! Output variables + + double precision,intent(out) :: Ec(nsp,nEns) + +! Select correlation functional + + select case (DFA) + + case ('HF') + + Ec(:,:) = 0d0 + + case ('LYP') + + Ec(:,:) = 0d0 + + case ('PBE') + + Ec(:,:) = 0d0 + + case default + + call print_warning('!!! Hybrid correlation functional not available !!!') + stop + + end select + +end subroutine unrestricted_hybrid_correlation_derivative_discontinuity diff --git a/src/eDFT/unrestricted_hybrid_correlation_energy.f90 b/src/eDFT/unrestricted_hybrid_correlation_energy.f90 new file mode 100644 index 0000000..e8a286b --- /dev/null +++ b/src/eDFT/unrestricted_hybrid_correlation_energy.f90 @@ -0,0 +1,58 @@ +subroutine unrestricted_hybrid_correlation_energy(DFA,nEns,wEns,nGrid,weight,rho,drho,Ec) + +! Compute the unrestricted version of the correlation energy for hybrid functionals + + implicit none + include 'parameters.h' + +! Input variables + + character(len=12),intent(in) :: DFA + integer,intent(in) :: nEns + double precision,intent(in) :: wEns(nEns) + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rho(nGrid,nspin) + double precision,intent(in) :: drho(ncart,nGrid,nspin) + +! Local variables + + double precision :: EcLDA(nsp) + double precision :: EcGGA(nsp) + double precision :: aC + +! Output variables + + double precision,intent(out) :: Ec(nsp) + + select case (DFA) + + case('HF') + + Ec(:) = 0d0 + + case('B3LYP') + + aC = 0.81d0 + + call unrestricted_lda_correlation_energy('VWN3 ',nEns,wEns,nGrid,weight,rho,EcLDA) + call unrestricted_gga_correlation_energy('LYP ',nEns,wEns,nGrid,weight,rho,drho,EcGGA) + + Ec(:) = EcLDA(:) + aC*(EcGGA(:) - EcLDA(:)) + + case('BHHLYP') + + call unrestricted_gga_correlation_energy('LYP ',nEns,wEns,nGrid,weight,rho,drho,Ec) + + case('PBE') + + call unrestricted_gga_correlation_energy('PBE ',nEns,wEns,nGrid,weight,rho,drho,Ec) + + case default + + call print_warning('!!! Hybrid correlation energy not available !!!') + stop + + end select + +end subroutine unrestricted_hybrid_correlation_energy diff --git a/src/eDFT/unrestricted_hybrid_correlation_potential.f90 b/src/eDFT/unrestricted_hybrid_correlation_potential.f90 new file mode 100644 index 0000000..4b37441 --- /dev/null +++ b/src/eDFT/unrestricted_hybrid_correlation_potential.f90 @@ -0,0 +1,69 @@ +subroutine unrestricted_hybrid_correlation_potential(DFA,nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,Fc) + +! Compute the correlation potential for hybrid functionals + + implicit none + include 'parameters.h' + +! Input variables + + character(len=12),intent(in) :: DFA + integer,intent(in) :: nEns + double precision,intent(in) :: wEns(nEns) + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + integer,intent(in) :: nBas + double precision,intent(in) :: AO(nBas,nGrid) + double precision,intent(in) :: dAO(ncart,nBas,nGrid) + double precision,intent(in) :: rho(nGrid,nspin) + double precision,intent(in) :: drho(ncart,nGrid,nspin) + +! Local variables + + double precision,allocatable :: FcLDA(:,:,:) + double precision,allocatable :: FcGGA(:,:,:) + double precision :: aC + +! Output variables + + double precision,intent(out) :: Fc(nBas,nBas,nspin) + +! Memory allocation + + select case (DFA) + + case('HF') + + Fc(:,:,:) = 0d0 + + case('B3LYP') + + allocate(FcLDA(nBas,nBas,nspin),FcGGA(nBas,nBas,nspin)) + + aC = 0.81d0 + + call unrestricted_lda_correlation_potential('VWN3 ',nEns,wEns,nGrid,weight,nBas,AO,rho,FcLDA) + call unrestricted_gga_correlation_potential('LYP ',nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,FcGGA) + + Fc(:,:,:) = FcLDA(:,:,:) + aC*(FcGGA(:,:,:) - FcLDA(:,:,:)) + + case('BHHLYP') + + allocate(FcGGA(nBas,nBas,nspin)) + + call unrestricted_gga_correlation_potential('LYP ',nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,Fc) + + case('PBE') + + allocate(FcGGA(nBas,nBas,nspin)) + + call unrestricted_gga_correlation_potential('PBE ',nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,Fc) + + case default + + call print_warning('!!! Hybrid correlation potential not available !!!') + stop + + end select + +end subroutine unrestricted_hybrid_correlation_potential diff --git a/src/eDFT/unrestricted_hybrid_exchange_derivative_discontinuity.f90 b/src/eDFT/unrestricted_hybrid_exchange_derivative_discontinuity.f90 new file mode 100644 index 0000000..7e5bde8 --- /dev/null +++ b/src/eDFT/unrestricted_hybrid_exchange_derivative_discontinuity.f90 @@ -0,0 +1,54 @@ +subroutine unrestricted_hybrid_exchange_derivative_discontinuity(DFA,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,rhow,& + Cx_choice,doNcentered,kappa,ExDD) + +! Compute the exchange part of the derivative discontinuity for hybrid functionals + + implicit none + include 'parameters.h' + +! Input variables + + character(len=12),intent(in) :: DFA + integer,intent(in) :: nEns + double precision,intent(in) :: wEns(nEns) + double precision,intent(in) :: aCC_w1(3) + double precision,intent(in) :: aCC_w2(3) + + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rhow(nGrid) + integer,intent(in) :: Cx_choice + logical,intent(in) :: doNcentered + double precision,intent(in) :: kappa(nEns) + +! Local variables + + +! Output variables + + double precision,intent(out) :: ExDD(nEns) + +! Select exchange functional + + select case (DFA) + + case ('HF') + + ExDD(:) = 0d0 + + case ('B3') + + ExDD(:) = 0d0 + + case ('PBE') + + ExDD(:) = 0d0 + + case default + + call print_warning('!!! Hybrid exchange derivative discontinuity not available !!!') + stop + + end select + +end subroutine unrestricted_hybrid_exchange_derivative_discontinuity diff --git a/src/eDFT/unrestricted_hybrid_exchange_energy.f90 b/src/eDFT/unrestricted_hybrid_exchange_energy.f90 new file mode 100644 index 0000000..8fee449 --- /dev/null +++ b/src/eDFT/unrestricted_hybrid_exchange_energy.f90 @@ -0,0 +1,76 @@ +subroutine unrestricted_hybrid_exchange_energy(DFA,LDA_centered,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,nBas,P,FxHF, & + rho,drho,Ex,Cx_choice) + +! Compute the exchange energy for hybrid functionals + + implicit none + include 'parameters.h' + +! Input variables + + character(len=12),intent(in) :: DFA + logical,intent(in) :: LDA_centered + integer,intent(in) :: nEns + double precision,intent(in) :: wEns(nEns) + double precision,intent(in) :: aCC_w1(3) + double precision,intent(in) :: aCC_w2(3) + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: FxHF(nBas,nBas) + double precision,intent(in) :: rho(nGrid) + double precision,intent(in) :: drho(ncart,nGrid) + integer,intent(in) :: Cx_choice + +! Local variables + + double precision :: ExLDA,ExGGA,ExHF + double precision :: a0,aX + +! Output variables + + double precision,intent(out) :: Ex + + select case (DFA) + + case ('HF') + + call unrestricted_fock_exchange_energy(nBas,P,FxHF,Ex) + + case ('B3LYP') + + a0 = 0.20d0 + aX = 0.72d0 + + call unrestricted_lda_exchange_energy('S51 ',LDA_centered,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,& + rho,ExLDA,Cx_choice) + call unrestricted_gga_exchange_energy('B88 ',nEns,wEns,nGrid,weight,rho,drho,ExGGA) + call unrestricted_fock_exchange_energy(nBas,P,FxHF,ExHF) + + Ex = ExLDA & + + a0*(ExHF - ExLDA) & + + aX*(ExGGA - ExLDA) + + case ('BHHLYP') + + call unrestricted_gga_exchange_energy('B88 ',nEns,wEns,nGrid,weight,rho,drho,ExGGA) + call unrestricted_fock_exchange_energy(nBas,P,FxHF,ExHF) + + Ex = 0.5d0*ExHF + 0.5d0*ExGGA + + case ('PBE') + + call unrestricted_gga_exchange_energy('PBE ',nEns,wEns,nGrid,weight,rho,drho,ExGGA) + call unrestricted_fock_exchange_energy(nBas,P,FxHF,ExHF) + + Ex = 0.25d0*ExHF + 0.75d0*ExGGA + + case default + + call print_warning('!!! Hybrid exchange energy not available !!!') + stop + + end select + +end subroutine unrestricted_hybrid_exchange_energy diff --git a/src/eDFT/unrestricted_hybrid_exchange_potential.f90 b/src/eDFT/unrestricted_hybrid_exchange_potential.f90 new file mode 100644 index 0000000..9875832 --- /dev/null +++ b/src/eDFT/unrestricted_hybrid_exchange_potential.f90 @@ -0,0 +1,87 @@ +subroutine unrestricted_hybrid_exchange_potential(DFA,LDA_centered,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight,nBas,P, & + ERI,AO,dAO,rho,drho,Fx,FxHF,Cx_choice) + +! Compute the exchange potential for hybrid functionals + + implicit none + include 'parameters.h' + +! Input variables + + character(len=12),intent(in) :: DFA + logical,intent(in) :: LDA_centered + integer,intent(in) :: nEns + double precision,intent(in) :: wEns(nEns) + double precision,intent(in) :: aCC_w1(3) + double precision,intent(in) :: aCC_w2(3) + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + integer,intent(in) :: nBas + double precision,intent(in) :: P(nBas,nBas) + double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas) + double precision,intent(in) :: AO(nBas,nGrid) + double precision,intent(in) :: dAO(ncart,nBas,nGrid) + double precision,intent(in) :: rho(nGrid) + double precision,intent(in) :: drho(ncart,nGrid) + integer,intent(in) :: Cx_choice + +! Local variables + + double precision,allocatable :: FxLDA(:,:),FxGGA(:,:) + double precision :: a0,aX + +! Output variables + + double precision,intent(out) :: Fx(nBas,nBas),FxHF(nBas,nBas) + +! Memory allocation + + select case (DFA) + + case('HF') + + call unrestricted_fock_exchange_potential(nBas,P,ERI,FxHF) + Fx(:,:) = FxHF(:,:) + + case('B3LYP') + + allocate(FxLDA(nBas,nBas),FxGGA(nBas,nBas)) + + a0 = 0.20d0 + aX = 0.72d0 + + call unrestricted_lda_exchange_potential('S51 ',LDA_centered,nEns,wEns,aCC_w1,aCC_w2,nGrid,weight, & + nBas,AO,rho,FxLDA,Cx_choice) + call unrestricted_gga_exchange_potential('B88 ',nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,FxGGA) + call unrestricted_fock_exchange_potential(nBas,P,ERI,FxHF) + + Fx(:,:) = FxLDA(:,:) & + + a0*(FxHF(:,:) - FxLDA(:,:)) & + + aX*(FxGGA(:,:) - FxLDA(:,:)) + + case('BHHLYP') + + allocate(FxGGA(nBas,nBas)) + + call unrestricted_gga_exchange_potential('B88 ',nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,FxGGA) + call unrestricted_fock_exchange_potential(nBas,P,ERI,FxHF) + + Fx(:,:) = 0.5d0*FxHF(:,:) + 0.5d0*FxGGA(:,:) + + case('PBE') + + allocate(FxGGA(nBas,nBas)) + + call unrestricted_gga_exchange_potential('PBE ',nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,FxGGA) + call unrestricted_fock_exchange_potential(nBas,P,ERI,FxHF) + + Fx(:,:) = 0.25d0*FxHF(:,:) + 0.75d0*FxGGA(:,:) + + case default + + call print_warning('!!! Hybrid exchange potential not available !!!') + stop + + end select + +end subroutine unrestricted_hybrid_exchange_potential diff --git a/src/eDFT/unrestricted_individual_energy.f90 b/src/eDFT/unrestricted_individual_energy.f90 index d0fcd99..f397140 100644 --- a/src/eDFT/unrestricted_individual_energy.f90 +++ b/src/eDFT/unrestricted_individual_energy.f90 @@ -84,13 +84,13 @@ subroutine unrestricted_individual_energy(x_rung,x_DFA,c_rung,c_DFA,LDA_centered nEl(:) = 0d0 do iEns=1,nEns do iBas=1,nBas - nEl(iEns) = nEl(iEns) + occnum(iBas,1,iEns) + occnum(iBas,2,iEns) + do ispin=1,nspin + nEl(iEns) = nEl(iEns) + occnum(iBas,ispin,iEns) + end do end do kappa(iEns) = nEl(iEns)/nEl(1) end do - print*,'test1' - !------------------------------------------------------------------------ ! Kinetic energy !------------------------------------------------------------------------ @@ -104,7 +104,6 @@ subroutine unrestricted_individual_energy(x_rung,x_DFA,c_rung,c_DFA,LDA_centered end if end do end do - print*,'test2' !------------------------------------------------------------------------ ! Potential energy @@ -120,7 +119,6 @@ subroutine unrestricted_individual_energy(x_rung,x_DFA,c_rung,c_DFA,LDA_centered end do end do - print*,'test3' !------------------------------------------------------------------------ ! Individual Hartree energy !------------------------------------------------------------------------ @@ -145,7 +143,7 @@ subroutine unrestricted_individual_energy(x_rung,x_DFA,c_rung,c_DFA,LDA_centered if(doNcentered) EJ(:,iEns) = kappa(iEns)*EJ(:,iEns) end do - print*,'test4' + !------------------------------------------------------------------------ ! Checking Hartree contributions for each individual states !------------------------------------------------------------------------ @@ -174,8 +172,6 @@ subroutine unrestricted_individual_energy(x_rung,x_DFA,c_rung,c_DFA,LDA_centered end do end do - print*,'test5' - !------------------------------------------------------------------------ ! Checking exchange contributions for each individual states !------------------------------------------------------------------------ diff --git a/src/eDFT/unrestricted_lda_correlation_energy.f90 b/src/eDFT/unrestricted_lda_correlation_energy.f90 index 938ec59..49a72df 100644 --- a/src/eDFT/unrestricted_lda_correlation_energy.f90 +++ b/src/eDFT/unrestricted_lda_correlation_energy.f90 @@ -32,14 +32,18 @@ subroutine unrestricted_lda_correlation_energy(DFA,nEns,wEns,nGrid,weight,rho,Ec call UW38_lda_correlation_energy(nGrid,weight,rho,Ec) -! Vosko, Wilk and Nusair's functional V: Can. J. Phys. 58 (1980) 1200 + case ('PW92') + + call UPW92_lda_correlation_energy(nGrid,weight,rho,Ec) + + case ('VWN3') + + call UVWN3_lda_correlation_energy(nGrid,weight,rho,Ec) case ('VWN5') call UVWN5_lda_correlation_energy(nGrid,weight,rho,Ec) -! Chachiyo's LDA correlation functional: Chachiyo, JCP 145 (2016) 021101 - case ('C16') call UC16_lda_correlation_energy(nGrid,weight,rho,Ec) diff --git a/src/eDFT/unrestricted_lda_correlation_individual_energy.f90 b/src/eDFT/unrestricted_lda_correlation_individual_energy.f90 index 1db2a25..6cdb3b9 100644 --- a/src/eDFT/unrestricted_lda_correlation_individual_energy.f90 +++ b/src/eDFT/unrestricted_lda_correlation_individual_energy.f90 @@ -26,6 +26,10 @@ subroutine unrestricted_lda_correlation_individual_energy(DFA,LDA_centered,nEns, ! Vosko, Wilk and Nusair's functional V: Can. J. Phys. 58 (1980) 1200 + case ('VWN3') + + call UVWN3_lda_correlation_individual_energy(nGrid,weight,rhow,rho,Ec) + case ('VWN5') call UVWN5_lda_correlation_individual_energy(nGrid,weight,rhow,rho,Ec) diff --git a/src/eDFT/unrestricted_lda_correlation_potential.f90 b/src/eDFT/unrestricted_lda_correlation_potential.f90 index 549bc55..9d44349 100644 --- a/src/eDFT/unrestricted_lda_correlation_potential.f90 +++ b/src/eDFT/unrestricted_lda_correlation_potential.f90 @@ -30,20 +30,22 @@ include 'parameters.h' Fc(:,:,:) = 0d0 -! Wigner's LDA correlation functional: Wigner, Trans. Faraday Soc. 34 (1938) 678 - case ('W38') call UW38_lda_correlation_potential(nGrid,weight(:),nBas,AO(:,:),rho(:,:),Fc(:,:,:)) -! Vosko, Wilk and Nusair's functional V: Can. J. Phys. 58 (1980) 1200 + case ('PW92') + + call UPW92_lda_correlation_potential(nGrid,weight(:),nBas,AO(:,:),rho(:,:),Fc(:,:,:)) + + case ('VWN3') + + call UVWN3_lda_correlation_potential(nGrid,weight(:),nBas,AO(:,:),rho(:,:),Fc(:,:,:)) case ('VWN5') call UVWN5_lda_correlation_potential(nGrid,weight(:),nBas,AO(:,:),rho(:,:),Fc(:,:,:)) -! Chachiyo's LDA correlation functional: Chachiyo, JCP 145 (2016) 021101 - case ('C16') call UC16_lda_correlation_potential(nGrid,weight(:),nBas,AO(:,:),rho(:,:),Fc(:,:,:)) diff --git a/src/eDFT/unrestricted_lda_exchange_energy.f90 b/src/eDFT/unrestricted_lda_exchange_energy.f90 index f4d6fba..71e7aa1 100644 --- a/src/eDFT/unrestricted_lda_exchange_energy.f90 +++ b/src/eDFT/unrestricted_lda_exchange_energy.f90 @@ -36,7 +36,8 @@ subroutine unrestricted_lda_exchange_energy(DFA,LDA_centered,nEns,wEns,aCC_w1,aC case default - call print_warning('!!! LDA exchange functional not available !!!') + call print_warning('!!! LDA exchange energy not available !!!') + stop end select diff --git a/src/eDFT/unrestricted_lda_exchange_potential.f90 b/src/eDFT/unrestricted_lda_exchange_potential.f90 index dd26ffb..718bce8 100644 --- a/src/eDFT/unrestricted_lda_exchange_potential.f90 +++ b/src/eDFT/unrestricted_lda_exchange_potential.f90 @@ -39,7 +39,7 @@ subroutine unrestricted_lda_exchange_potential(DFA,LDA_centered,nEns,wEns,aCC_w1 case default - call print_warning('!!! LDA exchange functional not available !!!') + call print_warning('!!! LDA exchange potential not available !!!') stop end select diff --git a/src/eDFT/unrestricted_mgga_correlation_derivative_discontinuity.f90 b/src/eDFT/unrestricted_mgga_correlation_derivative_discontinuity.f90 new file mode 100644 index 0000000..4a870fe --- /dev/null +++ b/src/eDFT/unrestricted_mgga_correlation_derivative_discontinuity.f90 @@ -0,0 +1,34 @@ +subroutine unrestricted_mgga_correlation_derivative_discontinuity(DFA,nEns,wEns,nGrid,weight,rhow,Ec) + +! Compute the correlation MGGA part of the derivative discontinuity + + implicit none + include 'parameters.h' + +! Input variables + + character(len=12),intent(in) :: DFA + integer,intent(in) :: nEns + double precision,intent(in) :: wEns(nEns) + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rhow(nGrid,nspin) + +! Local variables + +! Output variables + + double precision,intent(out) :: Ec(nsp,nEns) + +! Select correlation functional + + select case (DFA) + + case default + + call print_warning('!!! MGGA correlation functional not available !!!') + stop + + end select + +end subroutine unrestricted_mgga_correlation_derivative_discontinuity diff --git a/src/eDFT/unrestricted_mgga_correlation_energy.f90 b/src/eDFT/unrestricted_mgga_correlation_energy.f90 new file mode 100644 index 0000000..ae797ac --- /dev/null +++ b/src/eDFT/unrestricted_mgga_correlation_energy.f90 @@ -0,0 +1,36 @@ +subroutine unrestricted_mgga_correlation_energy(DFA,nEns,wEns,nGrid,weight,rho,drho,Ec) + +! Compute unrestricted MGGA correlation energy + + implicit none + include 'parameters.h' + +! Input variables + + character(len=12),intent(in) :: DFA + integer,intent(in) :: nEns + double precision,intent(in) :: wEns(nEns) + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rho(nGrid,nspin) + double precision,intent(in) :: drho(ncart,nGrid,nspin) + +! Local variables + + integer :: iG + double precision :: ra,rb,ga,gb + +! Output variables + + double precision :: Ec(nsp) + + select case (DFA) + + case default + + call print_warning('!!! MGGA correlation energy not available !!!') + stop + + end select + +end subroutine unrestricted_mgga_correlation_energy diff --git a/src/eDFT/unrestricted_mgga_correlation_potential.f90 b/src/eDFT/unrestricted_mgga_correlation_potential.f90 new file mode 100644 index 0000000..cda1e10 --- /dev/null +++ b/src/eDFT/unrestricted_mgga_correlation_potential.f90 @@ -0,0 +1,38 @@ +subroutine unrestricted_mgga_correlation_potential(DFA,nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,Fc) + +! Compute unrestricted MGGA correlation potential + + implicit none + include 'parameters.h' + +! Input variables + + character(len=12),intent(in) :: DFA + integer,intent(in) :: nEns + double precision,intent(in) :: wEns(nEns) + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + integer,intent(in) :: nBas + double precision,intent(in) :: AO(nBas,nGrid) + double precision,intent(in) :: dAO(3,nBas,nGrid) + double precision,intent(in) :: rho(nGrid,nspin) + double precision,intent(in) :: drho(3,nGrid,nspin) + +! Local variables + +! Output variables + + double precision,intent(out) :: Fc(nBas,nBas,nspin) + +! Select MGGA exchange functional + + select case (DFA) + + case default + + call print_warning('!!! MGGA correlation potential not available !!!') + stop + + end select + +end subroutine unrestricted_mgga_correlation_potential diff --git a/src/eDFT/unrestricted_mgga_exchange_derivative_discontinuity.f90 b/src/eDFT/unrestricted_mgga_exchange_derivative_discontinuity.f90 new file mode 100644 index 0000000..1d75470 --- /dev/null +++ b/src/eDFT/unrestricted_mgga_exchange_derivative_discontinuity.f90 @@ -0,0 +1,36 @@ +subroutine unrestricted_mgga_exchange_derivative_discontinuity(DFA,nEns,wEns,nGrid,weight,rhow,drhow,ExDD) + +! Compute the exchange MGGA part of the derivative discontinuity + + implicit none + include 'parameters.h' + +! Input variables + + character(len=12),intent(in) :: DFA + integer,intent(in) :: nEns + double precision,intent(in) :: wEns(nEns) + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rhow(nGrid) + double precision,intent(in) :: drhow(ncart,nGrid) + +! Local variables + + +! Output variables + + double precision,intent(out) :: ExDD(nEns) + +! Select exchange functional + + select case (DFA) + + case default + + call print_warning('!!! MGGA exchange derivative discontinuity not available !!!') + stop + + end select + +end subroutine unrestricted_mgga_exchange_derivative_discontinuity diff --git a/src/eDFT/unrestricted_mgga_exchange_energy.f90 b/src/eDFT/unrestricted_mgga_exchange_energy.f90 new file mode 100644 index 0000000..18a9cf7 --- /dev/null +++ b/src/eDFT/unrestricted_mgga_exchange_energy.f90 @@ -0,0 +1,32 @@ +subroutine unrestricted_mgga_exchange_energy(DFA,nEns,wEns,nGrid,weight,rho,drho,Ex) + +! Select MGGA exchange functional for energy calculation + + implicit none + + include 'parameters.h' + +! Input variables + + character(len=12),intent(in) :: DFA + integer,intent(in) :: nEns + double precision,intent(in) :: wEns(nEns) + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rho(nGrid) + double precision,intent(in) :: drho(3,nGrid) + +! Output variables + + double precision :: Ex + + select case (DFA) + + case default + + call print_warning('!!! MGGA exchange energy not available !!!') + stop + + end select + +end subroutine unrestricted_mgga_exchange_energy diff --git a/src/eDFT/unrestricted_mgga_exchange_individual_energy.f90 b/src/eDFT/unrestricted_mgga_exchange_individual_energy.f90 new file mode 100644 index 0000000..74267d5 --- /dev/null +++ b/src/eDFT/unrestricted_mgga_exchange_individual_energy.f90 @@ -0,0 +1,35 @@ +subroutine unrestricted_mgga_exchange_individual_energy(DFA,nEns,wEns,nGrid,weight,rhow,drhow,rho,drho,Ex) + +! Compute MGGA exchange energy for individual states + + implicit none + include 'parameters.h' + +! Input variables + + character(len=12),intent(in) :: DFA + integer,intent(in) :: nEns + double precision,intent(in) :: wEns(nEns) + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + double precision,intent(in) :: rhow(nGrid) + double precision,intent(in) :: drhow(ncart,nGrid) + double precision,intent(in) :: rho(nGrid) + double precision,intent(in) :: drho(ncart,nGrid) + +! Output variables + + double precision :: Ex + +! Select correlation functional + + select case (DFA) + + case default + + call print_warning('!!! MGGA exchange individual energy not available !!!') + stop + + end select + +end subroutine unrestricted_mgga_exchange_individual_energy diff --git a/src/eDFT/unrestricted_mgga_exchange_potential.f90 b/src/eDFT/unrestricted_mgga_exchange_potential.f90 new file mode 100644 index 0000000..aef588f --- /dev/null +++ b/src/eDFT/unrestricted_mgga_exchange_potential.f90 @@ -0,0 +1,36 @@ +subroutine unrestricted_mgga_exchange_potential(DFA,nEns,wEns,nGrid,weight,nBas,AO,dAO,rho,drho,Fx) + +! Select MGGA exchange functional for potential calculation + + implicit none + include 'parameters.h' + +! Input variables + + character(len=12),intent(in) :: DFA + integer,intent(in) :: nEns + double precision,intent(in) :: wEns(nEns) + integer,intent(in) :: nGrid + double precision,intent(in) :: weight(nGrid) + integer,intent(in) :: nBas + double precision,intent(in) :: AO(nBas,nGrid) + double precision,intent(in) :: dAO(3,nBas,nGrid) + double precision,intent(in) :: rho(nGrid) + double precision,intent(in) :: drho(3,nGrid) + +! Output variables + + double precision,intent(out) :: Fx(nBas,nBas) + +! Select MGGA exchange functional + + select case (DFA) + + case default + + call print_warning('!!! MGGA exchange potential not available !!!') + stop + + end select + +end subroutine unrestricted_mgga_exchange_potential diff --git a/src/eDFT/xc_potential.f90 b/src/eDFT/xc_potential.f90 new file mode 100644 index 0000000..2037ab2 --- /dev/null +++ b/src/eDFT/xc_potential.f90 @@ -0,0 +1,40 @@ +subroutine xc_potential(nBas,c,Fx,Fc,Vxc) + +! Compute the exchange-correlation potential in the MO basis + + implicit none + include 'parameters.h' + +! Input variables + + integer,intent(in) :: nBas + double precision,intent(in) :: c(nBas,nBas,nspin) + double precision,intent(in) :: Fx(nBas,nBas,nspin) + double precision,intent(in) :: Fc(nBas,nBas,nspin) + +! Local variables + + integer :: mu,nu + integer :: p + integer :: ispin + +! Output variables + + double precision,intent(out) :: Vxc(nBas,nspin) + +! Compute Vxc + + Vxc(:,:) = 0d0 + do p=1,nBas + do ispin=1,nspin + do mu=1,nBas + do nu=1,nBas + Vxc(p,ispin) = Vxc(p,ispin) & + + c(mu,p,ispin)*(Fx(mu,nu,ispin) + Fc(mu,nu,ispin))*c(nu,p,ispin) + + end do + end do + end do + end do + +end subroutine xc_potential diff --git a/src/utils/orthogonalization_matrix.f90 b/src/utils/orthogonalization_matrix.f90 index 348abdb..5c78601 100644 --- a/src/utils/orthogonalization_matrix.f90 +++ b/src/utils/orthogonalization_matrix.f90 @@ -57,9 +57,9 @@ subroutine orthogonalization_matrix(ortho_type,nBas,S,X) elseif(ortho_type == 2) then - write(*,*) - write(*,*) 'Canonical orthogonalization' - write(*,*) +! write(*,*) +! write(*,*) 'Canonical orthogonalization' +! write(*,*) Uvec = S call diagonalize_matrix(nBas,Uvec,Uval) @@ -83,9 +83,9 @@ subroutine orthogonalization_matrix(ortho_type,nBas,S,X) elseif(ortho_type == 3) then - write(*,*) - write(*,*) ' SVD-based orthogonalization NYI' - write(*,*) +! write(*,*) +! write(*,*) ' SVD-based orthogonalization NYI' +! write(*,*) ! Uvec = S ! call diagonalize_matrix(nBas,Uvec,Uval) diff --git a/src/utils/wrap_lapack.f90 b/src/utils/wrap_lapack.f90 index 2a38dfa..54d6cd0 100644 --- a/src/utils/wrap_lapack.f90 +++ b/src/utils/wrap_lapack.f90 @@ -153,7 +153,7 @@ subroutine linear_solve(N,A,b,x,rcond) implicit none integer,intent(in) :: N - double precision,intent(in) :: A(N,N),b(N),rcond + double precision,intent(out) :: A(N,N),b(N),rcond double precision,intent(out) :: x(N) integer :: info,lwork