PTEROSOR/QuAcK
10
1
Fork 0
mirror of https://github.com/pfloos/quack synced 2024-12-22 12:23:42 +01:00
Code Releases Activity

T matrix kernel of the ppBSE working in TDA in RHF and GHF

Browse Source
This commit is contained in:
Antoine Marie 2024-10-31 16:07:25 +01:00
parent 127aeabf72
commit 5b5d3376c9
5 changed files with 51 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
src/GT/GGT_Tmatrix.f90
View File

@ -25,7 +25,6 @@ subroutine GGT_Tmatrix(nOrb,nC,nO,nV,nR,nOO,nVV,lambda,ERI,eGF,Om1,rho1,Om2,rho2
! Local variables
integer :: p,q,r,s
integer :: c,d,k,l
integer :: kl,cd
! Output variables
@ -38,8 +37,8 @@ subroutine GGT_Tmatrix(nOrb,nC,nO,nV,nR,nOO,nVV,lambda,ERI,eGF,Om1,rho1,Om2,rho2
! Start by building the tensor elements of T
! This is probabbly not a good idea because this tensor is really large
!$OMP PARALLEL &
!$OMP SHARED(nC,nO,nOrb,nR,T,ERI,rho1,rho2,Om1,Om2) &
!$OMP PRIVATE(p,q,r,s,c,d,cd,k,l,kl) &
!$OMP SHARED(nC,nO,nOrb,nR,nOO,nVV,T,ERI,rho1,rho2,Om1,Om2) &
!$OMP PRIVATE(p,q,r,s,cd,kl) &
!$OMP DEFAULT(NONE)
!$OMP DO
do s=nC+1,nOrb-nR
@ -49,25 +48,13 @@ subroutine GGT_Tmatrix(nOrb,nC,nO,nV,nR,nOO,nVV,lambda,ERI,eGF,Om1,rho1,Om2,rho2
T(p,q,r,s) = ERI(p,q,r,s) - ERI(p,q,s,r)
cd = 0
do c=nO+1,nOrb-nR
do d=c+1,nOrb-nR
cd = cd + 1
do cd=1,nVV
T(p,q,r,s) = T(p,q,r,s) - rho1(p,q,cd)*rho1(r,s,cd)/Om1(cd)
end do
T(p,q,r,s) = T(p,q,r,s) - rho1(p,q,cd)*rho1(r,s,cd)/Om1(cd)
end do ! d
end do ! c
kl = 0
do k=nC+1,nO
do l=k+1,nO
kl = kl + 1
T(p,q,r,s) = T(p,q,r,s) + rho2(p,q,kl)*rho2(r,s,kl)/Om2(kl)
enddo
enddo
do kl=1,nOO
T(p,q,r,s) = T(p,q,r,s) + rho2(p,q,kl)*rho2(r,s,kl)/Om2(kl)
end do
enddo
enddo

2
src/GT/GGTpp_ppBSE.f90
View File

@ -91,9 +91,9 @@ subroutine GGTpp_ppBSE(TDA_T,TDA,dBSE,dTDA,eta,nOrb,nC,nO,nV,nR,nOO,nVV,ERI,dipo
allocate(KB_sta(nVV,nOO),KC_sta(nVV,nVV),KD_sta(nOO,nOO))
if(.not.TDA) call GGTpp_ppBSE_static_kernel_B(eta,nOrb,nC,nO,nV,nR,nOO,nVV,1d0,ERI,eGT,Om1,rho1,Om2,rho2,T,KB_sta)
call GGTpp_ppBSE_static_kernel_C(eta,nOrb,nC,nO,nV,nR,nOO,nVV,1d0,ERI,eGT,Om1,rho1,Om2,rho2,T,KC_sta)
call GGTpp_ppBSE_static_kernel_D(eta,nOrb,nC,nO,nV,nR,nOO,nVV,1d0,ERI,eGT,Om1,rho1,Om2,rho2,T,KD_sta)
if(.not.TDA) call GGTpp_ppBSE_static_kernel_B(eta,nOrb,nC,nO,nV,nR,nOO,nVV,1d0,ERI,eGT,Om1,rho1,Om2,rho2,T,KB_sta)
deallocate(Om1,Om2,rho1,rho2)
! Deallocate the 4-tensor T

113
src/GT/RGT_Tmatrix.f90
View File

@ -46,8 +46,8 @@ subroutine RGT_Tmatrix(isp_T,nBas,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,lambda,ERI,Om1
if(isp_T == 1) then
!$OMP PARALLEL &
!$OMP SHARED(nC,nO,nBas,nR,T,ERI,rho1t,rho2t,Om1t,Om2t) &
!$OMP PRIVATE(p,q,r,s,c,d,cd,k,l,kl) &
!$OMP SHARED(nC,nO,nBas,nR,T,ERI,nOOt,nVVt,rho1t,rho2t,Om1t,Om2t) &
!$OMP PRIVATE(p,q,r,s,cd,kl) &
!$OMP DEFAULT(NONE)
!$OMP DO
do s=nC+1,nBas-nR
@ -57,21 +57,13 @@ subroutine RGT_Tmatrix(isp_T,nBas,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,lambda,ERI,Om1
T(p,q,r,s) = ERI(p,q,r,s) - ERI(p,q,s,r)
cd = 0
do c=nO+1,nBas-nR
do d=c+1,nBas-nR
cd = cd + 1
T(p,q,r,s) = T(p,q,r,s) - rho1t(p,q,cd) * rho1t(r,s,cd) / Om1t(cd)
end do ! d
end do ! c
do cd=1,nVVt
T(p,q,r,s) = T(p,q,r,s) - rho1t(p,q,cd) * rho1t(r,s,cd) / Om1t(cd)
end do ! cd
kl = 0
do k=nC+1,nO
do l=k+1,nO
kl = kl + 1
T(p,q,r,s) = T(p,q,r,s) + rho2t(p,q,kl) * rho2t(r,s,kl) / Om2t(kl)
enddo ! l
enddo ! k
do kl=1,nOOt
T(p,q,r,s) = T(p,q,r,s) + rho2t(p,q,kl) * rho2t(r,s,kl) / Om2t(kl)
enddo ! kl
enddo ! p
enddo ! q
@ -86,8 +78,8 @@ subroutine RGT_Tmatrix(isp_T,nBas,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,lambda,ERI,Om1
if(isp_T == 2) then
!$OMP PARALLEL &
!$OMP SHARED(nC,nO,nBas,nR,T,ERI,rho1s,rho2s,Om1s,Om2s,rho1t,rho2t,Om1t,Om2t) &
!$OMP PRIVATE(p,q,r,s,c,d,cd,k,l,kl) &
!$OMP SHARED(nC,nO,nBas,nR,T,ERI,nOOs,nOOt,nVVs,nVVt,rho1s,rho2s,Om1s,Om2s,rho1t,rho2t,Om1t,Om2t) &
!$OMP PRIVATE(p,q,r,s,cd,kl) &
!$OMP DEFAULT(NONE)
!$OMP DO
do s=nC+1,nBas-nR
@ -97,37 +89,21 @@ subroutine RGT_Tmatrix(isp_T,nBas,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,lambda,ERI,Om1
T(p,q,r,s) = ERI(p,q,r,s)
cd = 0
do c=nO+1,nBas-nR
do d=c,nBas-nR
cd = cd + 1
T(p,q,r,s) = T(p,q,r,s) - 0.5d0 * rho1s(p,q,cd) * rho1s(r,s,cd) / Om1s(cd)
end do ! d
end do ! c
do cd=1,nVVs
T(p,q,r,s) = T(p,q,r,s) - 0.5d0 * rho1s(p,q,cd) * rho1s(r,s,cd) / Om1s(cd)
end do ! cd
cd = 0
do c=nO+1,nBas-nR
do d=c+1,nBas-nR
cd = cd + 1
T(p,q,r,s) = T(p,q,r,s) - 0.5d0 * rho1t(p,q,cd) * rho1t(r,s,cd) / Om1t(cd)
end do ! d
end do ! c
do cd=1,nVVt
T(p,q,r,s) = T(p,q,r,s) - 0.5d0 * rho1t(p,q,cd) * rho1t(r,s,cd) / Om1t(cd)
end do ! cd
kl = 0
do k=nC+1,nO
do l=k,nO
kl = kl + 1
T(p,q,r,s) = T(p,q,r,s) + 0.5d0 * rho2s(p,q,kl) * rho2s(r,s,kl) / Om2s(kl)
enddo ! l
enddo ! k
do kl=1,nOOs
T(p,q,r,s) = T(p,q,r,s) + 0.5d0 * rho2s(p,q,kl) * rho2s(r,s,kl) / Om2s(kl)
enddo ! kl
kl = 0
do k=nC+1,nO
do l=k+1,nO
kl = kl + 1
T(p,q,r,s) = T(p,q,r,s) + 0.5d0 * rho2t(p,q,kl) * rho2t(r,s,kl) / Om2t(kl)
enddo ! l
enddo ! k
do kl=1,nOOt
T(p,q,r,s) = T(p,q,r,s) + 0.5d0 * rho2t(p,q,kl) * rho2t(r,s,kl) / Om2t(kl)
enddo ! kl
enddo ! p
enddo ! q
@ -141,10 +117,9 @@ subroutine RGT_Tmatrix(isp_T,nBas,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,lambda,ERI,Om1
! Elements baab
if(isp_T == 3) then
!$OMP PARALLEL &
!$OMP SHARED(nC,nO,nBas,nR,T,ERI,rho1s,rho2s,Om1s,Om2s,rho1t,rho2t,Om1t,Om2t) &
!$OMP PRIVATE(p,q,r,s,c,d,cd,k,l,kl) &
!$OMP SHARED(nC,nO,nBas,nR,T,ERI,nOOs,nOOt,nVVs,nVVt,rho1s,rho2s,Om1s,Om2s,rho1t,rho2t,Om1t,Om2t) &
!$OMP PRIVATE(p,q,r,s,cd,kl) &
!$OMP DEFAULT(NONE)
!$OMP DO
do s=nC+1,nBas-nR
@ -154,37 +129,21 @@ subroutine RGT_Tmatrix(isp_T,nBas,nC,nO,nV,nR,nOOs,nVVs,nOOt,nVVt,lambda,ERI,Om1
T(p,q,r,s) = - ERI(p,q,s,r)
cd = 0
do c=nO+1,nBas-nR
do d=c+1,nBas-nR
cd = cd + 1
T(p,q,r,s) = T(p,q,r,s) + 0.5d0 * rho1t(p,q,cd) * rho1s(r,s,cd) / Om1t(cd)
end do ! d
end do ! c
do cd=1,nVVs
T(p,q,r,s) = T(p,q,r,s) + 0.5d0 * rho1s(p,q,cd) * rho1s(r,s,cd) / Om1s(cd)
end do ! cd
cd = 0
do c=nO+1,nBas-nR
do d=c,nBas-nR
cd = cd + 1
T(p,q,r,s) = T(p,q,r,s) - (1d0 - Kronecker_delta(c,d)) * 0.5d0 * rho1s(p,q,cd) * rho1t(r,s,cd) / Om1s(cd)
end do ! d
end do ! c
do cd=1,nVVt
T(p,q,r,s) = T(p,q,r,s) - 0.5d0 * rho1t(p,q,cd) * rho1t(r,s,cd) / Om1t(cd)
end do ! cd
kl = 0
do k=nC+1,nO
do l=k+1,nO
kl = kl + 1
T(p,q,r,s) = T(p,q,r,s) - 0.5d0 * rho2t(p,q,kl) * rho2s(r,s,kl) / Om2t(kl)
enddo ! l
enddo ! k
do kl=1,nOOs
T(p,q,r,s) = T(p,q,r,s) - 0.5d0 * rho2s(p,q,kl) * rho2s(r,s,kl) / Om2s(kl)
enddo ! kl
kl = 0
do k=nC+1,nO
do l=k,nO
kl = kl + 1
T(p,q,r,s) = T(p,q,r,s) + (1d0 - Kronecker_delta(k,l)) * 0.5d0 * rho2s(p,q,kl) * rho2t(r,s,kl) / Om2s(kl)
enddo ! l
enddo ! k
do kl=1,nOOt
T(p,q,r,s) = T(p,q,r,s) + 0.5d0 * rho2t(p,q,kl) * rho2t(r,s,kl) / Om2t(kl)
enddo ! kl
enddo ! p
enddo ! q

8
src/GT/RGTpp_ppBSE.f90
View File

@ -66,8 +66,8 @@ subroutine RGTpp_ppBSE(TDA_T,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,
allocate(Bpp(nVVs,nOOs),Cpp(nVVs,nVVs),Dpp(nOOs,nOOs))
if(.not.TDA_T) call ppLR_B(isp_T,nBas,nC,nO,nV,nR,nOOs,nVVs,1d0,ERI,Bpp)
call ppLR_C(isp_T,nBas,nC,nO,nV,nR,nVVs,1d0,eGT,ERI,Cpp)
call ppLR_D(isp_T,nBas,nC,nO,nV,nR,nOOs,1d0,eGT,ERI,Dpp)
call ppLR_C(isp_T,nBas,nC,nO,nV,nR,nVVs,1d0,eT,ERI,Cpp)
call ppLR_D(isp_T,nBas,nC,nO,nV,nR,nOOs,1d0,eT,ERI,Dpp)
allocate(Om1s(nVVs),X1s(nVVs,nVVs),Y1s(nOOs,nVVs))
allocate(Om2s(nOOs),X2s(nVVs,nOOs),Y2s(nOOs,nOOs))
@ -88,8 +88,8 @@ subroutine RGTpp_ppBSE(TDA_T,TDA,dBSE,dTDA,singlet,triplet,eta,nBas,nC,nO,nV,nR,
allocate(Bpp(nVVt,nOOt),Cpp(nVVt,nVVt),Dpp(nOOt,nOOt))
if(.not.TDA_T) call ppLR_B(isp_T,nBas,nC,nO,nV,nR,nOOt,nVVt,1d0,ERI,Bpp)
call ppLR_C(isp_T,nBas,nC,nO,nV,nR,nVVt,1d0,eGT,ERI,Cpp)
call ppLR_D(isp_T,nBas,nC,nO,nV,nR,nOOt,1d0,eGT,ERI,Dpp)
call ppLR_C(isp_T,nBas,nC,nO,nV,nR,nVVt,1d0,eT,ERI,Cpp)
call ppLR_D(isp_T,nBas,nC,nO,nV,nR,nOOt,1d0,eT,ERI,Dpp)
allocate(Om1t(nVVt),X1t(nVVt,nVVt),Y1t(nOOt,nVVt))
allocate(Om2t(nOOt),X2t(nVVt,nOOt),Y2t(nOOt,nOOt))

4
src/GT/RGTpp_ppBSE_static_kernel_D.f90
View File

@ -68,10 +68,10 @@ subroutine RGTpp_ppBSE_static_kernel_D(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,lambda
num = Taaaa(j,e,k,m)*Tabab(m,i,e,l) + Tabab(j,e,k,m)*Taaaa(m,i,e,l)
KD_sta(ij,kl) = KD_sta(ij,kl) + num*dem/(dem**2 + eta**2)
num = Tabab(i,m,k,e)*Tbaab(e,j,m,l) + Tbaab(i,e,k,m)*Tabab(m,j,e,l)
num = Tbaab(i,m,k,e)*Tbaab(e,j,m,l) + Tbaab(i,e,k,m)*Tbaab(m,j,e,l)
KD_sta(ij,kl) = KD_sta(ij,kl) - num*dem/(dem**2 + eta**2)
num = Tabab(j,m,k,e)*Tbaab(e,i,m,l) + Tbaab(j,e,k,m)*Tabab(m,i,e,l)
num = Tbaab(j,m,k,e)*Tbaab(e,i,m,l) + Tbaab(j,e,k,m)*Tbaab(m,i,e,l)
KD_sta(ij,kl) = KD_sta(ij,kl) - num*dem/(dem**2 + eta**2)
end do
end do