PTEROSOR/QuAcK
10
1
Fork 0
mirror of https://github.com/pfloos/quack synced 2024-11-04 05:03:49 +01:00
Code Releases Activity

ppLR in GTpp and GW

Browse Source
This commit is contained in:
Pierre-Francois Loos 2023-07-20 14:59:02 +02:00
parent ad174054bb
commit 63ab549f6b
14 changed files with 157 additions and 225 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/GT/dynamic_Tmatrix_A.f90 → src/GT/GTpp_dynamic_kernel_Aph.f90
View File

@ -1,4 +1,4 @@
subroutine dynamic_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,eGT,Om1,Om2,rho1,rho2,OmBSE,TA,ZA) subroutine GTpp_dynamic_kernel_Aph(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,eGT,Om1,Om2,rho1,rho2,OmBSE,TA,ZA)
! Compute the dynamic part of the Bethe-Salpeter equation matrices for GT ! Compute the dynamic part of the Bethe-Salpeter equation matrices for GT
@ -92,4 +92,4 @@ subroutine dynamic_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,eGT,Om1,Om2,
!$omp end parallel do !$omp end parallel do
end subroutine dynamic_Tmatrix_A end subroutine

4
src/GT/dynamic_Tmatrix_B.f90 → src/GT/GTpp_dynamic_kernel_Bph.f90
View File

@ -1,4 +1,4 @@
subroutine dynamic_Tmatrix_B(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,eGT,Omega1,Omega2,rho1,rho2,OmBSE,TB,ZB) subroutine GTpp_dynamic_kernel_Bph(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,eGT,Omega1,Omega2,rho1,rho2,OmBSE,TB,ZB)
! Compute the off-diagonal dynamic part of the Bethe-Salpeter equation matrices for GT ! Compute the off-diagonal dynamic part of the Bethe-Salpeter equation matrices for GT
@ -88,4 +88,4 @@ subroutine dynamic_Tmatrix_B(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,eGT,Omega1,O
end do end do
end do end do
end subroutine dynamic_Tmatrix_B end subroutine

24
src/GT/GTpp_phACFTD.f90
View File

@ -134,8 +134,8 @@ subroutine GTpp_phACFDT(exchange_kernel,doXBS,dRPA,TDA_T,TDA,BSE,singlet,triplet
call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,ERI,X1s,Y1s,rho1s,X2s,Y2s,rho2s) call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,ERI,X1s,Y1s,rho1s,X2s,Y2s,rho2s)
call static_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOOs,nVVs,lambda,Om1s,rho1s,Om2s,rho2s,TAs) call GTpp_static_kernel_Aph(eta,nBas,nC,nO,nV,nR,nS,nOOs,nVVs,lambda,Om1s,rho1s,Om2s,rho2s,TAs)
if(.not.TDA) call static_Tmatrix_B(eta,nBas,nC,nO,nV,nR,nS,nOOs,nVVs,lambda,Om1s,rho1s,Om2s,rho2s,TBs) if(.not.TDA) call GTpp_static_kernel_Bph(eta,nBas,nC,nO,nV,nR,nS,nOOs,nVVs,lambda,Om1s,rho1s,Om2s,rho2s,TBs)
isp_T = 2 isp_T = 2
iblock = 4 iblock = 4
@ -152,16 +152,16 @@ subroutine GTpp_phACFDT(exchange_kernel,doXBS,dRPA,TDA_T,TDA,BSE,singlet,triplet
call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,ERI,X1t,Y1t,rho1t,X2t,Y2t,rho2t) call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,ERI,X1t,Y1t,rho1t,X2t,Y2t,rho2t)
call static_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOOt,nVVt,lambda,Om1t,rho1t,Om2t,rho2t,TAt) call GTpp_static_kernel_Aph(eta,nBas,nC,nO,nV,nR,nS,nOOt,nVVt,lambda,Om1t,rho1t,Om2t,rho2t,TAt)
if(.not.TDA) call static_Tmatrix_B(eta,nBas,nC,nO,nV,nR,nS,nOOt,nVVt,lambda,Om1t,rho1t,Om2t,rho2t,TBt) if(.not.TDA) call Gtpp_static_kernel_Bph(eta,nBas,nC,nO,nV,nR,nS,nOOt,nVVt,lambda,Om1t,rho1t,Om2t,rho2t,TBt)
end if end if
call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,lambda,eGT,ERI,Aph) call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,lambda,eGT,ERI,Aph)
if(.not.TDA) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,lambda,ERI,Bph) if(.not.TDA) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,lambda,ERI,Bph)
Aph(:,:) = Aph(:,:) + TAt(:,:) + TAs(:,:) Aph(:,:) = Aph(:,:) - TAt(:,:) - TAs(:,:)
if(.not.TDA) Bph(:,:) = Bph(:,:) + TBt(:,:) + TBs(:,:) if(.not.TDA) Bph(:,:) = Bph(:,:) - TBt(:,:) - TBs(:,:)
call phLR(TDA,nS,Aph,Bph,EcAc(ispin),Om,XpY,XmY) call phLR(TDA,nS,Aph,Bph,EcAc(ispin),Om,XpY,XmY)
@ -218,8 +218,8 @@ subroutine GTpp_phACFDT(exchange_kernel,doXBS,dRPA,TDA_T,TDA,BSE,singlet,triplet
call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,ERI,X1s,Y1s,rho1s,X2s,Y2s,rho2s) call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,ERI,X1s,Y1s,rho1s,X2s,Y2s,rho2s)
call static_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOOs,nVVs,lambda,Om1s,rho1s,Om2s,rho2s,TAs) call GTpp_static_kernel_Aph(eta,nBas,nC,nO,nV,nR,nS,nOOs,nVVs,lambda,Om1s,rho1s,Om2s,rho2s,TAs)
if(.not.TDA) call static_Tmatrix_B(eta,nBas,nC,nO,nV,nR,nS,nOOs,nVVs,lambda,Om1s,rho1s,Om2s,rho2s,TBs) if(.not.TDA) call GTpp_static_kernel_Bph(eta,nBas,nC,nO,nV,nR,nS,nOOs,nVVs,lambda,Om1s,rho1s,Om2s,rho2s,TBs)
isp_T = 2 isp_T = 2
iblock = 4 iblock = 4
@ -236,16 +236,16 @@ subroutine GTpp_phACFDT(exchange_kernel,doXBS,dRPA,TDA_T,TDA,BSE,singlet,triplet
call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,ERI,X1t,Y1t,rho1t,X2t,Y2t,rho2t) call GTpp_excitation_density(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,ERI,X1t,Y1t,rho1t,X2t,Y2t,rho2t)
call static_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOOt,nVVt,lambda,Om1t,rho1t,Om2t,rho2t,TAt) call GTpp_static_kernel_Aph(eta,nBas,nC,nO,nV,nR,nS,nOOt,nVVt,lambda,Om1t,rho1t,Om2t,rho2t,TAt)
if(.not.TDA) call static_Tmatrix_B(eta,nBas,nC,nO,nV,nR,nS,nOOt,nVVt,lambda,Om1t,rho1t,Om2t,rho2t,TBt) if(.not.TDA) call GTpp_static_kernel_Bph(eta,nBas,nC,nO,nV,nR,nS,nOOt,nVVt,lambda,Om1t,rho1t,Om2t,rho2t,TBt)
end if end if
call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,lambda,eGT,ERI,Aph) call phLR_A(ispin,dRPA,nBas,nC,nO,nV,nR,nS,lambda,eGT,ERI,Aph)
if(.not.TDA) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,lambda,ERI,Bph) if(.not.TDA) call phLR_B(ispin,dRPA,nBas,nC,nO,nV,nR,nS,lambda,ERI,Bph)
Aph(:,:) = Aph(:,:) + TAt(:,:) - TAs(:,:) Aph(:,:) = Aph(:,:) + TAs(:,:) - TAt(:,:)
if(.not.TDA) Bph(:,:) = Bph(:,:) + TBt(:,:) - TBs(:,:) if(.not.TDA) Bph(:,:) = Bph(:,:) + TBs(:,:) - TBt(:,:)
call phLR(TDA,nS,Aph,Bph,EcAc(ispin),Om,XpY,XmY) call phLR(TDA,nS,Aph,Bph,EcAc(ispin),Om,XpY,XmY)

