quack/src/MP/GMP2.f90

subroutine GMP2(dotest,regularize,nBas,nC,nO,nV,nR,ERI,ENuc,EGHF,eHF,EcMP2)

! Perform second-order Moller-Plesset calculation with and without regularizers

  implicit none

! Input variables

  logical,intent(in)            :: dotest

  logical,intent(in)            :: regularize
  integer,intent(in)            :: nBas
  integer,intent(in)            :: nC
  integer,intent(in)            :: nO
  integer,intent(in)            :: nV
  integer,intent(in)            :: nR
  double precision,intent(in)   :: ENuc
  double precision,intent(in)   :: EGHF
  double precision,intent(in)   :: eHF(nBas)
  double precision,intent(in)   :: ERI(nBas,nBas,nBas,nBas)

! Local variables

  integer                       :: i,j,a,b

  double precision              :: kappa,sigm1,sigm2
  double precision              :: num
  double precision              :: Dijab
  double precision              :: fs,fs2,fk

  double precision              :: E2d,E2ds,E2ds2,E2dk
  double precision              :: E2x,E2xs,E2xs2,E2xk

  double precision              :: EcsMP2,Ecs2MP2,EckMP2

! Output variables

  double precision,intent(out)  :: EcMP2

! Hello world

  write(*,*)
  write(*,*)'*******************************'
  write(*,*)'* Generalized MP2 Calculation |'
  write(*,*)'*******************************'
  write(*,*)

!---------------------------------------------!
! Parameters for regularized MP2 calculations !
!---------------------------------------------!

  kappa = 1.1d0
  sigm1 = 0.7d0
  sigm2 = 0.4d0

!--------------------------------------------------!
! Compute conventinal and regularized MP2 energies !
!--------------------------------------------------!

  E2d   = 0d0
  E2ds  = 0d0
  E2ds2 = 0d0
  E2dk  = 0d0

  E2x   = 0d0
  E2xs  = 0d0
  E2xs2 = 0d0
  E2xk  = 0d0

  do i=nC+1,nO
    do j=nC+1,nO
      do a=nO+1,nBas-nR
        do b=nO+1,nBas-nR

          Dijab = eHF(a) + eHF(b) - eHF(i) - eHF(j) 

          ! Second-order ring diagram

          fs  = (1d0 - exp(-sigm1*Dijab))/Dijab
          fs2 = (1d0 - exp(-sigm2*Dijab*Dijab))/Dijab
          fk  = (1d0 - exp(-kappa*Dijab))**2/Dijab

          num   = 0.25d0*(ERI(i,j,a,b)**2 + ERI(i,j,b,a)**2)
          E2d   = E2d   - num/Dijab
          E2ds  = E2ds  - num*fs 
          E2ds2 = E2ds2 - num*fs2
          E2dk  = E2dk  - num*fk

          ! Second-order exchange diagram

          num   = 0.5d0*ERI(i,j,a,b)*ERI(i,j,b,a)
          E2x   = E2x   + num/Dijab
          E2xs  = E2xs  + num*fs 
          E2xs2 = E2xs2 + num*fs2
          E2xk  = E2xk  + num*fk

        end do
      end do
    end do
  end do

  EcMP2   = E2d   + E2x
  EcsMP2  = E2ds  + E2xs
  Ecs2MP2 = E2ds2 + E2xs2
  EckMP2  = E2dk  + E2xk

!------------!
! MP2 energy !
!------------!

  write(*,*)
  write(*,'(A32)')           '---------------------------'
  write(*,'(A32)')           ' GMP2 calculation          '
  write(*,'(A32)')           '---------------------------'
  write(*,'(A32,1X,F16.10)') ' GMP2 correlation energy = ',EcMP2
  write(*,'(A32,1X,F16.10)') ' Direct part             = ',E2d
  write(*,'(A32,1X,F16.10)') ' Exchange part           = ',E2x
  write(*,'(A32)')           '---------------------------'
  write(*,'(A32,1X,F16.10)') ' GMP2 electronic  energy = ',EGHF + EcMP2
  write(*,'(A32,1X,F16.10)') ' GMP2 total       energy = ',ENuc + EGHF + EcMP2
  write(*,'(A32)')           '---------------------------'
  write(*,*)

  if(regularize) then

!-------------------!
! sigma1-MP2 energy !
!-------------------!

    write(*,*)
    write(*,'(A32)')           '---------------------------'
    write(*,'(A32)')           ' sigma-GMP2 calculation    '
    write(*,'(A32)')           '---------------------------'
    write(*,'(A32,1X,F16.10)') ' GMP2 correlation energy = ',EcsMP2
    write(*,'(A32,1X,F16.10)') ' Direct part             = ',E2ds
    write(*,'(A32,1X,F16.10)') ' Exchange part           = ',E2xs
    write(*,'(A32)')           '---------------------------'
    write(*,'(A32,1X,F16.10)') ' GMP2 electronic  energy = ',EGHF + EcsMP2
    write(*,'(A32,1X,F16.10)') ' GMP2 total       energy = ',ENuc + EGHF + EcsMP2
    write(*,'(A32)')           '---------------------------'
    write(*,*)

!--------------------!
! sigma^2-MP2 energy !
!--------------------!

    write(*,*)
    write(*,'(A32)')           '---------------------------'
    write(*,'(A32)')           ' sigma^2-GMP2 calculation  '
    write(*,'(A32)')           '---------------------------'
    write(*,'(A32,1X,F16.10)') ' GMP2 correlation energy = ',Ecs2MP2
    write(*,'(A32,1X,F16.10)') ' Direct part             = ',E2ds2
    write(*,'(A32,1X,F16.10)') ' Exchange part           = ',E2xs2
    write(*,'(A32)')           '---------------------------'
    write(*,'(A32,1X,F16.10)') ' GMP2 electronic  energy = ',EGHF + Ecs2MP2
    write(*,'(A32,1X,F16.10)') ' GMP2 total       energy = ',ENuc + EGHF + Ecs2MP2
    write(*,'(A32)')           '---------------------------'
    write(*,*)

!------------------!
! kappa-MP2 energy !
!------------------!

    write(*,*)
    write(*,'(A32)')           '---------------------------'
    write(*,'(A32)')           ' kappa-GMP2 calculation    '
    write(*,'(A32)')           '---------------------------'
    write(*,'(A32,1X,F16.10)') ' GMP2 correlation energy = ',EckMP2
    write(*,'(A32,1X,F16.10)') ' Direct part             = ',E2dk
    write(*,'(A32,1X,F16.10)') ' Exchange part           = ',-E2xk
    write(*,'(A32)')           '---------------------------'
    write(*,'(A32,1X,F16.10)') ' GMP2 electronic  energy = ',EGHF + EckMP2
    write(*,'(A32,1X,F16.10)') ' GMP2 total       energy = ',ENuc + EGHF + EckMP2
    write(*,'(A32)')           '---------------------------'
    write(*,*)

  end if

  if(dotest) then

    call dump_test_value('G','MP2 correlation energy',EcMP2)

  end if


end subroutine