mirror of
https://github.com/pfloos/quack
synced 2024-06-21 12:42:15 +02:00
188 lines
4.3 KiB
Fortran
188 lines
4.3 KiB
Fortran
subroutine MP3(nBas,nEl,ERI,e,ENuc,EHF)
|
|
|
|
! Perform third-order Moller-Plesset calculation
|
|
|
|
implicit none
|
|
|
|
! Input variables
|
|
|
|
integer,intent(in) :: nBas,nEl
|
|
double precision,intent(in) :: ENuc,EHF
|
|
double precision,intent(in) :: e(nBas)
|
|
double precision,intent(in) :: ERI(nBas,nBas,nBas,nBas)
|
|
|
|
! Local variables
|
|
|
|
double precision :: eps,E2,EcMP2
|
|
double precision :: eps1,eps2,E3a,E3b,E3c
|
|
double precision :: EcMP3
|
|
|
|
integer :: nBas2,nO,nV
|
|
integer :: i,j,k,l,a,b,c,d
|
|
|
|
double precision,allocatable :: se(:)
|
|
double precision,allocatable :: eO(:)
|
|
double precision,allocatable :: eV(:)
|
|
|
|
double precision,allocatable :: sERI(:,:,:,:)
|
|
double precision,allocatable :: dbERI(:,:,:,:)
|
|
|
|
double precision,allocatable :: OOOO(:,:,:,:)
|
|
double precision,allocatable :: OOVV(:,:,:,:)
|
|
double precision,allocatable :: OVVO(:,:,:,:)
|
|
double precision,allocatable :: VVOO(:,:,:,:)
|
|
double precision,allocatable :: VVVV(:,:,:,:)
|
|
|
|
|
|
! Hello world
|
|
|
|
write(*,*)
|
|
write(*,*)'************************************************'
|
|
write(*,*)'| Moller-Plesset third-order calculation |'
|
|
write(*,*)'************************************************'
|
|
write(*,*)
|
|
|
|
! Spatial to spin orbitals
|
|
|
|
nBas2 = 2*nBas
|
|
|
|
allocate(se(nBas2),sERI(nBas2,nBas2,nBas2,nBas2))
|
|
|
|
call spatial_to_spin_MO_energy(nBas,e,nBas2,se)
|
|
call spatial_to_spin_ERI(nBas,ERI,nBas2,sERI)
|
|
|
|
! Antysymmetrize ERIs
|
|
|
|
allocate(dbERI(nBas2,nBas2,nBas2,nBas2))
|
|
|
|
call antisymmetrize_ERI(2,nBas2,sERI,dbERI)
|
|
|
|
deallocate(sERI)
|
|
|
|
! Define occupied and virtual spaces
|
|
|
|
nO = nEl
|
|
nV = nBas2 - nO
|
|
|
|
! Form energy denominator
|
|
|
|
allocate(eO(nO),eV(nV))
|
|
|
|
eO(:) = se(1:nO)
|
|
eV(:) = se(nO+1:nBas2)
|
|
|
|
deallocate(se)
|
|
|
|
! Create integral batches
|
|
|
|
allocate(OOOO(nO,nO,nO,nO),OOVV(nO,nO,nV,nV),OVVO(nO,nV,nV,nO),VVOO(nV,nV,nO,nO),VVVV(nV,nV,nV,nV))
|
|
|
|
OOOO(:,:,:,:) = dbERI( 1:nO , 1:nO , 1:nO , 1:nO )
|
|
OOVV(:,:,:,:) = dbERI( 1:nO , 1:nO ,nO+1:nBas2,nO+1:nBas2)
|
|
OVVO(:,:,:,:) = dbERI( 1:nO ,nO+1:nBas2,nO+1:nBas2, 1:nO )
|
|
VVOO(:,:,:,:) = dbERI(nO+1:nBas2,nO+1:nBas2, 1:nO , 1:nO )
|
|
VVVV(:,:,:,:) = dbERI(nO+1:nBas2,nO+1:nBas2,nO+1:nBas2,nO+1:nBas2)
|
|
|
|
deallocate(dbERI)
|
|
|
|
! Compute MP2 energy
|
|
|
|
E2 = 0d0
|
|
|
|
do i=1,nO
|
|
do j=1,nO
|
|
do a=1,nV
|
|
do b=1,nV
|
|
|
|
eps = eO(i) + eO(j) - eV(a) - eV(b)
|
|
|
|
E2 = E2 + OOVV(i,j,a,b)*OOVV(i,j,a,b)/eps
|
|
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
EcMP2 = 0.25d0*E2
|
|
|
|
! Compute MP3 energy
|
|
|
|
E3a = 0d0
|
|
|
|
do i=1,nO
|
|
do j=1,nO
|
|
do k=1,nO
|
|
do l=1,nO
|
|
do a=1,nV
|
|
do b=1,nV
|
|
|
|
eps1 = eO(i) + eO(j) - eV(a) - eV(b)
|
|
eps2 = eO(k) + eO(l) - eV(a) - eV(b)
|
|
|
|
E3a = E3a + OOVV(i,j,a,b)*OOOO(k,l,i,j)*VVOO(a,b,k,l)/(eps1*eps2)
|
|
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
E3b = 0d0
|
|
|
|
do i=1,nO
|
|
do j=1,nO
|
|
do a=1,nV
|
|
do b=1,nV
|
|
do c=1,nV
|
|
do d=1,nV
|
|
|
|
eps1 = eO(i) + eO(j) - eV(a) - eV(b)
|
|
eps2 = eO(i) + eO(j) - eV(c) - eV(d)
|
|
|
|
E3b = E3b + OOVV(i,j,a,b)*VVVV(a,b,c,d)*VVOO(c,d,i,j)/(eps1*eps2)
|
|
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
E3c = 0d0
|
|
|
|
do i=1,nO
|
|
do j=1,nO
|
|
do k=1,nO
|
|
do a=1,nV
|
|
do b=1,nV
|
|
do c=1,nV
|
|
|
|
eps1 = eO(i) + eO(j) - eV(a) - eV(b)
|
|
eps2 = eO(i) + eO(k) - eV(a) - eV(c)
|
|
|
|
E3c = E3c + OOVV(i,j,a,b)*OVVO(k,b,c,j)*VVOO(a,c,i,k)/(eps1*eps2)
|
|
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
EcMP3 = 0.125d0*E3a + 0.125d0*E3b + E3c
|
|
|
|
write(*,*)
|
|
write(*,'(A32)') '-----------------------'
|
|
write(*,'(A32)') ' MP3 calculation '
|
|
write(*,'(A32)') '-----------------------'
|
|
write(*,'(A32,1X,F16.10)') ' MP2 contribution ',EcMP2
|
|
write(*,'(A32,1X,F16.10)') ' MP3 contribution ',EcMP3
|
|
write(*,'(A32)') '-----------------------'
|
|
write(*,'(A32,1X,F16.10)') ' MP3 correlation energy', EcMP2 + EcMP3
|
|
write(*,'(A32,1X,F16.10)') ' MP3 total energy',ENuc + EHF + EcMP2 + EcMP3
|
|
write(*,'(A32)') '-----------------------'
|
|
write(*,*)
|
|
|
|
end subroutine MP3
|