non-working mrcc_sto

plugins/dress_zmq/dressing.irp.f

@@ -86,7 +86,7 @@ END_PROVIDER
   else
     errr = 1d-4
   end if
-  relative_error = errr
+  relative_error = errr * 0d0
   print *, "RELATIVE ERROR", relative_error
   call ZMQ_dress(E_CI_before, dress, del, del_s2, abs(relative_error))
   

plugins/dress_zmq/dressing_vector.irp.f

@@ -11,19 +11,22 @@
  double precision :: f, tmp
  double precision, external :: u_dot_v
  
+ print *, "DELTA_IJ", delta_ij(1,:10,1)
+ print *, "DELTA_IJ div", delta_ij(1,:10,1) / psi_coef(dressed_column_idx(1),1)
+ !stop
  do k=1,N_states
    l = dressed_column_idx(k)
    f = 1.d0/psi_coef(l,k)
    do jj = 1, n_det
      j = jj !idx_non_ref(jj)
-     dressing_column_h(j,k) = delta_ij   (k,jj,1)
+     dressing_column_h(j,k) = delta_ij   (k,jj,1) * f
-     dressing_column_s(j,k) = delta_ij   (k,jj,2)!delta_ij_s2(k,jj)
+     dressing_column_s(j,k) = delta_ij   (k,jj,2) * f!delta_ij_s2(k,jj)
    enddo
    tmp = u_dot_v(dressing_column_h(1,k), psi_coef(1,k), N_det)
    dressing_column_h(l,k) -= tmp * f
    tmp = u_dot_v(dressing_column_s(1,k), psi_coef(1,k), N_det)
    dressing_column_s(l,k) -= tmp * f
  enddo
-
+ !stop
 END_PROVIDER
 

plugins/dress_zmq/run_dress_slave.irp.f

@@ -57,12 +57,12 @@ subroutine run_dress_slave(thread,iproc,energy)
       call alpha_callback(delta_ij_loc, i_generator, subset)
 
       !!! SET DRESSING COLUMN?
-      do i=1,N_det
+      !do i=1,N_det
-        do i_state=1,N_states
+      !  do i_state=1,N_states
-          delta_ij_loc(i_state,i,1) = delta_ij_loc(i_state,i,1) / div(i_state) 
+      !    delta_ij_loc(i_state,i,1) = delta_ij_loc(i_state,i,1) / div(i_state) 
-          delta_ij_loc(i_state,i,2) = delta_ij_loc(i_state,i,2) / div(i_state)
+      !    delta_ij_loc(i_state,i,2) = delta_ij_loc(i_state,i,2) / div(i_state)
-        end do
+      !  end do
-      end do
+      !end do
 
       call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
       call push_dress_results(zmq_socket_push, i_generator, delta_ij_loc, task_id)

plugins/mrcc_sto/mrcc_sto.irp.f

@@ -1,3 +1,4 @@
+
 program mrcc_sto
   implicit none
   BEGIN_DOC
@@ -13,13 +14,205 @@ program mrcc_sto
   call dress_zmq()
 end
 
+ BEGIN_PROVIDER [ integer, idx_non_ref_from_sorted, (N_det) ]
+&BEGIN_PROVIDER [ integer, psi_from_sorted, (N_det) ]
+  implicit none
+  integer :: i,inpsisor
   
+  idx_non_ref_from_sorted = 0
+  psi_from_sorted = 0
+
+  do i=1,N_det
+    psi_from_sorted(psi_det_sorted_order(i)) = i
+    inpsisor = psi_det_sorted_order(i)
+    if(inpsisor <= 0) stop "idx_non_ref_from_sorted"
+    idx_non_ref_from_sorted(inpsisor) = idx_non_ref_rev(i)
+  end do
+END_PROVIDER
 
-!! TESTS MINILIST
 subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, alpha)
  use bitmasks
  implicit none
