Attachment 1551 Details for Bug 9826 – failing preprocessed code

failing preprocessed code

vec{str}.F90.pre (text/plain), 31.14 KB, created by Andrey V Khavryuchenko on 2006-07-31 18:14:04 MSD

(hide)

Description:

Filename:

MIME Type:

Creator: Andrey V Khavryuchenko

Created: 2006-07-31 18:14:04 MSD

Size: 31.14 KB

patch

obsolete

># 1 "GNU-f95-on-LINUX/f95files/vec{str}.F90"
># 1 "<built-in>"
># 1 "<command line>"
># 1 "GNU-f95-on-LINUX/f95files/vec{str}.F90"
>!---------------------------------------------------------------------------
>!
>!  VEC{STR}: String vectors
>!
>!  Notes
>!
>!  Normally, a STR variable means a character string of length STR_SIZE.
>!  However, in this module we use assumed length character strings.
>!  Note also that ELEMENT_TYPE_SIZE is defind as "len(self(1))*CHR_SIZE".
>!
>! Copyright (C) Dylan Jayatilaka, 1998
>!
>! This library is free software; you can redistribute it and/or
>! modify it under the terms of the GNU Library General Public
>! License as published by the Free Software Foundation; either
>! version 2 of the License, or (at your option) any later version.
>!
>! This library is distributed in the hope that it will be useful,
>! but WITHOUT ANY WARRANTY; without even the implied warranty of
>! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
>! Library General Public License for more details.
>!
>! You should have received a copy of the GNU Library General Public
>! License along with this library; if not, write to the
>! Free Software Foundation, Inc., 59 Temple Place - Suite 330,
>! Boston, MA  02111-1307, USA.
>!
>! $Id: vec{str}.foo 2787 2006-04-18 05:35:01Z dylan_ $
>!---------------------------------------------------------------------------
>
>module VEC_STR_MODULE
>
>   use TYPES_MODULE
>
>   use SYSTEM_MODULE
>
>   use STR_MODULE, only: remove_blanks_
>   use STR_MODULE, only: replace_all_
>   use STR_MODULE, only: same_as_
>   use STR_MODULE, only: to_lower_case_
>   use STR_MODULE, only: to_upper_case_
>
>   use VEC_INT_MODULE, only: create_
>   use VEC_INT_MODULE, only: destroy_
>
>   implicit none
>
>
>
>
>
>   private
>
>   public    append_
>   interface append_
>      module procedure append_0
>      module procedure append_1
>   end interface
>
>   public    append_only_if_unique_
>   interface append_only_if_unique_
>      module procedure append_only_if_unique
>   end interface
>
>   public    copy_
>   interface copy_
>      module procedure copy
>   end interface
>
>   public    create_
>   interface create_
>      module procedure create_0
>      module procedure create_1
>      module procedure create_2
>   end interface
>
>   public    create_copy_
>   interface create_copy_
>      module procedure create_copy
>   end interface
>
>   public    destroy_
>   interface destroy_
>      module procedure destroy
>   end interface
>
>   public    equals_
>   interface equals_
>      module procedure equals
>   end interface
>
>   public    expand_
>   interface expand_
>      module procedure expand
>   end interface
>
>   public    has_any_included_in_
>   interface has_any_included_in_
>      module procedure has_any_included_in
>   end interface
>
>   public    has_any_including_
>   interface has_any_including_
>      module procedure has_any_including
>   end interface
>
>   public    has_repetitions_
>   interface has_repetitions_
>      module procedure has_repetitions
>   end interface
>
>   public    includes_
>   interface includes_
>      module procedure includes
>   end interface
>
>   public    index_of_
>   interface index_of_
>      module procedure index_of
>   end interface
>
>   public    index_of_first_included_in_
>   interface index_of_first_included_in_
>      module procedure index_of_first_included_in
>   end interface
>
>   public    index_of_first_that_includes_
>   interface index_of_first_that_includes_
>      module procedure index_of_first_that_includes
>   end interface
>
>   public    index_of_matching_bracket_
>   interface index_of_matching_bracket_
>      module procedure index_of_matching_bracket
>   end interface
>
>   public    join_
>   interface join_
>      module procedure join_0
>      module procedure join_1
>   end interface
>
>   public    no_of_unique_elements_
>   interface no_of_unique_elements_
>      module procedure no_of_unique_elements
>   end interface
>
>   public    prepend_
>   interface prepend_
>      module procedure prepend_0
>      module procedure prepend_1
>   end interface
>
>   public    prune_
>   interface prune_
>      module procedure prune_0
>      module procedure prune_1
>   end interface
>
>   public    quick_sort_
>   interface quick_sort_
>      module procedure quick_sort_0
>      module procedure quick_sort_1
>   end interface
>
>   private    quick_sort_decreasing_
>   interface quick_sort_decreasing_
>      module procedure quick_sort_decreasing_0
>      module procedure quick_sort_decreasing_1
>   end interface
>
>   private    quick_sort_increasing_
>   interface quick_sort_increasing_
>      module procedure quick_sort_increasing_0
>      module procedure quick_sort_increasing_1
>   end interface
>
>   public    remove_blanks_
>   interface remove_blanks_
>      module procedure remove_blanks
>   end interface
>
>   public    remove_repetitions_
>   interface remove_repetitions_
>      module procedure remove_repetitions
>   end interface
>
>   public    replace_all_
>   interface replace_all_
>      module procedure replace_all
>   end interface
>
>   public    reverse_order_
>   interface reverse_order_
>      module procedure reverse_order
>   end interface
>
>   public    same_as_
>   interface same_as_
>      module procedure same_as
>   end interface
>
>   public    shrink_
>   interface shrink_
>      module procedure shrink
>   end interface
>
>   public    sort_
>   interface sort_
>      module procedure sort
>   end interface
>
>   public    swap_elements_
>   interface swap_elements_
>      module procedure swap_elements
>   end interface
>
>   public    to_lower_case_
>   interface to_lower_case_
>      module procedure to_lower_case
>   end interface
>
>   public    to_upper_case_
>   interface to_upper_case_
>      module procedure to_upper_case
>   end interface
>
>contains
>
>! *****************
>! Memory allocation
>! *****************
>
>   subroutine create_0(self,dim)
>   character(len=*), dimension(:) :: self
>   ! Create space for object
>      pointer :: self
>      integer(4), intent(in) :: dim
>   ! Ensure (dim>=0) or die and print: "VEC{STR}:create_0 ... dimension of array not 1 or greater"
>   ! The following code is inherited from VEC{INTRINSIC}
>      nullify(self)
>      allocate(self(dim))
>      ! Normally keep track of new memory usage here ...
>   end subroutine
>
>   subroutine create_1(self,lb,ub)
>   character(len=*), dimension(:) :: self
>   ! Create the vector with lower bound "lb", upper bound "ub"
>      pointer :: self
>      integer(4), intent(in) :: lb,ub
>   ! The following code is inherited from VEC{INTRINSIC}
>      nullify(self)
>      allocate(self(lb:ub))
>      ! Normally keep track of new memory usage here ...
>   end subroutine
>
>   subroutine create_2(self,bounds)
>   character(len=*), dimension(:) :: self
>   ! Create the vector with "bounds"
>      pointer :: self
>      integer(4), dimension(2), intent(in) :: bounds
>   ! The following code is inherited from VEC{INTRINSIC}
>      call create_(self,bounds(1),bounds(2))
>    ! if (bounds.dim==1); .create(bounds(1))
>    ! else;               .create(bounds(1),bounds(2))
>    ! end
>   end subroutine
>
>   subroutine destroy(self)
>   character(len=*), dimension(:) :: self
>   ! Destroy space for object
>      pointer :: self
>   ! The following code is inherited from VEC{INTRINSIC}
>      if (.not. associated(self)) return
>      ! Normally delete old memory usage here ...
>      deallocate(self)
>   end subroutine
>
>   subroutine create_copy(self,v)
>   character(len=*), dimension(:) :: self
>   ! Create a copy of vector "v".
>      pointer :: self
>      character(len=*), dimension(:), intent(in) :: v
>   ! The following code is inherited from VEC{INTRINSIC}
>      call create_(self,size(v))
>      self = v
>   end subroutine
>
>   subroutine copy(self,v)
>   character(len=*), dimension(:) :: self
>   ! Copy vector "v".
>      character(len=*), dimension(:), intent(in) :: v
>   ! Ensure (size(self)==size(v)) or die and print: "VEC{STR}:copy ... vec size does not match"
>   ! The following code is inherited from VEC{INTRINSIC}
>      self = v
>   end subroutine
>
>! ******************
>! Size-of operations
>! ******************
>
>! ***********************
>! Shrinking and expansion
>! ***********************
>
>   subroutine shrink(self,dim)
>   character(len=*), dimension(:) :: self
>   ! Shrink self to dimension dim.  Contents are retained.
>     pointer :: self
>     integer(4), intent(in) :: dim
>     character(len=len(self(1))), dimension(:), pointer :: old
>     integer(4) :: n
>   ! Ensure (associated(self)) or die and print: "VEC{STR}:shrink ... no self array"
>   ! Ensure (dim<=size(self)) or die and print: "VEC{STR}:shrink ... dim too large"
>   ! The following code is inherited from VEC{INTRINSIC}
>     if (dim==size(self)) return
>     old => self
>     nullify(self)
>     call create_(self,dim)
>     do n=1,dim
>       self(n) = old(n)
>     end do
>     call destroy_(old)
>   end subroutine
>
>   subroutine expand(self,dim)
>   character(len=*), dimension(:) :: self
>   ! Expand self to dimension dim. New slots are left undefined.
>     pointer :: self
>     integer(4), intent(in) :: dim
>     character(len=len(self(1))), dimension(:), pointer :: old
>     integer(4) :: old_dim
>   ! The following code is inherited from VEC{INTRINSIC}
>     if (.not. associated(self)) then
>        call create_(self,dim)
>     else
>        ! Ensure (dim>=size(self)) or die and print: "VEC{STR}:expand ... dim not large enough"
>        old => self
>        old_dim = size(old)
>        nullify(self)
>        call create_(self,dim)
>        self(1:old_dim) = old
>        call destroy_(old)
>     end if
>   end subroutine
>
>   subroutine append_0(self,v)
>   character(len=*), dimension(:) :: self
>   ! Expands self and appends the contents of vector "v".
>     pointer :: self
>     character(len=*), dimension(:), intent(in) :: v
>     integer(4) :: dim
>   ! The following code is inherited from VEC{INTRINSIC}
>     if (.not. associated(self)) then; dim = 0
>     else;                 dim = size(self)
>     end if
>     call expand_(self,dim+size(v))
>     self(dim+1:) = v
>   end subroutine
>
>   subroutine append_1(self,value)
>   character(len=*), dimension(:) :: self
>   ! Expands self by 1, and appends the single scalar "value" onto the end.
>     pointer :: self
>     character(len=*), intent(in) :: value
>     integer(4) :: dim
>   ! The following code is inherited from VEC{INTRINSIC}
>     if (.not. associated(self)) then; dim = 0
>     else;                 dim = size(self)
>     end if
>     call expand_(self,dim+1)
>     self(dim+1) = value
>   end subroutine
>
>   subroutine append_only_if_unique(self,value)
>   character(len=*), dimension(:) :: self
>   ! Expands self by 1, and appends the single scalar "value" onto the end, but
>   ! only if the "value" is unique
>     pointer :: self
>     character(len=*), intent(in) :: value
>   ! The following code is inherited from VEC{INTRINSIC}
>     if (any(self==value)) return
>     call append_(self,value)
>   end subroutine
>
>   subroutine prepend_0(self,v)
>   character(len=*), dimension(:) :: self
>   ! Prepend the vector "v" to "self". "self" is expanded.
>     pointer :: self
>     character(len=*), dimension(:), intent(in) :: v
>     integer(4) :: dim,dimv
>   ! The following code is inherited from VEC{INTRINSIC}
>     dim  = size(self)
>     dimv = size(v)
>     call expand_(self,dim+dimv)
>     self(dimv+1:    ) = self(1:dim)
>     self(     1:dimv) = v
>   end subroutine
>
>   subroutine prepend_1(self,value)
>   character(len=*), dimension(:) :: self
>   ! Prepend an single "value" to "self". "self" is expanded.
>     pointer :: self
>     character(len=*), intent(in) :: value
>     integer(4) :: dim
>   ! The following code is inherited from VEC{INTRINSIC}
>     dim = size(self)
>     call expand_(self,dim+1)
>     self(2:) = self(1:dim)
>     self(1 ) = value
>   end subroutine
>
>   function join_0(self,v) result(res)
>   character(len=*), dimension(:) :: self
>   ! Yield a vector which is the concatenation of "self" and "v"
>     character(len=*), dimension(:), intent(in) :: v
>     character(len=len(self(1))), dimension(:), pointer :: res
>     integer(4) :: dim, dim_v
>   ! The following code is inherited from VEC{INTRINSIC}
>     dim   = size(self)
>     dim_v = size(v)
>     call create_(res,dim+dim_v)
>     res(    1:dim      ) = self
>     res(dim+1:dim+dim_v) = v
>   end function
>
>   function join_1(self,v1,v2) result(res)
>   character(len=*), dimension(:) :: self
>   ! Yield a vector which is the concatenation of "self" and "v1" and "v2"
>     character(len=*), dimension(:), intent(in) :: v1,v2
>     character(len=len(self(1))), dimension(:), pointer :: res
>     integer(4) :: dim, dim_v1, dim_v2
>   ! The following code is inherited from VEC{INTRINSIC}
>     dim    = size(self)
>     dim_v1 = size(v1)
>     dim_v2 = size(v2)
>     call create_(res,dim+dim_v1+dim_v2)
>     res(           1:dim              ) = self
>     res(dim+       1:dim+dim_v1       ) = v1
>     res(dim+dim_v1+1:dim+dim_v1+dim_v2) = v2
>   end function
>
>   subroutine prune_0(self,values)
>   character(len=*), dimension(:) :: self
>   ! Removes the scalar "values" from the vector, if they are there.
>   ! The order of the elementsis otherwise unchanged.
>     pointer :: self
>     character(len=*), dimension(:), intent(in) :: values
>     character(len=512), dimension(:), pointer :: copy
>     integer(4) :: i,n
>   ! The following code is inherited from VEC{INTRINSIC}
>     call create_(copy,size(self))
>     n = 0
>     do i = 1,size(self)
>        if (any(values==self(i))) cycle
>        n = n + 1
>        copy(n) = self(i)
>     end do
>     call shrink_(copy,n)
>     call destroy_(self)
>     self => copy
>   end subroutine
>
>   subroutine prune_1(self,value)
>   character(len=*), dimension(:) :: self
>   ! Removes the single scalar "value" from the vector, if it is there.
>   ! The order of the elementsis otherwise unchanged.
>     pointer :: self
>     character(len=*), intent(in) :: value
>     character(len=512), dimension(:), pointer :: copy
>     integer(4) :: i,n
>   ! The following code is inherited from VEC{INTRINSIC}
>     call create_(copy,size(self))
>     n = 0
>     do i = 1,size(self)
>        if (self(i)==value) cycle
>        n = n + 1
>        copy(n) = self(i)
>     end do
>     call shrink_(copy,n)
>     call destroy_(self)
>     self => copy
>   end subroutine
>
>! ********************
>! Comparison functions
>! ********************
>
>   function equals(self,v) result(res)
>   character(len=*), dimension(:) :: self
>   ! Return true if "self" is the same as "v".
>      intent(in) :: self
>      character(len=*), dimension(:), intent(in) :: v
>      logical(4) :: res
>   ! The following code is inherited from VEC{INTRINSIC}
>      res = same_as_(self,v)
>   end function
>
>   function same_as(self,v) result(res)
>   character(len=*), dimension(:) :: self
>   ! Return true if "self" is the same as "v".
>      intent(in) :: self
>      character(len=*), dimension(:), intent(in) :: v
>      logical(4) :: res
>   ! The following code is inherited from VEC{INTRINSIC}
>      if (size(self)/=size(v)) then; res = .false.
>      else;                  res = all(self==v)
>      end if
>   end function
>
>! *****************************
>! Repetition related operations
>! *****************************
>
>   subroutine remove_repetitions(self)
>   character(len=*), dimension(:) :: self
>   ! Sort through the vector and remove repeated elements which come later in
>   ! the list.  NOTE: the vector may shrink
>      pointer :: self
>      character(len=len(self(1))), dimension(:), pointer :: unique
>      integer(4) :: i,j,n
>      logical(4) :: found
>   ! Ensure (associated(self)) or die and print: "VEC{STR}:remove_repetitions ... no vector"
>   ! The following code is inherited from VEC{OBJECT}
>      if (size(self)==1) return
>      call create_(unique,size(self))
>      n = 1
>      unique(1) = self(1)
>      do i = 2,size(self)
>         found = .false.
>         do j = 1,n
>            if (.not. same_as_(self(i),unique(j))) cycle
>            found = .true.
>         end do
>         if (found) cycle
>         n = n + 1
>         unique(n) = self(i)
>      end do
>      call destroy_(self)
>      call create_(self,n)
>      self = unique(1:n)
>      call destroy_(unique)
>   end subroutine
>
>   function has_repetitions(self) result(res)
>   character(len=*), dimension(:) :: self
>   ! Return .true. if self has at least one repeated element.
>      logical(4) :: res
>      character(len=len(self(1))), dimension(:), pointer :: unique
>      integer(4) :: i,j,n
>   ! The following code is inherited from VEC{OBJECT}
>      res = .false.
>      if (size(self)==1) return
>      call create_(unique,size(self))
>      n = 1
>      unique(1) = self(1)
>      do i = 2,size(self)
>         do j = 1,n
>            if (.not. same_as_(self(i),unique(j))) cycle
>            res = .true.
>            return
>         end do
>         n = n + 1
>         unique(n) = self(i)
>      end do
>      call destroy_(unique)
>   end function
>
>   pure function no_of_unique_elements(self) result(res)
>   character(len=*), dimension(:) :: self
>   ! Return the number of unique elements in the vector.
>      intent(in) :: self
>      integer(4) :: res
>      integer(4) :: n,i
>      logical(4) :: same
>   ! The following code is inherited from VEC{OBJECT}
>      res = 1
>      do n = 2,size(self)
>         same = .false.
>         do i = 1,n-1
>            if (.not. same_as_(self(n),self(i))) cycle
>            same = .true.
>            exit
>         end do
>         if (.not. same) res = res + 1
>      end do
>   end function
>
>! ****************
>! Sorting routines
>! ****************
>
>   pure subroutine sort(self,decreasing_order)
>   character(len=*), dimension(:) :: self
>   ! Sort array "self" from lowest to highest, using simple insertion sort.  If
>   ! "decreasing_order" is present and .true. sort from highest to lowest instead.
>     intent(inout) :: self
>     logical(4), intent(in), optional :: decreasing_order
>     integer(4) :: i,j,n
>     logical(4) :: lowest_first
>   ! The following code is inherited from VEC{OBJECT}
>     lowest_first = .true.
>     if (present(decreasing_order)) lowest_first = .not. decreasing_order
>     n = size(self)
>     if (lowest_first) then
>       do i=1,n-1
>       do j=i+1,n
>          if (self(j) < self(i)) call swap_elements_(self,i,j)
>       end do
>       end do
>     else
>       do i=1,n-1
>       do j=i+1,n
>          if (self(j) > self(i)) call swap_elements_(self,i,j)
>       end do
>       end do
>     end if
>   end subroutine
>
>   subroutine quick_sort_0(self,decreasing_order)
>   character(len=*), dimension(:) :: self
>   ! Sort the vector into increasing order.If "decreasing_order" is present and
>   ! .true., the vector is sorted from largest to smallest
>      intent(in) :: self
>      logical(4), optional, intent(in) :: decreasing_order
>      logical(4) :: decreasing
>   ! The following code is inherited from VEC{OBJECT}
>      decreasing = .false.
>      if (present(decreasing_order)) decreasing = decreasing_order
>      if (.not. decreasing) then; call quick_sort_increasing_(self)
>      else;                     call quick_sort_decreasing_(self)
>      end if
>   end subroutine
>
>   recursive subroutine quick_sort_increasing_0(self)
>   character(len=*), dimension(:) :: self
>   ! Sort the vector into order, smallest to largest
>      character(len=len(self(1))), dimension(:), pointer :: smaller,larger
>      integer(4) :: n, ns, ne, nl
>      character(len=len(self(1))) :: chosen
>   ! The following code is inherited from VEC{OBJECT}
>      if (size(self)<=1) return
>      n = size(self)
>      chosen = self(1)
>      ns = count(self<chosen)
>      nl = count(self>chosen)
>      ne = n - ns - nl
>      call create_(smaller,ns)
>      call create_(larger,nl)
>      smaller = pack(self,self<chosen)
>      larger  = pack(self,self>chosen)
>      call quick_sort_(smaller)
>      call quick_sort_(larger)
>      self(1:ns)       = smaller
>      self(ns+1:ns+ne) = chosen
>      self(ns+ne+1:)   = larger
>      call destroy_(larger)
>      call destroy_(smaller)
>   end subroutine
>
>   recursive subroutine quick_sort_decreasing_0(self)
>   character(len=*), dimension(:) :: self
>   ! Sort the vector into order, largest to smallest
>      character(len=len(self(1))), dimension(:), pointer :: smaller,larger
>      integer(4) :: n, ns, ne, nl
>      character(len=len(self(1))) :: chosen
>   ! The following code is inherited from VEC{OBJECT}
>      if (size(self)<=1) return
>      n = size(self)
>      chosen = self(1)
>      ns = count(self<chosen)
>      nl = count(self>chosen)
>      ne = n - ns - nl
>      call create_(smaller,ns)
>      call create_(larger,nl)
>      smaller = pack(self,self<chosen)
>      larger  = pack(self,self>chosen)
>      call quick_sort_(smaller)
>      call quick_sort_(larger)
>      self(1:nl)       = larger
>      self(nl+1:nl+ne) = chosen
>      self(nl+ne+1:)   = smaller
>      call destroy_(larger)
>      call destroy_(smaller)
>   end subroutine
>
>   subroutine quick_sort_1(self,indices,decreasing_order)
>   character(len=*), dimension(:) :: self
>   ! Return the "indices" which sort self from smallest to largest, i.e. on
>   ! return "self(indices)" is sorted. NOTE: self is *not* sorted.
>   ! If "decreasing_order" is present and .true., the indices are sorted from
>   ! largest to smallest
>      intent(in) :: self
>      integer(4), dimension(:), intent(inout) :: indices
>      logical(4), optional, intent(in) :: decreasing_order
>      logical(4) :: decreasing
>      integer(4) :: i
>   ! Ensure (size(indices)==size(self)) or die and print: "VEC{STR}:quick_sort_1 ... wrong size, indices"
>   ! The following code is inherited from VEC{OBJECT}
>      decreasing = .false.
>      if (present(decreasing_order)) decreasing = decreasing_order
>      indices = (/(i,i=1,size(self))/) ! initialise indices
>      if (.not. decreasing) then; call quick_sort_increasing_(self,indices)
>      else;                     call quick_sort_decreasing_(self,indices)
>      end if
>   end subroutine
>
>   recursive subroutine quick_sort_increasing_1(self,indices)
>   character(len=*), dimension(:) :: self
>   ! Return the indices which sort vector from smallest to largest, i.e. on
>   ! return "self(indices)" is sorted. NOTE: self is *not* sorted.
>      intent(in) :: self
>      integer(4), dimension(:), intent(inout) :: indices
>      integer(4), dimension(:), pointer :: list,small,equal,large,small_indices,equal_indices,large_indices
>      integer(4) :: n, i, ns, ne, nl
>      character(len=len(self(1))) :: chosen
>   ! The following code is inherited from VEC{OBJECT}
>      if (size(indices)<=1) return
>      n = size(indices)
>      call create_(list,n); list = (/(i,i=1,n)/)
>      chosen = self(1)
>      ns = count(self<chosen)
>      nl = count(self>chosen)
>      ne = n - ns - nl
>      call create_(small,ns); call create_(small_indices,ns)
>      call create_(equal,ne); call create_(equal_indices,ne)
>      call create_(large,nl); call create_(large_indices,nl)
>      small = pack(list,self <chosen) ! indices of small self elements
>      equal = pack(list,self==chosen) ! indices of equal self elements
>      large = pack(list,self >chosen) ! indices of large self elements
>      small_indices = indices(small)
>      equal_indices = indices(equal)
>      large_indices = indices(large)
>      if (ns>1) call quick_sort_increasing_(self(small),small_indices)
>      if (nl>1) call quick_sort_increasing_(self(large),large_indices)
>      indices(1:ns)       = small_indices
>      indices(ns+1:ns+ne) = equal_indices
>      indices(ns+ne+1:)   = large_indices
>      call destroy_(large_indices); call destroy_(large)
>      call destroy_(equal_indices); call destroy_(equal)
>      call destroy_(small_indices); call destroy_(small)
>      call destroy_(list)
>   end subroutine
>
>   recursive subroutine quick_sort_decreasing_1(self,indices)
>   character(len=*), dimension(:) :: self
>   ! Return the indices which sort vector from largest to smallest, i.e. on
>   ! return "self(indices)" is sorted. NOTE: self is *not* sorted.
>      intent(in) :: self
>      integer(4), dimension(:), intent(inout) :: indices
>      integer(4), dimension(:), pointer :: list,small,equal,large,small_indices,equal_indices,large_indices
>      integer(4) :: n, i, ns, ne, nl
>      character(len=len(self(1))) :: chosen
>   ! The following code is inherited from VEC{OBJECT}
>      if (size(indices)<=1) return
>      n = size(indices)
>      call create_(list,n); list = (/(i,i=1,n)/)
>      chosen = self(1)
>      ns = count(self>chosen)
>      nl = count(self<chosen)
>      ne = n - ns - nl
>      call create_(small,ns); call create_(small_indices,ns)
>      call create_(equal,ne); call create_(equal_indices,ne)
>      call create_(large,nl); call create_(large_indices,nl)
>      small = pack(list,self >chosen) ! indices of large self elements
>      equal = pack(list,self==chosen) ! indices of equal self elements
>      large = pack(list,self <chosen) ! indices of small self elements
>      small_indices = indices(small)
>      equal_indices = indices(equal)
>      large_indices = indices(large)
>      if (ns>1) call quick_sort_decreasing_(self(small),small_indices)
>      if (nl>1) call quick_sort_decreasing_(self(large),large_indices)
>      indices(1:ns)       = small_indices
>      indices(ns+1:ns+ne) = equal_indices
>      indices(ns+ne+1:)   = large_indices
>      call destroy_(large_indices); call destroy_(large)
>      call destroy_(equal_indices); call destroy_(equal)
>      call destroy_(small_indices); call destroy_(small)
>      call destroy_(list)
>   end subroutine
>
>   pure subroutine reverse_order(self)
>   character(len=*), dimension(:) :: self
>   ! Reverse the order of the elements of self
>     intent(inout) :: self
>     integer(4) :: n,dim
>   ! The following code is inherited from VEC{INTRINSIC}
>     dim = size(self)
>     do n = 1,dim/2
>       call swap_elements_(self,n,dim-n+1)
>     end do
>   end subroutine
>
>   pure subroutine swap_elements(self,e1,e2)
>   character(len=*), dimension(:) :: self
>   ! Swap elements "e1" and "e2" in "self".
>      intent(inout) :: self
>      integer(4), intent(in) :: e1,e2
>
>      character(len=512) :: val
>   ! The following code is inherited from VEC{INTRINSIC}
>      val = self(e1)
>      self(e1) = self(e2)
>      self(e2) = val
>   end subroutine
>
>! *****************************************
>! Inclusion and matching related operations
>! *****************************************
>
>   function has_any_included_in(self,string,at_start) result(res)
>   character(len=*), dimension(:) :: self
>   ! Return .true. if self has any element included in "string" which starts at
>   ! the start of the "string", provided "at_start" is .true.; otherwise
>   ! returns .true. even if the match was not at the start.
>      character(len=*), intent(in) :: string
>      logical(4), optional :: at_start
>      logical(4) :: res
>      logical(4) :: first
>      first = .false.
>      if (present(at_start)) first = at_start
>      if (first) then
>         res = any(index(spread(string,1,size(self)),self) == 1)
>      else
>         res = any(index(spread(string,1,size(self)),self) /= 0)
>      end if
>   end function
>
>   function index_of_first_included_in(self,string) result(res)
>   character(len=*), dimension(:) :: self
>   ! Return the index of the first element in self which is included in
>   ! "string", or zero otherwise.
>      character(len=*), intent(in) :: string
>      integer(4) :: res
>      integer(4) :: i
>      res = 0
>      do i = 1,size(self)
>         res = index(string,self(i))
>         if (res>0) exit
>      end do
>   end function
>
>   function has_any_including(self,string) result(res)
>   character(len=*), dimension(:) :: self
>   ! Return .true. if self has any element which includes "string".
>      character(len=*), intent(in) :: string
>      logical(4) :: res
>      res = any(index(self,spread(string,1,size(self))) /= 0)
>   end function
>
>   function includes(self,string,at_start) result(res)
>   character(len=*), dimension(:) :: self
>   ! Return .true. for a particular element, if that element of self includes "string".
>   ! Returns .false. if no element matches. If "at_start" is present and .true., then the
>   ! result is .true. only if the item matches at the start of the string.
>      character(len=*), intent(in) :: string
>      logical(4), optional :: at_start
>      logical(4), dimension(size(self)) :: res
>      logical(4) :: first
>      first = .false.
>      if (present(at_start)) first = at_start
>      if (first) then
>         res = index(self,spread(string,1,size(self))) == 1
>      else
>         res = index(self,spread(string,1,size(self))) /= 0
>      end if
>   end function
>
>   function index_of_first_that_includes(self,string) result(res)
>   character(len=*), dimension(:) :: self
>   ! Return the index of the first element of self that includes "string".
>   ! Returns 0 if no element matches.
>      character(len=*), intent(in) :: string
>      integer(4) :: res
>      integer(4) :: i
>      do i = 1,size(self)
>         res = index(self(i),string)
>         if (res==0) cycle
>         res = i
>         exit
>      end do
>   end function
>
>   function index_of(self,string) result(res)
>   character(len=*), dimension(:) :: self
>   ! Return the first index of the "string" in self.
>   ! Returns 0 if no element matches.
>      character(len=*), intent(in) :: string
>      integer(4) :: res
>      integer(4) :: i
>      res = 0
>      do i = 1,size(self)
>         if (self(i)/=string) cycle
>         res = i
>         exit
>      end do
>   end function
>
>   function index_of_matching_bracket(self,symbol) result(res)
>   character(len=*), dimension(:) :: self
>   ! Return the first index of the matching bracket "symbol" in self.
>   ! The first element of self need not be an opening bracket symbol.
>      character(len=*), intent(in) :: symbol
>      integer(4) :: res
>      character(len=1), dimension(4) :: opening = (/"{","(","[","<"/)
>      character(len=1), dimension(4) :: closing = (/"}",")","]",">"/)
>      character(len=1) :: op,cl
>      integer(4) :: i,s,n
>   ! Ensure (any(symbol==opening)) or die and print: "VEC{STR}:index_of_matching_bracket ... unrecognised open bracket symbol"
>   ! Ensure (index_of_(self,symbol)>0) or die and print: "VEC{STR}:index_of_matching_bracket ... no open bracket symbol in self"
>   ! Ensure (index_of_(self,symbol)<size(self)) or die and print: "VEC{STR}:index_of_matching_bracket ... open bracket is at end of self"
>      op = symbol
>      cl = closing(index_of_(opening,symbol))
>      s = index_of_(self,op)
>      n = 0
>      do i = s+1,size(self)
>         if (self(i)==op) n = n + 1
>         if (self(i)==cl .and. n==0) exit
>         if (self(i)==cl .and. n>0) n = n - 1
>      end do
>      ! Ensure (n==0) or die and print: "VEC{STR}:index_of_matching_bracket ... unmatching number of closing bracket symbols"
>      res = i
>   end function
>
>! **********
>! Misc stuff
>! **********
>
>   subroutine to_lower_case(self)
>   character(len=*), dimension(:) :: self
>   ! Change upper case charaters to lower case in all elements
>       integer(4) :: i
>      do i = 1,size(self)
>         call to_lower_case_(self(i))
>      end do
>   end subroutine
>
>   subroutine to_upper_case(self)
>   character(len=*), dimension(:) :: self
>   ! Change lower case charaters to upper case in all elements
>       integer(4) :: i
>      do i = 1,size(self)
>         call to_upper_case_(self(i))
>      end do
>   end subroutine
>
>   subroutine replace_all(self,a,b)
>   character(len=*), dimension(:) :: self
>   ! Replace all occurences of string "a" by "b". String "b" can be zero
>   ! length, however, replacements only occur up to the last nonblank
>   ! character in "self" i.e. up to len_trim(self).
>      character(len=*) :: a,b
>      integer(4) :: i
>      do i = 1,size(self)
>         call replace_all_(self(i),a,b)
>      end do
>   end subroutine
>
>   subroutine remove_blanks(self)
>   character(len=*), dimension(:) :: self
>   ! Replace all blanks by moving all non-blank characters leftwards
>      integer(4) :: i
>      do i = 1,size(self)
>         call remove_blanks_(self(i))
>      end do
>   end subroutine
>
>end module

Actions: View

Attachments on bug 9826: 1551 | 1554