pickOrbs_real_hubbard_single Subroutine

public subroutine pickOrbs_real_hubbard_single(ilut, nI, csf_i, excitInfo, pgen)

Arguments

Type IntentOptional Attributes Name
integer(kind=n_int), intent(in) :: ilut(0:nifguga)
integer, intent(in) :: nI(nel)
type(CSF_Info_t), intent(in) :: csf_i
type(ExcitationInformation_t), intent(out) :: excitInfo
real(kind=dp), intent(out) :: pgen

Contents


Source Code

    subroutine pickOrbs_real_hubbard_single(ilut, nI, csf_i, excitInfo, pgen)
        ! write a specialized orbital picker for the real-space hubbard
        ! implementation, since we do not need all the symmetry stuff and
        ! we have to take the correct TMAT values for the ml-spin values
        integer(n_int), intent(in) :: ilut(0:nifguga)
        integer, intent(in) :: nI(nel)
        type(CSF_Info_t), intent(in) :: csf_i
        type(ExcitationInformation_t), intent(out) :: excitInfo
        real(dp), intent(out) :: pgen
        character(*), parameter :: this_routine = "pickOrbs_real_hubbard_single"

        integer :: elec, orb_i, orb_a
        real(dp) :: cum_arr(nSpatOrbs), elec_factor, cum_sum, r

        unused_var(ilut)

        ! first pick electron randomly:
        elec = 1 + floor(genrand_real2_dSFMT() * nel)

        orb_i = gtID(nI(elec))

        ! still use cum arrays to enable applying guga restrictions!
        ! but all orbitals are possible now of course

        select case (csf_i%stepvector(orb_i))

        case (1)
            ! i need a switch possibility for other d = 1 values
            call gen_cum_list_real_hub_1(csf_i, orb_i, cum_arr)

            elec_factor = 1.0_dp

        case (2)
            ! i need a switch possibility for other d = 2 values
            call gen_cum_list_real_hub_2(csf_i, orb_i, cum_arr)

            elec_factor = 1.0_dp

        case (3)
            ! no restrictions actually
            call gen_cum_list_real_hub_3(csf_i, orb_i, cum_arr)

            ! but twice the chance to have picked this spatial orbital:
            elec_factor = 2.0_dp

        case default
            call stop_all(this_routine, "should not have picked empty orb!")

        end select

        cum_sum = cum_arr(nSpatOrbs)

        if (near_zero(cum_sum)) then
            orb_a = 0
            excitInfo%valid = .false.
            return
        else
            r = genrand_real2_dSFMT() * cum_sum
            orb_a = binary_search_first_ge(cum_arr, r)

            if (orb_a == 1) then
                pgen = cum_arr(1) / cum_sum
            else
                pgen = (cum_arr(orb_a) - cum_arr(orb_a - 1)) / cum_sum

            end if
        end if

        ASSERT(orb_a /= orb_i)

        pgen = pgen * elec_factor / real(nel, dp)

        if (orb_a < orb_i) then
            ! raising generator
            excitInfo = assign_excitInfo_values_single(gen_type%R, orb_a, orb_i, orb_a, orb_i)

        else
            ! lowering generator
            excitInfo = assign_excitInfo_values_single(gen_type%L, orb_a, orb_i, orb_i, orb_a)

        end if

    end subroutine pickOrbs_real_hubbard_single