10
0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-11-19 04:22:32 +01:00
QuantumPackage/src/casscf/tot_en.irp.f
2019-06-26 00:58:17 +02:00

102 lines
2.9 KiB
Fortran

BEGIN_PROVIDER [real*8, etwo]
&BEGIN_PROVIDER [real*8, eone]
&BEGIN_PROVIDER [real*8, eone_bis]
&BEGIN_PROVIDER [real*8, etwo_bis]
&BEGIN_PROVIDER [real*8, etwo_ter]
&BEGIN_PROVIDER [real*8, ecore]
&BEGIN_PROVIDER [real*8, ecore_bis]
implicit none
integer :: t,u,v,x,i,ii,tt,uu,vv,xx,j,jj,t3,u3,v3,x3
real*8 :: e_one_all,e_two_all
e_one_all=0.D0
e_two_all=0.D0
do i=1,n_core_orb
ii=list_core(i)
e_one_all+=2.D0*mo_one_e_integrals(ii,ii)
do j=1,n_core_orb
jj=list_core(j)
e_two_all+=2.D0*bielec_PQxx(ii,ii,j,j)-bielec_PQxx(ii,jj,j,i)
end do
do t=1,n_act_orb
tt=list_act(t)
t3=t+n_core_orb
do u=1,n_act_orb
uu=list_act(u)
u3=u+n_core_orb
e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) &
-bielec_PQxx(tt,ii,i,u3))
end do
end do
end do
do t=1,n_act_orb
tt=list_act(t)
do u=1,n_act_orb
uu=list_act(u)
e_one_all+=D0tu(t,u)*mo_one_e_integrals(tt,uu)
do v=1,n_act_orb
v3=v+n_core_orb
do x=1,n_act_orb
x3=x+n_core_orb
e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxx(tt,uu,v3,x3)
end do
end do
end do
end do
ecore =nuclear_repulsion
ecore_bis=nuclear_repulsion
do i=1,n_core_orb
ii=list_core(i)
ecore +=2.D0*mo_one_e_integrals(ii,ii)
ecore_bis+=2.D0*mo_one_e_integrals(ii,ii)
do j=1,n_core_orb
jj=list_core(j)
ecore +=2.D0*bielec_PQxx(ii,ii,j,j)-bielec_PQxx(ii,jj,j,i)
ecore_bis+=2.D0*bielec_PxxQ(ii,i,j,jj)-bielec_PxxQ(ii,j,j,ii)
end do
end do
eone =0.D0
eone_bis=0.D0
etwo =0.D0
etwo_bis=0.D0
etwo_ter=0.D0
do t=1,n_act_orb
tt=list_act(t)
t3=t+n_core_orb
do u=1,n_act_orb
uu=list_act(u)
u3=u+n_core_orb
eone +=D0tu(t,u)*mo_one_e_integrals(tt,uu)
eone_bis+=D0tu(t,u)*mo_one_e_integrals(tt,uu)
do i=1,n_core_orb
ii=list_core(i)
eone +=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) &
-bielec_PQxx(tt,ii,i,u3))
eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQ(tt,u3,i,ii) &
-bielec_PxxQ(tt,i,i,uu))
end do
do v=1,n_act_orb
vv=list_act(v)
v3=v+n_core_orb
do x=1,n_act_orb
xx=list_act(x)
x3=x+n_core_orb
real*8 :: h1,h2,h3
h1=bielec_PQxx(tt,uu,v3,x3)
h2=bielec_PxxQ(tt,u3,v3,xx)
h3=bielecCI(t,u,v,xx)
etwo +=P0tuvx(t,u,v,x)*h1
etwo_bis+=P0tuvx(t,u,v,x)*h2
etwo_ter+=P0tuvx(t,u,v,x)*h3
if ((h1.ne.h2).or.(h1.ne.h3)) then
write(6,9901) t,u,v,x,h1,h2,h3
9901 format('aie: ',4I4,3E20.12)
end if
end do
end do
end do
end do
END_PROVIDER