LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-12-22 20:35:19 +01:00
Code Issues Releases Wiki Activity

Accelerated diag_h_mat_elem

Browse Source
This commit is contained in:
Anthony Scemama 2015-11-20 22:11:22 +01:00
parent 007e234997
commit 5d253ea84b
2 changed files with 44 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
src/Determinants/H_apply.template.f
View File

@ -186,10 +186,8 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
particle(j,1) = iand(xor(particl_1(j,1),key_in(j,1)),particl_1(j,1))
particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2))
enddo
call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int)
call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int)
call bitstring_to_list(hole(1,1),occ_hole(1,1),N_elec_in_key_hole_1(1),N_int)
call bitstring_to_list(hole(1,2),occ_hole(1,2),N_elec_in_key_hole_1(2),N_int)
call bitstring_to_list_ab(particle,occ_particle,N_elec_in_key_part_1,N_int)
call bitstring_to_list_ab(hole,occ_hole,N_elec_in_key_hole_1,N_int)
allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2), &
ib_jb_pairs(2,0:(elec_alpha_num)*mo_tot_num))
@ -252,10 +250,8 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
particle_tmp(j,2) = iand(xor(particl_2(j,2),hole(j,2)),particl_2(j,2))
enddo
call bitstring_to_list(particle_tmp(1,1),occ_particle_tmp(1,1),N_elec_in_key_part_2(1),N_int)
call bitstring_to_list(particle_tmp(1,2),occ_particle_tmp(1,2),N_elec_in_key_part_2(2),N_int)
call bitstring_to_list(hole_tmp (1,1),occ_hole_tmp (1,1),N_elec_in_key_hole_2(1),N_int)
call bitstring_to_list(hole_tmp (1,2),occ_hole_tmp (1,2),N_elec_in_key_hole_2(2),N_int)
call bitstring_to_list_ab(particle_tmp,occ_particle_tmp,N_elec_in_key_part_2,N_int)
call bitstring_to_list_ab(hole_tmp,occ_hole_tmp,N_elec_in_key_hole_2,N_int)
! hole = a^(+)_j_a(ispin) a_i_a(ispin)|key_in> : mono exc :: orb(i_a,ispin) --> orb(j_a,ispin)
hole_save = hole
@ -447,10 +443,8 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,i_generator,iproc_in $pa
particle(j,2) = iand(xor(particl_1(j,2),key_in(j,2)),particl_1(j,2))
enddo
call bitstring_to_list(particle(1,1),occ_particle(1,1),N_elec_in_key_part_1(1),N_int)
call bitstring_to_list(particle(1,2),occ_particle(1,2),N_elec_in_key_part_1(2),N_int)
call bitstring_to_list(hole (1,1),occ_hole (1,1),N_elec_in_key_hole_1(1),N_int)
call bitstring_to_list(hole (1,2),occ_hole (1,2),N_elec_in_key_hole_1(2),N_int)
call bitstring_to_list_ab(particle,occ_particle,N_elec_in_key_part_1,N_int)
call bitstring_to_list_ab(hole,occ_hole,N_elec_in_key_hole_1,N_int)
allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2))
do ispin=1,2

38
src/Determinants/slater_rules.irp.f
View File

@ -361,6 +361,44 @@ subroutine bitstring_to_list_ab( string, list, n_elements, Nint)
integer, intent(out) :: list(Nint*bit_kind_size,2)
integer, intent(out) :: n_elements(2)
integer :: i, j, ishift
integer(bit_kind) :: l
n_elements(1) = 0
n_elements(2) = 0
ishift = 1
do i=1,Nint
l = string(i,1)
do while (l /= 0_bit_kind)
n_elements(1) = n_elements(1)+1
j = trailz(l)
list(n_elements(1),1) = ishift+j
l = ibclr(l,j)
enddo
l = string(i,2)
do while (l /= 0_bit_kind)
n_elements(2) = n_elements(2)+1
j = trailz(l)
list(n_elements(2),2) = ishift+j
l = ibclr(l,j)
enddo
ishift = ishift + bit_kind_size
enddo
end
subroutine bitstring_to_list_ab_old( 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