9
1
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-07-19 17:23:25 +02:00
qp2/src/perturbation/selection.irp.f

131 lines
4.3 KiB
Fortran

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
! Fill the H_apply buffer with determiants for the selection
END_DOC
integer, intent(in) :: n_selected, Nint, N_st, iproc
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
logical :: is_selected
PROVIDE H_apply_buffer_allocated N_int
ASSERT (Nint > 0)
ASSERT (N_int == N_int)
ASSERT (N_selected >= 0)
call omp_set_lock(H_apply_buffer_lock(1,iproc))
new_size = H_apply_buffer(iproc)%N_det + n_selected
if (new_size > h_apply_buffer(iproc)%sze) then
call resize_h_apply_buffer(max(h_apply_buffer(iproc)%sze*2,new_size),iproc)
endif
do i=1,H_apply_buffer(iproc)%N_det
ASSERT (sum(popcnt(h_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num)
ASSERT (sum(popcnt(h_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num)
enddo
l=H_apply_buffer(iproc)%N_det
do i=1,n_selected
is_selected = .False.
do j=1,N_st
s = dabs(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
if (is_selected) then
l = l+1
do j=1,N_int
h_apply_buffer(iproc)%det(j,1,l) = det_buffer(j,1,i)
h_apply_buffer(iproc)%det(j,2,l) = det_buffer(j,2,i)
enddo
do j=1,N_st
H_apply_buffer(iproc)%e2(l,j) = e_2_pert_buffer(j,i)
H_apply_buffer(iproc)%coef(l,j) = coef_pert_buffer(j,i)
enddo
ASSERT (sum(popcnt(h_apply_buffer(iproc)%det(:,1,l)) )== elec_alpha_num)
ASSERT (sum(popcnt(h_apply_buffer(iproc)%det(:,2,l))) == elec_beta_num)
endif
enddo
H_apply_buffer(iproc)%N_det = l
do i=1,H_apply_buffer(iproc)%N_det
ASSERT (sum(popcnt(h_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num)
ASSERT (sum(popcnt(h_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num)
enddo
call omp_unset_lock(H_apply_buffer_lock(1,iproc))
end
BEGIN_PROVIDER [ double precision, selection_criterion ]
&BEGIN_PROVIDER [ double precision, selection_criterion_min ]
&BEGIN_PROVIDER [ double precision, selection_criterion_factor ]
implicit none
BEGIN_DOC
! Threshold to select determinants. Set by selection routines.
END_DOC
selection_criterion = 0.1d0
selection_criterion_factor = 0.01d0
selection_criterion_min = selection_criterion
END_PROVIDER
subroutine remove_small_contributions
implicit none
BEGIN_DOC
! Remove determinants with small contributions. N_states is assumed to be
! provided.
END_DOC
integer :: i,j,k, N_removed
logical, allocatable :: keep(:)
double precision :: i_H_psi_array(N_states)
allocate (keep(N_det))
call diagonalize_CI
do i=1,N_det
keep(i) = .True.
enddo
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,j,i_H_psi_array) &
!$OMP SHARED(k,psi_det_sorted,psi_coef_sorted,N_int,N_det,psi_det_size,N_states, &
!$OMP selection_criterion_min,keep,N_det_generators) &
!$OMP REDUCTION(+:N_removed)
!$OMP DO
do i=2*N_det_generators+1, N_det
call i_H_psi(psi_det_sorted(1,1,i),psi_det_sorted,psi_coef_sorted,N_int,min(N_det,2*N_det_generators),psi_det_size,N_states,i_H_psi_array)
keep(i) = .False.
do j=1,N_states
keep(i) = keep(i) .or. (-(psi_coef_sorted(i,j)*i_H_psi_array(j)) > selection_criterion_min)
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
N_removed = 0
k = 0
do i=1, N_det
PROVIDE psi_coef psi_det psi_det_sorted psi_coef_sorted
if (keep(i)) then
k += 1
do j=1,N_int
psi_det(j,1,k) = psi_det_sorted(j,1,i)
psi_det(j,2,k) = psi_det_sorted(j,2,i)
enddo
do j=1,N_states
psi_coef(k,j) = psi_coef_sorted(i,j)
enddo
else
N_removed += 1
endif
enddo
deallocate(keep)
if (N_removed > 0) then
N_det = N_det - N_removed
SOFT_TOUCH N_det psi_det psi_coef
call write_int(6,N_removed, 'Removed determinants')
endif
end