From 9b83c8c4fd5deab29aac1741fc3ad4d7342612ea Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Thu, 9 Mar 2023 15:44:20 -0500 Subject: [PATCH 1/7] fix - gnu and pgi issue with class(*) in send_data3d (#1149) --- diag_manager/diag_manager.F90 | 46 ++++++++++++++++++++++++++--------- 1 file changed, 35 insertions(+), 11 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index e78ee3e6f9..828d267c56 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1315,7 +1315,7 @@ LOGICAL FUNCTION send_data_0d(diag_field_id, field, time, err_msg) & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT - send_data_0d = send_data_3d(diag_field_id, field_out, time, err_msg=err_msg) + send_data_0d = diag_send_data(diag_field_id, field_out, time, err_msg=err_msg) END FUNCTION send_data_0d !> @return true if send is successful @@ -1370,18 +1370,18 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN - send_data_1d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& + send_data_1d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& & mask=mask_out, ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg) ELSE - send_data_1d = send_data_3d(diag_field_id, field_out, time, mask=mask_out,& + send_data_1d = diag_send_data(diag_field_id, field_out, time, mask=mask_out,& & weight=weight, err_msg=err_msg) END IF ELSE IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN - send_data_1d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& + send_data_1d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& & ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg) ELSE - send_data_1d = send_data_3d(diag_field_id, field_out, time, weight=weight, err_msg=err_msg) + send_data_1d = diag_send_data(diag_field_id, field_out, time, weight=weight, err_msg=err_msg) END IF END IF END FUNCTION send_data_1d @@ -1438,10 +1438,10 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & END IF IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN - send_data_2d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1, mask=mask_out,& - & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) + send_data_2d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,& + & mask=mask_out, ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) ELSE - send_data_2d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,& + send_data_2d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,& & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) END IF END FUNCTION send_data_2d @@ -1454,6 +1454,30 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CLASS(*), INTENT(in), OPTIONAL :: weight TYPE (time_type), INTENT(in), OPTIONAL :: time INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in + LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask + CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg + + if (present(mask) .and. present(rmask)) then + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + mask=mask, rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, & + err_msg=err_msg) + elseif (present(rmask)) then + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) + else + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) + endif + END FUNCTION send_data_3d + !> @return true if send is successful + LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, & + & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) + INTEGER, INTENT(in) :: diag_field_id + CLASS(*), DIMENSION(:,:,:), INTENT(in) :: field + CLASS(*), INTENT(in), OPTIONAL :: weight + TYPE (time_type), INTENT(in), OPTIONAL :: time + INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL, contiguous, target :: mask CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg @@ -1503,10 +1527,10 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN - send_data_3d = .FALSE. + diag_send_data = .FALSE. RETURN ELSE - send_data_3d = .TRUE. + diag_send_data = .TRUE. END IF IF ( PRESENT(err_msg) ) err_msg = '' @@ -3219,7 +3243,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & DEALLOCATE(field_out) DEALLOCATE(oor_mask) - END FUNCTION send_data_3d + END FUNCTION diag_send_data !> @return true if send is successful LOGICAL FUNCTION send_tile_averaged_data1d ( id, field, area, time, mask ) From 9339b88d9fe1afe75913d6b820c8249019ab0efd Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Thu, 9 Mar 2023 15:45:52 -0500 Subject: [PATCH 2/7] feat: extend `string` interface in `fms_string_utils_mod` (#1142) --- CMakeLists.txt | 2 + string_utils/Makefile.am | 5 +- string_utils/fms_string_utils.F90 | 98 +++++++++++++++------ string_utils/include/fms_string_utils.inc | 87 ++++++++++++++++++ string_utils/include/fms_string_utils_r4.fh | 30 +++++++ string_utils/include/fms_string_utils_r8.fh | 30 +++++++ test_fms/string_utils/test_string_utils.F90 | 93 +++++++++++++++++++ 7 files changed, 315 insertions(+), 30 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/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 ca0c3ab5ef..408c5eea7a 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. @@ -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 = \ diff --git a/string_utils/fms_string_utils.F90 b/string_utils/fms_string_utils.F90 index cf2dcd0376..78d086f571 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, i4_kind, i8_kind use mpp_mod implicit none @@ -43,6 +44,7 @@ module fms_string_utils_mod public :: fms_cstring2cpointer public :: string public :: string_copy + public :: stringify !> @} interface @@ -112,11 +114,12 @@ subroutine c_free(ptr) bind(c,name="free") module procedure cpointer_fortran_conversion end interface -!> Converts a number to a string +!> Converts an array of real numbers to a string !> @ingroup fms_mod -interface string - module procedure string_from_integer - module procedure string_from_real +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 @@ -237,31 +240,65 @@ subroutine fms_f2c_string (dest, str_in) enddo end subroutine fms_f2c_string - - !> @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 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 Converts a number or a Boolean value to a string + !> @return The argument as a string + function string(v, fmt) + class(*), intent(in) :: v !< Value to be converted to a string + character(*), intent(in), optional :: fmt !< Optional format string for a real or integral argument + character(:), allocatable :: string + + select type(v) + type is (logical) + if (present(fmt)) then + call mpp_error(WARNING, "string(): Ignoring `fmt` argument for type `logical`") + endif + if (v) then + string = "True" + else + string = "False" + endif + + type is (integer(i4_kind)) + allocate(character(32) :: string) + if (present(fmt)) then + write(string, "(" // fmt // ")") v + else + write(string, '(i0)') v + endif + string = trim(adjustl(string)) + + type is (integer(i8_kind)) + allocate(character(32) :: string) + if (present(fmt)) then + write(string, "(" // fmt // ")") v + else + write(string, '(i0)') v + endif + string = trim(adjustl(string)) + + type is (real(r4_kind)) + allocate(character(32) :: string) + if (present(fmt)) then + write(string, "(" // fmt // ")") v + else + write(string, *) v + endif + string = trim(adjustl(string)) + + type is (real(r8_kind)) + allocate(character(32) :: string) + if (present(fmt)) then + write(string, "(" // fmt // ")") v + else + write(string, *) v + endif + string = trim(adjustl(string)) + + class default + call mpp_error(FATAL, "string(): Called with incompatible argument type. Possible types & + &include integer(4), integer(8), real(4), real(8), or logical.") + end select + end function string !> @brief Safely copy a string from one buffer to another. subroutine string_copy(dest, source, check_for_null) @@ -290,6 +327,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..db6e067c4f --- /dev/null +++ b/string_utils/include/fms_string_utils.inc @@ -0,0 +1,87 @@ +!*********************************************************************** +!* 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 1D array of real numbers to a string +!> @return The 1D array as a string +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), fmt) + else + STRINGIFY_1D_ = "[" + endif + + do i = 2,n + STRINGIFY_1D_ = STRINGIFY_1D_ // ", " // string(arr(i), fmt) + enddo + + 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 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), fmt) + else + STRINGIFY_2D_ = "[" + endif + + do i = 2,n + STRINGIFY_2D_ = STRINGIFY_2D_ // ", " // STRINGIFY_1D_(arr(:,i), fmt) + enddo + + 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 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), fmt) + else + STRINGIFY_3D_ = "[" + endif + + do i = 2,n + STRINGIFY_3D_ = STRINGIFY_3D_ // ", " // STRINGIFY_2D_(arr(:,:,i), fmt) + enddo + + 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 new file mode 100644 index 0000000000..c12cb7e001 --- /dev/null +++ b/string_utils/include/fms_string_utils_r4.fh @@ -0,0 +1,30 @@ +!*********************************************************************** +!* 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 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 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 new file mode 100644 index 0000000000..4e40b1264a --- /dev/null +++ b/string_utils/include/fms_string_utils_r8.fh @@ -0,0 +1,30 @@ +!*********************************************************************** +!* 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 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 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 ff9f51ec4e..41d4923c71 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, i4_kind, i8_kind use mpp_mod use, intrinsic :: iso_c_binding @@ -110,6 +111,9 @@ 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 check_stringify + call fms_end() deallocate(my_array) @@ -165,4 +169,93 @@ subroutine check_my_indices(indices, ans, string) end do end subroutine check_my_indices + subroutine check_string + 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(12345_i4_kind) .ne. "12345") then + call mpp_error(FATAL, "string() unit test failed for positive integer(4)") + endif + + if (string(-12345_i4_kind) .ne. "-12345") then + call mpp_error(FATAL, "string() unit test failed for negative integer(4)") + endif + + 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 real(4)") + endif + + if (string(-1._r4_kind, "F15.7") .ne. "-1.0000000") then + 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 real(8)") + endif + + if (string(-1._r8_kind, "F25.16") .ne. "-1.0000000000000000") then + call mpp_error(FATAL, "string() unit test failed for negative real(8)") + 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 (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, "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, "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, "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 + + 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 (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 + + 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 (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 + end program test_fms_string_utils From 0ff254e409b74d7d17ab234abe5ecd985967256c Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Thu, 9 Mar 2023 15:47:47 -0500 Subject: [PATCH 3/7] fix: add omp directives for race condition in tridiagonal (#1109) --- tridiagonal/tridiagonal.F90 | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/tridiagonal/tridiagonal.F90 b/tridiagonal/tridiagonal.F90 index 3aaddf070c..c22f99c4ee 100644 --- a/tridiagonal/tridiagonal.F90 +++ b/tridiagonal/tridiagonal.F90 @@ -89,8 +89,10 @@ subroutine tri_invert(x,d,a,b,c) integer :: k if(present(a)) then - init_tridiagonal = .true. + !< Check if module variables are allocated + !$OMP SINGLE + init_tridiagonal = .true. if(allocated(e)) deallocate(e) if(allocated(g)) deallocate(g) if(allocated(bb)) deallocate(bb) @@ -99,6 +101,7 @@ subroutine tri_invert(x,d,a,b,c) allocate(g (size(x,1),size(x,2),size(x,3))) allocate(bb(size(x,1),size(x,2))) allocate(cc(size(x,1),size(x,2),size(x,3))) + !$OMP END SINGLE !< There is an implicit barrier. e(:,:,1) = - a(:,:,1)/b(:,:,1) a(:,:,size(x,3)) = 0.0 @@ -132,12 +135,15 @@ end subroutine tri_invert !> @brief Releases memory used by the solver subroutine close_tridiagonal -implicit none + implicit none -deallocate(e) -deallocate(g) -deallocate(bb) -deallocate(cc) + !< Check if module variables are allocated + !$OMP SINGLE + if(allocated(e)) deallocate(e) + if(allocated(g)) deallocate(g) + if(allocated(bb)) deallocate(bb) + if(allocated(cc)) deallocate(cc) + !$OMP END SINGLE !< There is an implicit barrier. return end subroutine close_tridiagonal From 63626578cb8ed4bed1ce670b88acd6a1ec438e32 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Mon, 13 Mar 2023 10:22:06 -0400 Subject: [PATCH 4/7] fix: missing if statement in PR #1149 (#1155) --- diag_manager/diag_manager.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 828d267c56..92fdf0e122 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1465,6 +1465,9 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & elseif (present(rmask)) then send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) + elseif (present(mask)) then + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + mask=mask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) else send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) From 7188e3a2e634376da74c3e4247bc9b487ef52700 Mon Sep 17 00:00:00 2001 From: MiKyung Lee <58964324+mlee03@users.noreply.github.com> Date: Tue, 28 Mar 2023 08:54:27 -0400 Subject: [PATCH 5/7] fix: time_manager missing changes from year to yr, month to mo, day to dy (#1169) --- time_interp/time_interp.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/time_interp/time_interp.F90 b/time_interp/time_interp.F90 index 83cacec3f4..87e146714a 100644 --- a/time_interp/time_interp.F90 +++ b/time_interp/time_interp.F90 @@ -391,7 +391,7 @@ subroutine time_interp_month ( Time, weight, year1, year2, month1, month2 ) ! mid point of current month in seconds mid_month = days_in_month(Time) * halfday ! time into current month in seconds - cur_month = second + secmin*minute + sechour*hour + secday*(day-1) + cur_month = second + secmin*minute + sechour*hour + secday*(dy-1) if ( cur_month >= mid_month ) then ! current time is after mid point of current month @@ -466,8 +466,8 @@ subroutine time_interp_day ( Time, weight, year1, year2, month1, month2, day1, d endif else ! current time is before mid point of day - year2 = year; month2 = month; day2 = day - year1 = year; month1 = month; day1 = day - 1 + year2 = yr; month2 = mo ; day2 = dy + year1 = yr; month1 = mo; day1 = dy - 1 weight = real(sday + halfday) / real(secday) if (day1 < 1) then From 8a78face399bca9b121e3f94c0389d43d8cf39aa Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Mon, 3 Apr 2023 14:31:20 -0400 Subject: [PATCH 6/7] chore: update changelog and version numbers for release (#1167) --- CHANGELOG.md | 37 +++++++++++++++++++++++++++++++++++++ CMakeLists.txt | 2 +- configure.ac | 2 +- libFMS/Makefile.am | 2 +- 4 files changed, 40 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 67752821b4..55522567bb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,43 @@ and this project uses `yyyy.rr[.pp]`, where `yyyy` is the year a patch is releas `rr` is a sequential release number (starting from `01`), and an optional two-digit sequential patch number (starting from `01`). +## [2023.01] - 2023-04-03 +### Known Issues +- If using GCC 10 or higher as well as MPICH, compilation errors will occur unless `-fallow-argument-mismatch` is included in the Fortran compiler flags(the flag will now be added automatically if building with autotools or CMake). +- GCC 11.1.0 is unsupported due to compilation issues with select type. The issue is resolved in later GCC releases. +- When outputting sub-region diagnostics, the current diag_manager does not add "tileX" to the filename when using a cube sphere. This leads to trouble when trying to combine the files and regrid them (if the region is in two different tiles) + +### Added +- DIAG_MANAGER: Added code refactored as part of larger diag_manager rewrite for the send_data routines. The refactored code is disabled by default and enabled by setting `use_refactored_send` to true in the diag_manager_nml, and should mirror current behaviour. +- FMS2_IO: Added the ability to set deflate_level and shuffle netcdf options in `fms2_io_nml`. Also added functionality for registering dimensions as unlimited compressed. +- YAML_PARSER: Added support for emitting multiple tabbed section keys to allow diag manager yaml output + +### Changed +- STRING_UTILS: Extended the `string` interface in fms_string_utils_mod to accept reals of 4 or 8 kind, as well as 1, 2, and 3 dimensional real arrays +- DIAG_MANAGER: Changed the `log_diag_field_info` routine to allow for specifying seperator +- INTERPOLATOR(s): In horiz_interp, amip_interp and interpolator, changed pointers arrays into allocatables + +### Fixed +- TRIDIAGONAL: Added OMP directives to prevent race conditions +- DIAG_MANAGER: Added `diag_send_data` routine to fix class(\*) related compiler issues from the refactor update +- SAT_VAPOR_PRES_K: Removed implied saves causing issues with class(\*) type checking +- TIME_INTERP: Fixed naming conflicts between module level and local variables +- YAML_PARSER: Fixed typo in variable name, rename variables to avoid fortran keywords +- DOCS: Fixed incorrect serial build instructions +- COMPILER SUPPORT: Fixed compilation errors with Intel's llvm-based compiler and added support for the CMake build. Also fixed mpp_checksum unit test failures with openmpi and nvhpc compilation issues. +- TIME_MANAGER: Fixed an bug from PR #1169 that was causing answer changes in land models + +### Tag Commit Hashes +- 2023.01-beta4 (63626578cb8ed4bed1ce670b88acd6a1ec438e32) +- 2023.01-beta3 (0ff254e409b74d7d17ab234abe5ecd985967256c) +- 2023.01-beta2 (74d8e734bd43b0ce043003da74896e5d747afc2f) +- 2023.01-beta1 (6255971af28381fad22547bdc2c538fc3ea2e8bf) +- 2023.01-alpha4 (4526cc94a3e19fe8fa151f54b0db432e1fb2f7d0) +- 2023.01-alpha3 (f0e8cab3d8e58195f7c2663b84fd0bed12fa8b64) +- 2023.01-alpha2 (91e732473f7cffce070f9ce239f8ffa22c081261) +- 2023.01-alpha1 (203c8bf464ff26fe0fe39b1451caedd026bbce55) + + ## [2022.04] - 2022-10-13 ### Known Issues - If using GCC 10 or higher as well as MPICH, compilation errors will occur unless `-fallow-argument-mismatch` is included in the Fortran compiler flags(the flag will now be added automatically if building with autotools or CMake). diff --git a/CMakeLists.txt b/CMakeLists.txt index a4759aaa72..473d8b91f9 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -26,7 +26,7 @@ set(CMAKE_Fortran_FLAGS_DEBUG) # Define the CMake project project(FMS - VERSION 2022.04.0 + VERSION 2023.01.0 DESCRIPTION "GFDL FMS Library" HOMEPAGE_URL "https://www.gfdl.noaa.gov/fms" LANGUAGES C Fortran) diff --git a/configure.ac b/configure.ac index 7f3a1c0087..ea919ccbc8 100644 --- a/configure.ac +++ b/configure.ac @@ -25,7 +25,7 @@ AC_PREREQ([2.69]) # Initialize with name, version, and support email address. AC_INIT([GFDL FMS Library], - [2022.04.00-dev], + [2023.01.00], [gfdl.climate.model.info@noaa.gov], [FMS], [https://www.github.com/NOAA-GFDL/FMS]) diff --git a/libFMS/Makefile.am b/libFMS/Makefile.am index 868c792d4c..e56820e701 100644 --- a/libFMS/Makefile.am +++ b/libFMS/Makefile.am @@ -28,7 +28,7 @@ lib_LTLIBRARIES = libFMS.la # These linker flags specify libtool version info. # See http://www.gnu.org/software/libtool/manual/libtool.html#Libtool-versioning # for information regarding incrementing `-version-info`. -libFMS_la_LDFLAGS = -version-info 14:0:0 +libFMS_la_LDFLAGS = -version-info 15:0:0 # Add the convenience libraries to the FMS library. libFMS_la_LIBADD = $(top_builddir)/platform/libplatform.la From 003b8e1e39a7cd8e38120075b42ceec257881d25 Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 6 Apr 2023 08:26:07 -0400 Subject: [PATCH 7/7] chore: append dev to version number post-release (#1179) --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index ea919ccbc8..799fa4ba48 100644 --- a/configure.ac +++ b/configure.ac @@ -25,7 +25,7 @@ AC_PREREQ([2.69]) # Initialize with name, version, and support email address. AC_INIT([GFDL FMS Library], - [2023.01.00], + [2023.01.00-dev], [gfdl.climate.model.info@noaa.gov], [FMS], [https://www.github.com/NOAA-GFDL/FMS])