-  double precision,intent(inout)  :: delta_ij_loc(N_states,N_det,2) 
+
+  integer(bit_kind), intent(in)   :: alpha(N_int,2)
+  integer,intent(in)              :: minilist(n_minilist), n_minilist
+  double precision, intent(inout) :: delta_ij_loc(N_states,N_det,2)
+
+
+  integer                        :: i,j,k,l,m
+  integer                        :: degree1, degree2, degree
+  integer, allocatable           :: idx_alpha(:)
+
+  double precision               :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states), hka
+  double precision, allocatable  :: dIa_hla(:,:), dIa_sla(:,:)
+  double precision               :: phase, phase2
+  double precision               :: ci_inv(N_states)
+  integer                        :: exc(0:2,2,2)
+  integer                        :: h1,h2,p1,p2,s1,s2
+  integer(bit_kind)              :: tmp_det(N_int,2)
+  integer                        :: i_state, k_sd, l_sd, m_sd, ll_sd, i_I
+  double precision, allocatable  :: hij_cache(:), sij_cache(:)
+  double precision :: Delta_E_inv(N_states)
+  double precision :: sdress, hdress
+  double precision :: c0(N_states)
+  logical :: ok
+  
+
+  if (perturbative_triples) then
+    PROVIDE one_anhil fock_virt_total fock_core_inactive_total one_creat
+  endif
+  allocate(hij_cache(N_det), sij_cache(N_det)) 
+  allocate (dIa_hla(N_states,N_det), dIa_sla(N_states,N_det))
+  allocate (idx_alpha(0:n_minilist))
+  
+  do i_state=1,N_states
+    c0(i_state) = 1.d0/psi_coef(dressed_column_idx(i_state),i_state)
+  enddo
+  ll_sd = 0
+  do l_sd=1,n_minilist
+    ok = .true.
+    k_sd = minilist(l_sd)
+    !if(idx_non_ref_rev(k_sd) == 0) cycle
+    
+    do i_I=1,N_det_ref
+      call get_excitation_degree(psi_det_sorted(1,1,k_sd),psi_ref(1,1,i_I),degree1,N_int)
+      if(degree1 == 0) then
+        ok = .false.
+        exit
+      end if
+    end do
+    
+    if( xor(ok, idx_non_ref_from_sorted(k_sd) > 0)) stop "BUGUE"
+    if(ok) then
+      ll_sd += 1
+      idx_alpha(ll_sd) = k_sd
+!     call i_h_j(alpha,psi_non_ref(1,1,idx_alpha(l_sd)),N_int,hij_cache(k_sd))
+!     call get_s2(alpha,psi_non_ref(1,1,idx_alpha(l_sd)),N_int,sij_cache(k_sd))
+     call i_h_j(alpha,psi_det_sorted(1,1,k_sd),N_int,hij_cache(k_sd))
+     call get_s2(alpha,psi_det_sorted(1,1,k_sd),N_int,sij_cache(k_sd))
+    end if
+  enddo
+  
+  idx_alpha(0) = ll_sd
+  
+
+  do i_I=1,N_det_ref
+    call get_excitation_degree(alpha,psi_ref(1,1,i_I),degree1,N_int)
+    if (degree1 > 4) then
+      cycle
+    endif
+    
+    do i_state=1,N_states
+      dIa(i_state) = 0.d0
+    enddo
+
+    do k_sd=1,idx_alpha(0)
+      !print *, "idx ", k_sd
+      !print *, "idx2", idx_alpha(k_sd)
+      !print *, "ref
+      !if(idx_non_ref_rev(idx_alpha(k_sd)) == 0) cycle
+      call get_excitation_degree(psi_ref(1,1,i_I),psi_det_sorted(1,1,idx_alpha(k_sd)),degree,N_int)
+!      print *, "diden"
+      if (degree > 2) then
+        cycle
+      endif
+      
+      call get_excitation(psi_det_sorted(1,1,idx_alpha(k_sd)),alpha,exc,degree2,phase,N_int)
+      !print *, "DEG", degree2
+      call decode_exc(exc,degree2,h1,p1,h2,p2,s1,s2)
+      do k=1,N_int
+        tmp_det(k,1) = psi_ref(k,1,i_I)
+        tmp_det(k,2) = psi_ref(k,2,i_I)
+      enddo
+      call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, N_int)
+      
+      do i_state=1,N_states
+        dIK(i_state) = dij(i_I, idx_non_ref_from_sorted(idx_alpha(k_sd)), i_state)
+      enddo
+      
+      ! <I| \l/ |alpha>
+      do i_state=1,N_states
+        dka(i_state) = 0.d0
+      enddo
+
+      if (ok) then
+        do l_sd=k_sd+1,idx_alpha(0)
+          call get_excitation_degree(tmp_det,psi_det_sorted(1,1,idx_alpha(l_sd)),degree,N_int)
+          if (degree == 0) then
+            call get_excitation(psi_ref(1,1,i_I),psi_det_sorted(1,1,idx_alpha(l_sd)),exc,degree,phase2,N_int)
+            do i_state=1,N_states
+              dka(i_state) = dij(i_I, idx_non_ref_from_sorted(idx_alpha(l_sd)), i_state) * phase * phase2
+            enddo
+            exit
+          endif
+        enddo
+      else if (perturbative_triples) then
+          hka = hij_cache(idx_alpha(k_sd))
+          if (dabs(hka) > 1.d-12) then
+            call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),alpha,Delta_E_inv)
+
+            do i_state=1,N_states
+              ASSERT (Delta_E_inv(i_state) < 0.d0)
+              dka(i_state) = hka / Delta_E_inv(i_state)
+            enddo
+          endif
+      endif
+
+      if (perturbative_triples.and. (degree2 == 1) ) then
+          call i_h_j(psi_ref(1,1,i_I),tmp_det,N_int,hka)
+          hka = hij_cache(idx_alpha(k_sd)) - hka
+          if (dabs(hka) > 1.d-12) then
+            call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),alpha,Delta_E_inv)
+            do i_state=1,N_states
+              ASSERT (Delta_E_inv(i_state) < 0.d0)
+              dka(i_state) = hka / Delta_E_inv(i_state)
+            enddo
+          endif
+      endif
+      do i_state=1,N_states
+        dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state)
+      enddo
+    enddo
+    
+    do i_state=1,N_states
+      ci_inv(i_state) = psi_ref_coef_inv(i_I,i_state)
+    enddo
+    do l_sd=1,idx_alpha(0)
+      k_sd = idx_alpha(l_sd)
+      hla = hij_cache(k_sd)
+      sla = sij_cache(k_sd)
+      do i_state=1,N_states
+        dIa_hla(i_state,k_sd) = dIa(i_state) * hla
+        dIa_sla(i_state,k_sd) = dIa(i_state) * sla
+      enddo
+    enddo
+    do i_state=1,N_states
+      do l_sd=1,idx_alpha(0)
+        !print *, "DRES"
+        !print *, i_state, idx_alpha(l_sd)
+        k_sd = idx_alpha(l_sd)
+        m_sd = psi_from_sorted(k_sd)
+        if(psi_det(1,1,m_sd) /= psi_det_sorted(1,1,k_sd)) stop "psi_from_sorted foireous"
+        hdress = dIa_hla(i_state,k_sd) * psi_ref_coef(i_I,i_state) * c0(i_state)
+        sdress = dIa_sla(i_state,k_sd) * psi_ref_coef(i_I,i_state) * c0(i_state)
+        !$OMP ATOMIC
+        delta_ij_loc(i_state,m_sd,1) += hdress
+        !$OMP ATOMIC
+        delta_ij_loc(i_state,m_sd,2) += sdress
+        !print *, "ENDRES" 
+      enddo
+    enddo
+  enddo
+end subroutine
+
+
+
+
+
+!! TESTS MINILIST
+subroutine test_minilist(minilist, n_minilist, alpha)
+  use bitmasks
+  implicit none
   integer, intent(in)            :: n_minilist
   integer(bit_kind),intent(in)  :: alpha(N_int, 2)
   integer, intent(in) :: minilist(n_minilist)