12
src/GT/GTpp_phBSE.f90
View File

@ -99,8 +99,8 @@ subroutine GTpp_phBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
deallocate(Bpp,Cpp,Dpp) deallocate(Bpp,Cpp,Dpp)
call static_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOOab,nVVab,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TAab) call GTpp_static_kernel_Aph(eta,nBas,nC,nO,nV,nR,nS,nOOab,nVVab,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TAab)
if(.not.TDA) call static_Tmatrix_B(eta,nBas,nC,nO,nV,nR,nS,nOOab,nVVab,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TBab) if(.not.TDA) call GTpp_static_kernel_Bph(eta,nBas,nC,nO,nV,nR,nS,nOOab,nVVab,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TBab)
!----------------------------------------! !----------------------------------------!
! Compute T-matrix for alpha-alpha block ! ! Compute T-matrix for alpha-alpha block !
@ -119,8 +119,8 @@ subroutine GTpp_phBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
deallocate(Bpp,Cpp,Dpp) deallocate(Bpp,Cpp,Dpp)
call static_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOOaa,nVVaa,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TAaa) call GTpp_static_kernel_Aph(eta,nBas,nC,nO,nV,nR,nS,nOOaa,nVVaa,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TAaa)
if(.not.TDA) call static_Tmatrix_B(eta,nBas,nC,nO,nV,nR,nS,nOOaa,nVVaa,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TBaa) if(.not.TDA) call GTpp_static_kernel_Bph(eta,nBas,nC,nO,nV,nR,nS,nOOaa,nVVaa,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TBaa)
!------------------! !------------------!
! Singlet manifold ! ! Singlet manifold !
@ -153,7 +153,7 @@ subroutine GTpp_phBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
else else
call Bethe_Salpeter_Tmatrix_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO,nV,nR,nS,nOOab,nVVab,nOOaa,nVVaa, & call GTpp_phBSE_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO,nV,nR,nS,nOOab,nVVab,nOOaa,nVVaa, &
Om1ab,Om2ab,Om1aa,Om2aa,rho1ab,rho2ab,rho1aa,rho2aa,eT,eGT, & Om1ab,Om2ab,Om1aa,Om2aa,rho1ab,rho2ab,rho1aa,rho2aa,eT,eGT, &
dipole_int,OmBSE,XpY_BSE,XmY_BSE,TAab,TAaa) dipole_int,OmBSE,XpY_BSE,XmY_BSE,TAab,TAaa)
end if end if
@ -193,7 +193,7 @@ subroutine GTpp_phBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
else else
call Bethe_Salpeter_Tmatrix_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO,nV,nR,nS,nOOab,nVVab,nOOaa,nVVaa, & call GTpp_phBSE_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO,nV,nR,nS,nOOab,nVVab,nOOaa,nVVaa, &
Om1ab,Om2ab,Om1aa,Om2aa,rho1ab,rho2ab,rho1aa,rho2aa,eT,eGT, & Om1ab,Om2ab,Om1aa,Om2aa,rho1ab,rho2ab,rho1aa,rho2aa,eT,eGT, &
dipole_int,OmBSE,XpY_BSE,XmY_BSE,TAab,TAaa) dipole_int,OmBSE,XpY_BSE,XmY_BSE,TAab,TAaa)
end if end if

11
src/GT/Bethe_Salpeter_Tmatrix_dynamic_perturbation.f90 → src/GT/GTpp_phBSE_dynamic_perturbation.f90
View File

