10
0
mirror of https://github.com/LCPQ/quantum_package synced 2024-12-22 20:35:19 +01:00
quantum_package/plugins/MRPT_Utils/mrpt_dress.irp.f
2017-04-13 14:55:10 +02:00

224 lines
7.0 KiB
Fortran

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),delta_e)
if(degree_scalar.eq.1)then
delta_e = 1.d+20
endif
! print*, 'delta_e',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) = electronic_psi_ref_average_value(1) - hjj
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
endif
hij_array(index_i) = hialpha
! print*, 'hialpha ',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