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

@@ -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

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
 

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 !<A pointer to r8 type of rmask
 
@@ -1716,11 +1719,15 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
        IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) RETURN
     END IF
     if (use_modern_diag) then !> 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)

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) &

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