@ -1,6 +1,5 @@
subroutine Bethe_Salpeter_Tmatrix_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO,nV,nR,nS,nOOab,nVVab,nOOaa,nVVaa, & subroutine GTpp_phBSE_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO,nV,nR,nS,nOOab,nVVab,nOOaa,nVVaa,Om1ab,Om2ab,Om1aa,Om2aa, &
Om1ab,Om2ab,Om1aa,Om2aa,rho1ab,rho2ab,rho1aa,rho2aa,eT,eGT, & rho1ab,rho2ab,rho1aa,rho2aa,eT,eGT,dipole_int,OmBSE,XpY,XmY,TAab,TAaa)
dipole_int,OmBSE,XpY,XmY,TAab,TAaa)
! Compute dynamical effects via perturbation theory for BSE@GT ! Compute dynamical effects via perturbation theory for BSE@GT
@ -82,11 +81,11 @@ subroutine Bethe_Salpeter_Tmatrix_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO
! Compute dynamical T-matrix for alpha-beta block ! Compute dynamical T-matrix for alpha-beta block
call dynamic_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOOab,nVVab,1d0,eGT,Om1ab,Om2ab,rho1ab,rho2ab,OmBSE(ia),dTAab,ZAab) call GTpp_dynamic_kernel_Aph(eta,nBas,nC,nO,nV,nR,nS,nOOab,nVVab,1d0,eGT,Om1ab,Om2ab,rho1ab,rho2ab,OmBSE(ia),dTAab,ZAab)
! Compute dynamical T-matrix for alpha-beta block ! Compute dynamical T-matrix for alpha-beta block
call dynamic_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOOaa,nVVaa,1d0,eGT,Om1aa,Om2aa,rho1aa,rho2aa,OmBSE(ia),dTAaa,ZAaa) call GTpp_dynamic_kernel_Aph(eta,nBas,nC,nO,nV,nR,nS,nOOaa,nVVaa,1d0,eGT,Om1aa,Om2aa,rho1aa,rho2aa,OmBSE(ia),dTAaa,ZAaa)
X(:) = 0.5d0*(XpY(ia,:) + XmY(ia,:)) X(:) = 0.5d0*(XpY(ia,:) + XmY(ia,:))
Y(:) = 0.5d0*(XpY(ia,:) - XmY(ia,:)) Y(:) = 0.5d0*(XpY(ia,:) - XmY(ia,:))
@ -130,4 +129,4 @@ subroutine Bethe_Salpeter_Tmatrix_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO
write(*,*) '---------------------------------------------------------------------------------------------------' write(*,*) '---------------------------------------------------------------------------------------------------'
write(*,*) write(*,*)
end subroutine Bethe_Salpeter_Tmatrix_dynamic_perturbation end subroutine

97
src/GT/GTpp_ppBSE.f90
View File

