pickRandomOrb_scalar Subroutine

public subroutine pickRandomOrb_scalar(csf_i, orbRes, pgen, orb, occRes)

Arguments

Type IntentOptional Attributes Name
type(CSF_Info_t), intent(in) :: csf_i
integer, intent(in) :: orbRes
real(kind=dp), intent(inout) :: pgen
integer, intent(out) :: orb
integer, intent(in), optional :: occRes

Contents

Source Code


Source Code

    subroutine pickRandomOrb_scalar(csf_i, orbRes, pgen, orb, occRes)
        ! routine to pick a random orbital under certain orbital and/or
        ! occupation number restrictions and gives the probability to pick
        ! this orbital
        ! these orbitals for now are chosen uniformly and not with any
        ! cauchy schwarz like criteria involving the one- and two-particle
        ! integrals
        type(CSF_Info_t), intent(in) :: csf_i
        integer, intent(in) :: orbRes
        real(dp), intent(inout) :: pgen
        integer, intent(out) :: orb
        integer, intent(in), optional :: occRes
        character(*), parameter :: this_routine = "pickRandomOrb_scalar"

        integer :: r, nOrbs, ierr
        logical :: mask(nSpatOrbs)
        integer, allocatable :: resOrbs(:)

        ASSERT(orbRes >= 0 .and. orbRes <= nSpatOrbs)
        ! could make this a global, permanent variable... should even!
!         orbInd = [ (r, r = 1, nBasis/2) ]

        ! create a list of the available orbitals under the provided
        ! restrictions:
        if (orbRes == 0) then
            ! in this case a occRes should be provided or else one could
            ! just create a random number between 1, nBasis/2 without this
            ! function
            ASSERT(present(occRes))
            ASSERT(occRes >= 0 .and. occRes <= 2)

            mask = (csf_i%Occ_int /= occRes)

        else
            ! check i occRes is present
            if (present(occRes)) then
                ASSERT(occRes >= 0 .and. occRes <= 2)
                mask = ((csf_i%Occ_int /= occRes) .and. (orbitalIndex /= orbRes))

            else
                ! only orbital restriction
                mask = (orbitalIndex /= orbRes)

            end if
        end if

        nOrbs = count(mask)
        ! here i could use nOrbs to indicate that no excitation is possible
        ! no -> just check outside if resorbs is size 0
        ! but i get a error further down if i access resOrbs(1)

        if (nOrbs > 0) then
            allocate(resOrbs(nOrbs), stat=ierr)

            resOrbs = pack(orbitalIndex, mask)

            r = 1 + floor(genrand_real2_dSFMT() * real(nOrbs, dp))

            orb = resOrbs(r)

            ! TODO: modify the pgen probabilities!
            ! here it should be 1/nOrbs, since its uniform isnt it?
            pgen = pgen / real(nOrbs, dp)

            deallocate(resOrbs)
        else
            ! indicate that no orbital is fitting with r = 0
            orb = 0

            ! do i have to set pgen to zero? probably
            pgen = 0.0_dp
        end if

    end subroutine pickRandomOrb_scalar