GAS_doubles_PCHB_spinorb_compute_samplers Subroutine

private subroutine GAS_doubles_PCHB_spinorb_compute_samplers(this, nBI, PCHB_particle_selection)

computes and stores values for the alias (spin-independent) sampling table

Type Bound

GAS_PCHB_DoublesSpinOrbFastWeightedExcGenerator_t

Arguments

Type IntentOptional Attributes Name
class(GAS_PCHB_DoublesSpinOrbFastWeightedExcGenerator_t), intent(inout) :: this
integer, intent(in) :: nBI
type(PCHB_ParticleSelection_t), intent(in) :: PCHB_particle_selection

Contents


Source Code

    subroutine GAS_doubles_PCHB_spinorb_compute_samplers(this, nBI, PCHB_particle_selection)
        !! computes and stores values for the alias (spin-independent) sampling table
        class(GAS_PCHB_DoublesSpinOrbFastWeightedExcGenerator_t), intent(inout) :: this
        integer, intent(in) :: nBI
        type(PCHB_ParticleSelection_t), intent(in) :: PCHB_particle_selection
        integer :: I, J, IJ, IJMax
        integer :: A, B, AB, ABMax
        integer(int64) :: memCost
            !! n_supergroup * num_fused_indices * bytes_per_sampler
        real(dp), allocatable :: w(:), IJ_weights(:, :, :)
        integer, allocatable :: supergroups(:, :)
        integer :: i_sg
        ! possible supergroups
        supergroups = this%indexer%get_supergroups()

        ! number of possible spin orbital pairs
        ijMax = fuseIndex(nBI, nBI)
        abMax = ijMax

        memCost = size(supergroups, 2, kind=int64) &
                  * int(ijMax, int64) &
                  * int(abMax, int64) * 8_int64

        write(stdout, *) "Excitation generator requires", real(memCost, dp) / 2.0_dp**30, "GB of memory"
        write(stdout, *) "The number of supergroups is", size(supergroups, 2)
        write(stdout, *) "Generating samplers for PCHB excitation generator"
        write(stdout, *) "Depending on the number of supergroups this can take up to 10min."

        call this%AB_sampler%shared_alloc([ijMax, size(supergroups, 2)], abMax, 'AB_PCHB_spinorb_sampler')

        ! One could allocate only on the intra-node-root here, if memory
        ! at initialization ever becomes an issue.
        ! Look at `gasci_pchb_doubles_spin_fulllyweighted.fpp` for inspiration.
        allocate(w(abMax), IJ_weights(nBI, nBI, size(supergroups, 2)), source=0._dp)

        supergroup: do i_sg = 1, size(supergroups, 2)
            if (mod(i_sg, 100) == 0) write(stdout, *) 'Still generating the samplers'
            first_particle: do I = 1, nBI
                ! A,B are ordered, so we can assume I < J
                second_particle: do J = I + 1, nBI
                    w(:) = 0._dp
                    ! for each (I,J), get all matrix elements <IJ|H|AB> and use them as
                    ! weights to prepare the sampler
                    first_hole: do A = 1, nBI
                        if (any(A == [I, J])) cycle
                        second_hole: do B = 1, nBI
                            if (any(B == [I, J, A])) cycle
                            AB = fuseIndex(A, B)
                            associate(exc => merge(Excite_2_t(I, A, J, B), Excite_2_t(I, B, J, A), A < B))
                                if (this%GAS_spec%is_allowed(exc, supergroups(:, i_sg)) .and. spin_allowed(exc)) then
                                    w(AB) = get_PCHB_weight(exc)
                                end if
                            end associate
                        end do second_hole
                    end do first_hole
                    IJ = fuseIndex(I, J)
                    call this%AB_sampler%setup_entry(IJ, i_sg, root, w)

                    IJ_weights(I, J, i_sg) = sum(w)
                    IJ_weights(J, I, i_sg) = IJ_weights(I, J, i_sg)
                end do second_particle
            end do first_particle
        end do supergroup

        call allocate_and_init(PCHB_particle_selection, this%GAS_spec, &
            IJ_weights, root, this%use_lookup, this%particle_selector)

    end subroutine GAS_doubles_PCHB_spinorb_compute_samplers