LCPQ
/
eplf
mirror of https://gitlab.com/scemama/eplf
10
0
Fork 0
Code Issues Releases Wiki Activity

Acceleration

This commit is contained in:
Anthony Scemama 2010-12-17 11:39:42 +01:00
parent 921e8429cd
commit 77ca64c612
1 changed files with 44 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
src/eplf_function.irp.f
View File

@ -97,13 +97,14 @@ END_PROVIDER
integer :: k,l,m,n,p,p2
integer :: ik,il,jk,jl
double precision :: phase,dtemp(2)
integer :: exc(4)
integer :: exc(4), nactive, nactive2
PROVIDE det
PROVIDE elec_num_2
PROVIDE mo_value_prod_p
do k=1,det_num
do l=1,det_num
do l=k,det_num
exc(1) = abs(det_exc(k,l,1))
exc(2) = abs(det_exc(k,l,2))
@ -118,47 +119,49 @@ END_PROVIDER
dtemp(1) = 0.d0
dtemp(2) = 0.d0
do p=1,2
nactive = elec_num_2(p) -mo_closed_num
nactive2 = elec_num_2(p2)-mo_closed_num
p2 = 1+mod(p,2)
if ( exc(3) == 0 ) then
! Closed-open shell interactions
do j=1,mo_closed_num
do n=1,elec_num_2(p)-mo_closed_num
do n=1,nactive
ik = det(n,k,p)
il = det(n,l,p)
dtemp(1) += mo_value_p(ik)* ( &
mo_value_p(il)*mo_eplf_integral_matrix(j,j) - &
mo_value_p(j)*mo_eplf_integral_matrix(j,il) )
dtemp(2) += mo_value_p(ik)*mo_value_p(il)*mo_eplf_integral_matrix(j,j)
dtemp(1) += ( &
mo_value_prod_p(il,ik)*mo_eplf_integral_matrix(j,j) - &
mo_value_prod_p(j,ik)*mo_eplf_integral_matrix(j,il) )
dtemp(2) += mo_value_prod_p(il,ik)*mo_eplf_integral_matrix(j,j)
enddo
enddo
!- Open-closed shell interactions
do m=1,elec_num_2(p)-mo_closed_num
do m=1,nactive
jk = det(m,k,p)
jl = det(m,l,p)
do i=1,mo_closed_num
dtemp(1) += mo_value_p(i)* ( &
mo_value_p(i)*mo_eplf_integral_matrix(jk,jl) - &
mo_value_p(jl)*mo_eplf_integral_matrix(jk,i) )
dtemp(2) += mo_value_p(i)*mo_value_p(i)*mo_eplf_integral_matrix(jk,jl)
dtemp(1) += ( &
mo_value_prod_p(i,i)*mo_eplf_integral_matrix(jl,jk) - &
mo_value_prod_p(i,jl)*mo_eplf_integral_matrix(i,jk) )
dtemp(2) += mo_value_prod_p(i,i)*mo_eplf_integral_matrix(jl,jk)
enddo
enddo
!- Open-open shell interactions
do m=1,elec_num_2(p)-mo_closed_num
do m=1,nactive
jk = det(m,k,p)
jl = det(m,l,p)
do n=1,elec_num_2(p)-mo_closed_num
do n=1,nactive
ik = det(n,k,p)
il = det(n,l,p)
dtemp(1) += mo_value_p(ik)* ( &
mo_value_p(il)*mo_eplf_integral_matrix(jk,jl) - &
mo_value_p(jl)*mo_eplf_integral_matrix(jk,il) )
dtemp(1) += ( &
mo_value_prod_p(il,ik)*mo_eplf_integral_matrix(jl,jk) - &
mo_value_prod_p(jl,ik)*mo_eplf_integral_matrix(il,jk) )
enddo
do n=1,elec_num_2(p2)-mo_closed_num
do n=1,nactive2
ik = det(n,k,p2)
il = det(n,l,p2)
dtemp(2) += mo_value_p(ik)*mo_value_p(il)*mo_eplf_integral_matrix(jk,jl)
dtemp(2) += mo_value_prod_p(ik,il)*mo_eplf_integral_matrix(jl,jk)
enddo
enddo
@ -169,32 +172,32 @@ END_PROVIDER
!- Open-closed shell interactions
do j=1,mo_closed_num
dtemp(1) += mo_value_p(ik)* ( &
mo_value_p(il)*mo_eplf_integral_matrix(j,j) - &
mo_value_p(j)*mo_eplf_integral_matrix(j,il) )
dtemp(2) += mo_value_p(ik)*mo_value_p(il)*mo_eplf_integral_matrix(j,j)
dtemp(1) += ( &
mo_value_prod_p(il,ik)*mo_eplf_integral_matrix(j,j) - &
mo_value_prod_p(j,ik)*mo_eplf_integral_matrix(j,il) )
dtemp(2) += mo_value_prod_p(ik,il)*mo_eplf_integral_matrix(j,j)
enddo
!- Closed-open shell interactions
do i=1,mo_closed_num
dtemp(1) += mo_value_p(i)* ( &
mo_value_p(i)*mo_eplf_integral_matrix(jk,jl) - &
mo_value_p(jl)*mo_eplf_integral_matrix(jk,i) )
dtemp(2) += mo_value_p(i)*mo_value_p(i)*mo_eplf_integral_matrix(jk,jl)
dtemp(1) += ( &
mo_value_prod_p(i,i)*mo_eplf_integral_matrix(jl,jk) - &
mo_value_prod_p(i,jl)*mo_eplf_integral_matrix(i,jk) )
dtemp(2) += mo_value_prod_p(i,i)*mo_eplf_integral_matrix(jl,jk)
enddo
!- Open-open shell interactions
do m=1,elec_num_2(p)-mo_closed_num
do m=1,nactive
jk = det(m,k,p)
jl = det(m,l,p)
dtemp(1) += mo_value_p(ik)* ( &
mo_value_p(il)*mo_eplf_integral_matrix(jk,jl) - &
mo_value_p(jl)*mo_eplf_integral_matrix(jk,il) )
dtemp(1) += ( &
mo_value_prod_p(il,ik)*mo_eplf_integral_matrix(jl,jk) - &
mo_value_prod_p(jl,ik)*mo_eplf_integral_matrix(il,jk) )
enddo
do m=1,elec_num_2(p2)-mo_closed_num
do m=1,nactive2
jk = det(m,k,p2)
jl = det(m,l,p2)
dtemp(2) += mo_value_p(ik)*mo_value_p(il)*mo_eplf_integral_matrix(jk,jl)
dtemp(2) += mo_value_prod_p(ik,il)*mo_eplf_integral_matrix(jl,jk)
enddo
else if ( (exc(3) == 2).and.(exc(p) == 2) ) then
@ -202,9 +205,9 @@ END_PROVIDER
! Consider only the double excitations of same-spin electrons
call get_double_excitation(k,l,ik,il,jk,jl,p)
dtemp(1) += mo_value_p(ik)* ( &
mo_value_p(il)*mo_eplf_integral_matrix(jk,jl) - &
mo_value_p(jl)*mo_eplf_integral_matrix(jk,il) )
dtemp(1) += ( &
mo_value_prod_p(il,ik)*mo_eplf_integral_matrix(jl,jk) - &
mo_value_prod_p(jl,ik)*mo_eplf_integral_matrix(il,jk) )
else if ( (exc(3) == 2).and.(exc(p) == 1) ) then
@ -212,7 +215,7 @@ END_PROVIDER
call get_single_excitation(k,l,ik,il,p)
call get_single_excitation(k,l,jk,jl,p2)
dtemp(2) += mo_value_p(ik)*mo_value_p(il)*mo_eplf_integral_matrix(jk,jl)
dtemp(2) += mo_value_prod_p(ik,il)*mo_eplf_integral_matrix(jl,jk)
endif
enddo
@ -220,6 +223,10 @@ END_PROVIDER
phase = dble(exc(4))
eplf_up_up += phase * det_coef(k)*det_coef(l) * dtemp(1)
eplf_up_dn += phase * det_coef(k)*det_coef(l) * dtemp(2)
if (k /= l) then
eplf_up_up += phase * det_coef(k)*det_coef(l) * dtemp(1)
eplf_up_dn += phase * det_coef(k)*det_coef(l) * dtemp(2)
endif
enddo
enddo