From 0717225ab7ce2153bcf40c44bef988702491f5b8 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 14 Aug 2023 14:30:28 -0400 Subject: [PATCH 01/33] Add tests and checks --- test_fms/diag_manager/Makefile.am | 13 +- test_fms/diag_manager/check_time_none.F90 | 209 +++++++++++ test_fms/diag_manager/test_diag_manager2.sh | 34 +- .../diag_manager/test_diag_update_buffer.F90 | 8 +- .../diag_manager/test_reduction_methods.F90 | 345 ++++++++++++++++++ .../diag_manager/test_reduction_methods.sh | 131 +++++++ test_fms/diag_manager/testing_utils.F90 | 53 +++ 7 files changed, 751 insertions(+), 42 deletions(-) create mode 100644 test_fms/diag_manager/check_time_none.F90 create mode 100644 test_fms/diag_manager/test_reduction_methods.F90 create mode 100755 test_fms/diag_manager/test_reduction_methods.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 ccc888a0dc..8cbbe2bee3 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -30,7 +30,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. check_PROGRAMS = test_diag_manager test_diag_manager_time \ test_diag_dlinked_list test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer \ - test_flexible_time test_diag_update_buffer test_dm_openmp + test_flexible_time test_diag_update_buffer test_reduction_methods check_time_none # This is the source code for the test. test_diag_manager_SOURCES = test_diag_manager.F90 @@ -42,17 +42,20 @@ 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 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_reduction_methods.sh + +testing_utils.mod: testing_utils.$(OBJEXT) # Copy over other needed files to the srcdir -EXTRA_DIST = test_diag_manager2.sh check_crashes.sh +EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_reduction_methods.sh if USING_YAML skipflag="" @@ -62,5 +65,5 @@ endif TESTS_ENVIRONMENT = skipflag=${skipflag} -CLEANFILES = *.yaml 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_none.F90 b/test_fms/diag_manager/check_time_none.F90 new file mode 100644 index 0000000000..b99ce264f3 --- /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 + logical :: use_mask + + 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 + real(kind=r4_kind) :: buffer_exp !< Expected result + integer, optional, intent(in) :: nx_offset + integer, optional, intent(in) :: ny_offset + integer, optional, intent(in) :: nz_offset + + integer :: ii, j, k, l !< For looping + integer :: nx_oset + integer :: ny_oset + integer :: nz_oset + + 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 ab17c34d4f..4f44ea7ffe 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -460,7 +460,6 @@ test_expect_success "Unstructured grid (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager ' my_test_count=`expr $my_test_count + 1` - # test_diag_manager_time cat <<_EOF > diag_table test_diag_manager @@ -479,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 +503,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 ' @@ -865,36 +863,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_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 index 9ca4f93198..67de3ec665 100644 --- a/test_fms/diag_manager/test_diag_update_buffer.F90 +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -282,12 +282,12 @@ SUBROUTINE init_field_values (field) DO k = 1, NZ DO j = 1, NY DO i = 1, NX - itemp = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) SELECT TYPE ( field) TYPE IS (real(kind=r4_kind)) - field(i,j,k,l) = real(itemp, kind=r4_kind) - TYPE IS (integer(kind=i8_kind)) - field(i,j,k,l) = int(itemp, kind=i8_kind) + itemp = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) + field(i,j,k,l) = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) +1 TYPE IS (integer(kind=i8_kind)) + field(i,j,k,l) = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) END SELECT END DO END DO 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..aa37d42ab1 --- /dev/null +++ b/test_fms/diag_manager/test_reduction_methods.F90 @@ -0,0 +1,345 @@ +!*********************************************************************** +!* 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 + + !< 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(isc, jsc, 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(isc, jsc, 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, & + is_in=isd1, ie_in=ied1, & + rmask=drmask(:,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, & + is_in=isd1, ie_in=ied1, & + mask=dlmask(:,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(isd1:ied1,jsd1:jed1,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_reduction_methods.sh b/test_fms/diag_manager/test_reduction_methods.sh new file mode 100755 index 0000000000..3e4ab411c0 --- /dev/null +++ b/test_fms/diag_manager/test_reduction_methods.sh @@ -0,0 +1,131 @@ +#!/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 + +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_failure "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_failure "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 From 394b9b460e6a60b315f8e1fb92ce0cb10952aa35 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 14 Aug 2023 15:09:53 -0400 Subject: [PATCH 02/33] minor update --- test_fms/diag_manager/test_reduction_methods.F90 | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90 index aa37d42ab1..522c798875 100644 --- a/test_fms/diag_manager/test_reduction_methods.F90 +++ b/test_fms/diag_manager/test_reduction_methods.F90 @@ -210,8 +210,7 @@ program test_reduction_methods 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, & - is_in=isd1, ie_in=ied1, & - rmask=drmask(:,1,1,1)) + 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)) @@ -220,11 +219,10 @@ program test_reduction_methods rmask=drmask(:,:,:,1)) case (logical_mask) used = send_data(id_var1, cdata(:,1,1,1), Time, & - is_in=isd1, ie_in=ied1, & - mask=dlmask(:,1,1,1)) + 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(isd1:ied1,jsd1:jed1,1,1)) + 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)) From 026c0f94f62c44fdad71f1190f761a1ee50ce808 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 14 Aug 2023 16:53:29 -0400 Subject: [PATCH 03/33] fixes for halo tests --- test_fms/diag_manager/test_reduction_methods.F90 | 4 ++-- test_fms/diag_manager/test_reduction_methods.sh | 5 +++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90 index 522c798875..b60a8ca409 100644 --- a/test_fms/diag_manager/test_reduction_methods.F90 +++ b/test_fms/diag_manager/test_reduction_methods.F90 @@ -137,7 +137,7 @@ program test_reduction_methods if (test_case .eq. test_halos) then dlmask = allocate_logical_mask(isd, ied, jsd, jed, nz, nw) - if (mpp_pe() .eq. 0) dlmask(isc, jsc, 1, 1) = .False. + 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) @@ -145,7 +145,7 @@ program test_reduction_methods if (test_case .eq. test_halos) then drmask = allocate_real_mask(isd, ied, jsd, jed, nz, nw) - if (mpp_pe() .eq. 0) drmask(isc, jsc, 1, 1) = 0_r8_kind + if (mpp_pe() .eq. 0) drmask(1+nhalox, 1+nhaloy, 1, 1) = 0_r8_kind endif end select diff --git a/test_fms/diag_manager/test_reduction_methods.sh b/test_fms/diag_manager/test_reduction_methods.sh index 3e4ab411c0..0de41c9f1b 100755 --- a/test_fms/diag_manager/test_reduction_methods.sh +++ b/test_fms/diag_manager/test_reduction_methods.sh @@ -28,6 +28,7 @@ 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 @@ -115,7 +116,7 @@ printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | 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_failure "Checking answers for the "none" reduction method with halo output with logical mask (test $my_test_count)" ' +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 ' @@ -124,7 +125,7 @@ printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | 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_failure "Checking answers for the "none" reduction method with halo output with real mask (test $my_test_count)" ' +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 From 608744f45d1f3aa183bcef5f98a378caab6c7102 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Tue, 15 Aug 2023 10:52:38 -0400 Subject: [PATCH 04/33] rename test script to test_time_none --- test_fms/diag_manager/Makefile.am | 4 ++-- .../{test_reduction_methods.sh => test_time_none.sh} | 0 2 files changed, 2 insertions(+), 2 deletions(-) rename test_fms/diag_manager/{test_reduction_methods.sh => test_time_none.sh} (100%) diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index 8cbbe2bee3..d96ede52b9 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -50,12 +50,12 @@ 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 test_reduction_methods.sh +TESTS = test_diag_manager2.sh test_time_none.sh testing_utils.mod: testing_utils.$(OBJEXT) # Copy over other needed files to the srcdir -EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_reduction_methods.sh +EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh if USING_YAML skipflag="" diff --git a/test_fms/diag_manager/test_reduction_methods.sh b/test_fms/diag_manager/test_time_none.sh similarity index 100% rename from test_fms/diag_manager/test_reduction_methods.sh rename to test_fms/diag_manager/test_time_none.sh From 65f6541051df69d5e43a6c4f3cca3ea8f7b131c0 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Tue, 15 Aug 2023 11:42:46 -0400 Subject: [PATCH 05/33] add min tests --- test_fms/diag_manager/Makefile.am | 8 +- test_fms/diag_manager/check_time_min.F90 | 209 +++++++++++++++++++++++ test_fms/diag_manager/test_time_min.sh | 132 ++++++++++++++ 3 files changed, 346 insertions(+), 3 deletions(-) create mode 100644 test_fms/diag_manager/check_time_min.F90 create mode 100755 test_fms/diag_manager/test_time_min.sh diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index d96ede52b9..40cf764ae4 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -30,7 +30,8 @@ LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. check_PROGRAMS = test_diag_manager test_diag_manager_time \ 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 + test_flexible_time test_diag_update_buffer test_reduction_methods check_time_none \ + check_time_min # This is the source code for the test. test_diag_manager_SOURCES = test_diag_manager.F90 @@ -44,18 +45,19 @@ test_diag_buffer_SOURCES= test_diag_buffer.F90 test_flexible_time_SOURCES = test_flexible_time.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 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 test_time_none.sh +TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh testing_utils.mod: testing_utils.$(OBJEXT) # Copy over other needed files to the srcdir -EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh +EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh if USING_YAML skipflag="" 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..65702bff5d --- /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 + logical :: use_mask + + 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 + real(kind=r4_kind) :: buffer_exp !< Expected result + integer, optional, intent(in) :: nx_offset + integer, optional, intent(in) :: ny_offset + integer, optional, intent(in) :: nz_offset + + integer :: ii, j, k, l !< For looping + integer :: nx_oset + integer :: ny_oset + integer :: nz_oset + + 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/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 From 80b3897e02a30325c28f666ec51587c5d551d860 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Tue, 15 Aug 2023 12:24:48 -0400 Subject: [PATCH 06/33] add tests for time_max --- test_fms/diag_manager/Makefile.am | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index 40cf764ae4..2945e60ab6 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -31,7 +31,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la check_PROGRAMS = test_diag_manager test_diag_manager_time \ 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_min check_time_max # This is the source code for the test. test_diag_manager_SOURCES = test_diag_manager.F90 @@ -46,13 +46,14 @@ test_flexible_time_SOURCES = test_flexible_time.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 test_time_none.sh test_time_min.sh +TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh testing_utils.mod: testing_utils.$(OBJEXT) From da6c92b81e09b609f1aabe5bbd5b1ea8083dd15f Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Tue, 15 Aug 2023 12:26:18 -0400 Subject: [PATCH 07/33] forgot to git add the new files --- test_fms/diag_manager/check_time_max.F90 | 209 +++++++++++++++++++++++ test_fms/diag_manager/test_time_max.sh | 132 ++++++++++++++ 2 files changed, 341 insertions(+) create mode 100644 test_fms/diag_manager/check_time_max.F90 create mode 100755 test_fms/diag_manager/test_time_max.sh 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..08f3b8302e --- /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 + logical :: use_mask + + 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 + real(kind=r4_kind) :: buffer_exp !< Expected result + integer, optional, intent(in) :: nx_offset + integer, optional, intent(in) :: ny_offset + integer, optional, intent(in) :: nz_offset + + integer :: ii, j, k, l !< For looping + integer :: nx_oset + integer :: ny_oset + integer :: nz_oset + + 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/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 From 2a5067b1bd720e6baa2a04c06a270656a0368cf1 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Tue, 15 Aug 2023 13:39:19 -0400 Subject: [PATCH 08/33] Attempt to add a time_sum test. Needs some work as some tests are failing --- test_fms/diag_manager/Makefile.am | 9 +- test_fms/diag_manager/check_time_sum.F90 | 219 +++++++++++++++++++++++ test_fms/diag_manager/test_time_sum.sh | 132 ++++++++++++++ 3 files changed, 357 insertions(+), 3 deletions(-) create mode 100644 test_fms/diag_manager/check_time_sum.F90 create mode 100755 test_fms/diag_manager/test_time_sum.sh diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index 2945e60ab6..7acc41fa22 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -31,7 +31,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la check_PROGRAMS = test_diag_manager test_diag_manager_time \ 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 + check_time_min check_time_max check_time_sum # This is the source code for the test. test_diag_manager_SOURCES = test_diag_manager.F90 @@ -47,18 +47,21 @@ 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 +check_time_sum_SOURCES = testing_utils.F90 check_time_sum.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 test_time_none.sh test_time_min.sh test_time_max.sh +TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh \ + test_time_sum.sh testing_utils.mod: testing_utils.$(OBJEXT) # Copy over other needed files to the srcdir -EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh +EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh \ + test_time_sum.sh if USING_YAML skipflag="" diff --git a/test_fms/diag_manager/check_time_sum.F90 b/test_fms/diag_manager/check_time_sum.F90 new file mode 100644 index 0000000000..847a0deedc --- /dev/null +++ b/test_fms/diag_manager/check_time_sum.F90 @@ -0,0 +1,219 @@ +!*********************************************************************** +!* 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 "sum" reduction method +program check_time_sum + 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 + logical :: use_mask + + 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_sum.nc", "read")) & + call mpp_error(FATAL, "unable to open file") + + if (.not. open_file(fileobj1, "test_sum_regional.nc.0004", "read")) & + call mpp_error(FATAL, "unable to open file") + + if (.not. open_file(fileobj2, "test_sum_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_sum - time_level:", string(i) + call read_data(fileobj, "var0_sum", 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_sum - time_level:", string(i) + call read_data(fileobj, "var1_sum", 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_sum - time_level:", string(i) + call read_data(fileobj, "var2_sum", 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_sum - time_level:", string(i) + call read_data(fileobj, "var3_sum", 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_sum - time_level:", string(i) + call read_data(fileobj, "var3_Z_sum", 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_sum in the first regional file- time_level:", string(i) + call read_data(fileobj1, "var3_sum", 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_sum in the second regional file- time_level:", string(i) + call read_data(fileobj2, "var3_sum", 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 + integer function basic_math(time_level) + integer, intent(in) :: time_level + + integer :: ii + + basic_math = 0 + do ii = (time_level-1)*6+1, time_level*6 + basic_math = basic_math + ii + enddo + end function + + !> @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)* 6_r8_kind + & + real(basic_math(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_sum::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)*6_r8_kind + & + real(basic_math(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_sum::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)*6_r8_kind + & + real(basic_math(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_sum::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 + real(kind=r4_kind) :: buffer_exp !< Expected result + integer, optional, intent(in) :: nx_offset + integer, optional, intent(in) :: ny_offset + integer, optional, intent(in) :: nz_offset + + integer :: ii, j, k, l !< For looping + integer :: nx_oset + integer :: ny_oset + integer :: nz_oset + + 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))*6_r8_kind + & + real(basic_math(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_sum::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/test_time_sum.sh b/test_fms/diag_manager/test_time_sum.sh new file mode 100755 index 0000000000..f86fad0cbb --- /dev/null +++ b/test_fms/diag_manager/test_time_sum.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_sum +2 1 1 0 0 0 + +"test_sum", 6, "hours", 1, "hours", "time" +"test_sum_regional", 6, "hours", 1, "hours", "time" + +"ocn_mod", "var0", "var0_sum", "test_sum", "all", "sum", "none", 2 +"ocn_mod", "var1", "var1_sum", "test_sum", "all", "sum", "none", 2 +"ocn_mod", "var2", "var2_sum", "test_sum", "all", "sum", "none", 2 +"ocn_mod", "var3", "var3_sum", "test_sum", "all", "sum", "none", 2 + +"ocn_mod", "var3", "var3_Z", "test_sum", "all", "sum", "-1 -1 -1 -1 2. 3.", 2 + +"ocn_mod", "var3", "var3_sum", "test_sum_regional", "all", "sum", "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 "sum" reduction method (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "sum" reduction method (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' + +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 "sum" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_failure "Checking answers for the "sum" reduction method, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' + +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 "sum" reduction method, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_failure "Checking answers for the "sum" reduction method, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' + +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 "sum" reduction method with openmp (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_failure "Checking answers for the "sum" reduction method with openmp (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' + +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 "sum" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_failure "Checking answers for the "sum" reduction method with openmp, logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' + +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 "sum" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_failure "Checking answers for the "sum" reduction method with openmp, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' +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 "sum" reduction method with halo output (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_success "Checking answers for the "sum" reduction method with halo output (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' + +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 "sum" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_failure "Checking answers for the "sum" reduction method with halo output with logical mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' + +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 "sum" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 6 ../test_reduction_methods +' +test_expect_failure "Checking answers for the "sum" reduction method with halo output with real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_sum +' +fi +test_done \ No newline at end of file From 0b9113a21c5a6e3a263d1da0de42fce0784e24d5 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Tue, 15 Aug 2023 14:03:49 -0400 Subject: [PATCH 09/33] Revert "Attempt to add a time_sum test. Needs some work as some tests are failing" This reverts commit 2a5067b1bd720e6baa2a04c06a270656a0368cf1. --- test_fms/diag_manager/Makefile.am | 9 +- test_fms/diag_manager/check_time_sum.F90 | 219 ----------------------- test_fms/diag_manager/test_time_sum.sh | 132 -------------- 3 files changed, 3 insertions(+), 357 deletions(-) delete mode 100644 test_fms/diag_manager/check_time_sum.F90 delete mode 100755 test_fms/diag_manager/test_time_sum.sh diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index 7acc41fa22..2945e60ab6 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -31,7 +31,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la check_PROGRAMS = test_diag_manager test_diag_manager_time \ 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 check_time_sum + check_time_min check_time_max # This is the source code for the test. test_diag_manager_SOURCES = test_diag_manager.F90 @@ -47,21 +47,18 @@ 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 -check_time_sum_SOURCES = testing_utils.F90 check_time_sum.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 test_time_none.sh test_time_min.sh test_time_max.sh \ - test_time_sum.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 = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh \ - test_time_sum.sh +EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh if USING_YAML skipflag="" diff --git a/test_fms/diag_manager/check_time_sum.F90 b/test_fms/diag_manager/check_time_sum.F90 deleted file mode 100644 index 847a0deedc..0000000000 --- a/test_fms/diag_manager/check_time_sum.F90 +++ /dev/null @@ -1,219 +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 Checks the output file after running test_reduction_methods using the "sum" reduction method -program check_time_sum - 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 - logical :: use_mask - - 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_sum.nc", "read")) & - call mpp_error(FATAL, "unable to open file") - - if (.not. open_file(fileobj1, "test_sum_regional.nc.0004", "read")) & - call mpp_error(FATAL, "unable to open file") - - if (.not. open_file(fileobj2, "test_sum_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_sum - time_level:", string(i) - call read_data(fileobj, "var0_sum", 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_sum - time_level:", string(i) - call read_data(fileobj, "var1_sum", 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_sum - time_level:", string(i) - call read_data(fileobj, "var2_sum", 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_sum - time_level:", string(i) - call read_data(fileobj, "var3_sum", 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_sum - time_level:", string(i) - call read_data(fileobj, "var3_Z_sum", 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_sum in the first regional file- time_level:", string(i) - call read_data(fileobj1, "var3_sum", 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_sum in the second regional file- time_level:", string(i) - call read_data(fileobj2, "var3_sum", 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 - integer function basic_math(time_level) - integer, intent(in) :: time_level - - integer :: ii - - basic_math = 0 - do ii = (time_level-1)*6+1, time_level*6 - basic_math = basic_math + ii - enddo - end function - - !> @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)* 6_r8_kind + & - real(basic_math(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_sum::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)*6_r8_kind + & - real(basic_math(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_sum::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)*6_r8_kind + & - real(basic_math(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_sum::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 - real(kind=r4_kind) :: buffer_exp !< Expected result - integer, optional, intent(in) :: nx_offset - integer, optional, intent(in) :: ny_offset - integer, optional, intent(in) :: nz_offset - - integer :: ii, j, k, l !< For looping - integer :: nx_oset - integer :: ny_oset - integer :: nz_oset - - 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))*6_r8_kind + & - real(basic_math(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_sum::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/test_time_sum.sh b/test_fms/diag_manager/test_time_sum.sh deleted file mode 100755 index f86fad0cbb..0000000000 --- a/test_fms/diag_manager/test_time_sum.sh +++ /dev/null @@ -1,132 +0,0 @@ -#!/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_sum -2 1 1 0 0 0 - -"test_sum", 6, "hours", 1, "hours", "time" -"test_sum_regional", 6, "hours", 1, "hours", "time" - -"ocn_mod", "var0", "var0_sum", "test_sum", "all", "sum", "none", 2 -"ocn_mod", "var1", "var1_sum", "test_sum", "all", "sum", "none", 2 -"ocn_mod", "var2", "var2_sum", "test_sum", "all", "sum", "none", 2 -"ocn_mod", "var3", "var3_sum", "test_sum", "all", "sum", "none", 2 - -"ocn_mod", "var3", "var3_Z", "test_sum", "all", "sum", "-1 -1 -1 -1 2. 3.", 2 - -"ocn_mod", "var3", "var3_sum", "test_sum_regional", "all", "sum", "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 "sum" reduction method (test $my_test_count)" ' - mpirun -n 6 ../test_reduction_methods -' -test_expect_success "Checking answers for the "sum" reduction method (test $my_test_count)" ' - mpirun -n 1 ../check_time_sum -' - -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 "sum" reduction method, logical mask (test $my_test_count)" ' - mpirun -n 6 ../test_reduction_methods -' -test_expect_failure "Checking answers for the "sum" reduction method, logical mask (test $my_test_count)" ' - mpirun -n 1 ../check_time_sum -' - -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 "sum" reduction method, real mask (test $my_test_count)" ' - mpirun -n 6 ../test_reduction_methods -' -test_expect_failure "Checking answers for the "sum" reduction method, real mask (test $my_test_count)" ' - mpirun -n 1 ../check_time_sum -' - -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 "sum" reduction method with openmp (test $my_test_count)" ' - mpirun -n 6 ../test_reduction_methods -' -test_expect_failure "Checking answers for the "sum" reduction method with openmp (test $my_test_count)" ' - mpirun -n 1 ../check_time_sum -' - -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 "sum" reduction method with openmp, logical mask (test $my_test_count)" ' - mpirun -n 6 ../test_reduction_methods -' -test_expect_failure "Checking answers for the "sum" reduction method with openmp, logical mask (test $my_test_count)" ' - mpirun -n 1 ../check_time_sum -' - -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 "sum" reduction method with openmp, real mask (test $my_test_count)" ' - mpirun -n 6 ../test_reduction_methods -' -test_expect_failure "Checking answers for the "sum" reduction method with openmp, real mask (test $my_test_count)" ' - mpirun -n 1 ../check_time_sum -' -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 "sum" reduction method with halo output (test $my_test_count)" ' - mpirun -n 6 ../test_reduction_methods -' -test_expect_success "Checking answers for the "sum" reduction method with halo output (test $my_test_count)" ' - mpirun -n 1 ../check_time_sum -' - -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 "sum" reduction method with halo output with logical mask (test $my_test_count)" ' - mpirun -n 6 ../test_reduction_methods -' -test_expect_failure "Checking answers for the "sum" reduction method with halo output with logical mask (test $my_test_count)" ' - mpirun -n 1 ../check_time_sum -' - -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 "sum" reduction method with halo output with real mask (test $my_test_count)" ' - mpirun -n 6 ../test_reduction_methods -' -test_expect_failure "Checking answers for the "sum" reduction method with halo output with real mask (test $my_test_count)" ' - mpirun -n 1 ../check_time_sum -' -fi -test_done \ No newline at end of file From 1f9cc028f1097ab2e541084b382217572c8ecd5f Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Tue, 15 Aug 2023 14:18:55 -0400 Subject: [PATCH 10/33] rever change to test_diag_update_buffer --- test_fms/diag_manager/test_diag_update_buffer.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 index 67de3ec665..9ca4f93198 100644 --- a/test_fms/diag_manager/test_diag_update_buffer.F90 +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -282,12 +282,12 @@ SUBROUTINE init_field_values (field) DO k = 1, NZ DO j = 1, NY DO i = 1, NX + itemp = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) SELECT TYPE ( field) TYPE IS (real(kind=r4_kind)) - itemp = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) - field(i,j,k,l) = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) -1 TYPE IS (integer(kind=i8_kind)) - field(i,j,k,l) = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) + field(i,j,k,l) = real(itemp, kind=r4_kind) + TYPE IS (integer(kind=i8_kind)) + field(i,j,k,l) = int(itemp, kind=i8_kind) END SELECT END DO END DO From ad47337018bcca96454596527175730bba3922c4 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Tue, 15 Aug 2023 14:22:53 -0400 Subject: [PATCH 11/33] remove test_dm_openmp as it is not necessary anymore --- test_fms/diag_manager/test_dm_openmp.F90 | 149 ----------------------- 1 file changed, 149 deletions(-) delete mode 100644 test_fms/diag_manager/test_dm_openmp.F90 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 From 675f37a3ce507bcb1620db07d4d4bffed0eeaf4f Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Tue, 15 Aug 2023 14:25:55 -0400 Subject: [PATCH 12/33] minor documentation updates --- test_fms/diag_manager/check_time_max.F90 | 18 +++++++++--------- test_fms/diag_manager/check_time_min.F90 | 18 +++++++++--------- test_fms/diag_manager/check_time_none.F90 | 18 +++++++++--------- .../diag_manager/test_reduction_methods.F90 | 2 +- 4 files changed, 28 insertions(+), 28 deletions(-) diff --git a/test_fms/diag_manager/check_time_max.F90 b/test_fms/diag_manager/check_time_max.F90 index 08f3b8302e..b8e82f3472 100644 --- a/test_fms/diag_manager/check_time_max.F90 +++ b/test_fms/diag_manager/check_time_max.F90 @@ -34,8 +34,8 @@ program check_time_max 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 - logical :: use_mask + 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 @@ -170,16 +170,16 @@ end subroutine check_data_2d 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 + 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 - integer, optional, intent(in) :: ny_offset - integer, optional, intent(in) :: nz_offset + 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 - integer :: ny_oset - integer :: nz_oset + 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 diff --git a/test_fms/diag_manager/check_time_min.F90 b/test_fms/diag_manager/check_time_min.F90 index 65702bff5d..f0d8f8029d 100644 --- a/test_fms/diag_manager/check_time_min.F90 +++ b/test_fms/diag_manager/check_time_min.F90 @@ -34,8 +34,8 @@ program check_time_min 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 - logical :: use_mask + 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 @@ -170,16 +170,16 @@ end subroutine check_data_2d 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 + 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 - integer, optional, intent(in) :: ny_offset - integer, optional, intent(in) :: nz_offset + 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 - integer :: ny_oset - integer :: nz_oset + 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 diff --git a/test_fms/diag_manager/check_time_none.F90 b/test_fms/diag_manager/check_time_none.F90 index b99ce264f3..11844448c0 100644 --- a/test_fms/diag_manager/check_time_none.F90 +++ b/test_fms/diag_manager/check_time_none.F90 @@ -34,8 +34,8 @@ program check_time_none 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 - logical :: use_mask + 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 @@ -170,16 +170,16 @@ end subroutine check_data_2d 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 + 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 - integer, optional, intent(in) :: ny_offset - integer, optional, intent(in) :: nz_offset + 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 - integer :: ny_oset - integer :: nz_oset + 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 diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90 index b60a8ca409..3f85a043f0 100644 --- a/test_fms/diag_manager/test_reduction_methods.F90 +++ b/test_fms/diag_manager/test_reduction_methods.F90 @@ -81,7 +81,7 @@ program test_reduction_methods 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 + real(kind=r8_kind) :: missing_value !< Missing value to use !< Configuration parameters integer :: test_case = test_normal !< Indicates which test case to run From c3bc53a86d1d009f1e870ec34ce437f92953bd3e Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Tue, 15 Aug 2023 14:59:35 -0400 Subject: [PATCH 13/33] add missing script to DIST --- test_fms/diag_manager/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index 2945e60ab6..de682cc7ee 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -58,7 +58,7 @@ TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.s testing_utils.mod: testing_utils.$(OBJEXT) # Copy over other needed files to the srcdir -EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.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="" From d2a981125c9d4bd68ced90f824f51b1266eb7a3f Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Tue, 15 Aug 2023 18:00:12 -0400 Subject: [PATCH 14/33] pushing for the day, tries to implement time_none --- diag_manager/Makefile.am | 17 +++- diag_manager/fms_diag_object.F90 | 93 ++++++++++++++----- diag_manager/fms_diag_output_buffer.F90 | 23 +++++ diag_manager/fms_diag_reduction_methods.F90 | 9 ++ .../include/fms_diag_reduction_methods.inc | 40 ++++++++ .../include/fms_diag_reduction_methods_r4.fh | 32 +++++++ .../include/fms_diag_reduction_methods_r8.fh | 32 +++++++ test_fms/diag_manager/Makefile.am | 2 +- test_fms/diag_manager/test_time_none.sh | 51 +++++++++- 9 files changed, 267 insertions(+), 32 deletions(-) create mode 100644 diag_manager/include/fms_diag_reduction_methods.inc create mode 100644 diag_manager/include/fms_diag_reduction_methods_r4.fh create mode 100644 diag_manager/include/fms_diag_reduction_methods_r8.fh diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index acf839f025..4a482b1d49 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -54,7 +54,10 @@ libdiag_manager_la_SOURCES = \ fms_diag_bbox.F90 \ fms_diag_reduction_methods.F90 \ include/fms_diag_fieldbuff_update.inc \ - include/fms_diag_fieldbuff_update.fh + include/fms_diag_fieldbuff_update.fh \ + include/fms_diag_reduction_methods.inc \ + include/fms_diag_reduction_methods_r4.fh \ + include/fms_diag_reduction_methods_r8.fh # Some mods are dependant on other mods in this dir. diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT) @@ -68,7 +71,8 @@ fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \ fms_diag_time_utils_mod.$(FC_MODEXT) \ fms_diag_output_buffer_mod.$(FC_MODEXT) \ - fms_diag_reduction_methods_mod.$(FC_MODEXT) + fms_diag_reduction_methods_mod.$(FC_MODEXT) \ + fms_diag_bbox_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \ fms_diag_axis_object_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \ @@ -76,7 +80,7 @@ fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_ fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \ diag_grid_mod.$(FC_MODEXT) -fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) +fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ @@ -89,7 +93,8 @@ diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MOD fms_diag_object_container_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT) \ fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ fms_diag_fieldbuff_update_mod.$(FC_MODEXT) -fms_diag_output_buffer_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) +fms_diag_output_buffer_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \ + fms_diag_reduction_methods_mod.$(FC_MODEXT) fms_diag_reduction_methods_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT) fms_diag_output_buffer_mod.$(FC_MODEXT) \ diag_data_mod.$(FC_MODEXT) @@ -118,7 +123,9 @@ MODFILES = \ fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \ fms_diag_reduction_methods_mod.$(FC_MODEXT) \ include/fms_diag_fieldbuff_update.inc \ - include/fms_diag_fieldbuff_update.fh + include/fms_diag_fieldbuff_update.fh \ + include/fms_diag_reduction_methods_r4.fh \ + include/fms_diag_reduction_methods_r8.fh nodist_include_HEADERS = $(MODFILES) BUILT_SOURCES = $(MODFILES) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 789b6e55e6..926880be98 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -20,7 +20,9 @@ module fms_diag_object_mod use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe, stdout use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, & &DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, & - &get_base_time, NULL_AXIS_ID, get_var_type, diag_not_registered + &get_base_time, NULL_AXIS_ID, get_var_type, diag_not_registered, & + &time_none, time_max, time_min, time_sum, time_average, time_diurnal, & + &time_power, time_rms USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, & @@ -38,6 +40,7 @@ module fms_diag_object_mod use fms_mod, only: fms_error_handler use fms_diag_reduction_methods_mod, only: check_indices_order, init_mask, set_weight use constants_mod, only: SECONDS_PER_DAY +USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type #endif #if defined(_OPENMP) use omp_lib @@ -504,7 +507,6 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm integer :: is, js, ks !< Starting indicies of the field_data integer :: ie, je, ke !< Ending indicies of the field_data - integer :: n1, n2, n3 !< Size of the 3 indicies of the field data integer :: omp_num_threads !< Number of openmp threads integer :: omp_level !< The openmp active level logical :: buffer_the_data !< True if the user selects to buffer the data and run @@ -516,6 +518,7 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm logical, allocatable, dimension(:,:,:,:) :: oor_mask !< Out of range mask real(kind=r8_kind) :: field_weight !< Weight to use when averaging (it will be converted !! based on the type of field_data when doing the math) + type(fmsDiagIbounds_type) :: bounds !< Bounds (starting ending indices) for the field #ifndef use_yaml CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") @@ -560,26 +563,23 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm buffer_the_data = (omp_num_threads > 1 .AND. omp_level > 0) #endif + !> Calculate the i,j,k start and end + ! If is, js, or ks not present default them to 1 + is = 1 + js = 1 + ks = 1 + IF ( PRESENT(is_in) ) is = is_in + IF ( PRESENT(js_in) ) js = js_in + IF ( PRESENT(ks_in) ) ks = ks_in + ie = is+SIZE(field_data, 1)-1 + je = js+SIZE(field_data, 2)-1 + ke = ks+SIZE(field_data, 3)-1 + IF ( PRESENT(ie_in) ) ie = ie_in + IF ( PRESENT(je_in) ) je = je_in + IF ( PRESENT(ke_in) ) ke = ke_in + !If this is true, buffer data main_if: if (buffer_the_data) then - !> Calculate the i,j,k start and end - ! If is, js, or ks not present default them to 1 - is = 1 - js = 1 - ks = 1 - IF ( PRESENT(is_in) ) is = is_in - IF ( PRESENT(js_in) ) js = js_in - IF ( PRESENT(ks_in) ) ks = ks_in - n1 = SIZE(field_data, 1) - n2 = SIZE(field_data, 2) - n3 = SIZE(field_data, 3) - ie = is+n1-1 - je = js+n2-1 - ke = ks+n3-1 - IF ( PRESENT(ie_in) ) ie = ie_in - IF ( PRESENT(je_in) ) je = je_in - IF ( PRESENT(ke_in) ) ke = ke_in - !> Only 1 thread allocates the output buffer and sets set_math_needs_to_be_done !$omp critical if (.not. this%FMS_diag_fields(diag_field_id)%is_data_buffer_allocated()) then @@ -595,9 +595,11 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm fms_diag_accept_data = .TRUE. return else + call bounds%reset(999,-999) + call bounds%update_bounds(is, ie, js, je, ks, ke) !TODO may need more updates for halos call this%allocate_diag_field_output_buffers(field_data, diag_field_id) fms_diag_accept_data = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, field_weight, & - time, is, js, ks, ie, je, ke) + bounds, Time=Time) call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.) return end if main_if @@ -718,18 +720,59 @@ end subroutine fms_diag_do_io !! based on the specified reduction method for the field. !> @return .True. if no error occurs. logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight, & - time, is_in, js_in, ks_in, ie_in, je_in, ke_in) + bounds, time) class(fmsDiagObject_type), intent(in), target :: this !< Diag Object class(*), intent(in) :: field_data(:,:,:,:) !< Field data integer, intent(in) :: diag_field_id !< ID of the input field logical, intent(in), target :: oor_mask(:,:,:,:) !< mask real(kind=r8_kind), intent(in) :: weight !< Must be a updated weight + type(fmsDiagIbounds_type), intent(in) :: bounds !< Bounds for the field type(time_type), intent(in), optional :: time !< Current time - integer, intent(in), optional :: is_in, js_in, ks_in !< Starting indices of the variable - integer, intent(in), optional :: ie_in, je_in, ke_in !< Ending indices of the variable - !TODO Everything + !TODO Mostly everything +#ifdef use_yaml + type(fmsDiagField_type), pointer :: field_ptr !< Pointer to the field's object + type(fmsDiagOutputBuffer_type), pointer :: buffer_ptr !< Pointer to the field's buffer + class(fmsDiagFileContainer_type), pointer :: file_ptr !< Pointer to the field's file + type(diagYamlFilesVar_type), pointer :: field_yaml_ptr !< Pointer to the field's yaml + + integer :: reduction_method !< Integer representing a reduction method + integer :: ids !< For looping through buffer ids + integer :: buffer_id !< Id of the buffer + integer :: file_id !< File id + character(len=50) :: error_msg !< Error message to check + + !TODO mostly everything + field_ptr => this%FMS_diag_fields(diag_field_id) + do ids = 1, size(field_ptr%buffer_ids) + error_msg = "" + !< Gather all the objects needed for the buffer + field_yaml_ptr => field_ptr%diag_field(ids) + buffer_id = this%FMS_diag_fields(diag_field_id)%buffer_ids(ids) + buffer_ptr => this%FMS_diag_output_buffers(buffer_id) + file_id = this%FMS_diag_fields(diag_field_id)%file_ids(ids) !TODO not sure if this is correct + file_ptr => this%FMS_diag_files(file_id) + + !< Reset the bounds based on the reduced k range and subregional + + !< Determine the reduction method for the buffer + reduction_method = field_yaml_ptr%get_var_reduction() + select case(reduction_method) + case (time_none) + error_msg = buffer_ptr%do_time_none_wrapper(field_data, oor_mask, bounds) + case (time_min) + case (time_max) + case (time_sum) + case (time_power) + case (time_rms) + case (time_diurnal) + end select + enddo fms_diag_do_reduction = .true. +#else + fms_diag_do_reduction = .false. + CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#endif end function fms_diag_do_reduction !> @brief Adds the diag ids of the Area and or Volume of the diag_field_object diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90 index f23d6ea3d7..6f23214ff5 100644 --- a/diag_manager/fms_diag_output_buffer.F90 +++ b/diag_manager/fms_diag_output_buffer.F90 @@ -32,6 +32,8 @@ module fms_diag_output_buffer_mod use diag_data_mod, only: DIAG_NULL, DIAG_NOT_REGISTERED, i4, i8, r4, r8 use fms2_io_mod, only: FmsNetcdfFile_t, write_data, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t use fms_diag_yaml_mod, only: diag_yaml +use fms_diag_bbox_mod, only: fmsDiagIbounds_type +use fms_diag_reduction_methods_mod, only: do_time_none implicit none @@ -68,6 +70,7 @@ module fms_diag_output_buffer_mod procedure :: initialize_buffer procedure :: get_buffer procedure :: flush_buffer + procedure :: do_time_none_wrapper end type fmsDiagOutputBuffer_type @@ -432,5 +435,25 @@ subroutine write_buffer_wrapper_u(this, fms2io_fileobj, unlim_dim_level) call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level) end select end subroutine write_buffer_wrapper_u + +function do_time_none_wrapper(this, field_data, mask, bounds) & + result(err_msg) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write + class(*), intent(in) :: field_data(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + character(len=50) :: err_msg + + type(fmsDiagIbounds_type), intent(in) :: bounds + + err_msg = "" + select type (output_buffer => this%buffer) + type is (real(kind=r8_kind)) + select type (field_data) + type is (real(kind=r8_kind)) + err_msg=do_time_none(output_buffer, field_data, mask, bounds) + end select + end select + +end function do_time_none_wrapper #endif end module fms_diag_output_buffer_mod diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 8962638c04..8d3b12ef54 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -29,10 +29,16 @@ !> @{ module fms_diag_reduction_methods_mod use platform_mod, only: r8_kind, r4_kind + use fms_diag_bbox_mod, only: fmsDiagIbounds_type implicit none private public :: check_indices_order, init_mask, set_weight + public :: do_time_none + + interface do_time_none + module procedure do_time_none_r4, do_time_none_r8 + end interface do_time_none contains @@ -124,6 +130,9 @@ pure function set_weight(weight) & endif end function set_weight +#include "fms_diag_reduction_methods_r4.fh" +#include "fms_diag_reduction_methods_r8.fh" + end module fms_diag_reduction_methods_mod !> @} ! close documentation grouping \ No newline at end of file diff --git a/diag_manager/include/fms_diag_reduction_methods.inc b/diag_manager/include/fms_diag_reduction_methods.inc new file mode 100644 index 0000000000..ca447ce825 --- /dev/null +++ b/diag_manager/include/fms_diag_reduction_methods.inc @@ -0,0 +1,40 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +function DO_TIME_NONE_ (data_out, data_in, mask, bounds) & +result(error_msg) + real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) + real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) + logical, intent(in) :: mask(:,:,:,:) + type(fmsDiagIbounds_type), intent(in) :: bounds + + character(len=50) :: error_msg + integer :: is, ie, js, je, ks, ke + + is = bounds%get_imin() + ie = bounds%get_imax() + js = bounds%get_jmin() + je = bounds%get_jmax() + ks = bounds%get_kmin() + ke = bounds%get_kmax() + + data_out(is:ie, js:je, ks:ke, :, 1) = data_in(:,:,:,:) + + error_msg = "" +end function DO_TIME_NONE_ \ No newline at end of file diff --git a/diag_manager/include/fms_diag_reduction_methods_r4.fh b/diag_manager/include/fms_diag_reduction_methods_r4.fh new file mode 100644 index 0000000000..ddf29ddf89 --- /dev/null +++ b/diag_manager/include/fms_diag_reduction_methods_r4.fh @@ -0,0 +1,32 @@ +!* 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 . +!*********************************************************************** +!> @file +!> @brief Imports the time reduction methods routines from other include files used +!! in @ref diag_manager_mod + +!> @addtogroup diag_manager_mod +!> @{ + +#undef FMS_TRM_KIND_ +#define FMS_TRM_KIND_ r4_kind + +#undef DO_TIME_NONE_ +#define DO_TIME_NONE_ do_time_none_r4 + +#include "fms_diag_reduction_methods.inc" + +!> @} +! close documentation grouping \ No newline at end of file diff --git a/diag_manager/include/fms_diag_reduction_methods_r8.fh b/diag_manager/include/fms_diag_reduction_methods_r8.fh new file mode 100644 index 0000000000..079153cdfe --- /dev/null +++ b/diag_manager/include/fms_diag_reduction_methods_r8.fh @@ -0,0 +1,32 @@ +!* 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 . +!*********************************************************************** +!> @file +!> @brief Imports the time reduction methods routines from other include files used +!! in @ref diag_manager_mod + +!> @addtogroup diag_manager_mod +!> @{ + +#undef FMS_TRM_KIND_ +#define FMS_TRM_KIND_ r8_kind + +#undef DO_TIME_NONE_ +#define DO_TIME_NONE_ do_time_none_r8 + +#include "fms_diag_reduction_methods.inc" + +!> @} +! close documentation grouping \ No newline at end of file diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index de682cc7ee..5ae3dfc310 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -53,7 +53,7 @@ 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 test_time_none.sh test_time_min.sh test_time_max.sh +#TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh testing_utils.mod: testing_utils.$(OBJEXT) diff --git a/test_fms/diag_manager/test_time_none.sh b/test_fms/diag_manager/test_time_none.sh index 0de41c9f1b..88f87d5d7a 100755 --- a/test_fms/diag_manager/test_time_none.sh +++ b/test_fms/diag_manager/test_time_none.sh @@ -46,8 +46,57 @@ test_none "ocn_mod", "var3", "var3_none", "test_none_regional", "all", .false., "78. 81. 78. 81. 2. 3.", 2 #chosen by MKL _EOF +cat <<_EOF > diag_table.yaml +title: test_none +base_date: 2 1 1 0 0 0 +diag_files: +- file_name: test_none + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - module: ocn_mod + var_name: var0 + output_name: var0_none + reduction: none + kind: r4 + - module: ocn_mod + var_name: var1 + output_name: var1_none + reduction: none + kind: r4 + - module: ocn_mod + var_name: var2 + output_name: var2_none + reduction: none + kind: r4 + - module: ocn_mod + var_name: var3 + output_name: var3_none + reduction: none + kind: r4 +- file_name: test_none_regional + freq: 6 + freq_units: hours + time_units: hours + unlimdim: time + sub_region: + - grid_type: latlon + corner1: 78. 78. + corner2: 78. 78. + corner3: 81. 81. + corner4: 81. 81. + varlist: + - module: ocn_mod + var_name: var3 + output_name: var3_none + reduction: none + zbounds: 2. 3. + kind: r4 +_EOF + my_test_count=1 -printf "&test_reduction_methods_nml \n test_case = 0 \n \n/" | cat > input.nml +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 0 \n/" | cat > input.nml test_expect_success "Running diag_manager with "none" reduction method (test $my_test_count)" ' mpirun -n 6 ../test_reduction_methods ' From 00cded413802b96d8aa41d7a4aa17ac62d2a08a1 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Thu, 17 Aug 2023 14:47:25 -0400 Subject: [PATCH 15/33] implement time_none --- diag_manager/fms_diag_axis_object.F90 | 103 +++++++---- diag_manager/fms_diag_bbox.F90 | 171 +++++++++++++++++- diag_manager/fms_diag_object.F90 | 66 ++++++- diag_manager/fms_diag_output_buffer.F90 | 10 +- diag_manager/fms_diag_reduction_methods.F90 | 1 + .../include/fms_diag_reduction_methods.inc | 42 +++-- test_fms/diag_manager/Makefile.am | 2 +- test_fms/diag_manager/check_time_none.F90 | 36 ++-- test_fms/diag_manager/test_time_none.sh | 29 +-- 9 files changed, 368 insertions(+), 92 deletions(-) diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90 index 14a54387bc..835b25ad93 100644 --- a/diag_manager/fms_diag_axis_object.F90 +++ b/diag_manager/fms_diag_axis_object.F90 @@ -115,12 +115,14 @@ module fms_diag_axis_object_mod INTEGER , private :: ending_index !< Ending index of the subaxis relative to the !! parent axis INTEGER , private :: parent_axis_id !< Id of the parent_axis + INTEGER , private :: compute_idx(2) real(kind=r4_kind), allocatable, private :: zbounds(:) !< Bounds of the Z axis contains procedure :: fill_subaxis procedure :: axis_length procedure :: get_starting_index procedure :: get_ending_index + procedure :: get_compute_indices END TYPE fmsDiagSubAxis_type !> @brief Type to hold the diurnal axis @@ -665,7 +667,7 @@ subroutine get_indices(this, compute_idx, corners_indices, starting_index, endin ending_index = diag_null !< If the compute domain of the current PE is outisde of the range of sub_axis, return - if (compute_idx(1) > subregion_start .and. compute_idx(2) > subregion_start) return + if (compute_idx(1) < subregion_start .and. compute_idx(2) < subregion_start) return if (compute_idx(1) > subregion_end .and. compute_idx(2) > subregion_end) return need_to_define_axis = .true. @@ -738,13 +740,14 @@ end subroutine get_compute_domain !!!!!!!!!!!!!!!!!! SUB AXIS PROCEDURES !!!!!!!!!!!!!!!!! !> @brief Fills in the information needed to define a subaxis - subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id, parent_axis_name, zbounds) + subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id, parent_axis_name, compute_idx, zbounds) class(fmsDiagSubAxis_type) , INTENT(INOUT) :: this !< diag_sub_axis obj integer , intent(in) :: starting_index !< Starting index of the subRegion for the PE integer , intent(in) :: ending_index !< Ending index of the subRegion for the PE integer , intent(in) :: axis_id !< Axis id to assign to the subaxis integer , intent(in) :: parent_id !< The id of the parent axis, the subaxis belongs to character(len=*) , intent(in) :: parent_axis_name !< Name of the parent_axis + integer , intent(in) :: compute_idx(2) real(kind=r4_kind), optional, intent(in) :: zbounds(2) !< Bounds of the z-axis this%axis_id = axis_id @@ -752,6 +755,7 @@ subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id, this%ending_index = ending_index this%parent_axis_id = parent_id this%subaxis_name = trim(parent_axis_name)//"_sub01" + this%compute_idx = compute_idx if (present(zbounds)) then allocate(this%zbounds(2)) @@ -785,6 +789,14 @@ function get_ending_index(this) result(indx) indx = this%ending_index end function get_ending_index + !> @brief Accesses its member compute_indices + !! @return a copy of the ending_index + function get_compute_indices(this) result(indx) + class(fmsDiagSubAxis_type), intent(in) :: this !< diag_sub_axis object + integer :: indx(2) !< Result to return + indx = this%compute_idx + end function get_compute_indices + !> @brief Get the ntiles in a domain !> @return the number of tiles in a domain function get_ntiles(this) & @@ -1022,8 +1034,9 @@ subroutine define_subaxis_index(diag_axis, axis_ids, naxis, subRegion, write_on_ !< If the PE's compute is not inside the subRegion, define a null subaxis and go to the next axis if (.not. need_to_define_axis) then + compute_idx = diag_null call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), & - diag_null, diag_null) + diag_null, diag_null, compute_idx) cycle endif @@ -1031,7 +1044,7 @@ subroutine define_subaxis_index(diag_axis, axis_ids, naxis, subRegion, write_on_ write_on_this_pe = .true. call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), & - starting_index, ending_index) + starting_index, ending_index, compute_idx) end select enddo @@ -1052,10 +1065,13 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_ integer :: lat_indices(2) !< Starting and ending latitude indices of the subRegion integer :: lon_indices(2) !< Starting and ending longitude indices of the subRegion integer :: compute_idx(2) !< Compute domain of the current axis - integer :: starting_index !< Starting index of the subRegion for the current PE - integer :: ending_index !< Ending index of the subRegion for the current PE - logical :: need_to_define_axis !< .true. if it is needed to define the subaxis + integer :: starting_index(2) !< Starting index of the subRegion for the current PE + integer :: ending_index(2) !< Ending index of the subRegion for the current PE + logical :: need_to_define_axis(2) !< .true. if it is needed to define the subaxis integer :: i !< For do loops + integer :: parent_axis_ids(2) + logical :: is_x_y_axis + integer :: compute_idx_2(2, 2) !< Get the rectangular coordinates of the subRegion !! If the subRegion is not rectangular, the points outside of the subRegion will be masked @@ -1076,29 +1092,24 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_ select_axis_type: select type (parent_axis => diag_axis(axis_ids(i))%axis) type is (fmsDiagFullAxis_type) !< Get the PEs compute domain - call parent_axis%get_compute_domain(compute_idx, need_to_define_axis) + call parent_axis%get_compute_domain(compute_idx, is_x_y_axis) !< If this is not a "X" or "Y" axis go to the next axis - if (.not. need_to_define_axis) cycle + if (.not. is_x_y_axis) cycle !< Determine if the PE's compute domain is inside the subRegion !! If it is get the starting and ending indices for that PE if (parent_axis%cart_name .eq. "X") then - call parent_axis%get_indices(compute_idx, lon_indices, starting_index, ending_index, & - need_to_define_axis) + call parent_axis%get_indices(compute_idx, lon_indices, starting_index(1), ending_index(1), & + need_to_define_axis(1)) + parent_axis_ids(1) = axis_ids(i) + compute_idx_2(1,:) = compute_idx else if (parent_axis%cart_name .eq. "Y") then - call parent_axis%get_indices(compute_idx, lat_indices, starting_index, ending_index, & - need_to_define_axis) + call parent_axis%get_indices(compute_idx, lat_indices, starting_index(2), ending_index(2), & + need_to_define_axis(2)) + parent_axis_ids(2) = axis_ids(i) + compute_idx_2(2,:) = compute_idx endif - - !< If the PE's compute is not inside the subRegion move to the next axis - if (.not. need_to_define_axis) cycle - - !< If it made it to this point, the current PE is in the subRegion! - write_on_this_pe = .true. - - call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), & - starting_index, ending_index) end select select_axis_type enddo loop_over_axis_ids else if_is_cube_sphere @@ -1106,10 +1117,10 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_ select type (parent_axis => diag_axis(axis_ids(i))%axis) type is (fmsDiagFullAxis_type) !< Get the PEs compute domain - call parent_axis%get_compute_domain(compute_idx, need_to_define_axis) + call parent_axis%get_compute_domain(compute_idx, is_x_y_axis) !< If this is not a "X" or "Y" axis go to the next axis - if (.not. need_to_define_axis) cycle + if (.not. is_x_y_axis) cycle !< Get the starting and ending indices of the subregion relative to the global grid if (parent_axis%cart_name .eq. "X") then @@ -1118,34 +1129,44 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_ lon_indices(1) = nearest_index(lon(1), adata) lon_indices(2) = nearest_index(lon(2), adata) + 1 end select - call parent_axis%get_indices(compute_idx, lon_indices, starting_index, ending_index, & - need_to_define_axis) + call parent_axis%get_indices(compute_idx, lon_indices, starting_index(1), ending_index(1), & + need_to_define_axis(1)) + parent_axis_ids(1) = axis_ids(i) + compute_idx_2(1,:) = compute_idx else if (parent_axis%cart_name .eq. "Y") then select type(adata=>parent_axis%axis_data) type is (real) lat_indices(1) = nearest_index(lat(1), adata) lat_indices(2) = nearest_index(lat(2), adata) + 1 end select - call parent_axis%get_indices(compute_idx, lat_indices, starting_index, ending_index, & - need_to_define_axis) + call parent_axis%get_indices(compute_idx, lat_indices, starting_index(2), ending_index(2), & + need_to_define_axis(2)) + parent_axis_ids(2) = axis_ids(i) + compute_idx_2(2,:) = compute_idx endif - - !< If the PE's compute is not inside the subRegion move to the next axis - if (.not. need_to_define_axis) cycle - - !< If it made it to this point, the current PE is in the subRegion! - write_on_this_pe = .true. - - call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), & - starting_index, ending_index) end select enddo loop_over_axis_ids2 endif if_is_cube_sphere + + !< If the PE's compute is not inside the subRegion move to the next axis + if (any(.not. need_to_define_axis )) return + + !< If it made it to this point, the current PE is in the subRegion! + write_on_this_pe = .true. + + do i = 1, size(parent_axis_ids) + select type (parent_axis => diag_axis(parent_axis_ids(i))%axis) + type is (fmsDiagFullAxis_type) + call define_new_axis(diag_axis, parent_axis, naxis, parent_axis_ids(i), & + starting_index(i), ending_index(i), compute_idx_2(i,:)) + end select + enddo + end subroutine define_subaxis_latlon !> @brief Creates a new subaxis and fills it will all the information it needs subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, & - starting_index, ending_index, new_axis_id, zbounds) + starting_index, ending_index, compute_idx, new_axis_id, zbounds) class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object class(fmsDiagFullAxis_type), intent(inout) :: parent_axis !< The parent axis @@ -1154,6 +1175,7 @@ subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, & integer, intent(in) :: parent_id !< Id of the parent axis integer, intent(in) :: starting_index !< PE's Starting index integer, intent(in) :: ending_index !< PE's Ending index + integer, intent(in) :: compute_idx(2) integer, optional, intent(out) :: new_axis_id !< Axis id of the axis this is creating real(kind=r4_kind), optional, intent(in) :: zbounds(2) !< Bounds of the Z axis @@ -1171,7 +1193,7 @@ subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, & select type (sub_axis => diag_axis(naxis)%axis) type is (fmsDiagSubAxis_type) call sub_axis%fill_subaxis(starting_index, ending_index, naxis, parent_id, & - parent_axis%axis_name, zbounds) + parent_axis%axis_name, compute_idx, zbounds) end select end subroutine define_new_axis @@ -1333,7 +1355,8 @@ subroutine create_new_z_subaxis(zbounds, var_axis_ids, diag_axis, naxis, file_ax end select call define_new_axis(diag_axis, parent_axis, naxis, parent_axis%axis_id, & - &subaxis_indices(1), subaxis_indices(2), subaxis_id, zbounds) + &subaxis_indices(1), subaxis_indices(2), (/lbound(zaxis_data,1), ubound(zaxis_data,1)/), & + &subaxis_id, zbounds) var_axis_ids(i) = subaxis_id return endif diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 index 956dabd31c..8b3f969be2 100644 --- a/diag_manager/fms_diag_bbox.F90 +++ b/diag_manager/fms_diag_bbox.F90 @@ -31,6 +31,7 @@ MODULE fms_diag_bbox_mod USE fms_mod, ONLY: error_mesg, FATAL, fms_error_handler + use mpp_mod implicit none @@ -39,24 +40,29 @@ MODULE fms_diag_bbox_mod !! array index bounds of the spatial component a diag_manager field output !! buffer array. TYPE, public :: fmsDiagIbounds_type - PRIVATE INTEGER :: imin !< Lower i bound. INTEGER :: imax !< Upper i bound. INTEGER :: jmin !< Lower j bound. INTEGER :: jmax !< Upper j bound. INTEGER :: kmin !< Lower k bound. INTEGER :: kmax !< Upper k bound. + logical :: has_halos + integer :: nhalo_I + integer :: nhalo_J contains procedure :: reset => reset_bounds procedure :: reset_bounds_from_array_4D procedure :: reset_bounds_from_array_5D procedure :: update_bounds + procedure :: update_bounds_from_halos + procedure :: reset_bounds_to_write procedure :: get_imin procedure :: get_imax procedure :: get_jmin procedure :: get_jmax procedure :: get_kmin procedure :: get_kmax + procedure :: update_index END TYPE fmsDiagIbounds_type !> @brief Data structure holding starting and ending indices in the I, J, and @@ -81,10 +87,49 @@ MODULE fms_diag_bbox_mod procedure :: get_fje end type fmsDiagBoundsHalos_type - public :: recondition_indices + public :: recondition_indices, update_bounds_out, determine_if_block_is_in_region + + integer, parameter :: xdimension = 1 + integer, parameter :: ydimension = 2 + integer, parameter :: zdimension = 3 CONTAINS +logical function determine_if_block_is_in_region(subregion_start, subregion_end, bounds, dimension) + integer, intent(in) :: subregion_start + integer, intent(in) :: subregion_end + type(fmsDiagIbounds_type), intent(in) :: bounds + integer, intent(in) :: dimension + + integer :: block_start + integer :: block_end + + determine_if_block_is_in_region = .true. + select case (dimension) + case (xdimension) + block_start = bounds%imin + block_end = bounds%imax + case (ydimension) + block_start = bounds%jmin + block_end = bounds%jmax + case (zdimension) + block_start = bounds%kmin + block_end = bounds%kmax + end select + + if (block_start < subregion_start .and. block_end < subregion_start) then + determine_if_block_is_in_region = .false. + return + endif + + if (block_start > subregion_end .and. block_end > subregion_end) then + determine_if_block_is_in_region = .false. + return + endif + + determine_if_block_is_in_region = .true. +end function + !> @brief Gets imin of fmsDiagIbounds_type !! @return copy of integer member imin pure integer function get_imin (this) result(rslt) @@ -128,6 +173,34 @@ pure integer function get_kmax (this) result(rslt) rslt = this%kmax end function get_kmax + subroutine update_index(this, starting_index, ending_index, dimension, ignore_halos) + class (fmsDiagIbounds_type), intent(inout) :: this !< The !< ibounds instance + integer, intent(in) :: starting_index + integer, intent(in) :: ending_index + integer, intent(in) :: dimension + logical, intent(in) :: ignore_halos + + integer :: nhalox, nhaloy + if (ignore_halos) then + nhalox = 0 + nhaloy = 0 + else + nhalox= this%nhalo_I + nhaloy= this%nhalo_J + endif + select case(dimension) + case (xdimension) + this%imin = starting_index + nhalox + this%imax = ending_index + nhalox + case (ydimension) + this%jmin = starting_index + nhaloy + this%jmax = ending_index + nhaloy + case (zdimension) + this%kmin = starting_index + this%kmax = ending_index + end select + end subroutine + !> @brief Gets the halo size of fmsDiagBoundsHalos_type in the I dimension !! @return copy of integer member hi pure integer function get_hi (this) result(rslt) @@ -202,11 +275,87 @@ SUBROUTINE update_bounds(this, lower_i, upper_i, lower_j, upper_j, lower_k, uppe this%kmax = MAX(this%kmax, upper_k) END SUBROUTINE update_bounds + subroutine reset_bounds_to_write(this, field_data) + CLASS (fmsDiagIbounds_type), intent(inout) :: this ! @brief Reset the instance bounding box with the bounds determined from the !! first three dimensions of the 5D "array" argument SUBROUTINE reset_bounds_from_array_4D(this, array) CLASS (fmsDiagIbounds_type), INTENT(inout) :: this !< The instance of the bounding box. - REAL, INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array. + class(*), INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array. this%imin = LBOUND(array,1) this%imax = UBOUND(array,1) this%jmin = LBOUND(array,2) @@ -319,6 +468,22 @@ function recondition_indices(indices, field, is_in, js_in, ks_in, & indices%fje = fje end function recondition_indices + subroutine update_bounds_out(bounds_in, bounds_out) + CLASS (fmsDiagIbounds_type), INTENT(in) :: bounds_in + CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_out + + if ((bounds_in%imax - bounds_in%imin+1) .ne. (bounds_out%imax - bounds_out%imin+1)) then + bounds_out%imax = bounds_in%imax + bounds_out%imin = bounds_in%imin + endif + + if ((bounds_in%jmax - bounds_in%jmin+1) .ne. (bounds_out%jmax - bounds_out%jmin+1)) then + bounds_out%jmax = bounds_in%jmax + bounds_out%jmin = bounds_in%jmin + endif + + end subroutine + END MODULE fms_diag_bbox_mod !> @} ! close documentation grouping diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 926880be98..968ec0227d 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -40,7 +40,7 @@ module fms_diag_object_mod use fms_mod, only: fms_error_handler use fms_diag_reduction_methods_mod, only: check_indices_order, init_mask, set_weight use constants_mod, only: SECONDS_PER_DAY -USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type +USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type, update_bounds_out, determine_if_block_is_in_region #endif #if defined(_OPENMP) use omp_lib @@ -520,6 +520,7 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm !! based on the type of field_data when doing the math) type(fmsDiagIbounds_type) :: bounds !< Bounds (starting ending indices) for the field + logical :: has_halos #ifndef use_yaml CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") #else @@ -536,6 +537,10 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm error_string = check_indices_order(is_in, ie_in, js_in, je_in) if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info)) + has_halos = .false. + if ((present(is_in) .and. present(ie_in)) .or. (present(js_in) .and. present(je_in))) & + has_halos = .true. + !< If the field has `mask_variant=.true.`, check that mask OR rmask are present if (this%FMS_diag_fields(diag_field_id)%is_mask_variant()) then if (.not. associated(mask) .and. .not. associated(rmask)) call mpp_error(FATAL, & @@ -596,7 +601,8 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm return else call bounds%reset(999,-999) - call bounds%update_bounds(is, ie, js, je, ks, ke) !TODO may need more updates for halos + err_msg = bounds%update_bounds_from_halos(field_data, is, ie, js, je, ks, ke, has_halos) + if (trim(err_msg) .ne. "") call mpp_error(FATAL, "WUT") call this%allocate_diag_field_output_buffers(field_data, diag_field_id) fms_diag_accept_data = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, field_weight, & bounds, Time=Time) @@ -741,6 +747,19 @@ logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask integer :: buffer_id !< Id of the buffer integer :: file_id !< File id character(len=50) :: error_msg !< Error message to check + integer, allocatable :: axis_ids(:) + logical :: is_regional + logical :: reduced_k_range + type(fmsDiagIbounds_type) :: bounds_in + type(fmsDiagIbounds_type) :: bounds_out + integer :: i + integer :: sindex + integer :: eindex + integer :: compute_idx(2) + logical :: dummy + character(len=1) :: cart_axis + logical :: is_block_in_region + integer :: starting, ending !TODO mostly everything field_ptr => this%FMS_diag_fields(diag_field_id) @@ -753,13 +772,50 @@ logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask file_id = this%FMS_diag_fields(diag_field_id)%file_ids(ids) !TODO not sure if this is correct file_ptr => this%FMS_diag_files(file_id) + if (.not. file_ptr%writing_on_this_pe()) cycle + + !< Initialize the bounds + bounds_out = bounds + bounds_in = bounds + call bounds_out%reset_bounds_from_array_4D(buffer_ptr%buffer(:,:,:,:,1)) + call update_bounds_out(bounds, bounds_out) + + if (.not. bounds_in%has_halos) then + print *, "buffer has halos" + call bounds_in%reset_bounds_from_array_4D(field_data) + endif + !< Reset the bounds based on the reduced k range and subregional + is_regional = file_ptr%is_regional() + reduced_k_range = field_yaml_ptr%has_var_zbounds() + + if (is_regional .or. reduced_k_range) then + print *, "buffer is subregional" + axis_ids = buffer_ptr%get_axis_ids() + do i = 1, size(axis_ids) + select type (diag_axis => this%diag_axis(axis_ids(i))%axis) + type is (fmsDiagSubAxis_type) + sindex = diag_axis%get_starting_index() + eindex = diag_axis%get_ending_index() + compute_idx = diag_axis%get_compute_indices() + starting=sindex-compute_idx(1)+1 + ending=eindex-compute_idx(1)+1 + call bounds_in%update_index(starting, ending, i, .false.) + call bounds_out%update_index(1, ending-starting+1, i, .true.) + print *, mpp_pe(), ":", ending-starting+1 + + is_block_in_region = determine_if_block_is_in_region(starting, ending, bounds_out, i) + if (.not. is_block_in_region) return + end select + enddo + deallocate(axis_ids) + endif !< Determine the reduction method for the buffer reduction_method = field_yaml_ptr%get_var_reduction() select case(reduction_method) case (time_none) - error_msg = buffer_ptr%do_time_none_wrapper(field_data, oor_mask, bounds) + error_msg = buffer_ptr%do_time_none_wrapper(field_data, oor_mask, bounds_in, bounds_out) case (time_min) case (time_max) case (time_sum) @@ -1050,6 +1106,7 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id) character(len=128), allocatable :: var_name !< Field name to initialize output buffers logical :: is_scalar !< Flag indicating that the variable is a scalar integer :: yaml_id + integer :: file_id if (this%FMS_diag_fields(field_id)%buffer_allocated) return @@ -1088,6 +1145,9 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id) ! Loop over a number of fields/buffers where this variable occurs do i = 1, size(this%FMS_diag_fields(field_id)%buffer_ids) buffer_id = this%FMS_diag_fields(field_id)%buffer_ids(i) + file_id = this%FMS_diag_fields(field_id)%file_ids(i) + + if (.not. this%FMS_diag_files(file_id)%writing_on_this_pe()) cycle ndims = 0 if (.not. is_scalar) then diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90 index 6f23214ff5..b5ce3c6a3d 100644 --- a/diag_manager/fms_diag_output_buffer.F90 +++ b/diag_manager/fms_diag_output_buffer.F90 @@ -28,7 +28,7 @@ module fms_diag_output_buffer_mod use platform_mod use iso_c_binding use time_manager_mod, only: time_type -use mpp_mod, only: mpp_error, FATAL +use mpp_mod, only: mpp_error, FATAL, mpp_pe use diag_data_mod, only: DIAG_NULL, DIAG_NOT_REGISTERED, i4, i8, r4, r8 use fms2_io_mod, only: FmsNetcdfFile_t, write_data, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t use fms_diag_yaml_mod, only: diag_yaml @@ -436,21 +436,21 @@ subroutine write_buffer_wrapper_u(this, fms2io_fileobj, unlim_dim_level) end select end subroutine write_buffer_wrapper_u -function do_time_none_wrapper(this, field_data, mask, bounds) & +function do_time_none_wrapper(this, field_data, mask, bounds_in, bounds_out) & result(err_msg) class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write class(*), intent(in) :: field_data(:,:,:,:) + type(fmsDiagIbounds_type), intent(in) :: bounds_in + type(fmsDiagIbounds_type), intent(in) :: bounds_out logical, intent(in) :: mask(:,:,:,:) character(len=50) :: err_msg - type(fmsDiagIbounds_type), intent(in) :: bounds - err_msg = "" select type (output_buffer => this%buffer) type is (real(kind=r8_kind)) select type (field_data) type is (real(kind=r8_kind)) - err_msg=do_time_none(output_buffer, field_data, mask, bounds) + err_msg=do_time_none(output_buffer, field_data, mask, bounds_in, bounds_out) end select end select diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 8d3b12ef54..e59813a1c8 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -30,6 +30,7 @@ module fms_diag_reduction_methods_mod use platform_mod, only: r8_kind, r4_kind use fms_diag_bbox_mod, only: fmsDiagIbounds_type + use mpp_mod implicit none private diff --git a/diag_manager/include/fms_diag_reduction_methods.inc b/diag_manager/include/fms_diag_reduction_methods.inc index ca447ce825..808236ff40 100644 --- a/diag_manager/include/fms_diag_reduction_methods.inc +++ b/diag_manager/include/fms_diag_reduction_methods.inc @@ -17,24 +17,44 @@ !* License along with FMS. If not, see . !*********************************************************************** -function DO_TIME_NONE_ (data_out, data_in, mask, bounds) & +function DO_TIME_NONE_ (data_out, data_in, mask, bounds_in, bounds_out) & result(error_msg) real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) - logical, intent(in) :: mask(:,:,:,:) - type(fmsDiagIbounds_type), intent(in) :: bounds + logical, intent(in), target :: mask(:,:,:,:) + type(fmsDiagIbounds_type), intent(in) :: bounds_in + type(fmsDiagIbounds_type), intent(in) :: bounds_out character(len=50) :: error_msg - integer :: is, ie, js, je, ks, ke + integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in + integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out - is = bounds%get_imin() - ie = bounds%get_imax() - js = bounds%get_jmin() - je = bounds%get_jmax() - ks = bounds%get_kmin() - ke = bounds%get_kmax() + is_out = bounds_out%get_imin() + ie_out = bounds_out%get_imax() + js_out = bounds_out%get_jmin() + je_out = bounds_out%get_jmax() + ks_out = bounds_out%get_kmin() + ke_out = bounds_out%get_kmax() - data_out(is:ie, js:je, ks:ke, :, 1) = data_in(:,:,:,:) + is_in = bounds_in%get_imin() + ie_in = bounds_in%get_imax() + js_in = bounds_in%get_jmin() + je_in = bounds_in%get_jmax() + ks_in = bounds_in%get_kmin() + ke_in = bounds_in%get_kmax() +! write ((mpp_pe()+1)*100, *) "BOUNDS", lbound(mask), ubound(mask) + write ((mpp_pe()+1)*100, *) "indices_in:", is_in,ie_in, js_in,je_in, ks_in,ke_in + write ((mpp_pe()+1)*100, *) "indices_out:", is_out,ie_out, js_out,je_out, ks_out,ke_out + write ((mpp_pe()+1)*100, *) "bounds_in", lbound(data_in), ubound(data_in) + write ((mpp_pe()+1)*100, *) "bounds_in", lbound(data_out), ubound(data_out) + + write ((mpp_pe()+1)*100, *) "WUTT:", mask(is_in:ie_in, js_in:je_in, ks_in:ke_in, :) + where (mask(is_in:ie_in, js_in:je_in, ks_in:ke_in, :)) & + data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) = & + data_in(is_in:ie_in, js_in:je_in, ks_in:ke_in, :) + + write ((mpp_pe()+1)*100, *) "data_in:", data_in(is_in:ie_in, js_in:je_in, ks_in:ke_in, :) + write ((mpp_pe()+1)*100, *) "data_out:", data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) error_msg = "" end function DO_TIME_NONE_ \ No newline at end of file diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index 5ae3dfc310..ea9e10b55e 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -53,7 +53,7 @@ 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 test_time_none.sh test_time_min.sh test_time_max.sh +TESTS = test_time_none.sh #test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh testing_utils.mod: testing_utils.$(OBJEXT) diff --git a/test_fms/diag_manager/check_time_none.F90 b/test_fms/diag_manager/check_time_none.F90 index 11844448c0..65baad237a 100644 --- a/test_fms/diag_manager/check_time_none.F90 +++ b/test_fms/diag_manager/check_time_none.F90 @@ -60,18 +60,18 @@ program check_time_none 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(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") + ! 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 read_data(fileobj, "var0_none", cdata_out(1,1,1,1), unlim_dim_level=i) call check_data_0d(cdata_out(1,1,1,1), i) cdata_out = -999_r4_kind @@ -89,20 +89,20 @@ program check_time_none 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_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 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) + ! 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() @@ -120,7 +120,7 @@ subroutine check_data_0d(buffer, time_level) 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 + print *, mpp_pe(), time_level, buffer_exp, buffer call mpp_error(FATAL, "Check_time_none::check_data_0d:: Data is not correct") endif end subroutine check_data_0d diff --git a/test_fms/diag_manager/test_time_none.sh b/test_fms/diag_manager/test_time_none.sh index 88f87d5d7a..a72ece40a0 100755 --- a/test_fms/diag_manager/test_time_none.sh +++ b/test_fms/diag_manager/test_time_none.sh @@ -75,11 +75,18 @@ diag_files: output_name: var3_none reduction: none kind: r4 + - module: ocn_mod + var_name: var3 + output_name: var3_Z + reduction: none + zbounds: 2. 3. + kind: r4 + write_var: True - file_name: test_none_regional - freq: 6 - freq_units: hours + freq: 6 hours time_units: hours unlimdim: time + write_file: True sub_region: - grid_type: latlon corner1: 78. 78. @@ -105,7 +112,7 @@ test_expect_success "Checking answers for the "none" reduction method (test $my_ ' 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 +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &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 ' @@ -114,7 +121,7 @@ test_expect_success "Checking answers for the "none" reduction method, logical m ' 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 +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &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 ' @@ -122,9 +129,9 @@ test_expect_success "Checking answers for the "none" reduction method, real mask mpirun -n 1 ../check_time_none ' -export OMP_NUM_THREADS=2 +export OMP_NUM_THREADS=1 my_test_count=`expr $my_test_count + 1` -printf "&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&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 ' @@ -133,7 +140,7 @@ test_expect_success "Checking answers for the "none" reduction method with openm ' 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 +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&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 ' @@ -142,7 +149,7 @@ test_expect_success "Checking answers for the "none" reduction method with openm ' 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 +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&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 ' @@ -152,7 +159,7 @@ test_expect_success "Checking answers for the "none" reduction method with openm 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 +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&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 ' @@ -161,7 +168,7 @@ test_expect_success "Checking answers for the "none" reduction method with halo ' 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 +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&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 ' @@ -170,7 +177,7 @@ test_expect_success "Checking answers for the "none" reduction method with halo ' 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 +printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&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 ' From 3d1acc30f684525fc96b05ac3dee410b6131c292 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Fri, 18 Aug 2023 10:26:23 -0400 Subject: [PATCH 16/33] push so i can debug on gaea --- diag_manager/fms_diag_bbox.F90 | 19 +++++++++++++++++++ diag_manager/fms_diag_object.F90 | 9 ++++++--- test_fms/diag_manager/Makefile.am | 2 +- .../diag_manager/test_reduction_methods.F90 | 2 +- 4 files changed, 27 insertions(+), 5 deletions(-) diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 index 8b3f969be2..5c2ac65eab 100644 --- a/diag_manager/fms_diag_bbox.F90 +++ b/diag_manager/fms_diag_bbox.F90 @@ -56,6 +56,7 @@ MODULE fms_diag_bbox_mod procedure :: update_bounds procedure :: update_bounds_from_halos procedure :: reset_bounds_to_write + procedure :: rebase procedure :: get_imin procedure :: get_imax procedure :: get_jmin @@ -468,6 +469,24 @@ function recondition_indices(indices, field, is_in, js_in, ks_in, & indices%fje = fje end function recondition_indices + subroutine rebase(bounds_in, bounds, dimension) + CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_in + CLASS (fmsDiagIbounds_type), INTENT(in) :: bounds + integer, intent(in) :: dimension + + select case (dimension) + case (xdimension) + bounds_in%imin = bounds_in%imin - bounds%imin +1 + bounds_in%imax = bounds_in%imax - bounds%imin +1 + case (ydimension) + bounds_in%jmin = bounds_in%jmin - bounds%jmin +1 + bounds_in%jmax = bounds_in%jmax - bounds%jmin +1 + case (zdimension) + bounds_in%kmin = bounds_in%kmin - bounds%kmin +1 + bounds_in%kmax = bounds_in%kmax - bounds%kmin +1 + end select + end subroutine + subroutine update_bounds_out(bounds_in, bounds_out) CLASS (fmsDiagIbounds_type), INTENT(in) :: bounds_in CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_out diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 968ec0227d..360d11a7f0 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -802,10 +802,13 @@ logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask ending=eindex-compute_idx(1)+1 call bounds_in%update_index(starting, ending, i, .false.) call bounds_out%update_index(1, ending-starting+1, i, .true.) - print *, mpp_pe(), ":", ending-starting+1 - is_block_in_region = determine_if_block_is_in_region(starting, ending, bounds_out, i) - if (.not. is_block_in_region) return + is_block_in_region = determine_if_block_is_in_region(starting, ending, bounds, i) + if (.not. is_block_in_region) then + return + endif + + call bounds_in%rebase(bounds, i) end select enddo deallocate(axis_ids) diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index de682cc7ee..34a6df2130 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -53,7 +53,7 @@ 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 test_time_none.sh test_time_min.sh test_time_max.sh +#TESTS = test_time_none.sh #test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh testing_utils.mod: testing_utils.$(OBJEXT) diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90 index 3f85a043f0..2cce0439a1 100644 --- a/test_fms/diag_manager/test_reduction_methods.F90 +++ b/test_fms/diag_manager/test_reduction_methods.F90 @@ -177,7 +177,7 @@ program test_reduction_methods jed1 = jsd1 + jec-jsc call diag_manager_set_time_end(set_date(2,1,3,0,0,0)) - do i = 1, ntimes + do i = 1, 1 !, ntimes Time = Time + Time_step call set_buffer(cdata, i) From 9e4ac3c7666f023517bf71c555edfec2fa36bfa4 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Fri, 18 Aug 2023 15:34:38 -0400 Subject: [PATCH 17/33] finish implement time_none, needs MAJOR clean up --- diag_manager/fms_diag_bbox.F90 | 44 +++++++++++++++---- diag_manager/fms_diag_object.F90 | 35 ++++++++++----- test_fms/diag_manager/Makefile.am | 2 +- .../diag_manager/test_reduction_methods.F90 | 2 +- 4 files changed, 63 insertions(+), 20 deletions(-) diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 index 5c2ac65eab..a46cd776c2 100644 --- a/diag_manager/fms_diag_bbox.F90 +++ b/diag_manager/fms_diag_bbox.F90 @@ -30,7 +30,7 @@ !> @{ MODULE fms_diag_bbox_mod - USE fms_mod, ONLY: error_mesg, FATAL, fms_error_handler + USE fms_mod, ONLY: error_mesg, FATAL, fms_error_handler, string use mpp_mod implicit none @@ -57,6 +57,7 @@ MODULE fms_diag_bbox_mod procedure :: update_bounds_from_halos procedure :: reset_bounds_to_write procedure :: rebase + procedure :: rebase_more procedure :: get_imin procedure :: get_imax procedure :: get_jmin @@ -469,21 +470,48 @@ function recondition_indices(indices, field, is_in, js_in, ks_in, & indices%fje = fje end function recondition_indices - subroutine rebase(bounds_in, bounds, dimension) + subroutine rebase_more(bounds_in, starting, ending, dimension) + CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_in + integer, intent(in) :: starting + integer, intent(in) :: ending + integer, intent(in) :: dimension + + select case (dimension) + case (xdimension) + print *, mpp_pe(), "beforex:", bounds_in%imin, bounds_in%imax, starting + bounds_in%imin = max(starting, bounds_in%imin)-starting+1 + bounds_in%imax = min(bounds_in%imax, bounds_in%imin + ending-starting) + print *, mpp_pe(), "afterx:", bounds_in%imin, bounds_in%imax + case (ydimension) + print *, mpp_pe(), "beforey:", bounds_in%jmin, bounds_in%jmax, starting + bounds_in%jmin = max(starting, bounds_in%jmin)-starting+1 + bounds_in%jmax = min(bounds_in%jmax, bounds_in%jmin + ending-starting) + print *, mpp_pe(), "aftery:", bounds_in%jmin, bounds_in%jmax, starting + case (zdimension) + bounds_in%kmin =max(starting, bounds_in%kmin)-starting+1 + bounds_in%kmax = min(bounds_in%kmax, bounds_in%kmin + ending-starting) + end select + end subroutine + + subroutine rebase(bounds_in, bounds, starting, ending, dimension) CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_in CLASS (fmsDiagIbounds_type), INTENT(in) :: bounds + integer, intent(in) :: ending + integer, intent(in) :: starting integer, intent(in) :: dimension select case (dimension) case (xdimension) - bounds_in%imin = bounds_in%imin - bounds%imin +1 - bounds_in%imax = bounds_in%imax - bounds%imin +1 + print *, string(mpp_pe()), " is x ", starting-bounds_in%imin+1, starting + bounds_in%imin = min(starting-bounds%imin+1, starting) + bounds_in%imax = bounds_in%imin + (ending-starting) case (ydimension) - bounds_in%jmin = bounds_in%jmin - bounds%jmin +1 - bounds_in%jmax = bounds_in%jmax - bounds%jmin +1 + print *, string(mpp_pe()), " is x ", starting-bounds_in%jmin+1, starting + bounds_in%jmin = min(starting-bounds%jmin+1, starting) + bounds_in%jmax = bounds_in%jmin + (ending-starting) case (zdimension) - bounds_in%kmin = bounds_in%kmin - bounds%kmin +1 - bounds_in%kmax = bounds_in%kmax - bounds%kmin +1 + bounds_in%kmin = min(starting-bounds%kmin+1, starting) + bounds_in%kmax = bounds_in%kmin + (ending-starting) end select end subroutine diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 360d11a7f0..df5c860c66 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -17,6 +17,7 @@ !* License along with FMS. If not, see . !*********************************************************************** module fms_diag_object_mod + use fms_mod, only: string use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe, stdout use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, & &DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, & @@ -521,6 +522,7 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm type(fmsDiagIbounds_type) :: bounds !< Bounds (starting ending indices) for the field logical :: has_halos + logical :: using_blocking #ifndef use_yaml CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") #else @@ -537,6 +539,10 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm error_string = check_indices_order(is_in, ie_in, js_in, je_in) if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info)) + using_blocking = .false. + if ((present(is_in) .and. .not. present(ie_in)) .or. (present(js_in) .and. .not. present(je_in))) & + using_blocking = .true. + has_halos = .false. if ((present(is_in) .and. present(ie_in)) .or. (present(js_in) .and. present(je_in))) & has_halos = .true. @@ -605,7 +611,7 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm if (trim(err_msg) .ne. "") call mpp_error(FATAL, "WUT") call this%allocate_diag_field_output_buffers(field_data, diag_field_id) fms_diag_accept_data = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, field_weight, & - bounds, Time=Time) + bounds, using_blocking, Time=Time) call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.) return end if main_if @@ -726,13 +732,14 @@ end subroutine fms_diag_do_io !! based on the specified reduction method for the field. !> @return .True. if no error occurs. logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight, & - bounds, time) + bounds, using_blocking, time) class(fmsDiagObject_type), intent(in), target :: this !< Diag Object class(*), intent(in) :: field_data(:,:,:,:) !< Field data integer, intent(in) :: diag_field_id !< ID of the input field logical, intent(in), target :: oor_mask(:,:,:,:) !< mask real(kind=r8_kind), intent(in) :: weight !< Must be a updated weight type(fmsDiagIbounds_type), intent(in) :: bounds !< Bounds for the field + logical, intent(in) :: using_blocking type(time_type), intent(in), optional :: time !< Current time !TODO Mostly everything @@ -792,7 +799,9 @@ logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask if (is_regional .or. reduced_k_range) then print *, "buffer is subregional" axis_ids = buffer_ptr%get_axis_ids() + is_block_in_region = .true. do i = 1, size(axis_ids) + if (.not. is_block_in_region) cycle select type (diag_axis => this%diag_axis(axis_ids(i))%axis) type is (fmsDiagSubAxis_type) sindex = diag_axis%get_starting_index() @@ -800,18 +809,24 @@ logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask compute_idx = diag_axis%get_compute_indices() starting=sindex-compute_idx(1)+1 ending=eindex-compute_idx(1)+1 - call bounds_in%update_index(starting, ending, i, .false.) - call bounds_out%update_index(1, ending-starting+1, i, .true.) - - is_block_in_region = determine_if_block_is_in_region(starting, ending, bounds, i) - if (.not. is_block_in_region) then - return + if (using_blocking) then + is_block_in_region = determine_if_block_is_in_region(starting, ending, bounds, i) + !call bounds_out%update_index(starting, ending, i, .false.) + call bounds_out%rebase_more(starting, ending, i) + call bounds_in%rebase(bounds, starting, ending, i) + if (i .eq. 1) print *, string(mpp_pe()), " is x ", string(bounds%get_imin()), ":", string(bounds%get_imax()), starting, ending, is_block_in_region, string(bounds_in%get_imin()), ":", string(bounds_in%get_imax()) + if (i .eq. 2) print *, string(mpp_pe()), " is y ", string(bounds%get_jmin()), ":", string(bounds%get_jmax()), starting, ending, is_block_in_region, string(bounds_in%get_jmin()), ":", string(bounds_in%get_jmax()) + if (i .eq. 3) print *, string(mpp_pe()), " is z ", string(bounds%get_kmin()), ":", string(bounds%get_kmax()), starting, ending, is_block_in_region, string(bounds_in%get_kmin()), ":", string(bounds_in%get_kmax()) + else + call bounds_in%update_index(starting, ending, i, .false.) + call bounds_out%update_index(1, ending-starting+1, i, .true.) endif - - call bounds_in%rebase(bounds, i) end select enddo + ! write((mpp_pe()+1)*100, *) bounds_in%get_imin(), bounds_in%get_imax(), bounds_in%get_jmin(), bounds_in%get_jmax() + ! write((mpp_pe()+1)*100, *) bounds_out%get_imin(), bounds_out%get_imax(), bounds_out%get_jmin(), bounds_out%get_jmax() deallocate(axis_ids) + if (.not. is_block_in_region) return endif !< Determine the reduction method for the buffer diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index 34a6df2130..ea9e10b55e 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -53,7 +53,7 @@ SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ $(abs_top_srcdir)/test_fms/tap-driver.sh # Run the test. -#TESTS = test_time_none.sh #test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh +TESTS = test_time_none.sh #test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh testing_utils.mod: testing_utils.$(OBJEXT) diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90 index 2cce0439a1..3f85a043f0 100644 --- a/test_fms/diag_manager/test_reduction_methods.F90 +++ b/test_fms/diag_manager/test_reduction_methods.F90 @@ -177,7 +177,7 @@ program test_reduction_methods jed1 = jsd1 + jec-jsc call diag_manager_set_time_end(set_date(2,1,3,0,0,0)) - do i = 1, 1 !, ntimes + do i = 1, ntimes Time = Time + Time_step call set_buffer(cdata, i) From 560bbfeab3b3178b7a564fbe1ec464feff451397 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Fri, 18 Aug 2023 17:36:47 -0400 Subject: [PATCH 18/33] some clean up and documentation --- diag_manager/fms_diag_bbox.F90 | 28 +--- diag_manager/fms_diag_object.F90 | 124 +++++++++--------- diag_manager/fms_diag_output_buffer.F90 | 28 ++-- diag_manager/fms_diag_reduction_methods.F90 | 2 + .../include/fms_diag_reduction_methods.inc | 37 +++--- test_fms/diag_manager/test_time_none.sh | 19 +-- 6 files changed, 107 insertions(+), 131 deletions(-) diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 index a46cd776c2..f22225b263 100644 --- a/diag_manager/fms_diag_bbox.F90 +++ b/diag_manager/fms_diag_bbox.F90 @@ -54,7 +54,7 @@ MODULE fms_diag_bbox_mod procedure :: reset_bounds_from_array_4D procedure :: reset_bounds_from_array_5D procedure :: update_bounds - procedure :: update_bounds_from_halos + procedure :: set_bounds procedure :: reset_bounds_to_write procedure :: rebase procedure :: rebase_more @@ -89,7 +89,7 @@ MODULE fms_diag_bbox_mod procedure :: get_fje end type fmsDiagBoundsHalos_type - public :: recondition_indices, update_bounds_out, determine_if_block_is_in_region + public :: recondition_indices, determine_if_block_is_in_region integer, parameter :: xdimension = 1 integer, parameter :: ydimension = 2 @@ -299,7 +299,7 @@ subroutine reset_bounds_to_write(this, field_data) endif end subroutine - function update_bounds_from_halos(this, field_data, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k, has_halos) & + function set_bounds(this, field_data, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k, has_halos) & result(error_msg) CLASS (fmsDiagIbounds_type), intent(inout) :: this ! @brief Reset the instance bounding box with the bounds determined from the !! first three dimensions of the 5D "array" argument SUBROUTINE reset_bounds_from_array_4D(this, array) @@ -478,15 +478,11 @@ subroutine rebase_more(bounds_in, starting, ending, dimension) select case (dimension) case (xdimension) - print *, mpp_pe(), "beforex:", bounds_in%imin, bounds_in%imax, starting bounds_in%imin = max(starting, bounds_in%imin)-starting+1 bounds_in%imax = min(bounds_in%imax, bounds_in%imin + ending-starting) - print *, mpp_pe(), "afterx:", bounds_in%imin, bounds_in%imax case (ydimension) - print *, mpp_pe(), "beforey:", bounds_in%jmin, bounds_in%jmax, starting bounds_in%jmin = max(starting, bounds_in%jmin)-starting+1 bounds_in%jmax = min(bounds_in%jmax, bounds_in%jmin + ending-starting) - print *, mpp_pe(), "aftery:", bounds_in%jmin, bounds_in%jmax, starting case (zdimension) bounds_in%kmin =max(starting, bounds_in%kmin)-starting+1 bounds_in%kmax = min(bounds_in%kmax, bounds_in%kmin + ending-starting) @@ -515,22 +511,6 @@ subroutine rebase(bounds_in, bounds, starting, ending, dimension) end select end subroutine - subroutine update_bounds_out(bounds_in, bounds_out) - CLASS (fmsDiagIbounds_type), INTENT(in) :: bounds_in - CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_out - - if ((bounds_in%imax - bounds_in%imin+1) .ne. (bounds_out%imax - bounds_out%imin+1)) then - bounds_out%imax = bounds_in%imax - bounds_out%imin = bounds_in%imin - endif - - if ((bounds_in%jmax - bounds_in%jmin+1) .ne. (bounds_out%jmax - bounds_out%jmin+1)) then - bounds_out%jmax = bounds_in%jmax - bounds_out%jmin = bounds_in%jmin - endif - - end subroutine - END MODULE fms_diag_bbox_mod !> @} ! close documentation grouping diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index df5c860c66..dd577d13fd 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -41,7 +41,7 @@ module fms_diag_object_mod use fms_mod, only: fms_error_handler use fms_diag_reduction_methods_mod, only: check_indices_order, init_mask, set_weight use constants_mod, only: SECONDS_PER_DAY -USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type, update_bounds_out, determine_if_block_is_in_region +USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type, determine_if_block_is_in_region #endif #if defined(_OPENMP) use omp_lib @@ -520,9 +520,8 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm real(kind=r8_kind) :: field_weight !< Weight to use when averaging (it will be converted !! based on the type of field_data when doing the math) type(fmsDiagIbounds_type) :: bounds !< Bounds (starting ending indices) for the field - - logical :: has_halos - logical :: using_blocking + logical :: has_halos !< .True. if field_data contains halos + logical :: using_blocking !< .True. if field_data is passed in blocks #ifndef use_yaml CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") #else @@ -606,9 +605,9 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm fms_diag_accept_data = .TRUE. return else - call bounds%reset(999,-999) - err_msg = bounds%update_bounds_from_halos(field_data, is, ie, js, je, ks, ke, has_halos) - if (trim(err_msg) .ne. "") call mpp_error(FATAL, "WUT") + error_string = bounds%set_bounds(field_data, is, ie, js, je, ks, ke, has_halos) + if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info)) + call this%allocate_diag_field_output_buffers(field_data, diag_field_id) fms_diag_accept_data = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, field_weight, & bounds, using_blocking, Time=Time) @@ -728,9 +727,9 @@ subroutine fms_diag_do_io(this, is_end_of_run) #endif end subroutine fms_diag_do_io - !> @brief Computes average, min, max, rms error, etc. - !! based on the specified reduction method for the field. - !> @return .True. if no error occurs. +!> @brief Computes average, min, max, rms error, etc. +!! based on the specified reduction method for the field. +!> @return .True. if no error occurs. logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight, & bounds, using_blocking, time) class(fmsDiagObject_type), intent(in), target :: this !< Diag Object @@ -739,7 +738,8 @@ logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask logical, intent(in), target :: oor_mask(:,:,:,:) !< mask real(kind=r8_kind), intent(in) :: weight !< Must be a updated weight type(fmsDiagIbounds_type), intent(in) :: bounds !< Bounds for the field - logical, intent(in) :: using_blocking + logical, intent(in) :: using_blocking !< .True. if field data is passed + !! in blocks type(time_type), intent(in), optional :: time !< Current time !TODO Mostly everything @@ -749,59 +749,64 @@ logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask class(fmsDiagFileContainer_type), pointer :: file_ptr !< Pointer to the field's file type(diagYamlFilesVar_type), pointer :: field_yaml_ptr !< Pointer to the field's yaml - integer :: reduction_method !< Integer representing a reduction method - integer :: ids !< For looping through buffer ids - integer :: buffer_id !< Id of the buffer - integer :: file_id !< File id - character(len=50) :: error_msg !< Error message to check - integer, allocatable :: axis_ids(:) - logical :: is_regional - logical :: reduced_k_range - type(fmsDiagIbounds_type) :: bounds_in - type(fmsDiagIbounds_type) :: bounds_out - integer :: i - integer :: sindex - integer :: eindex - integer :: compute_idx(2) - logical :: dummy - character(len=1) :: cart_axis - logical :: is_block_in_region - integer :: starting, ending + integer :: reduction_method !< Integer representing a reduction method + integer :: ids !< For looping through buffer ids + integer :: buffer_id !< Id of the buffer + integer :: file_id !< File id + character(len=50) :: error_msg !< Error message to check + integer, allocatable :: axis_ids(:) !< Axis ids for the buffer + logical :: is_subregional !< .True. if the buffer is subregional + logical :: reduced_k_range !< .True. is the field is only outputing a section + !! of the z dimension + type(fmsDiagIbounds_type) :: bounds_in !< Starting and ending indices of the input field_data + type(fmsDiagIbounds_type) :: bounds_out !< Starting and ending indices of the output buffer + integer :: i !< For looping through axid ids + integer :: sindex !< Starting index of a subregion + integer :: eindex !< Ending index of a subregion + integer :: compute_idx(2) !< Starting and Ending of the compute domain + character(len=1) :: cart_axis !< Cartesian axis of the axis + logical :: block_in_subregion !< .True. if the current block is part of the subregion + integer :: starting !< Starting index of the subregion relative to the compute domain + integer :: ending !< Ending index of the subregion relative to the compute domain !TODO mostly everything field_ptr => this%FMS_diag_fields(diag_field_id) - do ids = 1, size(field_ptr%buffer_ids) + buffer_loop: do ids = 1, size(field_ptr%buffer_ids) error_msg = "" + buffer_id = this%FMS_diag_fields(diag_field_id)%buffer_ids(ids) + file_id = this%FMS_diag_fields(diag_field_id)%file_ids(ids) + !< Gather all the objects needed for the buffer field_yaml_ptr => field_ptr%diag_field(ids) - buffer_id = this%FMS_diag_fields(diag_field_id)%buffer_ids(ids) - buffer_ptr => this%FMS_diag_output_buffers(buffer_id) - file_id = this%FMS_diag_fields(diag_field_id)%file_ids(ids) !TODO not sure if this is correct - file_ptr => this%FMS_diag_files(file_id) + buffer_ptr => this%FMS_diag_output_buffers(buffer_id) + file_ptr => this%FMS_diag_files(file_id) + !< Leave if the current PE does not contain any data if (.not. file_ptr%writing_on_this_pe()) cycle - !< Initialize the bounds bounds_out = bounds - bounds_in = bounds - call bounds_out%reset_bounds_from_array_4D(buffer_ptr%buffer(:,:,:,:,1)) - call update_bounds_out(bounds, bounds_out) + if (.not. using_blocking) then + !< Set output bounds to start at 1:size(buffer_ptr%buffer) + call bounds_out%reset_bounds_from_array_4D(buffer_ptr%buffer(:,:,:,:,1)) + endif - if (.not. bounds_in%has_halos) then - print *, "buffer has halos" + bounds_in = bounds + if (.not. bounds%has_halos) then + !< If field_data does not contain halos, set bounds_in to start at 1:size(field_data) call bounds_in%reset_bounds_from_array_4D(field_data) endif - !< Reset the bounds based on the reduced k range and subregional - is_regional = file_ptr%is_regional() + is_subregional = file_ptr%is_regional() reduced_k_range = field_yaml_ptr%has_var_zbounds() - if (is_regional .or. reduced_k_range) then - print *, "buffer is subregional" + !< Reset the bounds based on the reduced k range and subregional + is_subregional_reduced_k_range: if (is_subregional .or. reduced_k_range) then axis_ids = buffer_ptr%get_axis_ids() - is_block_in_region = .true. - do i = 1, size(axis_ids) - if (.not. is_block_in_region) cycle + block_in_subregion = .true. + axis_loops: do i = 1, size(axis_ids) + !< Move on if the block does not have any data for the subregion + if (.not. block_in_subregion) cycle + select type (diag_axis => this%diag_axis(axis_ids(i))%axis) type is (fmsDiagSubAxis_type) sindex = diag_axis%get_starting_index() @@ -810,24 +815,25 @@ logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask starting=sindex-compute_idx(1)+1 ending=eindex-compute_idx(1)+1 if (using_blocking) then - is_block_in_region = determine_if_block_is_in_region(starting, ending, bounds, i) - !call bounds_out%update_index(starting, ending, i, .false.) - call bounds_out%rebase_more(starting, ending, i) + block_in_subregion = determine_if_block_is_in_region(starting, ending, bounds, i) + !< Set bounds_in so that you can the correct section of the data for the block (starting at 1) call bounds_in%rebase(bounds, starting, ending, i) - if (i .eq. 1) print *, string(mpp_pe()), " is x ", string(bounds%get_imin()), ":", string(bounds%get_imax()), starting, ending, is_block_in_region, string(bounds_in%get_imin()), ":", string(bounds_in%get_imax()) - if (i .eq. 2) print *, string(mpp_pe()), " is y ", string(bounds%get_jmin()), ":", string(bounds%get_jmax()), starting, ending, is_block_in_region, string(bounds_in%get_jmin()), ":", string(bounds_in%get_jmax()) - if (i .eq. 3) print *, string(mpp_pe()), " is z ", string(bounds%get_kmin()), ":", string(bounds%get_kmax()), starting, ending, is_block_in_region, string(bounds_in%get_kmin()), ":", string(bounds_in%get_kmax()) + + !< Set bounds_out to be the correct section relative to the block starting and ending indices + call bounds_out%rebase_more(starting, ending, i) else + !< Set bounds_in so that only the subregion section of the data will be used (starting at 1) call bounds_in%update_index(starting, ending, i, .false.) + + !< Set bounds_out to 1:size(subregion) for the PE call bounds_out%update_index(1, ending-starting+1, i, .true.) endif end select - enddo - ! write((mpp_pe()+1)*100, *) bounds_in%get_imin(), bounds_in%get_imax(), bounds_in%get_jmin(), bounds_in%get_jmax() - ! write((mpp_pe()+1)*100, *) bounds_out%get_imin(), bounds_out%get_imax(), bounds_out%get_jmin(), bounds_out%get_jmax() + enddo axis_loops deallocate(axis_ids) - if (.not. is_block_in_region) return - endif + !< Move on to the next buffer if the block does not have any data for the subregion + if (.not. block_in_subregion) cycle + endif is_subregional_reduced_k_range !< Determine the reduction method for the buffer reduction_method = field_yaml_ptr%get_var_reduction() @@ -841,7 +847,7 @@ logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask case (time_rms) case (time_diurnal) end select - enddo + enddo buffer_loop fms_diag_do_reduction = .true. #else fms_diag_do_reduction = .false. diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90 index b5ce3c6a3d..fd361efdc0 100644 --- a/diag_manager/fms_diag_output_buffer.F90 +++ b/diag_manager/fms_diag_output_buffer.F90 @@ -28,7 +28,7 @@ module fms_diag_output_buffer_mod use platform_mod use iso_c_binding use time_manager_mod, only: time_type -use mpp_mod, only: mpp_error, FATAL, mpp_pe +use mpp_mod, only: mpp_error, FATAL use diag_data_mod, only: DIAG_NULL, DIAG_NOT_REGISTERED, i4, i8, r4, r8 use fms2_io_mod, only: FmsNetcdfFile_t, write_data, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t use fms_diag_yaml_mod, only: diag_yaml @@ -436,24 +436,36 @@ subroutine write_buffer_wrapper_u(this, fms2io_fileobj, unlim_dim_level) end select end subroutine write_buffer_wrapper_u +!> @brief Does the time_none reduction method on the buffer object +!! @return Error message if the math was not successful function do_time_none_wrapper(this, field_data, mask, bounds_in, bounds_out) & result(err_msg) - class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write - class(*), intent(in) :: field_data(:,:,:,:) - type(fmsDiagIbounds_type), intent(in) :: bounds_in - type(fmsDiagIbounds_type), intent(in) :: bounds_out - logical, intent(in) :: mask(:,:,:,:) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write + class(*), intent(in) :: field_data(:,:,:,:) !< Buffer data for current time + type(fmsDiagIbounds_type), intent(in) :: bounds_in !< Indicies for the buffer passed in + type(fmsDiagIbounds_type), intent(in) :: bounds_out !< Indicies for the output buffer + logical, intent(in) :: mask(:,:,:,:) !< Mask for the field character(len=50) :: err_msg + !TODO This does not need to be done for every time step + !TODO This will be expanded for integers err_msg = "" select type (output_buffer => this%buffer) type is (real(kind=r8_kind)) select type (field_data) type is (real(kind=r8_kind)) - err_msg=do_time_none(output_buffer, field_data, mask, bounds_in, bounds_out) + call do_time_none(output_buffer, field_data, mask, bounds_in, bounds_out) + class default + err_msg="output buffer the buffer send in are not of the same type (r8_kind)" + end select + type is (real(kind=r4_kind)) + select type (field_data) + type is (real(kind=r4_kind)) + call do_time_none(output_buffer, field_data, mask, bounds_in, bounds_out) + class default + err_msg="output buffer the buffer send in are not of the same type (r4_kind)" end select end select - end function do_time_none_wrapper #endif end module fms_diag_output_buffer_mod diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index e59813a1c8..617454928f 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -37,6 +37,8 @@ module fms_diag_reduction_methods_mod public :: check_indices_order, init_mask, set_weight public :: do_time_none + !> @brief Does the time_none reduction method. See include/fms_diag_reduction_methods.inc + !TODO This needs to be extended to integers interface do_time_none module procedure do_time_none_r4, do_time_none_r8 end interface do_time_none diff --git a/diag_manager/include/fms_diag_reduction_methods.inc b/diag_manager/include/fms_diag_reduction_methods.inc index 808236ff40..0d6633285b 100644 --- a/diag_manager/include/fms_diag_reduction_methods.inc +++ b/diag_manager/include/fms_diag_reduction_methods.inc @@ -17,17 +17,20 @@ !* License along with FMS. If not, see . !*********************************************************************** -function DO_TIME_NONE_ (data_out, data_in, mask, bounds_in, bounds_out) & -result(error_msg) - real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) - real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) - logical, intent(in), target :: mask(:,:,:,:) - type(fmsDiagIbounds_type), intent(in) :: bounds_in - type(fmsDiagIbounds_type), intent(in) :: bounds_out +!> @brief Do the time_none reduction method (i.e copy the correct portion of the input data) +subroutine DO_TIME_NONE_ (data_out, data_in, mask, bounds_in, bounds_out) + real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data + real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< data to update the buffer with + logical, intent(in) :: mask(:,:,:,:) !< mask + type(fmsDiagIbounds_type), intent(in) :: bounds_in !< indices indicating the correct portion + !! of the input buffer + type(fmsDiagIbounds_type), intent(in) :: bounds_out !< indices indicating the correct portion + !! of the output buffer - character(len=50) :: error_msg - integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in - integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out + integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in !< Starting and ending indices of each dimention for + !! the input buffer + integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out !< Starting and ending indices of each dimention for + !! the output buffer is_out = bounds_out%get_imin() ie_out = bounds_out%get_imax() @@ -43,18 +46,8 @@ result(error_msg) ks_in = bounds_in%get_kmin() ke_in = bounds_in%get_kmax() -! write ((mpp_pe()+1)*100, *) "BOUNDS", lbound(mask), ubound(mask) - write ((mpp_pe()+1)*100, *) "indices_in:", is_in,ie_in, js_in,je_in, ks_in,ke_in - write ((mpp_pe()+1)*100, *) "indices_out:", is_out,ie_out, js_out,je_out, ks_out,ke_out - write ((mpp_pe()+1)*100, *) "bounds_in", lbound(data_in), ubound(data_in) - write ((mpp_pe()+1)*100, *) "bounds_in", lbound(data_out), ubound(data_out) - - write ((mpp_pe()+1)*100, *) "WUTT:", mask(is_in:ie_in, js_in:je_in, ks_in:ke_in, :) where (mask(is_in:ie_in, js_in:je_in, ks_in:ke_in, :)) & data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) = & data_in(is_in:ie_in, js_in:je_in, ks_in:ke_in, :) - - write ((mpp_pe()+1)*100, *) "data_in:", data_in(is_in:ie_in, js_in:je_in, ks_in:ke_in, :) - write ((mpp_pe()+1)*100, *) "data_out:", data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) - error_msg = "" -end function DO_TIME_NONE_ \ No newline at end of file + +end subroutine DO_TIME_NONE_ \ 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 index 88ef897691..c26e7f6d38 100755 --- a/test_fms/diag_manager/test_time_none.sh +++ b/test_fms/diag_manager/test_time_none.sh @@ -28,24 +28,6 @@ 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 - cat <<_EOF > diag_table.yaml title: test_none base_date: 2 1 1 0 0 0 @@ -127,6 +109,7 @@ test_expect_success "Checking answers for the "none" reduction method, real mask mpirun -n 1 ../check_time_none ' +#TODO this needs to be set back to 2, once the set_math_needs_to_be_done=.true. portion of the code is implemented export OMP_NUM_THREADS=1 my_test_count=`expr $my_test_count + 1` printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml From 198293536c41871abd0c63d483f0135f27d0139a Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 21 Aug 2023 10:49:12 -0400 Subject: [PATCH 19/33] more documentation updates to the diag_object and diag_bbox --- diag_manager/fms_diag_bbox.F90 | 129 +++++++++++++++---------------- diag_manager/fms_diag_object.F90 | 12 +-- 2 files changed, 67 insertions(+), 74 deletions(-) diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 index f22225b263..f0b830d746 100644 --- a/diag_manager/fms_diag_bbox.F90 +++ b/diag_manager/fms_diag_bbox.F90 @@ -55,9 +55,8 @@ MODULE fms_diag_bbox_mod procedure :: reset_bounds_from_array_5D procedure :: update_bounds procedure :: set_bounds - procedure :: reset_bounds_to_write - procedure :: rebase - procedure :: rebase_more + procedure :: rebase_input + procedure :: rebase_output procedure :: get_imin procedure :: get_imax procedure :: get_jmin @@ -97,14 +96,17 @@ MODULE fms_diag_bbox_mod CONTAINS -logical function determine_if_block_is_in_region(subregion_start, subregion_end, bounds, dimension) - integer, intent(in) :: subregion_start - integer, intent(in) :: subregion_end - type(fmsDiagIbounds_type), intent(in) :: bounds - integer, intent(in) :: dimension +!> @brief The PEs grid points are divided further into "blocks". This function determines if a block +! has data for a given subregion and dimension +!! @return .true. if the a subergion is inside a block +logical pure function determine_if_block_is_in_region(subregion_start, subregion_end, bounds, dimension) + integer, intent(in) :: subregion_start !< Begining of the subregion + integer, intent(in) :: subregion_end !< Ending of the subregion + type(fmsDiagIbounds_type), intent(in) :: bounds !< Starting and ending of the subregion + integer, intent(in) :: dimension !< Dimension to check - integer :: block_start - integer :: block_end + integer :: block_start !< Begining index of the block + integer :: block_end !< Ending index of the block determine_if_block_is_in_region = .true. select case (dimension) @@ -175,14 +177,21 @@ pure integer function get_kmax (this) result(rslt) rslt = this%kmax end function get_kmax + !> @brief Updates the starting and ending index of a given dimension subroutine update_index(this, starting_index, ending_index, dimension, ignore_halos) - class (fmsDiagIbounds_type), intent(inout) :: this !< The !< ibounds instance - integer, intent(in) :: starting_index - integer, intent(in) :: ending_index - integer, intent(in) :: dimension - logical, intent(in) :: ignore_halos + class (fmsDiagIbounds_type), intent(inout) :: this !< The bounding box to update + integer, intent(in) :: starting_index !< Starting index to update to + integer, intent(in) :: ending_index !< Ending index to update to + integer, intent(in) :: dimension !< Dimension to update + logical, intent(in) :: ignore_halos !< If .true. halos will be ignored + !! i.e output buffers can ignore halos as + !! they do not get updates. The indices of the + !! Input buffers need to add the number of halos + !! so math is done only on the compute domain + + integer :: nhalox !< Number of halos in x + integer :: nhaloy !< Number of halos in y - integer :: nhalox, nhaloy if (ignore_halos) then nhalox = 0 nhaloy = 0 @@ -277,44 +286,25 @@ SUBROUTINE update_bounds(this, lower_i, upper_i, lower_j, upper_j, lower_k, uppe this%kmax = MAX(this%kmax, upper_k) END SUBROUTINE update_bounds - subroutine reset_bounds_to_write(this, field_data) - CLASS (fmsDiagIbounds_type), intent(inout) :: this ! @brief Sets the bounds of a bounding region + !! @return empty string if sucessful or error message if unsucessful function set_bounds(this, field_data, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k, has_halos) & result(error_msg) - CLASS (fmsDiagIbounds_type), intent(inout) :: this ! @brief Rebase the ouput bounds for a given dimension based on the starting and ending indices + subroutine rebase_output(bounds_out, starting, ending, dimension) + CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_out !< Bounds to rebase + integer, intent(in) :: starting !< Starting index of the dimension + integer, intent(in) :: ending !< Ending index of the dimension + integer, intent(in) :: dimension !< Dimension to update select case (dimension) case (xdimension) - bounds_in%imin = max(starting, bounds_in%imin)-starting+1 - bounds_in%imax = min(bounds_in%imax, bounds_in%imin + ending-starting) + bounds_out%imin = max(starting, bounds_out%imin)-starting+1 + bounds_out%imax = min(bounds_out%imax, bounds_out%imin + ending-starting) case (ydimension) - bounds_in%jmin = max(starting, bounds_in%jmin)-starting+1 - bounds_in%jmax = min(bounds_in%jmax, bounds_in%jmin + ending-starting) + bounds_out%jmin = max(starting, bounds_out%jmin)-starting+1 + bounds_out%jmax = min(bounds_out%jmax, bounds_out%jmin + ending-starting) case (zdimension) - bounds_in%kmin =max(starting, bounds_in%kmin)-starting+1 - bounds_in%kmax = min(bounds_in%kmax, bounds_in%kmin + ending-starting) + bounds_out%kmin =max(starting, bounds_out%kmin)-starting+1 + bounds_out%kmax = min(bounds_out%kmax, bounds_out%kmin + ending-starting) end select end subroutine - subroutine rebase(bounds_in, bounds, starting, ending, dimension) - CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_in - CLASS (fmsDiagIbounds_type), INTENT(in) :: bounds - integer, intent(in) :: ending - integer, intent(in) :: starting - integer, intent(in) :: dimension + !> @brief Rebase the input bounds for a given dimension based on the starting and ending indices + subroutine rebase_input(bounds_in, bounds, starting, ending, dimension) + CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_in !< Bounds to rebase + CLASS (fmsDiagIbounds_type), INTENT(in) :: bounds !< Original indices (i.e is_in, ie_in, + !! passed into diag_manager) + integer, intent(in) :: starting !< Starting index of the dimension + integer, intent(in) :: ending !< Ending index of the dimension + integer, intent(in) :: dimension !< Dimension to update select case (dimension) case (xdimension) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index dd577d13fd..fa393eaf5e 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -17,7 +17,6 @@ !* License along with FMS. If not, see . !*********************************************************************** module fms_diag_object_mod - use fms_mod, only: string use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe, stdout use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, & &DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, & @@ -781,7 +780,7 @@ logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask buffer_ptr => this%FMS_diag_output_buffers(buffer_id) file_ptr => this%FMS_diag_files(file_id) - !< Leave if the current PE does not contain any data + !< Go away if the file is a subregional file and the current PE does not have any data for it if (.not. file_ptr%writing_on_this_pe()) cycle bounds_out = bounds @@ -817,10 +816,10 @@ logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask if (using_blocking) then block_in_subregion = determine_if_block_is_in_region(starting, ending, bounds, i) !< Set bounds_in so that you can the correct section of the data for the block (starting at 1) - call bounds_in%rebase(bounds, starting, ending, i) + call bounds_in%rebase_input(bounds, starting, ending, i) !< Set bounds_out to be the correct section relative to the block starting and ending indices - call bounds_out%rebase_more(starting, ending, i) + call bounds_out%rebase_output(starting, ending, i) else !< Set bounds_in so that only the subregion section of the data will be used (starting at 1) call bounds_in%update_index(starting, ending, i, .false.) @@ -1129,8 +1128,8 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id) class(*), allocatable :: missing_value !< Missing value to initialize the data to character(len=128), allocatable :: var_name !< Field name to initialize output buffers logical :: is_scalar !< Flag indicating that the variable is a scalar - integer :: yaml_id - integer :: file_id + integer :: yaml_id !< Yaml id for the buffer + integer :: file_id !< File id for the buffer if (this%FMS_diag_fields(field_id)%buffer_allocated) return @@ -1171,6 +1170,7 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id) buffer_id = this%FMS_diag_fields(field_id)%buffer_ids(i) file_id = this%FMS_diag_fields(field_id)%file_ids(i) + !< Go away if the file is a subregional file and the current PE does not have any data for it if (.not. this%FMS_diag_files(file_id)%writing_on_this_pe()) cycle ndims = 0 From ec707f20dd1d178ff0a6f2995bc7ac10bd155738 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 21 Aug 2023 11:02:51 -0400 Subject: [PATCH 20/33] more documentation updates, fix lint --- diag_manager/fms_diag_axis_object.F90 | 37 +++++++++++++++------------ diag_manager/fms_diag_bbox.F90 | 6 ++--- 2 files changed, 23 insertions(+), 20 deletions(-) diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90 index 835b25ad93..8a31f445f3 100644 --- a/diag_manager/fms_diag_axis_object.F90 +++ b/diag_manager/fms_diag_axis_object.F90 @@ -115,7 +115,7 @@ module fms_diag_axis_object_mod INTEGER , private :: ending_index !< Ending index of the subaxis relative to the !! parent axis INTEGER , private :: parent_axis_id !< Id of the parent_axis - INTEGER , private :: compute_idx(2) + INTEGER , private :: compute_idx(2) !< Starting and ending index of the compute domain real(kind=r4_kind), allocatable, private :: zbounds(:) !< Bounds of the Z axis contains procedure :: fill_subaxis @@ -740,14 +740,16 @@ end subroutine get_compute_domain !!!!!!!!!!!!!!!!!! SUB AXIS PROCEDURES !!!!!!!!!!!!!!!!! !> @brief Fills in the information needed to define a subaxis - subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id, parent_axis_name, compute_idx, zbounds) + subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id, parent_axis_name, compute_idx, & + zbounds) class(fmsDiagSubAxis_type) , INTENT(INOUT) :: this !< diag_sub_axis obj integer , intent(in) :: starting_index !< Starting index of the subRegion for the PE integer , intent(in) :: ending_index !< Ending index of the subRegion for the PE integer , intent(in) :: axis_id !< Axis id to assign to the subaxis - integer , intent(in) :: parent_id !< The id of the parent axis, the subaxis belongs to + integer , intent(in) :: parent_id !< The id of the parent axis the subaxis belongs to character(len=*) , intent(in) :: parent_axis_name !< Name of the parent_axis - integer , intent(in) :: compute_idx(2) + integer , intent(in) :: compute_idx(2) !< Starting and ending index of + !! the axis's compute domain real(kind=r4_kind), optional, intent(in) :: zbounds(2) !< Bounds of the z-axis this%axis_id = axis_id @@ -1060,18 +1062,18 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_ logical, intent(out) :: write_on_this_pe !< .true. if the subregion !! is on this PE - real :: lat(2) !< Starting and ending lattiude of the subRegion - real :: lon(2) !< Starting and ending longitude or the subRegion - integer :: lat_indices(2) !< Starting and ending latitude indices of the subRegion - integer :: lon_indices(2) !< Starting and ending longitude indices of the subRegion - integer :: compute_idx(2) !< Compute domain of the current axis - integer :: starting_index(2) !< Starting index of the subRegion for the current PE - integer :: ending_index(2) !< Ending index of the subRegion for the current PE - logical :: need_to_define_axis(2) !< .true. if it is needed to define the subaxis - integer :: i !< For do loops - integer :: parent_axis_ids(2) - logical :: is_x_y_axis - integer :: compute_idx_2(2, 2) + real :: lat(2) !< Starting and ending lattiude of the subRegion + real :: lon(2) !< Starting and ending longitude or the subRegion + integer :: lat_indices(2) !< Starting and ending latitude indices of the subRegion + integer :: lon_indices(2) !< Starting and ending longitude indices of the subRegion + integer :: compute_idx(2) !< Compute domain of the current axis + integer :: starting_index(2) !< Starting index of the subRegion for the current PE for the "x" and "y" direction + integer :: ending_index(2) !< Ending index of the subRegion for the current PE for the "x" and "y" direction + logical :: need_to_define_axis(2) !< .true. if it is needed to define the subaxis for the "x" and "y" direction + integer :: i !< For do loops + integer :: parent_axis_ids(2) !< The axis id of the parent axis for the "x" and "y" direction + logical :: is_x_y_axis !< .true. if the axis is x or y + integer :: compute_idx_2(2, 2) !< Starting and ending indices of the compute domain for the "x" and "y" direction !< Get the rectangular coordinates of the subRegion !! If the subRegion is not rectangular, the points outside of the subRegion will be masked @@ -1175,7 +1177,8 @@ subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, & integer, intent(in) :: parent_id !< Id of the parent axis integer, intent(in) :: starting_index !< PE's Starting index integer, intent(in) :: ending_index !< PE's Ending index - integer, intent(in) :: compute_idx(2) + integer, intent(in) :: compute_idx(2) !< Starting and ending index of + !! the axis's compute domain integer, optional, intent(out) :: new_axis_id !< Axis id of the axis this is creating real(kind=r4_kind), optional, intent(in) :: zbounds(2) !< Bounds of the Z axis diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 index f0b830d746..e086216a8d 100644 --- a/diag_manager/fms_diag_bbox.F90 +++ b/diag_manager/fms_diag_bbox.F90 @@ -46,9 +46,9 @@ MODULE fms_diag_bbox_mod INTEGER :: jmax !< Upper j bound. INTEGER :: kmin !< Lower k bound. INTEGER :: kmax !< Upper k bound. - logical :: has_halos - integer :: nhalo_I - integer :: nhalo_J + logical :: has_halos !< .True. if the buffer has halos + integer :: nhalo_I !< Number of halos in i + integer :: nhalo_J !< Number of halos in j contains procedure :: reset => reset_bounds procedure :: reset_bounds_from_array_4D From 686b2b799c9f6dc847253bbbcbda977f57d8342f Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 21 Aug 2023 11:07:03 -0400 Subject: [PATCH 21/33] move a use statement so that it can compile without yaml --- diag_manager/fms_diag_object.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index fa393eaf5e..8d63741c69 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -40,8 +40,8 @@ module fms_diag_object_mod use fms_mod, only: fms_error_handler use fms_diag_reduction_methods_mod, only: check_indices_order, init_mask, set_weight use constants_mod, only: SECONDS_PER_DAY -USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type, determine_if_block_is_in_region #endif +USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type, determine_if_block_is_in_region #if defined(_OPENMP) use omp_lib #endif From 086931e5bd02a70f18af58c4666d061f03ce8d1a Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 21 Aug 2023 11:36:36 -0400 Subject: [PATCH 22/33] lint fix --- diag_manager/fms_diag_axis_object.F90 | 3 ++- diag_manager/fms_diag_bbox.F90 | 2 -- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90 index 8a31f445f3..70250dd303 100644 --- a/diag_manager/fms_diag_axis_object.F90 +++ b/diag_manager/fms_diag_axis_object.F90 @@ -1067,7 +1067,8 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_ integer :: lat_indices(2) !< Starting and ending latitude indices of the subRegion integer :: lon_indices(2) !< Starting and ending longitude indices of the subRegion integer :: compute_idx(2) !< Compute domain of the current axis - integer :: starting_index(2) !< Starting index of the subRegion for the current PE for the "x" and "y" direction + integer :: starting_index(2) !< Starting index of the subRegion for the current PE for the "x" and "y" + !! direction integer :: ending_index(2) !< Ending index of the subRegion for the current PE for the "x" and "y" direction logical :: need_to_define_axis(2) !< .true. if it is needed to define the subaxis for the "x" and "y" direction integer :: i !< For do loops diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 index e086216a8d..6c71761911 100644 --- a/diag_manager/fms_diag_bbox.F90 +++ b/diag_manager/fms_diag_bbox.F90 @@ -491,11 +491,9 @@ subroutine rebase_input(bounds_in, bounds, starting, ending, dimension) select case (dimension) case (xdimension) - print *, string(mpp_pe()), " is x ", starting-bounds_in%imin+1, starting bounds_in%imin = min(starting-bounds%imin+1, starting) bounds_in%imax = bounds_in%imin + (ending-starting) case (ydimension) - print *, string(mpp_pe()), " is x ", starting-bounds_in%jmin+1, starting bounds_in%jmin = min(starting-bounds%jmin+1, starting) bounds_in%jmax = bounds_in%jmin + (ending-starting) case (zdimension) From 31c0e8c49818553262e2a145ae0e73c3949576e6 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 21 Aug 2023 15:05:58 -0400 Subject: [PATCH 23/33] Fix some bugs in %rebase_input and don't use pointer remapping --- diag_manager/diag_manager.F90 | 49 +++++++++++++++------ diag_manager/fms_diag_bbox.F90 | 12 ++--- diag_manager/fms_diag_object.F90 | 10 +++-- diag_manager/fms_diag_reduction_methods.F90 | 8 ++-- 4 files changed, 52 insertions(+), 27 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index c153b564ef..9f75ad6915 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1676,9 +1676,9 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, CHARACTER(len=128) :: error_string, error_string1 REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field - class(*), pointer, dimension(:,:,:,:) :: field_remap !< 4d remapped pointer - logical, pointer, dimension(:,:,:,:) :: mask_remap !< 4d remapped pointer - class(*), pointer, dimension(:,:,:,:) :: rmask_remap !< 4d remapped pointer + class(*), allocatable, dimension(:,:,:,:) :: field_remap !< 4d remapped pointer + logical, allocatable, dimension(:,:,:,:) :: mask_remap !< 4d remapped pointer + class(*), allocatable, dimension(:,:,:,:) :: rmask_remap !< 4d remapped pointer REAL(kind=r4_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r4 !< A pointer to r4 type of rmask REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 ! Set up array lengths for remapping - field_remap => null() - mask_remap => null() - rmask_remap => null() - ie = SIZE(field,1) - je = SIZE(field,2) - ke = SIZE(field,3) - field_remap(1:ie,1:je,1:ke,1:1) => field - if (present(mask)) mask_remap(1:ie,1:je,1:ke,1:1) => mask - if (present(rmask)) rmask_remap(1:ie,1:je,1:ke,1:1) => rmask + + field_remap = copy_3d_to_4d(field) + if (present(rmask)) rmask_remap = copy_3d_to_4d(rmask) + if (present(mask)) then + allocate(mask_remap(1:size(mask,1), 1:size(mask,2), 1:size(mask,3), 1)) + mask_remap(:,:,:,1) = mask + endif endif SELECT TYPE (field) TYPE IS (real(kind=r4_kind)) @@ -1744,7 +1742,9 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, diag_send_data = fms_diag_object%fms_diag_accept_data(diag_field_id, field_remap, mask_remap, rmask_remap, & time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, & err_msg) - nullify (field_remap) + deallocate (field_remap) + if (allocated(mask_remap)) deallocate(mask_remap) + if (allocated(rmask_remap)) deallocate(rmask_remap) elSE ! modern_if ! oor_mask is only used for checking out of range values. ALLOCATE(oor_mask(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status) @@ -4480,6 +4480,29 @@ SUBROUTINE diag_field_add_cell_measures(diag_field_id, area, volume) END IF END SUBROUTINE diag_field_add_cell_measures + !> @brief Copies a 3d buffer to a 4d buffer + !> @return a 4d buffer + function copy_3d_to_4d(data_in) & + result(data_out) + class (*), intent(in) :: data_in(:,:,:) !< Data to copy + class (*), allocatable :: data_out(:,:,:,:) + + select type(data_in) + type is (real(kind=r8_kind)) + allocate(real(kind=r8_kind) :: data_out(1:size(data_in,1), 1:size(data_in,2), 1:size(data_in,3), 1)) + select type (data_out) + type is (real(kind=r8_kind)) + data_out(:,:,:,1) = data_in + end select + type is (real(kind=r4_kind)) + allocate(real(kind=r4_kind) :: data_out(1:size(data_in,1), 1:size(data_in,2), 1:size(data_in,3), 1)) + select type (data_out) + type is (real(kind=r4_kind)) + data_out(:,:,:,1) = data_in + end select + end select + end function + END MODULE diag_manager_mod !> @} ! close documentation grouping diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 index 6c71761911..b4f69c0ef6 100644 --- a/diag_manager/fms_diag_bbox.F90 +++ b/diag_manager/fms_diag_bbox.F90 @@ -491,14 +491,14 @@ subroutine rebase_input(bounds_in, bounds, starting, ending, dimension) select case (dimension) case (xdimension) - bounds_in%imin = min(starting-bounds%imin+1, starting) - bounds_in%imax = bounds_in%imin + (ending-starting) + bounds_in%imin = min(abs(starting-bounds%imin+1), starting) + bounds_in%imax = min(bounds_in%imax, (bounds_in%imin + ending-starting)) case (ydimension) - bounds_in%jmin = min(starting-bounds%jmin+1, starting) - bounds_in%jmax = bounds_in%jmin + (ending-starting) + bounds_in%jmin = min(abs(starting-bounds%jmin+1), starting) + bounds_in%jmax = min(bounds_in%jmax, (bounds_in%jmin + ending-starting)) case (zdimension) - bounds_in%kmin = min(starting-bounds%kmin+1, starting) - bounds_in%kmax = bounds_in%kmin + (ending-starting) + bounds_in%kmin = min(abs(starting-bounds%kmin+1), starting) + bounds_in%kmax = min(bounds_in%kmax, (bounds_in%kmin + ending-starting)) end select end subroutine diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 8d63741c69..9e1d3c772d 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -495,9 +495,9 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm class(fmsDiagObject_type),TARGET, INTENT(inout) :: this !< Diaj_obj to fill INTEGER, INTENT(in) :: diag_field_id !< The ID of the diag field CLASS(*), DIMENSION(:,:,:,:), INTENT(in) :: field_data !< The data for the diag_field - LOGICAL, DIMENSION(:,:,:,:), pointer, INTENT(in) :: mask !< Logical mask indicating the grid + LOGICAL, allocatable, INTENT(in) :: mask(:,:,:,:) !< Logical mask indicating the grid !! points to mask (null if no mask) - CLASS(*), DIMENSION(:,:,:,:), pointer, INTENT(in) :: rmask !< real mask indicating the grid + CLASS(*), allocatable, INTENT(in) :: rmask(:,:,:,:)!< real mask indicating the grid !! points to mask (null if no mask) CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight used for averaging TYPE (time_type), INTENT(in), OPTIONAL :: time !< The current time @@ -547,13 +547,13 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm !< If the field has `mask_variant=.true.`, check that mask OR rmask are present if (this%FMS_diag_fields(diag_field_id)%is_mask_variant()) then - if (.not. associated(mask) .and. .not. associated(rmask)) call mpp_error(FATAL, & + if (.not. allocated(mask) .and. .not. allocated(rmask)) call mpp_error(FATAL, & "The field was registered with mask_variant, but mask or rmask are not present in the send_data call. "//& trim(field_info)) endif !< Check that mask and rmask are not both present - if (associated(mask) .and. associated(rmask)) call mpp_error(FATAL, & + if (allocated(mask) .and. allocated(rmask)) call mpp_error(FATAL, & "mask and rmask are both present in the send_data call. "//& trim(field_info)) @@ -815,6 +815,8 @@ logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask ending=eindex-compute_idx(1)+1 if (using_blocking) then block_in_subregion = determine_if_block_is_in_region(starting, ending, bounds, i) + if (.not. block_in_subregion) cycle + !< Set bounds_in so that you can the correct section of the data for the block (starting at 1) call bounds_in%rebase_input(bounds, starting, ending, i) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 617454928f..fa4a7b9fcd 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -91,8 +91,8 @@ end function check_indices_order !> @return logical mask function init_mask(rmask, mask, field) & result(oor_mask) - LOGICAL, DIMENSION(:,:,:,:), pointer, INTENT(in) :: mask !< The location of the mask - CLASS(*), DIMENSION(:,:,:,:), pointer, INTENT(in) :: rmask !< The masking values + LOGICAL, DIMENSION(:,:,:,:), allocatable, INTENT(in) :: mask !< The location of the mask + CLASS(*), DIMENSION(:,:,:,:), allocatable, INTENT(in) :: rmask !< The masking values CLASS(*), DIMENSION(:,:,:,:), intent(in) :: field !< Field_data logical, allocatable, dimension(:,:,:,:) :: oor_mask !< mask @@ -100,9 +100,9 @@ function init_mask(rmask, mask, field) & ALLOCATE(oor_mask(SIZE(field, 1), SIZE(field, 2), SIZE(field, 3), SIZE(field, 4))) oor_mask = .true. - if (associated(mask)) then + if (allocated(mask)) then oor_mask = mask - elseif (associated(rmask)) then + elseif (allocated(rmask)) then select type (rmask) type is (real(kind=r8_kind)) WHERE (rmask < 0.5_r8_kind) oor_mask = .FALSE. From 2ecb2aae64d027cb182f9dec53afacb3628e6131 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 21 Aug 2023 15:20:59 -0400 Subject: [PATCH 24/33] improve error messages in check_time_none, run all of the tests --- test_fms/diag_manager/Makefile.am | 2 +- test_fms/diag_manager/check_time_none.F90 | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index ea9e10b55e..de682cc7ee 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -53,7 +53,7 @@ SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ $(abs_top_srcdir)/test_fms/tap-driver.sh # Run the test. -TESTS = test_time_none.sh #test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh +TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh testing_utils.mod: testing_utils.$(OBJEXT) diff --git a/test_fms/diag_manager/check_time_none.F90 b/test_fms/diag_manager/check_time_none.F90 index bdfd2d6025..5abe0ac8cb 100644 --- a/test_fms/diag_manager/check_time_none.F90 +++ b/test_fms/diag_manager/check_time_none.F90 @@ -58,13 +58,13 @@ program check_time_none nw = 2 if (.not. open_file(fileobj, "test_none.nc", "read")) & - call mpp_error(FATAL, "unable to open file") + call mpp_error(FATAL, "unable to open test_none.nc") if (.not. open_file(fileobj1, "test_none_regional.nc.0004", "read")) & - call mpp_error(FATAL, "unable to open file") + call mpp_error(FATAL, "unable to open test_none_regional.nc.0004") if (.not. open_file(fileobj2, "test_none_regional.nc.0005", "read")) & - call mpp_error(FATAL, "unable to open file") + call mpp_error(FATAL, "unable to open test_none_regional.nc.0005") cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw) From cfd5fd3404223ca8f1c464ffed3f7a5413a0adac Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 21 Aug 2023 16:06:49 -0400 Subject: [PATCH 25/33] turn off checks --- test_fms/diag_manager/test_time_none.sh | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/test_fms/diag_manager/test_time_none.sh b/test_fms/diag_manager/test_time_none.sh index c26e7f6d38..e378318caf 100755 --- a/test_fms/diag_manager/test_time_none.sh +++ b/test_fms/diag_manager/test_time_none.sh @@ -87,7 +87,7 @@ printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_metho 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)" ' +test_expect_failure "Checking answers for the "none" reduction method (test $my_test_count)" ' mpirun -n 1 ../check_time_none ' @@ -96,7 +96,7 @@ printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_meth 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)" ' +test_expect_failure "Checking answers for the "none" reduction method, logical mask (test $my_test_count)" ' mpirun -n 1 ../check_time_none ' @@ -105,7 +105,7 @@ printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_meth 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)" ' +test_expect_failure "Checking answers for the "none" reduction method, real mask (test $my_test_count)" ' mpirun -n 1 ../check_time_none ' @@ -116,7 +116,7 @@ printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_metho 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)" ' +test_expect_failure "Checking answers for the "none" reduction method with openmp (test $my_test_count)" ' mpirun -n 1 ../check_time_none ' @@ -125,7 +125,7 @@ printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_metho 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)" ' +test_expect_failure "Checking answers for the "none" reduction method with openmp, logical mask (test $my_test_count)" ' mpirun -n 1 ../check_time_none ' @@ -134,7 +134,7 @@ printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_metho 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)" ' +test_expect_failure "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 @@ -144,7 +144,7 @@ printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_metho 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)" ' +test_expect_failure "Checking answers for the "none" reduction method with halo output (test $my_test_count)" ' mpirun -n 1 ../check_time_none ' @@ -153,7 +153,7 @@ printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_metho 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)" ' +test_expect_failure "Checking answers for the "none" reduction method with halo output with logical mask (test $my_test_count)" ' mpirun -n 1 ../check_time_none ' @@ -162,7 +162,7 @@ printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_metho 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)" ' +test_expect_failure "Checking answers for the "none" reduction method with halo output with real mask (test $my_test_count)" ' mpirun -n 1 ../check_time_none ' fi From a46f3255fdb79c9e0060a400500997eb38d6b9ab Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 21 Aug 2023 16:47:57 -0400 Subject: [PATCH 26/33] refactor fms_diag_do_reduction --- diag_manager/fms_diag_object.F90 | 19 +++++---- diag_manager/fms_diag_output_buffer.F90 | 4 +- test_fms/diag_manager/test_time_none.sh | 54 ++++++++++++------------- 3 files changed, 41 insertions(+), 36 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 9e1d3c772d..372b908d54 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -608,8 +608,9 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info)) call this%allocate_diag_field_output_buffers(field_data, diag_field_id) - fms_diag_accept_data = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, field_weight, & + error_string = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, field_weight, & bounds, using_blocking, Time=Time) + if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info)) call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.) return end if main_if @@ -728,9 +729,10 @@ end subroutine fms_diag_do_io !> @brief Computes average, min, max, rms error, etc. !! based on the specified reduction method for the field. -!> @return .True. if no error occurs. -logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight, & - bounds, using_blocking, time) +!> @return Empty string if successful, error message if it fails +function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight, & + bounds, using_blocking, time) & + result(error_msg) class(fmsDiagObject_type), intent(in), target :: this !< Diag Object class(*), intent(in) :: field_data(:,:,:,:) !< Field data integer, intent(in) :: diag_field_id !< ID of the input field @@ -748,11 +750,12 @@ logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask class(fmsDiagFileContainer_type), pointer :: file_ptr !< Pointer to the field's file type(diagYamlFilesVar_type), pointer :: field_yaml_ptr !< Pointer to the field's yaml + character(len=50) :: error_msg !< Error message to check + integer :: reduction_method !< Integer representing a reduction method integer :: ids !< For looping through buffer ids integer :: buffer_id !< Id of the buffer integer :: file_id !< File id - character(len=50) :: error_msg !< Error message to check integer, allocatable :: axis_ids(:) !< Axis ids for the buffer logical :: is_subregional !< .True. if the buffer is subregional logical :: reduced_k_range !< .True. is the field is only outputing a section @@ -841,6 +844,9 @@ logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask select case(reduction_method) case (time_none) error_msg = buffer_ptr%do_time_none_wrapper(field_data, oor_mask, bounds_in, bounds_out) + if (trim(error_msg) .ne. "") then + return + endif case (time_min) case (time_max) case (time_sum) @@ -849,9 +855,8 @@ logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask case (time_diurnal) end select enddo buffer_loop - fms_diag_do_reduction = .true. #else - fms_diag_do_reduction = .false. + error_msg = "" CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") #endif end function fms_diag_do_reduction diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90 index fd361efdc0..6c284812cd 100644 --- a/diag_manager/fms_diag_output_buffer.F90 +++ b/diag_manager/fms_diag_output_buffer.F90 @@ -456,14 +456,14 @@ function do_time_none_wrapper(this, field_data, mask, bounds_in, bounds_out) & type is (real(kind=r8_kind)) call do_time_none(output_buffer, field_data, mask, bounds_in, bounds_out) class default - err_msg="output buffer the buffer send in are not of the same type (r8_kind)" + err_msg="the output buffer and the buffer send in are not of the same type (r8_kind)" end select type is (real(kind=r4_kind)) select type (field_data) type is (real(kind=r4_kind)) call do_time_none(output_buffer, field_data, mask, bounds_in, bounds_out) class default - err_msg="output buffer the buffer send in are not of the same type (r4_kind)" + err_msg="the output buffer and the buffer send in are not of the same type (r4_kind)" end select end select end function do_time_none_wrapper diff --git a/test_fms/diag_manager/test_time_none.sh b/test_fms/diag_manager/test_time_none.sh index e378318caf..3ed6551f1d 100755 --- a/test_fms/diag_manager/test_time_none.sh +++ b/test_fms/diag_manager/test_time_none.sh @@ -87,27 +87,27 @@ printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_metho test_expect_success "Running diag_manager with "none" reduction method (test $my_test_count)" ' mpirun -n 6 ../test_reduction_methods ' -test_expect_failure "Checking answers for the "none" reduction method (test $my_test_count)" ' - mpirun -n 1 ../check_time_none -' +# 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 "&diag_manager_nml \n use_modern_diag=.true. \n / \n &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_failure "Checking answers for the "none" reduction method, logical mask (test $my_test_count)" ' - mpirun -n 1 ../check_time_none -' +# 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 "&diag_manager_nml \n use_modern_diag=.true. \n / \n &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_failure "Checking answers for the "none" reduction method, real mask (test $my_test_count)" ' - mpirun -n 1 ../check_time_none -' +# test_expect_success "Checking answers for the "none" reduction method, real mask (test $my_test_count)" ' +# mpirun -n 1 ../check_time_none +# ' #TODO this needs to be set back to 2, once the set_math_needs_to_be_done=.true. portion of the code is implemented export OMP_NUM_THREADS=1 @@ -116,27 +116,27 @@ printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_metho test_expect_success "Running diag_manager with "none" reduction method with openmp (test $my_test_count)" ' mpirun -n 6 ../test_reduction_methods ' -test_expect_failure "Checking answers for the "none" reduction method with openmp (test $my_test_count)" ' - mpirun -n 1 ../check_time_none -' +# 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 "&diag_manager_nml \n use_modern_diag=.true. \n / \n&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_failure "Checking answers for the "none" reduction method with openmp, logical mask (test $my_test_count)" ' - mpirun -n 1 ../check_time_none -' +# 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 "&diag_manager_nml \n use_modern_diag=.true. \n / \n&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_failure "Checking answers for the "none" reduction method with openmp, real mask (test $my_test_count)" ' - mpirun -n 1 ../check_time_none -' +# 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` @@ -144,26 +144,26 @@ printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_metho 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_failure "Checking answers for the "none" reduction method with halo output (test $my_test_count)" ' - mpirun -n 1 ../check_time_none -' +# 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 "&diag_manager_nml \n use_modern_diag=.true. \n / \n&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_failure "Checking answers for the "none" reduction method with halo output with logical mask (test $my_test_count)" ' - mpirun -n 1 ../check_time_none -' +# 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 "&diag_manager_nml \n use_modern_diag=.true. \n / \n&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_failure "Checking answers for the "none" reduction method with halo output with real mask (test $my_test_count)" ' - mpirun -n 1 ../check_time_none -' +# 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 From 6d6529de3c96624e89a248529524c2055ced2538 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 21 Aug 2023 16:52:32 -0400 Subject: [PATCH 27/33] move a line --- diag_manager/fms_diag_object.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 372b908d54..72bc6c5499 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -743,6 +743,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight !! in blocks type(time_type), intent(in), optional :: time !< Current time + character(len=50) :: error_msg !< Error message to check !TODO Mostly everything #ifdef use_yaml type(fmsDiagField_type), pointer :: field_ptr !< Pointer to the field's object @@ -750,8 +751,6 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight class(fmsDiagFileContainer_type), pointer :: file_ptr !< Pointer to the field's file type(diagYamlFilesVar_type), pointer :: field_yaml_ptr !< Pointer to the field's yaml - character(len=50) :: error_msg !< Error message to check - integer :: reduction_method !< Integer representing a reduction method integer :: ids !< For looping through buffer ids integer :: buffer_id !< Id of the buffer From fd034dbf458b9181983180ebf4ad07dd3e528918 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 21 Aug 2023 16:58:59 -0400 Subject: [PATCH 28/33] renames a variable --- diag_manager/fms_diag_bbox.F90 | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 index b4f69c0ef6..7c164624b9 100644 --- a/diag_manager/fms_diag_bbox.F90 +++ b/diag_manager/fms_diag_bbox.F90 @@ -99,17 +99,17 @@ MODULE fms_diag_bbox_mod !> @brief The PEs grid points are divided further into "blocks". This function determines if a block ! has data for a given subregion and dimension !! @return .true. if the a subergion is inside a block -logical pure function determine_if_block_is_in_region(subregion_start, subregion_end, bounds, dimension) +logical pure function determine_if_block_is_in_region(subregion_start, subregion_end, bounds, dim) integer, intent(in) :: subregion_start !< Begining of the subregion integer, intent(in) :: subregion_end !< Ending of the subregion type(fmsDiagIbounds_type), intent(in) :: bounds !< Starting and ending of the subregion - integer, intent(in) :: dimension !< Dimension to check + integer, intent(in) :: dim !< Dimension to check integer :: block_start !< Begining index of the block integer :: block_end !< Ending index of the block determine_if_block_is_in_region = .true. - select case (dimension) + select case (dim) case (xdimension) block_start = bounds%imin block_end = bounds%imax @@ -178,11 +178,11 @@ pure integer function get_kmax (this) result(rslt) end function get_kmax !> @brief Updates the starting and ending index of a given dimension - subroutine update_index(this, starting_index, ending_index, dimension, ignore_halos) + subroutine update_index(this, starting_index, ending_index, dim, ignore_halos) class (fmsDiagIbounds_type), intent(inout) :: this !< The bounding box to update integer, intent(in) :: starting_index !< Starting index to update to integer, intent(in) :: ending_index !< Ending index to update to - integer, intent(in) :: dimension !< Dimension to update + integer, intent(in) :: dim !< Dimension to update logical, intent(in) :: ignore_halos !< If .true. halos will be ignored !! i.e output buffers can ignore halos as !! they do not get updates. The indices of the @@ -199,7 +199,7 @@ subroutine update_index(this, starting_index, ending_index, dimension, ignore_ha nhalox= this%nhalo_I nhaloy= this%nhalo_J endif - select case(dimension) + select case(dim) case (xdimension) this%imin = starting_index + nhalox this%imax = ending_index + nhalox @@ -461,13 +461,13 @@ function recondition_indices(indices, field, is_in, js_in, ks_in, & end function recondition_indices !> @brief Rebase the ouput bounds for a given dimension based on the starting and ending indices - subroutine rebase_output(bounds_out, starting, ending, dimension) + subroutine rebase_output(bounds_out, starting, ending, dim) CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_out !< Bounds to rebase integer, intent(in) :: starting !< Starting index of the dimension integer, intent(in) :: ending !< Ending index of the dimension - integer, intent(in) :: dimension !< Dimension to update + integer, intent(in) :: dim !< Dimension to update - select case (dimension) + select case (dim) case (xdimension) bounds_out%imin = max(starting, bounds_out%imin)-starting+1 bounds_out%imax = min(bounds_out%imax, bounds_out%imin + ending-starting) @@ -481,15 +481,15 @@ subroutine rebase_output(bounds_out, starting, ending, dimension) end subroutine !> @brief Rebase the input bounds for a given dimension based on the starting and ending indices - subroutine rebase_input(bounds_in, bounds, starting, ending, dimension) + subroutine rebase_input(bounds_in, bounds, starting, ending, dim) CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_in !< Bounds to rebase CLASS (fmsDiagIbounds_type), INTENT(in) :: bounds !< Original indices (i.e is_in, ie_in, !! passed into diag_manager) integer, intent(in) :: starting !< Starting index of the dimension integer, intent(in) :: ending !< Ending index of the dimension - integer, intent(in) :: dimension !< Dimension to update + integer, intent(in) :: dim !< Dimension to update - select case (dimension) + select case (dim) case (xdimension) bounds_in%imin = min(abs(starting-bounds%imin+1), starting) bounds_in%imax = min(bounds_in%imax, (bounds_in%imin + ending-starting)) From 8f23dafa364a35d5660595cffba404b7dd74034f Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Wed, 23 Aug 2023 12:09:43 -0400 Subject: [PATCH 29/33] minor documentation updates --- diag_manager/diag_manager.F90 | 6 ++-- diag_manager/fms_diag_bbox.F90 | 30 ++++++++++++++----- diag_manager/fms_diag_object.F90 | 4 +++ .../include/fms_diag_reduction_methods_r4.fh | 3 ++ .../include/fms_diag_reduction_methods_r8.fh | 3 ++ test_fms/diag_manager/check_time_max.F90 | 2 ++ test_fms/diag_manager/check_time_min.F90 | 2 ++ test_fms/diag_manager/check_time_none.F90 | 2 ++ 8 files changed, 42 insertions(+), 10 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 9f75ad6915..5a1eda00cf 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1676,9 +1676,9 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, CHARACTER(len=128) :: error_string, error_string1 REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field - class(*), allocatable, dimension(:,:,:,:) :: field_remap !< 4d remapped pointer - logical, allocatable, dimension(:,:,:,:) :: mask_remap !< 4d remapped pointer - class(*), allocatable, dimension(:,:,:,:) :: rmask_remap !< 4d remapped pointer + class(*), allocatable, dimension(:,:,:,:) :: field_remap !< 4d remapped array + logical, allocatable, dimension(:,:,:,:) :: mask_remap !< 4d remapped array + class(*), allocatable, dimension(:,:,:,:) :: rmask_remap !< 4d remapped array REAL(kind=r4_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r4 !< A pointer to r4 type of rmask REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 ! @brief Gets imin of fmsDiagIbounds_type !! @return copy of integer member imin @@ -300,7 +299,7 @@ function set_bounds(this, field_data, lower_i, upper_i, lower_j, upper_j, lower_ INTEGER, INTENT(in) :: upper_k !< Upper k bound. LOGICAL, INTENT(in) :: has_halos !< .true. if the field has halos - character(len=150) :: error_msg + character(len=150) :: error_msg !< Error message to output integer :: nhalos_2 !< 2 times the number of halo points integer :: nhalox !< Number of halos in x @@ -460,13 +459,22 @@ function recondition_indices(indices, field, is_in, js_in, ks_in, & indices%fje = fje end function recondition_indices - !> @brief Rebase the ouput bounds for a given dimension based on the starting and ending indices + !> @brief Rebase the ouput bounds for a given dimension based on the starting and ending indices of + !! a subregion. This is for when blocking is used. subroutine rebase_output(bounds_out, starting, ending, dim) CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_out !< Bounds to rebase integer, intent(in) :: starting !< Starting index of the dimension integer, intent(in) :: ending !< Ending index of the dimension integer, intent(in) :: dim !< Dimension to update + !> The starting index is going to be either "starting" if only a section of the + !! block is in the subregion or bounds_out%[]min if the whole section of the block is in the + !! subregion. The -starting+1 s needed so that indices start as 1 since the output buffer has + !! indices 1:size of a subregion + + !> The ending index is going to be either bounds_out%[]max if the whole section of the block + !! is in the subregion or bounds_out%[]min + size of the subregion if only a section of the + !! block is in the susbregion select case (dim) case (xdimension) bounds_out%imin = max(starting, bounds_out%imin)-starting+1 @@ -481,6 +489,7 @@ subroutine rebase_output(bounds_out, starting, ending, dim) end subroutine !> @brief Rebase the input bounds for a given dimension based on the starting and ending indices + !! of a subregion. This is for when blocking is used subroutine rebase_input(bounds_in, bounds, starting, ending, dim) CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_in !< Bounds to rebase CLASS (fmsDiagIbounds_type), INTENT(in) :: bounds !< Original indices (i.e is_in, ie_in, @@ -489,6 +498,13 @@ subroutine rebase_input(bounds_in, bounds, starting, ending, dim) integer, intent(in) :: ending !< Ending index of the dimension integer, intent(in) :: dim !< Dimension to update + !> The starting index is going to be either "starting" if only a section of the + !! block is in the subregion or starting-bounds%imin+1 if the whole section of the block is in the + !! subregion. + + !> The ending index is going to be either bounds_out%[]max if the whole section of the block + !! is in the subregion or bounds%[]min + size of the subregion if only a section of the + !! block is in the susbregion select case (dim) case (xdimension) bounds_in%imin = min(abs(starting-bounds%imin+1), starting) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 72bc6c5499..e22183ede4 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -849,9 +849,13 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight case (time_min) case (time_max) case (time_sum) + case (time_average) case (time_power) case (time_rms) case (time_diurnal) + case default + error_msg = "The reduction method is not supported. "//& + "Only none, min, max, sum, average, power, rms, and diurnal are supported." end select enddo buffer_loop #else diff --git a/diag_manager/include/fms_diag_reduction_methods_r4.fh b/diag_manager/include/fms_diag_reduction_methods_r4.fh index ddf29ddf89..922972cce3 100644 --- a/diag_manager/include/fms_diag_reduction_methods_r4.fh +++ b/diag_manager/include/fms_diag_reduction_methods_r4.fh @@ -1,3 +1,6 @@ +!*********************************************************************** +!* 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 diff --git a/diag_manager/include/fms_diag_reduction_methods_r8.fh b/diag_manager/include/fms_diag_reduction_methods_r8.fh index 079153cdfe..25c3031a22 100644 --- a/diag_manager/include/fms_diag_reduction_methods_r8.fh +++ b/diag_manager/include/fms_diag_reduction_methods_r8.fh @@ -1,3 +1,6 @@ +!*********************************************************************** +!* 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 diff --git a/test_fms/diag_manager/check_time_max.F90 b/test_fms/diag_manager/check_time_max.F90 index b8e82f3472..e579bada4f 100644 --- a/test_fms/diag_manager/check_time_max.F90 +++ b/test_fms/diag_manager/check_time_max.F90 @@ -25,6 +25,8 @@ program check_time_max 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 + implicit none + 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 diff --git a/test_fms/diag_manager/check_time_min.F90 b/test_fms/diag_manager/check_time_min.F90 index f0d8f8029d..cb1406070c 100644 --- a/test_fms/diag_manager/check_time_min.F90 +++ b/test_fms/diag_manager/check_time_min.F90 @@ -25,6 +25,8 @@ program check_time_min 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 + implicit none + 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 diff --git a/test_fms/diag_manager/check_time_none.F90 b/test_fms/diag_manager/check_time_none.F90 index 5abe0ac8cb..f703469078 100644 --- a/test_fms/diag_manager/check_time_none.F90 +++ b/test_fms/diag_manager/check_time_none.F90 @@ -25,6 +25,8 @@ program check_time_none 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 + implicit none + 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 From b8a83aaf2fec307297071aad299aeb385a577129 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Wed, 23 Aug 2023 12:12:03 -0400 Subject: [PATCH 30/33] turn the checks back on --- test_fms/diag_manager/test_time_none.sh | 56 ++++++++++++------------- 1 file changed, 28 insertions(+), 28 deletions(-) diff --git a/test_fms/diag_manager/test_time_none.sh b/test_fms/diag_manager/test_time_none.sh index 3ed6551f1d..7e2597ee87 100755 --- a/test_fms/diag_manager/test_time_none.sh +++ b/test_fms/diag_manager/test_time_none.sh @@ -87,56 +87,56 @@ printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_metho 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 -# ' +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 "&diag_manager_nml \n use_modern_diag=.true. \n / \n &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 -# ' +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 "&diag_manager_nml \n use_modern_diag=.true. \n / \n &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 -# ' +test_expect_success "Checking answers for the "none" reduction method, real mask (test $my_test_count)" ' + mpirun -n 1 ../check_time_none +' -#TODO this needs to be set back to 2, once the set_math_needs_to_be_done=.true. portion of the code is implemented +TODO this needs to be set back to 2, once the set_math_needs_to_be_done=.true. portion of the code is implemented export OMP_NUM_THREADS=1 my_test_count=`expr $my_test_count + 1` printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&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 -# ' +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 "&diag_manager_nml \n use_modern_diag=.true. \n / \n&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 -# ' +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 "&diag_manager_nml \n use_modern_diag=.true. \n / \n&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 -# ' +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` @@ -144,26 +144,26 @@ printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_metho 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 -# ' +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 "&diag_manager_nml \n use_modern_diag=.true. \n / \n&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 -# ' +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 "&diag_manager_nml \n use_modern_diag=.true. \n / \n&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 -# ' +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 From e0cc678bf9713f73031c36ccc54ae67b14bc5523 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Wed, 23 Aug 2023 17:05:25 -0400 Subject: [PATCH 31/33] fix issue when getting subregion --- diag_manager/fms_diag_axis_object.F90 | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90 index 70250dd303..8f22f7d2db 100644 --- a/diag_manager/fms_diag_axis_object.F90 +++ b/diag_manager/fms_diag_axis_object.F90 @@ -1128,9 +1128,12 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_ !< Get the starting and ending indices of the subregion relative to the global grid if (parent_axis%cart_name .eq. "X") then select type(adata=>parent_axis%axis_data) - type is (real) - lon_indices(1) = nearest_index(lon(1), adata) - lon_indices(2) = nearest_index(lon(2), adata) + 1 + type is (real(kind=r8_kind)) + lon_indices(1) = nearest_index(real(lon(1), kind=r8_kind), adata) + lon_indices(2) = nearest_index(real(lon(2), kind=r8_kind), adata) + 1 + type is (real(kind=r4_kind)) + lon_indices(1) = nearest_index(real(lon(1), kind=r4_kind), adata) + lon_indices(2) = nearest_index(real(lon(2), kind=r4_kind), adata) + 1 end select call parent_axis%get_indices(compute_idx, lon_indices, starting_index(1), ending_index(1), & need_to_define_axis(1)) @@ -1138,9 +1141,12 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_ compute_idx_2(1,:) = compute_idx else if (parent_axis%cart_name .eq. "Y") then select type(adata=>parent_axis%axis_data) - type is (real) - lat_indices(1) = nearest_index(lat(1), adata) - lat_indices(2) = nearest_index(lat(2), adata) + 1 + type is (real(kind=r8_kind)) + lat_indices(1) = nearest_index(real(lat(1), kind=r8_kind), adata) + lat_indices(2) = nearest_index(real(lat(2), kind=r8_kind), adata) + 1 + type is (real(kind=r4_kind)) + lat_indices(1) = nearest_index(real(lat(1), kind=r4_kind), adata) + lat_indices(2) = nearest_index(real(lat(2), kind=r4_kind), adata) + 1 end select call parent_axis%get_indices(compute_idx, lat_indices, starting_index(2), ending_index(2), & need_to_define_axis(2)) From be486f72f223f6c14379557ea8abaa55c761929e Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Thu, 24 Aug 2023 13:14:19 -0400 Subject: [PATCH 32/33] Add error messages inside the select types, add a function to get the field name from the field_id --- diag_manager/diag_manager.F90 | 32 +++++++++++++++++++++++--------- diag_manager/fms_diag_object.F90 | 13 +++++++++++++ 2 files changed, 36 insertions(+), 9 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 5a1eda00cf..18972883ef 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1688,6 +1688,7 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, REAL :: rmask_threshold !< Holds the values 0.5_r4_kind or 0.5_r8_kind, or related threhold values !! needed to be passed to the math/buffer update functions. + character(len=:), allocatable :: field_name !< Name of the field ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN @@ -1720,12 +1721,7 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, END IF if (use_modern_diag) then !> Set up array lengths for remapping - field_remap = copy_3d_to_4d(field) - if (present(rmask)) rmask_remap = copy_3d_to_4d(rmask) - if (present(mask)) then - allocate(mask_remap(1:size(mask,1), 1:size(mask,2), 1:size(mask,3), 1)) - mask_remap(:,:,:,1) = mask - endif + endif SELECT TYPE (field) TYPE IS (real(kind=r4_kind)) @@ -1739,6 +1735,13 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, END SELECT ! Split old and modern2023 here modern_if: iF (use_modern_diag) then + field_name = fms_diag_object%fms_get_field_name_from_id(diag_field_id) + field_remap = copy_3d_to_4d(field, trim(field_name)//"'s data") + if (present(rmask)) rmask_remap = copy_3d_to_4d(rmask, trim(field_name)//"'s mask") + if (present(mask)) then + allocate(mask_remap(1:size(mask,1), 1:size(mask,2), 1:size(mask,3), 1)) + mask_remap(:,:,:,1) = mask + endif diag_send_data = fms_diag_object%fms_diag_accept_data(diag_field_id, field_remap, mask_remap, rmask_remap, & time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, & err_msg) @@ -4482,26 +4485,37 @@ END SUBROUTINE diag_field_add_cell_measures !> @brief Copies a 3d buffer to a 4d buffer !> @return a 4d buffer - function copy_3d_to_4d(data_in) & + function copy_3d_to_4d(data_in, field_name) & result(data_out) - class (*), intent(in) :: data_in(:,:,:) !< Data to copy + class (*), intent(in) :: data_in(:,:,:) !< Data to copy + character(len=*), intent(in) :: field_name !< Name of the field copying (for error messages) class (*), allocatable :: data_out(:,:,:,:) + !TODO this should be extended to integers select type(data_in) type is (real(kind=r8_kind)) allocate(real(kind=r8_kind) :: data_out(1:size(data_in,1), 1:size(data_in,2), 1:size(data_in,3), 1)) select type (data_out) type is (real(kind=r8_kind)) data_out(:,:,:,1) = data_in + class default + call mpp_error(FATAL, "The copy of "//trim(field_name)//& + " was not allocated to the correct type (r8_kind). This shouldn't have happened") end select type is (real(kind=r4_kind)) allocate(real(kind=r4_kind) :: data_out(1:size(data_in,1), 1:size(data_in,2), 1:size(data_in,3), 1)) select type (data_out) type is (real(kind=r4_kind)) data_out(:,:,:,1) = data_in + class default + call mpp_error(FATAL, "The copy of "//trim(field_name)//& + " was not allocated to the correct type (r4_kind). This shouldn't have happened") end select + class default + call mpp_error(FATAL, "The data for "//trim(field_name)//& + &" is not a valid type. Currently only r4 and r8 are supported") end select - end function + end function copy_3d_to_4d END MODULE diag_manager_mod !> @} diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index e22183ede4..2f0cfc03ee 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -83,6 +83,7 @@ module fms_diag_object_mod procedure :: fms_get_domain2d procedure :: fms_get_axis_length procedure :: fms_get_diag_field_id_from_name + procedure :: fms_get_field_name_from_id procedure :: fms_get_axis_name_from_id procedure :: fms_diag_accept_data procedure :: fms_diag_send_complete @@ -939,6 +940,18 @@ subroutine fms_diag_axis_add_attribute(this, axis_id, att_name, att_value) #endif end subroutine fms_diag_axis_add_attribute +!> \brief Gets the field_name from the diag_field +!> \returns a copy of the field_name +function fms_get_field_name_from_id (this, field_id) & + result(field_name) + + class(fmsDiagObject_type), intent (in) :: this !< The diag object, the caller + integer, intent (in) :: field_id !< Field id to get the name for + character(len=:), allocatable :: field_name + + field_name = this%FMS_diag_fields(field_id)%get_varname() +end function fms_get_field_name_from_id + !> \brief Gets the diag field ID from the module name and field name. !> \returns a copy of the ID of the diag field or DIAG_FIELD_NOT_FOUND if the field is not registered FUNCTION fms_get_diag_field_id_from_name(this, module_name, field_name) & From 6ba0be585da04c244178d000950647714d308626 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Thu, 24 Aug 2023 13:33:38 -0400 Subject: [PATCH 33/33] add a missing #ifdef use_yaml --- diag_manager/fms_diag_object.F90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 2f0cfc03ee..907f0c6613 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -948,8 +948,11 @@ function fms_get_field_name_from_id (this, field_id) & class(fmsDiagObject_type), intent (in) :: this !< The diag object, the caller integer, intent (in) :: field_id !< Field id to get the name for character(len=:), allocatable :: field_name - +#ifndef use_yaml + CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#else field_name = this%FMS_diag_fields(field_id)%get_varname() +#endif end function fms_get_field_name_from_id !> \brief Gets the diag field ID from the module name and field name.