From 8458bfdbc7adfcc76726977db4617b32e415432e Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Fri, 11 Aug 2023 05:29:10 -0400 Subject: [PATCH 1/2] modern_diag: add the write_data calls (#1320) * add the write_data calls * fix the test_flexible_time after the update --- diag_manager/Makefile.am | 2 +- diag_manager/fms_diag_file_object.F90 | 38 ++++++- diag_manager/fms_diag_object.F90 | 4 +- diag_manager/fms_diag_output_buffer.F90 | 113 ++++++++++++++++++- test_fms/diag_manager/test_flexible_time.F90 | 18 ++- 5 files changed, 164 insertions(+), 11 deletions(-) diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index b5570cf5ff..4933350e6f 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -87,7 +87,7 @@ 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_output_buffer_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) # Mod files are built and then installed as headers. MODFILES = \ diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90 index 5a277971e6..84c3f3980e 100644 --- a/diag_manager/fms_diag_file_object.F90 +++ b/diag_manager/fms_diag_file_object.F90 @@ -45,7 +45,7 @@ module fms_diag_file_object_mod fmsDiagFullAxis_type, define_subaxis, define_diurnal_axis, & fmsDiagDiurnalAxis_type, create_new_z_subaxis use fms_diag_field_object_mod, only: fmsDiagField_type -use fms_diag_output_buffer_mod, only: fmsDiagOutputBufferContainer_type +use fms_diag_output_buffer_mod, only: fmsDiagOutputBufferContainer_type, fmsDiagOutputBuffer_class use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout, & uppercase, lowercase @@ -161,6 +161,7 @@ module fms_diag_file_object_mod procedure :: open_diag_file procedure :: write_global_metadata procedure :: write_time_metadata + procedure :: write_field_data procedure :: write_axis_metadata procedure :: write_field_metadata procedure :: write_axis_data @@ -1119,6 +1120,41 @@ subroutine write_time_metadata(this) end subroutine write_time_metadata +!> \brief Write out the field data to the file +subroutine write_field_data(this, field_obj, buffer_obj) + class(fmsDiagFileContainer_type), intent(in), target :: this !< The diag file object to write to + type(fmsDiagField_type), intent(in), target :: field_obj(:) !< The field object to write from + type(fmsDiagOutputBufferContainer_type), intent(in), target :: buffer_obj(:) !< The buffer object with the data + + class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open + class(FmsNetcdfFile_t), pointer :: fileobj !< Fileobj to write to + integer :: i !< For do loops + integer :: field_id !< The id of the field writing the data from + + diag_file => this%FMS_diag_file + fileobj => diag_file%fileobj + + !TODO This may be offloaded in the future + if (diag_file%is_static) then + !< Here the file is static so there is no need for the unlimited dimension + !! as a variables are static + do i = 1, diag_file%number_of_buffers + call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fileobj) + enddo + else + do i = 1, diag_file%number_of_buffers + field_id = buffer_obj(diag_file%buffer_ids(i))%get_field_id() + if (field_obj(field_id)%is_static()) then + !< If the variable is static, only write it the first time + if (diag_file%unlim_dimension_level .eq. 1) call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fileobj) + else + call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fileobj, unlim_dim_level=diag_file%unlim_dimension_level) + endif + enddo + endif + +end subroutine write_field_data + !> \brief Determine if it is time to close the file !! \return .True. if it is time to close the file logical function is_time_to_close_file (this, time_step) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 46099be45c..5915a604e0 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -227,7 +227,7 @@ integer function fms_register_diag_field_obj & fieldptr%buffer_ids = get_diag_field_ids(diag_field_indices) do i = 1, size(fieldptr%buffer_ids) call this%FMS_diag_output_buffers(fieldptr%buffer_ids(i))%set_field_id(this%registered_variables) - call this%FMS_diag_output_buffers(fieldptr%buffer_ids(i))%set_yaml_id(diag_field_indices(i)) + call this%FMS_diag_output_buffers(fieldptr%buffer_ids(i))%set_yaml_id(fieldptr%buffer_ids(i)) enddo !> Allocate and initialize member buffer_allocated of this field @@ -719,7 +719,7 @@ subroutine fms_diag_do_io(this, is_end_of_run) if (diag_file%is_time_to_write(model_time)) then call diag_file%increase_unlim_dimension_level() call diag_file%write_time_data() - !TODO call diag_file%add_variable_data() + call diag_file%write_field_data(this%FMS_diag_fields, this%FMS_diag_output_buffers) call diag_file%update_next_write(model_time) call diag_file%update_current_new_file_freq_index(model_time) if (diag_file%is_time_to_close_file(model_time)) call diag_file%close_diag_file() diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90 index 3603bb4321..3f2e1db095 100644 --- a/diag_manager/fms_diag_output_buffer.F90 +++ b/diag_manager/fms_diag_output_buffer.F90 @@ -24,18 +24,19 @@ !! buffer0-5d types extend fmsDiagBuffer_class, and upon allocation !! are added to the module's buffer_lists depending on it's dimension module fms_diag_output_buffer_mod - +#ifdef use_yaml use platform_mod use iso_c_binding use time_manager_mod, only: time_type 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 implicit none private -#ifdef use_yaml !> @brief Object that holds buffered data and other diagnostics !! Abstract to ensure use through its extensions(buffer0-5d types) type, abstract :: fmsDiagOutputBuffer_class @@ -72,6 +73,11 @@ module fms_diag_output_buffer_mod procedure :: get_field_id procedure :: set_yaml_id procedure :: get_yaml_id + procedure :: write_buffer + !! These are needed because otherwise the write_data calls will go into the wrong interface + procedure :: write_buffer_wrapper_netcdf + procedure :: write_buffer_wrapper_domain + procedure :: write_buffer_wrapper_u end type !> Scalar buffer type to extend fmsDiagBufferContainer_type @@ -1497,5 +1503,108 @@ function get_yaml_id(this) & res = this%yaml_id end function get_yaml_id + +!> @brief Write the buffer to the file +subroutine write_buffer(this, fileobj, unlim_dim_level) + class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write + class(FmsNetcdfFile_t), intent(in) :: fileobj !< fileobj to write to + integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension + + select type(fileobj) + type is (FmsNetcdfFile_t) + call this%write_buffer_wrapper_netcdf(fileobj, unlim_dim_level=unlim_dim_level) + type is (FmsNetcdfDomainFile_t) + call this%write_buffer_wrapper_domain(fileobj, unlim_dim_level=unlim_dim_level) + type is (FmsNetcdfUnstructuredDomainFile_t) + call this%write_buffer_wrapper_u(fileobj, unlim_dim_level=unlim_dim_level) + class default + call mpp_error(FATAL, "The file "//trim(fileobj%path)//" is not one of the accepted types"//& + " only FmsNetcdfFile_t, FmsNetcdfDomainFile_t, and FmsNetcdfUnstructuredDomainFile_t are accepted.") + end select +end subroutine write_buffer + +!> @brief Write the buffer to the FmsNetcdfFile_t fileobj +subroutine write_buffer_wrapper_netcdf(this, fileobj, unlim_dim_level) + class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write + type(FmsNetcdfFile_t), intent(in) :: fileobj !< fileobj to write to + integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension + + character(len=:), allocatable :: varname !< name of the variable + + varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname() + select type(buffer_obj=>this%diag_buffer_obj) + type is (outputBuffer0d_type) + call write_data(fileobj, varname, buffer_obj%buffer(1), unlim_dim_level=unlim_dim_level) + type is (outputBuffer1d_type) + call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) + type is (outputBuffer2d_type) + call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) + type is (outputBuffer3d_type) + call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) + type is (outputBuffer4d_type) + call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) + type is (outputBuffer5d_type) + call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) + class default + call mpp_error(FATAL, "The field:"//trim(varname)//" does not have a valid buffer object type."//& + " Only 0d, 1d, 2d, 3d, 4d, and 5d buffers are supported.") + end select +end subroutine write_buffer_wrapper_netcdf + +!> @brief Write the buffer to the FmsNetcdfDomainFile_t fileobj +subroutine write_buffer_wrapper_domain(this, fileobj, unlim_dim_level) + class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write + type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< fileobj to write to + integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension + + character(len=:), allocatable :: varname !< name of the variable + + varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname() + select type(buffer_obj=>this%diag_buffer_obj) + type is (outputBuffer0d_type) + call write_data(fileobj, varname, buffer_obj%buffer(1), unlim_dim_level=unlim_dim_level) + type is (outputBuffer1d_type) + call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) + type is (outputBuffer2d_type) + call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) + type is (outputBuffer3d_type) + call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) + type is (outputBuffer4d_type) + call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) + type is (outputBuffer5d_type) + call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) + class default + call mpp_error(FATAL, "The field:"//trim(varname)//" does not have a valid buffer object type."//& + " Only 0d, 1d, 2d, 3d, 4d, and 5d buffers are supported.") + end select +end subroutine write_buffer_wrapper_domain + +!> @brief Write the buffer to the FmsNetcdfUnstructuredDomainFile_t fileobj +subroutine write_buffer_wrapper_u(this, fileobj, unlim_dim_level) + class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write + type(FmsNetcdfUnstructuredDomainFile_t), intent(in) :: fileobj !< fileobj to write to + integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension + + character(len=:), allocatable :: varname !< name of the variable + + varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname() + select type(buffer_obj=>this%diag_buffer_obj) + type is (outputBuffer0d_type) + call write_data(fileobj, varname, buffer_obj%buffer(1), unlim_dim_level=unlim_dim_level) + type is (outputBuffer1d_type) + call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) + type is (outputBuffer2d_type) + call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) + type is (outputBuffer3d_type) + call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) + type is (outputBuffer4d_type) + call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) + type is (outputBuffer5d_type) + call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) + class default + call mpp_error(FATAL, "The field:"//trim(varname)//" does not have a valid buffer object type."//& + " Only 0d, 1d, 2d, 3d, 4d, and 5d buffers are supported.") + end select +end subroutine write_buffer_wrapper_u #endif end module fms_diag_output_buffer_mod diff --git a/test_fms/diag_manager/test_flexible_time.F90 b/test_fms/diag_manager/test_flexible_time.F90 index a3a78a5f8f..2dd881177d 100644 --- a/test_fms/diag_manager/test_flexible_time.F90 +++ b/test_fms/diag_manager/test_flexible_time.F90 @@ -21,15 +21,19 @@ program test_flexible_time use fms_mod, only: fms_init, fms_end use time_manager_mod, only: set_date, time_type, increment_date, set_calendar_type, & - JULIAN, set_time + JULIAN, set_time, operator(+) use diag_manager_mod, only: diag_manager_init, diag_axis_init, register_diag_field, & - diag_manager_set_time_end, diag_send_complete, diag_manager_end + diag_manager_set_time_end, diag_send_complete, diag_manager_end, & + send_data use mpp_mod, only: FATAL, mpp_error +use platform_mod, only: r8_kind implicit none +real(kind=r8_kind) :: var_data(2) !< Dummy data +logical :: used !< .True. if send_data was sucessful type(time_type) :: Time !< Time of the simulation -type(time_type) :: Start_Time !< Start time of the simulation +type(time_type) :: Time_step !< Start time of the simulation type(time_type) :: End_Time !< End Time of the simulation integer :: i integer :: id_z, id_var @@ -39,18 +43,22 @@ program test_flexible_time call diag_manager_init !< Starting time of the simulation -Start_Time = set_date(2,1,1,3,0,0) !02/01/01 hour 3 +Time = set_date(2,1,1,3,0,0) !02/01/01 hour 3 !< Set up a dummy variable id_z = diag_axis_init('z', (/1. ,2. /), 'point_Z', 'z', long_name='point_Z') -id_var = register_diag_field ('atm_mod', 'var1', (/id_z/), Start_Time, 'Var not domain decomposed', 'mullions') +id_var = register_diag_field ('atm_mod', 'var1', (/id_z/), Time, 'Var not domain decomposed', 'mullions') !< Set up the end of the simulation (i.e 2 days long) End_Time = set_date(2,1,3,3,0,0) call diag_manager_set_time_end(End_Time) !< Set up the simulation +Time_step = set_time (3600,0) !< 1 hour do i=1,48 + var_data = real(i, kind=r8_kind) + Time = Time + Time_step + used = send_data(id_var, var_data, Time) call diag_send_complete(set_time(3600,0)) enddo From f28b99b3ea7d2006abc9bbc224fb5bb06b1f3e09 Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Fri, 11 Aug 2023 13:48:37 -0400 Subject: [PATCH 2/2] modern_diag_manager: fms_diag_do_reduction (#1321) * Add getters functions to get the subaxis starting and ending indices * add the fms_diag_reduction_methods_module * adds checks to make sure the indices are passed in correctly to send_data * Sets up fms_diag_do_reduction and adds checks to make sure the input arguments are correct --- CMakeLists.txt | 1 + diag_manager/Makefile.am | 7 +- diag_manager/diag_manager.F90 | 22 ++- diag_manager/fms_diag_axis_object.F90 | 18 +++ diag_manager/fms_diag_field_object.F90 | 3 +- diag_manager/fms_diag_object.F90 | 168 ++++++++++---------- diag_manager/fms_diag_reduction_methods.F90 | 129 +++++++++++++++ 7 files changed, 255 insertions(+), 93 deletions(-) create mode 100644 diag_manager/fms_diag_reduction_methods.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index cf87384155..0a27917a52 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -139,6 +139,7 @@ list(APPEND fms_fortran_src_files diag_manager/fms_diag_elem_weight_procs.F90 diag_manager/fms_diag_fieldbuff_update.F90 diag_manager/fms_diag_bbox.F90 + diag_manager/fms_diag_reduction_methods.F90 drifters/cloud_interpolator.F90 drifters/drifters.F90 drifters/drifters_comm.F90 diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 4933350e6f..acf839f025 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -52,6 +52,7 @@ libdiag_manager_la_SOURCES = \ fms_diag_elem_weight_procs.F90 \ fms_diag_fieldbuff_update.F90 \ fms_diag_bbox.F90 \ + fms_diag_reduction_methods.F90 \ include/fms_diag_fieldbuff_update.inc \ include/fms_diag_fieldbuff_update.fh @@ -66,7 +67,8 @@ diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEX 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_output_buffer_mod.$(FC_MODEXT) \ + fms_diag_reduction_methods_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) \ @@ -88,6 +90,8 @@ diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MOD 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_reduction_methods_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT) fms_diag_output_buffer_mod.$(FC_MODEXT) \ + diag_data_mod.$(FC_MODEXT) # Mod files are built and then installed as headers. MODFILES = \ @@ -112,6 +116,7 @@ MODFILES = \ fms_diag_bbox_mod.$(FC_MODEXT) \ fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ 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 diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 433ae4f5df..c153b564ef 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1632,6 +1632,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & END FUNCTION send_data_3d !> @return true if send is successful +!TODO documentation, seperate the old and new LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, & & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) INTEGER, INTENT(in) :: diag_field_id @@ -1640,7 +1641,7 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, TYPE (time_type), INTENT(in), OPTIONAL :: time INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL, contiguous, target :: mask - CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: rmask + CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL, contiguous, target :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg REAL :: weight1 @@ -1675,7 +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_modern !< i8 4d remapped pointer + class(*), pointer, dimension(:,:,:,:) :: field_remap !< 4d remapped pointer + logical, pointer, dimension(:,:,:,:) :: mask_remap !< 4d remapped pointer + class(*), pointer, 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_modern => null() + field_remap => null() + mask_remap => null() + rmask_remap => null() ie = SIZE(field,1) je = SIZE(field,2) ke = SIZE(field,3) - field_modern(1:ie,1:je,1:ke,1:1) => field + 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 endif SELECT TYPE (field) TYPE IS (real(kind=r4_kind)) @@ -1734,9 +1741,10 @@ 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 - diag_send_data = fms_diag_object%fms_diag_accept_data(diag_field_id, field_modern, time, is_in, js_in, ks_in, & - & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) - nullify (field_modern) + 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) 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) diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90 index 8ae2a325b9..d9cf39c848 100644 --- a/diag_manager/fms_diag_axis_object.F90 +++ b/diag_manager/fms_diag_axis_object.F90 @@ -119,6 +119,8 @@ module fms_diag_axis_object_mod contains procedure :: fill_subaxis procedure :: axis_length + procedure :: get_starting_index + procedure :: get_ending_index END TYPE fmsDiagSubAxis_type !> @brief Type to hold the diurnal axis @@ -766,6 +768,22 @@ function axis_length(this) & res = this%ending_index - this%starting_index + 1 end function + !> @brief Accesses its member starting_index + !! @return a copy of the starting_index + function get_starting_index(this) result(indx) + class(fmsDiagSubAxis_type), intent(in) :: this !< diag_sub_axis object + integer :: indx !< Result to return + indx = this%starting_index + end function get_starting_index + + !> @brief Accesses its member ending_index + !! @return a copy of the ending_index + function get_ending_index(this) result(indx) + class(fmsDiagSubAxis_type), intent(in) :: this !< diag_sub_axis object + integer :: indx !< Result to return + indx = this%ending_index + end function get_ending_index + !> @brief Get the ntiles in a domain !> @return the number of tiles in a domain function get_ntiles(this) & diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90 index ff4734ab32..9592e39978 100644 --- a/diag_manager/fms_diag_field_object.F90 +++ b/diag_manager/fms_diag_field_object.F90 @@ -680,7 +680,8 @@ pure function get_mask_variant (this) & result(rslt) class (fmsDiagField_type), intent(in) :: this !< diag object logical :: rslt - rslt = this%mask_variant + rslt = .false. + if (allocated(this%mask_variant)) rslt = this%mask_variant end function get_mask_variant !> @brief Gets local diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 5915a604e0..208be4b2f4 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -36,6 +36,7 @@ module fms_diag_object_mod &parse_compress_att, get_axis_id_from_name use fms_diag_output_buffer_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 #endif #if defined(_OPENMP) @@ -83,6 +84,7 @@ module fms_diag_object_mod procedure :: fms_diag_accept_data procedure :: fms_diag_send_complete procedure :: fms_diag_do_io + procedure :: fms_diag_do_reduction procedure :: fms_diag_field_add_cell_measures procedure :: allocate_diag_field_output_buffers procedure :: fms_diag_compare_window @@ -486,52 +488,72 @@ end function fms_diag_axis_init !! multithreaded case. !! \note If some of the diag manager is offloaded in the future, then it should be treated similarly !! to the multi-threaded option for processing later -logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is_in, js_in, ks_in, & - mask, rmask, ie_in, je_in, ke_in, weight, err_msg) - class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill - INTEGER, INTENT(in) :: diag_field_id !< The ID of the input diagnostic field - CLASS(*), DIMENSION(:,:,:,:), INTENT(in) :: field_data !< The data for the input diagnostic - CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight used for averaging - TYPE (time_type), INTENT(in), OPTIONAL :: time !< The current time - INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in !< Indicies for the variable - LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask !< The location of the mask - CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask !< The masking values - CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< An error message returned - integer :: is, js, ks !< Starting indicies of the field_data - integer :: ie, je, ke !< Ending indicied 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 the calculations - !! later. \note This is experimental - !TODO logical, allocatable, dimension(:,:,:) :: oor_mask !< Out of range mask - integer :: sample !< Index along the diurnal time axis - integer :: day !< Number of days - integer :: second !< Number of seconds - integer :: tick !< Number of ticks representing fractional second - integer :: buffer_id !< Index of a buffer - !TODO: logical :: phys_window - character(len=128) :: error_string !< Store error text - integer :: i !< For looping - logical :: data_buffer_is_allocated !< .true. if the data buffer is allocated +logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rmask, & + time, is_in, js_in, ks_in, & + ie_in, je_in, ke_in, weight, err_msg) + 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 + !! points to mask (null if no mask) + CLASS(*), DIMENSION(:,:,:,:), pointer, 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 + INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in !< Starting indices + INTEGER, INTENT(in), OPTIONAL :: ie_in, je_in, ke_in !< Ending indices + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< An error message returned + + 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 + !! the calculationslater. \note This is experimental + character(len=128) :: error_string !< Store error text + logical :: data_buffer_is_allocated !< .true. if the data buffer is allocated + character(len=128) :: field_info !< String holding info about the field to append to the + !! error message + 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) #ifndef use_yaml CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") #else - class(diagYamlFilesVar_type), pointer :: ptr_diag_field_yaml !< Pointer to a field from yaml fields + field_info = " Check send data call for field:"//trim(this%FMS_diag_fields(diag_field_id)%get_varname()) - !TODO: weight is for time averaging where each time level may have a different weight - ! call real_copy_set() + !< Check if time should be present for this field + if (.not.this%FMS_diag_fields(diag_field_id)%is_static() .and. .not.present(time)) & + call mpp_error(FATAL, "Time must be present if the field is not static. "//trim(field_info)) - !TODO: oor_mask is only used for checking out of range values. - ! call init_mask_3d() + !< Set the field_weight. If "weight" is not present it will be set to 1.0_r8_kind + field_weight = set_weight(weight) - !TODO: Check improper combinations of is, ie, js, and je. - ! if (check_indices_order()) deallocate(oor_mask) + !< Check that the indices are present in the correct combination + 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)) -!> Does the user want to push off calculations until send_diag_complete? + !< 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, & + "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, & + "mask and rmask are both present in the send_data call. "//& + trim(field_info)) + + !< Create the oor_mask based on the "mask" and "rmask" arguments + oor_mask = init_mask(rmask, mask, field_data) + + !> Does the user want to push off calculations until send_diag_complete? buffer_the_data = .false. -!> initialize the number of threads and level to be 0 + + !> initialize the number of threads and level to be 0 omp_num_threads = 0 omp_level = 0 #if defined(_OPENMP) @@ -539,9 +561,10 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is omp_level = omp_get_level() buffer_the_data = (omp_num_threads > 1 .AND. omp_level > 0) #endif -!If this is true, buffer data + + !If this is true, buffer data main_if: if (buffer_the_data) then -!> Calculate the i,j,k start and end + !> Calculate the i,j,k start and end ! If is, js, or ks not present default them to 1 is = 1 js = 1 @@ -568,60 +591,19 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is call this%FMS_diag_fields(diag_field_id)%set_data_buffer_is_allocated(.TRUE.) call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.TRUE.) !$omp end critical + !TODO Save the field_weight and the oor_mask to use later in the calculations call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data,& is, js, ks, ie, je, ke) fms_diag_accept_data = .TRUE. return else -!!TODO: Loop through fields and do averages/math functions - call this%allocate_diag_field_output_buffers(field_data, diag_field_id) - do i = 1, size(this%FMS_diag_fields(diag_field_id)%buffer_ids) - buffer_id = this%FMS_diag_fields(diag_field_id)%buffer_ids(i) - - !!TODO: Check if the field is a physics window - !! phys_window = fms_diag_compare_window() - - !!TODO: Get local start and end indices on 3 axes for regional output - - !> Compute the diurnal index - sample = 1 - if (present(time)) then - call get_time(time, second, day, tick) !< Current time in days and seconds - ptr_diag_field_yaml => diag_yaml%get_diag_field_from_id(buffer_id) - sample = floor((second + real(tick) / get_ticks_per_second()) & - & * ptr_diag_field_yaml%get_n_diurnal() / SECONDS_PER_DAY) + 1 - end if - - !!TODO: Get the vertical layer start and end indices - - !!TODO: Initialize output time for fields output every time step - - !< Check if time should be present for this field - if (.not.this%FMS_diag_fields(diag_field_id)%is_static() .and. .not.present(time)) then - write(error_string, '(a,"/",a)') trim(this%FMS_diag_fields(diag_field_id)%get_modname()),& - & trim(this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_outname()) - if (fms_error_handler('fms_diag_object_mod::fms_diag_accept_data', 'module/output_name: '& - &//trim(error_string)//', time must be present for nonstatic field', err_msg)) then - !!TODO: deallocate local pointers/allocatables if needed - return - end if - end if - - !!TODO: Is it time to output for this field? CAREFUL ABOUT > vs >= HERE - !--- The fields send out within openmp parallel region will be written out in - !--- diag_send_complete. - - !!TODO: Is check to bounds of current field necessary? - - !!TODO: Take care of submitted field data - - enddo + 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) call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.) - fms_diag_accept_data = .TRUE. return end if main_if -!> Return false if nothing is done + !> Return false if nothing is done fms_diag_accept_data = .FALSE. return #endif @@ -734,6 +716,24 @@ 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. +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) + 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(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 + fms_diag_do_reduction = .true. +end function fms_diag_do_reduction + !> @brief Adds the diag ids of the Area and or Volume of the diag_field_object subroutine fms_diag_field_add_cell_measures(this, diag_field_id, area, volume) class(fmsDiagObject_type), intent (inout) :: this !< The diag object diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 new file mode 100644 index 0000000000..8962638c04 --- /dev/null +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -0,0 +1,129 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +!> @defgroup fms_diag_reduction_methods_mod fms_diag_reduction_methods_mod +!> @ingroup diag_manager +!! @brief fms_diag_reduction_methods_mod contains routines that are meant to be used for +!! error checking and setting up to do the reduction methods + +!> @file +!> @brief File for @ref fms_diag_reduction_methods_mod + +!> @addtogroup fms_diag_reduction_methods_mod +!> @{ +module fms_diag_reduction_methods_mod + use platform_mod, only: r8_kind, r4_kind + implicit none + private + + public :: check_indices_order, init_mask, set_weight + + contains + + !> @brief Checks improper combinations of is, ie, js, and je. + !! @return The error message, empty string if no errors were found + !> @note accept_data works in either one or another of two modes. + !! 1. Input field is a window (e.g. FMS physics) + !! 2. Input field includes halo data + !! It cannot handle a window of data that has halos. + !! (A field with no windows or halos can be thought of as a special case of either mode.) + !! The logic for indexing is quite different for these two modes, but is not clearly separated. + !! If both the beggining and ending indices are present, then field is assumed to have halos. + !! If only beggining indices are present, then field is assumed to be a window. + !> @par + !! There are a number of ways a user could mess up this logic, depending on the combination + !! of presence/absence of is,ie,js,je. The checks below should catch improper combinations. + pure function check_indices_order(is_in, ie_in, js_in, je_in) & + result(error_msg) + integer, intent(in), optional :: is_in, ie_in, js_in, je_in !< Indices passed to fms_diag_accept_data() + character(len=128) :: error_msg !< An error message used only for testing purpose!!! + + error_msg = "" + IF ( PRESENT(ie_in) ) THEN + IF ( .NOT.PRESENT(is_in) ) THEN + error_msg = 'ie_in present without is_in' + return + END IF + IF ( PRESENT(js_in) .AND. .NOT.PRESENT(je_in) ) THEN + error_msg = 'is_in and ie_in present, but js_in present without je_in' + return + END IF + END IF + + IF ( PRESENT(je_in) ) THEN + IF ( .NOT.PRESENT(js_in) ) THEN + error_msg = 'je_in present without js_in' + return + END IF + IF ( PRESENT(is_in) .AND. .NOT.PRESENT(ie_in) ) THEN + error_msg = 'js_in and je_in present, but is_in present without ie_in' + return + END IF + END IF + end function check_indices_order + + !> @brief Sets the logical mask based on mask or rmask + !> @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 + CLASS(*), DIMENSION(:,:,:,:), intent(in) :: field !< Field_data + + logical, allocatable, dimension(:,:,:,:) :: oor_mask !< mask + + ALLOCATE(oor_mask(SIZE(field, 1), SIZE(field, 2), SIZE(field, 3), SIZE(field, 4))) + oor_mask = .true. + + if (associated(mask)) then + oor_mask = mask + elseif (associated(rmask)) then + select type (rmask) + type is (real(kind=r8_kind)) + WHERE (rmask < 0.5_r8_kind) oor_mask = .FALSE. + type is (real(kind=r4_kind)) + WHERE (rmask < 0.5_r4_kind) oor_mask = .FALSE. + end select + endif + + end function init_mask + + !> @brief Sets the weight based on the weight passed into send_data (1.0_r8_kind if the weight is not passed in) + !! The weight will be saved as an r8 and converted to r4 as needed + !! @return weight to use when averaging + pure function set_weight(weight) & + result(out_weight) + CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight use when averaging + + real(kind=r8_kind) :: out_weight + + out_weight = 1.0_r8_kind + if (present(weight)) then + select type(weight) + type is (real(kind=r8_kind)) + out_weight = real(weight, kind = r8_kind) + type is (real(kind=r4_kind)) + out_Weight = real(weight, kind = r8_kind) + end select + endif + end function set_weight + +end module fms_diag_reduction_methods_mod +!> @} +! close documentation grouping \ No newline at end of file