@ -62,6 +62,7 @@ subroutine GTpp_ppBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
integer :: nVVt integer :: nVVt
double precision :: EcRPA(nspin) double precision :: EcRPA(nspin)
double precision,allocatable :: Bpp(:,:),Cpp(:,:),Dpp(:,:)
double precision,allocatable :: TBab(:,:),TCab(:,:),TDab(:,:) double precision,allocatable :: TBab(:,:),TCab(:,:),TDab(:,:)
double precision,allocatable :: TBaa(:,:),TCaa(:,:),TDaa(:,:) double precision,allocatable :: TBaa(:,:),TCaa(:,:),TDaa(:,:)
@ -94,30 +95,41 @@ subroutine GTpp_ppBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
iblock = 3 iblock = 3
EcRPA(ispin) = 0d0 allocate(Bpp(nVVab,nOOab),Cpp(nVVab,nVVab),Dpp(nOOab,nOOab))
call ppLR(iblock,TDA_T,nBas,nC,nO,nV,nR,nOOab,nVVab,1d0,eT,ERI,Om1ab,X1ab,Y1ab,Om2ab,X2ab,Y2ab,EcRPA(ispin)) if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOab,nVVab,1d0,ERI,Bpp)
call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVab,1d0,eT,ERI,Cpp)
call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOab,1d0,eT,ERI,Dpp)
call ppLR(TDA_T,nOOab,nVVab,Bpp,Cpp,Dpp,Om1ab,X1ab,Y1ab,Om2ab,X2ab,Y2ab,EcRPA(ispin))
deallocate(Bpp,Cpp,Dpp)
allocate(TBab(nVVs,nOOs),TCab(nVVs,nVVs),TDab(nOOs,nOOs)) allocate(TBab(nVVs,nOOs),TCab(nVVs,nVVs),TDab(nOOs,nOOs))
if(.not.TDA) call static_Tmatrix_B_pp(ispin,eta,nBas,nC,nO,nV,nR,nOOab,nVVab,nOOs,nVVs,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TBab) if(.not.TDA_T) call GTpp_static_kernel_Bpp(ispin,eta,nBas,nC,nO,nV,nR,nOOab,nVVab,nOOs,nVVs,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TBab)
call static_Tmatrix_C_pp(ispin,eta,nBas,nC,nO,nV,nR,nOOab,nVVab,nOOs,nVVs,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TCab) call GTpp_static_kernel_Cpp(ispin,eta,nBas,nC,nO,nV,nR,nOOab,nVVab,nOOs,nVVs,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TCab)
call static_Tmatrix_D_pp(ispin,eta,nBas,nC,nO,nV,nR,nOOab,nVVab,nOOs,nVVs,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TDab) call GTpp_static_kernel_Dpp(ispin,eta,nBas,nC,nO,nV,nR,nOOab,nVVab,nOOs,nVVs,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TDab)
!----------------------------------------! !----------------------------------------!
! Compute T-matrix for alpha-alpha block ! ! Compute T-matrix for alpha-alpha block !
!----------------------------------------! !----------------------------------------!
iblock = 4 iblock = 4
EcRPA(ispin) = 0d0
call ppLR(iblock,TDA_T,nBas,nC,nO,nV,nR,nOOaa,nVVaa,1d0,eT,ERI,Om1aa,X1aa,Y1aa,Om2aa,X2aa,Y2aa,EcRPA(ispin)) allocate(Bpp(nVVaa,nOOaa),Cpp(nVVaa,nVVaa),Dpp(nOOaa,nOOaa))
if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOaa,nVVaa,1d0,ERI,Bpp)
call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVaa,1d0,eT,ERI,Cpp)
call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOaa,1d0,eT,ERI,Dpp)
call ppLR(TDA_T,nOOaa,nVVaa,Bpp,Cpp,Dpp,Om1aa,X1aa,Y1aa,Om2aa,X2aa,Y2aa,EcRPA(ispin))
deallocate(Bpp,Cpp,Dpp)
allocate(TBaa(nVVs,nOOs),TCaa(nVVs,nVVs),TDaa(nOOs,nOOs)) allocate(TBaa(nVVs,nOOs),TCaa(nVVs,nVVs),TDaa(nOOs,nOOs))
if(.not.TDA) call static_Tmatrix_B_pp(ispin,eta,nBas,nC,nO,nV,nR,nOOaa,nVVaa,nOOs,nVVs,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TBaa) if(.not.TDA_T) call GTpp_static_kernel_Bpp(ispin,eta,nBas,nC,nO,nV,nR,nOOaa,nVVaa,nOOs,nVVs,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TBaa)
call static_Tmatrix_C_pp(ispin,eta,nBas,nC,nO,nV,nR,nOOaa,nVVaa,nOOs,nVVs,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TCaa) call GTpp_static_kernel_Cpp(ispin,eta,nBas,nC,nO,nV,nR,nOOaa,nVVaa,nOOs,nVVs,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TCaa)
call static_Tmatrix_D_pp(ispin,eta,nBas,nC,nO,nV,nR,nOOaa,nVVaa,nOOs,nVVs,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TDaa) call GTpp_static_kernel_Dpp(ispin,eta,nBas,nC,nO,nV,nR,nOOaa,nVVaa,nOOs,nVVs,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TDaa)
!----------------------------------! !----------------------------------!
! pp/hh sectors for singlet states ! ! pp/hh sectors for singlet states !
@ -125,14 +137,22 @@ subroutine GTpp_ppBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
EcBSE(ispin) = 0d0 EcBSE(ispin) = 0d0
allocate(Om1s(nVVs),X1s(nVVs,nVVs),Y1s(nOOs,nVVs),Om2s(nOOs),X2s(nVVs,nOOs),Y2s(nOOs,nOOs)) allocate(Om1s(nVVs),X1s(nVVs,nVVs),Y1s(nOOs,nVVs),Om2s(nOOs),X2s(nVVs,nOOs),Y2s(nOOs,nOOs), &
Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs))
call linear_response_pp_BSE(ispin,TDA,.true.,nBas,nC,nO,nV,nR,nOOs,nVVs,1d0,eGT,ERI, & if(.not.TDA) call ppLR_B(ispin,nBas,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp)
TBaa+TBab,TCaa+TCab,TDaa+TDab,Om1s,X1s,Y1s,Om2s,X2s,Y2s,EcBSE(ispin)) call ppLR_C(ispin,nBas,nC,nO,nV,nR,nVVs,1d0,eGT,ERI,Cpp)
call ppLR_D(ispin,nBas,nC,nO,nV,nR,nOOs,1d0,eGT,ERI,Dpp)
Bpp(:,:) = Bpp(:,:) - TBab(:,:) - TBaa(:,:)
Cpp(:,:) = Cpp(:,:) - TCab(:,:) - TCaa(:,:)
Dpp(:,:) = Dpp(:,:) - TDab(:,:) - TDaa(:,:)
call ppLR(TDA,nOOs,nVVs,Bpp,Cpp,Dpp,Om1s,X1s,Y1s,Om2s,X2s,Y2s,EcBSE(ispin))
call print_transition_vectors_pp(.true.,nBas,nC,nO,nV,nR,nOOs,nVVs,dipole_int,Om1s,X1s,Y1s,Om2s,X2s,Y2s) call print_transition_vectors_pp(.true.,nBas,nC,nO,nV,nR,nOOs,nVVs,dipole_int,Om1s,X1s,Y1s,Om2s,X2s,Y2s)
deallocate(Om1s,X1s,Y1s,Om2s,X2s,Y2s,TBab,TCab,TDab,TBaa,TCaa,TDaa) deallocate(Om1s,X1s,Y1s,Om2s,X2s,Y2s,TBab,TCab,TDab,TBaa,TCaa,TDaa,Bpp,Cpp,Dpp)
end if end if
@ -152,32 +172,42 @@ subroutine GTpp_ppBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
!---------------------------------------! !---------------------------------------!
iblock = 3 iblock = 3
EcRPA(ispin) = 0d0
call ppLR(iblock,TDA_T,nBas,nC,nO,nV,nR,nOOab,nVVab,1d0,eT,ERI,Om1ab,X1ab,Y1ab,Om2ab,X2ab,Y2ab,EcRPA(ispin)) allocate(Bpp(nVVab,nOOab),Cpp(nVVab,nVVab),Dpp(nOOab,nOOab))
if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOab,nVVab,1d0,ERI,Bpp)
call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVab,1d0,eT,ERI,Cpp)
call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOab,1d0,eT,ERI,Dpp)
call ppLR(TDA_T,nOOab,nVVab,Bpp,Cpp,Dpp,Om1ab,X1ab,Y1ab,Om2ab,X2ab,Y2ab,EcRPA(ispin))
deallocate(Bpp,Cpp,Dpp)
allocate(TBab(nVVt,nOOt),TCab(nVVt,nVVt),TDab(nOOt,nOOt)) allocate(TBab(nVVt,nOOt),TCab(nVVt,nVVt),TDab(nOOt,nOOt))
if(.not.TDA) call static_Tmatrix_B_pp(ispin,eta,nBas,nC,nO,nV,nR,nOOab,nVVab,nOOt,nVVt,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TBab) if(.not.TDA_T) call GTpp_static_kernel_Bpp(ispin,eta,nBas,nC,nO,nV,nR,nOOab,nVVab,nOOt,nVVt,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TBab)
call static_Tmatrix_C_pp(ispin,eta,nBas,nC,nO,nV,nR,nOOab,nVVab,nOOt,nVVt,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TCab) call GTpp_static_kernel_Cpp(ispin,eta,nBas,nC,nO,nV,nR,nOOab,nVVab,nOOt,nVVt,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TCab)
call static_Tmatrix_D_pp(ispin,eta,nBas,nC,nO,nV,nR,nOOab,nVVab,nOOt,nVVt,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TDab) call GTpp_static_kernel_Dpp(ispin,eta,nBas,nC,nO,nV,nR,nOOab,nVVab,nOOt,nVVt,1d0,Om1ab,rho1ab,Om2ab,rho2ab,TDab)
!----------------------------------------! !----------------------------------------!
! Compute T-matrix for alpha-alpha block ! ! Compute T-matrix for alpha-alpha block !
!----------------------------------------! !----------------------------------------!
ispin = 2
iblock = 4 iblock = 4
EcRPA(ispin) = 0d0 allocate(Bpp(nVVaa,nOOaa),Cpp(nVVaa,nVVaa),Dpp(nOOaa,nOOaa))
call ppLR(iblock,TDA_T,nBas,nC,nO,nV,nR,nOOaa,nVVaa,1d0,eT,ERI,Om1aa,X1aa,Y1aa,Om2aa,X2aa,Y2aa,EcRPA(ispin)) if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOaa,nVVaa,1d0,ERI,Bpp)
call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVaa,1d0,eT,ERI,Cpp)
call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOaa,1d0,eT,ERI,Dpp)
call ppLR(TDA_T,nOOaa,nVVaa,Bpp,Cpp,Dpp,Om1aa,X1aa,Y1aa,Om2aa,X2aa,Y2aa,EcRPA(ispin))
deallocate(Bpp,Cpp,Dpp)
allocate(TBaa(nVVt,nOOt),TCaa(nVVt,nVVt),TDaa(nOOt,nOOt)) allocate(TBaa(nVVt,nOOt),TCaa(nVVt,nVVt),TDaa(nOOt,nOOt))
if(.not.TDA) call static_Tmatrix_B_pp(ispin,eta,nBas,nC,nO,nV,nR,nOOaa,nVVaa,nOOt,nVVt,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TBaa) if(.not.TDA_T) call GTpp_static_kernel_Bpp(ispin,eta,nBas,nC,nO,nV,nR,nOOaa,nVVaa,nOOt,nVVt,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TBaa)
call static_Tmatrix_C_pp(ispin,eta,nBas,nC,nO,nV,nR,nOOaa,nVVaa,nOOt,nVVt,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TCaa) call GTpp_static_kernel_Cpp(ispin,eta,nBas,nC,nO,nV,nR,nOOaa,nVVaa,nOOt,nVVt,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TCaa)
call static_Tmatrix_D_pp(ispin,eta,nBas,nC,nO,nV,nR,nOOaa,nVVaa,nOOt,nVVt,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TDaa) call GTpp_static_kernel_Dpp(ispin,eta,nBas,nC,nO,nV,nR,nOOaa,nVVaa,nOOt,nVVt,1d0,Om1aa,rho1aa,Om2aa,rho2aa,TDaa)
!----------------------------------! !----------------------------------!
! pp/hh sectors for triplet states ! ! pp/hh sectors for triplet states !
@ -185,14 +215,23 @@ subroutine GTpp_ppBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
EcBSE(ispin) = 0d0 EcBSE(ispin) = 0d0
allocate(Om1t(nVVt),X1t(nVVt,nVVt),Y1t(nOOt,nVVt),Om2t(nOOt),X2t(nVVt,nOOt),Y2t(nOOt,nOOt)) allocate(Om1t(nVVt),X1t(nVVt,nVVt),Y1t(nOOt,nVVt),Om2t(nOOt),X2t(nVVt,nOOt),Y2t(nOOt,nOOt), &
Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt))
call linear_response_pp_BSE(ispin,TDA,.true.,nBas,nC,nO,nV,nR,nOOt,nVVt,1d0,eGT,ERI, &
TBaa-TBab,TCaa-TCab,TDaa-TDab,Om1t,X1t,Y1t,Om2t,X2t,Y2t,EcBSE(ispin)) if(.not.TDA) call ppLR_B(ispin,nBas,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp)
call ppLR_C(ispin,nBas,nC,nO,nV,nR,nVVs,1d0,eGT,ERI,Cpp)
call ppLR_D(ispin,nBas,nC,nO,nV,nR,nOOs,1d0,eGT,ERI,Dpp)
Bpp(:,:) = Bpp(:,:) + TBab(:,:) - TBaa(:,:)
Cpp(:,:) = Cpp(:,:) + TCab(:,:) - TCaa(:,:)
Dpp(:,:) = Dpp(:,:) + TDab(:,:) - TDaa(:,:)
call ppLR(TDA,nOOs,nVVs,Bpp,Cpp,Dpp,Om1s,X1s,Y1s,Om2s,X2s,Y2s,EcBSE(ispin))
call print_transition_vectors_pp(.false.,nBas,nC,nO,nV,nR,nOOt,nVVt,dipole_int,Om1t,X1t,Y1t,Om2t,X2t,Y2t) call print_transition_vectors_pp(.false.,nBas,nC,nO,nV,nR,nOOt,nVVt,dipole_int,Om1t,X1t,Y1t,Om2t,X2t,Y2t)
deallocate(Om1t,X1t,Y1t,Om2t,X2t,Y2t,TBab,TCab,TDab,TBaa,TCaa,TDaa) deallocate(Om1t,X1t,Y1t,Om2t,X2t,Y2t,TBab,TCab,TDab,TBaa,TCaa,TDaa,Bpp,Cpp,Dpp)
end if end if

