test_fms/string_utils/test_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 !> @brief  This programs tests the public subroutines in test_fms_string_utils:
  21 !! fms_array_to_pointer, fms_pointer_to_array, fms_sort_this, fms_find_my_string
  22 program test_fms_string_utils
  23   use fms_string_utils_mod
  24   use fms_mod, only: fms_init, fms_end
  25   use platform_mod, only: r4_kind, r8_kind, i4_kind, i8_kind
  26   use mpp_mod
  27   use, intrinsic :: iso_c_binding
  28
  29   implicit none
  30
  31   character(len=10), allocatable :: my_array(:) !< Array of strings
  32   character(len=:), allocatable :: my_sorted_array(:) !< Sorted array of strings
  33   type(c_ptr), allocatable :: my_pointer(:) !< Array of pointers
  34   integer, allocatable :: my_ids(:) !< Array of indices
  35   integer :: i !< For do loops
  36   integer, allocatable :: ifind(:) !< Array of indices where a string was found
  37   integer :: nunique !< Number of unique strings in an array of strings
  38
  39   call fms_init()
  40
  41   allocate(my_array(10))
  42   allocate(my_ids(10))
  43
  44   my_array(1) = "golf"//c_null_char
  45   my_array(2) = "charlie"//c_null_char
  46   my_array(3) = "golf"//c_null_char
  47   my_array(4) = "beta"//c_null_char
  48   my_array(5) = "alpha"//c_null_char
  49   my_array(6) = "foxtrop"//c_null_char
  50   my_array(7) = "golf"//c_null_char
  51   my_array(8) = "foxtrop"//c_null_char
  52   my_array(9) = "juliet"//c_null_char
  53   my_array(10) ="india"//c_null_char
  54
  55   do i=1, 10
  56     my_ids(i) = i
  57   end do
  58
  59   my_pointer = fms_array_to_pointer(my_array)
  60
  61   print *, "Check if fms_find_unique works without sorting the array first!"
  62   nunique = fms_find_unique(my_pointer, 10)
  63   if (nunique .ne. 7) call mpp_error(FATAL, "The number of unique strings in your array is not correct")
  64
  65   call fms_sort_this(my_pointer, 10, my_ids)
  66   my_sorted_array = fms_pointer_to_array(my_pointer, 10)
  67   print *, "Checking if the array was sorted correctly"
  68   call check_my_sorted_array(my_sorted_array)
  69
  70   ifind = fms_find_my_string(my_pointer, 10, "alpha")
  71   print *, "Checking if 'alpha' was found in the array at all the right places"
  72   call check_my_indices(ifind, (/1/), "alpha")
  73   deallocate(ifind)
  74
  75   ifind = fms_find_my_string(my_pointer, 10, "beta")
  76   print *, "Checking if 'beta' was found in the array at all the right places"
  77   call check_my_indices(ifind, (/2/), "beta")
  78   deallocate(ifind)
  79
  80   ifind = fms_find_my_string(my_pointer, 10, "charlie")
  81   print *, "Checking if 'charlie' was found in the array at all the right places"
  82   call check_my_indices(ifind, (/3/), "charlie")
  83   deallocate(ifind)
  84
  85   ifind = fms_find_my_string(my_pointer, 10, "foxtrop")
  86   print *, "Checking if 'foxtrop' was found in the array at all the right places"
  87   call check_my_indices(ifind, (/5,4/), "foxtrop")
  88   deallocate(ifind)
  89
  90   ifind = fms_find_my_string(my_pointer, 10, "golf")
  91   print *, "Checking if 'golf' was found in the array at all the right places"
  92   call check_my_indices(ifind, (/6,7,8/), "golf")
  93   deallocate(ifind)
  94
  95   ifind = fms_find_my_string(my_pointer, 10, "india")
  96   print *, "Checking if 'india' was found in the array at all the right places"
  97   call check_my_indices(ifind, (/9/), "india")
  98   deallocate(ifind)
  99
 100   ifind = fms_find_my_string(my_pointer, 10, "juliet")
 101   print *, "Checking if 'juliet' was found in the array at all the right places"
 102   call check_my_indices(ifind, (/10/), "juliet")
 103   deallocate(ifind)
 104
 105   ifind = fms_find_my_string(my_pointer, 10, "tamales")
 106   print *, "Checking if 'tamales' was found in the array at all the right places"
 107   call check_my_indices(ifind, (/-999/), "tamales")
 108   deallocate(ifind)
 109
 110   nunique = fms_find_unique(my_pointer, 10)
 111   print *, "Checking if fms_find_unique determines the correct number of unique strings"
 112   if (nunique .ne. 7) call mpp_error(FATAL, "The number of unique strings in your array is not correct")
 113
 114   call check_string
 115   call check_stringify
 116
 117   call fms_end()
 118
 119   deallocate(my_array)
 120   deallocate(my_ids)
 121   deallocate(my_pointer)
 122
 123   contains
 124
 125   !< Checks if the array was sorted correctly!
 126   subroutine check_my_sorted_array(sorted_array)
 127     character(len=*), intent(in) :: sorted_array(:) !< Array of sorted strings
 128     integer :: j !< For do loops
 129     character(len=10) :: ans(10) !< Expected array of sorted strings
 130
 131     ans(1) = "alpha"//c_null_char
 132     ans(2) = "beta"//c_null_char
 133     ans(3) = "charlie"//c_null_char
 134     ans(4) = "foxtrop"//c_null_char
 135     ans(5) = "foxtrop"//c_null_char
 136     ans(6) = "golf"//c_null_char
 137     ans(7) = "golf"//c_null_char
 138     ans(8) = "golf"//c_null_char
 139     ans(9) = "india"//c_null_char
 140     ans(10) = "juliet"//c_null_char
 141
 142     do j = 1, size(ans)
 143       print *, "Comparing ", trim(sorted_array(j)), " and ", trim(ans(j))
 144       if (trim(sorted_array(j)) .eq. trim(ans(j))) &
 145         call mpp_error(FATAL, "The sorted array is not correct!")
 146     end do
 147
 148   end subroutine check_my_sorted_array
 149
 150   !< Checks if an array of integers is the expected result
 151   subroutine check_my_indices(indices, ans, string)
 152     integer, intent(in) :: indices(:) !< Array of indices
 153     integer, intent(in) :: ans(:) !< Expected answers
 154     character(len=*), intent(in) :: string !< Name of field comparing
 155
 156     integer :: j !< For do loops
 157
 158     if (size(indices) .ne. size(ans)) then
 159       print *, "The size of ", trim(string), " is ", size(indices)
 160       call mpp_error(FATAL, "The size of the indices where "//trim(string)//" was found is not correct")
 161     endif
 162
 163     do j = 1, size(indices)
 164       print *, "Checking if the ", j, " index is ", ans(j)
 165       if (indices(j) .ne. ans(j)) then
 166         print *, "The indices of ", trim(string), " are ", indices
 167         call mpp_error(FATAL, "The indices where "//trim(string)//" was found is not correct")
 168       endif
 169     end do
 170   end subroutine check_my_indices
 171
 172   subroutine check_string
 173     if (string(.true.) .ne. "True") then
 174       call mpp_error(FATAL, "string() unit test failed for Boolean true value")
 175     endif
 176
 177     if (string(.false.) .ne. "False") then
 178       call mpp_error(FATAL, "string() unit test failed for Boolean false value")
 179     endif
 180
 181     if (string(12345_i4_kind) .ne. "12345") then
 182       call mpp_error(FATAL, "string() unit test failed for positive integer(4)")
 183     endif
 184
 185     if (string(-12345_i4_kind) .ne. "-12345") then
 186       call mpp_error(FATAL, "string() unit test failed for negative integer(4)")
 187     endif
 188
 189     if (string(12345_i8_kind) .ne. "12345") then
 190       call mpp_error(FATAL, "string() unit test failed for positive integer(8)")
 191     endif
 192
 193     if (string(-12345_i8_kind) .ne. "-12345") then
 194       call mpp_error(FATAL, "string() unit test failed for negative integer(8)")
 195     endif
 196
 197     if (string(1._r4_kind, "F15.7") .ne. "1.0000000") then
 198       call mpp_error(FATAL, "string() unit test failed for positive real(4)")
 199     endif
 200
 201     if (string(-1._r4_kind, "F15.7") .ne. "-1.0000000") then
 202       call mpp_error(FATAL, "string() unit test failed for negative real(4)")
 203     endif
 204
 205     if (string(1._r8_kind, "F25.16") .ne. "1.0000000000000000") then
 206       call mpp_error(FATAL, "string() unit test failed for positive real(8)")
 207     endif
 208
 209     if (string(-1._r8_kind, "F25.16") .ne. "-1.0000000000000000") then
 210       call mpp_error(FATAL, "string() unit test failed for negative real(8)")
 211     endif
 212   end subroutine
 213
 214   subroutine check_stringify
 215     real(r4_kind) :: arr_1d_r4(3), arr_2d_r4(2, 2), arr_3d_r4(2, 2, 2)
 216     real(r8_kind) :: arr_1d_r8(3), arr_2d_r8(2, 2), arr_3d_r8(2, 2, 2)
 217
 218     arr_1d_r4 = [0._r4_kind, 1._r4_kind, 2._r4_kind]
 219     if (stringify(arr_1d_r4, "F15.7") .ne. "[0.0000000, 1.0000000, 2.0000000]") then
 220       call mpp_error(FATAL, "stringify() unit test failed for 1D r4 array")
 221     endif
 222
 223     arr_1d_r8 = [0._r8_kind, 1._r8_kind, 2._r8_kind]
 224     if (stringify(arr_1d_r8, "F25.16") .ne. "[0.0000000000000000, 1.0000000000000000, 2.0000000000000000]") then
 225       call mpp_error(FATAL, "stringify() unit test failed for 1D r8 array")
 226     endif
 227
 228     arr_2d_r4 = reshape([[0._r4_kind, 1._r4_kind], [2._r4_kind, 3._r4_kind]], [2, 2])
 229     if (stringify(arr_2d_r4, "F15.7") .ne. &
 230     & "[[0.0000000, 1.0000000], [2.0000000, 3.0000000]]") then
 231       call mpp_error(FATAL, "stringify() unit test failed for 2D r4 array")
 232     endif
 233
 234     arr_2d_r8 = reshape([[0._r8_kind, 1._r8_kind], [2._r8_kind, 3._r8_kind]], [2, 2])
 235     if (stringify(arr_2d_r8, "F25.16") .ne. &
 236     & "[[0.0000000000000000, 1.0000000000000000], [2.0000000000000000, 3.0000000000000000]]") then
 237       call mpp_error(FATAL, "stringify() unit test failed for 2D r8 array")
 238     endif
 239
 240     arr_3d_r4 = reshape([ &
 241       & [[0._r4_kind, 1._r4_kind], [2._r4_kind, 3._r4_kind]], &
 242       & [[4._r4_kind, 5._r4_kind], [6._r4_kind, 7._r4_kind]] &
 243     & ], [2, 2, 2])
 244     if (stringify(arr_3d_r4, "F15.7") .ne. &
 245     & "[[[0.0000000, 1.0000000], [2.0000000, 3.0000000]],&
 246       & [[4.0000000, 5.0000000], [6.0000000, 7.0000000]]]") then
 247       call mpp_error(FATAL, "stringify() unit test failed for 3D r4 array")
 248     endif
 249
 250     arr_3d_r8 = reshape([ &
 251       & [[0._r8_kind, 1._r8_kind], [2._r8_kind, 3._r8_kind]], &
 252       & [[4._r8_kind, 5._r8_kind], [6._r8_kind, 7._r8_kind]] &
 253     & ], [2, 2, 2])
 254     if (stringify(arr_3d_r8, "F25.16") .ne. &
 255     & "[[[0.0000000000000000, 1.0000000000000000], [2.0000000000000000, 3.0000000000000000]],&
 256       & [[4.0000000000000000, 5.0000000000000000], [6.0000000000000000, 7.0000000000000000]]]") then
 257       call mpp_error(FATAL, "stringify() unit test failed for 3D r8 array")
 258     endif
 259   end subroutine
 260
 261 end program test_fms_string_utils