From 84a82e7ec7910f3392fcce0e6d2aed6fa6b73233 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 7 Aug 2023 14:06:35 -0400 Subject: [PATCH 1/7] Add getters functions to get the subaxis starting and ending indices --- diag_manager/fms_diag_axis_object.F90 | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90 index 8ae2a325b9..b70dcf1afa 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 Returns 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 Returns 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) & From 072c9e6cd66d5e6218fb5b085e20023f41cc5b5b Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 7 Aug 2023 14:13:33 -0400 Subject: [PATCH 2/7] add the fms_diag_reduction_methods_module --- CMakeLists.txt | 1 + diag_manager/Makefile.am | 7 ++++++- diag_manager/fms_diag_reduction_methods.F90 | 9 +++++++++ 3 files changed, 16 insertions(+), 1 deletion(-) create mode 100644 diag_manager/fms_diag_reduction_methods.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index 6f7c9ed261..3aa01dccdb 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 b5570cf5ff..c14b64ee26 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_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/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 new file mode 100644 index 0000000000..9680c8584f --- /dev/null +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -0,0 +1,9 @@ +!> \author Ganga Purja Pun +!> \email GFDL.Climate.Model.Info@noaa.gov +!! \brief Contains routines for the modern diag manager +!! These routines are meant to be used for checks and in reduction methods. + +module fms_diag_reduction_methods_mod + implicit none + +end module fms_diag_reduction_methods_mod \ No newline at end of file From 30f4d50f5129b26de1b2915956472a58ee3b20e2 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 7 Aug 2023 14:44:54 -0400 Subject: [PATCH 3/7] adds checks to make sure the indices are passed in correctly to send_data --- diag_manager/fms_diag_object.F90 | 7 +++- diag_manager/fms_diag_reduction_methods.F90 | 46 +++++++++++++++++++++ 2 files changed, 51 insertions(+), 2 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 46099be45c..a220176b4d 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 use constants_mod, only: SECONDS_PER_DAY #endif #if defined(_OPENMP) @@ -526,8 +527,10 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is !TODO: oor_mask is only used for checking out of range values. ! call init_mask_3d() - !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)//" Check send data call for field:"//& + trim(this%FMS_diag_fields(diag_field_id)%get_varname())) !> Does the user want to push off calculations until send_diag_complete? buffer_the_data = .false. diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 9680c8584f..dc02b7653e 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -5,5 +5,51 @@ module fms_diag_reduction_methods_mod implicit none + private + + public :: check_indices_order + + 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. + 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 end module fms_diag_reduction_methods_mod \ No newline at end of file From 2a90aaf41c4753623d41958a118df032d2e55f3c Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 7 Aug 2023 16:43:06 -0400 Subject: [PATCH 4/7] Sets up fms_diag_do_reduction and adds checks to make sure the input arguments are correct --- diag_manager/diag_manager.F90 | 12 +- diag_manager/fms_diag_field_object.F90 | 3 +- diag_manager/fms_diag_object.F90 | 167 ++++++++++---------- diag_manager/fms_diag_reduction_methods.F90 | 53 ++++++- 4 files changed, 143 insertions(+), 92 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 433ae4f5df..3711c816c5 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1675,7 +1675,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_modern !< 4d remapped pointer + logical, pointer, dimension(:,:,:,:) :: mask_modern !< 4d remapped pointer + class(*), pointer, dimension(:,:,:,:) :: rmask_modern !< 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() + mask_modern => null() + rmask_modern => null() ie = SIZE(field,1) je = SIZE(field,2) ke = SIZE(field,3) field_modern(1:ie,1:je,1:ke,1:1) => field + if (present(mask)) mask_modern(1:ie,1:je,1:ke,1:1) => mask endif SELECT TYPE (field) TYPE IS (real(kind=r4_kind)) @@ -1734,8 +1739,9 @@ 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) + diag_send_data = fms_diag_object%fms_diag_accept_data(diag_field_id, field_modern, mask_modern, rmask_modern, & + time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, & + err_msg) nullify (field_modern) elSE ! modern_if ! oor_mask is only used for checking out of range values. 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 a220176b4d..c9e6687256 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -36,7 +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 +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) @@ -84,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 @@ -487,54 +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 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 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) !< 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)//" Check send data call for field:"//& - trim(this%FMS_diag_fields(diag_field_id)%get_varname())) + 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) @@ -542,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 @@ -571,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 @@ -737,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 index dc02b7653e..6ed1ee446d 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -4,15 +4,16 @@ !! These routines are meant to be used for checks and in reduction methods. module fms_diag_reduction_methods_mod + use platform_mod, only: r8_kind, r4_kind implicit none private - public :: check_indices_order + 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 + !! @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 @@ -24,7 +25,8 @@ module fms_diag_reduction_methods_mod !> @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. - function check_indices_order(is_in, ie_in, js_in, je_in) result(error_msg) + 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!!! @@ -52,4 +54,49 @@ function check_indices_order(is_in, ie_in, js_in, je_in) result(error_msg) 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) + !> @return weight to used when averaging + pure function set_weight(weight) & + result(out_weight) + CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight used for 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 = r4_kind) + end select + endif + end function set_weight + end module fms_diag_reduction_methods_mod \ No newline at end of file From 17e0ab0d00af98e6fe8545589a217d0311e1afa8 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Tue, 8 Aug 2023 11:47:06 -0400 Subject: [PATCH 5/7] forgot to assign the rmask pointer --- diag_manager/diag_manager.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 3711c816c5..6ed1fc4818 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1726,6 +1726,7 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, ke = SIZE(field,3) field_modern(1:ie,1:je,1:ke,1:1) => field if (present(mask)) mask_modern(1:ie,1:je,1:ke,1:1) => mask + if (present(rmask)) rmask_modern(1:ie,1:je,1:ke,1:1) => rmask endif SELECT TYPE (field) TYPE IS (real(kind=r4_kind)) From 91a249ae58b4a33319202c259f183ee729c2102a Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Thu, 10 Aug 2023 07:57:31 -0400 Subject: [PATCH 6/7] minor documentation updates, typo in set_weight, and renames some _modern variables --- diag_manager/diag_manager.F90 | 22 +++++------ diag_manager/fms_diag_axis_object.F90 | 4 +- diag_manager/fms_diag_object.F90 | 2 +- diag_manager/fms_diag_reduction_methods.F90 | 43 +++++++++++++++++---- 4 files changed, 49 insertions(+), 22 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 6ed1fc4818..d665451251 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1675,9 +1675,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 !< 4d remapped pointer - logical, pointer, dimension(:,:,:,:) :: mask_modern !< 4d remapped pointer - class(*), pointer, dimension(:,:,:,:) :: rmask_modern !< 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() - mask_modern => null() - rmask_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 - if (present(mask)) mask_modern(1:ie,1:je,1:ke,1:1) => mask - if (present(rmask)) rmask_modern(1:ie,1:je,1:ke,1:1) => rmask + 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)) @@ -1740,10 +1740,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, mask_modern, rmask_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_modern) + 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 b70dcf1afa..d9cf39c848 100644 --- a/diag_manager/fms_diag_axis_object.F90 +++ b/diag_manager/fms_diag_axis_object.F90 @@ -769,7 +769,7 @@ function axis_length(this) & end function !> @brief Accesses its member starting_index - !! @return Returns a copy of the 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 @@ -777,7 +777,7 @@ function get_starting_index(this) result(indx) end function get_starting_index !> @brief Accesses its member ending_index - !! @return Returns a copy of the 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 diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index c9e6687256..ff56e2c866 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -505,7 +505,7 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm 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 :: 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 diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 6ed1ee446d..8962638c04 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -1,8 +1,32 @@ -!> \author Ganga Purja Pun -!> \email GFDL.Climate.Model.Info@noaa.gov -!! \brief Contains routines for the modern diag manager -!! These routines are meant to be used for checks and in reduction methods. +!*********************************************************************** +!* 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 @@ -81,10 +105,11 @@ function init_mask(rmask, mask, field) & 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) - !> @return weight to used when averaging + !! 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 used for averaging + CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight use when averaging real(kind=r8_kind) :: out_weight @@ -94,9 +119,11 @@ pure function set_weight(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 = r4_kind) + out_Weight = real(weight, kind = r8_kind) end select endif end function set_weight -end module fms_diag_reduction_methods_mod \ No newline at end of file +end module fms_diag_reduction_methods_mod +!> @} +! close documentation grouping \ No newline at end of file From b9dabe052f99eeaca3aadf58306e16c38b383957 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Fri, 11 Aug 2023 09:11:32 -0400 Subject: [PATCH 7/7] set rmask as contiguous, this will probably be needed later --- diag_manager/diag_manager.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index d665451251..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