From 696780c887ba6500da9c03d59884aee2a6e42206 Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Wed, 16 Aug 2023 11:26:56 -0400 Subject: [PATCH] test: modern diag manager add reduction method tests (#1335) --- test_fms/diag_manager/Makefile.am | 20 +- test_fms/diag_manager/check_time_max.F90 | 209 +++++++++++ test_fms/diag_manager/check_time_min.F90 | 209 +++++++++++ test_fms/diag_manager/check_time_none.F90 | 209 +++++++++++ test_fms/diag_manager/test_diag_manager2.sh | 33 +- test_fms/diag_manager/test_dm_openmp.F90 | 149 -------- .../diag_manager/test_reduction_methods.F90 | 343 ++++++++++++++++++ test_fms/diag_manager/test_time_max.sh | 132 +++++++ test_fms/diag_manager/test_time_min.sh | 132 +++++++ test_fms/diag_manager/test_time_none.sh | 132 +++++++ test_fms/diag_manager/testing_utils.F90 | 53 +++ 11 files changed, 1433 insertions(+), 188 deletions(-) create mode 100644 test_fms/diag_manager/check_time_max.F90 create mode 100644 test_fms/diag_manager/check_time_min.F90 create mode 100644 test_fms/diag_manager/check_time_none.F90 delete mode 100644 test_fms/diag_manager/test_dm_openmp.F90 create mode 100644 test_fms/diag_manager/test_reduction_methods.F90 create mode 100755 test_fms/diag_manager/test_time_max.sh create mode 100755 test_fms/diag_manager/test_time_min.sh create mode 100755 test_fms/diag_manager/test_time_none.sh create mode 100644 test_fms/diag_manager/testing_utils.F90 diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index bfe3814a5d..de682cc7ee 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -29,9 +29,9 @@ LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. check_PROGRAMS = test_diag_manager test_diag_manager_time \ - test_diag_update_buffer test_diag_dlinked_list \ - test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer test_flexible_time \ - test_dm_openmp + test_diag_dlinked_list test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer \ + test_flexible_time test_diag_update_buffer test_reduction_methods check_time_none \ + check_time_min check_time_max # This is the source code for the test. test_diag_manager_SOURCES = test_diag_manager.F90 @@ -43,17 +43,22 @@ test_diag_ocean_SOURCES = test_diag_ocean.F90 test_modern_diag_SOURCES = test_modern_diag.F90 test_diag_buffer_SOURCES= test_diag_buffer.F90 test_flexible_time_SOURCES = test_flexible_time.F90 -test_dm_openmp_SOURCES = test_dm_openmp.F90 +test_reduction_methods_SOURCES = testing_utils.F90 test_reduction_methods.F90 +check_time_none_SOURCES = testing_utils.F90 check_time_none.F90 +check_time_min_SOURCES = testing_utils.F90 check_time_min.F90 +check_time_max_SOURCES = testing_utils.F90 check_time_max.F90 TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ $(abs_top_srcdir)/test_fms/tap-driver.sh # Run the test. -TESTS = test_diag_manager2.sh +TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh + +testing_utils.mod: testing_utils.$(OBJEXT) # Copy over other needed files to the srcdir -EXTRA_DIST = input.nml_base diagTables test_diag_manager2.sh check_crashes.sh +EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh test_time_max.sh if USING_YAML skipflag="" @@ -63,4 +68,5 @@ endif TESTS_ENVIRONMENT = skipflag=${skipflag} -CLEANFILES = input.nml *.nc *.out diag_table *-files/* *.dpi *.spi *.dyn *.spl +CLEANFILES = *.yaml input.nml *.nc *.out diag_table* *-files/* *.dpi *.spi *.dyn *.spl *.mod + diff --git a/test_fms/diag_manager/check_time_max.F90 b/test_fms/diag_manager/check_time_max.F90 new file mode 100644 index 0000000000..b8e82f3472 --- /dev/null +++ b/test_fms/diag_manager/check_time_max.F90 @@ -0,0 +1,209 @@ +!*********************************************************************** +!* 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 Checks the output file after running test_reduction_methods using the "max" reduction method +program check_time_max + use fms_mod, only: fms_init, fms_end, string + use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file + use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file + use platform_mod, only: r4_kind, r8_kind + use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask + + type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj + type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1 + type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2 + real(kind=r4_kind), allocatable :: cdata_out(:,:,:,:) !< Data in the compute domain + integer :: nx !< Number of points in the x direction + integer :: ny !< Number of points in the y direction + integer :: nz !< Number of points in the z direction + integer :: nw !< Number of points in the 4th dimension + integer :: i !< For looping + integer :: io_status !< Io status after reading the namelist + logical :: use_mask !< .true. if using masks + + integer :: test_case = test_normal !< Indicates which test case to run + integer :: mask_case = no_mask !< Indicates which masking option to run + + namelist / test_reduction_methods_nml / test_case, mask_case + + call fms_init() + + read (input_nml_file, test_reduction_methods_nml, iostat=io_status) + + select case(mask_case) + case (no_mask) + use_mask = .false. + case (logical_mask, real_mask) + use_mask = .true. + end select + nx = 96 + ny = 96 + nz = 5 + nw = 2 + + if (.not. open_file(fileobj, "test_max.nc", "read")) & + call mpp_error(FATAL, "unable to open file") + + if (.not. open_file(fileobj1, "test_max_regional.nc.0004", "read")) & + call mpp_error(FATAL, "unable to open file") + + if (.not. open_file(fileobj2, "test_max_regional.nc.0005", "read")) & + call mpp_error(FATAL, "unable to open file") + + cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw) + + do i = 1, 8 + cdata_out = -999_r4_kind + print *, "Checking answers for var0_max - time_level:", string(i) + call read_data(fileobj, "var0_max", cdata_out(1:1,1,1,1), unlim_dim_level=i) !eyeroll + call check_data_0d(cdata_out(1,1,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var1_max - time_level:", string(i) + call read_data(fileobj, "var1_max", cdata_out(:,1,1,1), unlim_dim_level=i) + call check_data_1d(cdata_out(:,1,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var2_max - time_level:", string(i) + call read_data(fileobj, "var2_max", cdata_out(:,:,1,1), unlim_dim_level=i) + call check_data_2d(cdata_out(:,:,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_max - time_level:", string(i) + call read_data(fileobj, "var3_max", cdata_out(:,:,:,1), unlim_dim_level=i) + call check_data_3d(cdata_out(:,:,:,1), i, .false.) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_Z_max - time_level:", string(i) + call read_data(fileobj, "var3_Z_max", cdata_out(:,:,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(:,:,1:2,1), i, .true., nz_offset=1) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_max in the first regional file- time_level:", string(i) + call read_data(fileobj1, "var3_max", cdata_out(1:4,1:3,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(1:4,1:3,1:2,1), i, .true., nx_offset=77, ny_offset=77, nz_offset=1) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_max in the second regional file- time_level:", string(i) + call read_data(fileobj2, "var3_max", cdata_out(1:4,1:1,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(1:4,1:1,1:2,1), i, .true., nx_offset=77, ny_offset=80, nz_offset=1) + enddo + + call fms_end() + +contains + + !> @brief Check that the 0d data read in is correct + subroutine check_data_0d(buffer, time_level) + real(kind=r4_kind), intent(inout) :: buffer !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + + real(kind=r4_kind) :: buffer_exp !< Expected result + + buffer_exp = real(1000_r8_kind+10_r8_kind+1_r8_kind + & + real(6*time_level, kind=r8_kind)/100_r8_kind, kind=r4_kind) + + if (abs(buffer - buffer_exp) > 0) then + print *, mpp_pe(), time_level, buffer, buffer_exp + call mpp_error(FATAL, "Check_time_max::check_data_0d:: Data is not correct") + endif + end subroutine check_data_0d + + !> @brief Check that the 1d data read in is correct + subroutine check_data_1d(buffer, time_level) + real(kind=r4_kind), intent(in) :: buffer(:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + real(kind=r4_kind) :: buffer_exp !< Expected result + + integer ii, j, k, l !< For looping + + do ii = 1, size(buffer, 1) + buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+10_r8_kind+1_r8_kind + & + real(6*time_level, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1) buffer_exp = -666_r4_kind + if (abs(buffer(ii) - buffer_exp) > 0) then + print *, mpp_pe(), ii, buffer(ii), buffer_exp + call mpp_error(FATAL, "Check_time_max::check_data_1d:: Data is not correct") + endif + enddo + end subroutine check_data_1d + + !> @brief Check that the 2d data read in is correct + subroutine check_data_2d(buffer, time_level) + real(kind=r4_kind), intent(in) :: buffer(:,:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + real(kind=r4_kind) :: buffer_exp !< Expected result + + integer ii, j, k, l !< For looping + + do ii = 1, size(buffer, 1) + do j = 1, size(buffer, 2) + buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+ & + 10_r8_kind*real(j, kind=r8_kind)+1_r8_kind + & + real(6*time_level, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1 .and. j .eq. 1) buffer_exp = -666_r4_kind + if (abs(buffer(ii, j) - buffer_exp) > 0) then + print *, mpp_pe(), ii, j, buffer(ii, j), buffer_exp + call mpp_error(FATAL, "Check_time_max::check_data_2d:: Data is not correct") + endif + enddo + enddo + end subroutine check_data_2d + + !> @brief Check that the 3d data read in is correct + subroutine check_data_3d(buffer, time_level, is_regional, nx_offset, ny_offset, nz_offset) + real(kind=r4_kind), intent(in) :: buffer(:,:,:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + logical, intent(in) :: is_regional !< .True. if the variable is subregional + real(kind=r4_kind) :: buffer_exp !< Expected result + integer, optional, intent(in) :: nx_offset !< Offset in the x direction + integer, optional, intent(in) :: ny_offset !< Offset in the y direction + integer, optional, intent(in) :: nz_offset !< Offset in the z direction + + integer :: ii, j, k, l !< For looping + integer :: nx_oset !< Offset in the x direction (local variable) + integer :: ny_oset !< Offset in the y direction (local variable) + integer :: nz_oset !< Offset in the z direction (local variable) + + nx_oset = 0 + if (present(nx_offset)) nx_oset = nx_offset + + ny_oset = 0 + if (present(ny_offset)) ny_oset = ny_offset + + nz_oset = 0 + if (present(nz_offset)) nz_oset = nz_offset + + do ii = 1, size(buffer, 1) + do j = 1, size(buffer, 2) + do k = 1, size(buffer, 3) + buffer_exp = real(real(ii+nx_oset, kind=r8_kind)* 1000_r8_kind + & + 10_r8_kind*real(j+ny_oset, kind=r8_kind) + & + 1_r8_kind*real(k+nz_oset, kind=r8_kind) + & + real(6*time_level, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. .not. is_regional) buffer_exp = -666_r4_kind + if (abs(buffer(ii, j, k) - buffer_exp) > 0) then + print *, mpp_pe(), ii, j, k, buffer(ii, j, k), buffer_exp + call mpp_error(FATAL, "Check_time_max::check_data_3d:: Data is not correct") + endif + enddo + enddo + enddo + end subroutine check_data_3d +end program \ No newline at end of file diff --git a/test_fms/diag_manager/check_time_min.F90 b/test_fms/diag_manager/check_time_min.F90 new file mode 100644 index 0000000000..f0d8f8029d --- /dev/null +++ b/test_fms/diag_manager/check_time_min.F90 @@ -0,0 +1,209 @@ +!*********************************************************************** +!* 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 Checks the output file after running test_reduction_methods using the "min" reduction method +program check_time_min + use fms_mod, only: fms_init, fms_end, string + use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file + use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file + use platform_mod, only: r4_kind, r8_kind + use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask + + type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj + type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1 + type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2 + real(kind=r4_kind), allocatable :: cdata_out(:,:,:,:) !< Data in the compute domain + integer :: nx !< Number of points in the x direction + integer :: ny !< Number of points in the y direction + integer :: nz !< Number of points in the z direction + integer :: nw !< Number of points in the 4th dimension + integer :: i !< For looping + integer :: io_status !< Io status after reading the namelist + logical :: use_mask !< .true. if using masks + + integer :: test_case = test_normal !< Indicates which test case to run + integer :: mask_case = no_mask !< Indicates which masking option to run + + namelist / test_reduction_methods_nml / test_case, mask_case + + call fms_init() + + read (input_nml_file, test_reduction_methods_nml, iostat=io_status) + + select case(mask_case) + case (no_mask) + use_mask = .false. + case (logical_mask, real_mask) + use_mask = .true. + end select + nx = 96 + ny = 96 + nz = 5 + nw = 2 + + if (.not. open_file(fileobj, "test_min.nc", "read")) & + call mpp_error(FATAL, "unable to open file") + + if (.not. open_file(fileobj1, "test_min_regional.nc.0004", "read")) & + call mpp_error(FATAL, "unable to open file") + + if (.not. open_file(fileobj2, "test_min_regional.nc.0005", "read")) & + call mpp_error(FATAL, "unable to open file") + + cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw) + + do i = 1, 8 + cdata_out = -999_r4_kind + print *, "Checking answers for var0_min - time_level:", string(i) + call read_data(fileobj, "var0_min", cdata_out(1:1,1,1,1), unlim_dim_level=i) !eyeroll + call check_data_0d(cdata_out(1,1,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var1_min - time_level:", string(i) + call read_data(fileobj, "var1_min", cdata_out(:,1,1,1), unlim_dim_level=i) + call check_data_1d(cdata_out(:,1,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var2_min - time_level:", string(i) + call read_data(fileobj, "var2_min", cdata_out(:,:,1,1), unlim_dim_level=i) + call check_data_2d(cdata_out(:,:,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_min - time_level:", string(i) + call read_data(fileobj, "var3_min", cdata_out(:,:,:,1), unlim_dim_level=i) + call check_data_3d(cdata_out(:,:,:,1), i, .false.) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_Z_min - time_level:", string(i) + call read_data(fileobj, "var3_Z_min", cdata_out(:,:,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(:,:,1:2,1), i, .true., nz_offset=1) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_min in the first regional file- time_level:", string(i) + call read_data(fileobj1, "var3_min", cdata_out(1:4,1:3,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(1:4,1:3,1:2,1), i, .true., nx_offset=77, ny_offset=77, nz_offset=1) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_min in the second regional file- time_level:", string(i) + call read_data(fileobj2, "var3_min", cdata_out(1:4,1:1,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(1:4,1:1,1:2,1), i, .true., nx_offset=77, ny_offset=80, nz_offset=1) + enddo + + call fms_end() + +contains + + !> @brief Check that the 0d data read in is correct + subroutine check_data_0d(buffer, time_level) + real(kind=r4_kind), intent(inout) :: buffer !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + + real(kind=r4_kind) :: buffer_exp !< Expected result + + buffer_exp = real(1000_r8_kind+10_r8_kind+1_r8_kind + & + real(6*(time_level-1)+1, kind=r8_kind)/100_r8_kind, kind=r4_kind) + + if (abs(buffer - buffer_exp) > 0) then + print *, mpp_pe(), time_level, buffer, buffer_exp + call mpp_error(FATAL, "Check_time_min::check_data_0d:: Data is not correct") + endif + end subroutine check_data_0d + + !> @brief Check that the 1d data read in is correct + subroutine check_data_1d(buffer, time_level) + real(kind=r4_kind), intent(in) :: buffer(:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + real(kind=r4_kind) :: buffer_exp !< Expected result + + integer ii, j, k, l !< For looping + + do ii = 1, size(buffer, 1) + buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+10_r8_kind+1_r8_kind + & + real(6*(time_level-1)+1, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1) buffer_exp = -666_r4_kind + if (abs(buffer(ii) - buffer_exp) > 0) then + print *, mpp_pe(), ii, buffer(ii), buffer_exp + call mpp_error(FATAL, "Check_time_min::check_data_1d:: Data is not correct") + endif + enddo + end subroutine check_data_1d + + !> @brief Check that the 2d data read in is correct + subroutine check_data_2d(buffer, time_level) + real(kind=r4_kind), intent(in) :: buffer(:,:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + real(kind=r4_kind) :: buffer_exp !< Expected result + + integer ii, j, k, l !< For looping + + do ii = 1, size(buffer, 1) + do j = 1, size(buffer, 2) + buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+ & + 10_r8_kind*real(j, kind=r8_kind)+1_r8_kind + & + real(6*(time_level-1)+1, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1 .and. j .eq. 1) buffer_exp = -666_r4_kind + if (abs(buffer(ii, j) - buffer_exp) > 0) then + print *, mpp_pe(), ii, j, buffer(ii, j), buffer_exp + call mpp_error(FATAL, "Check_time_min::check_data_2d:: Data is not correct") + endif + enddo + enddo + end subroutine check_data_2d + + !> @brief Check that the 3d data read in is correct + subroutine check_data_3d(buffer, time_level, is_regional, nx_offset, ny_offset, nz_offset) + real(kind=r4_kind), intent(in) :: buffer(:,:,:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + logical, intent(in) :: is_regional !< .True. if the variable is subregional + real(kind=r4_kind) :: buffer_exp !< Expected result + integer, optional, intent(in) :: nx_offset !< Offset in the x direction + integer, optional, intent(in) :: ny_offset !< Offset in the y direction + integer, optional, intent(in) :: nz_offset !< Offset in the z direction + + integer :: ii, j, k, l !< For looping + integer :: nx_oset !< Offset in the x direction (local variable) + integer :: ny_oset !< Offset in the y direction (local variable) + integer :: nz_oset !< Offset in the z direction (local variable) + + nx_oset = 0 + if (present(nx_offset)) nx_oset = nx_offset + + ny_oset = 0 + if (present(ny_offset)) ny_oset = ny_offset + + nz_oset = 0 + if (present(nz_offset)) nz_oset = nz_offset + + do ii = 1, size(buffer, 1) + do j = 1, size(buffer, 2) + do k = 1, size(buffer, 3) + buffer_exp = real(real(ii+nx_oset, kind=r8_kind)* 1000_r8_kind + & + 10_r8_kind*real(j+ny_oset, kind=r8_kind) + & + 1_r8_kind*real(k+nz_oset, kind=r8_kind) + & + real(6*(time_level-1)+1, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. .not. is_regional) buffer_exp = -666_r4_kind + if (abs(buffer(ii, j, k) - buffer_exp) > 0) then + print *, mpp_pe(), ii, j, k, buffer(ii, j, k), buffer_exp + call mpp_error(FATAL, "Check_time_min::check_data_3d:: Data is not correct") + endif + enddo + enddo + enddo + end subroutine check_data_3d +end program \ No newline at end of file diff --git a/test_fms/diag_manager/check_time_none.F90 b/test_fms/diag_manager/check_time_none.F90 new file mode 100644 index 0000000000..11844448c0 --- /dev/null +++ b/test_fms/diag_manager/check_time_none.F90 @@ -0,0 +1,209 @@ +!*********************************************************************** +!* 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 Checks the output file after running test_reduction_methods using the "none" reduction method +program check_time_none + use fms_mod, only: fms_init, fms_end, string + use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file + use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file + use platform_mod, only: r4_kind, r8_kind + use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask + + type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj + type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1 + type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2 + real(kind=r4_kind), allocatable :: cdata_out(:,:,:,:) !< Data in the compute domain + integer :: nx !< Number of points in the x direction + integer :: ny !< Number of points in the y direction + integer :: nz !< Number of points in the z direction + integer :: nw !< Number of points in the 4th dimension + integer :: i !< For looping + integer :: io_status !< Io status after reading the namelist + logical :: use_mask !< .true. if using masks + + integer :: test_case = test_normal !< Indicates which test case to run + integer :: mask_case = no_mask !< Indicates which masking option to run + + namelist / test_reduction_methods_nml / test_case, mask_case + + call fms_init() + + read (input_nml_file, test_reduction_methods_nml, iostat=io_status) + + select case(mask_case) + case (no_mask) + use_mask = .false. + case (logical_mask, real_mask) + use_mask = .true. + end select + nx = 96 + ny = 96 + nz = 5 + nw = 2 + + if (.not. open_file(fileobj, "test_none.nc", "read")) & + call mpp_error(FATAL, "unable to open file") + + if (.not. open_file(fileobj1, "test_none_regional.nc.0004", "read")) & + call mpp_error(FATAL, "unable to open file") + + if (.not. open_file(fileobj2, "test_none_regional.nc.0005", "read")) & + call mpp_error(FATAL, "unable to open file") + + cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw) + + do i = 1, 8 + cdata_out = -999_r4_kind + print *, "Checking answers for var0_none - time_level:", string(i) + call read_data(fileobj, "var0_none", cdata_out(1:1,1,1,1), unlim_dim_level=i) !eyeroll + call check_data_0d(cdata_out(1,1,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var1_none - time_level:", string(i) + call read_data(fileobj, "var1_none", cdata_out(:,1,1,1), unlim_dim_level=i) + call check_data_1d(cdata_out(:,1,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var2_none - time_level:", string(i) + call read_data(fileobj, "var2_none", cdata_out(:,:,1,1), unlim_dim_level=i) + call check_data_2d(cdata_out(:,:,1,1), i) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_none - time_level:", string(i) + call read_data(fileobj, "var3_none", cdata_out(:,:,:,1), unlim_dim_level=i) + call check_data_3d(cdata_out(:,:,:,1), i, .false.) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_Z - time_level:", string(i) + call read_data(fileobj, "var3_Z", cdata_out(:,:,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(:,:,1:2,1), i, .true., nz_offset=1) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_none in the first regional file- time_level:", string(i) + call read_data(fileobj1, "var3_none", cdata_out(1:4,1:3,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(1:4,1:3,1:2,1), i, .true., nx_offset=77, ny_offset=77, nz_offset=1) + + cdata_out = -999_r4_kind + print *, "Checking answers for var3_none in the second regional file- time_level:", string(i) + call read_data(fileobj2, "var3_none", cdata_out(1:4,1:1,1:2,1), unlim_dim_level=i) + call check_data_3d(cdata_out(1:4,1:1,1:2,1), i, .true., nx_offset=77, ny_offset=80, nz_offset=1) + enddo + + call fms_end() + +contains + + !> @brief Check that the 0d data read in is correct + subroutine check_data_0d(buffer, time_level) + real(kind=r4_kind), intent(inout) :: buffer !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + + real(kind=r4_kind) :: buffer_exp !< Expected result + + buffer_exp = real(1000_r8_kind+10_r8_kind+1_r8_kind + & + real(time_level*6, kind=r8_kind)/100_r8_kind, kind=r4_kind) + + if (abs(buffer - buffer_exp) > 0) then + print *, mpp_pe(), time_level, buffer_exp + call mpp_error(FATAL, "Check_time_none::check_data_0d:: Data is not correct") + endif + end subroutine check_data_0d + + !> @brief Check that the 1d data read in is correct + subroutine check_data_1d(buffer, time_level) + real(kind=r4_kind), intent(in) :: buffer(:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + real(kind=r4_kind) :: buffer_exp !< Expected result + + integer ii, j, k, l !< For looping + + do ii = 1, size(buffer, 1) + buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+10_r8_kind+1_r8_kind + & + real(time_level*6, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1) buffer_exp = -666_r4_kind + if (abs(buffer(ii) - buffer_exp) > 0) then + print *, mpp_pe(), ii, buffer(ii), buffer_exp + call mpp_error(FATAL, "Check_time_none::check_data_1d:: Data is not correct") + endif + enddo + end subroutine check_data_1d + + !> @brief Check that the 2d data read in is correct + subroutine check_data_2d(buffer, time_level) + real(kind=r4_kind), intent(in) :: buffer(:,:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + real(kind=r4_kind) :: buffer_exp !< Expected result + + integer ii, j, k, l !< For looping + + do ii = 1, size(buffer, 1) + do j = 1, size(buffer, 2) + buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+ & + 10_r8_kind*real(j, kind=r8_kind)+1_r8_kind + & + real(time_level*6, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1 .and. j .eq. 1) buffer_exp = -666_r4_kind + if (abs(buffer(ii, j) - buffer_exp) > 0) then + print *, mpp_pe(), ii, j, buffer(ii, j), buffer_exp + call mpp_error(FATAL, "Check_time_none::check_data_2d:: Data is not correct") + endif + enddo + enddo + end subroutine check_data_2d + + !> @brief Check that the 3d data read in is correct + subroutine check_data_3d(buffer, time_level, is_regional, nx_offset, ny_offset, nz_offset) + real(kind=r4_kind), intent(in) :: buffer(:,:,:) !< Buffer read from the table + integer, intent(in) :: time_level !< Time level read in + logical, intent(in) :: is_regional !< .True. if the variable is subregional + real(kind=r4_kind) :: buffer_exp !< Expected result + integer, optional, intent(in) :: nx_offset !< Offset in the x direction + integer, optional, intent(in) :: ny_offset !< Offset in the y direction + integer, optional, intent(in) :: nz_offset !< Offset in the z direction + + integer :: ii, j, k, l !< For looping + integer :: nx_oset !< Offset in the x direction (local variable) + integer :: ny_oset !< Offset in the y direction (local variable) + integer :: nz_oset !< Offset in the z direction (local variable) + + nx_oset = 0 + if (present(nx_offset)) nx_oset = nx_offset + + ny_oset = 0 + if (present(ny_offset)) ny_oset = ny_offset + + nz_oset = 0 + if (present(nz_offset)) nz_oset = nz_offset + + do ii = 1, size(buffer, 1) + do j = 1, size(buffer, 2) + do k = 1, size(buffer, 3) + buffer_exp = real(real(ii+nx_oset, kind=r8_kind)* 1000_r8_kind + & + 10_r8_kind*real(j+ny_oset, kind=r8_kind) + & + 1_r8_kind*real(k+nz_oset, kind=r8_kind) + & + real(time_level*6, kind=r8_kind)/100_r8_kind, kind=r4_kind) + if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. .not. is_regional) buffer_exp = -666_r4_kind + if (abs(buffer(ii, j, k) - buffer_exp) > 0) then + print *, mpp_pe(), ii, j, k, buffer(ii, j, k), buffer_exp + call mpp_error(FATAL, "Check_time_none::check_data_3d:: Data is not correct") + endif + enddo + enddo + enddo + end subroutine check_data_3d +end program diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh index 1fc8c1e3c1..813e225156 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -478,7 +478,6 @@ test_diag_manager "test_diag_manager_mod", "sst", "sst", "ocn_end%4yr%2mo%2dy%2hr", "all", .true., "none", 2 _EOF -my_test_count=25 rm -f input.nml && touch input.nml test_expect_success "wildcard filenames (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager_time @@ -505,7 +504,7 @@ test_expect_success "diurnal test (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager_time ' setup_test -my_test_count=26 +my_test_count=`expr $my_test_count + 1` test_expect_success "Test the diag update_buffer (test $my_test_count)" ' mpirun -n 1 ../test_diag_update_buffer ' @@ -866,36 +865,6 @@ printf "&diag_manager_nml \n use_modern_diag = .false. \n use_clock_average = .t mpirun -n 1 ../test_flexible_time ' -printf "&diag_manager_nml \n use_modern_diag = .true. \n /" | cat > input.nml -cat <<_EOF > diag_table.yaml -title: test_diag_manager -base_date: 2 1 1 0 0 0 -diag_files: -- file_name: file_openmp_test - freq: 1 hours - time_units: hours - unlimdim: time - varlist: - - module: ocn_mod - var_name: var1 - reduction: none - kind: r4 - - module: ocn_mod - var_name: var2 - reduction: none - kind: r4 - - module: ocn_mod - var_name: var3 - reduction: none - kind: r4 -_EOF - -export OMP_NUM_THREADS=2 -my_test_count=`expr $my_test_count + 1` - test_expect_success "Test the modern diag manager end to end but it uses the openmp stuff(test $my_test_count)" ' - mpirun -n 6 ../test_dm_openmp - ' -export OMP_NUM_THREADS=1 else my_test_count=`expr $my_test_count + 1` test_expect_failure "test modern diag manager failure when compiled without -Duse-yaml flag (test $my_test_count)" ' diff --git a/test_fms/diag_manager/test_dm_openmp.F90 b/test_fms/diag_manager/test_dm_openmp.F90 deleted file mode 100644 index 99ca790aac..0000000000 --- a/test_fms/diag_manager/test_dm_openmp.F90 +++ /dev/null @@ -1,149 +0,0 @@ -!*********************************************************************** -!* 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 This programs tests the modern diag_manager - -program test_diag_openmp - use omp_lib - use mpp_mod, only: mpp_npes, mpp_pe, mpp_sync - use platform_mod, only: r8_kind - use mpp_domains_mod, only: domain2d, mpp_define_domains, mpp_define_io_domain, mpp_get_compute_domain - use block_control_mod, only: block_control_type, define_blocks - use fms_mod, only: fms_init, fms_end - use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field, & - diag_send_complete, diag_manager_set_time_end, send_data, register_static_field - use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time - - - implicit none - - integer :: nx !< Number of points in the x direction - integer :: ny !< Number of points in the y direction - integer :: nz !< Number of points in the z direction - integer :: layout(2) !< Layout - integer :: io_layout(2) !< Io layout - type(domain2d) :: Domain !< 2D domain - integer :: is !< Starting x compute index - integer :: ie !< Ending x compute index - integer :: js !< Starting y compute index - integer :: je !< Ending y compute index - type(time_type) :: Time !< Time of the simulation - type(time_type) :: Time_step !< Time of the simulation - real, dimension(:), allocatable :: x !< X axis data - integer :: id_x !< axis id for the x dimension - real, dimension(:), allocatable :: y !< Y axis_data - integer :: id_y !< axis id for the y dimension - real, dimension(:), allocatable :: z !< Z axis data - integer :: id_z !< axis id for the z dimension - real(kind=r8_kind), allocatable :: var(:,:,:) !< Dummy variable data - integer :: i, j !< For do loops - type(block_control_type) :: my_block !< Returns instantiated @ref block_control_type - logical :: message !< Flag for outputting debug message - integer :: isw !< Starting index for each thread in the x direction - integer :: iew !< Ending index for each thread in the x direction - integer :: jsw !< Starting index for each thread in the y direction - integer :: jew !< Ending index for each thread in the y direction - integer :: is1 !< Starting index for each thread in the x direction (1-based) - integer :: ie1 !< Ending index for each thread in the x direction (1-based) - integer :: js1 !< Starting index for each thread in the y direction (1-based) - integer :: je1 !< Ending index for each thread in the y direction (1-based) - integer :: id_var1 !< diag_field id for var in 1d - integer :: id_var2 !< diag_field id for var in lon/lat grid - integer :: id_var3 !< diag_field id for var in lon/lat/z grid - logical :: used !< .true. if the send_data call was sucessful - - call fms_init - call set_calendar_type(JULIAN) - call diag_manager_init - - nx = 96 - ny = 96 - nz = 5 - layout = (/1, mpp_npes()/) - io_layout = (/1, 1/) - - ! Set up the intial time - Time = set_date(2,1,1,0,0,0) - - !< Create a lat/lon domain - call mpp_define_domains( (/1,nx,1,ny/), layout, Domain, name='2D domain') - call mpp_define_io_domain(Domain, io_layout) - call mpp_get_compute_domain(Domain, is, ie, js, je) - - ! Set up the data - allocate(x(nx), y(ny), z(nz)) - allocate(var(is:ie, js:je, nz)) - do i=1,nx - x(i) = i - enddo - - do i=1,ny - y(i) = i - enddo - - do i=1,nz - z(i) = i - enddo - - !< Register the axis: - id_x = diag_axis_init('x', x, 'point_E', 'x', long_name='point_E', Domain2=Domain) - id_y = diag_axis_init('y', y, 'point_N', 'y', long_name='point_N', Domain2=Domain) - id_z = diag_axis_init('z', z, 'pressure', 'z', long_name='too much pressure') - - !< Register the variables - id_var1 = register_diag_field ('ocn_mod', 'var1', (/id_x/), Time, 'Var in a lon domain', 'mullions') - id_var2 = register_diag_field ('ocn_mod', 'var2', (/id_x, id_y/), Time, 'Var in a lon/lat domain', 'mullions') - id_var3 = register_diag_field ('ocn_mod', 'var3', (/id_x, id_y, id_z/), Time, & - 'Var in a lon/lat/z domain', 'mullions') - - call diag_manager_set_time_end(set_date(2,1,2,0,0,0)) - - !< Divide the domain further into blocks - call define_blocks ('testing_model', my_block, is, ie, js, je, kpts=0, & - nx_block=1, ny_block=4, message=message) - - Time_step = set_time (3600,0) !< 1 hour - do j = 1, 23 !simulated time - Time = set_date(2,1,1,j,0,0) - var = real(j, kind=r8_kind) !< Set the data -!$OMP parallel do default(shared) private(i, isw, iew, jsw, jew) schedule (dynamic,1) - do i = 1, 4 - isw = my_block%ibs(i) - jsw = my_block%jbs(i) - iew = my_block%ibe(i) - jew = my_block%jbe(i) - - !--- indices for 1-based arrays --- - is1 = isw-is+1 - ie1 = iew-is+1 - js1 = jsw-js+1 - je1 = jew-js+1 - - used=send_data(id_var1, var(is1:ie1, 1, 1), time, is_in=is1, ie_in=ie1) - used=send_data(id_var2, var(is1:ie1, js1:je1, 1), time, is_in=is1, js_in=js1, & - ie_in=ie1, je_in=je1) - used=send_data(id_var3, var(is1:ie1, js1:je1, :), time, is_in=is1, js_in=js1, & - ie_in=ie1, je_in=je1, ks_in=1, ke_in=nz) - enddo - call diag_send_complete(Time_step) - enddo - - call diag_manager_end(Time) - call fms_end -end program test_diag_openmp \ No newline at end of file diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90 new file mode 100644 index 0000000000..3f85a043f0 --- /dev/null +++ b/test_fms/diag_manager/test_reduction_methods.F90 @@ -0,0 +1,343 @@ +!*********************************************************************** +!* 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 General program to test the different possible reduction methods +program test_reduction_methods + use fms_mod, only: fms_init, fms_end + use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask + use platform_mod, only: r8_kind + use block_control_mod, only: block_control_type, define_blocks + use mpp_mod, only: mpp_sync, FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast, input_nml_file + use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time, OPERATOR(+) + use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field, & + diag_send_complete, diag_manager_set_time_end, send_data + use mpp_domains_mod, only: domain2d, mpp_define_domains, mpp_define_io_domain, mpp_get_compute_domain, & + mpp_get_data_domain + + implicit none + + integer :: nx !< Number of points in the x direction + integer :: ny !< Number of points in the y direction + integer :: nz !< Number of points in the z direction + integer :: nw !< Number of points in the 4th dimension + integer :: layout(2) !< Layout + integer :: io_layout(2) !< Io layout + type(domain2d) :: Domain !< 2D domain + integer :: isc, isd !< Starting x compute, data domain index + integer :: iec, ied !< Ending x compute, data domain index + integer :: jsc, jsd !< Starting y compute, data domaine index + integer :: jec, jed !< Ending y compute, data domain index + integer :: nhalox !< Number of halos in x + integer :: nhaloy !< Number of halos in y + real(kind=r8_kind), allocatable :: cdata(:,:,:,:) !< Data in the compute domain + real(kind=r8_kind), allocatable :: ddata(:,:,:,:) !< Data in the data domain + real(kind=r8_kind), allocatable :: crmask(:,:,:,:) !< Mask in the compute domain + real(kind=r8_kind), allocatable :: drmask(:,:,:,:) !< Mask in the data domain + logical, allocatable :: clmask(:,:,:,:) !< Logical mask in the compute domain + logical, allocatable :: dlmask(:,:,:,:) !< Logical mask in the data domain + type(time_type) :: Time !< Time of the simulation + type(time_type) :: Time_step !< Time of the simulation + integer :: ntimes !< Number of times + integer :: id_x !< axis id for the x dimension + integer :: id_y !< axis id for the y dimension + integer :: id_z !< axis id for the z dimension + integer :: id_w !< axis id for the w dimension + integer :: id_var0 !< diag_field id for 0d var + integer :: id_var1 !< diag_field id for 1d var + integer :: id_var2 !< diag_field id for 2d var + integer :: id_var3 !< diag_field id for 3d var + integer :: id_var4 !< diag_field id for 4d var + integer :: io_status !< Status after reading the namelist + type(block_control_type) :: my_block !< Returns instantiated @ref block_control_type + logical :: message !< Flag for outputting debug message + integer :: isd1 !< Starting x data domain index (1-based) + integer :: ied1 !< Ending x data domain index (1-based) + integer :: jsd1 !< Starting y data domain index (1-based) + integer :: jed1 !< Ending y data domain index (1-based) + integer :: isw !< Starting index for each thread in the x direction + integer :: iew !< Ending index for each thread in the x direction + integer :: jsw !< Starting index for each thread in the y direction + integer :: jew !< Ending index for each thread in the y direction + integer :: is1 !< Starting index for each thread in the x direction (1-based) + integer :: ie1 !< Ending index for each thread in the x direction (1-based) + integer :: js1 !< Starting index for each thread in the y direction (1-based) + integer :: je1 !< Ending index for each thread in the y direction (1-based) + integer :: iblock !< For looping through the blocks + integer :: i !< For do loops + logical :: used !< Dummy argument to send_data + real(kind=r8_kind) :: missing_value !< Missing value to use + + !< Configuration parameters + integer :: test_case = test_normal !< Indicates which test case to run + integer :: mask_case = no_mask !< Indicates which masking option to run + + namelist / test_reduction_methods_nml / test_case, mask_case + + call fms_init + call set_calendar_type(JULIAN) + call diag_manager_init + + read (input_nml_file, test_reduction_methods_nml, iostat=io_status) + if (io_status > 0) call mpp_error(FATAL,'=>test_modern_diag: Error reading input.nml') + + Time = set_date(2,1,1,0,0,0) + Time_step = set_time (3600,0) !< 1 hour + nx = 96 + ny = 96 + nz = 5 + nw = 2 + layout = (/1, mpp_npes()/) + io_layout = (/1, 1/) + nhalox = 2 + nhaloy = 2 + ntimes = 48 + + !< Create a lat/lon domain + call mpp_define_domains( (/1,nx,1,ny/), layout, Domain, name='2D domain', xhalo=nhalox, yhalo=nhaloy) + call mpp_define_io_domain(Domain, io_layout) + call mpp_get_compute_domain(Domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain, isd, ied, jsd, jed) + + cdata = allocate_buffer(isc, iec, jsc, jec, nz, nw) + call init_buffer(cdata, isc, iec, jsc, jec, 0) + + select case (test_case) + case (test_normal) + if (mpp_pe() .eq. mpp_root_pe()) print *, "Testing the normal send_data calls" + case (test_halos) + if (mpp_pe() .eq. mpp_root_pe()) print *, "Testing the send_data calls with halos" + ddata = allocate_buffer(isd, ied, jsd, jed, nz, nw) + call init_buffer(ddata, isc, iec, jsc, jec, 2) !< The halos never get set + case (test_openmp) + if (mpp_pe() .eq. mpp_root_pe()) print *, "Testing the send_data calls with openmp blocks" + call define_blocks ('testing_model', my_block, isc, iec, jsc, jec, kpts=0, & + nx_block=1, ny_block=4, message=message) + end select + + select case (mask_case) + case (logical_mask) + clmask = allocate_logical_mask(isc, iec, jsc, jec, nz, nw) + if (mpp_pe() .eq. 0) clmask(isc, jsc, 1, 1) = .False. + + if (test_case .eq. test_halos) then + dlmask = allocate_logical_mask(isd, ied, jsd, jed, nz, nw) + if (mpp_pe() .eq. 0) dlmask(1+nhalox, 1+nhaloy, 1, 1) = .False. + endif + case (real_mask) + crmask = allocate_real_mask(isc, iec, jsc, jec, nz, nw) + if (mpp_pe() .eq. 0) crmask(isc, jsc, 1, 1) = 0_r8_kind + + if (test_case .eq. test_halos) then + drmask = allocate_real_mask(isd, ied, jsd, jed, nz, nw) + if (mpp_pe() .eq. 0) drmask(1+nhalox, 1+nhaloy, 1, 1) = 0_r8_kind + endif + end select + + !< Register the axis + id_x = diag_axis_init('x', real((/ (i, i = 1,nx) /), kind=r8_kind), 'point_E', 'x', long_name='point_E', & + Domain2=Domain) + id_y = diag_axis_init('y', real((/ (i, i = 1,ny) /), kind=r8_kind), 'point_N', 'y', long_name='point_N', & + Domain2=Domain) + id_z = diag_axis_init('z', real((/ (i, i = 1,nz) /), kind=r8_kind), 'point_Z', 'z', long_name='point_Z') + id_w = diag_axis_init('w', real((/ (i, i = 1,nw) /), kind=r8_kind), 'point_W', 'n', long_name='point_W') + + missing_value = -666._r8_kind + !< Register the fields + id_var0 = register_diag_field ('ocn_mod', 'var0', Time, 'Var0d', & + 'mullions', missing_value = missing_value) + id_var1 = register_diag_field ('ocn_mod', 'var1', (/id_x/), Time, 'Var1d', & + 'mullions', missing_value = missing_value) + id_var2 = register_diag_field ('ocn_mod', 'var2', (/id_x, id_y/), Time, 'Var2d', & + 'mullions', missing_value = missing_value) + id_var3 = register_diag_field ('ocn_mod', 'var3', (/id_x, id_y, id_z/), Time, 'Var3d', & + 'mullions', missing_value = missing_value) + id_var4 = register_diag_field ('ocn_mod', 'var4', (/id_x, id_y, id_z, id_w/), Time, 'Var4d', & + 'mullions', missing_value = missing_value) + + !< Get the data domain indices (1 based) + isd1 = isc-isd+1 + jsd1 = jsc-jsd+1 + ied1 = isd1 + iec-isc + jed1 = jsd1 + jec-jsc + + call diag_manager_set_time_end(set_date(2,1,3,0,0,0)) + do i = 1, ntimes + Time = Time + Time_step + + call set_buffer(cdata, i) + used = send_data(id_var0, cdata(1,1,1,1), Time) + + select case(test_case) + case (test_normal) + select case (mask_case) + case (no_mask) + used = send_data(id_var1, cdata(:,1,1,1), Time) + used = send_data(id_var2, cdata(:,:,1,1), Time) + used = send_data(id_var3, cdata(:,:,:,1), Time) + case (real_mask) + used = send_data(id_var1, cdata(:,1,1,1), Time, rmask=crmask(:,1,1,1)) + used = send_data(id_var2, cdata(:,:,1,1), Time, rmask=crmask(:,:,1,1)) + used = send_data(id_var3, cdata(:,:,:,1), Time, rmask=crmask(:,:,:,1)) + case (logical_mask) + used = send_data(id_var1, cdata(:,1,1,1), Time, mask=clmask(:,1,1,1)) + used = send_data(id_var2, cdata(:,:,1,1), Time, mask=clmask(:,:,1,1)) + used = send_data(id_var3, cdata(:,:,:,1), Time, mask=clmask(:,:,:,1)) + end select + case (test_halos) + call set_buffer(ddata, i) + select case (mask_case) + case (no_mask) + used = send_data(id_var1, cdata(:,1,1,1), Time) + used = send_data(id_var2, ddata(:,:,1,1), Time, & + is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1) + used = send_data(id_var3, ddata(:,:,:,1), Time, & + is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1) + case (real_mask) + used = send_data(id_var1, cdata(:,1,1,1), Time, & + rmask=crmask(:,1,1,1)) + used = send_data(id_var2, ddata(:,:,1,1), Time, & + is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, & + rmask=drmask(:,:,1,1)) + used = send_data(id_var3, ddata(:,:,:,1), Time, & + is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, & + rmask=drmask(:,:,:,1)) + case (logical_mask) + used = send_data(id_var1, cdata(:,1,1,1), Time, & + mask=clmask(:,1,1,1)) + used = send_data(id_var2, ddata(:,:,1,1), Time, & + is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, & + mask=dlmask(:,:,1,1)) + used = send_data(id_var3, ddata(:,:,:,1), Time, & + is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, & + mask=dlmask(:,:,:,1)) + end select + case (test_openmp) +!$OMP parallel do default(shared) private(iblock, isw, iew, jsw, jew, is1, ie1, js1, je1) + do iblock=1, 4 + isw = my_block%ibs(iblock) + jsw = my_block%jbs(iblock) + iew = my_block%ibe(iblock) + jew = my_block%jbe(iblock) + + !--- indices for 1-based arrays --- + is1 = isw-isc+1 + ie1 = iew-isc+1 + js1 = jsw-jsc+1 + je1 = jew-jsc+1 + + select case (mask_case) + case (no_mask) + used=send_data(id_var1, cdata(is1:ie1, 1, 1, 1), time, is_in=is1, ie_in=ie1) + used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1) + used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1) + case (real_mask) + used=send_data(id_var1, cdata(is1:ie1, 1, 1, 1), time, is_in=is1, ie_in=ie1, & + rmask=crmask(is1:ie1, 1, 1, 1)) + used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1, & + rmask=crmask(is1:ie1, js1:je1, 1, 1)) + used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1, & + rmask=crmask(is1:ie1, js1:je1, :, 1)) + case (logical_mask) + used=send_data(id_var1, cdata(is1:ie1, 1, 1, 1), time, is_in=is1, ie_in=ie1, & + mask=clmask(is1:ie1, 1, 1, 1)) + used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1, & + mask=clmask(is1:ie1, js1:je1, 1, 1)) + used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1, & + mask=clmask(is1:ie1, js1:je1, :, 1)) + end select + enddo + end select + + call diag_send_complete(Time_step) + enddo + + call diag_manager_end(Time) + + call fms_end + + contains + + !> @brief Allocate the logical mask based on the starting/ending indices + !! @return logical mask initiliazed to .True. + function allocate_logical_mask(is, ie, js, je, k, l) & + result(buffer) + integer, intent(in) :: is !< Starting x index + integer, intent(in) :: ie !< Ending x index + integer, intent(in) :: js !< Starting y index + integer, intent(in) :: je !< Ending y index + integer, intent(in) :: k !< Number of points in the 4th dimension + integer, intent(in) :: l !< Number of points in the 5th dimension + + logical, allocatable :: buffer(:,:,:,:) + + allocate(buffer(is:ie, js:je, 1:k, 1:l)) + buffer = .True. + end function allocate_logical_mask + + !> @brief Allocate the real mask based on the starting/ending indices + !! @returnreal mask initiliazed to 1_r8_kind + function allocate_real_mask(is, ie, js, je, k, l) & + result(buffer) + integer, intent(in) :: is !< Starting x index + integer, intent(in) :: ie !< Ending x index + integer, intent(in) :: js !< Starting y index + integer, intent(in) :: je !< Ending y index + integer, intent(in) :: k !< Number of points in the 4th dimension + integer, intent(in) :: l !< Number of points in the 5th dimension + real(kind=r8_kind), allocatable :: buffer(:,:,:,:) + + allocate(buffer(is:ie, js:je, 1:k, 1:l)) + buffer = 1.0_r8_kind + end function allocate_real_mask + + !> @brief initiliazed the buffer based on the starting/ending indices + subroutine init_buffer(buffer, is, ie, js, je, nhalo) + real(kind=r8_kind), intent(inout) :: buffer(:,:,:,:) !< output buffer + integer, intent(in) :: is !< Starting x index + integer, intent(in) :: ie !< Ending x index + integer, intent(in) :: js !< Starting y index + integer, intent(in) :: je !< Ending y index + integer, intent(in) :: nhalo !< Number of halos + + integer :: ii, j, k, l + + do ii = is, ie + do j = js, je + do k = 1, size(buffer, 3) + do l = 1, size(buffer,4) + buffer(ii-is+1+nhalo, j-js+1+nhalo, k, l) = real(ii, kind=r8_kind)* 1000_r8_kind + & + real(j, kind=r8_kind)* 10_r8_kind + & + real(k, kind=r8_kind) + enddo + enddo + enddo + enddo + + end subroutine init_buffer + + !> @brief Set the buffer based on the time_index + subroutine set_buffer(buffer, time_index) + real(kind=r8_kind), intent(inout) :: buffer(:,:,:,:) !< Output buffer + integer, intent(in) :: time_index !< Time index + + buffer = nint(buffer) + real(time_index, kind=r8_kind)/100_r8_kind + + end subroutine set_buffer + +end program test_reduction_methods diff --git a/test_fms/diag_manager/test_time_max.sh b/test_fms/diag_manager/test_time_max.sh new file mode 100755 index 0000000000..5a35179b2f --- /dev/null +++ b/test_fms/diag_manager/test_time_max.sh @@ -0,0 +1,132 @@ +#!/bin/sh + +#*********************************************************************** +#* 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 . +#*********************************************************************** + +# Copyright (c) 2019-2020 Ed Hartnett, Seth Underwood + +# Set common test settings. +. ../test-lib.sh + +if [ -z "${skipflag}" ]; then +# create and enter directory for in/output files +output_dir + +#TODO replace with yaml diag_table and set diag_manager_nml::use_modern_diag=.true. +cat <<_EOF > diag_table +test_max +2 1 1 0 0 0 + +"test_max", 6, "hours", 1, "hours", "time" +"test_max_regional", 6, "hours", 1, "hours", "time" + +"ocn_mod", "var0", "var0_max", "test_max", "all", "max", "none", 2 +"ocn_mod", "var1", "var1_max", "test_max", "all", "max", "none", 2 +"ocn_mod", "var2", "var2_max", "test_max", "all", "max", "none", 2 +"ocn_mod", "var3", "var3_max", "test_max", "all", "max", "none", 2 + +"ocn_mod", "var3", "var3_Z", "test_max", "all", "max", "-1 -1 -1 -1 2. 3.", 2 + +"ocn_mod", "var3", "var3_max", "test_max_regional", "all", "max", "78. 81. 78. 81. 2. 3.", 2 #chosen by MKL +_EOF + +my_test_count=1 +printf "&test_reduction_methods_nml \n test_case = 0 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' + +export OMP_NUM_THREADS=2 +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method with openmp (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method with openmp (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' +export OMP_NUM_THREADS=1 + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method with halo output (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method with halo output (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "max" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "max" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_max +' +fi +test_done \ No newline at end of file diff --git a/test_fms/diag_manager/test_time_min.sh b/test_fms/diag_manager/test_time_min.sh new file mode 100755 index 0000000000..7049dc6abb --- /dev/null +++ b/test_fms/diag_manager/test_time_min.sh @@ -0,0 +1,132 @@ +#!/bin/sh + +#*********************************************************************** +#* 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 . +#*********************************************************************** + +# Copyright (c) 2019-2020 Ed Hartnett, Seth Underwood + +# Set common test settings. +. ../test-lib.sh + +if [ -z "${skipflag}" ]; then +# create and enter directory for in/output files +output_dir + +#TODO replace with yaml diag_table and set diag_manager_nml::use_modern_diag=.true. +cat <<_EOF > diag_table +test_min +2 1 1 0 0 0 + +"test_min", 6, "hours", 1, "hours", "time" +"test_min_regional", 6, "hours", 1, "hours", "time" + +"ocn_mod", "var0", "var0_min", "test_min", "all", "min", "none", 2 +"ocn_mod", "var1", "var1_min", "test_min", "all", "min", "none", 2 +"ocn_mod", "var2", "var2_min", "test_min", "all", "min", "none", 2 +"ocn_mod", "var3", "var3_min", "test_min", "all", "min", "none", 2 + +"ocn_mod", "var3", "var3_Z", "test_min", "all", "min", "-1 -1 -1 -1 2. 3.", 2 + +"ocn_mod", "var3", "var3_min", "test_min_regional", "all", "min", "78. 81. 78. 81. 2. 3.", 2 #chosen by MKL +_EOF + +my_test_count=1 +printf "&test_reduction_methods_nml \n test_case = 0 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' + +export OMP_NUM_THREADS=2 +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method with openmp (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method with openmp (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' +export OMP_NUM_THREADS=1 + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method with halo output (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method with halo output (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "min" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "min" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_min +' +fi +test_done \ No newline at end of file diff --git a/test_fms/diag_manager/test_time_none.sh b/test_fms/diag_manager/test_time_none.sh new file mode 100755 index 0000000000..0de41c9f1b --- /dev/null +++ b/test_fms/diag_manager/test_time_none.sh @@ -0,0 +1,132 @@ +#!/bin/sh + +#*********************************************************************** +#* 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 . +#*********************************************************************** + +# Copyright (c) 2019-2020 Ed Hartnett, Seth Underwood + +# Set common test settings. +. ../test-lib.sh + +if [ -z "${skipflag}" ]; then +# create and enter directory for in/output files +output_dir + +#TODO replace with yaml diag_table and set diag_manager_nml::use_modern_diag=.true. +cat <<_EOF > diag_table +test_none +2 1 1 0 0 0 + +"test_none", 6, "hours", 1, "hours", "time" +"test_none_regional", 6, "hours", 1, "hours", "time" + +"ocn_mod", "var0", "var0_none", "test_none", "all", .false., "none", 2 +"ocn_mod", "var1", "var1_none", "test_none", "all", .false., "none", 2 +"ocn_mod", "var2", "var2_none", "test_none", "all", .false., "none", 2 +"ocn_mod", "var3", "var3_none", "test_none", "all", .false., "none", 2 + +"ocn_mod", "var3", "var3_Z", "test_none", "all", .false., "-1 -1 -1 -1 2. 3.", 2 + +"ocn_mod", "var3", "var3_none", "test_none_regional", "all", .false., "78. 81. 78. 81. 2. 3.", 2 #chosen by MKL +_EOF + +my_test_count=1 +printf "&test_reduction_methods_nml \n test_case = 0 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' + +export OMP_NUM_THREADS=2 +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method with openmp (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method with openmp (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' +export OMP_NUM_THREADS=1 + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method with halo output (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method with halo output (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' + +my_test_count=`expr $my_test_count + 1` +printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml +test_expect_success "Running diag_manager with "none" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "none" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' +fi +test_done \ No newline at end of file diff --git a/test_fms/diag_manager/testing_utils.F90 b/test_fms/diag_manager/testing_utils.F90 new file mode 100644 index 0000000000..45530fcc3e --- /dev/null +++ b/test_fms/diag_manager/testing_utils.F90 @@ -0,0 +1,53 @@ +!*********************************************************************** +!* 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 Utilities used in multiple test +module testing_utils + use platform_mod, only: r8_kind + private + + public :: allocate_buffer + public :: test_normal, test_openmp, test_halos + public :: no_mask, logical_mask, real_mask + + integer, parameter :: test_normal = 0 !< sending a buffer in the compute domain + integer, parameter :: test_openmp = 1 !< sending a buffer in the compute domain but with blocking + integer, parameter :: test_halos = 2 !< sending a buffer in the data domain (i.e with halos) + integer, parameter :: no_mask = 0 !< Not using a mask + integer, parameter :: logical_mask = 1 !< Using a logical mask + integer, parameter :: real_mask = 2 !< Using a real mask + + contains + + !> @brief Allocate the output buffer based on the starting/ending indices + !! @return output buffer set to -999_r8_kind + function allocate_buffer(is, ie, js, je, k, l) & + result(buffer) + integer, intent(in) :: is !< Starting x index + integer, intent(in) :: ie !< Ending x index + integer, intent(in) :: js !< Starting y index + integer, intent(in) :: je !< Ending y index + integer, intent(in) :: k !< Number of points in the 4th dimension + integer, intent(in) :: l !< Number of points in the 5th dimension + real(kind=r8_kind), allocatable :: buffer(:,:,:,:) + + allocate(buffer(is:ie, js:je, 1:k, 1:l)) + buffer = -999_r8_kind + end function allocate_buffer +end module