mirror of
https://github.com/LCPQ/quantum_package
synced 2025-01-03 10:05:57 +01:00
bitstring_to_list_ab
This commit is contained in:
parent
26d02019ed
commit
007e234997
@ -18,13 +18,13 @@ program mp2_wf
|
||||
call H_apply_mp2_selection(pt2, norm_pert, H_pert_diag, N_st)
|
||||
psi_det = psi_det_sorted
|
||||
psi_coef = psi_coef_sorted
|
||||
touch N_det psi_det psi_coef
|
||||
print*,'N_det = ',N_det
|
||||
print*,'-----'
|
||||
print *, 'PT2 = ', pt2(1)
|
||||
print *, 'E = ', HF_energy
|
||||
print *, 'E_before +PT2 = ', HF_energy+pt2(1)
|
||||
N_det = min(N_det,N_det_max)
|
||||
touch N_det psi_det psi_coef
|
||||
call save_wavefunction
|
||||
call ezfio_set_mp2_energy(HF_energy+pt2(1))
|
||||
deallocate(pt2,norm_pert,H_pert_diag)
|
||||
|
||||
@ -60,7 +60,7 @@ class H_apply(object):
|
||||
s["omp_master"] = "!$OMP MASTER"
|
||||
s["omp_end_master"] = "!$OMP END MASTER"
|
||||
s["omp_barrier"] = "!$OMP BARRIER"
|
||||
s["omp_do"] = "!$OMP DO SCHEDULE (static)"
|
||||
s["omp_do"] = "!$OMP DO SCHEDULE (static,1)"
|
||||
s["omp_enddo"] = "!$OMP ENDDO NOWAIT"
|
||||
|
||||
d = { True : '.True.', False : '.False.'}
|
||||
|
||||
@ -71,7 +71,6 @@
|
||||
one_body_dm_mo_beta = one_body_dm_mo_beta + tmp_b
|
||||
!$OMP END CRITICAL
|
||||
deallocate(tmp_a,tmp_b)
|
||||
!$OMP BARRIER
|
||||
!$OMP END PARALLEL
|
||||
|
||||
endif
|
||||
@ -157,7 +156,6 @@ END_PROVIDER
|
||||
one_body_single_double_dm_mo_beta = one_body_single_double_dm_mo_beta + tmp_b
|
||||
!$OMP END CRITICAL
|
||||
deallocate(tmp_a,tmp_b)
|
||||
!$OMP BARRIER
|
||||
!$OMP END PARALLEL
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
@ -349,6 +349,42 @@ subroutine get_mono_excitation(det1,det2,exc,phase,Nint)
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine bitstring_to_list_ab( string, list, n_elements, Nint)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Gives the inidices(+1) of the bits set to 1 in the bit string
|
||||
! For alpha/beta determinants
|
||||
END_DOC
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: string(Nint,2)
|
||||
integer, intent(out) :: list(Nint*bit_kind_size,2)
|
||||
integer, intent(out) :: n_elements(2)
|
||||
|
||||
integer :: i, ishift
|
||||
integer(bit_kind) :: l
|
||||
|
||||
n_elements(1) = 0
|
||||
n_elements(2) = 0
|
||||
ishift = 2
|
||||
do i=1,Nint
|
||||
l = string(i,1)
|
||||
do while (l /= 0_bit_kind)
|
||||
n_elements(1) = n_elements(1)+1
|
||||
list(n_elements(1),1) = ishift+popcnt(l-1_bit_kind) - popcnt(l)
|
||||
l = iand(l,l-1_bit_kind)
|
||||
enddo
|
||||
l = string(i,2)
|
||||
do while (l /= 0_bit_kind)
|
||||
n_elements(2) = n_elements(2)+1
|
||||
list(n_elements(2),2) = ishift+popcnt(l-1_bit_kind) - popcnt(l)
|
||||
l = iand(l,l-1_bit_kind)
|
||||
enddo
|
||||
ishift = ishift + bit_kind_size
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
@ -370,7 +406,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
|
||||
integer :: i,j,k
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
double precision :: diag_H_mat_elem, phase,phase_2
|
||||
integer :: n_occ_alpha, n_occ_beta
|
||||
integer :: n_occ_ab(2)
|
||||
logical :: has_mipi(Nint*bit_kind_size)
|
||||
double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size)
|
||||
PROVIDE mo_bielec_integrals_in_map mo_integrals_map
|
||||
@ -422,8 +458,8 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
|
||||
endif
|
||||
case (1)
|
||||
call get_mono_excitation(key_i,key_j,exc,phase,Nint)
|
||||
call bitstring_to_list(key_i(1,1), occ(1,1), n_occ_alpha, Nint)
|
||||
call bitstring_to_list(key_i(1,2), occ(1,2), n_occ_beta, Nint)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
|
||||
has_mipi = .False.
|
||||
if (exc(0,1,1) == 1) then
|
||||
! Mono alpha
|
||||
@ -506,7 +542,7 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree)
|
||||
integer :: i,j,k
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
double precision :: diag_H_mat_elem
|
||||
integer :: n_occ_alpha, n_occ_beta
|
||||
integer :: n_occ_ab(2)
|
||||
logical :: has_mipi(Nint*bit_kind_size)
|
||||
double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size)
|
||||
PROVIDE mo_bielec_integrals_in_map mo_integrals_map
|
||||
@ -558,8 +594,8 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree)
|
||||
endif
|
||||
case (1)
|
||||
call get_mono_excitation(key_i,key_j,exc,phase,Nint)
|
||||
call bitstring_to_list(key_i(1,1), occ(1,1), n_occ_alpha, Nint)
|
||||
call bitstring_to_list(key_i(1,2), occ(1,2), n_occ_beta, Nint)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
|
||||
has_mipi = .False.
|
||||
if (exc(0,1,1) == 1) then
|
||||
! Mono alpha
|
||||
@ -642,7 +678,7 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
|
||||
integer :: i,j,k
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
double precision :: diag_H_mat_elem, phase,phase_2
|
||||
integer :: n_occ_alpha, n_occ_beta
|
||||
integer :: n_occ_ab(2)
|
||||
logical :: has_mipi(Nint*bit_kind_size)
|
||||
double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size)
|
||||
PROVIDE mo_bielec_integrals_in_map mo_integrals_map
|
||||
@ -696,8 +732,8 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble)
|
||||
endif
|
||||
case (1)
|
||||
call get_mono_excitation(key_i,key_j,exc,phase,Nint)
|
||||
call bitstring_to_list(key_i(1,1), occ(1,1), n_occ_alpha, Nint)
|
||||
call bitstring_to_list(key_i(1,2), occ(1,2), n_occ_beta, Nint)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
|
||||
has_mipi = .False.
|
||||
if (exc(0,1,1) == 1) then
|
||||
! Mono alpha
|
||||
@ -1229,15 +1265,15 @@ double precision function diag_H_mat_elem(det_in,Nint)
|
||||
endif
|
||||
|
||||
!call debug_det(det_in,Nint)
|
||||
integer :: tmp
|
||||
call bitstring_to_list(particle(1,1), occ_particle(1,1), tmp, Nint)
|
||||
ASSERT (tmp == nexc(1))
|
||||
call bitstring_to_list(particle(1,2), occ_particle(1,2), tmp, Nint)
|
||||
ASSERT (tmp == nexc(2))
|
||||
call bitstring_to_list(hole(1,1), occ_hole(1,1), tmp, Nint)
|
||||
ASSERT (tmp == nexc(1))
|
||||
call bitstring_to_list(hole(1,2), occ_hole(1,2), tmp, Nint)
|
||||
ASSERT (tmp == nexc(2))
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(particle, occ_particle, tmp, Nint)
|
||||
ASSERT (tmp(1) == nexc(1))
|
||||
ASSERT (tmp(2) == nexc(2))
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(hole, occ_hole, tmp, Nint)
|
||||
ASSERT (tmp(1) == nexc(1))
|
||||
ASSERT (tmp(2) == nexc(2))
|
||||
|
||||
det_tmp = ref_bitmask
|
||||
do ispin=1,2
|
||||
@ -1317,13 +1353,11 @@ subroutine ac_operator(iorb,ispin,key,hjj,Nint,na,nb)
|
||||
ASSERT (ispin < 3)
|
||||
ASSERT (Nint > 0)
|
||||
|
||||
integer :: tmp
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list(key(1,1), occ(1,1), tmp, Nint)
|
||||
ASSERT (tmp == elec_alpha_num)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list(key(1,2), occ(1,2), tmp, Nint)
|
||||
ASSERT (tmp == elec_beta_num)
|
||||
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||
ASSERT (tmp(1) == elec_alpha_num)
|
||||
ASSERT (tmp(2) == elec_beta_num)
|
||||
|
||||
k = ishft(iorb-1,-bit_kind_shift)+1
|
||||
ASSERT (k > 0)
|
||||
@ -1354,10 +1388,10 @@ subroutine get_occ_from_key(key,occ,Nint)
|
||||
integer(bit_kind), intent(in) :: key(Nint,2)
|
||||
integer , intent(in) :: Nint
|
||||
integer , intent(out) :: occ(Nint*bit_kind_size,2)
|
||||
integer :: tmp
|
||||
integer :: tmp(2)
|
||||
|
||||
call bitstring_to_list(key(1,1), occ(1,1), tmp, Nint)
|
||||
call bitstring_to_list(key(1,2), occ(1,2), tmp, Nint)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||
|
||||
end
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user