quantum_package/plugins/MRPT_Utils/mrpt_dress.irp.f

use omp_lib
use bitmasks

BEGIN_PROVIDER [ integer(omp_lock_kind), psi_ref_bis_lock, (psi_det_size) ]
 implicit none
 BEGIN_DOC
 ! Locks on ref determinants to fill delta_ij
 END_DOC
 integer :: i
 do i=1,psi_det_size
   call omp_init_lock( psi_ref_bis_lock(i) )
 enddo

END_PROVIDER


subroutine mrpt_dress(delta_ij_,  Ndet,i_generator,n_selected,det_buffer,Nint,iproc,key_mask)
 use bitmasks
 implicit none

  integer, intent(in)            :: i_generator,n_selected, Nint, iproc
  integer, intent(in)            :: Ndet
  integer(bit_kind),intent(in)   :: key_mask(Nint, 2)
  integer(bit_kind), intent(in)  :: det_buffer(Nint,2,n_selected)
  double precision, intent(inout) :: delta_ij_(Ndet,Ndet,*)


  integer                        :: i,j,k,l
  integer                        :: idx_alpha(0:psi_det_size)
  integer                        :: degree_alpha(psi_det_size)
  logical                        :: fullMatch
 
  double precision               :: delta_e_inv_array(psi_det_size,N_states)
  double precision               :: hij_array(psi_det_size)

  integer(bit_kind)              :: tq(Nint,2,n_selected)
  integer                        :: N_tq

  double precision               :: hialpha,hij
  integer                        :: i_state, i_alpha
  
  integer(bit_kind),allocatable  :: miniList(:,:,:)
  integer,allocatable            :: idx_miniList(:)
  integer                        :: N_miniList, leng
  double precision               :: delta_e(N_states),hij_tmp
  integer                        :: index_i,index_j
  double precision :: phase_array(N_det_ref),phase
  integer                        :: exc(0:2,2,2),degree
  
  
  leng = max(N_det_generators, N_det_generators)
  allocate(miniList(Nint, 2, leng), idx_miniList(leng))
  
  !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint)
  call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint)
  
  if(fullMatch) then
    return
  end if
  
  
  call find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)

  if(N_tq > 0) then
    call create_minilist(key_mask, psi_ref, miniList, idx_miniList, N_det_ref, N_minilist, Nint)
  end if
  
  
 double  precision :: coef_array(N_states)
  do i_alpha=1,N_tq
!  do i = 1, N_det_ref
!   do i_state = 1, N_states
!    coef_array(i_state) = psi_ref_coef(i,i_state)
!   enddo
!   call i_H_j(psi_ref(1,1,i),tq(1,1,i_alpha),n_int,hialpha)
!     if(dabs(hialpha).le.1.d-20)then
!      do i_state = 1, N_states
!       delta_e(i_state) = 1.d+20
!      enddo
!     else
!      call get_delta_e_dyall(psi_ref(1,1,i),tq(1,1,i_alpha),coef_array,hialpha,delta_e)
!     endif
!     hij_array(i) = hialpha
!     do i_state = 1,N_states
!      delta_e_inv_array(i,i_state) = 1.d0/delta_e(i_state)
!     enddo
!  enddo
!  do i = 1, N_det_ref
!   do j = 1, N_det_ref
!    do i_state = 1, N_states
!     delta_ij_(i,j,i_state) += hij_array(i) * hij_array(j)* delta_e_inv_array(j,i_state)
!    enddo
!   enddo
!  enddo
!  cycle



 !  call get_excitation_degree_vector(psi_ref,tq(1,1,i_alpha),degree_alpha,Nint,N_det_ref,idx_alpha)
    call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
    
    do j=1,idx_alpha(0)
      idx_alpha(j) = idx_miniList(idx_alpha(j))
    enddo
     
    phase_array  =0.d0
    do i = 1,idx_alpha(0)
      index_i = idx_alpha(i)
      call i_h_j(tq(1,1,i_alpha),psi_ref(1,1,index_i),Nint,hialpha)
      do i_state = 1, N_states
       coef_array(i_state) = psi_ref_coef(index_i,i_state)
      enddo
      integer :: degree_scalar

      call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,index_i),degree_scalar,N_int)
!     if(degree_scalar == 2)then
!      hialpha = 0.d0
!     endif
      if(dabs(hialpha).le.1.d-20)then
       do i_state = 1, N_states
        delta_e(i_state) = 1.d+20
       enddo
      else 
       call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e)
       !!!!!!!!!!!!! SHIFTED BK 
!      double precision :: hjj
!      call i_h_j(tq(1,1,i_alpha),tq(1,1,i_alpha),Nint,hjj)
!      delta_e(1) = CI_electronic_energy(1) - hjj
!      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      endif
      hij_array(index_i) = hialpha
      do i_state = 1,N_states
       delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state)
      enddo
    enddo
    
    do i=1,idx_alpha(0)
      index_i = idx_alpha(i)
      hij_tmp = hij_array(index_i)
      call omp_set_lock( psi_ref_bis_lock(index_i) )
      do j = 1, idx_alpha(0)
       index_j = idx_alpha(j)
       !!!!!!!!!!!!!!!!!! WARNING TEST
       !!!!!!!!!!!!!!!!!! WARNING TEST
!      if(index_j .ne. index_i)cycle
       !!!!!!!!!!!!!!!!!! WARNING TEST
       !!!!!!!!!!!!!!!!!! WARNING TEST
       !!!!!!!!!!!!!!!!!! WARNING TEST
       do i_state=1,N_states
        ! standard dressing first order
         delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_inv_array(index_j,i_state)
       enddo
      enddo
      call omp_unset_lock( psi_ref_bis_lock(index_i))
    enddo
  enddo
  deallocate(miniList, idx_miniList)
end



 BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted,  (N_int,2,N_det_ref,2) ]
&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_ref,2) ]
&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_ref,2) ]
&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_ref,2) ]
  gen_det_sorted(:,:,:,1) = psi_ref(:,:,:N_det_ref)
  gen_det_sorted(:,:,:,2) = psi_ref(:,:,:N_det_ref)
  call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_ref, N_int)
  call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_ref, N_int)
END_PROVIDER


subroutine find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList)

 use bitmasks
 implicit none

  integer, intent(in)            :: n_selected, Nint

  integer(bit_kind), intent(in)  :: det_buffer(Nint,2,n_selected)
  integer                        :: i,j,k,m
  logical                        :: is_in_wavefunction
  integer                        :: degree(psi_det_size)
  integer                        :: idx(0:psi_det_size)
  logical                        :: good

  integer(bit_kind), intent(out) :: tq(Nint,2,n_selected)
  integer, intent(out)           :: N_tq
  
  
  integer                        :: nt,ni
  logical, external              :: is_connected_to
  
  
  integer(bit_kind),intent(in)  :: miniList(Nint,2,N_det_ref)
  integer,intent(in)            :: N_miniList

  
  
  N_tq = 0
  
  
  i_loop : do i=1,N_selected
    if(is_connected_to(det_buffer(1,1,i), miniList, Nint, N_miniList)) then
      cycle
    end if

    if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det_ref)) then
      N_tq += 1
      do k=1,N_int
        tq(k,1,N_tq) = det_buffer(k,1,i)
        tq(k,2,N_tq) = det_buffer(k,2,i)
      enddo
    endif
  enddo i_loop
end