From 7e0b254c489c538e0c74b7debd38326d74fc52a1 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 6 Jun 2014 14:28:47 +0200 Subject: [PATCH] Introduced ib_jb pairs in H_apply --- scripts/generate_h_apply.py | 2 +- src/Dets/H_apply_template.f | 110 +++++++++++++++++++++--------------- src/Dets/README.rst | 22 ++++---- 3 files changed, 78 insertions(+), 56 deletions(-) diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index ac7e8e02..feab4c12 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -41,7 +41,7 @@ class H_apply(object): s["omp_parallel"] = """!$OMP PARALLEL DEFAULT(SHARED) & !$OMP PRIVATE(i,j,k,l,keys_out,hole,particle, & !$OMP occ_particle,occ_hole,j_a,k_a,other_spin, & - !$OMP hole_save,ispin,jj,l_a, & + !$OMP hole_save,ispin,jj,l_a,ib_jb_pairs, & !$OMP accu,i_a,hole_tmp,particle_tmp,occ_particle_tmp, & !$OMP occ_hole_tmp,key_idx,i_b,j_b,key,N_elec_in_key_part_1,& !$OMP N_elec_in_key_hole_1,N_elec_in_key_part_2, & diff --git a/src/Dets/H_apply_template.f b/src/Dets/H_apply_template.f index c1dd13dc..5eb25ed5 100644 --- a/src/Dets/H_apply_template.f +++ b/src/Dets/H_apply_template.f @@ -26,6 +26,7 @@ subroutine $subroutine_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_gene double precision :: mo_bielec_integral integer, allocatable :: ia_ja_pairs(:,:,:) + integer, allocatable :: ib_jb_pairs(:,:) double precision :: diag_H_mat_elem integer :: iproc integer(omp_lock_kind), save :: lck, ifirst=0 @@ -60,7 +61,8 @@ subroutine $subroutine_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_gene 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) - allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2)) + allocate (ia_ja_pairs(2,0:(elec_alpha_num)*mo_tot_num,2), & + ib_jb_pairs(2,0:(elec_alpha_num)*mo_tot_num)) do ispin=1,2 i=0 @@ -129,60 +131,33 @@ subroutine $subroutine_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_gene if (ispin == 1) then integer :: jjj + i=0 do kk = 1,N_elec_in_key_hole_2(other_spin) - hole = hole_save i_b = occ_hole_tmp(kk,other_spin) ASSERT (i_b > 0) ASSERT (i_b <= mo_tot_num) - k = ishft(i_b-1,-bit_kind_shift)+1 - j = i_b-ishft(k-1,bit_kind_shift)-1 - hole(k,other_spin) = ibclr(hole(k,other_spin),j) do jjj=1,N_elec_in_key_part_2(other_spin) ! particule j_b = occ_particle_tmp(jjj,other_spin) ASSERT (j_b > 0) ASSERT (j_b <= mo_tot_num) - key = hole - k = ishft(j_b-1,-bit_kind_shift)+1 - l = j_b-ishft(k-1,bit_kind_shift)-1 - key(k,other_spin) = ibset(key(k,other_spin),l) - key_idx += 1 - do k=1,N_int - keys_out(k,1,key_idx) = key(k,1) - keys_out(k,2,key_idx) = key(k,2) - enddo - ASSERT (key_idx <= size_max) - if (key_idx == size_max) then - $keys_work - key_idx = 0 - endif - ! endif + i+= 1 + ib_jb_pairs(1,i) = i_b + ib_jb_pairs(2,i) = j_b enddo - if (abort_here) then - exit - endif enddo - endif - ! does all the mono excitations of the same spin - do kk = 1,N_elec_in_key_hole_2(ispin) - i_b = occ_hole_tmp(kk,ispin) - ASSERT (i_b > 0) - ASSERT (i_b <= mo_tot_num) - if (i_b <= i_a.or.i_b == j_a) cycle - hole = hole_save - k = ishft(i_b-1,-bit_kind_shift)+1 - j = i_b-ishft(k-1,bit_kind_shift)-1 - hole(k,ispin) = ibclr(hole(k,ispin),j) - do jjj=1,N_elec_in_key_part_2(ispin) - j_b = occ_particle_tmp(jjj,ispin) - ASSERT (j_b > 0) - ASSERT (j_b <= mo_tot_num) - if (j_b <= j_a) cycle + ib_jb_pairs(1,0) = i + + do kk = 1,ib_jb_pairs(1,0) + hole = hole_save + i_b = ib_jb_pairs(1,kk) + j_b = ib_jb_pairs(2,kk) + k = ishft(i_b-1,-bit_kind_shift)+1 + j = i_b-ishft(k-1,bit_kind_shift)-1 + hole(k,other_spin) = ibclr(hole(k,other_spin),j) key = hole k = ishft(j_b-1,-bit_kind_shift)+1 l = j_b-ishft(k-1,bit_kind_shift)-1 - key(k,ispin) = ibset(key(k,ispin),l) - !! a^((+)_j_b(ispin) a_i_b(ispin) : mono exc :: orb(i_b,ispin) --> orb(j_b,ispin) - + key(k,other_spin) = ibset(key(k,other_spin),l) key_idx += 1 do k=1,N_int keys_out(k,1,key_idx) = key(k,1) @@ -197,13 +172,59 @@ subroutine $subroutine_diexc(key_in, hole_1,particl_1, hole_2, particl_2, i_gene exit endif enddo - enddo! kk + endif + + ! does all the mono excitations of the same spin + i=0 + do kk = 1,N_elec_in_key_hole_2(ispin) + i_b = occ_hole_tmp(kk,ispin) + if (i_b <= i_a.or.i_b == j_a) cycle + ASSERT (i_b > 0) + ASSERT (i_b <= mo_tot_num) + do jjj=1,N_elec_in_key_part_2(ispin) ! particule + j_b = occ_particle_tmp(jjj,ispin) + ASSERT (j_b > 0) + ASSERT (j_b <= mo_tot_num) + if (j_b <= j_a) cycle + i+= 1 + ib_jb_pairs(1,i) = i_b + ib_jb_pairs(2,i) = j_b + enddo + enddo + ib_jb_pairs(1,0) = i + + do kk = 1,ib_jb_pairs(1,0) + hole = hole_save + i_b = ib_jb_pairs(1,kk) + j_b = ib_jb_pairs(2,kk) + k = ishft(i_b-1,-bit_kind_shift)+1 + j = i_b-ishft(k-1,bit_kind_shift)-1 + hole(k,ispin) = ibclr(hole(k,ispin),j) + key = hole + k = ishft(j_b-1,-bit_kind_shift)+1 + l = j_b-ishft(k-1,bit_kind_shift)-1 + key(k,ispin) = ibset(key(k,ispin),l) + key_idx += 1 + do k=1,N_int + keys_out(k,1,key_idx) = key(k,1) + keys_out(k,2,key_idx) = key(k,2) + enddo + ASSERT (key_idx <= size_max) + if (key_idx == size_max) then + $keys_work + key_idx = 0 + endif + if (abort_here) then + exit + endif + enddo ! kk + enddo ! ii $omp_enddo enddo ! ispin $keys_work $deinit_thread - deallocate (ia_ja_pairs, & + deallocate (ia_ja_pairs, ib_jb_pairs, & keys_out, hole_save, & key,hole, particle, hole_tmp,& particle_tmp, occ_particle, & @@ -235,6 +256,7 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,i_generator $parameters integer :: ii,i,jj,j,k,ispin,l integer,allocatable :: occ_particle(:,:), occ_hole(:,:) integer,allocatable :: occ_particle_tmp(:,:), occ_hole_tmp(:,:) + integer,allocatable :: ib_jb_pairs(:,:) integer :: kk,pp,other_spin,key_idx integer :: N_elec_in_key_hole_1(2),N_elec_in_key_part_1(2) integer :: N_elec_in_key_hole_2(2),N_elec_in_key_part_2(2) diff --git a/src/Dets/README.rst b/src/Dets/README.rst index ce68d471..0b972cd9 100644 --- a/src/Dets/README.rst +++ b/src/Dets/README.rst @@ -83,7 +83,7 @@ Documentation .br Initial guess vectors are not necessarily orthonormal -`repeat_excitation `_ +`repeat_excitation `_ Undocumented `connected_to_ref `_ @@ -152,7 +152,7 @@ Documentation `davidson_threshold `_ Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] -`det_search_key `_ +`det_search_key `_ Return an integer*8 corresponding to a determinant index for searching `n_det `_ @@ -164,35 +164,35 @@ Documentation `n_states `_ Number of states to consider -`psi_average_norm_contrib `_ +`psi_average_norm_contrib `_ Contribution of determinants to the state-averaged density -`psi_average_norm_contrib_sorted `_ +`psi_average_norm_contrib_sorted `_ Wave function sorted by determinants contribution to the norm (state-averaged) -`psi_coef `_ - The wave function. Initialized with Hartree-Fock if the EZFIO file +`psi_coef `_ + The wave function coefficients. Initialized with Hartree-Fock if the EZFIO file is empty -`psi_coef_sorted `_ +`psi_coef_sorted `_ Wave function sorted by determinants contribution to the norm (state-averaged) -`psi_coef_sorted_bit `_ +`psi_coef_sorted_bit `_ Determinants on which we apply for perturbation. o They are sorted by determinants interpreted as integers. Useful to accelerate the search of a determinant `psi_det `_ - The wave function. Initialized with Hartree-Fock if the EZFIO file + The wave function determinants. Initialized with Hartree-Fock if the EZFIO file is empty `psi_det_size `_ Size of the psi_det/psi_coef arrays -`psi_det_sorted `_ +`psi_det_sorted `_ Wave function sorted by determinants contribution to the norm (state-averaged) -`psi_det_sorted_bit `_ +`psi_det_sorted_bit `_ Determinants on which we apply for perturbation. o They are sorted by determinants interpreted as integers. Useful to accelerate the search of a determinant