LCPQ/quack
4
1
Fork 0
mirror of https://github.com/pfloos/quack synced 2024-12-22 12:23:50 +01:00
Code Releases Activity

create G routines and remove duplicated code

Browse Source
This commit is contained in:
Pierre-Francois Loos 2024-09-08 17:23:23 +02:00
parent b6652240d3
commit 0cbd4fb10f
7 changed files with 207 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
src/GT/GGTpp_ppBSE_static_kernel_B.f90 Normal file
View File

@ -0,0 +1,68 @@
subroutine GGTpp_ppBSE_static_kernel_B(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
implicit none
include 'parameters.h'
! Input variables
integer,intent(in) :: ispin
double precision,intent(in) :: eta
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
integer,intent(in) :: nOOx
integer,intent(in) :: nVVx
double precision,intent(in) :: lambda
double precision,intent(in) :: Om1(nVV)
double precision,intent(in) :: rho1(nBas,nBas,nVV)
double precision,intent(in) :: Om2(nOO)
double precision,intent(in) :: rho2(nBas,nBas,nOO)
! Local variables
double precision :: chi
double precision :: eps
integer :: i,j,a,b,ij,ab,cd,kl
! Output variables
double precision,intent(out) :: TB(nVVx,nOOx)
ab = 0
do a=nO+1,nBas-nR
do b=a+1,nBas-nR
ab = ab + 1
ij = 0
do i=nC+1,nO
do j=i+1,nO
ij = ij + 1
chi = 0d0
do cd=1,nVV
eps = + Om1(cd)
chi = chi + rho1(a,b,cd)*rho1(i,j,cd)*eps/(eps**2 + eta**2)
end do
do kl=1,nOO
eps = - Om2(kl)
chi = chi + rho2(a,b,kl)*rho2(i,j,kl)*eps/(eps**2 + eta**2)
end do
TB(ab,ij) = lambda*chi
end do
end do
end do
end do
end subroutine

68
src/GT/GGTpp_ppBSE_static_kernel_C.f90 Normal file
View File

@ -0,0 +1,68 @@
subroutine GGTpp_ppBSE_static_kernel_C(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
implicit none
include 'parameters.h'
! Input variables
integer,intent(in) :: ispin
double precision,intent(in) :: eta
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
integer,intent(in) :: nOOx
integer,intent(in) :: nVVx
double precision,intent(in) :: lambda
double precision,intent(in) :: Om1(nVV)
double precision,intent(in) :: rho1(nBas,nBas,nVV)
double precision,intent(in) :: Om2(nOO)
double precision,intent(in) :: rho2(nBas,nBas,nOO)
! Local variables
double precision,external :: Kronecker_delta
double precision :: chi
double precision :: eps
integer :: a,b,c,d,ab,cd,ef,mn
! Output variables
double precision,intent(out) :: TC(nVVx,nVVx)
ab = 0
do a=nO+1,nBas-nR
do b=a+1,nBas-nR
ab = ab + 1
cd = 0
do c=nO+1,nBas-nR
do d=c+1,nBas-nR
cd = cd + 1
chi = 0d0
do ef=1,nVV
eps = + Om1(ef)
chi = chi + rho1(a,b,ef)*rho1(c,d,ef)*eps/(eps**2 + eta**2)
end do
do mn=1,nOO
eps = - Om2(mn)
chi = chi + rho2(a,b,mn)*rho2(c,d,mn)*eps/(eps**2 + eta**2)
end do
TC(ab,cd) = lambda*chi
end do
end do
end do
end do
end subroutine

67
src/GT/GGTpp_ppBSE_static_kernel_D.f90 Normal file
View File

@ -0,0 +1,67 @@
subroutine GGTpp_ppBSE_static_kernel_D(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
implicit none
include 'parameters.h'
! Input variables
integer,intent(in) :: ispin
double precision,intent(in) :: eta
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
integer,intent(in) :: nOOx
integer,intent(in) :: nVVx
double precision,intent(in) :: lambda
double precision,intent(in) :: Om1(nVV)
double precision,intent(in) :: rho1(nBas,nBas,nVV)
double precision,intent(in) :: Om2(nOO)
double precision,intent(in) :: rho2(nBas,nBas,nOO)
! Local variables
double precision :: chi
double precision :: eps
integer :: i,j,k,l,ij,kl,ef,mn
! Output variables
double precision,intent(out) :: TD(nOOx,nOOx)
ij = 0
do i=nC+1,nO
do j=i+1,nO
ij = ij + 1
kl = 0
do k=nC+1,nO
do l=k+1,nO
kl = kl + 1
chi = 0d0
do ef=1,nVV
eps = + Om1(ef)
chi = chi + rho1(i,j,ef)*rho1(k,l,ef)*eps/(eps**2 + eta**2)
end do
do mn=1,nOO
eps = - Om2(mn)
chi = chi + rho2(i,j,mn)*rho2(k,l,mn)*eps/(eps**2 + eta**2)
end do
TD(ij,kl) = lambda*chi
end do
end do
end do
end do
end subroutine

2
src/GT/RGTpp_excitation_density.f90
View File

@ -130,7 +130,7 @@ subroutine RGTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho
! Triplet manifold ! Triplet manifold
!---------------------------------------------- !----------------------------------------------
if(ispin == 2 .or. ispin == 4) then if(ispin == 2) then
dim_1 = (nBas - nO) * (nBas - nO - 1) / 2 dim_1 = (nBas - nO) * (nBas - nO - 1) / 2
dim_2 = nO * (nO - 1) / 2 dim_2 = nO * (nO - 1) / 2

2
src/GT/RGTpp_ppBSE_static_kernel_B.f90
View File

@ -76,7 +76,7 @@ subroutine RGTpp_ppBSE_static_kernel_B(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,n
! triplet block ! ! triplet block !
!===============! !===============!
if(ispin == 2 .or. ispin == 4) then if(ispin == 2) then
ab = 0 ab = 0
do a=nO+1,nBas-nR do a=nO+1,nBas-nR

2
src/GT/RGTpp_ppBSE_static_kernel_C.f90
View File

@ -79,7 +79,7 @@ subroutine RGTpp_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,n
! triplet block ! ! triplet block !
!===============! !===============!
if(ispin == 2 .or. ispin == 4) then if(ispin == 2) then
ab = 0 ab = 0
do a=nO+1,nBas-nR do a=nO+1,nBas-nR

2
src/GT/RGTpp_ppBSE_static_kernel_D.f90
View File

@ -76,7 +76,7 @@ subroutine RGTpp_ppBSE_static_kernel_D(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,n
! triplet block ! ! triplet block !
!===============! !===============!
if(ispin == 2 .or. ispin == 4) then if(ispin == 2) then
ij = 0 ij = 0
do i=nC+1,nO do i=nC+1,nO