pick_b_orb_guga_mol Subroutine

private subroutine pick_b_orb_guga_mol(csf_i, occ_orbs, orb_a, cc_b, int_contrib, cum_sum, orb_b, orb_res, range_flag)

Arguments

Type IntentOptional Attributes Name
type(CSF_Info_t), intent(in) :: csf_i
integer, intent(in) :: occ_orbs(2)
integer, intent(in) :: orb_a
integer, intent(in) :: cc_b
real(kind=dp), intent(out) :: int_contrib
real(kind=dp), intent(out) :: cum_sum
integer, intent(out) :: orb_b
integer, intent(in), optional :: orb_res
logical, intent(in), optional :: range_flag

Contents

Source Code


Source Code

    subroutine pick_b_orb_guga_mol(csf_i, occ_orbs, orb_a, cc_b, int_contrib, &
                                   cum_sum, orb_b, orb_res, range_flag)
        ! restrict the b, if orbital (a) is singly occupied already..
        ! and switch to spatial orbital picking!
        type(CSF_Info_t), intent(in) :: csf_i
        integer, intent(in) :: occ_orbs(2), orb_a, cc_b
        real(dp), intent(out) :: int_contrib, cum_sum
        integer, intent(out) :: orb_b
        integer, intent(in), optional :: orb_res
        logical, intent(in), optional :: range_flag
        character(*), parameter :: this_routine = "pick_b_orb_guga_mol"

        real(dp) :: cum_arr(OrbClassCount(cc_b)), r
        integer :: nOrbs, label_index, i, orb, orb_index
        logical :: tSingle

        ! rewrite this funcitonality new:
        nOrbs = OrbClassCount(cc_b)

        label_index = SymLabelCounts2(1, cc_b)

        cum_sum = 0.0_dp

        ! have to predetermine is already picked orbital is singly occupied
        ! already: if yes, its not allowd to be picked again in here
        if (csf_i%Occ_int(orb_a) == 1) then
            tSingle = .true.
        else
            tSingle = .false.
        end if

        ! make a spatial orbital list of symmetry allowed orbitals!
        ! but that probably should be done globally in the setup phase, since
        ! this does not change
        ! did that in sym_label_list_spat

        ! depending on input do the specific loops
        if (present(range_flag)) then
            if (range_flag) then
                ASSERT(present(orb_res))
                ASSERT(orb_res /= 0)

                ! the case that a whole range is forbidden due to GUGA restrictions
                ! is only in the case, when orbital (a) is on of the original I,J
                ! orbitals, so in this case a will not be chosen due to the
                ! GUGA restrictions already

                ! the direction of the range is indicated through the sign of the
                ! index restriciton
                if (orb_res < 0) then
                    ! only orbitals below orb_res allowed
                    do i = 1, nOrbs
                        orb = sym_label_list_spat(label_index + i - 1)

                        if (csf_i%stepvector(orb) /= 3 .and. orb < -orb_res) then
                            cum_sum = cum_sum + &
                                      get_guga_integral_contrib(occ_orbs, orb_a, orb)
                        end if

                        cum_arr(i) = cum_sum
                    end do
                else
                    ! only orbitals above orb_res are allowed!
                    do i = 1, nOrbs
                        orb = sym_label_list_spat(label_index + i - 1)

                        if (csf_i%stepvector(orb) /= 3 .and. orb > orb_res) then
                            cum_sum = cum_sum + &
                                      get_guga_integral_contrib(occ_orbs, orb_a, orb)
                        end if

                        cum_arr(i) = cum_sum
                    end do
                end if
            end if
        else
            if (present(orb_res)) then
                ! should i assert here, that orb_res should not be 0?
                ! otherwise it would be stupid to input..
                ASSERT(orb_res /= 0)
                ASSERT(orb_res > 0)
                ! but now i have to include that orb (a) might be off-limits!
                if (tSingle) then
                    ! then orb_a is also off-limits!
                    do i = 1, nOrbs
                        orb = sym_label_list_spat(label_index + i - 1)

                        if (csf_i%stepvector(orb) /= 3 .and. orb /= orb_res &
                            .and. orb /= orb_a) then
                            cum_sum = cum_sum + &
                                      get_guga_integral_contrib(occ_orbs, orb_a, orb)
                        end if

                        cum_arr(i) = cum_sum
                    end do
                else
                    ! orb a is not off-limits
                    do i = 1, nOrbs
                        orb = sym_label_list_spat(label_index + i - 1)

                        if (csf_i%stepvector(orb) /= 3 .and. orb /= orb_res) then
                            cum_sum = cum_sum + &
                                      get_guga_integral_contrib(occ_orbs, orb_a, orb)
                        end if

                        cum_arr(i) = cum_sum

                    end do
                end if
            else
                ! no guga restrictions, only have to check if orb a was single
                if (tSingle) then
                    do i = 1, nOrbs
                        orb = sym_label_list_spat(label_index + i - 1)

                        if (csf_i%stepvector(orb) /= 3 .and. orb /= orb_a) then
                            cum_sum = cum_sum + &
                                      get_guga_integral_contrib(occ_orbs, orb_a, orb)
                        end if

                        cum_arr(i) = cum_sum
                    end do
                else
                    ! no restrictions except double occuations
                    do i = 1, nOrbs
                        orb = sym_label_list_spat(label_index + i - 1)

                        if (csf_i%stepvector(orb) /= 3) then
                            cum_sum = cum_sum + &
                                      get_guga_integral_contrib(occ_orbs, orb_a, orb)
                        end if
                        cum_arr(i) = cum_sum
                    end do
                end if
            end if
        end if

        if (near_zero(cum_sum)) then
            orb_b = 0
            return
        end if

        r = genrand_real2_dSFMT() * cum_sum
        orb_index = binary_search_first_ge(cum_arr, r)

        orb_b = sym_label_list_spat(label_index + orb_index - 1)

        if (orb_index == 1) then
            int_contrib = cum_arr(orb_index)
        else
            int_contrib = cum_arr(orb_index) - cum_arr(orb_index - 1)
        end if

    end subroutine pick_b_orb_guga_mol