From cd25d07f6f5cf61c9cb1265688f62c14ce002e20 Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Fri, 6 Sep 2024 16:16:16 +0200 Subject: [PATCH] ebugging GF2 ppBSE spin adaptation --- src/GF/RGF2_ppBSE_static_kernel_B.f90 | 1 + src/GF/RGF2_ppBSE_static_kernel_C.f90 | 331 +++++++++++++------------- src/GF/RGF2_ppBSE_static_kernel_D.f90 | 5 +- 3 files changed, 171 insertions(+), 166 deletions(-) diff --git a/src/GF/RGF2_ppBSE_static_kernel_B.f90 b/src/GF/RGF2_ppBSE_static_kernel_B.f90 index be2572d..8c1af34 100644 --- a/src/GF/RGF2_ppBSE_static_kernel_B.f90 +++ b/src/GF/RGF2_ppBSE_static_kernel_B.f90 @@ -68,6 +68,7 @@ subroutine RGF2_ppBSE_static_kernel_B(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,lambda, end do KB_sta(ab,ij) = 2d0*lambda*KB_sta(ab,ij)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(i,j))) + end do end do diff --git a/src/GF/RGF2_ppBSE_static_kernel_C.f90 b/src/GF/RGF2_ppBSE_static_kernel_C.f90 index 6c47166..7a5aecd 100644 --- a/src/GF/RGF2_ppBSE_static_kernel_C.f90 +++ b/src/GF/RGF2_ppBSE_static_kernel_C.f90 @@ -37,22 +37,22 @@ subroutine RGF2_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nVV,lambda,ERI, ! Initialization KC_sta(:,:) = 0d0 - eta2 = eta * eta +! eta2 = eta * eta - allocate(Om_tmp(nBas,nBas)) - Om_tmp(:,:) = 0d0 +! allocate(Om_tmp(nBas,nBas)) +! Om_tmp(:,:) = 0d0 - ! Compute the energy differences and denominator once and store them in a temporary array - !$OMP PARALLEL DEFAULT(NONE) PRIVATE(m,e,dem) SHARED(nC,nO,nBas,nR, eta2, eGF, Om_tmp) - !$OMP DO - do m=nC+1,nO - do e=nO+1,nBas-nR - dem = eGF(m) - eGF(e) - Om_tmp(m,e) = dem / (dem*dem + eta2) - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL +! ! Compute the energy differences and denominator once and store them in a temporary array +! !$OMP PARALLEL DEFAULT(NONE) PRIVATE(m,e,dem) SHARED(nC,nO,nBas,nR, eta2, eGF, Om_tmp) +! !$OMP DO +! do m=nC+1,nO +! do e=nO+1,nBas-nR +! dem = eGF(m) - eGF(e) +! Om_tmp(m,e) = dem / (dem*dem + eta2) +! enddo +! enddo +! !$OMP END DO +! !$OMP END PARALLEL ! Second-order correlation kernel for the block C of the singlet manifold @@ -60,93 +60,94 @@ subroutine RGF2_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nVV,lambda,ERI, ! OpenMP implementation ! --- --- --- - if(ispin == 1) then +! if(ispin == 1) then - a0 = nBas - nR - nO - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(a, b, aa, ab, c, d, cd, m, e, num) & - !$OMP SHARED(nO, nBas, nR, nC, a0, ERI, Om_tmp, KC_sta, lambda) - !$OMP DO - do a=nO+1,nBas-nR - aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO - do b=a,nBas-nR - ab = aa + b +! a0 = nBas - nR - nO +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(a, b, aa, ab, c, d, cd, m, e, num) & +! !$OMP SHARED(nO, nBas, nR, nC, a0, ERI, Om_tmp, KC_sta, lambda) +! !$OMP DO +! do a=nO+1,nBas-nR +! aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO +! do b=a,nBas-nR +! ab = aa + b - cd = 0 - do c=nO+1,nBas-nR - do d=c,nBas-nR - cd = cd + 1 - - do m=nC+1,nO - do e=nO+1,nBas-nR - - num = 2d0*ERI(a,m,c,e)*ERI(b,e,d,m) - ERI(a,m,c,e)*ERI(b,e,m,d) & - - ERI(a,m,e,c)*ERI(b,e,d,m) - ERI(a,m,e,c)*ERI(b,e,m,d) +! cd = 0 +! do c=nO+1,nBas-nR +! do d=c,nBas-nR +! cd = cd + 1 +! +! do m=nC+1,nO +! do e=nO+1,nBas-nR +! +! num = 2d0*ERI(a,m,c,e)*ERI(b,e,d,m) - ERI(a,m,c,e)*ERI(b,e,m,d) & +! - ERI(a,m,e,c)*ERI(b,e,d,m) - ERI(a,m,e,c)*ERI(b,e,m,d) - KC_sta(ab,cd) = KC_sta(ab,cd) + num * Om_tmp(m,e) - - num = 2d0*ERI(b,m,c,e)*ERI(a,e,d,m) - ERI(b,m,c,e)*ERI(a,e,m,d) & - - ERI(b,m,e,c)*ERI(a,e,d,m) - ERI(b,m,e,c)*ERI(a,e,m,d) +! KC_sta(ab,cd) = KC_sta(ab,cd) + num * Om_tmp(m,e) +! +! num = 2d0*ERI(b,m,c,e)*ERI(a,e,d,m) - ERI(b,m,c,e)*ERI(a,e,m,d) & +! - ERI(b,m,e,c)*ERI(a,e,d,m) - ERI(b,m,e,c)*ERI(a,e,m,d) - KC_sta(ab,cd) = KC_sta(ab,cd) + num * Om_tmp(m,e) - - end do - end do +! KC_sta(ab,cd) = KC_sta(ab,cd) + num * Om_tmp(m,e) +! +! end do +! end do - KC_sta(ab,cd) = 2d0*lambda*KC_sta(ab,cd)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) - - end do - end do +! KC_sta(ab,cd) = 2d0*lambda*KC_sta(ab,cd)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) +! +! end do +! end do - end do - end do - !$OMP END DO - !$OMP END PARALLEL +! end do +! end do +! !$OMP END DO +! !$OMP END PARALLEL - end if +! end if ! --- --- --- ! Naive implementation ! --- --- --- -! if(ispin == 1) then + + if(ispin == 1) then + + ab = 0 + do a=nO+1,nBas-nR + do b=a,nBas-nR + ab = ab + 1 + + cd = 0 + do c=nO+1,nBas-nR + do d=c,nBas-nR + cd = cd + 1 + + do m=nC+1,nO + do e=nO+1,nBas-nR -! ab = 0 -! do a=nO+1,nBas-nR -! do b=a,nBas-nR -! ab = ab + 1 - -! cd = 0 -! do c=nO+1,nBas-nR -! do d=c,nBas-nR -! cd = cd + 1 - -! do m=nC+1,nO -! do e=nO+1,nBas-nR - -! dem = eGF(m) - eGF(e) -! num = 2d0*ERI(a,m,c,e)*ERI(b,e,d,m) - ERI(a,m,c,e)*ERI(b,e,m,d) & -! - ERI(a,m,e,c)*ERI(b,e,d,m) - ERI(a,m,e,c)*ERI(b,e,m,d) - -! KC_sta(ab,cd) = KC_sta(ab,cd) + num*dem/(dem**2 + eta**2) - -! dem = eGF(m) - eGF(e) -! num = 2d0*ERI(b,m,c,e)*ERI(a,e,d,m) - ERI(b,m,c,e)*ERI(a,e,m,d) & -! - ERI(b,m,e,c)*ERI(a,e,d,m) - ERI(b,m,e,c)*ERI(a,e,m,d) - -! KC_sta(ab,cd) = KC_sta(ab,cd) + num*dem/(dem**2 + eta**2) - -! end do -! end do - -! KC_sta(ab,cd) = 2d0*lambda*KC_sta(ab,cd)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) - -! end do -! end do - -! end do -! end do - -! end if + dem = eGF(m) - eGF(e) + num = 2d0*ERI(a,m,c,e)*ERI(b,e,d,m) - ERI(a,m,c,e)*ERI(b,e,m,d) & + - ERI(a,m,e,c)*ERI(b,e,d,m) - ERI(a,m,e,c)*ERI(b,e,m,d) + + KC_sta(ab,cd) = KC_sta(ab,cd) + num*dem/(dem**2 + eta**2) + + dem = eGF(m) - eGF(e) + num = 2d0*ERI(b,m,c,e)*ERI(a,e,d,m) - ERI(b,m,c,e)*ERI(a,e,m,d) & + - ERI(b,m,e,c)*ERI(a,e,d,m) - ERI(b,m,e,c)*ERI(a,e,m,d) + + KC_sta(ab,cd) = KC_sta(ab,cd) + num*dem/(dem**2 + eta**2) + + end do + end do + + KC_sta(ab,cd) = 2d0*lambda*KC_sta(ab,cd)/sqrt((1d0 + Kronecker_delta(a,b))*(1d0 + Kronecker_delta(c,d))) + + end do + end do + + end do + end do + + end if ! Second-order correlation kernel for the block C of the triplet manifold @@ -154,47 +155,89 @@ subroutine RGF2_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nVV,lambda,ERI, ! OpenMP implementation ! --- --- --- - if(ispin == 2) then +! if(ispin == 2) then - a0 = nBas - nR - nO - 1 - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(a, b, aa, ab, c, d, cd, m, e, num) & - !$OMP SHARED(nO, nBas, nR, nC, a0, ERI, Om_tmp, KC_sta) - !$OMP DO - do a = nO+1, nBas-nR - aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO - 1 - do b = a+1, nBas-nR - ab = aa + b +! a0 = nBas - nR - nO - 1 +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(a, b, aa, ab, c, d, cd, m, e, num) & +! !$OMP SHARED(nO, nBas, nR, nC, a0, ERI, Om_tmp, KC_sta) +! !$OMP DO +! do a = nO+1, nBas-nR +! aa = a0 * (a - nO - 1) - (a - nO - 1) * (a - nO) / 2 - nO - 1 +! do b = a+1, nBas-nR +! ab = aa + b - cd = 0 - do c=nO+1,nBas-nR - do d=c+1,nBas-nR - cd = cd + 1 +! cd = 0 +! do c=nO+1,nBas-nR +! do d=c+1,nBas-nR +! cd = cd + 1 +! +! do m=nC+1,nO +! do e=nO+1,nBas-nR +! +! num = 2d0*ERI(a,m,c,e)*ERI(b,e,d,m) - ERI(a,m,c,e)*ERI(b,e,m,d) & +! - ERI(a,m,e,c)*ERI(b,e,d,m) + ERI(a,m,e,c)*ERI(b,e,m,d) + +! KC_sta(ab,cd) = KC_sta(ab,cd) + 2d0 * num * Om_tmp(m,e) +! +! num = 2d0*ERI(b,m,c,e)*ERI(a,e,d,m) - ERI(b,m,c,e)*ERI(a,e,m,d) & +! - ERI(b,m,e,c)*ERI(a,e,d,m) + ERI(b,m,e,c)*ERI(a,e,m,d) + +! KC_sta(ab,cd) = KC_sta(ab,cd) - 2d0 * num * Om_tmp(m,e) +! +! end do +! end do + +! end do +! end do + +! end do +! end do +! !$OMP END DO +! !$OMP END PARALLEL + +! end if + +! --- --- --- +! Naive implementation +! --- --- --- + + if(ispin == 2) then + + 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 + + do m=nC+1,nO + do e=nO+1,nBas-nR - do m=nC+1,nO - do e=nO+1,nBas-nR - - num = 2d0*ERI(a,m,c,e)*ERI(b,e,d,m) - ERI(a,m,c,e)*ERI(b,e,m,d) & - - ERI(a,m,e,c)*ERI(b,e,d,m) + ERI(a,m,e,c)*ERI(b,e,m,d) + dem = eGF(m) - eGF(e) + num = 2d0*ERI(a,m,c,e)*ERI(b,e,d,m) - ERI(a,m,c,e)*ERI(b,e,m,d) & + - ERI(a,m,e,c)*ERI(b,e,d,m) + ERI(a,m,e,c)*ERI(b,e,m,d) - KC_sta(ab,cd) = KC_sta(ab,cd) + 2d0 * num * Om_tmp(m,e) - - num = 2d0*ERI(b,m,c,e)*ERI(a,e,d,m) - ERI(b,m,c,e)*ERI(a,e,m,d) & - - ERI(b,m,e,c)*ERI(a,e,d,m) + ERI(b,m,e,c)*ERI(a,e,m,d) + KC_sta(ab,cd) = KC_sta(ab,cd) + 2d0*num*dem/(dem**2 + eta**2) + + dem = eGF(m) - eGF(e) + num = 2d0*ERI(b,m,c,e)*ERI(a,e,d,m) - ERI(b,m,c,e)*ERI(a,e,m,d) & + - ERI(b,m,e,c)*ERI(a,e,d,m) + ERI(b,m,e,c)*ERI(a,e,m,d) - KC_sta(ab,cd) = KC_sta(ab,cd) - 2d0 * num * Om_tmp(m,e) - - end do - end do + KC_sta(ab,cd) = KC_sta(ab,cd) - 2d0*num*dem/(dem**2 + eta**2) + + end do + end do - end do - end do - - end do - end do - !$OMP END DO - !$OMP END PARALLEL + end do + end do + end do + end do + end if if(ispin == 4) then @@ -237,48 +280,8 @@ subroutine RGF2_ppBSE_static_kernel_C(ispin,eta,nBas,nC,nO,nV,nR,nVV,lambda,ERI, ! Second-order correlation kernel for the block C of the spinorbital manifold -! --- --- --- -! Naive implementation -! --- --- --- -! if(ispin == 2) then - -! 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 - -! do m=nC+1,nO -! do e=nO+1,nBas-nR - -! dem = eGF(m) - eGF(e) -! num = 2d0*ERI(a,m,c,e)*ERI(b,e,d,m) - ERI(a,m,c,e)*ERI(b,e,m,d) & -! - ERI(a,m,e,c)*ERI(b,e,d,m) + ERI(a,m,e,c)*ERI(b,e,m,d) - -! KC_sta(ab,cd) = KC_sta(ab,cd) + 2d0*num*dem/(dem**2 + eta**2) - -! dem = eGF(m) - eGF(e) -! num = 2d0*ERI(b,m,c,e)*ERI(a,e,d,m) - ERI(b,m,c,e)*ERI(a,e,m,d) & -! - ERI(b,m,e,c)*ERI(a,e,d,m) + ERI(b,m,e,c)*ERI(a,e,m,d) - -! KC_sta(ab,cd) = KC_sta(ab,cd) - 2d0*num*dem/(dem**2 + eta**2) - -! end do -! end do - -! end do -! end do - -! end do -! end do - - ! end if - deallocate(Om_tmp) +! deallocate(Om_tmp) end subroutine diff --git a/src/GF/RGF2_ppBSE_static_kernel_D.f90 b/src/GF/RGF2_ppBSE_static_kernel_D.f90 index 4f91bd5..0838c71 100644 --- a/src/GF/RGF2_ppBSE_static_kernel_D.f90 +++ b/src/GF/RGF2_ppBSE_static_kernel_D.f90 @@ -52,13 +52,13 @@ subroutine RGF2_ppBSE_static_kernel_D(ispin,eta,nBas,nC,nO,nV,nR,nOO,lambda,ERI, do m=nC+1,nO do e=nO+1,nBas-nR - dem = - eGF(e) + eGF(m) + dem = eGF(m) - eGF(e) num = 2d0*ERI(i,e,k,m)*ERI(j,m,l,e) - ERI(i,e,k,m)*ERI(j,m,e,l) & - ERI(i,e,m,k)*ERI(j,m,l,e) - ERI(i,e,m,k)*ERI(j,m,e,l) KD_sta(ij,kl) = KD_sta(ij,kl) + num*dem/(dem**2 + eta**2) - dem = - eGF(e) + eGF(m) + dem = eGF(m) - eGF(e) num = 2d0*ERI(j,e,k,m)*ERI(i,m,l,e) - ERI(j,e,k,m)*ERI(i,m,e,l) & - ERI(j,e,m,k)*ERI(i,m,l,e) - ERI(j,e,m,k)*ERI(i,m,e,l) @@ -68,6 +68,7 @@ subroutine RGF2_ppBSE_static_kernel_D(ispin,eta,nBas,nC,nO,nV,nR,nOO,lambda,ERI, end do KD_sta(ij,kl) = 2d0*lambda*KD_sta(ij,kl)/sqrt((1d0 + Kronecker_delta(i,j))*(1d0 + Kronecker_delta(k,l))) + end do end do