mirror of
https://github.com/LCPQ/quantum_package
synced 2024-08-16 09:38:31 +02:00
corrected bug in MRCC
This commit is contained in:
parent
c7de30e580
commit
1469822e94
@ -25,8 +25,8 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref,i_ge
|
|||||||
|
|
||||||
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
|
integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected)
|
||||||
integer :: i,j,k,l,m
|
integer :: i,j,k,l,m
|
||||||
integer :: degree_alpha(psi_det_size), degree_alpha_tmp(psi_det_size)
|
integer :: degree_alpha(psi_det_size)
|
||||||
integer :: idx_alpha(0:psi_det_size), idx_alpha_tmp(0:psi_det_size)
|
integer :: idx_alpha(0:psi_det_size)
|
||||||
logical :: good, fullMatch
|
logical :: good, fullMatch
|
||||||
|
|
||||||
integer(bit_kind) :: tq(Nint,2,n_selected)
|
integer(bit_kind) :: tq(Nint,2,n_selected)
|
||||||
@ -74,11 +74,6 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref,i_ge
|
|||||||
call find_triples_and_quadruples_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask)
|
call find_triples_and_quadruples_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask)
|
||||||
else
|
else
|
||||||
call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)
|
call find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)
|
||||||
! microlist(:N_miniList) = minilist(:N_miniList)
|
|
||||||
! idx_microlist(:N_minilist) = idx_minilist(:)
|
|
||||||
! N_microlist(0) = N_miniList
|
|
||||||
! ptr_microlist(1) = 1
|
|
||||||
! ptr_microlist(2) = N_miniList + 1
|
|
||||||
end if
|
end if
|
||||||
|
|
||||||
|
|
||||||
@ -139,41 +134,41 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref,i_ge
|
|||||||
idx_microlist_zero(ptr_microlist(1) + l) = idx_microlist(ptr_microlist(smallerlist) + l)
|
idx_microlist_zero(ptr_microlist(1) + l) = idx_microlist(ptr_microlist(smallerlist) + l)
|
||||||
end do
|
end do
|
||||||
|
|
||||||
call get_excitation_degree_vector(microlist_zero,tq(1,1,i_alpha),degree_alpha_tmp,Nint,N_microlist(smallerlist)+N_microlist(0),idx_alpha_tmp)
|
call get_excitation_degree_vector(microlist_zero,tq(1,1,i_alpha),degree_alpha,Nint,N_microlist(smallerlist)+N_microlist(0),idx_alpha)
|
||||||
do j=1,idx_alpha_tmp(0)
|
do j=1,idx_alpha(0)
|
||||||
idx_alpha_tmp(j) = idx_microlist_zero(idx_alpha_tmp(j))
|
idx_alpha(j) = idx_microlist_zero(idx_alpha(j))
|
||||||
end do
|
end do
|
||||||
|
|
||||||
|
|
||||||
i = 1
|
! i = 1
|
||||||
j = 2
|
! j = 2
|
||||||
do j = 2, idx_alpha_tmp(0)
|
! do j = 2, idx_alpha_tmp(0)
|
||||||
if(idx_alpha_tmp(j) < idx_alpha_tmp(j-1)) exit
|
! if(idx_alpha_tmp(j) < idx_alpha_tmp(j-1)) exit
|
||||||
end do
|
! end do
|
||||||
|
!
|
||||||
m = j
|
! m = j
|
||||||
|
!
|
||||||
idx_alpha(0) = idx_alpha_tmp(0)
|
! idx_alpha(0) = idx_alpha_tmp(0)
|
||||||
|
!
|
||||||
do l = 1, idx_alpha(0)
|
! do l = 1, idx_alpha(0)
|
||||||
if(j > idx_alpha_tmp(0)) then
|
! if(j > idx_alpha_tmp(0)) then
|
||||||
k = i
|
! k = i
|
||||||
i += 1
|
! i += 1
|
||||||
else if(i >= m) then
|
! else if(i >= m) then
|
||||||
k = j
|
! k = j
|
||||||
j += 1
|
! j += 1
|
||||||
else if(idx_alpha_tmp(i) < idx_alpha_tmp(j)) then
|
! else if(idx_alpha_tmp(i) < idx_alpha_tmp(j)) then
|
||||||
k = i
|
! k = i
|
||||||
i += 1
|
! i += 1
|
||||||
else
|
! else
|
||||||
k = j
|
! k = j
|
||||||
j += 1
|
! j += 1
|
||||||
end if
|
! end if
|
||||||
|
! ! k=l
|
||||||
idx_alpha(l) = idx_alpha_tmp(k)
|
! idx_alpha(l) = idx_alpha_tmp(k)
|
||||||
degree_alpha(l) = degree_alpha_tmp(k)
|
! degree_alpha(l) = degree_alpha_tmp(k)
|
||||||
end do
|
! end do
|
||||||
|
!
|
||||||
else
|
else
|
||||||
call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
|
call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
|
||||||
do j=1,idx_alpha(0)
|
do j=1,idx_alpha(0)
|
||||||
@ -240,32 +235,17 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref,i_ge
|
|||||||
tmp_det(k,1) = psi_ref(k,1,i_I)
|
tmp_det(k,1) = psi_ref(k,1,i_I)
|
||||||
tmp_det(k,2) = psi_ref(k,2,i_I)
|
tmp_det(k,2) = psi_ref(k,2,i_I)
|
||||||
enddo
|
enddo
|
||||||
! Hole (see list_to_bitstring)
|
|
||||||
iint = ishft(h1-1,-bit_kind_shift) + 1
|
|
||||||
ipos = h1-ishft((iint-1),bit_kind_shift)-1
|
|
||||||
tmp_det(iint,s1) = ibclr(tmp_det(iint,s1),ipos)
|
|
||||||
|
|
||||||
! Particle
|
logical :: ok
|
||||||
iint = ishft(p1-1,-bit_kind_shift) + 1
|
call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint)
|
||||||
ipos = p1-ishft((iint-1),bit_kind_shift)-1
|
if(.not. ok) cycle
|
||||||
tmp_det(iint,s1) = ibset(tmp_det(iint,s1),ipos)
|
|
||||||
if (degree_alpha(k_sd) == 2) then
|
|
||||||
! Hole (see list_to_bitstring)
|
|
||||||
iint = ishft(h2-1,-bit_kind_shift) + 1
|
|
||||||
ipos = h2-ishft((iint-1),bit_kind_shift)-1
|
|
||||||
tmp_det(iint,s2) = ibclr(tmp_det(iint,s2),ipos)
|
|
||||||
|
|
||||||
! Particle
|
|
||||||
iint = ishft(p2-1,-bit_kind_shift) + 1
|
|
||||||
ipos = p2-ishft((iint-1),bit_kind_shift)-1
|
|
||||||
tmp_det(iint,s2) = ibset(tmp_det(iint,s2),ipos)
|
|
||||||
endif
|
|
||||||
|
|
||||||
! <I| \l/ |alpha>
|
! <I| \l/ |alpha>
|
||||||
do i_state=1,Nstates
|
do i_state=1,Nstates
|
||||||
dka(i_state) = 0.d0
|
dka(i_state) = 0.d0
|
||||||
enddo
|
enddo
|
||||||
do l_sd=k_sd+1,idx_alpha(0)
|
do l_sd=k_sd+1,idx_alpha(0)
|
||||||
|
|
||||||
call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint)
|
call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint)
|
||||||
if (degree == 0) then
|
if (degree == 0) then
|
||||||
|
|
||||||
@ -279,11 +259,12 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref,i_ge
|
|||||||
if (.not.loop) then
|
if (.not.loop) then
|
||||||
call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint)
|
call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint)
|
||||||
hIl = hij_mrcc(idx_alpha(l_sd),i_I)
|
hIl = hij_mrcc(idx_alpha(l_sd),i_I)
|
||||||
! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl)
|
! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl)
|
||||||
do i_state=1,Nstates
|
do i_state=1,Nstates
|
||||||
dka(i_state) = hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2
|
dka(i_state) = hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2
|
||||||
enddo
|
enddo
|
||||||
endif
|
endif
|
||||||
|
|
||||||
exit
|
exit
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
@ -324,6 +305,9 @@ end
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
subroutine find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList)
|
subroutine find_triples_and_quadruples(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList)
|
||||||
|
|
||||||
use bitmasks
|
use bitmasks
|
||||||
|
@ -1,25 +1,69 @@
|
|||||||
|
! BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ]
|
||||||
|
! implicit none
|
||||||
|
! BEGIN_DOC
|
||||||
|
! ! cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m)
|
||||||
|
! END_DOC
|
||||||
|
! integer :: i,k
|
||||||
|
! double precision :: ihpsi(N_states),ihpsi_current(N_states)
|
||||||
|
! integer :: i_pert_count
|
||||||
|
!
|
||||||
|
! i_pert_count = 0
|
||||||
|
! lambda_mrcc = 0.d0
|
||||||
|
!
|
||||||
|
! do i=1,N_det_non_ref
|
||||||
|
! call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,size(psi_ref_coef,1), n_states, ihpsi_current)
|
||||||
|
! do k=1,N_states
|
||||||
|
! if (ihpsi_current(k) == 0.d0) then
|
||||||
|
! ihpsi_current(k) = 1.d-32
|
||||||
|
! endif
|
||||||
|
! if(dabs(ihpsi_current(k) * psi_non_ref_coef(i,k)) < 1d-6) then
|
||||||
|
! i_pert_count +=1
|
||||||
|
! else
|
||||||
|
! lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k)
|
||||||
|
! endif
|
||||||
|
! enddo
|
||||||
|
! enddo
|
||||||
|
!
|
||||||
|
! print*,'N_det_non_ref = ',N_det_non_ref
|
||||||
|
! print*,'Number of ignored determinants = ',i_pert_count
|
||||||
|
! print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1)
|
||||||
|
! END_PROVIDER
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ]
|
BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ]
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m)
|
! cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m)
|
||||||
END_DOC
|
END_DOC
|
||||||
integer :: i,k
|
integer :: i,k
|
||||||
double precision :: ihpsi(N_states),ihpsi_current(N_states)
|
double precision :: ihpsi_current(N_states)
|
||||||
integer :: i_pert_count
|
integer :: i_pert_count
|
||||||
|
double precision :: hii, lambda_pert
|
||||||
|
|
||||||
i_pert_count = 0
|
i_pert_count = 0
|
||||||
lambda_mrcc = 0.d0
|
lambda_mrcc = 0.d0
|
||||||
|
|
||||||
do i=1,N_det_non_ref
|
do i=1,N_det_non_ref
|
||||||
call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,size(psi_ref_coef,1), n_states, ihpsi_current)
|
call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref, &
|
||||||
|
size(psi_ref_coef,1), N_states,ihpsi_current)
|
||||||
|
call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii)
|
||||||
do k=1,N_states
|
do k=1,N_states
|
||||||
if (ihpsi_current(k) == 0.d0) then
|
if (ihpsi_current(k) == 0.d0) then
|
||||||
ihpsi_current(k) = 1.d-32
|
ihpsi_current(k) = 1.d-32
|
||||||
endif
|
endif
|
||||||
if(dabs(ihpsi_current(k) * psi_non_ref_coef(i,k)) < 1d-5) then
|
|
||||||
i_pert_count +=1
|
|
||||||
else
|
|
||||||
lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k)
|
lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k)
|
||||||
|
if ( dabs(psi_non_ref_coef(i,k)*ihpsi_current(k)) < 1.d-6 ) then
|
||||||
|
i_pert_count += 1
|
||||||
|
lambda_mrcc(k,i) = 0.d0
|
||||||
|
! lambda_pert = 1.d0 / (psi_ref_energy_diagonalized(k)-hii)
|
||||||
|
! if((ihpsi_current(k) * lambda_pert) < 0.5d0 * psi_non_ref_coef_restart(i,k) ) then
|
||||||
|
! lambda_mrcc(k,i) = 0.d0
|
||||||
|
! endif
|
||||||
|
endif
|
||||||
|
double precision, parameter :: x = 2.d0
|
||||||
|
if (lambda_mrcc(k,i) > x) then
|
||||||
|
lambda_mrcc(k,i) = x
|
||||||
|
else if (lambda_mrcc(k,i) < -x) then
|
||||||
|
lambda_mrcc(k,i) = -x
|
||||||
endif
|
endif
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
@ -27,11 +71,11 @@ BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ]
|
|||||||
print*,'N_det_non_ref = ',N_det_non_ref
|
print*,'N_det_non_ref = ',N_det_non_ref
|
||||||
print*,'Number of ignored determinants = ',i_pert_count
|
print*,'Number of ignored determinants = ',i_pert_count
|
||||||
print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1)
|
print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1)
|
||||||
|
print*,'lambda min/max = ',maxval(dabs(lambda_mrcc)), minval(dabs(lambda_mrcc))
|
||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
!BEGIN_PROVIDER [ double precision, delta_ij_non_ref, (N_det_non_ref, N_det_non_ref,N_states) ]
|
!BEGIN_PROVIDER [ double precision, delta_ij_non_ref, (N_det_non_ref, N_det_non_ref,N_states) ]
|
||||||
!implicit none
|
!implicit none
|
||||||
!BEGIN_DOC
|
!BEGIN_DOC
|
||||||
|
@ -1728,3 +1728,55 @@ subroutine H_u_0(v_0,u_0,H_jj,n,keys_tmp,Nint)
|
|||||||
deallocate (shortcut, sort_idx, sorted, version)
|
deallocate (shortcut, sort_idx, sorted, version)
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
|
subroutine apply_excitation(det, exc, res, ok, Nint)
|
||||||
|
use bitmasks
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(in) :: Nint
|
||||||
|
integer, intent(in) :: exc(0:2,2,2)
|
||||||
|
integer(bit_kind),intent(in) :: det(Nint, 2)
|
||||||
|
integer(bit_kind),intent(out) :: res(Nint, 2)
|
||||||
|
logical, intent(out) :: ok
|
||||||
|
integer :: h1,p1,h2,p2,s1,s2,degree
|
||||||
|
integer :: ii, pos
|
||||||
|
|
||||||
|
|
||||||
|
ok = .false.
|
||||||
|
degree = exc(0,1,1) + exc(0,1,2)
|
||||||
|
|
||||||
|
if(.not. (degree > 0 .and. degree <= 2)) then
|
||||||
|
print *, degree
|
||||||
|
print *, "apply ex"
|
||||||
|
STOP
|
||||||
|
endif
|
||||||
|
|
||||||
|
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
|
||||||
|
res = det
|
||||||
|
|
||||||
|
ii = (h1-1)/bit_kind_size + 1
|
||||||
|
pos = mod(h1-1, 64)!iand(h1-1,bit_kind_size-1) ! mod 64
|
||||||
|
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return
|
||||||
|
res(ii, s1) = ibclr(res(ii, s1), pos)
|
||||||
|
|
||||||
|
ii = (p1-1)/bit_kind_size + 1
|
||||||
|
pos = mod(p1-1, 64)!iand(p1-1,bit_kind_size-1)
|
||||||
|
if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return
|
||||||
|
res(ii, s1) = ibset(res(ii, s1), pos)
|
||||||
|
|
||||||
|
if(degree == 2) then
|
||||||
|
ii = (h2-1)/bit_kind_size + 1
|
||||||
|
pos = mod(h2-1, 64)!iand(h2-1,bit_kind_size-1)
|
||||||
|
if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return
|
||||||
|
res(ii, s2) = ibclr(res(ii, s2), pos)
|
||||||
|
|
||||||
|
ii = (p2-1)/bit_kind_size + 1
|
||||||
|
pos = mod(p2-1, 64)!iand(p2-1,bit_kind_size-1)
|
||||||
|
if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return
|
||||||
|
res(ii, s2) = ibset(res(ii, s2), pos)
|
||||||
|
endif
|
||||||
|
|
||||||
|
ok = .true.
|
||||||
|
end subroutine
|
||||||
|
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user