gen_all_singles_rs_hub_default Subroutine

public subroutine gen_all_singles_rs_hub_default(nI, n_excits, det_list, sign_list)

Arguments

Type IntentOptional Attributes Name
integer, intent(in) :: nI(nel)
integer, intent(out) :: n_excits
integer(kind=n_int), intent(out), allocatable :: det_list(:,:)
real(kind=dp), intent(out), optional, allocatable :: sign_list(:)

Contents


Source Code

    subroutine gen_all_singles_rs_hub_default(nI, n_excits, det_list, sign_list)
        integer, intent(in) :: nI(nel)
        integer, intent(out) :: n_excits
        integer(n_int), intent(out), allocatable :: det_list(:, :)
        real(dp), intent(out), allocatable, optional :: sign_list(:)
#if defined(DEBUG_) || defined(CMPLX_)
        character(*), parameter :: this_routine = "gen_all_singles_rs_hub_default"
#endif
        integer(n_int) :: ilut(0:NIfTot), ilutJ(0:NIfTot)
        integer :: n_bound, i, src, j, neigh, ex(2, 2), pos, nJ(nel)
        integer(n_int), allocatable :: temp_list(:, :)
        integer, allocatable :: neighbors(:)
        HElement_t(dp) :: elem
        real(dp), allocatable :: temp_sign(:)
        logical :: t_sign, tpar

        ASSERT(associated(lat))

        call EncodeBitDet(nI, ilut)

        n_excits = 1

        n_bound = nel * (nbasis - nel)
        allocate(temp_list(0:NIfTot, n_bound))
        temp_list = 0_n_int

        if (present(sign_list)) then
            t_sign = .true.
            allocate(temp_sign(n_bound), source=0.0_dp)
        else
            t_sign = .false.
        end if

        ex = 0
        ! loop over electrons
        do i = 1, nel
            src = nI(i)
            ex(1, 1) = src
            neighbors = lat%get_spinorb_neighbors(src)

            ! and loop over the neighboring sites of this electron
            do j = 1, size(neighbors)

                neigh = neighbors(j)

                ex(2, 1) = neigh

                ASSERT(same_spin(src, neigh))

                ! if it is not occupied it should be a possible excitation
                if (IsNotOcc(ilut, neighbors(j))) then
                    ! but to be sure, check the matrix element:
                    ! but use the lattice get_helement_lattice to
                    ! avoid circular dependencies
                    call make_single(nI, nJ, i, neighbors(j), ex, tpar)
                    elem = get_helement_lattice(nI, nJ)

                    if (abs(elem) > EPS) then

                        ilutJ = make_ilutJ(ilut, ex, 1)

                        ! actually a search is not really necessary.. since
                        ! all the single excitations are unique.. but
                        ! just to be sure
                        pos = binary_search_ilut(temp_list(:, 1:n_excits), ilutJ, nifd + 1)

                        if (pos < 0) then

                            temp_list(:, n_excits) = ilutJ

                            if (t_sign) then
#ifdef CMPLX_
                                call stop_all(this_routine, "not implemented for complex")
#else
                                temp_sign(n_excits) = sign(1.0_dp, elem)
                                call sort(temp_list(:, 1:n_excits), temp_sign(1:n_excits))
#endif
                            else
                                call sort(temp_list(:, 1:n_excits), ilut_lt, ilut_gt)
                            end if
                            n_excits = n_excits + 1
                            ! damn.. i have to sort everytime i guess..
                        end if
                    end if
                end if
            end do
        end do

        n_excits = n_excits - 1
        allocate(det_list(0:NIfTot, n_excits), source=temp_list(:, 1:n_excits))

        if (t_sign) then
            allocate(sign_list(n_excits), source=temp_sign(1:n_excits))

            call sort(det_list, sign_list)
        else
            call sort(det_list, ilut_lt, ilut_gt)
        end if

    end subroutine gen_all_singles_rs_hub_default