qp2/plugins/local/tc_progs/select_dets_bi_ortho.irp.f

! ---

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

! ---