gen_excit_back_spawn_hubbard Subroutine

public subroutine gen_excit_back_spawn_hubbard(nI, ilutI, nJ, ilutJ, exFlag, ic, ExcitMat, tParity, pgen, HElGen, store, part_type)

Arguments

Type IntentOptional Attributes Name
integer, intent(in) :: nI(nel)
integer(kind=n_int), intent(in) :: ilutI(0:niftot)
integer, intent(out) :: nJ(nel)
integer(kind=n_int), intent(out) :: ilutJ(0:niftot)
integer, intent(in) :: exFlag
integer, intent(out) :: ic
integer, intent(out) :: ExcitMat(2,maxExcit)
logical, intent(out) :: tParity
real(kind=dp), intent(out) :: pgen
real(kind=dp), intent(out) :: HElGen
type(excit_gen_store_type), intent(inout), target :: store
integer, intent(in), optional :: part_type

Contents


Source Code

    subroutine gen_excit_back_spawn_hubbard(nI, ilutI, nJ, ilutJ, exFlag, ic, &
                                            ExcitMat, tParity, pgen, HelGen, store, part_type)
        integer, intent(in) :: nI(nel), exFlag
        integer(n_int), intent(in) :: ilutI(0:niftot)
        integer, intent(out) :: nJ(nel), ic, ExcitMat(2, maxExcit)
        integer(n_int), intent(out) :: ilutJ(0:niftot)
        logical, intent(out) :: tParity
        real(dp), intent(out) :: pgen
        HElement_t(dp), intent(out) :: HElGen
        type(excit_gen_store_type), intent(inout), target :: store
        integer, intent(in), optional :: part_type
        character(*), parameter :: this_routine = "gen_excit_back_spawn_hubbard"

        integer :: iUnused
#ifdef DEBUG_
        real(dp) :: pgen2
        HElement_t(dp) :: temp_hel
#endif
        ! so now pack everything necessary for a ueg excitation generator.

        ! why is ilutJ not created here? do it!
        HelGen = 0.0_dp
        iUnused = exFlag
        iUnused = store%nopen

        ic = 2

        ! this function gets pointed to if tUEG, t_back_spawn_flex and tLatticeGens
        ! is set
        ! BUT: again: we also need to take care of the HPHF keyword..
        ! which is a mess

        ! implement it for now without this tNoFailAb flag
        ASSERT(.not. tNoFailAb)

        if ((t_back_spawn .or. t_back_spawn_flex) .and. .not. &
            test_flag(ilutI, get_initiator_flag(part_type))) then

            call gen_double_back_spawn_hubbard(nI, ilutI, nJ, ilutJ, tParity, ExcitMat, &
                                               pgen)

#ifdef DEBUG_
            if (.not. IsNullDet(nJ)) then
                pgen2 = calc_pgen_back_spawn_hubbard(nI, ilutI, ExcitMat, ic, part_type)
                if (abs(pgen - pgen2) > 1.0e-6_dp) then
                    if (tHPHF) then
                        print *, "due to circular dependence, no matrix element calc possible!"
!                         temp_hel = hphf_off_diag_helement(nI,nJ,ilutI,ilutJ)
                        temp_hel = 0.0_dp
                    else
                        temp_hel = get_helement(nI, nJ, ilutI, ilutJ)
                    end if

                    write(stdout, *) 'Calculated and actual pgens differ. for non-initiator'
                    write(stdout, *) 'This will break HPHF calculations'
                    call write_det(stdout, nI, .false.)
                    write(stdout, '(" --> ")', advance='no')
                    call write_det(stdout, nJ, .true.)
                    write(stdout, *) 'Excitation matrix: ', ExcitMat(1, 1:ic), '-->', &
                        ExcitMat(2, 1:ic)
                    write(stdout, *) 'Generated pGen:  ', pgen
                    write(stdout, *) 'Calculated pGen: ', pgen2
                    write(stdout, *) 'matrix element: ', temp_hel
                    call stop_all(this_routine, "Invalid pGen")
                end if
            end if
#endif
        else
            ! do i want to rewrite the old on or just reuse? for now reuse:
            call CreateExcitLattice(nI, ilutI, nJ, tParity, ExcitMat, pgen, part_type)

            if (.not. IsNullDet(nJ)) ilutJ = make_ilutJ(ilutI, ExcitMat, ic)

#ifdef DEBUG_
            if (.not. IsNullDet(nJ)) then
                call CalcPGenLattice(ExcitMat, pgen2)
                if (abs(pgen - pgen2) > 1.0e-6_dp) then
                    if (tHPHF) then
                        print *, "due to circular dependence, no matrix element calc possible!"
!                         temp_hel = hphf_off_diag_helement(nI,nJ,ilutI,ilutJ)
                        temp_hel = 0.0_dp
                    else
                        temp_hel = get_helement(nI, nJ, ilutI, ilutJ)
                    end if

                    write(stdout, *) 'Calculated and actual pgens differ. for non-initiator'
                    write(stdout, *) 'This will break HPHF calculations'
                    call write_det(stdout, nI, .false.)
                    write(stdout, '(" --> ")', advance='no')
                    call write_det(stdout, nJ, .true.)
                    write(stdout, *) 'Excitation matrix: ', ExcitMat(1, 1:ic), '-->', &
                        ExcitMat(2, 1:ic)
                    write(stdout, *) 'Generated pGen:  ', pgen
                    write(stdout, *) 'Calculated pGen: ', pgen2
                    write(stdout, *) 'matrix element: ', temp_hel
                    call stop_all(this_routine, "Invalid pGen")
                end if
            end if
#endif
        end if

    end subroutine gen_excit_back_spawn_hubbard