LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-07-03 18:05:59 +02:00
Code Issues Releases Wiki Activity

removed duplicate determinants - questionable efficiency

Browse Source
This commit is contained in:
Yann Garniron 2018-02-15 14:07:20 +01:00
parent a828a1c5c8
commit 5bd59241fa
2 changed files with 26 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
plugins/dress_zmq/alpha_factory.irp.f
View File

@ -366,11 +366,14 @@ subroutine alpha_callback_mask(delta_ij_loc, sp, mask, bannedOrb, banned, indexe
integer(bit_kind) :: alpha(N_int, 2, 1)
integer, allocatable :: labuf(:)
logical :: ok
integer :: i,j,s,st1,st2,st3,st4
integer :: i,j,k,s,st1,st2,st3,st4
integer :: lindex(mo_tot_num,2), lindex_end(mo_tot_num, 2)
integer :: s1, s2, stamo
logical,allocatable :: putten(:)
allocate(labuf(N_det), putten(N_det))
putten = .false.
allocate(labuf(N_det))
st1 = indexes_end(0,0)
if(st1 > 0) labuf(:st1) = abuf(:st1)
st1 += 1
@ -403,6 +406,9 @@ subroutine alpha_callback_mask(delta_ij_loc, sp, mask, bannedOrb, banned, indexe
if(lindex(i,s1) /= 0) then
st2 = st1 + 1 + lindex_end(i,s1)-lindex(i,s1)
labuf(st1:st2-1) = abuf(lindex(i,s1):lindex_end(i,s1))
do j=st1,st2-1
putten(labuf(j)) = .true.
end do
else
st2 = st1
end if
@ -416,8 +422,15 @@ subroutine alpha_callback_mask(delta_ij_loc, sp, mask, bannedOrb, banned, indexe
do j=stamo,mo_tot_num
if(bannedOrb(j,s2) .or. banned(i,j)) cycle
if(lindex(j,s2) /= 0) then
st3 = st2 + 1 + lindex_end(j,s2)-lindex(j,s2)
labuf(st2:st3-1) = abuf(lindex(j,s2):lindex_end(j,s2))
st3 = st2
do k=lindex(j,s2), lindex_end(j,s2)
if(.not. putten(abuf(k))) then
labuf(st3) = abuf(k)
st3 += 1
end if
end do
!st3 = st2 + 1 + lindex_end(j,s2)-lindex(j,s2)
!labuf(st2:st3-1) = abuf(lindex(j,s2):lindex_end(j,s2))
else
st3 = st2
end if
@ -437,6 +450,13 @@ subroutine alpha_callback_mask(delta_ij_loc, sp, mask, bannedOrb, banned, indexe
!call dress_with_alpha_buffer(delta_ij_loc, abuf, siz, alpha, 1)
end if
end do
if(lindex(i,s1) /= 0) then
do j=st1,st2-1
putten(labuf(j)) = .false.
end do
end if
end do
end subroutine

4
plugins/mrcc_sto/mrcc_dress.irp.f
View File

@ -23,12 +23,12 @@ subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, abuf, n_a
testc = 0
do i=1,N_det
call get_excitation_degree(psi_det_sorted(1,1,i), abuf(1,1,a), deg, N_int)
if(deg <= 2) refc(i) = 1
if(deg <= 2) refc(i) = refc(i) + 1
end do
do i=1,n_minilist
call get_excitation_degree(psi_det_sorted(1,1,minilist(i)), abuf(1,1,a), deg, N_int)
if(deg <= 2) then
testc(minilist(i)) = 1
testc(minilist(i)) += 1
else
stop "NON LIKED"
end if