base_util_spill_arr_char_string Subroutine

  1. base_module.f90
  2. base
  3. base_util_spill_arr_char_string

public subroutine base_util_spill_arr_char_string(keeps, discards, lspill_list, ldestructive)

Performs a spill operation on a single array of type character strings This is the inverse of a spill operation

Arguments

TypeIntentOptionalAttributesName
character(len=STRMAX), intent(inout), dimension(:), allocatable:: keeps

Array of values to keep

character(len=STRMAX), intent(inout), dimension(:), allocatable:: discards

Array of 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


Called by

proc~~base_util_spill_arr_char_string~~CalledByGraph proc~base_util_spill_arr_char_string base_util_spill_arr_char_string interface~util_spill util_spill interface~util_spill->proc~base_util_spill_arr_char_string

Contents

Source Code

base_util_spill_arr_char_string

Source Code

      subroutine base_util_spill_arr_char_string(keeps, discards, lspill_list, ldestructive)
         !! author: David A. Minton 
         !! 
         !! Performs a spill operation on a single array of type character strings 
         !! This is the inverse of a spill operation 
         implicit none
         ! Arguments
         character(len=STRMAX), dimension(:), allocatable, intent(inout) :: keeps        
            !! Array of values to keep  
         character(len=STRMAX), dimension(:), allocatable, intent(inout) :: discards     
            !! Array of 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) :: nspill, nkeep, nlist
         character(len=STRMAX), 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(nspill))
         else if (size(discards) /= nspill) then
            deallocate(discards)
            allocate(discards(nspill))
         end if

         discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist))
         if (ldestructive) then
            if (nkeep > 0) then
               allocate(tmp(nkeep))
               tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist))
               call move_alloc(tmp, keeps)
            else
               deallocate(keeps)
            end if
         end if

         return
      end subroutine base_util_spill_arr_char_string