QuAcK/src/GT/Bethe_Salpeter_Tmatrix_dynamic_perturbation.f90

subroutine Bethe_Salpeter_Tmatrix_dynamic_perturbation(singlet,triplet,dTDA,eta,nBas,nC,nO,nV,nR,nS,nOOs,nVVs,nOOt,nVVt, &
                                                       Omega1s,Omega2s,Omega1t,Omega2t,rho1s,rho2s,rho1t,rho2t,eT,eGT,   &
                                                       dipole_int,OmBSE,XpY,XmY,TAs,TBs,TAt,TBt)

! Compute dynamical effects via perturbation theory for BSE@GT

  implicit none
  include 'parameters.h'

! Input variables

  logical,intent(in)            :: singlet
  logical,intent(in)            :: triplet
  logical,intent(in)            :: dTDA 
  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)            :: nS

  integer,intent(in)            :: nOOs
  integer,intent(in)            :: nVVs
  integer,intent(in)            :: nOOt
  integer,intent(in)            :: nVVt

  double precision,intent(in)   :: eT(nBas)
  double precision,intent(in)   :: eGT(nBas)
  double precision,intent(in)   :: dipole_int(nBas,nBas,ncart)
  double precision,intent(in)   :: OmBSE(nS,nspin)
  double precision,intent(in)   :: XpY(nS,nS,nspin)
  double precision,intent(in)   :: XmY(nS,nS,nspin)

  double precision,intent(in)   :: Omega1s(nVVs)
  double precision,intent(in)   :: Omega2s(nOOs)
  double precision,intent(in)   :: rho1s(nBas,nBas,nVVs)
  double precision,intent(in)   :: rho2s(nBas,nBas,nOOs)
  double precision,intent(in)   :: Omega1t(nVVt)
  double precision,intent(in)   :: Omega2t(nOOt)
  double precision,intent(in)   :: rho1t(nBas,nBas,nVVt)
  double precision,intent(in)   :: rho2t(nBas,nBas,nOOt)

  double precision,intent(in)   :: TAs(nS,nS)
  double precision,intent(in)   :: TBs(nS,nS)
  double precision,intent(in)   :: TAt(nS,nS)
  double precision,intent(in)   :: TBt(nS,nS)

! Local variables

  integer                       :: ia
  integer                       :: ispin

  integer                       :: maxS = 10
  double precision              :: gapGT

  double precision,allocatable  :: OmDyn(:,:)
  double precision,allocatable  :: ZDyn(:,:)
  double precision,allocatable  :: X(:)
  double precision,allocatable  :: Y(:)

  double precision,allocatable  :: dTAs(:,:)
  double precision,allocatable  :: ZAs(:,:)

  double precision,allocatable  :: dTAt(:,:)
  double precision,allocatable  :: ZAt(:,:)