@@ -47,8 +240,6 @@ subroutine dress_with_alpha_buffer(delta_ij_loc, minilist, n_minilist, alpha)
       exit
     end if
   end do
-
-  delta_ij_loc = 0d0
 end subroutine
 
 

plugins/mrcepa0/dressing.irp.f

@@ -867,6 +867,7 @@ end
   else
     target_error = 1d-4
   end if
+  target_error = 0d0
   call ZMQ_mrcc(E_CI_before, mrcc, delta_ij_mrcc_zmq, delta_ij_s2_mrcc_zmq, abs(target_error))
 
   mrcc_previous_E(:) = mrcc_E0_denominator(:)

plugins/mrcepa0/dressing_vector.irp.f

@@ -24,6 +24,7 @@
    tmp = u_dot_v(dressing_column_s(1,k), psi_coef(1,k), N_det)
    dressing_column_s(l,k) -= tmp * f
  enddo
-
+ print *, "DRESS", dressing_column_h(:10,1)
+! stop
 END_PROVIDER
 

plugins/mrcepa0/mrcc_stoch_routines.irp.f

@@ -114,17 +114,17 @@ subroutine ZMQ_mrcc(E, mrcc, delta, delta_s2, relative_error)
         print *,  irp_here, ': Failed in zmq_set_running'
       endif
 
-  !!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc+1)                &
+  !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc+1)                &
-  !    !$OMP  PRIVATE(i)
+      !$OMP  PRIVATE(i)
-  !i = omp_get_thread_num()
+  i = omp_get_thread_num()
-  !if (i==0) then
+  if (i==0) then
-  !  call mrcc_collector(zmq_socket_pull,E, relative_error, delta, delta_s2, mrcc)
-!
-!  else
-!    call mrcc_slave_inproc(i)
-!  endif
-!  !$OMP END PARALLEL
     call mrcc_collector(zmq_socket_pull,E, relative_error, delta, delta_s2, mrcc)
+!
+  else
+    call mrcc_slave_inproc(i)
+  endif
+  !$OMP END PARALLEL
+!  call mrcc_collector(zmq_socket_pull,E, relative_error, delta, delta_s2, mrcc)
   call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'mrcc')
   
   print *, '========== ================= ================= ================='

plugins/mrcepa0/run_mrcc_slave.irp.f

@@ -69,7 +69,6 @@ subroutine run_mrcc_slave(thread,iproc,energy)
     else
       integer :: i_generator, i_i_generator, subset
       read (task,*) subset, ind
-      print *, "SLAVE RECEIVED", ind
 !      if(buf%N == 0) then
 !        ! Only first time 
 !        call create_selection_buffer(1, 2, buf)