12
src/GT/static_Tmatrix_A.f90 → src/GT/GTpp_static_kernel_Aph.f90
View File

@ -1,4 +1,4 @@
subroutine static_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,Omega1,rho1,Omega2,rho2,TA) subroutine GTpp_static_kernel_Aph(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,Omega1,rho1,Omega2,rho2,KA)
! Compute the OOVV block of the static T-matrix ! Compute the OOVV block of the static T-matrix
@ -30,12 +30,12 @@ subroutine static_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,Omega1,rho1,O
! Output variables ! Output variables
double precision,intent(out) :: TA(nS,nS) double precision,intent(out) :: KA(nS,nS)
TA(:,:) = 0d0 KA(:,:) = 0d0
jb = 0 jb = 0
!$omp parallel do default(private) shared(TA,Omega1,Omega2,rho1,rho2,nO,nBas,nVV,nOO,chi,eps,eta,nC,nR,lambda) !$omp parallel do default(private) shared(KA,Omega1,Omega2,rho1,rho2,nO,nBas,nVV,nOO,chi,eps,eta,nC,nR,lambda)
do j=nC+1,nO do j=nC+1,nO
do b=nO+1,nBas-nR do b=nO+1,nBas-nR
jb = (b-nO) + (j-1)*(nBas-nO) jb = (b-nO) + (j-1)*(nBas-nO)
@ -58,7 +58,7 @@ subroutine static_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,Omega1,rho1,O
chi = chi + rho2(i,b,kl)*rho2(a,j,kl)*eps/(eps**2 + eta**2) chi = chi + rho2(i,b,kl)*rho2(a,j,kl)*eps/(eps**2 + eta**2)
enddo enddo
TA(ia,jb) = lambda*chi KA(ia,jb) = lambda*chi
enddo enddo
enddo enddo
@ -67,4 +67,4 @@ subroutine static_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,Omega1,rho1,O
!$omp end parallel do !$omp end parallel do
end subroutine static_Tmatrix_A end subroutine

