fms_string_utils.F90

!***********************************************************************
!*                             Apache License 2.0
!*
!* This file is part of the GFDL Flexible Modeling System (FMS).
!*
!* Licensed under the Apache License, Version 2.0 (the "License");
!* you may not use this file except in compliance with the License.
!* You may obtain a copy of the License at
!*
!*     http://www.apache.org/licenses/LICENSE-2.0
!*
!* FMS is distributed in the hope that it will be useful, but WITHOUT
!* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied;
!* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
!* PARTICULAR PURPOSE. See the License for the specific language
!* governing permissions and limitations under the License.
!***********************************************************************
 
!> @defgroup fms_string_utils_mod fms_string_utils_mod
!> @ingroup string_utils
!> @brief Routines to use for string manipulation
 
!> @file
!> @brief File for @ref fms_string_utils_mod
 
!> @addtogroup fms_string_utils_mod
!> @{
module fms_string_utils_mod
  use, intrinsic :: iso_c_binding
  use platform_mod, only: r4_kind, r8_kind, i4_kind, i8_kind
  use mpp_mod
 
  implicit none
  private
 
  public :: fms_array_to_pointer
  public :: fms_pointer_to_array
  public :: fms_sort_this
  public :: fms_find_my_string
  public :: fms_find_unique
  public :: fms_c2f_string
  public :: fms_f2c_string
  public :: fms_cstring2cpointer
  public :: string
  public :: string_copy
  public :: stringify
!> @}
 
  interface
  !> @brief Sorts an array of pointers (my pointer) of size (p_size) in
  !! alphabetical order.
  subroutine fms_sort_this(my_pointer, p_size, indices) bind(c)
    use iso_c_binding
 
    type(c_ptr),         intent(inout) :: my_pointer(*) !< IN:  Array of c pointers to sort
                                                        !! OUT: Sorted array of c pointers
    integer(kind=c_int), intent(in)    :: p_size        !< Size of the array
    integer(kind=c_int), intent(inout) :: indices(*)    !< IN:  Array of the indices of my_pointer
                                                        !! OUT: Sorted array of indices
  end subroutine fms_sort_this
 
  !> @brief Private c function that finds a string in a SORTED array of c pointers
  !! @return Indices of my_pointer where the string was found as a string!!!
  function fms_find_my_string_binding(my_pointer, p_size, string_to_find, nfound) bind(c) &
  result(indices)
    use iso_c_binding
 
    type(c_ptr),            intent(in) :: my_pointer(*)     !< Array of sorted c pointer
    integer(kind=c_int),    intent(in) :: p_size            !< Size of the array
    character(kind=c_char), intent(in) :: string_to_find(*) !< String to find
    integer(kind=c_int), intent(inout) :: nfound            !< Number of times the array was found
 
    type(c_ptr) :: indices
  end function fms_find_my_string_binding
 
  !> @brief c function that finds the number of unique strings in an array of c pointers
  !! @return number of unique strings
  function fms_find_unique(my_pointer, p_size) bind(c)&
  result(ntimes)
    use iso_c_binding
 
    type(c_ptr),            intent(in) :: my_pointer(*)     !< Array of sorted c pointer
    integer(kind=c_int),    intent(in) :: p_size            !< Size of the array
    integer(kind=c_int) :: ntimes
 
  end function fms_find_unique
 
  !> @brief converts a kind=c_char to type c_ptr
  pure function fms_cstring2cpointer (cs) result (cp) bind(c, name="cstring2cpointer")
   import c_char, c_ptr
   character(kind=c_char), intent(in) :: cs(*) !< C string input
   type (c_ptr) :: cp !< C pointer
  end function fms_cstring2cpointer
 
  !> @brief Finds the length of a C-string
  integer(c_size_t) pure function c_strlen(s) bind(c,name="strlen")
    import c_size_t, c_ptr
    type(c_ptr), intent(in), value :: s !< A C-string whose size is desired
  end function
 
  !> @brief Frees a C pointer
  subroutine c_free(ptr) bind(c,name="free")
    import c_ptr
    type(c_ptr), value :: ptr !< A C-pointer to free
  end subroutine
 
