4
1
mirror of https://github.com/pfloos/quack synced 2024-06-02 11:25:28 +02:00
quack/src/MP/UMP2.f90

168 lines
4.2 KiB
Fortran
Raw Permalink Normal View History

2023-11-11 23:00:00 +01:00
subroutine UMP2(dotest,nBas,nC,nO,nV,nR,ERI_aa,ERI_ab,ERI_bb,ENuc,EUHF,eHF,Ec)
2020-09-18 13:52:35 +02:00
! Perform unrestricted second-order Moller-Plesset calculation
implicit none
include 'parameters.h'
! Input variables
2023-11-11 23:00:00 +01:00
logical,intent(in) :: dotest
2020-09-18 13:52:35 +02:00
integer,intent(in) :: nBas
integer,intent(in) :: nC(nspin)
integer,intent(in) :: nO(nspin)
integer,intent(in) :: nV(nspin)
integer,intent(in) :: nR(nspin)
double precision,intent(in) :: ENuc
2023-11-11 23:00:00 +01:00
double precision,intent(in) :: EUHF
2020-09-18 13:52:35 +02:00
double precision,intent(in) :: ERI_aa(nBas,nBas,nBas,nBas)
double precision,intent(in) :: ERI_ab(nBas,nBas,nBas,nBas)
double precision,intent(in) :: ERI_bb(nBas,nBas,nBas,nBas)
2023-11-11 23:00:00 +01:00
double precision,intent(in) :: eHF(nBas,nspin)
2020-09-18 13:52:35 +02:00
! Local variables
integer :: bra,ket
integer :: i,j,a,b
double precision :: eps
double precision :: Edaa,Exaa,Ecaa
double precision :: Edab,Exab,Ecab
double precision :: Edbb,Exbb,Ecbb
double precision :: Ed,Ex
! Output variables
2023-10-27 13:35:10 +02:00
double precision,intent(out) :: Ec(nsp)
2020-09-18 13:52:35 +02:00
! Hello world
write(*,*)
2023-11-11 23:00:00 +01:00
write(*,*)'********************************'
write(*,*)'* Unrestricted MP2 Calculation *'
write(*,*)'********************************'
2020-09-18 13:52:35 +02:00
write(*,*)
!---------------------!
! Compute UMP2 energy |
!---------------------!
! aaaa block
bra = 1
ket = 1
Edaa = 0d0
Exaa = 0d0
do i=nC(bra)+1,nO(bra)
do a=nO(bra)+1,nBas-nR(bra)
do j=nC(ket)+1,nO(ket)
do b=nO(ket)+1,nBas-nR(ket)
2023-11-11 23:00:00 +01:00
eps = eHF(i,bra) + eHF(j,ket) - eHF(a,bra) - eHF(b,ket)
2020-09-18 13:52:35 +02:00
Edaa = Edaa + 0.5d0*ERI_aa(i,j,a,b)*ERI_aa(i,j,a,b)/eps
Exaa = Exaa - 0.5d0*ERI_aa(i,j,a,b)*ERI_aa(i,j,b,a)/eps
2023-12-03 18:47:30 +01:00
end do
end do
end do
end do
2020-09-18 13:52:35 +02:00
Ecaa = Edaa + Exaa
2021-03-07 22:44:37 +01:00
Ec(1) = Ecaa
2020-09-18 13:52:35 +02:00
! aabb block
bra = 1
ket = 2
Edab = 0d0
Exab = 0d0
do i=nC(bra)+1,nO(bra)
do a=nO(bra)+1,nBas-nR(bra)
do j=nC(ket)+1,nO(ket)
do b=nO(ket)+1,nBas-nR(ket)
2023-11-11 23:00:00 +01:00
eps = eHF(i,bra) + eHF(j,ket) - eHF(a,bra) - eHF(b,ket)
2020-09-18 13:52:35 +02:00
Edab = Edab + ERI_ab(i,j,a,b)*ERI_ab(i,j,a,b)/eps
2023-12-03 18:47:30 +01:00
end do
end do
end do
end do
2020-09-18 13:52:35 +02:00
Ecab = Edab + Exab
2021-03-07 22:44:37 +01:00
Ec(2) = Ecab
2020-09-18 13:52:35 +02:00
! bbbb block
bra = 2
ket = 2
Edbb = 0d0
Exbb = 0d0
do i=nC(bra)+1,nO(bra)
do a=nO(bra)+1,nBas-nR(bra)
do j=nC(ket)+1,nO(ket)
do b=nO(ket)+1,nBas-nR(ket)
2023-11-11 23:00:00 +01:00
eps = eHF(i,bra) + eHF(j,ket) - eHF(a,bra) - eHF(b,ket)
2020-09-18 13:52:35 +02:00
Edbb = Edbb + 0.5d0*ERI_bb(i,j,a,b)*ERI_bb(i,j,a,b)/eps
Exbb = Exbb - 0.5d0*ERI_bb(i,j,a,b)*ERI_bb(i,j,b,a)/eps
2023-12-03 18:47:30 +01:00
end do
end do
end do
end do
2020-09-18 13:52:35 +02:00
Ecbb = Edbb + Exbb
2021-03-07 22:44:37 +01:00
Ec(3) = Ecbb
2020-09-18 13:52:35 +02:00
! Final flush
Ed = Edaa + Edab + Edbb
Ex = Exaa + Exab + Exbb
write(*,*)
write(*,'(A32)') '--------------------------'
write(*,'(A32)') ' MP2 calculation '
write(*,'(A32)') '--------------------------'
2021-03-07 22:44:37 +01:00
write(*,'(A32,1X,F16.10)') ' MP2 correlation energy = ',sum(Ec(:))
2020-09-18 13:52:35 +02:00
write(*,'(A32,1X,F16.10)') ' alpha-alpha = ',Ecaa
write(*,'(A32,1X,F16.10)') ' alpha-beta = ',Ecab
write(*,'(A32,1X,F16.10)') ' beta-beta = ',Ecbb
write(*,*)
write(*,'(A32,1X,F16.10)') ' Direct part = ',Ed
write(*,'(A32,1X,F16.10)') ' alpha-alpha = ',Edaa
write(*,'(A32,1X,F16.10)') ' alpha-beta = ',Edab
write(*,'(A32,1X,F16.10)') ' beta-beta = ',Edbb
write(*,*)
write(*,'(A32,1X,F16.10)') ' Exchange part = ',Ex
write(*,'(A32,1X,F16.10)') ' alpha-alpha = ',Exaa
write(*,'(A32,1X,F16.10)') ' alpha-beta = ',Exab
write(*,'(A32,1X,F16.10)') ' beta-beta = ',Exbb
write(*,'(A32)') '--------------------------'
2023-11-11 23:00:00 +01:00
write(*,'(A32,1X,F16.10)') ' MP2 electronic energy = ', EUHF + sum(Ec(:))
write(*,'(A32,1X,F16.10)') ' MP2 total energy = ',ENuc + EUHF + sum(Ec(:))
2020-09-18 13:52:35 +02:00
write(*,'(A32)') '--------------------------'
write(*,*)
2023-11-11 23:00:00 +01:00
if(dotest) then
2023-11-14 14:31:27 +01:00
call dump_test_value('U','MP2 correlation energy',sum(Ec))
2023-11-11 23:00:00 +01:00
end if
2023-07-17 14:50:16 +02:00
end subroutine