From f74cd34c142f88eb263f4a1136a5aeed0d828474 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Tue, 31 Jan 2023 12:38:07 -0500 Subject: [PATCH 01/15] Fix misspellings Replace "sucess" with "success" and "sucessful" with "successful". --- parser/yaml_parser.F90 | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/parser/yaml_parser.F90 b/parser/yaml_parser.F90 index a24042cfcd..3503b9f7c8 100644 --- a/parser/yaml_parser.F90 +++ b/parser/yaml_parser.F90 @@ -61,13 +61,13 @@ module yaml_parser_mod interface !> @brief Private c function that opens and parses a yaml file (see yaml_parser_binding.c) -!! @return Flag indicating if the read was sucessful +!! @return Flag indicating if the read was successful function open_and_parse_file_wrap(filename, file_id) bind(c) & - result(sucess) + result(success) use iso_c_binding, only: c_char, c_int, c_bool character(kind=c_char), intent(in) :: filename(*) !< Filename of the yaml file integer(kind=c_int), intent(out) :: file_id !< File id corresponding to the yaml file that was opened - logical(kind=c_bool) :: sucess !< Flag indicating if the read was sucessful + logical(kind=c_bool) :: success !< Flag indicating if the read was successful end function open_and_parse_file_wrap !> @brief Private c function that checks if a file_id is valid (see yaml_parser_binding.c) @@ -129,14 +129,14 @@ end function get_value !> @brief Private c function that determines they value of a key in yaml_file (see yaml_parser_binding.c) !! @return c pointer with the value obtained -function get_value_from_key_wrap(file_id, block_id, key_name, sucess) bind(c) & +function get_value_from_key_wrap(file_id, block_id, key_name, success) bind(c) & result(key_value2) use iso_c_binding, only: c_ptr, c_char, c_int, c_bool integer(kind=c_int), intent(in) :: file_id !< File id of the yaml file to search integer(kind=c_int), intent(in) :: block_id !< ID corresponding to the block you want the key for character(kind=c_char), intent(in) :: key_name(*) !< Name of the key you want the value for - integer(kind=c_int), intent(out) :: sucess !< Flag indicating if the call was sucessful + integer(kind=c_int), intent(out) :: success !< Flag indicating if the call was successful type(c_ptr) :: key_value2 end function get_value_from_key_wrap @@ -206,7 +206,7 @@ function open_and_parse_file(filename) & result(file_id) character(len=*), intent(in) :: filename !< Filename of the yaml file - logical :: sucess !< Flag indicating if the read was sucessful + logical :: success !< Flag indicating if the read was successful logical :: yaml_exists !< Flag indicating whether the yaml exists integer :: file_id @@ -217,8 +217,8 @@ function open_and_parse_file(filename) & call mpp_error(NOTE, "The yaml file:"//trim(filename)//" does not exist, hopefully this is your intent!") return end if - sucess = open_and_parse_file_wrap(trim(filename)//c_null_char, file_id) - if (.not. sucess) call mpp_error(FATAL, "Error opening the yaml file:"//trim(filename)//". Check the file!") + success = open_and_parse_file_wrap(trim(filename)//c_null_char, file_id) + if (.not. success) call mpp_error(FATAL, "Error opening the yaml file:"//trim(filename)//". Check the file!") end function open_and_parse_file @@ -265,7 +265,7 @@ subroutine get_value_from_key_0d(file_id, block_id, key_name, key_value, is_opti character(len=255) :: buffer !< String buffer with the value type(c_ptr) :: c_buffer !< c pointer with the value - integer(kind=c_int) :: sucess !< Flag indicating if the value was obtained sucessfully + integer(kind=c_int) :: success !< Flag indicating if the value was obtained successfully logical :: optional !< Flag indicating that the key was optional integer :: err_unit !< integer with io error @@ -277,8 +277,8 @@ subroutine get_value_from_key_0d(file_id, block_id, key_name, key_value, is_opti if (.not. is_valid_block_id(file_id, block_id)) call mpp_error(FATAL, & & "The block id in your get_value_from_key call is invalid! Check your call.") - c_buffer = get_value_from_key_wrap(file_id, block_id, trim(key_name)//c_null_char, sucess) - if (sucess == 1) then + c_buffer = get_value_from_key_wrap(file_id, block_id, trim(key_name)//c_null_char, success) + if (success == 1) then buffer = fms_c2f_string(c_buffer) select type (key_value) @@ -331,7 +331,7 @@ subroutine get_value_from_key_1d(file_id, block_id, key_name, key_value, is_opti character(len=255) :: buffer !< String buffer with the value type(c_ptr) :: c_buffer !< c pointer with the value - integer(kind=c_int) :: sucess !< Flag indicating if the value was obtained sucessfully + integer(kind=c_int) :: success !< Flag indicating if the value was obtained successfully logical :: optional !< Flag indicating that the key was optional integer :: err_unit !< integer with io error @@ -343,8 +343,8 @@ subroutine get_value_from_key_1d(file_id, block_id, key_name, key_value, is_opti if (.not. is_valid_block_id(file_id, block_id)) call mpp_error(FATAL, & & "The block id in your get_value_from_key call is invalid! Check your call.") - c_buffer = get_value_from_key_wrap(file_id, block_id, trim(key_name)//c_null_char, sucess) - if (sucess == 1) then + c_buffer = get_value_from_key_wrap(file_id, block_id, trim(key_name)//c_null_char, success) + if (success == 1) then buffer = fms_c2f_string(c_buffer) select type (key_value) From 6ffcd21b917eb444e5d99ae07d392722a258f360 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Tue, 31 Jan 2023 12:49:56 -0500 Subject: [PATCH 02/15] Fix more typos Replace "they" with "the". --- parser/yaml_parser.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/parser/yaml_parser.F90 b/parser/yaml_parser.F90 index 3503b9f7c8..f518f7ce72 100644 --- a/parser/yaml_parser.F90 +++ b/parser/yaml_parser.F90 @@ -127,7 +127,7 @@ function get_value(file_id, key_id) bind(c) & type(c_ptr) :: key_value end function get_value -!> @brief Private c function that determines they value of a key in yaml_file (see yaml_parser_binding.c) +!> @brief Private c function that determines the value of a key in yaml_file (see yaml_parser_binding.c) !! @return c pointer with the value obtained function get_value_from_key_wrap(file_id, block_id, key_name, success) bind(c) & result(key_value2) @@ -258,7 +258,7 @@ subroutine get_value_from_key_0d(file_id, block_id, key_name, key_value, is_opti integer, intent(in) :: block_id !< ID corresponding to the block you want the key for character(len=*), intent(in) :: key_name !< Name of the key you want the value for class(*), intent(inout):: key_value !< Value of the key - logical, intent(in), optional :: is_optional !< Flag indicating if it is okay for they key to not exist. + logical, intent(in), optional :: is_optional !< Flag indicating if it is okay for the key to not exist. !! If the key does not exist key_value will not be set, so it !! is the user's responsibility to initialize it before the call @@ -324,7 +324,7 @@ subroutine get_value_from_key_1d(file_id, block_id, key_name, key_value, is_opti integer, intent(in) :: block_id !< ID corresponding to the block you want the key for character(len=*), intent(in) :: key_name !< Name of the key you want the value for class(*), intent(inout):: key_value(:) !< Value of the key - logical, intent(in), optional :: is_optional !< Flag indicating if it is okay for they key' to not exist. + logical, intent(in), optional :: is_optional !< Flag indicating if it is okay for the key' to not exist. !! If the key does not exist key_value will not be set, so it !! is the user's responsibility to initialize it before the call From 8234fd085eb2cc33decb5d9830fe8fcd618dcc6d Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Tue, 31 Jan 2023 12:58:15 -0500 Subject: [PATCH 03/15] Rename "optional" variable Use the name "optional_flag" instead of "optional", because the latter is a Fortran keyword. --- parser/yaml_parser.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/parser/yaml_parser.F90 b/parser/yaml_parser.F90 index f518f7ce72..14a494ba02 100644 --- a/parser/yaml_parser.F90 +++ b/parser/yaml_parser.F90 @@ -266,11 +266,11 @@ subroutine get_value_from_key_0d(file_id, block_id, key_name, key_value, is_opti type(c_ptr) :: c_buffer !< c pointer with the value integer(kind=c_int) :: success !< Flag indicating if the value was obtained successfully - logical :: optional !< Flag indicating that the key was optional + logical :: optional_flag !< Flag indicating that the key was optional integer :: err_unit !< integer with io error - optional = .false. - if (present(is_optional)) optional = is_optional + optional_flag = .false. + if (present(is_optional)) optional_flag = is_optional if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, & & "The file id in your get_value_from_key call is invalid! Check your call.") @@ -313,7 +313,7 @@ subroutine get_value_from_key_0d(file_id, block_id, key_name, key_value, is_opti &" is not supported. Only i4, i8, r4, r8 and strings are supported.") end select else - if(.not. optional) call mpp_error(FATAL, "Error getting the value for key:"//trim(key_name)) + if(.not. optional_flag) call mpp_error(FATAL, "Error getting the value for key:"//trim(key_name)) endif end subroutine get_value_from_key_0d @@ -332,11 +332,11 @@ subroutine get_value_from_key_1d(file_id, block_id, key_name, key_value, is_opti type(c_ptr) :: c_buffer !< c pointer with the value integer(kind=c_int) :: success !< Flag indicating if the value was obtained successfully - logical :: optional !< Flag indicating that the key was optional + logical :: optional_flag !< Flag indicating that the key was optional integer :: err_unit !< integer with io error - optional=.false. - if (present(is_optional)) optional = is_optional + optional_flag=.false. + if (present(is_optional)) optional_flag = is_optional if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, & & "The file id in your get_value_from_key call is invalid! Check your call.") @@ -371,7 +371,7 @@ subroutine get_value_from_key_1d(file_id, block_id, key_name, key_value, is_opti &" is not supported. Only i4, i8, r4, r8 and strings are supported.") end select else - if(.not. optional) call mpp_error(FATAL, "Error getting the value for key:"//trim(key_name)) + if(.not. optional_flag) call mpp_error(FATAL, "Error getting the value for key:"//trim(key_name)) endif end subroutine get_value_from_key_1d From 44ec5523e46322f9af2ef17789f779393750283a Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Fri, 3 Mar 2023 15:33:53 -0500 Subject: [PATCH 04/15] `fms_string_utils_mod`: Extend and improve `string()` Extend and improve `string()` in `fms_string_utils_mod`. `r4_kind` and `r8_kind` versions of `string_from_real` have been implemented. Leading and trailing whitespace are now stripped from the returned string. Functions to convert 1D, 2D, and 3D arrays to strings have been implemented and added to the `string` interface. --- string_utils/Makefile.am | 2 +- string_utils/fms_string_utils.F90 | 26 +++--- string_utils/include/fms_string_utils.inc | 95 +++++++++++++++++++++ string_utils/include/fms_string_utils_r4.fh | 32 +++++++ string_utils/include/fms_string_utils_r8.fh | 32 +++++++ 5 files changed, 170 insertions(+), 17 deletions(-) create mode 100644 string_utils/include/fms_string_utils.inc create mode 100644 string_utils/include/fms_string_utils_r4.fh create mode 100644 string_utils/include/fms_string_utils_r8.fh diff --git a/string_utils/Makefile.am b/string_utils/Makefile.am index ca0c3ab5ef..1ebb28a11d 100644 --- a/string_utils/Makefile.am +++ b/string_utils/Makefile.am @@ -21,7 +21,7 @@ # package. # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/string_utils/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build this uninstalled convenience library. diff --git a/string_utils/fms_string_utils.F90 b/string_utils/fms_string_utils.F90 index cf2dcd0376..60ab2796ab 100644 --- a/string_utils/fms_string_utils.F90 +++ b/string_utils/fms_string_utils.F90 @@ -28,6 +28,7 @@ !> @{ module fms_string_utils_mod use, intrinsic :: iso_c_binding + use platform_mod, only: r4_kind, r8_kind use mpp_mod implicit none @@ -112,11 +113,14 @@ subroutine c_free(ptr) bind(c,name="free") module procedure cpointer_fortran_conversion end interface -!> Converts a number to a string +!> Converts a number or a real array to a string !> @ingroup fms_mod interface string - module procedure string_from_integer - module procedure string_from_real + module procedure string_from_integer + module procedure string_from_r4, string_from_r8 + module procedure string_from_array_1d_r4, string_from_array_1d_r8 + module procedure string_from_array_2d_r4, string_from_array_2d_r8 + module procedure string_from_array_3d_r4, string_from_array_3d_r8 end interface !> @addtogroup fms_string_utils_mod @@ -250,19 +254,6 @@ function string_from_integer(i) result (res) end function string_from_integer - !####################################################################### - !> @brief Converts a real to a string - !> @return The real number as a string - function string_from_real(r) - real, intent(in) :: r !< Real number to be converted to a string - character(len=32) :: string_from_real - - write(string_from_real,*) r - - return - - end function string_from_real - !> @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. @@ -290,6 +281,9 @@ subroutine string_copy(dest, source, check_for_null) 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 diff --git a/string_utils/include/fms_string_utils.inc b/string_utils/include/fms_string_utils.inc new file mode 100644 index 0000000000..086f38dc73 --- /dev/null +++ b/string_utils/include/fms_string_utils.inc @@ -0,0 +1,95 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS 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 General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @brief Converts a real number to a string +!> @return The real number as a string +function STRING_FROM_REAL_(r) + real(STRING_UTILS_KIND_), intent(in) :: r !< Real number to be converted to a string + character(:), allocatable :: STRING_FROM_REAL_ + character(32) :: s + + write(s, *) r + STRING_FROM_REAL_ = trim(adjustl(s)) +end function + +!> @brief Converts a 1D array of real numbers to a string +!> @return The 1D array as a string +function STRING_FROM_ARRAY_1D_(arr) + real(STRING_UTILS_KIND_), dimension(:), intent(in) :: arr + character(:), allocatable :: STRING_FROM_ARRAY_1D_ + integer :: i, n + + n = size(arr) + + if (n .gt. 0) then + STRING_FROM_ARRAY_1D_ = "[" // STRING_FROM_REAL_(arr(1)) + else + STRING_FROM_ARRAY_1D_ = "[" + endif + + do i = 2,n + STRING_FROM_ARRAY_1D_ = STRING_FROM_ARRAY_1D_ // ", " // STRING_FROM_REAL_(arr(i)) + enddo + + STRING_FROM_ARRAY_1D_ = STRING_FROM_ARRAY_1D_ // "]" +end function + +!> @brief Converts a 2D array of real numbers to a string +!> @return The 2D array as a string +function STRING_FROM_ARRAY_2D_(arr) + real(STRING_UTILS_KIND_), dimension(:,:), intent(in) :: arr + character(:), allocatable :: STRING_FROM_ARRAY_2D_ + integer :: i, n + + n = size(arr, 2) + + if (n .gt. 0) then + STRING_FROM_ARRAY_2D_ = "[" // STRING_FROM_ARRAY_1D_(arr(:,1)) + else + STRING_FROM_ARRAY_2D_ = "[" + endif + + do i = 2,n + STRING_FROM_ARRAY_2D_ = STRING_FROM_ARRAY_2D_ // ", " // STRING_FROM_ARRAY_1D_(arr(:,i)) + enddo + + STRING_FROM_ARRAY_2D_ = STRING_FROM_ARRAY_2D_ // "]" +end function + +!> @brief Converts a 3D array of real numbers to a string +!> @return The 3D array as a string +function STRING_FROM_ARRAY_3D_(arr) + real(STRING_UTILS_KIND_), dimension(:,:,:), intent(in) :: arr + character(:), allocatable :: STRING_FROM_ARRAY_3D_ + integer :: i, n + + n = size(arr, 3) + + if (n .gt. 0) then + STRING_FROM_ARRAY_3D_ = "[" // STRING_FROM_ARRAY_2D_(arr(:,:,1)) + else + STRING_FROM_ARRAY_3D_ = "[" + endif + + do i = 2,n + STRING_FROM_ARRAY_3D_ = STRING_FROM_ARRAY_3D_ // ", " // STRING_FROM_ARRAY_2D_(arr(:,:,i)) + enddo + + STRING_FROM_ARRAY_3D_ = STRING_FROM_ARRAY_3D_ // "]" +end function diff --git a/string_utils/include/fms_string_utils_r4.fh b/string_utils/include/fms_string_utils_r4.fh new file mode 100644 index 0000000000..493eadacbf --- /dev/null +++ b/string_utils/include/fms_string_utils_r4.fh @@ -0,0 +1,32 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS 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 General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +#define STRING_UTILS_KIND_ r4_kind +#define STRING_FROM_REAL_ string_from_r4 +#define STRING_FROM_ARRAY_1D_ string_from_array_1d_r4 +#define STRING_FROM_ARRAY_2D_ string_from_array_2d_r4 +#define STRING_FROM_ARRAY_3D_ string_from_array_3d_r4 + +#include "fms_string_utils.inc" + +#undef STRING_UTILS_KIND_ +#undef STRING_FROM_REAL_ +#undef STRING_FROM_ARRAY_1D_ +#undef STRING_FROM_ARRAY_2D_ +#undef STRING_FROM_ARRAY_3D_ diff --git a/string_utils/include/fms_string_utils_r8.fh b/string_utils/include/fms_string_utils_r8.fh new file mode 100644 index 0000000000..ac03e94bfe --- /dev/null +++ b/string_utils/include/fms_string_utils_r8.fh @@ -0,0 +1,32 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS 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 General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +#define STRING_UTILS_KIND_ r8_kind +#define STRING_FROM_REAL_ string_from_r8 +#define STRING_FROM_ARRAY_1D_ string_from_array_1d_r8 +#define STRING_FROM_ARRAY_2D_ string_from_array_2d_r8 +#define STRING_FROM_ARRAY_3D_ string_from_array_3d_r8 + +#include "fms_string_utils.inc" + +#undef STRING_UTILS_KIND_ +#undef STRING_FROM_REAL_ +#undef STRING_FROM_ARRAY_1D_ +#undef STRING_FROM_ARRAY_2D_ +#undef STRING_FROM_ARRAY_3D_ From 789c6f54973582d2ee810e8c6ddc6248924d69e8 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Fri, 3 Mar 2023 16:23:30 -0500 Subject: [PATCH 05/15] Implement unit test for `string()` A unit test for `string()` from `fms_string_utils_mod` has been implemented. --- test_fms/string_utils/test_string_utils.F90 | 74 +++++++++++++++++++++ 1 file changed, 74 insertions(+) diff --git a/test_fms/string_utils/test_string_utils.F90 b/test_fms/string_utils/test_string_utils.F90 index ff9f51ec4e..191cf536a4 100644 --- a/test_fms/string_utils/test_string_utils.F90 +++ b/test_fms/string_utils/test_string_utils.F90 @@ -22,6 +22,7 @@ program test_fms_string_utils use fms_string_utils_mod use fms_mod, only: fms_init, fms_end + use platform_mod, only: r4_kind, r8_kind use mpp_mod use, intrinsic :: iso_c_binding @@ -110,6 +111,8 @@ program test_fms_string_utils print *, "Checking if fms_find_unique determines the correct number of unique strings" if (nunique .ne. 7) call mpp_error(FATAL, "The number of unique strings in your array is not correct") + call check_string + call fms_end() deallocate(my_array) @@ -165,4 +168,75 @@ subroutine check_my_indices(indices, ans, string) end do end subroutine check_my_indices + subroutine check_string + real(r4_kind) :: arr_1d_r4(3), arr_2d_r4(2, 2), arr_3d_r4(2, 2, 2) + real(r8_kind) :: arr_1d_r8(3), arr_2d_r8(2, 2), arr_3d_r8(2, 2, 2) + + if (string(12345) .ne. "12345") then + call mpp_error(FATAL, "string() unit test failed for positive integer") + endif + + if (string(-12345) .ne. "-12345") then + call mpp_error(FATAL, "string() unit test failed for negative integer") + endif + + if (string(1.2345_ r4_kind) .ne. "1.23450005") then + call mpp_error(FATAL, "string() unit test failed for positive r4 real") + endif + + if (string(-1.2345_ r4_kind) .ne. "-1.23450005") then + call mpp_error(FATAL, "string() unit test failed for negative r4 real") + endif + + if (string(1.2345_ r8_kind) .ne. "1.2344999999999999") then + call mpp_error(FATAL, "string() unit test failed for positive r8 real") + endif + + if (string(-1.2345_ r8_kind) .ne. "-1.2344999999999999") then + call mpp_error(FATAL, "string() unit test failed for negative r8 real") + endif + + arr_1d_r4 = [0._ r4_kind, 1._ r4_kind, 2._ r4_kind] + if (string(arr_1d_r4) .ne. "[0.00000000, 1.00000000, 2.00000000]") then + call mpp_error(FATAL, "string() unit test failed for 1D r4 array") + endif + + arr_1d_r8 = [0._ r8_kind, 1._ r8_kind, 2._ r8_kind] + if (string(arr_1d_r8) .ne. "[0.0000000000000000, 1.0000000000000000, 2.0000000000000000]") then + call mpp_error(FATAL, "string() unit test failed for 1D r8 array") + endif + + arr_2d_r4 = reshape([[0._ r4_kind, 1._ r4_kind], [2._ r4_kind, 3._ r4_kind]], [2, 2]) + if (string(arr_2d_r4) .ne. & + & "[[0.00000000, 1.00000000], [2.00000000, 3.00000000]]") then + call mpp_error(FATAL, "string() unit test failed for 2D r4 array") + endif + + arr_2d_r8 = reshape([[0._ r8_kind, 1._ r8_kind], [2._ r8_kind, 3._ r8_kind]], [2, 2]) + if (string(arr_2d_r8) .ne. & + & "[[0.0000000000000000, 1.0000000000000000], [2.0000000000000000, 3.0000000000000000]]") then + call mpp_error(FATAL, "string() unit test failed for 2D r8 array") + endif + + arr_3d_r4 = reshape([ & + & [[0._ r4_kind, 1._ r4_kind], [2._ r4_kind, 3._ r4_kind]], & + & [[4._ r4_kind, 5._ r4_kind], [6._ r4_kind, 7._ r4_kind]] & + & ], [2, 2, 2]) + if (string(arr_3d_r4) .ne. & + & "[[[0.00000000, 1.00000000], [2.00000000, 3.00000000]],& + & [[4.00000000, 5.00000000], [6.00000000, 7.00000000]]]") then + call mpp_error(FATAL, "string() unit test failed for 3D r4 array") + endif + + arr_3d_r8 = reshape([ & + & [[0._ r8_kind, 1._ r8_kind], [2._ r8_kind, 3._ r8_kind]], & + & [[4._ r8_kind, 5._ r8_kind], [6._ r8_kind, 7._ r8_kind]] & + & ], [2, 2, 2]) + if (string(arr_3d_r8) .ne. & + & "[[[0.0000000000000000, 1.0000000000000000], [2.0000000000000000, 3.0000000000000000]],& + & [[4.0000000000000000, 5.0000000000000000], [6.0000000000000000, 7.0000000000000000]]]") then + call mpp_error(FATAL, "string() unit test failed for 3D r8 array") + endif + end subroutine + end program test_fms_string_utils From a9a3a289e0924553d439edc9720a7b07f9a969e3 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Fri, 3 Mar 2023 17:30:43 -0500 Subject: [PATCH 06/15] Add new include directory to `CMakeLists.txt` In relation to the extension of the `string` interface in `fms_string_utils_mod`, the new include directory has been added to `CMakeLists.txt` and the new include files have been added to `string_utils/Makefile.am`. --- CMakeLists.txt | 2 ++ string_utils/Makefile.am | 3 +++ 2 files changed, 5 insertions(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index 930f37c426..a4759aaa72 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -296,6 +296,7 @@ foreach(kind ${kinds}) target_include_directories(${libTgt}_f PRIVATE include fms fms2_io/include + string_utils/include mpp/include diag_manager/include constants4 @@ -334,6 +335,7 @@ foreach(kind ${kinds}) $ $ $ + $ $ $) diff --git a/string_utils/Makefile.am b/string_utils/Makefile.am index 1ebb28a11d..408c5eea7a 100644 --- a/string_utils/Makefile.am +++ b/string_utils/Makefile.am @@ -30,6 +30,9 @@ noinst_LTLIBRARIES = libstring_utils.la # The convenience library depends on its source. libstring_utils_la_SOURCES = \ fms_string_utils.F90 \ + include/fms_string_utils.inc \ + include/fms_string_utils_r4.fh \ + include/fms_string_utils_r8.fh \ fms_string_utils_binding.c MODFILES = \ From da073565b45d60e83ad557c158fc4641b84b1dfc Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Fri, 3 Mar 2023 18:37:29 -0500 Subject: [PATCH 07/15] Remove spaces before real kind values `ifort` doesn't like spaces between real constants and kind values, so the spaces have been removed. --- test_fms/string_utils/test_string_utils.F90 | 24 ++++++++++----------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/test_fms/string_utils/test_string_utils.F90 b/test_fms/string_utils/test_string_utils.F90 index 191cf536a4..ea456ebe52 100644 --- a/test_fms/string_utils/test_string_utils.F90 +++ b/test_fms/string_utils/test_string_utils.F90 @@ -180,47 +180,47 @@ subroutine check_string call mpp_error(FATAL, "string() unit test failed for negative integer") endif - if (string(1.2345_ r4_kind) .ne. "1.23450005") then + if (string(1.2345_r4_kind) .ne. "1.23450005") then call mpp_error(FATAL, "string() unit test failed for positive r4 real") endif - if (string(-1.2345_ r4_kind) .ne. "-1.23450005") then + if (string(-1.2345_r4_kind) .ne. "-1.23450005") then call mpp_error(FATAL, "string() unit test failed for negative r4 real") endif - if (string(1.2345_ r8_kind) .ne. "1.2344999999999999") then + if (string(1.2345_r8_kind) .ne. "1.2344999999999999") then call mpp_error(FATAL, "string() unit test failed for positive r8 real") endif - if (string(-1.2345_ r8_kind) .ne. "-1.2344999999999999") then + if (string(-1.2345_r8_kind) .ne. "-1.2344999999999999") then call mpp_error(FATAL, "string() unit test failed for negative r8 real") endif - arr_1d_r4 = [0._ r4_kind, 1._ r4_kind, 2._ r4_kind] + arr_1d_r4 = [0._r4_kind, 1._r4_kind, 2._r4_kind] if (string(arr_1d_r4) .ne. "[0.00000000, 1.00000000, 2.00000000]") then call mpp_error(FATAL, "string() unit test failed for 1D r4 array") endif - arr_1d_r8 = [0._ r8_kind, 1._ r8_kind, 2._ r8_kind] + arr_1d_r8 = [0._r8_kind, 1._r8_kind, 2._r8_kind] if (string(arr_1d_r8) .ne. "[0.0000000000000000, 1.0000000000000000, 2.0000000000000000]") then call mpp_error(FATAL, "string() unit test failed for 1D r8 array") endif - arr_2d_r4 = reshape([[0._ r4_kind, 1._ r4_kind], [2._ r4_kind, 3._ r4_kind]], [2, 2]) + arr_2d_r4 = reshape([[0._r4_kind, 1._r4_kind], [2._r4_kind, 3._r4_kind]], [2, 2]) if (string(arr_2d_r4) .ne. & & "[[0.00000000, 1.00000000], [2.00000000, 3.00000000]]") then call mpp_error(FATAL, "string() unit test failed for 2D r4 array") endif - arr_2d_r8 = reshape([[0._ r8_kind, 1._ r8_kind], [2._ r8_kind, 3._ r8_kind]], [2, 2]) + arr_2d_r8 = reshape([[0._r8_kind, 1._r8_kind], [2._r8_kind, 3._r8_kind]], [2, 2]) if (string(arr_2d_r8) .ne. & & "[[0.0000000000000000, 1.0000000000000000], [2.0000000000000000, 3.0000000000000000]]") then call mpp_error(FATAL, "string() unit test failed for 2D r8 array") endif arr_3d_r4 = reshape([ & - & [[0._ r4_kind, 1._ r4_kind], [2._ r4_kind, 3._ r4_kind]], & - & [[4._ r4_kind, 5._ r4_kind], [6._ r4_kind, 7._ r4_kind]] & + & [[0._r4_kind, 1._r4_kind], [2._r4_kind, 3._r4_kind]], & + & [[4._r4_kind, 5._r4_kind], [6._r4_kind, 7._r4_kind]] & & ], [2, 2, 2]) if (string(arr_3d_r4) .ne. & & "[[[0.00000000, 1.00000000], [2.00000000, 3.00000000]],& @@ -229,8 +229,8 @@ subroutine check_string endif arr_3d_r8 = reshape([ & - & [[0._ r8_kind, 1._ r8_kind], [2._ r8_kind, 3._ r8_kind]], & - & [[4._ r8_kind, 5._ r8_kind], [6._ r8_kind, 7._ r8_kind]] & + & [[0._r8_kind, 1._r8_kind], [2._r8_kind, 3._r8_kind]], & + & [[4._r8_kind, 5._r8_kind], [6._r8_kind, 7._r8_kind]] & & ], [2, 2, 2]) if (string(arr_3d_r8) .ne. & & "[[[0.0000000000000000, 1.0000000000000000], [2.0000000000000000, 3.0000000000000000]],& From 6893d4a5417934806c4dde3b99de944bdc3c3821 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Sat, 4 Mar 2023 00:36:30 -0500 Subject: [PATCH 08/15] string(): Use explicit format strings Use explicit format strings in `string_from_r4()` and `string_from_r8()`. This makes the string conversions consistent across compilers, allowing the unit test to pass on both the GNU and Intel compilers. This change required `string_from_r4` and `string_from_r8` to be moved back from the include file into `fms_string_utils.F90`, since the two functions now use different format strings. --- string_utils/fms_string_utils.F90 | 23 +++++++++++++++++++- string_utils/include/fms_string_utils.inc | 15 ++----------- string_utils/include/fms_string_utils_r4.fh | 2 -- string_utils/include/fms_string_utils_r8.fh | 2 -- test_fms/string_utils/test_string_utils.F90 | 24 ++++++++++----------- 5 files changed, 36 insertions(+), 30 deletions(-) diff --git a/string_utils/fms_string_utils.F90 b/string_utils/fms_string_utils.F90 index 60ab2796ab..1748659e2d 100644 --- a/string_utils/fms_string_utils.F90 +++ b/string_utils/fms_string_utils.F90 @@ -251,9 +251,30 @@ function string_from_integer(i) result (res) write(tmp,'(i0)') i res = trim(tmp) return - end function string_from_integer + !> @brief Converts a real number (r4_kind) to a string + !> @return The real number as a string + function string_from_r4(r) + real(r4_kind), intent(in) :: r !< Real number to be converted to a string + character(:), allocatable :: string_from_r4 + character(15) :: s + + write(s, "(ES15.7E2)") r + string_from_r4 = trim(adjustl(s)) + end function + + !> @brief Converts a real number (r8_kind) to a string + !> @return The real number as a string + function string_from_r8(r) + real(r8_kind), intent(in) :: r !< Real number to be converted to a string + character(:), allocatable :: string_from_r8 + character(25) :: s + + write(s, "(ES25.16E2)") r + string_from_r8 = trim(adjustl(s)) + end function + !> @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. diff --git a/string_utils/include/fms_string_utils.inc b/string_utils/include/fms_string_utils.inc index 086f38dc73..153bd37a8a 100644 --- a/string_utils/include/fms_string_utils.inc +++ b/string_utils/include/fms_string_utils.inc @@ -17,17 +17,6 @@ !* License along with FMS. If not, see . !*********************************************************************** -!> @brief Converts a real number to a string -!> @return The real number as a string -function STRING_FROM_REAL_(r) - real(STRING_UTILS_KIND_), intent(in) :: r !< Real number to be converted to a string - character(:), allocatable :: STRING_FROM_REAL_ - character(32) :: s - - write(s, *) r - STRING_FROM_REAL_ = trim(adjustl(s)) -end function - !> @brief Converts a 1D array of real numbers to a string !> @return The 1D array as a string function STRING_FROM_ARRAY_1D_(arr) @@ -38,13 +27,13 @@ function STRING_FROM_ARRAY_1D_(arr) n = size(arr) if (n .gt. 0) then - STRING_FROM_ARRAY_1D_ = "[" // STRING_FROM_REAL_(arr(1)) + STRING_FROM_ARRAY_1D_ = "[" // string(arr(1)) else STRING_FROM_ARRAY_1D_ = "[" endif do i = 2,n - STRING_FROM_ARRAY_1D_ = STRING_FROM_ARRAY_1D_ // ", " // STRING_FROM_REAL_(arr(i)) + STRING_FROM_ARRAY_1D_ = STRING_FROM_ARRAY_1D_ // ", " // string(arr(i)) enddo STRING_FROM_ARRAY_1D_ = STRING_FROM_ARRAY_1D_ // "]" diff --git a/string_utils/include/fms_string_utils_r4.fh b/string_utils/include/fms_string_utils_r4.fh index 493eadacbf..161ccb1fd9 100644 --- a/string_utils/include/fms_string_utils_r4.fh +++ b/string_utils/include/fms_string_utils_r4.fh @@ -18,7 +18,6 @@ !*********************************************************************** #define STRING_UTILS_KIND_ r4_kind -#define STRING_FROM_REAL_ string_from_r4 #define STRING_FROM_ARRAY_1D_ string_from_array_1d_r4 #define STRING_FROM_ARRAY_2D_ string_from_array_2d_r4 #define STRING_FROM_ARRAY_3D_ string_from_array_3d_r4 @@ -26,7 +25,6 @@ #include "fms_string_utils.inc" #undef STRING_UTILS_KIND_ -#undef STRING_FROM_REAL_ #undef STRING_FROM_ARRAY_1D_ #undef STRING_FROM_ARRAY_2D_ #undef STRING_FROM_ARRAY_3D_ diff --git a/string_utils/include/fms_string_utils_r8.fh b/string_utils/include/fms_string_utils_r8.fh index ac03e94bfe..9a0a0af8f5 100644 --- a/string_utils/include/fms_string_utils_r8.fh +++ b/string_utils/include/fms_string_utils_r8.fh @@ -18,7 +18,6 @@ !*********************************************************************** #define STRING_UTILS_KIND_ r8_kind -#define STRING_FROM_REAL_ string_from_r8 #define STRING_FROM_ARRAY_1D_ string_from_array_1d_r8 #define STRING_FROM_ARRAY_2D_ string_from_array_2d_r8 #define STRING_FROM_ARRAY_3D_ string_from_array_3d_r8 @@ -26,7 +25,6 @@ #include "fms_string_utils.inc" #undef STRING_UTILS_KIND_ -#undef STRING_FROM_REAL_ #undef STRING_FROM_ARRAY_1D_ #undef STRING_FROM_ARRAY_2D_ #undef STRING_FROM_ARRAY_3D_ diff --git a/test_fms/string_utils/test_string_utils.F90 b/test_fms/string_utils/test_string_utils.F90 index ea456ebe52..b67f20c913 100644 --- a/test_fms/string_utils/test_string_utils.F90 +++ b/test_fms/string_utils/test_string_utils.F90 @@ -180,41 +180,41 @@ subroutine check_string call mpp_error(FATAL, "string() unit test failed for negative integer") endif - if (string(1.2345_r4_kind) .ne. "1.23450005") then + if (string(1._r4_kind) .ne. "1.0000000E+00") then call mpp_error(FATAL, "string() unit test failed for positive r4 real") endif - if (string(-1.2345_r4_kind) .ne. "-1.23450005") then + if (string(-1._r4_kind) .ne. "-1.0000000E+00") then call mpp_error(FATAL, "string() unit test failed for negative r4 real") endif - if (string(1.2345_r8_kind) .ne. "1.2344999999999999") then + if (string(1._r8_kind) .ne. "1.0000000000000000E+00") then call mpp_error(FATAL, "string() unit test failed for positive r8 real") endif - if (string(-1.2345_r8_kind) .ne. "-1.2344999999999999") then + if (string(-1._r8_kind) .ne. "-1.0000000000000000E+00") then call mpp_error(FATAL, "string() unit test failed for negative r8 real") endif arr_1d_r4 = [0._r4_kind, 1._r4_kind, 2._r4_kind] - if (string(arr_1d_r4) .ne. "[0.00000000, 1.00000000, 2.00000000]") then + if (string(arr_1d_r4) .ne. "[0.0000000E+00, 1.0000000E+00, 2.0000000E+00]") then call mpp_error(FATAL, "string() unit test failed for 1D r4 array") endif arr_1d_r8 = [0._r8_kind, 1._r8_kind, 2._r8_kind] - if (string(arr_1d_r8) .ne. "[0.0000000000000000, 1.0000000000000000, 2.0000000000000000]") then + if (string(arr_1d_r8) .ne. "[0.0000000000000000E+00, 1.0000000000000000E+00, 2.0000000000000000E+00]") then call mpp_error(FATAL, "string() unit test failed for 1D r8 array") endif arr_2d_r4 = reshape([[0._r4_kind, 1._r4_kind], [2._r4_kind, 3._r4_kind]], [2, 2]) if (string(arr_2d_r4) .ne. & - & "[[0.00000000, 1.00000000], [2.00000000, 3.00000000]]") then + & "[[0.0000000E+00, 1.0000000E+00], [2.0000000E+00, 3.0000000E+00]]") then call mpp_error(FATAL, "string() unit test failed for 2D r4 array") endif arr_2d_r8 = reshape([[0._r8_kind, 1._r8_kind], [2._r8_kind, 3._r8_kind]], [2, 2]) if (string(arr_2d_r8) .ne. & - & "[[0.0000000000000000, 1.0000000000000000], [2.0000000000000000, 3.0000000000000000]]") then + & "[[0.0000000000000000E+00, 1.0000000000000000E+00], [2.0000000000000000E+00, 3.0000000000000000E+00]]") then call mpp_error(FATAL, "string() unit test failed for 2D r8 array") endif @@ -223,8 +223,8 @@ subroutine check_string & [[4._r4_kind, 5._r4_kind], [6._r4_kind, 7._r4_kind]] & & ], [2, 2, 2]) if (string(arr_3d_r4) .ne. & - & "[[[0.00000000, 1.00000000], [2.00000000, 3.00000000]],& - & [[4.00000000, 5.00000000], [6.00000000, 7.00000000]]]") then + & "[[[0.0000000E+00, 1.0000000E+00], [2.0000000E+00, 3.0000000E+00]],& + & [[4.0000000E+00, 5.0000000E+00], [6.0000000E+00, 7.0000000E+00]]]") then call mpp_error(FATAL, "string() unit test failed for 3D r4 array") endif @@ -233,8 +233,8 @@ subroutine check_string & [[4._r8_kind, 5._r8_kind], [6._r8_kind, 7._r8_kind]] & & ], [2, 2, 2]) if (string(arr_3d_r8) .ne. & - & "[[[0.0000000000000000, 1.0000000000000000], [2.0000000000000000, 3.0000000000000000]],& - & [[4.0000000000000000, 5.0000000000000000], [6.0000000000000000, 7.0000000000000000]]]") then + & "[[[0.0000000000000000E+00, 1.0000000000000000E+00], [2.0000000000000000E+00, 3.0000000000000000E+00]],& + & [[4.0000000000000000E+00, 5.0000000000000000E+00], [6.0000000000000000E+00, 7.0000000000000000E+00]]]") then call mpp_error(FATAL, "string() unit test failed for 3D r8 array") endif end subroutine From 69d554e56cf4e9639193be0fba3537d29d508481 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Mon, 6 Mar 2023 09:51:53 -0500 Subject: [PATCH 09/15] string(): Add function for Boolean values Add a function for Boolean values to the `string` interface. Add three new test cases to the unit test. --- string_utils/fms_string_utils.F90 | 13 +++++++++++++ test_fms/string_utils/test_string_utils.F90 | 12 ++++++++++++ 2 files changed, 25 insertions(+) diff --git a/string_utils/fms_string_utils.F90 b/string_utils/fms_string_utils.F90 index 1748659e2d..f3bc8ba6c5 100644 --- a/string_utils/fms_string_utils.F90 +++ b/string_utils/fms_string_utils.F90 @@ -116,6 +116,7 @@ subroutine c_free(ptr) bind(c,name="free") !> Converts a number or a real array to a string !> @ingroup fms_mod interface string + module procedure string_from_logical module procedure string_from_integer module procedure string_from_r4, string_from_r8 module procedure string_from_array_1d_r4, string_from_array_1d_r8 @@ -241,6 +242,18 @@ subroutine fms_f2c_string (dest, str_in) enddo end subroutine fms_f2c_string + !> @brief Converts a Boolean value to a string + !> @return The Boolean value as a string + function string_from_logical(v) + logical, intent(in) :: v !< Boolean value to be converted to a string + character(:), allocatable :: string_from_logical + + if (v) then + string_from_logical = "True" + else + string_from_logical = "False" + endif + end function !> @brief Converts an integer to a string !> @return The integer as a string diff --git a/test_fms/string_utils/test_string_utils.F90 b/test_fms/string_utils/test_string_utils.F90 index b67f20c913..ee78901f97 100644 --- a/test_fms/string_utils/test_string_utils.F90 +++ b/test_fms/string_utils/test_string_utils.F90 @@ -172,6 +172,18 @@ subroutine check_string real(r4_kind) :: arr_1d_r4(3), arr_2d_r4(2, 2), arr_3d_r4(2, 2, 2) real(r8_kind) :: arr_1d_r8(3), arr_2d_r8(2, 2), arr_3d_r8(2, 2, 2) + if (string(.true.) .ne. "True") then + call mpp_error(FATAL, "string() unit test failed for Boolean true value") + endif + + if (string(.false.) .ne. "False") then + call mpp_error(FATAL, "string() unit test failed for Boolean false value") + endif + + if (string(0) .ne. "0") then + call mpp_error(FATAL, "string() unit test failed for zero integer") + endif + if (string(12345) .ne. "12345") then call mpp_error(FATAL, "string() unit test failed for positive integer") endif From dc808d4bc236c997589a45c36eaa7fdae6682d7f Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Mon, 6 Mar 2023 12:22:48 -0500 Subject: [PATCH 10/15] Create `stringify` interface Create a `stringify` interface in `fms_string_utils_mod`. Move the real array stringification functions from `string` to `stringify`. --- string_utils/fms_string_utils.F90 | 14 +++++--- string_utils/include/fms_string_utils.inc | 36 ++++++++++----------- string_utils/include/fms_string_utils_r4.fh | 12 +++---- string_utils/include/fms_string_utils_r8.fh | 12 +++---- test_fms/string_utils/test_string_utils.F90 | 33 ++++++++++--------- 5 files changed, 58 insertions(+), 49 deletions(-) diff --git a/string_utils/fms_string_utils.F90 b/string_utils/fms_string_utils.F90 index f3bc8ba6c5..de843e4d60 100644 --- a/string_utils/fms_string_utils.F90 +++ b/string_utils/fms_string_utils.F90 @@ -44,6 +44,7 @@ module fms_string_utils_mod public :: fms_cstring2cpointer public :: string public :: string_copy + public :: stringify !> @} interface @@ -113,15 +114,20 @@ subroutine c_free(ptr) bind(c,name="free") module procedure cpointer_fortran_conversion end interface -!> Converts a number or a real array to a string +!> Converts a number or a Boolean value to a string !> @ingroup fms_mod interface string module procedure string_from_logical module procedure string_from_integer module procedure string_from_r4, string_from_r8 - module procedure string_from_array_1d_r4, string_from_array_1d_r8 - module procedure string_from_array_2d_r4, string_from_array_2d_r8 - module procedure string_from_array_3d_r4, string_from_array_3d_r8 +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 diff --git a/string_utils/include/fms_string_utils.inc b/string_utils/include/fms_string_utils.inc index 153bd37a8a..c7dd4e0f33 100644 --- a/string_utils/include/fms_string_utils.inc +++ b/string_utils/include/fms_string_utils.inc @@ -19,66 +19,66 @@ !> @brief Converts a 1D array of real numbers to a string !> @return The 1D array as a string -function STRING_FROM_ARRAY_1D_(arr) +function STRINGIFY_1D_(arr) real(STRING_UTILS_KIND_), dimension(:), intent(in) :: arr - character(:), allocatable :: STRING_FROM_ARRAY_1D_ + character(:), allocatable :: STRINGIFY_1D_ integer :: i, n n = size(arr) if (n .gt. 0) then - STRING_FROM_ARRAY_1D_ = "[" // string(arr(1)) + STRINGIFY_1D_ = "[" // string(arr(1)) else - STRING_FROM_ARRAY_1D_ = "[" + STRINGIFY_1D_ = "[" endif do i = 2,n - STRING_FROM_ARRAY_1D_ = STRING_FROM_ARRAY_1D_ // ", " // string(arr(i)) + STRINGIFY_1D_ = STRINGIFY_1D_ // ", " // string(arr(i)) enddo - STRING_FROM_ARRAY_1D_ = STRING_FROM_ARRAY_1D_ // "]" + STRINGIFY_1D_ = STRINGIFY_1D_ // "]" end function !> @brief Converts a 2D array of real numbers to a string !> @return The 2D array as a string -function STRING_FROM_ARRAY_2D_(arr) +function STRINGIFY_2D_(arr) real(STRING_UTILS_KIND_), dimension(:,:), intent(in) :: arr - character(:), allocatable :: STRING_FROM_ARRAY_2D_ + character(:), allocatable :: STRINGIFY_2D_ integer :: i, n n = size(arr, 2) if (n .gt. 0) then - STRING_FROM_ARRAY_2D_ = "[" // STRING_FROM_ARRAY_1D_(arr(:,1)) + STRINGIFY_2D_ = "[" // STRINGIFY_1D_(arr(:,1)) else - STRING_FROM_ARRAY_2D_ = "[" + STRINGIFY_2D_ = "[" endif do i = 2,n - STRING_FROM_ARRAY_2D_ = STRING_FROM_ARRAY_2D_ // ", " // STRING_FROM_ARRAY_1D_(arr(:,i)) + STRINGIFY_2D_ = STRINGIFY_2D_ // ", " // STRINGIFY_1D_(arr(:,i)) enddo - STRING_FROM_ARRAY_2D_ = STRING_FROM_ARRAY_2D_ // "]" + STRINGIFY_2D_ = STRINGIFY_2D_ // "]" end function !> @brief Converts a 3D array of real numbers to a string !> @return The 3D array as a string -function STRING_FROM_ARRAY_3D_(arr) +function STRINGIFY_3D_(arr) real(STRING_UTILS_KIND_), dimension(:,:,:), intent(in) :: arr - character(:), allocatable :: STRING_FROM_ARRAY_3D_ + character(:), allocatable :: STRINGIFY_3D_ integer :: i, n n = size(arr, 3) if (n .gt. 0) then - STRING_FROM_ARRAY_3D_ = "[" // STRING_FROM_ARRAY_2D_(arr(:,:,1)) + STRINGIFY_3D_ = "[" // STRINGIFY_2D_(arr(:,:,1)) else - STRING_FROM_ARRAY_3D_ = "[" + STRINGIFY_3D_ = "[" endif do i = 2,n - STRING_FROM_ARRAY_3D_ = STRING_FROM_ARRAY_3D_ // ", " // STRING_FROM_ARRAY_2D_(arr(:,:,i)) + STRINGIFY_3D_ = STRINGIFY_3D_ // ", " // STRINGIFY_2D_(arr(:,:,i)) enddo - STRING_FROM_ARRAY_3D_ = STRING_FROM_ARRAY_3D_ // "]" + STRINGIFY_3D_ = STRINGIFY_3D_ // "]" end function diff --git a/string_utils/include/fms_string_utils_r4.fh b/string_utils/include/fms_string_utils_r4.fh index 161ccb1fd9..c12cb7e001 100644 --- a/string_utils/include/fms_string_utils_r4.fh +++ b/string_utils/include/fms_string_utils_r4.fh @@ -18,13 +18,13 @@ !*********************************************************************** #define STRING_UTILS_KIND_ r4_kind -#define STRING_FROM_ARRAY_1D_ string_from_array_1d_r4 -#define STRING_FROM_ARRAY_2D_ string_from_array_2d_r4 -#define STRING_FROM_ARRAY_3D_ string_from_array_3d_r4 +#define STRINGIFY_1D_ stringify_1d_r4 +#define STRINGIFY_2D_ stringify_2d_r4 +#define STRINGIFY_3D_ stringify_3d_r4 #include "fms_string_utils.inc" #undef STRING_UTILS_KIND_ -#undef STRING_FROM_ARRAY_1D_ -#undef STRING_FROM_ARRAY_2D_ -#undef STRING_FROM_ARRAY_3D_ +#undef STRINGIFY_1D_ +#undef STRINGIFY_2D_ +#undef STRINGIFY_3D_ diff --git a/string_utils/include/fms_string_utils_r8.fh b/string_utils/include/fms_string_utils_r8.fh index 9a0a0af8f5..4e40b1264a 100644 --- a/string_utils/include/fms_string_utils_r8.fh +++ b/string_utils/include/fms_string_utils_r8.fh @@ -18,13 +18,13 @@ !*********************************************************************** #define STRING_UTILS_KIND_ r8_kind -#define STRING_FROM_ARRAY_1D_ string_from_array_1d_r8 -#define STRING_FROM_ARRAY_2D_ string_from_array_2d_r8 -#define STRING_FROM_ARRAY_3D_ string_from_array_3d_r8 +#define STRINGIFY_1D_ stringify_1d_r8 +#define STRINGIFY_2D_ stringify_2d_r8 +#define STRINGIFY_3D_ stringify_3d_r8 #include "fms_string_utils.inc" #undef STRING_UTILS_KIND_ -#undef STRING_FROM_ARRAY_1D_ -#undef STRING_FROM_ARRAY_2D_ -#undef STRING_FROM_ARRAY_3D_ +#undef STRINGIFY_1D_ +#undef STRINGIFY_2D_ +#undef STRINGIFY_3D_ diff --git a/test_fms/string_utils/test_string_utils.F90 b/test_fms/string_utils/test_string_utils.F90 index ee78901f97..f39f0606dc 100644 --- a/test_fms/string_utils/test_string_utils.F90 +++ b/test_fms/string_utils/test_string_utils.F90 @@ -112,6 +112,7 @@ program test_fms_string_utils if (nunique .ne. 7) call mpp_error(FATAL, "The number of unique strings in your array is not correct") call check_string + call check_stringify call fms_end() @@ -169,9 +170,6 @@ subroutine check_my_indices(indices, ans, string) end subroutine check_my_indices subroutine check_string - real(r4_kind) :: arr_1d_r4(3), arr_2d_r4(2, 2), arr_3d_r4(2, 2, 2) - real(r8_kind) :: arr_1d_r8(3), arr_2d_r8(2, 2), arr_3d_r8(2, 2, 2) - if (string(.true.) .ne. "True") then call mpp_error(FATAL, "string() unit test failed for Boolean true value") endif @@ -207,47 +205,52 @@ subroutine check_string if (string(-1._r8_kind) .ne. "-1.0000000000000000E+00") then call mpp_error(FATAL, "string() unit test failed for negative r8 real") endif + end subroutine + + subroutine check_stringify + real(r4_kind) :: arr_1d_r4(3), arr_2d_r4(2, 2), arr_3d_r4(2, 2, 2) + real(r8_kind) :: arr_1d_r8(3), arr_2d_r8(2, 2), arr_3d_r8(2, 2, 2) arr_1d_r4 = [0._r4_kind, 1._r4_kind, 2._r4_kind] - if (string(arr_1d_r4) .ne. "[0.0000000E+00, 1.0000000E+00, 2.0000000E+00]") then - call mpp_error(FATAL, "string() unit test failed for 1D r4 array") + if (stringify(arr_1d_r4) .ne. "[0.0000000E+00, 1.0000000E+00, 2.0000000E+00]") then + call mpp_error(FATAL, "stringify() unit test failed for 1D r4 array") endif arr_1d_r8 = [0._r8_kind, 1._r8_kind, 2._r8_kind] - if (string(arr_1d_r8) .ne. "[0.0000000000000000E+00, 1.0000000000000000E+00, 2.0000000000000000E+00]") then - call mpp_error(FATAL, "string() unit test failed for 1D r8 array") + if (stringify(arr_1d_r8) .ne. "[0.0000000000000000E+00, 1.0000000000000000E+00, 2.0000000000000000E+00]") then + call mpp_error(FATAL, "stringify() unit test failed for 1D r8 array") endif arr_2d_r4 = reshape([[0._r4_kind, 1._r4_kind], [2._r4_kind, 3._r4_kind]], [2, 2]) - if (string(arr_2d_r4) .ne. & + if (stringify(arr_2d_r4) .ne. & & "[[0.0000000E+00, 1.0000000E+00], [2.0000000E+00, 3.0000000E+00]]") then - call mpp_error(FATAL, "string() unit test failed for 2D r4 array") + call mpp_error(FATAL, "stringify() unit test failed for 2D r4 array") endif arr_2d_r8 = reshape([[0._r8_kind, 1._r8_kind], [2._r8_kind, 3._r8_kind]], [2, 2]) - if (string(arr_2d_r8) .ne. & + if (stringify(arr_2d_r8) .ne. & & "[[0.0000000000000000E+00, 1.0000000000000000E+00], [2.0000000000000000E+00, 3.0000000000000000E+00]]") then - call mpp_error(FATAL, "string() unit test failed for 2D r8 array") + call mpp_error(FATAL, "stringify() unit test failed for 2D r8 array") endif arr_3d_r4 = reshape([ & & [[0._r4_kind, 1._r4_kind], [2._r4_kind, 3._r4_kind]], & & [[4._r4_kind, 5._r4_kind], [6._r4_kind, 7._r4_kind]] & & ], [2, 2, 2]) - if (string(arr_3d_r4) .ne. & + if (stringify(arr_3d_r4) .ne. & & "[[[0.0000000E+00, 1.0000000E+00], [2.0000000E+00, 3.0000000E+00]],& & [[4.0000000E+00, 5.0000000E+00], [6.0000000E+00, 7.0000000E+00]]]") then - call mpp_error(FATAL, "string() unit test failed for 3D r4 array") + call mpp_error(FATAL, "stringify() unit test failed for 3D r4 array") endif arr_3d_r8 = reshape([ & & [[0._r8_kind, 1._r8_kind], [2._r8_kind, 3._r8_kind]], & & [[4._r8_kind, 5._r8_kind], [6._r8_kind, 7._r8_kind]] & & ], [2, 2, 2]) - if (string(arr_3d_r8) .ne. & + if (stringify(arr_3d_r8) .ne. & & "[[[0.0000000000000000E+00, 1.0000000000000000E+00], [2.0000000000000000E+00, 3.0000000000000000E+00]],& & [[4.0000000000000000E+00, 5.0000000000000000E+00], [6.0000000000000000E+00, 7.0000000000000000E+00]]]") then - call mpp_error(FATAL, "string() unit test failed for 3D r8 array") + call mpp_error(FATAL, "stringify() unit test failed for 3D r8 array") endif end subroutine From 9370d6aef61dc3eb1a85653d5a6b1e78a1c9f8af Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Mon, 6 Mar 2023 18:29:09 -0500 Subject: [PATCH 11/15] Accept optional format string for reals Accept an optional format string as the second argument to `string_from_r4()`, `string_from_r8()`, and `stringify()`. If no format string is supplied, `*` is used. --- string_utils/fms_string_utils.F90 | 22 ----------- string_utils/include/fms_string_utils.inc | 44 +++++++++++++++------ string_utils/include/fms_string_utils_r4.fh | 2 + string_utils/include/fms_string_utils_r8.fh | 2 + test_fms/string_utils/test_string_utils.F90 | 32 +++++++-------- 5 files changed, 52 insertions(+), 50 deletions(-) diff --git a/string_utils/fms_string_utils.F90 b/string_utils/fms_string_utils.F90 index de843e4d60..6a8509c06d 100644 --- a/string_utils/fms_string_utils.F90 +++ b/string_utils/fms_string_utils.F90 @@ -272,28 +272,6 @@ function string_from_integer(i) result (res) return end function string_from_integer - !> @brief Converts a real number (r4_kind) to a string - !> @return The real number as a string - function string_from_r4(r) - real(r4_kind), intent(in) :: r !< Real number to be converted to a string - character(:), allocatable :: string_from_r4 - character(15) :: s - - write(s, "(ES15.7E2)") r - string_from_r4 = trim(adjustl(s)) - end function - - !> @brief Converts a real number (r8_kind) to a string - !> @return The real number as a string - function string_from_r8(r) - real(r8_kind), intent(in) :: r !< Real number to be converted to a string - character(:), allocatable :: string_from_r8 - character(25) :: s - - write(s, "(ES25.16E2)") r - string_from_r8 = trim(adjustl(s)) - end function - !> @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. diff --git a/string_utils/include/fms_string_utils.inc b/string_utils/include/fms_string_utils.inc index c7dd4e0f33..1d9e48803e 100644 --- a/string_utils/include/fms_string_utils.inc +++ b/string_utils/include/fms_string_utils.inc @@ -17,23 +17,41 @@ !* License along with FMS. If not, see . !*********************************************************************** +!> @brief Converts a real number to a string +!> @return The real number as a string +function STRING_FROM_REAL_(r, fmt) + real(STRING_UTILS_KIND_), intent(in) :: r !< Real number to be converted to a string + character(*), intent(in), optional :: fmt !< Optional format string for the real number + character(:), allocatable :: STRING_FROM_REAL_ + character(25) :: s + + if (present(fmt)) then + write(s, "(" // fmt // ")") r + else + write(s, *) r + endif + + STRING_FROM_REAL_ = trim(adjustl(s)) +end function + !> @brief Converts a 1D array of real numbers to a string !> @return The 1D array as a string -function STRINGIFY_1D_(arr) - real(STRING_UTILS_KIND_), dimension(:), intent(in) :: arr +function STRINGIFY_1D_(arr, fmt) + real(STRING_UTILS_KIND_), dimension(:), intent(in) :: arr !< Real array to be converted to a string + character(*), intent(in), optional :: fmt !< Optional format string for the real array entries character(:), allocatable :: STRINGIFY_1D_ integer :: i, n n = size(arr) if (n .gt. 0) then - STRINGIFY_1D_ = "[" // string(arr(1)) + STRINGIFY_1D_ = "[" // string(arr(1), fmt) else STRINGIFY_1D_ = "[" endif do i = 2,n - STRINGIFY_1D_ = STRINGIFY_1D_ // ", " // string(arr(i)) + STRINGIFY_1D_ = STRINGIFY_1D_ // ", " // string(arr(i), fmt) enddo STRINGIFY_1D_ = STRINGIFY_1D_ // "]" @@ -41,21 +59,22 @@ end function !> @brief Converts a 2D array of real numbers to a string !> @return The 2D array as a string -function STRINGIFY_2D_(arr) - real(STRING_UTILS_KIND_), dimension(:,:), intent(in) :: arr +function STRINGIFY_2D_(arr, fmt) + real(STRING_UTILS_KIND_), dimension(:,:), intent(in) :: arr !< Real array to be converted to a string + character(*), intent(in), optional :: fmt !< Optional format string for the real array entries character(:), allocatable :: STRINGIFY_2D_ integer :: i, n n = size(arr, 2) if (n .gt. 0) then - STRINGIFY_2D_ = "[" // STRINGIFY_1D_(arr(:,1)) + STRINGIFY_2D_ = "[" // STRINGIFY_1D_(arr(:,1), fmt) else STRINGIFY_2D_ = "[" endif do i = 2,n - STRINGIFY_2D_ = STRINGIFY_2D_ // ", " // STRINGIFY_1D_(arr(:,i)) + STRINGIFY_2D_ = STRINGIFY_2D_ // ", " // STRINGIFY_1D_(arr(:,i), fmt) enddo STRINGIFY_2D_ = STRINGIFY_2D_ // "]" @@ -63,21 +82,22 @@ end function !> @brief Converts a 3D array of real numbers to a string !> @return The 3D array as a string -function STRINGIFY_3D_(arr) - real(STRING_UTILS_KIND_), dimension(:,:,:), intent(in) :: arr +function STRINGIFY_3D_(arr, fmt) + real(STRING_UTILS_KIND_), dimension(:,:,:), intent(in) :: arr !< Real array to be converted to a string + character(*), intent(in), optional :: fmt !< Optional format string for the real array entries character(:), allocatable :: STRINGIFY_3D_ integer :: i, n n = size(arr, 3) if (n .gt. 0) then - STRINGIFY_3D_ = "[" // STRINGIFY_2D_(arr(:,:,1)) + STRINGIFY_3D_ = "[" // STRINGIFY_2D_(arr(:,:,1), fmt) else STRINGIFY_3D_ = "[" endif do i = 2,n - STRINGIFY_3D_ = STRINGIFY_3D_ // ", " // STRINGIFY_2D_(arr(:,:,i)) + STRINGIFY_3D_ = STRINGIFY_3D_ // ", " // STRINGIFY_2D_(arr(:,:,i), fmt) enddo STRINGIFY_3D_ = STRINGIFY_3D_ // "]" diff --git a/string_utils/include/fms_string_utils_r4.fh b/string_utils/include/fms_string_utils_r4.fh index c12cb7e001..ebb59fc6bb 100644 --- a/string_utils/include/fms_string_utils_r4.fh +++ b/string_utils/include/fms_string_utils_r4.fh @@ -18,6 +18,7 @@ !*********************************************************************** #define STRING_UTILS_KIND_ r4_kind +#define STRING_FROM_REAL_ string_from_r4 #define STRINGIFY_1D_ stringify_1d_r4 #define STRINGIFY_2D_ stringify_2d_r4 #define STRINGIFY_3D_ stringify_3d_r4 @@ -25,6 +26,7 @@ #include "fms_string_utils.inc" #undef STRING_UTILS_KIND_ +#undef STRING_FROM_REAL_ #undef STRINGIFY_1D_ #undef STRINGIFY_2D_ #undef STRINGIFY_3D_ diff --git a/string_utils/include/fms_string_utils_r8.fh b/string_utils/include/fms_string_utils_r8.fh index 4e40b1264a..35f6e3d38e 100644 --- a/string_utils/include/fms_string_utils_r8.fh +++ b/string_utils/include/fms_string_utils_r8.fh @@ -18,6 +18,7 @@ !*********************************************************************** #define STRING_UTILS_KIND_ r8_kind +#define STRING_FROM_REAL_ string_from_r8 #define STRINGIFY_1D_ stringify_1d_r8 #define STRINGIFY_2D_ stringify_2d_r8 #define STRINGIFY_3D_ stringify_3d_r8 @@ -25,6 +26,7 @@ #include "fms_string_utils.inc" #undef STRING_UTILS_KIND_ +#undef STRING_FROM_REAL_ #undef STRINGIFY_1D_ #undef STRINGIFY_2D_ #undef STRINGIFY_3D_ diff --git a/test_fms/string_utils/test_string_utils.F90 b/test_fms/string_utils/test_string_utils.F90 index f39f0606dc..23e41de7f8 100644 --- a/test_fms/string_utils/test_string_utils.F90 +++ b/test_fms/string_utils/test_string_utils.F90 @@ -190,19 +190,19 @@ subroutine check_string call mpp_error(FATAL, "string() unit test failed for negative integer") endif - if (string(1._r4_kind) .ne. "1.0000000E+00") then + if (string(1._r4_kind, "F15.7") .ne. "1.0000000") then call mpp_error(FATAL, "string() unit test failed for positive r4 real") endif - if (string(-1._r4_kind) .ne. "-1.0000000E+00") then + if (string(-1._r4_kind, "F15.7") .ne. "-1.0000000") then call mpp_error(FATAL, "string() unit test failed for negative r4 real") endif - if (string(1._r8_kind) .ne. "1.0000000000000000E+00") then + if (string(1._r8_kind, "F25.16") .ne. "1.0000000000000000") then call mpp_error(FATAL, "string() unit test failed for positive r8 real") endif - if (string(-1._r8_kind) .ne. "-1.0000000000000000E+00") then + if (string(-1._r8_kind, "F25.16") .ne. "-1.0000000000000000") then call mpp_error(FATAL, "string() unit test failed for negative r8 real") endif end subroutine @@ -212,24 +212,24 @@ subroutine check_stringify real(r8_kind) :: arr_1d_r8(3), arr_2d_r8(2, 2), arr_3d_r8(2, 2, 2) arr_1d_r4 = [0._r4_kind, 1._r4_kind, 2._r4_kind] - if (stringify(arr_1d_r4) .ne. "[0.0000000E+00, 1.0000000E+00, 2.0000000E+00]") then + if (stringify(arr_1d_r4, "F15.7") .ne. "[0.0000000, 1.0000000, 2.0000000]") then call mpp_error(FATAL, "stringify() unit test failed for 1D r4 array") endif arr_1d_r8 = [0._r8_kind, 1._r8_kind, 2._r8_kind] - if (stringify(arr_1d_r8) .ne. "[0.0000000000000000E+00, 1.0000000000000000E+00, 2.0000000000000000E+00]") then + if (stringify(arr_1d_r8, "F25.16") .ne. "[0.0000000000000000, 1.0000000000000000, 2.0000000000000000]") then call mpp_error(FATAL, "stringify() unit test failed for 1D r8 array") endif arr_2d_r4 = reshape([[0._r4_kind, 1._r4_kind], [2._r4_kind, 3._r4_kind]], [2, 2]) - if (stringify(arr_2d_r4) .ne. & - & "[[0.0000000E+00, 1.0000000E+00], [2.0000000E+00, 3.0000000E+00]]") then + if (stringify(arr_2d_r4, "F15.7") .ne. & + & "[[0.0000000, 1.0000000], [2.0000000, 3.0000000]]") then call mpp_error(FATAL, "stringify() unit test failed for 2D r4 array") endif arr_2d_r8 = reshape([[0._r8_kind, 1._r8_kind], [2._r8_kind, 3._r8_kind]], [2, 2]) - if (stringify(arr_2d_r8) .ne. & - & "[[0.0000000000000000E+00, 1.0000000000000000E+00], [2.0000000000000000E+00, 3.0000000000000000E+00]]") then + if (stringify(arr_2d_r8, "F25.16") .ne. & + & "[[0.0000000000000000, 1.0000000000000000], [2.0000000000000000, 3.0000000000000000]]") then call mpp_error(FATAL, "stringify() unit test failed for 2D r8 array") endif @@ -237,9 +237,9 @@ subroutine check_stringify & [[0._r4_kind, 1._r4_kind], [2._r4_kind, 3._r4_kind]], & & [[4._r4_kind, 5._r4_kind], [6._r4_kind, 7._r4_kind]] & & ], [2, 2, 2]) - if (stringify(arr_3d_r4) .ne. & - & "[[[0.0000000E+00, 1.0000000E+00], [2.0000000E+00, 3.0000000E+00]],& - & [[4.0000000E+00, 5.0000000E+00], [6.0000000E+00, 7.0000000E+00]]]") then + if (stringify(arr_3d_r4, "F15.7") .ne. & + & "[[[0.0000000, 1.0000000], [2.0000000, 3.0000000]],& + & [[4.0000000, 5.0000000], [6.0000000, 7.0000000]]]") then call mpp_error(FATAL, "stringify() unit test failed for 3D r4 array") endif @@ -247,9 +247,9 @@ subroutine check_stringify & [[0._r8_kind, 1._r8_kind], [2._r8_kind, 3._r8_kind]], & & [[4._r8_kind, 5._r8_kind], [6._r8_kind, 7._r8_kind]] & & ], [2, 2, 2]) - if (stringify(arr_3d_r8) .ne. & - & "[[[0.0000000000000000E+00, 1.0000000000000000E+00], [2.0000000000000000E+00, 3.0000000000000000E+00]],& - & [[4.0000000000000000E+00, 5.0000000000000000E+00], [6.0000000000000000E+00, 7.0000000000000000E+00]]]") then + if (stringify(arr_3d_r8, "F25.16") .ne. & + & "[[[0.0000000000000000, 1.0000000000000000], [2.0000000000000000, 3.0000000000000000]],& + & [[4.0000000000000000, 5.0000000000000000], [6.0000000000000000, 7.0000000000000000]]]") then call mpp_error(FATAL, "stringify() unit test failed for 3D r8 array") endif end subroutine From 6ecd9c73b91d9d66796007a5432724648058ca03 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Tue, 7 Mar 2023 10:34:48 -0500 Subject: [PATCH 12/15] string(): Increase length of temporary string Increase the length of the temporary string in `string_from_r4`/`string_from_r8` from 25 to 32 characters. --- string_utils/include/fms_string_utils.inc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/string_utils/include/fms_string_utils.inc b/string_utils/include/fms_string_utils.inc index 1d9e48803e..3c62c641d6 100644 --- a/string_utils/include/fms_string_utils.inc +++ b/string_utils/include/fms_string_utils.inc @@ -23,7 +23,7 @@ function STRING_FROM_REAL_(r, fmt) real(STRING_UTILS_KIND_), intent(in) :: r !< Real number to be converted to a string character(*), intent(in), optional :: fmt !< Optional format string for the real number character(:), allocatable :: STRING_FROM_REAL_ - character(25) :: s + character(32) :: s if (present(fmt)) then write(s, "(" // fmt // ")") r From 9aec801e6d325453b9691ac50d0d86aa2ec2ad02 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Wed, 8 Mar 2023 13:22:01 -0500 Subject: [PATCH 13/15] Use `class(*)` for `string()` --- string_utils/fms_string_utils.F90 | 74 ++++++++++++--------- string_utils/include/fms_string_utils.inc | 17 ----- string_utils/include/fms_string_utils_r4.fh | 2 - string_utils/include/fms_string_utils_r8.fh | 2 - 4 files changed, 44 insertions(+), 51 deletions(-) diff --git a/string_utils/fms_string_utils.F90 b/string_utils/fms_string_utils.F90 index 6a8509c06d..427162d2d2 100644 --- a/string_utils/fms_string_utils.F90 +++ b/string_utils/fms_string_utils.F90 @@ -114,14 +114,6 @@ subroutine c_free(ptr) bind(c,name="free") module procedure cpointer_fortran_conversion end interface -!> Converts a number or a Boolean value to a string -!> @ingroup fms_mod -interface string - module procedure string_from_logical - module procedure string_from_integer - module procedure string_from_r4, string_from_r8 -end interface - !> Converts an array of real numbers to a string !> @ingroup fms_mod interface stringify @@ -248,30 +240,52 @@ subroutine fms_f2c_string (dest, str_in) enddo end subroutine fms_f2c_string - !> @brief Converts a Boolean value to a string - !> @return The Boolean value as a string - function string_from_logical(v) - logical, intent(in) :: v !< Boolean value to be converted to a string - character(:), allocatable :: string_from_logical - - if (v) then - string_from_logical = "True" - else - string_from_logical = "False" - endif + !> @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 argument + character(:), allocatable :: string + + select type(v) + type is (logical) + if (v) then + string = "True" + else + string = "False" + endif + + type is (integer) + allocate(character(32) :: string) + write(string, '(i0)') v + 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)) + + type is (character(*)) + string = v + + class default + call mpp_error(FATAL, "string() called with incompatible argument") + end select end function - !> @brief Converts an integer to a string - !> @return The integer as a string - function string_from_integer(i) result (res) - integer, intent(in) :: i !< Integer to be converted to a string - character(:),allocatable :: res !< String converted frominteger - character(range(i)+2) :: tmp !< Temp string that is set to correct size - write(tmp,'(i0)') i - res = trim(tmp) - return - end function string_from_integer - !> @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. diff --git a/string_utils/include/fms_string_utils.inc b/string_utils/include/fms_string_utils.inc index 3c62c641d6..db6e067c4f 100644 --- a/string_utils/include/fms_string_utils.inc +++ b/string_utils/include/fms_string_utils.inc @@ -17,23 +17,6 @@ !* License along with FMS. If not, see . !*********************************************************************** -!> @brief Converts a real number to a string -!> @return The real number as a string -function STRING_FROM_REAL_(r, fmt) - real(STRING_UTILS_KIND_), intent(in) :: r !< Real number to be converted to a string - character(*), intent(in), optional :: fmt !< Optional format string for the real number - character(:), allocatable :: STRING_FROM_REAL_ - character(32) :: s - - if (present(fmt)) then - write(s, "(" // fmt // ")") r - else - write(s, *) r - endif - - STRING_FROM_REAL_ = trim(adjustl(s)) -end function - !> @brief Converts a 1D array of real numbers to a string !> @return The 1D array as a string function STRINGIFY_1D_(arr, fmt) diff --git a/string_utils/include/fms_string_utils_r4.fh b/string_utils/include/fms_string_utils_r4.fh index ebb59fc6bb..c12cb7e001 100644 --- a/string_utils/include/fms_string_utils_r4.fh +++ b/string_utils/include/fms_string_utils_r4.fh @@ -18,7 +18,6 @@ !*********************************************************************** #define STRING_UTILS_KIND_ r4_kind -#define STRING_FROM_REAL_ string_from_r4 #define STRINGIFY_1D_ stringify_1d_r4 #define STRINGIFY_2D_ stringify_2d_r4 #define STRINGIFY_3D_ stringify_3d_r4 @@ -26,7 +25,6 @@ #include "fms_string_utils.inc" #undef STRING_UTILS_KIND_ -#undef STRING_FROM_REAL_ #undef STRINGIFY_1D_ #undef STRINGIFY_2D_ #undef STRINGIFY_3D_ diff --git a/string_utils/include/fms_string_utils_r8.fh b/string_utils/include/fms_string_utils_r8.fh index 35f6e3d38e..4e40b1264a 100644 --- a/string_utils/include/fms_string_utils_r8.fh +++ b/string_utils/include/fms_string_utils_r8.fh @@ -18,7 +18,6 @@ !*********************************************************************** #define STRING_UTILS_KIND_ r8_kind -#define STRING_FROM_REAL_ string_from_r8 #define STRINGIFY_1D_ stringify_1d_r8 #define STRINGIFY_2D_ stringify_2d_r8 #define STRINGIFY_3D_ stringify_3d_r8 @@ -26,7 +25,6 @@ #include "fms_string_utils.inc" #undef STRING_UTILS_KIND_ -#undef STRING_FROM_REAL_ #undef STRINGIFY_1D_ #undef STRINGIFY_2D_ #undef STRINGIFY_3D_ From 16356ac2db33547a523befbeb1883caad680ba33 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Wed, 8 Mar 2023 14:50:46 -0500 Subject: [PATCH 14/15] Address Tom's review comments --- string_utils/fms_string_utils.F90 | 34 ++++++++++++++++++++++--------- 1 file changed, 24 insertions(+), 10 deletions(-) diff --git a/string_utils/fms_string_utils.F90 b/string_utils/fms_string_utils.F90 index 427162d2d2..78d086f571 100644 --- a/string_utils/fms_string_utils.F90 +++ b/string_utils/fms_string_utils.F90 @@ -28,7 +28,7 @@ !> @{ module fms_string_utils_mod use, intrinsic :: iso_c_binding - use platform_mod, only: r4_kind, r8_kind + use platform_mod, only: r4_kind, r8_kind, i4_kind, i8_kind use mpp_mod implicit none @@ -243,21 +243,37 @@ 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 argument + 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) + type is (integer(i4_kind)) allocate(character(32) :: string) - write(string, '(i0)') v + 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)) @@ -278,13 +294,11 @@ function string(v, fmt) endif string = trim(adjustl(string)) - type is (character(*)) - string = v - class default - call mpp_error(FATAL, "string() called with incompatible argument") + 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 + end function string !> @brief Safely copy a string from one buffer to another. subroutine string_copy(dest, source, check_for_null) From 22ae59127d0a632064a800f3445df3867550e499 Mon Sep 17 00:00:00 2001 From: Jesse Lentz Date: Wed, 8 Mar 2023 15:26:05 -0500 Subject: [PATCH 15/15] Add test cases for integer(8) arguments --- test_fms/string_utils/test_string_utils.F90 | 26 ++++++++++++--------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/test_fms/string_utils/test_string_utils.F90 b/test_fms/string_utils/test_string_utils.F90 index 23e41de7f8..41d4923c71 100644 --- a/test_fms/string_utils/test_string_utils.F90 +++ b/test_fms/string_utils/test_string_utils.F90 @@ -22,7 +22,7 @@ program test_fms_string_utils use fms_string_utils_mod use fms_mod, only: fms_init, fms_end - use platform_mod, only: r4_kind, r8_kind + use platform_mod, only: r4_kind, r8_kind, i4_kind, i8_kind use mpp_mod use, intrinsic :: iso_c_binding @@ -178,32 +178,36 @@ subroutine check_string call mpp_error(FATAL, "string() unit test failed for Boolean false value") endif - if (string(0) .ne. "0") then - call mpp_error(FATAL, "string() unit test failed for zero integer") + if (string(12345_i4_kind) .ne. "12345") then + call mpp_error(FATAL, "string() unit test failed for positive integer(4)") endif - if (string(12345) .ne. "12345") then - call mpp_error(FATAL, "string() unit test failed for positive integer") + if (string(-12345_i4_kind) .ne. "-12345") then + call mpp_error(FATAL, "string() unit test failed for negative integer(4)") endif - if (string(-12345) .ne. "-12345") then - call mpp_error(FATAL, "string() unit test failed for negative integer") + if (string(12345_i8_kind) .ne. "12345") then + call mpp_error(FATAL, "string() unit test failed for positive integer(8)") + endif + + if (string(-12345_i8_kind) .ne. "-12345") then + call mpp_error(FATAL, "string() unit test failed for negative integer(8)") endif if (string(1._r4_kind, "F15.7") .ne. "1.0000000") then - call mpp_error(FATAL, "string() unit test failed for positive r4 real") + call mpp_error(FATAL, "string() unit test failed for positive real(4)") endif if (string(-1._r4_kind, "F15.7") .ne. "-1.0000000") then - call mpp_error(FATAL, "string() unit test failed for negative r4 real") + call mpp_error(FATAL, "string() unit test failed for negative real(4)") endif if (string(1._r8_kind, "F25.16") .ne. "1.0000000000000000") then - call mpp_error(FATAL, "string() unit test failed for positive r8 real") + call mpp_error(FATAL, "string() unit test failed for positive real(8)") endif if (string(-1._r8_kind, "F25.16") .ne. "-1.0000000000000000") then - call mpp_error(FATAL, "string() unit test failed for negative r8 real") + call mpp_error(FATAL, "string() unit test failed for negative real(8)") endif end subroutine