subroutine create_crude_guga_single(ilut, nI, csf_i, exc, pgen, excitInfo_in)
integer(n_int), intent(in) :: ilut(0:nifguga)
integer, intent(in) :: nI(nel)
type(CSF_Info_t), intent(in) :: csf_i
integer(n_int), intent(out) :: exc(0:nifguga)
real(dp), intent(out) :: pgen
type(ExcitationInformation_t), intent(in), optional :: excitInfo_in
character(*), parameter :: this_routine = "create_crude_guga_single"
type(ExcitationInformation_t) :: excitInfo
integer :: i, j, st, en, start_d, end_d, gen
real(dp) :: orb_pgen, r, branch_pgen
HElement_t(dp) :: mat_ele
integer(n_int) :: ilutI(0:niftot), ilutJ(0:niftot)
ASSERT(isProperCSF_ilut(ilut))
! can i use the original orbital picker? no.. since it allows for
! switches..
if (present(excitInfo_in)) then
excitInfo = excitInfo_in
else
call pick_orbitals_single_crude(ilut, nI, csf_i, excitInfo, orb_pgen)
end if
if (.not. excitInfo%valid) then
! if no valid indices were picked, return 0 excitation and return
exc = 0_n_int
pgen = 0.0_dp
return
end if
! reimplement it from scratch
i = excitInfo%i
j = excitInfo%j
! try to make a valid, determinant-like single excitation,
! respecting the spin-character of the CSF
st = excitInfo%fullStart
en = excitInfo%fullEnd
gen = excitInfo%currentGen
start_d = csf_i%stepvector(st)
end_d = csf_i%stepvector(en)
branch_pgen = 1.0_dp
exc = ilut
associate(b => csf_i%B_int)
if (start_d == 3) then
! here we now it is a lowering generator with d_j = 1 or 2
! with restrictions however
! here a d_j = 2 is theoretically possible
ASSERT(gen == gen_type%L)
ASSERT(end_d /= 3)
if (end_d == 0) then
if (all(b(st:en - 1) > 0)) then
! in this case both starts are possible!
r = genrand_real2_dSFMT()
if (r < 0.5_dp) then
! make a 3 -> 1 and 0 -> 2
set_zero(exc, st)
set_one(exc, st)
set_two(exc, en)
else
! make 3 -> 2 and 0 -> 1
set_zero(exc, st)
set_two(exc, st)
set_one(exc, en)
end if
branch_pgen = 0.5_dp
else
! here only 3 > 1 and 0 > 2 is possible
! make
set_zero(exc, st)
set_one(exc, st)
set_two(exc, en)
end if
else if (end_d == 1) then
! then only the 3 > 1 start is possible and b is irrelevant
! make 3 > 1 and 1 > 3
set_zero(exc, st)
set_one(exc, st)
set_three(exc, en)
else if (end_d == 2) then
! this is only possible if all b are > 0
if (all(b(st:en - 1) > 0)) then
! make 3 > 2 and 2 > 3
set_zero(exc, st)
set_two(exc, st)
set_three(exc, en)
else
pgen = 0.0_dp
exc = 0_n_int
return
end if
end if
else if (start_d == 0) then
! here we know it is a raising generator
ASSERT(gen == gen_type%R)
ASSERT(end_d /= 0)
if (end_d == 3) then
if (all(b(st:en - 1) > 0)) then
r = genrand_real2_dSFMT()
if (r < 0.5_dp) then
! make 0 > 1 and 3 > 2
set_one(exc, st)
set_zero(exc, en)
set_two(exc, en)
else
! make 0 > 2 and 3 > 1
set_two(exc, st)
set_zero(exc, en)
set_one(exc, en)
end if
branch_pgen = 0.5_dp
else
! make 0 > 1 and 3 > 2
set_one(exc, st)
set_zero(exc, en)
set_two(exc, en)
end if
else if (end_d == 1) then
! make 0 > 1 and 1 > 0
set_one(exc, st)
set_zero(exc, en)
else if (end_d == 2) then
if (all(b(st:en - 1) > 0)) then
! make 0 > 2 and 2 > 0
set_two(exc, st)
set_zero(exc, en)
else
pgen = 0.0_dp
exc = 0_n_int
return
end if
end if
else if (start_d == 1) then
if (all(b(st:en - 1) > 0) .and. end_d /= 1) then
! only in this case it is possible
if (end_d == 2) then
if (gen == gen_type%R) then
! make 1 > 3 and 2 > 0
set_three(exc, st)
set_zero(exc, en)
else if (gen == gen_type%L) then
! make 1 > 0 and 2 > 3
set_zero(exc, st)
set_three(exc, en)
end if
else if (end_d == 3) then
ASSERT(gen == gen_type%R)
! make 1 > 3 and 3 > 1
set_three(exc, st)
set_zero(exc, en)
set_one(exc, en)
else if (end_d == 0) then
ASSERT(gen == gen_type%L)
! make 1 > 0 and 0 > 1
set_zero(exc, st)
set_one(exc, en)
end if
else
pgen = 0.0_dp
exc = 0_n_int
return
end if
else if (start_d == 2) then
! here I do not have a b restriction or?
if (end_d == 0) then
ASSERT(gen == gen_type%L)
! make 2 > 0 and 0 > 2
set_zero(exc, st)
set_two(exc, en)
else if (end_d == 3) then
ASSERT(gen == gen_type%R)
! make 2 > 3 and 3 > 2
set_three(exc, st)
set_zero(exc, en)
set_two(exc, en)
else if (end_d == 1) then
if (gen == gen_type%R) then
! make 2 > 3 and 1 > 0
set_three(exc, st)
set_zero(exc, en)
else if (gen == gen_type%L) then
! make 2 > 0 and 1 > 3
set_zero(exc, st)
set_three(exc, en)
end if
else if (end_d == 2) then
pgen = 0.0_dp
exc = 0_n_int
return
end if
end if
end associate
! we also want to check if we produced a valid CSF here
if (.not. isProperCSF_ilut(exc, .true.)) then
exc = 0_n_int
pgen = 0.0_dp
return
end if
call calc_guga_matrix_element(ilutI, csf_i, ilutJ, CSF_Info_t(ilutJ), excitInfo, mat_ele, .true.)
if (near_zero(mat_ele)) then
exc = 0_n_int
pgen = 0.0_dp
return
end if
call encode_matrix_element(exc, 0.0_dp, 2)
call encode_matrix_element(exc, mat_ele, 1)
global_excitInfo = excitInfo
if (present(excitInfo_in)) then
! then the orbitals were already picked before and we only want
! to give the branch_pgen here
pgen = branch_pgen
else
! otherwise we want the full pgen
pgen = orb_pgen * branch_pgen
end if
end subroutine create_crude_guga_single