! Memory allocation

  maxS = min(nS,maxS)
  allocate(OmDyn(maxS,nspin),ZDyn(maxS,nspin),X(nS),Y(nS),dTAs(nS,nS),ZAs(nS,nS),dTAt(nS,nS),ZAt(nS,nS))

  if(dTDA) then 
    write(*,*)
    write(*,*) '*** dynamical TDA activated ***'
    write(*,*)
  else
    print*, ' Beyond-TDA dynamical correction for BSE@GT NYI'
    return
  end if

  OmDyn(:,:) = 0d0
  ZDyn(:,:)  = 0d0

  do ia=1,maxS

  ! Compute dynamical T-matrix for alpha-beta block !

    ispin = 1
    call dynamic_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOOs,nVVs,1d0,eGT,Omega1s,Omega2s,rho1s,rho2s,OmBSE(ia,ispin),dTAs,ZAs)
 
  ! Compute dynamical T-matrix for alpha-beta block !

    ispin = 2
    call dynamic_Tmatrix_A(eta,nBas,nC,nO,nV,nR,nS,nOOt,nVVt,1d0,eGT,Omega1t,Omega2t,rho1t,rho2t,OmBSE(ia,ispin),dTAt,ZAt)

    do ispin=1,nspin
 
      X(:) = 0.5d0*(XpY(ia,:,ispin) + XmY(ia,:,ispin))
      Y(:) = 0.5d0*(XpY(ia,:,ispin) - XmY(ia,:,ispin))

      ! First-order correction 
     
      if(ispin == 1) then 
        ZDyn(ia,ispin)  = dot_product(X,matmul(ZAt+ZAs,X)) 
        OmDyn(ia,ispin) = dot_product(X,matmul(dTAt+dTAs,X)) - dot_product(X,matmul(TAt+TAs,X))
      end if

      if(ispin == 2) then 
        ZDyn(ia,ispin)  = dot_product(X,matmul(ZAt-ZAs,X)) 
        OmDyn(ia,ispin) = dot_product(X,matmul(dTAt-dTAs,X)) - dot_product(X,matmul(TAt-TAs,X))
      end if
     
      ZDyn(ia,ispin)  = 1d0/(1d0 - ZDyn(ia,ispin))
      OmDyn(ia,ispin) = ZDyn(ia,ispin)*OmDyn(ia,ispin)

    end do

  end do

!--------------!
! Dump results !
!--------------!

  gapGT = eGT(nO+1) - eGT(nO) 

  if(singlet) then 

    ispin = 1

    write(*,*) '---------------------------------------------------------------------------------------------------'
    write(*,*) ' First-order dynamical correction to static singlet Bethe-Salpeter excitation energies             '
    write(*,*) '---------------------------------------------------------------------------------------------------'
    write(*,'(A57,F10.6,A3)') ' BSE neutral excitation must be lower than the GT gap = ',gapGT*HaToeV,' eV'
    write(*,*) '---------------------------------------------------------------------------------------------------'
    write(*,'(2X,A5,1X,A20,1X,A20,1X,A20,1X,A20)') '#','Static (eV)','Dynamic (eV)','Correction (eV)','Renorm. (eV)'
    write(*,*) '---------------------------------------------------------------------------------------------------'

    do ia=1,maxS
      write(*,'(2X,I5,5X,F15.6,5X,F15.6,5X,F15.6,5X,F15.6)') & 
        ia,OmBSE(ia,ispin)*HaToeV,(OmBSE(ia,ispin)+OmDyn(ia,ispin))*HaToeV,OmDyn(ia,ispin)*HaToeV,ZDyn(ia,ispin)
    end do

    write(*,*) '---------------------------------------------------------------------------------------------------'
    write(*,*) 

  end if

  if(triplet) then 

    ispin = 2

    write(*,*) '---------------------------------------------------------------------------------------------------'
    write(*,*) ' First-order dynamical correction to static triplet Bethe-Salpeter excitation energies             '
    write(*,*) '---------------------------------------------------------------------------------------------------'
    write(*,'(A57,F10.6,A3)') ' BSE neutral excitation must be lower than the GT gap = ',gapGT*HaToeV,' eV'
    write(*,*) '---------------------------------------------------------------------------------------------------'
    write(*,'(2X,A5,1X,A20,1X,A20,1X,A20,1X,A20)') '#','Static (eV)','Dynamic (eV)','Correction (eV)','Renorm. (eV)'
    write(*,*) '---------------------------------------------------------------------------------------------------'

    do ia=1,maxS
      write(*,'(2X,I5,5X,F15.6,5X,F15.6,5X,F15.6,5X,F15.6)') & 
        ia,OmBSE(ia,ispin)*HaToeV,(OmBSE(ia,ispin)+OmDyn(ia,ispin))*HaToeV,OmDyn(ia,ispin)*HaToeV,ZDyn(ia,ispin)
    end do

    write(*,*) '---------------------------------------------------------------------------------------------------'
    write(*,*) 

  end if

end subroutine Bethe_Salpeter_Tmatrix_dynamic_perturbation