10
src/GT/static_Tmatrix_B.f90 → src/GT/GTpp_static_kernel_Bph.f90
View File

@ -1,4 +1,4 @@
subroutine static_Tmatrix_B(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,Omega1,rho1,Omega2,rho2,TB) subroutine GTpp_static_kernel_Bph(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,Omega1,rho1,Omega2,rho2,KB)
! Compute the OVVO block of the static T-matrix ! Compute the OVVO block of the static T-matrix
@ -30,9 +30,9 @@ subroutine static_Tmatrix_B(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,Omega1,rho1,O
! Output variables ! Output variables
double precision,intent(out) :: TB(nS,nS) double precision,intent(out) :: KB(nS,nS)
TB(:,:) = 0d0 KB(:,:) = 0d0
ia = 0 ia = 0
do i=nC+1,nO do i=nC+1,nO
@ -55,11 +55,11 @@ subroutine static_Tmatrix_B(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,Omega1,rho1,O
chi = chi + rho2(i,j,kl)*rho2(a,b,kl)*eps/(eps**2 + eta**2) chi = chi + rho2(i,j,kl)*rho2(a,b,kl)*eps/(eps**2 + eta**2)
enddo enddo
TB(ia,jb) = lambda*chi KB(ia,jb) = lambda*chi
enddo enddo
enddo enddo
enddo enddo
enddo enddo
end subroutine static_Tmatrix_B end subroutine

4
src/GT/static_Tmatrix_B_pp.f90 → src/GT/GTpp_static_kernel_Bpp.f90
View File

@ -1,4 +1,4 @@
subroutine static_Tmatrix_B_pp(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,nVVx,lambda,Om1,rho1,Om2,rho2,TB) subroutine GTpp_static_kernel_Bpp(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,nVVx,lambda,Om1,rho1,Om2,rho2,TB)
! Compute the VVOO block of the static T-matrix ! Compute the VVOO block of the static T-matrix
@ -148,4 +148,4 @@ subroutine static_Tmatrix_B_pp(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,nVVx,lamb
end if end if
end subroutine static_Tmatrix_B_pp end subroutine

4
src/GT/static_Tmatrix_C_pp.f90 → src/GT/GTpp_static_kernel_Cpp.f90
View File

@ -1,4 +1,4 @@
subroutine static_Tmatrix_C_pp(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,nVVx,lambda,Om1,rho1,Om2,rho2,TC) subroutine GTpp_static_kernel_Cpp(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,nVVx,lambda,Om1,rho1,Om2,rho2,TC)
! Compute the VVVV block of the static T-matrix ! Compute the VVVV block of the static T-matrix
@ -151,4 +151,4 @@ subroutine static_Tmatrix_C_pp(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,nVVx,lamb
end if end if
end subroutine static_Tmatrix_C_pp end subroutine

4
src/GT/static_Tmatrix_D_pp.f90 → src/GT/GTpp_static_kernel_Dpp.f90
View File

@ -1,4 +1,4 @@
subroutine static_Tmatrix_D_pp(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,nVVx,lambda,Om1,rho1,Om2,rho2,TD) subroutine GTpp_static_kernel_Dpp(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,nVVx,lambda,Om1,rho1,Om2,rho2,TD)
! Compute the OOOO block of the static T-matrix ! Compute the OOOO block of the static T-matrix
@ -149,4 +149,4 @@ subroutine static_Tmatrix_D_pp(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,nVVx,lamb
end if end if
end subroutine static_Tmatrix_D_pp end subroutine

8
src/GT/evGTpp.f90
View File

@ -138,8 +138,8 @@ subroutine evGTpp(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,BSE,TDA_T
allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs)) allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs))
if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI_MO,Bpp) if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI_MO,Bpp)
call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVs,1d0,eHF,ERI_MO,Cpp) call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVs,1d0,eGT,ERI_MO,Cpp)
call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOs,1d0,eHF,ERI_MO,Dpp) call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOs,1d0,eGT,ERI_MO,Dpp)
call ppLR(TDA_T,nOOs,nVVs,Bpp,Cpp,Dpp,Om1s,X1s,Y1s,Om2s,X2s,Y2s,EcRPA(ispin)) call ppLR(TDA_T,nOOs,nVVs,Bpp,Cpp,Dpp,Om1s,X1s,Y1s,Om2s,X2s,Y2s,EcRPA(ispin))
@ -157,8 +157,8 @@ subroutine evGTpp(maxSCF,thresh,max_diis,doACFDT,exchange_kernel,doXBS,BSE,TDA_T
allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt)) allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt))
if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI_MO,Bpp) if(.not.TDA_T) call ppLR_B(iblock,nBas,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI_MO,Bpp)
call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVt,1d0,eHF,ERI_MO,Cpp) call ppLR_C(iblock,nBas,nC,nO,nV,nR,nVVt,1d0,eGT,ERI_MO,Cpp)
call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOt,1d0,eHF,ERI_MO,Dpp) call ppLR_D(iblock,nBas,nC,nO,nV,nR,nOOt,1d0,eGT,ERI_MO,Dpp)
call ppLR(TDA_T,nOOt,nVVt,Bpp,Cpp,Dpp,Om1t,X1t,Y1t,Om2t,X2t,Y2t,EcRPA(ispin)) call ppLR(TDA_T,nOOt,nVVt,Bpp,Cpp,Dpp,Om1t,X1t,Y1t,Om2t,X2t,Y2t,EcRPA(ispin))

