From 0cbd4fb10ff0467e1ea01ec13f6724132d8e19d5 Mon Sep 17 00:00:00 2001 From: pfloos Date: Sun, 8 Sep 2024 17:23:23 +0200 Subject: [PATCH] create G routines and remove duplicated code --- src/GT/GGTpp_ppBSE_static_kernel_B.f90 | 68 ++++++++++++++++++++++++++ src/GT/GGTpp_ppBSE_static_kernel_C.f90 | 68 ++++++++++++++++++++++++++ src/GT/GGTpp_ppBSE_static_kernel_D.f90 | 67 +++++++++++++++++++++++++ src/GT/RGTpp_excitation_density.f90 | 2 +- src/GT/RGTpp_ppBSE_static_kernel_B.f90 | 2 +- src/GT/RGTpp_ppBSE_static_kernel_C.f90 | 2 +- src/GT/RGTpp_ppBSE_static_kernel_D.f90 | 2 +- 7 files changed, 207 insertions(+), 4 deletions(-) create mode 100644 src/GT/GGTpp_ppBSE_static_kernel_B.f90 create mode 100644 src/GT/GGTpp_ppBSE_static_kernel_C.f90 create mode 100644 src/GT/GGTpp_ppBSE_static_kernel_D.f90 diff --git a/src/GT/GGTpp_ppBSE_static_kernel_B.f90 b/src/GT/GGTpp_ppBSE_static_kernel_B.f90 new file mode 100644 index 0000000..2afe373 --- /dev/null +++ b/src/GT/GGTpp_ppBSE_static_kernel_B.f90 @@ -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 diff --git a/src/GT/GGTpp_ppBSE_static_kernel_C.f90 b/src/GT/GGTpp_ppBSE_static_kernel_C.f90 new file mode 100644 index 0000000..0ce97d4 --- /dev/null +++ b/src/GT/GGTpp_ppBSE_static_kernel_C.f90 @@ -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 diff --git a/src/GT/GGTpp_ppBSE_static_kernel_D.f90 b/src/GT/GGTpp_ppBSE_static_kernel_D.f90 new file mode 100644 index 0000000..b920a76 --- /dev/null +++ b/src/GT/GGTpp_ppBSE_static_kernel_D.f90 @@ -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 diff --git a/src/GT/RGTpp_excitation_density.f90 b/src/GT/RGTpp_excitation_density.f90 index e894d02..821db82 100644 --- a/src/GT/RGTpp_excitation_density.f90 +++ b/src/GT/RGTpp_excitation_density.f90 @@ -130,7 +130,7 @@ subroutine RGTpp_excitation_density(ispin,nBas,nC,nO,nV,nR,nOO,nVV,ERI,X1,Y1,rho ! Triplet manifold !---------------------------------------------- - if(ispin == 2 .or. ispin == 4) then + if(ispin == 2) then dim_1 = (nBas - nO) * (nBas - nO - 1) / 2 dim_2 = nO * (nO - 1) / 2 diff --git a/src/GT/RGTpp_ppBSE_static_kernel_B.f90 b/src/GT/RGTpp_ppBSE_static_kernel_B.f90 index 21a16ce..9b84f3f 100644 --- a/src/GT/RGTpp_ppBSE_static_kernel_B.f90 +++ b/src/GT/RGTpp_ppBSE_static_kernel_B.f90 @@ -76,7 +76,7 @@ subroutine RGTpp_ppBSE_static_kernel_B(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,n ! triplet block ! !===============! - if(ispin == 2 .or. ispin == 4) then + if(ispin == 2) then ab = 0 do a=nO+1,nBas-nR diff --git a/src/GT/RGTpp_ppBSE_static_kernel_C.f90 b/src/GT/RGTpp_ppBSE_static_kernel_C.f90 index c94360f..d6089ae 100644 --- a/src/GT/RGTpp_ppBSE_static_kernel_C.f90 +++ b/src/GT/RGTpp_ppBSE_static_kernel_C.f90 @@ -79,7 +79,7 @@ subroutine RGTpp_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,n ! triplet block ! !===============! - if(ispin == 2 .or. ispin == 4) then + if(ispin == 2) then ab = 0 do a=nO+1,nBas-nR diff --git a/src/GT/RGTpp_ppBSE_static_kernel_D.f90 b/src/GT/RGTpp_ppBSE_static_kernel_D.f90 index d349ee3..3a53998 100644 --- a/src/GT/RGTpp_ppBSE_static_kernel_D.f90 +++ b/src/GT/RGTpp_ppBSE_static_kernel_D.f90 @@ -76,7 +76,7 @@ subroutine RGTpp_ppBSE_static_kernel_D(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,n ! triplet block ! !===============! - if(ispin == 2 .or. ispin == 4) then + if(ispin == 2) then ij = 0 do i=nC+1,nO