LCPQ
/
quantum_package
mirror of https://github.com/LCPQ/quantum_package
10
0
Fork 0
Code Issues Releases Wiki Activity

experimental (not working) delta_cancel

This commit is contained in:
Yann Garniron 2017-10-17 16:05:51 +02:00
parent b5750ed87b
commit 59976b6c58
1 changed files with 80 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
plugins/mrcepa0/dressing.irp.f
View File

@ -2,6 +2,73 @@ use bitmasks
BEGIN_PROVIDER [ double precision, delta_ij_cancel, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii_cancel, (N_states, N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ij_s2_cancel, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii_s2_cancel, (N_states, N_det_ref) ]
use bitmasks
implicit none
integer :: i_state, i, i_I, J, k, k2, k1, kk, ll, m,l, deg, ni, m2
integer :: n(2)
integer :: p1,p2,h1,h2,s1,s2, blok, I_s, J_s, kn
logical :: ok
double precision :: phase_ia, phase_Ik, phase_Jl, phase_Ji,phase_la, phase_ka, phase_tmp
double precision :: Hka, Hla, Ska, Sla, tmp
double precision :: diI, hIi, hJi, delta_JI, dkI, HkI,ci_inv(N_states), cj_inv(N_states)
double precision :: contrib, contrib_s2, wall, iwall
integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ, exc
integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2),inac, virt
integer, external :: get_index_in_psi_det_sorted_bit, searchDet,detCmp
logical, external :: is_in_wavefunction
do i=1,N_det_ref
!$OMP PARALLEL DO default(shared) private(kk, k, blok, exc_Ik,det_tmp2,ok,deg,phase_Ik, l,ll) &
!$OMP private(contrib, contrib_s2, i_state)
do kk = 1, nlink(i)
k = det_cepa0_idx(linked(kk, i))
blok = blokMwen(kk, i)
call get_excitation(psi_ref(1,1,i),psi_non_ref(1,1,k),exc_Ik,deg,phase_Ik,N_int)
do j=1,N_det_ref
if(j == i) cycle
call apply_excitation(psi_ref(1,1,J),exc_Ik,det_tmp2,ok,N_int)
if(.not. ok) cycle
l = searchDet(det_cepa0(1,1,cepa0_shortcut(blok)), det_tmp2,cepa0_shortcut(blok+1)-cepa0_shortcut(blok), N_int)
if(l == -1) cycle
ll = cepa0_shortcut(blok)-1+l
l = det_cepa0_idx(ll)
ll = child_num(ll, J)
do i_state = 1, N_states
contrib = (dij(j, l, i_state) - dij(i, k, i_state)) * delta_cas(i,j,i_state)! * Hla *phase_ia * phase_ik
contrib_s2 = dij(j, l, i_state) - dij(i, k, i_state)! * Sla*phase_ia * phase_ik
if(dabs(psi_ref_coef(i,i_state)).ge.1.d-3) then
!$OMP ATOMIC
delta_ij_cancel(i_state,l,i) += contrib
!$OMP ATOMIC
delta_ij_s2_cancel(i_state,l,i) += contrib_s2
!$OMP ATOMIC
delta_ii_cancel(i_state,i) -= contrib / psi_ref_coef(i, i_state) * psi_non_ref_coef(l,i_state)
!$OMP ATOMIC
delta_ii_s2_cancel(i_state,i) -= contrib_s2 / psi_ref_coef(i, i_state) * psi_non_ref_coef(l,i_state)
else
!$OMP ATOMIC
delta_ij_cancel(i_state,l,i) += contrib * 0.5d0
!$OMP ATOMIC
delta_ij_s2_cancel(i_state,l,i) += contrib_s2 * 0.5d0
endif
end do
end do
end do
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, delta_ij_mrcc, (N_states,N_det_non_ref,N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ii_mrcc, (N_states, N_det_ref) ]
&BEGIN_PROVIDER [ double precision, delta_ij_s2_mrcc, (N_states,N_det_non_ref,N_det_ref) ]
@ -407,6 +474,19 @@ end
else
stop "invalid mrmode"
end if
if(mrmode == 2 .or. mrmode == 3) then
do i = 1, N_det_ref
do i_state = 1, N_states
delta_ii(i_state,i) += delta_ii_cancel(i_state,i)
enddo
do j = 1, N_det_non_ref
do i_state = 1, N_states
delta_ij(i_state,j,i) += delta_ij_cancel(i_state,j,i)
enddo
end do
end do
end if
END_PROVIDER