mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-11-09 06:53:38 +01:00
75 lines
1.5 KiB
Fortran
75 lines
1.5 KiB
Fortran
|
|
! ---
|
|
|
|
program select_dets_bi_ortho()
|
|
|
|
BEGIN_DOC
|
|
! TODO : Put the documentation of the program here
|
|
END_DOC
|
|
|
|
implicit none
|
|
|
|
print *, 'Hello world'
|
|
|
|
my_grid_becke = .True.
|
|
PROVIDE tc_grid1_a tc_grid1_r
|
|
my_n_pt_r_grid = tc_grid1_r
|
|
my_n_pt_a_grid = tc_grid1_a
|
|
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
|
|
|
read_wf = .True.
|
|
touch read_wf
|
|
|
|
!!!!!!!!!!!!!!! WARNING NO 3-BODY
|
|
!!!!!!!!!!!!!!! WARNING NO 3-BODY
|
|
three_body_h_tc = .False.
|
|
touch three_body_h_tc
|
|
!!!!!!!!!!!!!!! WARNING NO 3-BODY
|
|
!!!!!!!!!!!!!!! WARNING NO 3-BODY
|
|
|
|
call routine_test
|
|
! call test
|
|
end
|
|
|
|
! ---
|
|
|
|
subroutine routine_test
|
|
implicit none
|
|
use bitmasks ! you need to include the bitmasks_module.f90 features
|
|
integer :: i,n_good,degree
|
|
integer(bit_kind), allocatable :: dets(:,:,:)
|
|
integer, allocatable :: iorder(:)
|
|
double precision, allocatable :: coef(:),coef_new(:,:)
|
|
double precision :: thr
|
|
allocate(coef(N_det), iorder(N_det))
|
|
do i = 1, N_det
|
|
iorder(i) = i
|
|
call get_excitation_degree(HF_bitmask,psi_det(1,1,i),degree,N_int)
|
|
if(degree==1)then
|
|
coef(i) = -0.5d0
|
|
else
|
|
coef(i) = -dabs(coef_pt1_bi_ortho(i))
|
|
endif
|
|
enddo
|
|
call dsort(coef,iorder,N_det)
|
|
!thr = save_threshold
|
|
thr = 1d-15
|
|
n_good = 0
|
|
do i = 1, N_det
|
|
if(dabs(coef(i)).gt.thr)then
|
|
n_good += 1
|
|
endif
|
|
enddo
|
|
print*,'n_good = ',n_good
|
|
allocate(dets(N_int,2,n_good),coef_new(n_good,n_states))
|
|
do i = 1, n_good
|
|
dets(:,:,i) = psi_det(:,:,iorder(i))
|
|
coef_new(i,:) = psi_coef(iorder(i),:)
|
|
enddo
|
|
call save_wavefunction_general(n_good,n_states,dets,n_good,coef_new)
|
|
|
|
end
|
|
|
|
! ---
|
|
|