diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index d39273b2..ac7e8e02 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -20,6 +20,8 @@ init_thread printout_now printout_always deinit_thread +skip +init_main """.split() class H_apply(object): @@ -201,6 +203,11 @@ class H_apply(object): self.set_perturbation(pert) self.selection_pt2 = pert if pert is not None: + self.data["parameters"] += ",select_max_out" + self.data["declarations"] += """ + double precision, intent(inout) :: select_max_out""" + + self.data["params_post"] += ", select_max(i_generator)" self.data["size_max"] = str(1024*128) self.data["copy_buffer"] = """ call copy_h_apply_buffer_to_wf @@ -212,7 +219,24 @@ class H_apply(object): coef_pert_buffer = 0.d0 """ + self.data["keys_work"] self.data["keys_work"] += """ - call fill_H_apply_buffer_selection(key_idx,keys_out,e_2_pert_buffer,coef_pert_buffer,N_st,N_int,iproc) + call fill_H_apply_buffer_selection(key_idx,keys_out,e_2_pert_buffer, & + coef_pert_buffer,N_st,N_int,iproc,select_max_out) + """ + self.data["omp_parallel"] += """& + !$OMP REDUCTION (max:select_max_out)""" + self.data["skip"] = """ + if ((i_generator < size(select_max)).and. & + (select_max(i_generator) < selection_criterion_min*selection_criterion_factor)) then + !$ call omp_set_lock(lck) + do k=1,N_st + norm_psi(k) = norm_psi(k) + psi_coef(i_generator,k)*psi_coef(i_generator,k) + delta_pt2(k) = 0.d0 + pt2_old(k) = 0.d0 + enddo + !$ call omp_unset_lock(lck) + cycle + endif + select_max(i_generator) = 0.d0 """ diff --git a/src/Dets/H_apply.irp.f b/src/Dets/H_apply.irp.f index be94a7a0..c2302432 100644 --- a/src/Dets/H_apply.irp.f +++ b/src/Dets/H_apply.irp.f @@ -237,4 +237,3 @@ subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc) end - diff --git a/src/Dets/H_apply_template.f b/src/Dets/H_apply_template.f index 48b117cc..1e1500e2 100644 --- a/src/Dets/H_apply_template.f +++ b/src/Dets/H_apply_template.f @@ -369,6 +369,7 @@ subroutine $subroutine($params_main) if (abort_here) then cycle endif + $skip call $subroutine_diexc(psi_generators(1,1,i_generator), & generators_bitmask(1,1,d_hole1,i_bitmask_gen), & generators_bitmask(1,1,d_part1,i_bitmask_gen), & @@ -388,7 +389,7 @@ subroutine $subroutine($params_main) endif !$ call omp_unset_lock(lck) enddo - !$OMP END DO NOWAIT + !$OMP END DO !$OMP END PARALLEL !$ call omp_destroy_lock(lck) @@ -396,6 +397,7 @@ subroutine $subroutine($params_main) if (abort_here) then exit endif + $skip call $subroutine_diexc(psi_generators(1,1,i_generator), & generators_bitmask(1,1,d_hole1,i_bitmask_gen), & generators_bitmask(1,1,d_part1,i_bitmask_gen), & diff --git a/src/Dets/connected_to_ref.irp.f b/src/Dets/connected_to_ref.irp.f index 975d7557..773bad1d 100644 --- a/src/Dets/connected_to_ref.irp.f +++ b/src/Dets/connected_to_ref.irp.f @@ -32,10 +32,6 @@ logical function is_in_wavefunction(key,Nint,Ndet) i = ibegin + istep end do -! if (det_search /= det_ref) then -! return -! endif - do while (det_search_key(psi_det_sorted_bit(1,1,i),Nint) == det_ref) i = i-1 if (i == 0) then @@ -43,6 +39,10 @@ logical function is_in_wavefunction(key,Nint,Ndet) endif enddo i += 1 + if (i > N_det) then + return + endif + 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 diff --git a/src/Full_CI/full_ci.irp.f b/src/Full_CI/full_ci.irp.f index 12979d1a..e5a60f25 100644 --- a/src/Full_CI/full_ci.irp.f +++ b/src/Full_CI/full_ci.irp.f @@ -11,7 +11,7 @@ program cisd pt2 = 1.d0 diag_algorithm = "Lapack" - do while (maxval(abs(pt2(1:N_st))) > 1.d-2) + do while (maxval(abs(pt2(1:N_st))) > 1.d-3) call H_apply_FCI(pt2, norm_pert, H_pert_diag, N_st) call diagonalize_CI print *, 'N_det = ', N_det diff --git a/src/Generators_full/generators.irp.f b/src/Generators_full/generators.irp.f index 40013131..68236da2 100644 --- a/src/Generators_full/generators.irp.f +++ b/src/Generators_full/generators.irp.f @@ -52,4 +52,11 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_generators, (N_int,2,psi_det_size) ] END_PROVIDER + BEGIN_PROVIDER [ double precision, select_max, (3000) ] + implicit none + BEGIN_DOC + ! Memo to skip useless selectors + END_DOC + select_max = huge(1.d0) +END_PROVIDER diff --git a/src/Perturbation/selection.irp.f b/src/Perturbation/selection.irp.f index 254ee8a6..9420d482 100644 --- a/src/Perturbation/selection.irp.f +++ b/src/Perturbation/selection.irp.f @@ -1,4 +1,5 @@ -subroutine fill_H_apply_buffer_selection(n_selected,det_buffer,e_2_pert_buffer,coef_pert_buffer,N_st,Nint,iproc) +subroutine fill_H_apply_buffer_selection(n_selected,det_buffer,e_2_pert_buffer,coef_pert_buffer, & + N_st,Nint,iproc,select_max_out) use bitmasks implicit none BEGIN_DOC @@ -9,6 +10,7 @@ subroutine fill_H_apply_buffer_selection(n_selected,det_buffer,e_2_pert_buffer,c integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) double precision, intent(in) :: e_2_pert_buffer(N_st,n_selected) double precision, intent(in) :: coef_pert_buffer(N_st,n_selected) + double precision, intent(inout):: select_max_out integer :: i,j,k,l integer :: new_size double precision :: s, smin, smax @@ -35,6 +37,7 @@ subroutine fill_H_apply_buffer_selection(n_selected,det_buffer,e_2_pert_buffer,c do j=1,N_st s = -e_2_pert_buffer(j,i) is_selected = s > selection_criterion*selection_criterion_factor .or. is_selected + select_max_out = max(select_max_out,s) enddo @@ -72,7 +75,7 @@ end BEGIN_DOC ! Threshold to select determinants. Set by selection routines. END_DOC - selection_criterion = 10.d0 + selection_criterion = .1d0 selection_criterion_factor = 0.01d0 selection_criterion_min = selection_criterion @@ -132,5 +135,3 @@ subroutine remove_small_contributions end - -