10
0
mirror of https://github.com/LCPQ/quantum_package synced 2024-06-01 19:05:25 +02:00
quantum_package/src/Dets/connected_to_ref.irp.f

421 lines
11 KiB
FortranFixed
Raw Normal View History

2014-09-06 00:51:55 +02:00
integer*8 function det_search_key(det,Nint)
use bitmasks
implicit none
BEGIN_DOC
! Return an integer*8 corresponding to a determinant index for searching
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: det(Nint,2)
integer :: i
det_search_key = iand(det(1,1),det(1,2))
do i=2,Nint
det_search_key = ieor(det_search_key,iand(det(i,1),det(i,2)))
enddo
end
2014-10-15 10:08:00 +02:00
integer*8 function occ_pattern_search_key(det,Nint)
use bitmasks
implicit none
BEGIN_DOC
! Return an integer*8 corresponding to a determinant index for searching
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: det(Nint,2)
integer :: i
occ_pattern_search_key = ieor(det(1,1),det(1,2))
do i=2,Nint
occ_pattern_search_key = ieor(occ_pattern_search_key,iand(det(i,1),det(i,2)))
enddo
end
2015-03-20 00:15:34 +01:00
2014-06-02 16:42:33 +02:00
logical function is_in_wavefunction(key,Nint,Ndet)
2015-03-20 00:15:34 +01:00
use bitmasks
2014-06-02 15:18:45 +02:00
implicit none
2015-03-20 00:15:34 +01:00
BEGIN_DOC
! True if the determinant ``det`` is in the wave function
END_DOC
2014-06-02 16:42:33 +02:00
integer, intent(in) :: Nint, Ndet
2014-06-02 15:18:45 +02:00
integer(bit_kind), intent(in) :: key(Nint,2)
2015-03-20 00:15:34 +01:00
integer, external :: get_index_in_psi_det_sorted_bit
!DIR$ FORCEINLINE
is_in_wavefunction = get_index_in_psi_det_sorted_bit(key,Nint) > 0
end
integer function get_index_in_psi_det_sorted_bit(key,Nint)
use bitmasks
BEGIN_DOC
! Returns the index of the determinant in the ``psi_det_sorted_bit`` array
END_DOC
implicit none
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key(Nint,2)
2014-06-02 15:18:45 +02:00
integer :: i, ibegin, iend, istep, l
integer*8 :: det_ref, det_search
integer*8, external :: det_search_key
2015-03-20 00:15:34 +01:00
logical :: is_in_wavefunction
2014-06-02 15:18:45 +02:00
2015-04-01 13:22:00 +02:00
is_in_wavefunction = .False.
2015-03-20 00:15:34 +01:00
get_index_in_psi_det_sorted_bit = 0
2014-06-02 15:18:45 +02:00
ibegin = 1
2014-06-02 16:42:33 +02:00
iend = N_det+1
2014-06-02 15:18:45 +02:00
2014-09-06 00:51:55 +02:00
!DIR$ FORCEINLINE
2014-06-02 15:18:45 +02:00
det_ref = det_search_key(key,Nint)
2014-09-06 00:51:55 +02:00
!DIR$ FORCEINLINE
2014-06-02 16:42:33 +02:00
det_search = det_search_key(psi_det_sorted_bit(1,1,1),Nint)
2014-06-02 15:18:45 +02:00
2014-06-02 16:42:33 +02:00
istep = ishft(iend-ibegin,-1)
2014-06-02 15:18:45 +02:00
i=ibegin+istep
2014-06-02 16:42:33 +02:00
do while (istep > 0)
2014-09-06 00:51:55 +02:00
!DIR$ FORCEINLINE
2014-06-02 15:18:45 +02:00
det_search = det_search_key(psi_det_sorted_bit(1,1,i),Nint)
if ( det_search > det_ref ) then
iend = i
else if ( det_search == det_ref ) then
exit
else
ibegin = i
endif
2014-06-02 16:42:33 +02:00
istep = ishft(iend-ibegin,-1)
i = ibegin + istep
2014-06-02 15:18:45 +02:00
end do
2014-06-02 16:42:33 +02:00
2014-09-06 00:51:55 +02:00
!DIR$ FORCEINLINE
2014-06-02 15:18:45 +02:00
do while (det_search_key(psi_det_sorted_bit(1,1,i),Nint) == det_ref)
i = i-1
if (i == 0) then
exit
endif
enddo
i += 1
2015-04-02 10:13:33 +02:00
! if (i > N_det) then
! return
! endif
2014-06-02 21:43:55 +02:00
2014-09-06 00:51:55 +02:00
!DIR$ FORCEINLINE
2014-06-02 15:18:45 +02:00
do while (det_search_key(psi_det_sorted_bit(1,1,i),Nint) == det_ref)
if ( (key(1,1) /= psi_det_sorted_bit(1,1,i)).or. &
(key(1,2) /= psi_det_sorted_bit(1,2,i)) ) then
continue
else
is_in_wavefunction = .True.
2015-04-02 10:13:33 +02:00
!DIR$ IVDEP
!DIR$ LOOP COUNT MIN(3)
2014-06-02 15:18:45 +02:00
do l=2,Nint
if ( (key(l,1) /= psi_det_sorted_bit(l,1,i)).or. &
(key(l,2) /= psi_det_sorted_bit(l,2,i)) ) then
is_in_wavefunction = .False.
endif
enddo
if (is_in_wavefunction) then
2015-04-02 10:13:33 +02:00
get_index_in_psi_det_sorted_bit = i
exit
2015-04-02 10:13:33 +02:00
! return
2014-06-02 15:18:45 +02:00
endif
endif
i += 1
2014-06-02 16:42:33 +02:00
if (i > N_det) then
2015-04-02 10:13:33 +02:00
exit
! return
2014-06-02 16:42:33 +02:00
endif
2014-06-02 15:18:45 +02:00
enddo
! DEBUG is_in_wf
2015-04-02 10:13:33 +02:00
if (is_in_wavefunction) then
degree = 1
do i=1,N_det
integer :: degree
call get_excitation_degree(key,psi_det(1,1,i),degree,N_int)
if (degree == 0) then
exit
endif
enddo
if (degree /=0) then
stop 'pouet 1'
endif
else
do i=1,N_det
call get_excitation_degree(key,psi_det(1,1,i),degree,N_int)
if (degree == 0) then
stop 'pouet 2'
endif
enddo
endif
! END DEBUG is_in_wf
2014-06-02 15:18:45 +02:00
end
integer function connected_to_ref(key,keys,Nint,N_past_in,Ndet)
2014-05-21 16:37:54 +02:00
use bitmasks
implicit none
integer, intent(in) :: Nint, N_past_in, Ndet
integer(bit_kind), intent(in) :: keys(Nint,2,Ndet)
integer(bit_kind), intent(in) :: key(Nint,2)
integer :: N_past
integer :: i, l
integer :: degree_x2
logical :: det_is_not_or_may_be_in_ref, t
double precision :: hij_elec
! output : 0 : not connected
! i : connected to determinant i of the past
! -i : is the ith determinant of the refernce wf keys
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
connected_to_ref = 0
N_past = max(1,N_past_in)
if (Nint == 1) then
2014-09-06 00:51:55 +02:00
do i=N_past-1,1,-1
2014-05-21 16:37:54 +02:00
degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + &
popcnt(xor( key(1,2), keys(1,2,i)))
if (degree_x2 > 4) then
2014-05-21 16:37:54 +02:00
cycle
2014-05-28 23:12:00 +02:00
else
connected_to_ref = i
return
2014-05-21 16:37:54 +02:00
endif
enddo
return
2014-06-02 15:18:45 +02:00
2014-05-21 16:37:54 +02:00
else if (Nint==2) then
2014-09-06 00:51:55 +02:00
do i=N_past-1,1,-1
2014-05-21 16:37:54 +02:00
degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + &
popcnt(xor( key(1,2), keys(1,2,i))) + &
popcnt(xor( key(2,1), keys(2,1,i))) + &
popcnt(xor( key(2,2), keys(2,2,i)))
if (degree_x2 > 4) then
2014-05-21 16:37:54 +02:00
cycle
2014-05-28 23:12:00 +02:00
else
connected_to_ref = i
return
2014-05-21 16:37:54 +02:00
endif
enddo
return
else if (Nint==3) then
2014-09-06 00:51:55 +02:00
do i=N_past-1,1,-1
2014-05-21 16:37:54 +02:00
degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + &
popcnt(xor( key(1,2), keys(1,2,i))) + &
popcnt(xor( key(2,1), keys(2,1,i))) + &
popcnt(xor( key(2,2), keys(2,2,i))) + &
popcnt(xor( key(3,1), keys(3,1,i))) + &
popcnt(xor( key(3,2), keys(3,2,i)))
if (degree_x2 > 4) then
2014-05-21 16:37:54 +02:00
cycle
2014-05-28 23:12:00 +02:00
else
connected_to_ref = i
return
2014-05-21 16:37:54 +02:00
endif
enddo
return
else
2014-09-06 00:51:55 +02:00
do i=N_past-1,1,-1
2014-05-21 16:37:54 +02:00
degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + &
popcnt(xor( key(1,2), keys(1,2,i)))
!DEC$ LOOP COUNT MIN(3)
do l=2,Nint
degree_x2 = degree_x2 + popcnt(xor( key(l,1), keys(l,1,i))) +&
popcnt(xor( key(l,2), keys(l,2,i)))
enddo
if (degree_x2 > 4) then
2014-05-21 16:37:54 +02:00
cycle
2014-05-28 23:12:00 +02:00
else
connected_to_ref = i
return
2014-05-21 16:37:54 +02:00
endif
enddo
endif
2014-05-17 14:20:55 +02:00
end
2015-03-19 21:14:52 +01:00
integer function connected_to_ref_by_mono(key,keys,Nint,N_past_in,Ndet)
use bitmasks
implicit none
integer, intent(in) :: Nint, N_past_in, Ndet
integer(bit_kind), intent(in) :: keys(Nint,2,Ndet)
integer(bit_kind), intent(in) :: key(Nint,2)
integer :: N_past
integer :: i, l
integer :: degree_x2
logical :: det_is_not_or_may_be_in_ref, t
double precision :: hij_elec
! output : 0 : not connected
! i : connected to determinant i of the past
! -i : is the ith determinant of the refernce wf keys
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
connected_to_ref_by_mono = 0
N_past = max(1,N_past_in)
if (Nint == 1) then
do i=N_past-1,1,-1
degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + &
popcnt(xor( key(1,2), keys(1,2,i)))
if (degree_x2 > 3.and. degree_x2 <5) then
cycle
else if (degree_x2 == 4)then
cycle
else if(degree_x2 == 2)then
connected_to_ref_by_mono = i
return
endif
enddo
return
else if (Nint==2) then
do i=N_past-1,1,-1
degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + &
popcnt(xor( key(1,2), keys(1,2,i))) + &
popcnt(xor( key(2,1), keys(2,1,i))) + &
popcnt(xor( key(2,2), keys(2,2,i)))
if (degree_x2 > 3.and. degree_x2 <5) then
cycle
else if (degree_x2 == 4)then
cycle
else if(degree_x2 == 2)then
connected_to_ref_by_mono = i
return
endif
enddo
return
else if (Nint==3) then
do i=N_past-1,1,-1
degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + &
popcnt(xor( key(1,2), keys(1,2,i))) + &
popcnt(xor( key(2,1), keys(2,1,i))) + &
popcnt(xor( key(2,2), keys(2,2,i))) + &
popcnt(xor( key(3,1), keys(3,1,i))) + &
popcnt(xor( key(3,2), keys(3,2,i)))
if (degree_x2 > 3.and. degree_x2 <5) then
cycle
else if (degree_x2 == 4)then
cycle
else if(degree_x2 == 2)then
connected_to_ref_by_mono = i
return
endif
enddo
return
else
do i=N_past-1,1,-1
degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + &
popcnt(xor( key(1,2), keys(1,2,i)))
!DEC$ LOOP COUNT MIN(3)
do l=2,Nint
degree_x2 = degree_x2 + popcnt(xor( key(l,1), keys(l,1,i))) +&
popcnt(xor( key(l,2), keys(l,2,i)))
enddo
if (degree_x2 > 3.and. degree_x2 <5) then
cycle
else if (degree_x2 == 4)then
cycle
else if(degree_x2 == 2)then
connected_to_ref_by_mono = i
return
endif
enddo
endif
end
2014-05-17 14:20:55 +02:00
logical function det_is_not_or_may_be_in_ref(key,Nint)
2014-05-21 16:37:54 +02:00
use bitmasks
implicit none
BEGIN_DOC
! If true, det is not in ref
! If false, det may be in ref
END_DOC
2014-05-26 13:09:32 +02:00
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key(Nint,2)
2014-05-21 16:37:54 +02:00
integer(bit_kind) :: key_int
integer*1 :: key_short(bit_kind)
!DIR$ ATTRIBUTES ALIGN : 32 :: key_short
equivalence (key_int,key_short)
integer :: i, ispin, k
det_is_not_or_may_be_in_ref = .False.
do ispin=1,2
do i=1,Nint
key_int = key(i,ispin)
do k=1,bit_kind
det_is_not_or_may_be_in_ref = &
det_is_not_or_may_be_in_ref .or. &
key_pattern_not_in_ref(key_short(k), i, ispin)
enddo
if(det_is_not_or_may_be_in_ref) then
2014-05-17 14:20:55 +02:00
return
2014-05-21 16:37:54 +02:00
endif
enddo
2014-05-17 14:20:55 +02:00
enddo
2014-05-21 16:37:54 +02:00
2014-05-17 14:20:55 +02:00
end
BEGIN_PROVIDER [ logical, key_pattern_not_in_ref, (-128:127,N_int,2) ]
2014-05-21 16:37:54 +02:00
use bitmasks
implicit none
BEGIN_DOC
! Min and max values of the integers of the keys of the reference
END_DOC
integer :: i, j, ispin
integer(bit_kind) :: key
integer*1 :: key_short(bit_kind)
equivalence (key,key_short)
integer :: idx, k
key_pattern_not_in_ref = .True.
do j=1,N_det
do ispin=1,2
do i=1,N_int
key = psi_det(i,ispin,j)
do k=1,bit_kind
key_pattern_not_in_ref( key_short(k), i, ispin ) = .False.
enddo
enddo
enddo
2014-05-17 14:20:55 +02:00
enddo
2014-05-21 16:37:54 +02:00
2014-05-17 14:20:55 +02:00
END_PROVIDER