string_utils/fms_string_utils.F90

   1 !***********************************************************************
   2 !*                   GNU Lesser General Public License
   3 !*
   4 !* This file is part of the GFDL Flexible Modeling System (FMS).
   5 !*
   6 !* FMS is free software: you can redistribute it and/or modify it under
   7 !* the terms of the GNU Lesser General Public License as published by
   8 !* the Free Software Foundation, either version 3 of the License, or (at
   9 !* your option) any later version.
  10 !*
  11 !* FMS is distributed in the hope that it will be useful, but WITHOUT
  12 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 !* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14 !* for more details.
  15 !*
  16 !* You should have received a copy of the GNU Lesser General Public
  17 !* License along with FMS.  If not, see <http://www.gnu.org/licenses/>.
  18 !***********************************************************************
  19
  20 !> @defgroup fms_string_utils_mod fms_string_utils_mod
  21 !> @ingroup string_utils
  22 !> @brief Routines to use for string manipulation
  23
  24 !> @file
  25 !> @brief File for @ref fms_string_utils_mod
  26
  27 !> @addtogroup fms_string_utils_mod
  28 !> @{
  29 module fms_string_utils_mod
  30   use, intrinsic :: iso_c_binding
  31   use platform_mod, only: r4_kind, r8_kind, i4_kind, i8_kind
  32   use mpp_mod
  33
  34   implicit none
  35   private
  36
  37   public :: fms_array_to_pointer
  38   public :: fms_pointer_to_array
  39   public :: fms_sort_this
  40   public :: fms_find_my_string
  41   public :: fms_find_unique
  42   public :: fms_c2f_string
  43   public :: fms_f2c_string
  44   public :: fms_cstring2cpointer
  45   public :: string
  46   public :: string_copy
  47   public :: stringify
  48 !> @}
  49
  50   interface
  51   !> @brief Sorts an array of pointers (my pointer) of size (p_size) in
  52   !! alphabetical order.
  53   subroutine fms_sort_this(my_pointer, p_size, indices) bind(c)
  54     use iso_c_binding
  55
  56     type(c_ptr),         intent(inout) :: my_pointer(*) !< IN:  Array of c pointers to sort
  57                                                         !! OUT: Sorted array of c pointers
  58     integer(kind=c_int), intent(in)    :: p_size        !< Size of the array
  59     integer(kind=c_int), intent(inout) :: indices(*)    !< IN:  Array of the indices of my_pointer
  60                                                         !! OUT: Sorted array of indices
  61   end subroutine fms_sort_this
  62
  63   !> @brief Private c function that finds a string in a SORTED array of c pointers
  64   !! @return Indices of my_pointer where the string was found as a string!!!
  65   function fms_find_my_string_binding(my_pointer, p_size, string_to_find, nfound) bind(c) &
  66   result(indices)
  67     use iso_c_binding
  68
  69     type(c_ptr),            intent(in) :: my_pointer(*)     !< Array of sorted c pointer
  70     integer(kind=c_int),    intent(in) :: p_size            !< Size of the array
  71     character(kind=c_char), intent(in) :: string_to_find(*) !< String to find
  72     integer(kind=c_int), intent(inout) :: nfound            !< Number of times the array was found
  73
  74     type(c_ptr) :: indices
  75   end function fms_find_my_string_binding
  76
  77   !> @brief c function that finds the number of unique strings in an array of c pointers
  78   !! @return number of unique strings
  79   function fms_find_unique(my_pointer, p_size) bind(c)&
  80   result(ntimes)
  81     use iso_c_binding
  82
  83     type(c_ptr),            intent(in) :: my_pointer(*)     !< Array of sorted c pointer
  84     integer(kind=c_int),    intent(in) :: p_size            !< Size of the array
  85     integer(kind=c_int) :: ntimes
  86
  87   end function fms_find_unique
  88
  89   !> @brief converts a kind=c_char to type c_ptr
  90   pure function fms_cstring2cpointer (cs) result (cp) bind(c, name="cstring2cpointer")
  91    import c_char, c_ptr
  92    character(kind=c_char), intent(in) :: cs(*) !< C string input
  93    type (c_ptr) :: cp !< C pointer
  94   end function fms_cstring2cpointer
  95
  96   !> @brief Finds the length of a C-string
  97   integer(c_size_t) pure function c_strlen(s) bind(c,name="strlen")
  98     import c_size_t, c_ptr
  99     type(c_ptr), intent(in), value :: s !< A C-string whose size is desired
 100   end function
 101
 102   !> @brief Frees a C pointer
 103   subroutine c_free(ptr) bind(c,name="free")
 104     import c_ptr
 105     type(c_ptr), value :: ptr !< A C-pointer to free
 106   end subroutine
 107
 108 end interface
 109
 110 !> Converts a C string to a Fortran string
 111 !> @ingroup fms_mod
 112 interface fms_c2f_string
 113   module procedure cstring_fortran_conversion
 114   module procedure cpointer_fortran_conversion
 115 end interface
 116
 117 !> Converts an array of real numbers to a string
 118 !> @ingroup fms_mod
 119 interface stringify
 120   module procedure stringify_1d_r4, stringify_1d_r8
 121   module procedure stringify_2d_r4, stringify_2d_r8
 122   module procedure stringify_3d_r4, stringify_3d_r8
 123 end interface
 124
 125 !> @addtogroup fms_string_utils_mod
 126 !> @{
 127 contains
 128
 129   !> @brief Converts a character array to an array of c pointers!
 130   !! @return An array of c pointers
 131   function fms_array_to_pointer(my_array) &
 132   result(my_pointer)
 133     character(len=*), target :: my_array(:) !!< Array of strings to convert
 134     type(c_ptr), allocatable :: my_pointer(:)
 135
 136     integer :: i !< For do loops
 137
 138     if (allocated(my_pointer)) call mpp_error(FATAL, "The c pointer array is &
 139       already allocated. Deallocated before calling fms_array_to_pointer")
 140     allocate(my_pointer(size(my_array)))
 141
 142     do i = 1, size(my_array)
 143       my_pointer(i) = c_loc(my_array(i))
 144     enddo
 145   end function fms_array_to_pointer
 146
 147   !> @brief Convert an array of c pointers back to a character array
 148   !! @return A character array
 149   function fms_pointer_to_array(my_pointer, narray) &
 150   result(my_array)
 151     type(c_ptr), intent(in)       :: my_pointer(*) !< Array of c pointer
 152     integer,     intent(in)       :: narray        !< Length of the array
 153     character(len=:), allocatable :: my_array(:)
 154
 155     character(len=:), allocatable :: buffer !< Buffer to store a string
 156     integer                       :: i      !< For do loops
 157
 158     allocate(character(len=255) :: my_array(narray))
 159     do i = 1, narray
 160       buffer = fms_c2f_string(my_pointer(i))
 161       my_array(i) = buffer
 162       deallocate(buffer)
 163     enddo
 164   end function fms_pointer_to_array
 165
 166   !> @brief Searches through a SORTED array of pointers for a string
 167   !! @return the indices where the array was found
 168   !! If the string was not found, indices will be indices(1) = -999
 169   !> <br>Example usage:
 170   !!     my_pointer = fms_array_to_pointer(my_array)
 171   !!     call fms_sort_this(my_pointer, n_array, indices)
 172   !!     ifind = fms_find_my_string(my_pointer, n_array, string_to_find)
 173   function fms_find_my_string(my_pointer, narray, string_to_find) &
 174   result(ifind)
 175     type(c_ptr),      intent(in)    :: my_pointer(*)  !< Array of c pointer
 176     integer,          intent(in)    :: narray         !< Length of the array
 177     character(len=*), intent(in)    :: string_to_find !< string to find
 178     integer, allocatable            :: ifind(:)
 179
 180     integer                       :: nfind  !< number of times the string was found
 181     character(len=:), allocatable :: buffer !< buffer to read the indices into
 182
 183     buffer = fms_c2f_string(&
 184       fms_find_my_string_binding(my_pointer, narray, trim(string_to_find)//c_null_char, nfind))
 185
 186     if (allocated(ifind)) call mpp_error(FATAL, "The indices array is already allocated. &
 187     Deallocate it before calling fms_find_my_string")
 188
 189     if (nfind .gt. 0) then
 190       allocate(ifind(nfind))
 191       read(buffer,*) ifind
 192     else
 193       allocate(ifind(1))
 194       ifind = -999
 195     endif
 196
 197   end function fms_find_my_string
 198
 199   !> \brief Converts a C-string to a pointer and then to a Fortran string
 200   function cstring_fortran_conversion (cstring) result(fstring)
 201     character (kind=c_char), intent(in) :: cstring (*) !< Input C-string
 202     character(len=:), allocatable :: fstring    !< The fortran string returned
 203     fstring = cpointer_fortran_conversion(fms_cstring2cpointer(cstring))
 204   end function cstring_fortran_conversion
 205
 206   !> \brief Converts a C-string returned from a TYPE(C_PTR) function to
 207   !! a fortran string with type character.
 208   function cpointer_fortran_conversion (cstring) result(fstring)
 209     type (c_ptr), intent(in) :: cstring !< Input C-pointer
 210     character(len=:), allocatable :: fstring    !< The fortran string returned
 211     character(len=:,kind=c_char), pointer :: string_buffer !< A temporary pointer to between C and Fortran
 212     integer(c_size_t) :: length !< The string length
 213
 214     length = c_strlen(cstring)
 215     allocate (character(len=length, kind=c_char) :: string_buffer)
 216     block
 217       character(len=length,kind=c_char), pointer :: s
 218       call c_f_pointer(cstring,s)  ! Recovers a view of the C string
 219       string_buffer = s                   ! Copies the string contents
 220     end block
 221
 222     allocate(character(len=length) :: fstring) !> Set the length of fstring
 223     fstring = string_buffer
 224     deallocate(string_buffer)
 225   end function cpointer_fortran_conversion
 226
 227 !> @brief Copies a Fortran string into a C string and puts c_null_char in any trailing spaces
 228   subroutine fms_f2c_string (dest, str_in)
 229     character (c_char), intent (out) :: dest (:) !< C String to be copied into
 230     character (len=*), intent (in) :: str_in !< Fortran string to copy to C string
 231     integer :: i !< for looping
 232 !> Drop an error if the C string is not large enough to hold the input and the c_null_char at the end.
 233     if (len(trim(str_in)) .ge. size(dest)) call mpp_error(FATAL, &
 234       "The string "//trim(str_in)//" is larger than the destination C string")
 235 !> Copy c_null_char into each spot in dest
 236     dest = c_null_char
 237 !> Loop though and put each character of the Fortran string into the C string array
 238     do i = 1, len(trim(str_in))
 239       dest(i) = str_in(i:i)
 240     enddo
 241 end subroutine fms_f2c_string
 242
 243   !> @brief Converts a number or a Boolean value to a string
 244   !> @return The argument as a string
 245   function string(v, fmt)
 246     class(*), intent(in) :: v !< Value to be converted to a string
 247     character(*), intent(in), optional :: fmt !< Optional format string for a real or integral argument
 248     character(:), allocatable :: string
 249
 250     select type(v)
 251       type is (logical)
 252         if (present(fmt)) then
 253           call mpp_error(WARNING, "string(): Ignoring `fmt` argument for type `logical`")
 254         endif
 255         if (v) then
 256           string = "True"
 257         else
 258           string = "False"
 259         endif
 260
 261       type is (integer(i4_kind))
 262         allocate(character(32) :: string)
 263         if (present(fmt)) then
 264           write(string, "(" // fmt // ")") v
 265         else
 266           write(string, '(i0)') v
 267         endif
 268         string = trim(adjustl(string))
 269
 270       type is (integer(i8_kind))
 271         allocate(character(32) :: string)
 272         if (present(fmt)) then
 273           write(string, "(" // fmt // ")") v
 274         else
 275           write(string, '(i0)') v
 276         endif
 277         string = trim(adjustl(string))
 278
 279       type is (real(r4_kind))
 280         allocate(character(32) :: string)
 281         if (present(fmt)) then
 282           write(string, "(" // fmt // ")") v
 283         else
 284           write(string, *) v
 285         endif
 286         string = trim(adjustl(string))
 287
 288       type is (real(r8_kind))
 289         allocate(character(32) :: string)
 290         if (present(fmt)) then
 291           write(string, "(" // fmt // ")") v
 292         else
 293           write(string, *) v
 294         endif
 295         string = trim(adjustl(string))
 296
 297       class default
 298         call mpp_error(FATAL, "string(): Called with incompatible argument type. Possible types &
 299                               &include integer(4), integer(8), real(4), real(8), or logical.")
 300     end select
 301   end function string
 302
 303   !> @brief Safely copy a string from one buffer to another.
 304   subroutine string_copy(dest, source, check_for_null)
 305     character(len=*), intent(inout) :: dest !< Destination string.
 306     character(len=*), intent(in) :: source !< Source string.
 307     logical, intent(in), optional :: check_for_null !<Flag indicating to test for null character
 308
 309     integer :: i
 310     logical :: check_null
 311
 312     check_null = .false.
 313     if (present(check_for_null)) check_null = check_for_null
 314
 315     i = 0
 316     if (check_null) then
 317       i = index(source, char(0)) - 1
 318     endif
 319
 320     if (i < 1 ) i = len_trim(source)
 321
 322     if (len_trim(source(1:i)) .gt. len(dest)) then
 323       call mpp_error(FATAL, "The input destination string is not big enough to" &
 324                  //" to hold the input source string.")
 325     endif
 326     dest = ""
 327     dest = adjustl(trim(source(1:i)))
 328   end subroutine string_copy
 329
 330 #include "fms_string_utils_r4.fh"
 331 #include "fms_string_utils_r8.fh"
 332
 333 end module fms_string_utils_mod
 334 !> @}
 335 ! close documentation grouping