calcDoubleLowering Subroutine

public subroutine calcDoubleLowering(ilut, csf_i, excitInfo, excitations, nExcits, posSwitches, negSwitches)

Arguments

Type IntentOptional Attributes Name
integer(kind=n_int), intent(in) :: ilut(0:nifguga)
type(CSF_Info_t), intent(in) :: csf_i
type(ExcitationInformation_t), intent(inout) :: excitInfo
integer(kind=n_int), intent(out), allocatable :: excitations(:,:)
integer, intent(out) :: nExcits
real(kind=dp), intent(in) :: posSwitches(nSpatOrbs)
real(kind=dp), intent(in) :: negSwitches(nSpatOrbs)

Contents

Source Code


Source Code

    subroutine calcDoubleLowering(ilut, csf_i, excitInfo, excitations, nExcits, &
                                  posSwitches, negSwitches)
        ! this function can deal with 2 lowering and the mixed R->L-R
        ! case, since the called functions are the same
        integer(n_int), intent(in) :: ilut(0:nifguga)
        type(CSF_Info_t), intent(in) :: csf_i
        type(ExcitationInformation_t), intent(inout) :: excitInfo
        integer(n_int), intent(out), allocatable :: excitations(:, :)
        integer, intent(out) :: nExcits
        real(dp), intent(in) :: posSwitches(nSpatOrbs), negSwitches(nSpatOrbs)
        character(*), parameter :: this_routine = "calcDoubleLowering"

        integer :: iOrb, start2, ende1, ende2
        type(WeightObj_t) :: weights
        real(dp) :: plusWeight, minusWeight, zeroWeight
        integer(n_int), allocatable :: tempExcits(:, :)
        !todo asserts

#ifdef DEBUG_
        if (excitInfo%gen1 == excitInfo%gen2) then
            ASSERT(.not. isZero(ilut, excitInfo%fullStart))
            ASSERT(.not. isZero(ilut, excitInfo%secondStart))
            ASSERT(.not. isThree(ilut, excitInfo%firstEnd))
            ASSERT(.not. isThree(ilut, excitInfo%fullEnd))
        else
            ASSERT(.not. isThree(ilut, excitInfo%fullStart))
            ASSERT(.not. isZero(ilut, excitInfo%secondStart))
            ASSERT(.not. isThree(ilut, excitInfo%firstEnd))
            ASSERT(.not. isZero(ilut, excitInfo%fullEnd))
        end if
#endif

        start2 = excitInfo%secondStart
        ende1 = excitInfo%firstEnd
        ende2 = excitInfo%fullEnd

        ! : create correct weights:
        weights = init_fullDoubleWeight(csf_i, start2, ende1, ende2, negSwitches(start2), &
                                        negSwitches(ende1), posSwitches(start2), posSwitches(ende1), &
                                        csf_i%B_real(start2), csf_i%B_real(ende1))

        excitInfo%currentGen = excitInfo%firstGen
        ! then do single start:
        call createSingleStart(ilut, csf_i, excitInfo, posSwitches, negSwitches, &
                               weights, tempExcits, nExcits)

        ! and single update until semi start
        do iOrb = excitInfo%fullStart + 1, excitInfo%secondStart - 1
            call singleUpdate(ilut, csf_i, iOrb, excitInfo, posSwitches, negSwitches, &
                              weights, tempExcits, nExcits)
        end do

        ! change weights... maybe need both single and double type weights
        ! then do lowering semi start
        weights = weights%ptr

        minusWeight = weights%proc%minus(negSwitches(start2), csf_i%B_real(start2), weights%dat)
        plusWeight = weights%proc%plus(posSwitches(start2), csf_i%B_real(start2), weights%dat)
        zeroWeight = weights%proc%zero(negSwitches(start2), posSwitches(start2), &
                                       csf_i%B_real(start2), weights%dat)

        call calcLoweringSemiStart(ilut, csf_i, excitInfo, &
                                   tempExcits, nExcits, plusWeight, minusWeight, zeroWeight)

        ! then do double excitation over double excitation region
        do iOrb = excitInfo%secondStart + 1, excitInfo%firstEnd - 1
            call doubleUpdate(ilut, csf_i, iOrb, excitInfo, weights, tempExcits, nExcits, &
                              negSwitches, posSwitches)
        end do

        ! update weights again:
        weights = weights%ptr
        minusWeight = weights%proc%minus(negSwitches(ende1), csf_i%B_real(ende1), weights%dat)
        plusWeight = weights%proc%plus(posSwitches(ende1), csf_i%B_real(ende1), weights%dat)

        ! then do lowering semi stop
        call calcLoweringSemiStop(ilut, csf_i, excitInfo, tempExcits, nExcits, plusWeight, &
                                  minusWeight)

        ! have to set the used generators correctly to handle more versions

        ! and then do final single region again
        do iOrb = excitInfo%firstEnd + 1, excitInfo%fullEnd - 1
            call singleUpdate(ilut, csf_i, iOrb, excitInfo, posSwitches, negSwitches, &
                              weights, tempExcits, nExcits)
        end do

        ! and finally end step
        call singleEnd(ilut, csf_i, excitInfo, tempExcits, nExcits, excitations)

    end subroutine calcDoubleLowering