pick_weighted_elecs Subroutine

public subroutine pick_weighted_elecs(nI, elecs, src, sym_prod, ispn, sum_ml, pgen)

Arguments

Type IntentOptional Attributes Name
integer, intent(in) :: nI(nel)
integer, intent(out) :: elecs(2)
integer, intent(out) :: src(2)
integer, intent(out) :: sym_prod
integer, intent(out) :: ispn
integer, intent(out) :: sum_ml
real(kind=dp), intent(out) :: pgen

Contents

Source Code


Source Code

    subroutine pick_weighted_elecs(nI, elecs, src, sym_prod, ispn, sum_ml, &
                                   pgen)

        integer, intent(in) :: nI(nel)
        integer, intent(out) :: elecs(2), src(2), sym_prod, ispn, sum_ml
        real(dp), intent(out) :: pgen
        character(*), parameter :: this_routine = 'pick_weighted_elecs'

        logical, parameter :: tlinear = .true.
        logical, parameter :: tlinear2 = .false.

        real(dp) :: cum_sum, cpt, final_cpt, r
        real(dp), allocatable, save :: cum_list(:), cum_list_ii(:)
        real(dp) :: cum_sum_ii, cpt_ii, cpt_jj
        integer :: i, ind1, ind2
        integer, allocatable, save :: inds(:)

        if (.not. allocated(cum_list)) allocate(cum_list(nel))
        if (.not. allocated(cum_list_ii)) allocate(cum_list_ii(nel))
        if (.not. allocated(inds)) allocate(inds(nel))

        ! Pick the first electron uniformly, or according to <ii|ii>,
        ! and then pick the second electron according to <ji|ji>

        inds = gtID(nI)
        if (tlinear) then
            ! Pick the first electron uniformly
            elecs(1) = 1 + floor(genrand_real2_dSFMT() * nel)
            cpt_ii = 1.0_dp
            cum_sum_ii = nel
        else
            ! Pick the first electron according to <ii|ii>
            cum_sum_ii = 0
            do i = 1, nel
                cum_sum_ii = cum_sum_ii &
                             + abs(get_umat_el(inds(i), inds(i), &
                                               inds(i), inds(i)))
                cum_list_ii(i) = cum_sum_ii
            end do

            r = genrand_real2_dSFMT() * cum_sum_ii
            elecs(1) = binary_search_first_ge(cum_list_ii, r)
            if (elecs(1) == 1) then
                cpt_ii = cum_list_ii(1)
            else
                cpt_ii = cum_list_ii(elecs(1)) - cum_list_ii(elecs(1) - 1)
            end if
        end if

        ! Construct the weighted list <ji|ji>
        cum_sum = 0
        ind1 = inds(elecs(1))
        do i = 1, nel
            if (i == elecs(1)) then
                cpt = 0
            else
                if (tlinear2) then
                    cpt = 1.0
                else
                    cpt = abs(get_umat_el(ind1, inds(i), ind1, inds(i)))
                end if
                if (.not. tGUGA) then
                    if (is_beta(nI(i)) .eqv. is_beta(nI(elecs(1)))) then
                        cpt = cpt * pParallel
                    else
                        cpt = cpt * (1.0_dp - pParallel)
                    end if
                end if
            end if
            cum_sum = cum_sum + cpt
            cum_list(i) = cum_sum
        end do

        ! Get the appropriate index
        r = genrand_real2_dSFMT() * cum_sum
        elecs(2) = binary_search_first_ge(cum_list, r)

        ! Calculate the (partial) probability
        if (elecs(2) == 1) then
            cpt = cum_list(1)
        else
            cpt = cum_list(elecs(2)) - cum_list(elecs(2) - 1)
        end if
        pgen = (cpt_ii / cum_sum_ii) * cpt / cum_sum

        ! To calculate the generation probability, we need to consider the
        ! possibility of having picked the electrons in the order j, i.
        ! Construct the reverse list
        cum_sum = 0
        ind2 = inds(elecs(2))
        do i = 1, nel
            if (i == elecs(2)) then
                cpt = 0
            else
                if (tlinear2) then
                    cpt = 1.0
                else
                    cpt = abs(get_umat_el(ind2, inds(i), ind2, inds(i)))
                end if
                if (.not. tGUGA) then
                    if (is_beta(nI(i)) .eqv. is_beta(nI(elecs(2)))) then
                        cpt = cpt * pParallel
                    else
                        cpt = cpt * (1.0_dp - pParallel)
                    end if
                end if
            end if
            if (i == elecs(1)) final_cpt = cpt
            cum_sum = cum_sum + cpt
        end do

        ! And get the component for the second electron in the initial list
        if (tlinear) then
            cpt_jj = 1.0_dp
        else
            if (elecs(2) == 1) then
                cpt_jj = cum_list_ii(1)
            else
                cpt_jj = cum_list_ii(elecs(2)) - cum_list_ii(elecs(2) - 1)
            end if
        end if

        ! Adjust the probability for the j,i choice and then the 1/N one
        pgen = pgen + ((cpt_jj / cum_sum_ii) * (final_cpt / cum_sum))

        ! Generate the orbitals under consideration
        src = nI(elecs)

        if (is_beta(src(1)) .eqv. is_beta(src(2))) then
            if (is_beta(src(1))) then
                iSpn = 1
            else
                iSpn = 3
            end if
        else
            iSpn = 2
        end if

        ! The Ml value is obtained from the orbitals
        sum_ml = sum(G1(src)%Ml)

        ! And the spatial symmetries
        sym_prod = RandExcitSymLabelProd(SpinOrbSymLabel(src(1)), &
                                         SpinOrbSymLabel(src(2)))

    end subroutine pick_weighted_elecs