end interface
 
!> Converts a C string to a Fortran string
!> @ingroup fms_mod
interface fms_c2f_string
  module procedure cstring_fortran_conversion
  module procedure cpointer_fortran_conversion
end interface
 
!> Converts an array of real numbers to a string
!> @ingroup fms_mod
interface stringify
  module procedure stringify_1d_r4, stringify_1d_r8
  module procedure stringify_2d_r4, stringify_2d_r8
  module procedure stringify_3d_r4, stringify_3d_r8
end interface
 
!> @addtogroup fms_string_utils_mod
!> @{
contains
 
  !> @brief Converts a character array to an array of c pointers!
  !! @return An array of c pointers
  function fms_array_to_pointer(my_array) &
  result(my_pointer)
    character(len=*), target :: my_array(:) !!< Array of strings to convert
    type(c_ptr), allocatable :: my_pointer(:)
 
    integer :: i !< For do loops
 
    if (allocated(my_pointer)) call mpp_error(fatal, "The c pointer array is &
      already allocated. Deallocated before calling fms_array_to_pointer")
    allocate(my_pointer(size(my_array)))
 
    do i = 1, size(my_array)
      my_pointer(i) = c_loc(my_array(i))
    enddo
  end function fms_array_to_pointer
 
  !> @brief Convert an array of c pointers back to a character array
  !! @return A character array
  function fms_pointer_to_array(my_pointer, narray) &
  result(my_array)
    type(c_ptr), intent(in)       :: my_pointer(*) !< Array of c pointer
    integer,     intent(in)       :: narray        !< Length of the array
    character(len=:), allocatable :: my_array(:)
 
    character(len=:), allocatable :: buffer !< Buffer to store a string
    integer                       :: i      !< For do loops
 
    allocate(character(len=255) :: my_array(narray))
    do i = 1, narray
      buffer = fms_c2f_string(my_pointer(i))
      my_array(i) = buffer
      deallocate(buffer)
    enddo
  end function fms_pointer_to_array
 
  !> @brief Searches through a SORTED array of pointers for a string
  !! @return the indices where the array was found
  !! If the string was not found, indices will be indices(1) = -999
  !> <br>Example usage:
  !!     my_pointer = fms_array_to_pointer(my_array)
  !!     call fms_sort_this(my_pointer, n_array, indices)
  !!     ifind = fms_find_my_string(my_pointer, n_array, string_to_find)
  function fms_find_my_string(my_pointer, narray, string_to_find) &
  result(ifind)
    type(c_ptr),      intent(in)    :: my_pointer(*)  !< Array of c pointer
    integer,          intent(in)    :: narray         !< Length of the array
    character(len=*), intent(in)    :: string_to_find !< string to find
    integer, allocatable            :: ifind(:)
 
    integer                       :: nfind  !< number of times the string was found
    character(len=:), allocatable :: buffer !< buffer to read the indices into
 
    buffer = fms_c2f_string(&
      fms_find_my_string_binding(my_pointer, narray, trim(string_to_find)//c_null_char, nfind))
 
    if (allocated(ifind)) call mpp_error(fatal, "The indices array is already allocated. &
    Deallocate it before calling fms_find_my_string")
 
    if (nfind .gt. 0) then
      allocate(ifind(nfind))
      read(buffer,*) ifind
    else
      allocate(ifind(1))
      ifind = -999
    endif
 
  end function fms_find_my_string
 
  !> \brief Converts a C-string to a pointer and then to a Fortran string
  function cstring_fortran_conversion (cstring) result(fstring)
    character (kind=c_char), intent(in) :: cstring (*) !< Input C-string
    character(len=:), allocatable :: fstring    !< The fortran string returned
    fstring = cpointer_fortran_conversion(fms_cstring2cpointer(cstring))
  end function cstring_fortran_conversion
 
  !> \brief Converts a C-string returned from a TYPE(C_PTR) function to
  !! a fortran string with type character.
  function cpointer_fortran_conversion (cstring) result(fstring)
    type (c_ptr), intent(in) :: cstring !< Input C-pointer
    character(len=:), allocatable :: fstring    !< The fortran string returned
    character(len=:,kind=c_char), pointer :: string_buffer !< A temporary pointer to between C and Fortran
    integer(c_size_t) :: length !< The string length
 
    length = c_strlen(cstring)
    allocate (character(len=length, kind=c_char) :: string_buffer)
    block
      character(len=length,kind=c_char), pointer :: s
      call c_f_pointer(cstring,s)  ! Recovers a view of the C string
      string_buffer = s                   ! Copies the string contents
    end block
 
    allocate(character(len=length) :: fstring) !> Set the length of fstring
    fstring = string_buffer
    deallocate(string_buffer)
  end function cpointer_fortran_conversion
 
!> @brief Copies a Fortran string into a C string and puts c_null_char in any trailing spaces
  subroutine fms_f2c_string (dest, str_in)
    character (c_char), intent (out) :: dest (:) !< C String to be copied into
    character (len=*), intent (in) :: str_in !< Fortran string to copy to C string
    integer :: i !< for looping
!> Drop an error if the C string is not large enough to hold the input and the c_null_char at the end.
    if (len(trim(str_in)) .ge. size(dest)) call mpp_error(fatal, &
      "The string "//trim(str_in)//" is larger than the destination C string")
!> Copy c_null_char into each spot in dest
    dest = c_null_char
!> Loop though and put each character of the Fortran string into the C string array
    do i = 1, len(trim(str_in))
      dest(i) = str_in(i:i)
    enddo
end subroutine fms_f2c_string
 
  !> @brief Converts a number or a Boolean value to a string
  !> @return The argument as a string
  function string(v, fmt)
    class(*), intent(in) :: v !< Value to be converted to a string
    character(*), intent(in), optional :: fmt !< Optional format string for a real or integral argument
    character(:), allocatable :: string
 
    select type(v)
      type is (logical)
        if (present(fmt)) then
          call mpp_error(warning, "string(): Ignoring `fmt` argument for type `logical`")
        endif
        if (v) then
          string = "True"
        else
          string = "False"
        endif
 
      type is (integer(i4_kind))
        allocate(character(32) :: string)
        if (present(fmt)) then
          write(string, "(" // fmt // ")") v
        else
          write(string, '(i0)') v
        endif
        string = trim(adjustl(string))
 
      type is (integer(i8_kind))
        allocate(character(32) :: string)
        if (present(fmt)) then
          write(string, "(" // fmt // ")") v
        else
          write(string, '(i0)') v
        endif
        string = trim(adjustl(string))
 
      type is (real(r4_kind))
        allocate(character(32) :: string)
        if (present(fmt)) then
          write(string, "(" // fmt // ")") v
        else
          write(string, *) v
        endif
        string = trim(adjustl(string))
 
      type is (real(r8_kind))
        allocate(character(32) :: string)
        if (present(fmt)) then
          write(string, "(" // fmt // ")") v
        else
          write(string, *) v
        endif
        string = trim(adjustl(string))
 
      class default
        call mpp_error(fatal, "string(): Called with incompatible argument type. Possible types &
                              &include integer(4), integer(8), real(4), real(8), or logical.")
    end select
  end function string
 
  !> @brief Safely copy a string from one buffer to another.
  subroutine string_copy(dest, source, check_for_null)
    character(len=*), intent(inout) :: dest !< Destination string.
    character(len=*), intent(in) :: source !< Source string.
    logical, intent(in), optional :: check_for_null !<Flag indicating to test for null character
 
    integer :: i
    logical :: check_null
 
    check_null = .false.
    if (present(check_for_null)) check_null = check_for_null
 
    i = 0
    if (check_null) then
      i = index(source, char(0)) - 1
    endif
 
    if (i < 1 ) i = len_trim(source)
 
    if (len_trim(source(1:i)) .gt. len(dest)) then
      call mpp_error(fatal, "The input destination string is not big enough to" &
                 //" to hold the input source string.")
    endif
    dest = ""
    dest = adjustl(trim(source(1:i)))
  end subroutine string_copy
 
#include "fms_string_utils_r4.fh"
#include "fms_string_utils_r8.fh"
 
end module fms_string_utils_mod
!> @}
! close documentation grouping