Truncated wf a la QMC=Chem

plugins/QmcChem/truncate_wf_spin.irp.f

@@ -0,0 +1,104 @@
+program e_curve
+  use bitmasks
+  implicit none
+  integer :: i,j,k, kk, nab, m, l
+  double precision :: norm, E, hij, num, ci, cj
+  integer, allocatable :: iorder(:)
+  double precision , allocatable :: norm_sort(:)
+  double precision :: e_0(N_states)
+  if (.not.read_wf) then
+    stop 'Please set read_wf to true'
+  endif
+
+  PROVIDE mo_bielec_integrals_in_map H_apply_buffer_allocated
+
+  nab = n_det_alpha_unique+n_det_beta_unique
+  allocate ( norm_sort(0:nab), iorder(0:nab) )
+
+  double precision :: thresh
+  integer(bit_kind), allocatable :: det_i(:,:), det_j(:,:)
+  double precision, allocatable  :: u_t(:,:), v_t(:,:), s_t(:,:)
+  double precision, allocatable  :: u_0(:,:), v_0(:,:)
+  allocate(u_t(N_states,N_det),v_t(N_states,N_det),s_t(N_states,N_det))
+  allocate(u_0(N_states,N_det),v_0(N_states,N_det))
+
+  print *,  'Threshold?'
+  read(*,*) thresh
+
+  norm_sort(0) = 0.d0
+  iorder(0) = 0
+  do i=1,n_det_alpha_unique
+   norm_sort(i) = det_alpha_norm(i)
+   iorder(i) = i
+  enddo
+  
+  do i=1,n_det_beta_unique
+   norm_sort(i+n_det_alpha_unique) = det_beta_norm(i)
+   iorder(i+n_det_alpha_unique) = -i
+  enddo
+  
+  call dsort(norm_sort(1),iorder(1),nab)
+
+
+  PROVIDE psi_bilinear_matrix_values nuclear_repulsion 
+  print *,  ''
+  do j=0,nab
+    i = iorder(j)
+    if (i<0) then
+      do k=1,n_det
+        if (psi_bilinear_matrix_columns(k) == -i) then
+          psi_bilinear_matrix_values(k,1) = 0.d0
+        endif
+      enddo
+    else
+      do k=1,n_det
+        if (psi_bilinear_matrix_rows(k) ==  i) then
+          psi_bilinear_matrix_values(k,1) = 0.d0
+        endif
+      enddo
+    endif
+    if (thresh > norm_sort(j)) then
+      cycle
+    endif
+
+    u_0 = psi_bilinear_matrix_values(1:N_det,1:N_states)
+    v_t = 0.d0
+    s_t = 0.d0
+    call dtranspose(                                                   &
+        u_0,                                                           &
+        size(u_0, 1),                                                  &
+        u_t,                                                           &
+        size(u_t, 1),                                                  &
+        N_det, N_states)
+    call H_S2_u_0_nstates_openmp_work(v_t,s_t,u_t,N_states,N_det,1,N_det,0,1)
+    call dtranspose(                                                   &
+        v_t,                                                           &
+        size(v_t, 1),                                                  &
+        v_0,                                                           &
+        size(v_0, 1),                                                  &
+        N_states, N_det)
+    
+    double precision, external :: u_dot_u, u_dot_v
+    do i=1,N_states
+      e_0(i) = u_dot_v(v_t(1,i),u_0(1,i),N_det)/u_dot_u(u_0(1,i),N_det)
+    enddo
+
+    m = 0
+    do k=1,n_det
+     if (psi_bilinear_matrix_values(k,1) /= 0.d0) then
+      m = m+1
+     endif
+    enddo
+
+    E = E_0(1) + nuclear_repulsion
+    norm = u_dot_u(u_0(1,1),N_det)
+    print *,  'Number of determinants:', m
+    print *,  'Energy', E
+    exit
+  enddo
+  call wf_of_psi_bilinear_matrix()
+  call save_wavefunction
+
+  deallocate (iorder, norm_sort)
+end
+

src/Determinants/spindeterminants.irp.f

@@ -1204,3 +1204,36 @@ N_int;;
 END_TEMPLATE
 
 
+subroutine wf_of_psi_bilinear_matrix(truncate)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+! Generate a wave function containing all possible products 
+! of alpha and beta determinants
+  END_DOC
+  logical, intent(in)            :: truncate
+  integer                        :: i,j,k
+  integer(bit_kind)              :: tmp_det(N_int,2)
+  integer                        :: idx
+  integer, external              :: get_index_in_psi_det_sorted_bit
+  double precision               :: norm(N_states)
+  PROVIDE psi_bilinear_matrix
+
+  do k=1,N_det
+   i = psi_bilinear_matrix_rows(k)
+   j = psi_bilinear_matrix_columns(k)
+   psi_det(1:N_int,1,k) = psi_det_alpha_unique(1:N_int,i)
+   psi_det(1:N_int,2,k) = psi_det_beta_unique (1:N_int,j)
+  enddo
+  psi_coef(1:N_det,1:N_states) = psi_bilinear_matrix_values(1:N_det,1:N_states)
+  TOUCH psi_det psi_coef 
+
+  psi_det   = psi_det_sorted
+  psi_coef  = psi_coef_sorted
+  do while (sum( dabs(psi_coef(N_det,1:N_states)) ) == 0.d0)
+    N_det -= 1
+  enddo
+  SOFT_TOUCH psi_det psi_coef N_det
+
+end
+