LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-11-03 12:43:52 +01:00
Code Issues Releases Wiki Activity
cc53cff932
quantum_package/plugins/MRPT_Utils/second_order_new.irp.f

758 lines
35 KiB
Fortran
Raw Normal View History

second order for 1h2p with mono excitations
2016-09-18 19:46:13 +02:00
subroutine give_1h2p_new(matrix_1h2p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*)
integer :: i,v,r,a,b,c
integer :: iorb, vorb, rorb, aorb, borb,corb
integer :: ispin,jspin
integer :: idet,jdet
integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2)
double precision :: perturb_dets_phase(n_act_orb,2,2)
double precision :: perturb_dets_hij(n_act_orb,2,2)
double precision :: perturb_dets_hpsi0(n_act_orb,2,2,N_states)
logical :: already_generated(n_act_orb,2,2)
integer :: inint
integer :: elec_num_tab_local(2),acu_elec
integer(bit_kind) :: det_tmp(N_int,2)
integer(bit_kind) :: det_tmp_j(N_int,2)
integer :: exc(0:2,2,2)
integer :: accu_elec
conflicts minimized for merge
2016-11-02 17:39:39 +01:00
double precision :: get_mo_bielec_integral
second order for 1h2p with mono excitations
2016-09-18 19:46:13 +02:00
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
double precision :: accu_contrib(N_states)
integer :: degree(N_det)
integer :: idx(0:N_det)
double precision :: delta_e(n_act_orb,2,N_states)
double precision :: delta_e_inv(n_act_orb,2,N_states)
second order ok for 2h1p
2016-09-18 20:53:28 +02:00
double precision :: delta_e_inactive_virt(N_states)
second order for 1h2p with mono excitations
2016-09-18 19:46:13 +02:00
integer :: istate
integer :: index_orb_act_mono(N_det,6)
integer :: kspin
double precision :: delta_e_ja(N_states)
double precision :: hja
double precision :: contrib_hij
double precision :: fock_operator_local(n_act_orb,n_act_orb,2)
double precision :: hij_test
integer ::i_ok
integer(bit_kind) :: det_tmp_bis(N_int,2)
double precision :: hib , hab
double precision :: delta_e_ab(N_states)
double precision :: hib_test,hja_test,hab_test
integer :: i_hole,i_part
double precision :: hia,hjb
integer :: other_spin(2)
other_spin(1) = 2
other_spin(2) = 1
accu_contrib = 0.d0
!matrix_1h2p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
enddo
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do v = 1, n_virt_orb ! First virtual
vorb = list_virt(v)
do r = 1, n_virt_orb ! Second virtual
rorb = list_virt(r)
! take all the integral you will need for i,j,r fixed
do a = 1, n_act_orb
aorb = list_act(a)
conflicts minimized for merge
2016-11-02 17:39:39 +01:00
active_int(a,1) = get_mo_bielec_integral(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct
active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange
second order for 1h2p with mono excitations
2016-09-18 19:46:13 +02:00
perturb_dets_phase(a,1,1) = -1000.d0
perturb_dets_phase(a,1,2) = -1000.d0
perturb_dets_phase(a,2,2) = -1000.d0
perturb_dets_phase(a,2,1) = -1000.d0
enddo
do istate = 1, N_states
delta_e_inactive_virt(istate) = &
- fock_virt_total_spin_trace(rorb,istate) &
- fock_virt_total_spin_trace(vorb,istate) &
+ fock_core_inactive_total_spin_trace(iorb,istate)
enddo
do idet = 1, N_det
call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb)
do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb)
do a = 1, n_act_orb ! First active
aorb = list_act(a)
do istate = 1, N_states
perturb_dets_hpsi0(a,jspin,ispin,istate) = 0.d0
enddo
if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
enddo
! Do the excitation inactive -- > virtual
call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin
call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin
! Do the excitation active -- > virtual
call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin
call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin
! Check if the excitation is possible or not on psi_det(idet)
accu_elec= 0
do inint = 1, N_int
accu_elec+= popcnt(det_tmp(inint,jspin))
enddo
if(accu_elec .ne. elec_num_tab_local(jspin))then
perturb_dets_phase(a,jspin,ispin) = -1000.0d0
perturb_dets_hij(a,jspin,ispin) = 0.d0
cycle
endif
do inint = 1, N_int
perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1)
perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2)
enddo
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
perturb_dets_phase(a,jspin,ispin) = phase
do istate = 1, N_states
delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) + delta_e_inactive_virt(istate)
delta_e_inv(a,jspin,istate) = 1.d0 / delta_e(a,jspin,istate)
enddo
if(ispin == jspin)then
perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,1) - active_int(a,2) )
else
perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1)
endif
enddo
enddo
enddo
!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS
!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a^{\dagger}_b a_{a} | Idet>
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | K_{ab} | Idet>
do jdet = 1, idx(0)
if(degree(jdet)==1)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
i_hole = list_act_reverse(exc(1,1,1)) !!! a_a
i_part = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b}
kspin = 1 !!! kspin
index_orb_act_mono(idx(jdet),1) = i_hole
index_orb_act_mono(idx(jdet),2) = i_part
index_orb_act_mono(idx(jdet),3) = kspin
call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij)
fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator
fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator
else
! Mono beta
i_hole = list_act_reverse(exc(1,1,2)) !!! a_a
i_part = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b}
kspin = 2 !!! kspin
index_orb_act_mono(idx(jdet),1) = i_hole
index_orb_act_mono(idx(jdet),2) = i_part
index_orb_act_mono(idx(jdet),3) = kspin
call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij)
fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator
fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator
endif
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
else if(degree(jdet)==2)then
call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
! Mono alpha
index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a ALPHA
index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} ALPHA
index_orb_act_mono(idx(jdet),3) = 1
! Mono beta
index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,1,2)) !!! a_a BETA
index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} BETA
index_orb_act_mono(idx(jdet),6) = 2
second order for 1h2p with mono excitations
2016-09-18 19:46:13 +02:00
endif
enddo
do jdet = 1, idx(0)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CASE OF THE MONO EXCITATIONS
if(degree(jdet) == 1)then
! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator
! are connected by the presence of the perturbers determinants |det_tmp>
aorb = index_orb_act_mono(idx(jdet),1) ! a_{aorb}
borb = index_orb_act_mono(idx(jdet),2) ! a^{\dagger}_{borb}
kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation
! the determinants Idet and Jdet interact throw the following operator
! | Jdet > = a^{\dagger}_{borb,kspin} a_{aorb, kspin} | Idet >
accu_contrib = 0.d0
do ispin = 1, 2 ! you loop on all possible spin for the excitation
! a^{\dagger}_r a_{i} (ispin)
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
! if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count
logical :: cycle_same_spin_first_order
cycle_same_spin_first_order = .False.
if(ispin == kspin .and. vorb.le.rorb)then
cycle_same_spin_first_order = .True.
second order for 1h2p with mono excitations
2016-09-18 19:46:13 +02:00
endif
Now compiles with gfortran
2016-11-02 23:55:19 +01:00
! if(ispin .ne. kspin .and. cycle_same_spin_first_order .eqv. .False. )then ! condition not to double count
if(cycle_same_spin_first_order .eqv. .False. )then ! condition not to double count
second order for 1h2p with mono excitations
2016-09-18 19:46:13 +02:00
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
! FIRST ORDER CONTRIBUTION
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet >
if(perturb_dets_phase(aorb,kspin,ispin) .le. -10.d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin)
enddo
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
if(kspin == ispin)then
hia = phase * (active_int(aorb,1) - active_int(aorb,2) )
else
hia = phase * active_int(aorb,1)
endif
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
if(kspin == ispin)then
hja = phase * (active_int(borb,1) - active_int(borb,2) )
else
hja = phase * active_int(borb,1)
endif
contrib_hij = hja * hia
do istate = 1, N_states
accu_contrib(istate) += contrib_hij * delta_e_inv(aorb,kspin,istate)
enddo
endif
second order for 1h2p with mono excitations
2016-09-18 19:46:13 +02:00
!!!! SECOND ORDER CONTRIBTIONS
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,jspin} a_{corb,jspin} a_{iorb,ispin} | Idet >
do jspin = 1, 2
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
logical :: cycle_same_spin_second_order
cycle_same_spin_second_order = .False.
if(ispin == jspin .and. vorb.le.rorb)then
cycle_same_spin_second_order = .True.
endif
Now compiles with gfortran
2016-11-02 23:55:19 +01:00
if(cycle_same_spin_second_order .eqv. .False.)then
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
do corb = 1, n_act_orb
if(perturb_dets_phase(corb,jspin,ispin) .le. -10.d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
enddo
! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet >
call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok)
if(i_ok .ne. 1)cycle
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
hia = perturb_dets_hij(corb,jspin,ispin)
hab = fock_operator_local(aorb,borb,kspin) * phase
if(dabs(hia).le.1.d-12)cycle
if(dabs(hab).le.1.d-12)cycle
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
if(jspin == ispin)then
hjb = phase * (active_int(corb,1) - active_int(corb,2) )
else
hjb = phase * active_int(corb,1)
endif
if(dabs(hjb).le.1.d-12)cycle
do istate = 1, N_states
accu_contrib(istate)+=hia * delta_e_inv(corb,jspin,istate) & ! | Idet > --> | det_tmp >
! | det_tmp > --> | det_tmp_bis >
*hab / (delta_e(corb,jspin,istate) + one_anhil_one_creat(aorb,borb,kspin,kspin,istate)) &
*hjb
enddo
second order for 1h2p with mono excitations
2016-09-18 19:46:13 +02:00
enddo
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
endif
second order for 1h2p with mono excitations
2016-09-18 19:46:13 +02:00
enddo
enddo ! ispin
do istate = 1, N_states
matrix_1h2p(idet,idx(jdet),istate) += accu_contrib(istate)
enddo
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
else if (degree(jdet) == 2)then
! CASE OF THE DOUBLE EXCITATIONS, ONLY THIRD ORDER EFFECTS
accu_contrib = 0.d0
do ispin = 1, 2 ! you loop on all possible spin for the excitation
! a^{\dagger}_r a_{i} (ispin)
! if it is standard exchange case, the hole ALPHA == the part. BETA
if (index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then
aorb = index_orb_act_mono(idx(jdet),1) !! the HOLE of the ALPHA electron
borb = index_orb_act_mono(idx(jdet),4) !! the HOLE of the BETA electron
! first case :: | det_tmp > == a_{borb,\beta} | Idet >
cycle_same_spin_second_order = .False.
if(ispin == 2 .and. vorb.le.rorb)then
cycle_same_spin_second_order = .True.
endif
Now compiles with gfortran
2016-11-02 23:55:19 +01:00
if(cycle_same_spin_second_order .eqv. .False.)then ! condition not to double count
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
if(perturb_dets_phase(borb,2,ispin) .le. -10.d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,borb,2,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,borb,2,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,borb,2,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,borb,2,ispin)
enddo
hia = perturb_dets_hij(borb,2,ispin)
if(dabs(hia).le.1.d-12)cycle
call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),1,i_ok)
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
hab = fock_operator_local(aorb,borb,1) * phase
if(dabs(hab).le.1.d-12)cycle
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
if(ispin == 2)then
hjb = phase * (active_int(aorb,1) - active_int(aorb,2) )
else if (ispin == 1)then
hjb = phase * active_int(aorb,1)
endif
if(dabs(hjb).le.1.d-12)cycle
do istate = 1, N_states
accu_contrib(istate) += hia * delta_e_inv(borb,2,istate) & ! | Idet > --> | det_tmp >
! | det_tmp > --> | det_tmp_bis >
* hab / (delta_e(borb,2,istate) + one_anhil_one_creat(aorb,borb,1,1,istate)) &
* hjb
enddo
endif
! second case :: | det_tmp > == a_{aorb,\alpha} | Idet >
cycle_same_spin_second_order = .False.
if(ispin == 1 .and. vorb.le.rorb)then
cycle_same_spin_second_order = .True.
endif
Now compiles with gfortran
2016-11-02 23:55:19 +01:00
if(cycle_same_spin_second_order .eqv. .False.)then ! condition not to double count
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
if(perturb_dets_phase(aorb,1,ispin) .le. -10.d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,aorb,1,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,aorb,1,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,1,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,1,ispin)
enddo
hia = perturb_dets_hij(aorb,1,ispin)
if(dabs(hia).le.1.d-12)cycle
call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),2,i_ok)
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
hab = fock_operator_local(aorb,borb,2) * phase
if(dabs(hab).le.1.d-12)cycle
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
if(ispin == 1)then
hjb = phase * (active_int(borb,1) - active_int(borb,2) )
else if (ispin == 2)then
hjb = phase * active_int(borb,1)
endif
if(dabs(hjb).le.1.d-12)cycle
do istate = 1, N_states
accu_contrib(istate) += hia * delta_e_inv(aorb,1,istate) & ! | Idet > --> | det_tmp >
! | det_tmp > --> | det_tmp_bis >
* hab / (delta_e(aorb,1,istate) + one_anhil_one_creat(borb,aorb,2,2,istate)) &
* hjb
enddo
endif
! if it is a closed shell double excitation, the hole ALPHA == the hole BETA
else if (index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),4))then
aorb = index_orb_act_mono(idx(jdet),1) !! the HOLE of the ALPHA electron
borb = index_orb_act_mono(idx(jdet),2) !! the PART of the ALPHA electron
! first case :: | det_tmp > == a_{aorb,\beta} | Idet >
cycle_same_spin_second_order = .False.
if(ispin == 2 .and. vorb.le.rorb)then
cycle_same_spin_second_order = .True.
endif
Now compiles with gfortran
2016-11-02 23:55:19 +01:00
if(cycle_same_spin_second_order .eqv. .False.)then ! condition not to double count
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
if(perturb_dets_phase(aorb,2,ispin) .le. -10.d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,aorb,2,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,aorb,2,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,2,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,2,ispin)
enddo
hia = perturb_dets_hij(aorb,2,ispin)
if(dabs(hia).le.1.d-12)cycle
call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),1,i_ok)
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
hab = fock_operator_local(aorb,borb,1) * phase
if(dabs(hab).le.1.d-12)cycle
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
if(ispin == 2)then
hjb = phase * (active_int(borb,1) - active_int(borb,2) )
else if (ispin == 1)then
hjb = phase * active_int(borb,1)
endif
if(dabs(hjb).le.1.d-12)cycle
do istate = 1, N_states
accu_contrib(istate) += hia * delta_e_inv(aorb,2,istate) & ! | Idet > --> | det_tmp >
! | det_tmp > --> | det_tmp_bis >
* hab / (delta_e(aorb,2,istate) + one_anhil_one_creat(aorb,borb,1,1,istate)) &
* hjb
enddo
endif
! second case :: | det_tmp > == a_{aorb,\alpha} | Idet >
cycle_same_spin_second_order = .False.
if(ispin == 1 .and. vorb.le.rorb)then
cycle_same_spin_second_order = .True.
endif
Now compiles with gfortran
2016-11-02 23:55:19 +01:00
if(cycle_same_spin_second_order .eqv. .False.)then ! condition not to double count
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
if(perturb_dets_phase(aorb,1,ispin) .le. -10.d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,aorb,1,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,aorb,1,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,1,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,1,ispin)
enddo
hia = perturb_dets_hij(aorb,1,ispin)
if(dabs(hia).le.1.d-12)cycle
call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),2,i_ok)
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
hab = fock_operator_local(aorb,borb,2) * phase
if(dabs(hab).le.1.d-12)cycle
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
if(ispin == 1)then
hjb = phase * (active_int(borb,1) - active_int(borb,2) )
else if (ispin == 2)then
hjb = phase * active_int(borb,1)
endif
if(dabs(hjb).le.1.d-12)cycle
do istate = 1, N_states
accu_contrib(istate) += hia * delta_e_inv(aorb,1,istate) & ! | Idet > --> | det_tmp >
! | det_tmp > --> | det_tmp_bis >
* hab / (delta_e(aorb,1,istate) + one_anhil_one_creat(aorb,borb,2,2,istate)) &
* hjb
enddo
endif
else
! one should not fall in this case ...
call debug_det(psi_det(1,1,i),N_int)
call debug_det(psi_det(1,1,idx(jdet)),N_int)
call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
call decode_exc(exc,2,h1,p1,h2,p2,s1,s2)
integer :: h1, p1, h2, p2, s1, s2
print*, h1, p1, h2, p2, s1, s2
print*, 'pb !!! it is a double but not an exchange case ....'
stop
endif
enddo ! ispin
do istate = 1, N_states
matrix_1h2p(idet,idx(jdet),istate) += accu_contrib(istate)
enddo
second order for 1h2p with mono excitations
2016-09-18 19:46:13 +02:00
else if (degree(jdet) == 0)then
! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations
!
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet >
accu_contrib = 0.d0
do ispin = 1, 2
do kspin = 1, 2
do a = 1, n_act_orb ! First active
if( perturb_dets_phase(a,kspin,ispin) .le. -10.d0)cycle
if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count
contrib_hij = perturb_dets_hij(a,kspin,ispin) * perturb_dets_hij(a,kspin,ispin)
do istate = 1, N_states
accu_contrib(istate) += contrib_hij * delta_e_inv(a,kspin,istate)
enddo
enddo
enddo
enddo
do istate = 1, N_states
matrix_1h2p(idet,idet,istate) += accu_contrib(istate)
enddo
endif
enddo !! jdet
enddo
enddo
enddo
enddo
second order ok for 2h1p
2016-09-18 20:53:28 +02:00
end
subroutine give_2h1p_new(matrix_2h1p)
use bitmasks
implicit none
double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*)
integer :: i,j,r,a,b
integer :: iorb, jorb, rorb, aorb, borb
integer :: ispin,jspin
integer :: idet,jdet
integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2)
double precision :: perturb_dets_phase(n_act_orb,2,2)
double precision :: perturb_dets_hij(n_act_orb,2,2)
integer :: inint
integer :: elec_num_tab_local(2),acu_elec
integer(bit_kind) :: det_tmp(N_int,2)
integer :: exc(0:2,2,2)
integer :: accu_elec
conflicts minimized for merge
2016-11-02 17:39:39 +01:00
double precision :: get_mo_bielec_integral
second order ok for 2h1p
2016-09-18 20:53:28 +02:00
double precision :: active_int(n_act_orb,2)
double precision :: hij,phase
integer :: i_hole,i_part
double precision :: delta_e_inv(n_act_orb,2,N_states)
double precision :: fock_operator_local(n_act_orb,n_act_orb,2)
double precision :: delta_e_inactive_virt(N_states)
integer :: degree(N_det)
integer :: idx(0:N_det)
double precision :: delta_e(n_act_orb,2,N_states)
integer :: istate
integer :: index_orb_act_mono(N_det,3)
integer :: kspin
double precision :: hij_test
double precision :: accu_contrib(N_states)
double precision :: contrib_hij
double precision :: hja
integer :: corb,i_ok
integer(bit_kind) :: det_tmp_bis(N_int,2)
double precision :: hia,hjb,hab
!matrix_2h1p = 0.d0
elec_num_tab_local = 0
do inint = 1, N_int
elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
enddo
do i = 1, n_inact_orb ! First inactive
iorb = list_inact(i)
do j = 1, n_inact_orb ! Second inactive
jorb = list_inact(j)
do r = 1, n_virt_orb ! First virtual
rorb = list_virt(r)
! take all the integral you will need for i,j,r fixed
do a = 1, n_act_orb
aorb = list_act(a)
conflicts minimized for merge
2016-11-02 17:39:39 +01:00
active_int(a,1) = get_mo_bielec_integral(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct
active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange
second order ok for 2h1p
2016-09-18 20:53:28 +02:00
perturb_dets_phase(a,1,1) = -1000.d0
perturb_dets_phase(a,1,2) = -1000.d0
perturb_dets_phase(a,2,2) = -1000.d0
perturb_dets_phase(a,2,1) = -1000.d0
enddo
do istate = 1, N_states
delta_e_inactive_virt(istate) = &
- fock_virt_total_spin_trace(rorb,istate) &
+ fock_core_inactive_total_spin_trace(iorb,istate) &
+ fock_core_inactive_total_spin_trace(jorb,istate)
enddo
do idet = 1, N_det
call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements
do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r)
do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a)
if(ispin == jspin .and. iorb.le.jorb)cycle ! condition not to double count
do a = 1, n_act_orb ! First active
aorb = list_act(a)
do inint = 1, N_int
det_tmp(inint,1) = psi_det(inint,1,idet)
det_tmp(inint,2) = psi_det(inint,2,idet)
enddo
! Do the excitation inactive -- > virtual
call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin
call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin
! Do the excitation inactive -- > active
call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin
call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin
! Check if the excitation is possible or not on psi_det(idet)
accu_elec= 0
do inint = 1, N_int
accu_elec+= popcnt(det_tmp(inint,jspin))
enddo
if(accu_elec .ne. elec_num_tab_local(jspin))then
perturb_dets_phase(a,jspin,ispin) = -1000.0d0
perturb_dets_hij(a,jspin,ispin) = 0.d0
cycle
endif
do inint = 1, N_int
perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1)
perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2)
enddo
call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
perturb_dets_phase(a,jspin,ispin) = phase
do istate = 1, N_states
delta_e(a,jspin,istate) = one_creat(a,jspin,istate) + delta_e_inactive_virt(istate)
delta_e_inv(a,jspin,istate) = 1.d0 / delta_e(a,jspin,istate)
enddo
if(ispin == jspin)then
perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,1) - active_int(a,2) )
else
perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1)
endif
!!!!!!!!!!!!!!!!!!!!!1 Computation of the coefficient at first order coming from idet
!!!!!!!!!!!!!!!!!!!!! for the excitation (i,j)(ispin,jspin) ---> (r,a)(ispin,jspin)
enddo
enddo
enddo
!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS
!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator
!!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a_{b} a^{\dagger}_a | Idet>
do jdet = 1, idx(0)
if(degree(jdet)==1)then
call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
i_part = list_act_reverse(exc(1,2,1)) ! a^{\dagger}_{aorb}
i_hole = list_act_reverse(exc(1,1,1)) ! a_{borb}
kspin = 1
index_orb_act_mono(idx(jdet),1) = i_part !!! a^{\dagger}_a
index_orb_act_mono(idx(jdet),2) = i_hole !!! a_{b}
index_orb_act_mono(idx(jdet),3) = 1
call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij)
fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator
fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator
else
! Mono beta
i_part = list_act_reverse(exc(1,2,2))
i_hole = list_act_reverse(exc(1,1,2))
kspin = 2
index_orb_act_mono(idx(jdet),1) = i_part !!! a^{\dagger}_a
index_orb_act_mono(idx(jdet),2) = i_hole !!! a_{b}
index_orb_act_mono(idx(jdet),3) = 2
call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij)
fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator
fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator
endif
endif
enddo
do jdet = 1, idx(0)
! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator
! are connected by the presence of the perturbers determinants |det_tmp>
if(degree(jdet) == 1)then
aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb}
borb = index_orb_act_mono(idx(jdet),2) ! a_{borb}
kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation
! the determinants Idet and Jdet interact throw the following operator
! | Jdet > = a_{borb,kspin} a^{\dagger}_{aorb, kspin} | Idet >
accu_contrib = 0.d0
do ispin = 1, 2 ! you loop on all possible spin for the excitation
! a^{\dagger}_r a_{i} (ispin)
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
! if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count
logical :: cycle_same_spin_first_order
cycle_same_spin_first_order = .False.
if(ispin == kspin .and. iorb.le.jorb)then
cycle_same_spin_first_order = .True.
second order ok for 2h1p
2016-09-18 20:53:28 +02:00
endif
Now compiles with gfortran
2016-11-02 23:55:19 +01:00
if(ispin .ne. kspin .or. cycle_same_spin_first_order .eqv. .False. )then! condition not to double count
second order ok for 2h1p
2016-09-18 20:53:28 +02:00
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet >
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin)
enddo
! you determine the interaction between the excited determinant and the other parent | Jdet >
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet >
! hja = < det_tmp | H | Jdet >
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
if(kspin == ispin)then
hja = phase * (active_int(borb,1) - active_int(borb,2) )
else
hja = phase * active_int(borb,1)
endif
!! if(dabs(hja).le.1.d-10)cycle
do istate = 1, N_states
accu_contrib(istate) += hja * perturb_dets_hij(aorb,kspin,ispin) * delta_e_inv(aorb,kspin,istate)
enddo
endif
logical :: cycle_same_spin_second_order
second order ok for 2h1p
2016-09-18 20:53:28 +02:00
!!!! SECOND ORDER CONTRIBUTIONS
!!!! SECOND ORDER CONTRIBTIONS
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{corb,jspin} a_{jorb,jspin} a_{iorb,ispin} | Idet >
do jspin = 1, 2
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
cycle_same_spin_second_order = .False.
if(ispin == jspin .and. iorb.le.jorb)then
cycle_same_spin_second_order = .True.
endif
Now compiles with gfortran
2016-11-02 23:55:19 +01:00
if(ispin .ne. jspin .or. cycle_same_spin_second_order .eqv. .False. )then! condition not to double count
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
do corb = 1, n_act_orb
if(perturb_dets_phase(corb,jspin,ispin) .le. -10.d0)cycle
do inint = 1, N_int
det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin)
det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin)
enddo
! | det_tmp_bis > = a^{\dagger}_{aorb,kspin} a_{borb,kspin} a_{iorb,kspin} | Idet >
call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),kspin,i_ok)
if(i_ok .ne. 1)cycle
hia = perturb_dets_hij(corb,jspin,ispin)
if(dabs(hia).le.1.d-10)cycle
call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
hab = fock_operator_local(borb,aorb,kspin) * phase
if(dabs(hab).le.1.d-10)cycle
call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
if(jspin == ispin)then
hjb = phase * (active_int(corb,1) - active_int(corb,2) )
else
hjb = phase * active_int(corb,1)
endif
if(dabs(hjb).le.1.d-10)cycle
do istate = 1, N_states
accu_contrib(istate)+=hia * delta_e_inv(corb,jspin,istate) & ! | Idet > --> | det_tmp >
! | det_tmp > --> | det_tmp_bis >
*hab / (delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate)) &
*hjb
enddo
enddo ! jspin
endif
second order ok for 2h1p
2016-09-18 20:53:28 +02:00
enddo
enddo ! ispin
do istate = 1, N_states
matrix_2h1p(idx(jdet),idet,istate) += accu_contrib(istate)
enddo
else if (degree(jdet) == 0 )then
! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations
!
! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet >
accu_contrib = 0.d0
do ispin = 1, 2
do kspin = 1, 2
if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count
do a = 1, n_act_orb ! First active
contrib_hij = perturb_dets_hij(a,kspin,ispin) * perturb_dets_hij(a,kspin,ispin)
definitive version for the second order of 1h2p and 2h1p
2016-09-19 13:38:37 +02:00
if(dabs(contrib_hij).le.1.d-10)cycle
second order ok for 2h1p
2016-09-18 20:53:28 +02:00
do istate = 1, N_states
accu_contrib(istate) += contrib_hij * delta_e_inv(a,kspin,istate)
enddo
enddo
enddo
enddo
do istate =1, N_states
matrix_2h1p(idet,idet,istate) += accu_contrib(istate)
enddo
endif
enddo
enddo
enddo
enddo
enddo
second order for 1h2p with mono excitations
2016-09-18 19:46:13 +02:00
end
second order ok for 2h1p
2016-09-18 20:53:28 +02:00
Reference in New Issue Copy Permalink