ppLR in GTpp and GW

src/GT/GTpp_dynamic_kernel_Aph.f90

@@ -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
 
@@ -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
 
-end subroutine dynamic_Tmatrix_A
+end subroutine 

src/GT/GTpp_dynamic_kernel_Bph.f90

@@ -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
 
@@ -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 subroutine dynamic_Tmatrix_B
+end subroutine 

src/GT/GTpp_phACFTD.f90

@@ -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 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
         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 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
 
                    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)
  
-                   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)
 
@@ -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 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
         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 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
 
                    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)
 
-                   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)
 

src/GT/GTpp_phBSE.f90

@@ -99,8 +99,8 @@ subroutine GTpp_phBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
 
   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 !
@@ -119,8 +119,8 @@ subroutine GTpp_phBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
 
   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 !
@@ -153,7 +153,7 @@ subroutine GTpp_phBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
 
       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, & 
                                              dipole_int,OmBSE,XpY_BSE,XmY_BSE,TAab,TAaa)
       end if
@@ -193,7 +193,7 @@ subroutine GTpp_phBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
 
       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, & 
                                              dipole_int,OmBSE,XpY_BSE,XmY_BSE,TAab,TAaa)
       end if

src/GT/GTpp_phBSE_dynamic_perturbation.f90

@@ -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
 
@@ -82,11 +81,11 @@ subroutine Bethe_Salpeter_Tmatrix_dynamic_perturbation(ispin,dTDA,eta,nBas,nC,nO
 
     ! 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  
 
-    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,:))
     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(*,*) 
 
-end subroutine Bethe_Salpeter_Tmatrix_dynamic_perturbation
+end subroutine 

src/GT/GTpp_ppBSE.f90

@@ -62,6 +62,7 @@ subroutine GTpp_ppBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
   integer                       :: nVVt
 
   double precision              :: EcRPA(nspin)
+  double precision,allocatable  :: Bpp(:,:),Cpp(:,:),Dpp(:,:)
   double precision,allocatable  :: TBab(:,:),TCab(:,:),TDab(:,:)
   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
  
-    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))
  
-    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 !
   !----------------------------------------!
 
     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))
  
-    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 !
@@ -125,14 +137,22 @@ subroutine GTpp_ppBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
 
     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)
 
-    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
 
@@ -152,32 +172,42 @@ subroutine GTpp_ppBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
   !---------------------------------------!
 
     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))
  
-    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 !
   !----------------------------------------!
 
-    ispin  = 2
     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))
  
-    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 !
@@ -185,14 +215,23 @@ subroutine GTpp_ppBSE(TDA_T,TDA,dBSE,dTDA,evDyn,singlet,triplet,eta,nBas,nC,nO,n
 
     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)
 
-    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
 

src/GT/GTpp_static_kernel_Aph.f90

@@ -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
 
@@ -30,12 +30,12 @@ subroutine static_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,Omega1,rho1,O
 
 ! Output variables
 
-  double precision,intent(out)  :: TA(nS,nS)
+  double precision,intent(out)  :: KA(nS,nS)
 
-  TA(:,:) = 0d0
+  KA(:,:) = 0d0
 
   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 b=nO+1,nBas-nR
       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)
           enddo
 
-          TA(ia,jb) = lambda*chi
+          KA(ia,jb) = lambda*chi
 
         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
 
-end subroutine static_Tmatrix_A
+end subroutine 

src/GT/GTpp_static_kernel_Bph.f90

@@ -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
 
@@ -30,9 +30,9 @@ subroutine static_Tmatrix_B(eta,nBas,nC,nO,nV,nR,nS,nOO,nVV,lambda,Omega1,rho1,O
 
 ! Output variables
 
-  double precision,intent(out)  :: TB(nS,nS)
+  double precision,intent(out)  :: KB(nS,nS)
 
-  TB(:,:) = 0d0
+  KB(:,:) = 0d0
 
   ia = 0
   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)
           enddo
 
-          TB(ia,jb) = lambda*chi
+          KB(ia,jb) = lambda*chi
 
         enddo
       enddo
     enddo
   enddo
 
-end subroutine static_Tmatrix_B
+end subroutine 

src/GT/GTpp_static_kernel_Bpp.f90

@@ -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
 
@@ -148,4 +148,4 @@ subroutine static_Tmatrix_B_pp(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,nVVx,lamb
 
   end if
 
-end subroutine static_Tmatrix_B_pp
+end subroutine 

src/GT/GTpp_static_kernel_Cpp.f90

@@ -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
 
@@ -151,4 +151,4 @@ subroutine static_Tmatrix_C_pp(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,nVVx,lamb
 
   end if
 
-end subroutine static_Tmatrix_C_pp
+end subroutine 

src/GT/GTpp_static_kernel_Dpp.f90

@@ -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 
 
@@ -149,4 +149,4 @@ subroutine static_Tmatrix_D_pp(ispin,eta,nBas,nC,nO,nV,nR,nOO,nVV,nOOx,nVVx,lamb
 
   end if
 
-end subroutine static_Tmatrix_D_pp
+end subroutine 

src/GT/evGTpp.f90

@@ -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))
 
     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))
 
@@ -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))
 
     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))
 

src/GW/GW_ppBSE.f90

@@ -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  :: rho_RPA(:,:,:)
 
+  double precision,allocatable  :: Bpp(:,:)
+  double precision,allocatable  :: Cpp(:,:)
+  double precision,allocatable  :: Dpp(:,:)
+
   double precision,allocatable  :: Om1(:)
   double precision,allocatable  :: X1(:,:)
   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(*,*) 
 
     ispin = 1
-    EcBSE(ispin) = 0d0
 
     nOO = nO*(nO+1)/2
     nVV = nV*(nV+1)/2
 
     allocate(Om1(nVV),X1(nVV,nVV),Y1(nOO,nVV),       &
              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))
 
+    ! 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)
     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)
 
-    ! 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)
 
-    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
 
@@ -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),       &
              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))
 
+    ! 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)
     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)
 
-    ! 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)
 
-    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
 

src/LR/linear_response_pp_BSE.f90

@@ -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