41
src/GW/GW_ppBSE.f90
View File

@ -47,6 +47,10 @@ subroutine GW_ppBSE(TDA_W,TDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI,dipole
double precision,allocatable :: XmY_RPA(:,:) double precision,allocatable :: XmY_RPA(:,:)
double precision,allocatable :: rho_RPA(:,:,:) double precision,allocatable :: rho_RPA(:,:,:)
double precision,allocatable :: Bpp(:,:)
double precision,allocatable :: Cpp(:,:)
double precision,allocatable :: Dpp(:,:)
double precision,allocatable :: Om1(:) double precision,allocatable :: Om1(:)
double precision,allocatable :: X1(:,:) double precision,allocatable :: X1(:,:)
double precision,allocatable :: Y1(:,:) double precision,allocatable :: Y1(:,:)
@ -91,30 +95,35 @@ subroutine GW_ppBSE(TDA_W,TDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI,dipole
write(*,*) write(*,*)
ispin = 1 ispin = 1
EcBSE(ispin) = 0d0
nOO = nO*(nO+1)/2 nOO = nO*(nO+1)/2
nVV = nV*(nV+1)/2 nVV = nV*(nV+1)/2
allocate(Om1(nVV),X1(nVV,nVV),Y1(nOO,nVV), & allocate(Om1(nVV),X1(nVV,nVV),Y1(nOO,nVV), &
Om2(nOO),X2(nVV,nOO),Y2(nOO,nOO), & Om2(nOO),X2(nVV,nOO),Y2(nOO,nOO), &
Bpp(nVV,nOO),Cpp(nVV,nVV),Dpp(nOO,nOO), &
WB(nVV,nOO),WC(nVV,nVV),WD(nOO,nOO)) WB(nVV,nOO),WC(nVV,nVV),WD(nOO,nOO))
! Compute BSE excitation energies
if(.not.TDA) call static_screening_WB_pp(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,WB) if(.not.TDA) call static_screening_WB_pp(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,WB)
call static_screening_WC_pp(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,WC) call static_screening_WC_pp(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,WC)
call static_screening_WD_pp(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,WD) call static_screening_WD_pp(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,WD)
! Compute BSE excitation energies
call linear_response_pp_BSE(ispin,TDA,dRPA,nBas,nC,nO,nV,nR,nOO,nVV,1d0,eGW,ERI,WB,WC,WD, & if(.not.TDA) call ppLR_B(ispin,nBas,nC,nO,nV,nR,nOO,nVV,1d0,ERI,Bpp)
Om1,X1,Y1,Om2,X2,Y2,EcBSE(ispin)) call ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,1d0,eGW,ERI,Cpp)
call ppLR_D(ispin,nBas,nC,nO,nV,nR,nOO,1d0,eGW,ERI,Dpp)
! call print_excitation('pp-BSE (N+2)',ispin,nVV,Om1) Bpp(:,:) = Bpp(:,:) + WB(:,:)
! call print_excitation('pp-BSE (N-2)',ispin,nOO,Om2) Cpp(:,:) = Cpp(:,:) + WC(:,:)
Dpp(:,:) = Dpp(:,:) + WD(:,:)
call ppLR(TDA,nOO,nVV,Bpp,Cpp,Dpp,Om1,X1,Y1,Om2,X2,Y2,EcBSE(ispin))
call print_transition_vectors_pp(.true.,nBas,nC,nO,nV,nR,nOO,nVV,dipole_int,Om1,X1,Y1,Om2,X2,Y2) call print_transition_vectors_pp(.true.,nBas,nC,nO,nV,nR,nOO,nVV,dipole_int,Om1,X1,Y1,Om2,X2,Y2)
deallocate(Om1,X1,Y1,Om2,X2,Y2,WB,WC,WD) deallocate(Om1,X1,Y1,Om2,X2,Y2,Bpp,Cpp,Dpp,WB,WC,WD)
end if end if
@ -137,23 +146,29 @@ subroutine GW_ppBSE(TDA_W,TDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,nS,ERI,dipole
allocate(Om1(nVV),X1(nVV,nVV),Y1(nOO,nVV), & allocate(Om1(nVV),X1(nVV,nVV),Y1(nOO,nVV), &
Om2(nOO),X2(nVV,nOO),Y2(nOO,nOO), & Om2(nOO),X2(nVV,nOO),Y2(nOO,nOO), &
Bpp(nVV,nOO),Cpp(nVV,nVV),Dpp(nOO,nOO), &
WB(nVV,nOO),WC(nVV,nVV),WD(nOO,nOO)) WB(nVV,nOO),WC(nVV,nVV),WD(nOO,nOO))
! Compute BSE excitation energies
if(.not.TDA) call static_screening_WB_pp(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,WB) if(.not.TDA) call static_screening_WB_pp(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,WB)
call static_screening_WC_pp(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,WC) call static_screening_WC_pp(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,WC)
call static_screening_WD_pp(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,WD) call static_screening_WD_pp(ispin,eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,1d0,ERI,OmRPA,rho_RPA,WD)
! Compute BSE excitation energies
call linear_response_pp_BSE(ispin,TDA,dRPA,nBas,nC,nO,nV,nR,nOO,nVV,1d0,eGW,ERI,WB,WC,WD, & if(.not.TDA) call ppLR_B(ispin,nBas,nC,nO,nV,nR,nOO,nVV,1d0,ERI,Bpp)
Om1,X1,Y1,Om2,X2,Y2,EcBSE(ispin)) call ppLR_C(ispin,nBas,nC,nO,nV,nR,nVV,1d0,eGW,ERI,Cpp)
call ppLR_D(ispin,nBas,nC,nO,nV,nR,nOO,1d0,eGW,ERI,Dpp)
! call print_excitation('pp-BSE (N+2)',ispin,nVV,Om1) Bpp(:,:) = Bpp(:,:) + WB(:,:)
! call print_excitation('pp-BSE (N-2)',ispin,nOO,Om2) Cpp(:,:) = Cpp(:,:) + WC(:,:)
Dpp(:,:) = Dpp(:,:) + WD(:,:)
call ppLR(TDA,nOO,nVV,Bpp,Cpp,Dpp,Om1,X1,Y1,Om2,X2,Y2,EcBSE(ispin))
call print_transition_vectors_pp(.false.,nBas,nC,nO,nV,nR,nOO,nVV,dipole_int,Om1,X1,Y1,Om2,X2,Y2) call print_transition_vectors_pp(.false.,nBas,nC,nO,nV,nR,nOO,nVV,dipole_int,Om1,X1,Y1,Om2,X2,Y2)
deallocate(Om1,X1,Y1,Om2,X2,Y2,WB,WC,WD) deallocate(Om1,X1,Y1,Om2,X2,Y2,Bpp,Cpp,Dpp,WB,WC,WD)
end if end if

121
src/LR/linear_response_pp_BSE.f90
View File

@ -1,121 +0,0 @@
subroutine linear_response_pp_BSE(ispin,TDA,BSE,nBas,nC,nO,nV,nR,nOO,nVV,lambda,e,ERI,WB,WC,WD,Omega1,X1,Y1,Omega2,X2,Y2,EcBSE)
! Compute the p-p channel of BSE
implicit none
include 'parameters.h'
! Input variables
integer,intent(in) :: ispin
logical,intent(in) :: TDA
logical,intent(in) :: BSE
integer,intent(in) :: nBas
integer,intent(in) :: nC
integer,intent(in) :: nO
integer,intent(in) :: nV
integer,intent(in) :: nR
integer,intent(in) :: nOO
integer,intent(in) :: nVV
double precision,intent(in) :: lambda
double precision,intent(in) :: e(nBas)
double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas)
double precision,intent(in) :: WB(nVV,nOO)
double precision,intent(in) :: WC(nVV,nVV)
double precision,intent(in) :: WD(nOO,nOO)
! Local variables
integer :: ab,cd,ij,kl
integer :: p,q,r,s
double precision :: trace_matrix
double precision :: EcBSE1
double precision :: EcBSE2
double precision,allocatable :: B(:,:)
double precision,allocatable :: C(:,:)
double precision,allocatable :: D(:,:)
double precision,allocatable :: M(:,:)
double precision,allocatable :: Z(:,:)
double precision,allocatable :: Omega(:)
! Output variables
double precision,intent(out) :: Omega1(nVV)
double precision,intent(out) :: X1(nVV,nVV)
double precision,intent(out) :: Y1(nOO,nVV)
double precision,intent(out) :: Omega2(nOO)
double precision,intent(out) :: X2(nVV,nOO)
double precision,intent(out) :: Y2(nOO,nOO)
double precision,intent(out) :: EcBSE
! Memory allocation
allocate(B(nVV,nOO),C(nVV,nVV),D(nOO,nOO),M(nOO+nVV,nOO+nVV),Z(nOO+nVV,nOO+nVV),Omega(nOO+nVV))
!-------------------------------------------------!
! Solve the p-p eigenproblem !
!-------------------------------------------------!
! !
! | C B | | X1 X2 | | w1 0 | | X1 X2 | !
! | | | | = | | | | !
! | -Bt -D | | Y1 Y2 | | 0 w2 | | Y1 Y2 | !
! !
!-------------------------------------------------!
! Build B, C and D matrices for the pp channel
call ppLR_C(ispin,nBas,nC,nO,nV,nR,nOO,nVV,lambda,e,ERI,C)
call ppLR_D(ispin,nBas,nC,nO,nV,nR,nOO,nVV,lambda,e,ERI,D)
if(BSE) then
C(:,:) = C(:,:) - WC(:,:)
D(:,:) = D(:,:) - WD(:,:)
end if
if(TDA) then
X1(:,:) = +C(:,:)
Y1(:,:) = 0d0
if(nVV > 0) call diagonalize_matrix(nVV,X1,Omega1)
X2(:,:) = 0d0
Y2(:,:) = -D(:,:)
if(nOO > 0) call diagonalize_matrix(nOO,Y2,Omega2)
else
call ppLR_B(ispin,nBas,nC,nO,nV,nR,nOO,nVV,lambda,ERI,B)
if(BSE) B(:,:) = B(:,:) - WB(:,:)
! Diagonal blocks
M( 1:nVV , 1:nVV) = + C(1:nVV,1:nVV)
M(nVV+1:nVV+nOO,nVV+1:nVV+nOO) = - D(1:nOO,1:nOO)
! Off-diagonal blocks
M( 1:nVV ,nVV+1:nOO+nVV) = - B(1:nVV,1:nOO)
M(nVV+1:nOO+nVV, 1:nVV) = + transpose(B(1:nVV,1:nOO))
! Diagonalize the p-p matrix
if(nOO+nVV > 0) call diagonalize_general_matrix(nOO+nVV,M,Omega,Z)
! Split the various quantities in p-p and h-h parts
call sort_ppRPA(nOO,nVV,Omega,Z,Omega1,X1,Y1,Omega2,X2,Y2)
end if
! Compute the BSE correlation energy
EcBSE = 0.5d0*( sum(Omega1(:)) - sum(Omega2(:)) - trace_matrix(nVV,C(:,:)) - trace_matrix(nOO,D(:,:)) )
EcBSE1 = +sum(Omega1(:)) - trace_matrix(nVV,C(:,:))
EcBSE2 = -sum(Omega2(:)) - trace_matrix(nOO,D(:,:))
if(abs(EcBSE - EcBSE1) > 1d-6 .or. abs(EcBSE - EcBSE2) > 1d-6) &
print*,'!!! Issue in pp-BSE linear reponse calculation BSE1 != BSE2 !!!'
end subroutine