Performs a spill operation on a single array of DP vectors with shape (NDIM, n) This is the inverse of a spill operation
| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| real(kind=DP), | intent(inout), | dimension(:,:), allocatable | :: | keeps | Array of values to keep |
|
| real(kind=DP), | intent(inout), | dimension(:,:), allocatable | :: | discards | Array discards |
|
| logical, | intent(in), | dimension(:) | :: | lspill_list | Logical array of bodies to spill into the discards |
|
| logical, | intent(in) | :: | ldestructive | Logical flag indicating whether or not this operation should alter the keeps array or not |
subroutine base_util_spill_arr_DPvec(keeps, discards, lspill_list, ldestructive)
!! author: David A. Minton
!!
!! Performs a spill operation on a single array of DP vectors with shape (NDIM, n)
!! This is the inverse of a spill operation
implicit none
! Arguments
real(DP), dimension(:,:), allocatable, intent(inout) :: keeps
!! Array of values to keep
real(DP), dimension(:,:), allocatable, intent(inout) :: discards
!! Array discards
logical, dimension(:), intent(in) :: lspill_list
!! Logical array of bodies to spill into the discards
logical, intent(in) :: ldestructive
!! Logical flag indicating whether or not this operation should alter the keeps array or not
! Internals
integer(I4B) :: i, nspill, nkeep, nlist
real(DP), dimension(:,:), allocatable :: tmp
!! Array of values to keep
nkeep = count(.not.lspill_list(:))
nspill = count(lspill_list(:))
nlist = size(lspill_list(:))
if (.not.allocated(keeps) .or. nspill == 0) return
if (size(keeps) < nkeep) return
if (.not.allocated(discards)) then
allocate(discards(NDIM, nspill))
else if (size(discards, dim=2) /= nspill) then
deallocate(discards)
allocate(discards(NDIM, nspill))
end if
do i = 1, NDIM
discards(i,:) = pack(keeps(i,1:nlist), lspill_list(1:nlist))
end do
if (ldestructive) then
if (nkeep > 0) then
allocate(tmp(NDIM, nkeep))
do i = 1, NDIM
tmp(i, :) = pack(keeps(i, 1:nlist), .not. lspill_list(1:nlist))
end do
call move_alloc(tmp, keeps)
else
deallocate(keeps)
end if
end if
return
end subroutine base_util_spill_arr_DPvec