feat: Modern_diag_manager add send data 4d (NOAA-GFDL#1402)

diag_manager/diag_manager.F90

@@ -343,6 +343,7 @@ MODULE diag_manager_mod
      MODULE PROCEDURE send_data_1d
      MODULE PROCEDURE send_data_2d
      MODULE PROCEDURE send_data_3d
+     MODULE PROCEDURE send_data_4d
   END INTERFACE
 
   !> @brief Register a diagnostic field for a given module
@@ -3472,6 +3473,57 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
   endIF modern_if
   END FUNCTION diag_send_data
 
+  !> @brief Updates the output buffer for a field based on the data for current time step
+  !! @return true if send is successful
+  LOGICAL FUNCTION send_data_4d(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  !< The field id returned from the register call
+    CLASS(*),         INTENT(in)            :: field(:,:,:,:) !< The field data for the current time step
+    CLASS(*),         INTENT(in),  OPTIONAL :: weight         !< The weight to multiply the data by when averaging
+    TYPE (time_type), INTENT(in),  OPTIONAL :: time           !< The current model time
+    INTEGER,          INTENT(in),  OPTIONAL :: is_in          !< Starting i index of the data
+    INTEGER,          INTENT(in),  OPTIONAL :: js_in          !< Starting j index of the data
+    INTEGER,          INTENT(in),  OPTIONAL :: ks_in          !< Starting k index of the data
+    INTEGER,          INTENT(in),  OPTIONAL :: ie_in          !< Ending i index of the data
+    INTEGER,          INTENT(in),  OPTIONAL :: je_in          !< Ending j index of the data
+    INTEGER,          INTENT(in),  OPTIONAL :: ke_in          !< Ending k index of the data
+    LOGICAL,          INTENT(in),  OPTIONAL :: mask(:,:,:,:)  !< Logical mask indicating the points to not average
+    CLASS(*),         INTENT(in),  OPTIONAL :: rmask(:,:,:,:) !< Real mask indicating the points to not averafe
+    CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg        !< If some errors occurs, send_data will return the
+                                                              !! error message instead of crashing
+
+    class(*), allocatable :: rmask_local(:,:,:,:) !< Real version of the mask variable
+    logical,  allocatable :: mask_local(:,:,:,:)  !< Local version of the mask variable
+
+    ! If diag_field_id is < 0 it means that this field is not registered, simply return
+    IF ( diag_field_id <= 0 ) THEN
+      send_data_4d = .FALSE.
+      RETURN
+    ENDIF
+
+    if (.not. use_modern_diag) &
+      call mpp_error(FATAL, "Send_data_4d is only supported when diag_manager_nml::use_modern_diag=.true.")
+
+    !< The error checking is done in accept_data
+    if (present(mask)) mask_local = mask
+    if (present(rmask)) rmask_local = rmask
+
+    send_data_4d = fms_diag_object%fms_diag_accept_data(diag_field_id, field, mask_local, rmask_local, &
+                                                          time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
+                                                          err_msg)
+
+    if (present(err_msg)) then
+      if (err_msg .ne. "") then
+        call mpp_error(NOTE, trim(err_msg))
+        send_data_4d = .false.
+        return
+      endif
+    endif
+
+    if (allocated(rmask_local)) deallocate(rmask_local)
+    if (allocated(mask_local))  deallocate(mask_local)
+  end function send_data_4d
+
   !> @return true if send is successful
   LOGICAL FUNCTION send_tile_averaged_data1d ( id, field, area, time, mask )
     INTEGER, INTENT(in) :: id  !< id od the diagnostic field

test_fms/diag_manager/check_time_max.F90

@@ -91,6 +91,12 @@ program check_time_max
     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 var4_max - time_level:", string(i)
+    call read_data(fileobj, "var4_max", cdata_out(:,:,:,:), unlim_dim_level=i)
+    call check_data_3d(cdata_out(:,:,:,1), i, .false.)
+    call check_data_3d(cdata_out(:,:,:,2), 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)

test_fms/diag_manager/check_time_min.F90

@@ -91,6 +91,12 @@ program check_time_min
     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 var4_min - time_level:", string(i)
+    call read_data(fileobj, "var4_min", cdata_out(:,:,:,:), unlim_dim_level=i)
+    call check_data_3d(cdata_out(:,:,:,1), i, .false.)
+    call check_data_3d(cdata_out(:,:,:,2), 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)

test_fms/diag_manager/check_time_none.F90

@@ -91,6 +91,12 @@ 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 var4_none - time_level:", string(i)
+    call read_data(fileobj, "var4_none", cdata_out(:,:,:,:), unlim_dim_level=i)
+    call check_data_3d(cdata_out(:,:,:,1), i, .false.)
+    call check_data_3d(cdata_out(:,:,:,2), 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)

test_fms/diag_manager/check_time_sum.F90

@@ -93,6 +93,12 @@ program check_time_sum
     call read_data(fileobj, "var3_sum", cdata_out(:,:,:,1), unlim_dim_level=ti)
     call check_data_3d(cdata_out(:,:,:,1), ti, .false.)
 
+    cdata_out = -999_r4_kind
+    print *, "Checking answers for var4_sum - time_level:", string(ti)
+    call read_data(fileobj, "var4_sum", cdata_out(:,:,:,:), unlim_dim_level=ti)
+    call check_data_3d(cdata_out(:,:,:,1), ti, .false.)
+    call check_data_3d(cdata_out(:,:,:,2), ti, .false.)
+
     cdata_out = -999_r4_kind
     print *, "Checking answers for var3_Z - time_level:", string(ti)
     call read_data(fileobj, "var3_Z", cdata_out(:,:,1:2,1), unlim_dim_level=ti)

test_fms/diag_manager/test_reduction_methods.F90

@@ -133,19 +133,19 @@ program test_reduction_methods
   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 (mpp_pe() .eq. 0) clmask(isc, jsc, 1, :) = .False.
 
     if (test_case .eq. test_halos) then
       dlmask = allocate_logical_mask(isd, ied, jsd, jed, nz, nw)
-      if (mpp_pe() .eq. 0) dlmask(1+nhalox, 1+nhaloy, 1, 1) = .False.
+      if (mpp_pe() .eq. 0) dlmask(1+nhalox, 1+nhaloy, 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 (mpp_pe() .eq. 0) crmask(isc, jsc, 1, :) = 0_r8_kind
 
     if (test_case .eq. test_halos) then
       drmask = allocate_real_mask(isd, ied, jsd, jed, nz, nw)
-      if (mpp_pe() .eq. 0) drmask(1+nhalox, 1+nhaloy, 1, 1) = 0_r8_kind
+      if (mpp_pe() .eq. 0) drmask(1+nhalox, 1+nhaloy, 1, :) = 0_r8_kind
     endif
   end select
 
@@ -190,14 +190,17 @@ program test_reduction_methods
         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)
+        used = send_data(id_var4, cdata(:,:,:,:), 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))
+        used = send_data(id_var4, cdata(:,:,:,:), Time, rmask=crmask(:,:,:,:))
       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))
+        used = send_data(id_var4, cdata(:,:,:,:), Time, mask=clmask(:,:,:,:))
       end select
     case (test_halos)
       call set_buffer(ddata, i)
@@ -208,6 +211,8 @@ program test_reduction_methods
           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)
+        used = send_data(id_var4, ddata(:,:,:,:), Time, &
+          is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1)
       case (real_mask)
         used = send_data(id_var1, cdata(:,1,1,1), Time, &
           rmask=crmask(:,1,1,1))
@@ -217,6 +222,9 @@ program test_reduction_methods
         used = send_data(id_var3, ddata(:,:,:,1), Time, &
           is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
           rmask=drmask(:,:,:,1))
+        used = send_data(id_var4, ddata(:,:,:,:), Time, &
+          is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
+          rmask=drmask(:,:,:,:))
       case (logical_mask)
         used = send_data(id_var1, cdata(:,1,1,1), Time, &
           mask=clmask(:,1,1,1))
@@ -226,6 +234,9 @@ program test_reduction_methods
         used = send_data(id_var3, ddata(:,:,:,1), Time, &
           is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
           mask=dlmask(:,:,:,1))
+        used = send_data(id_var4, ddata(:,:,:,:), Time, &
+          is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
+          mask=dlmask(:,:,:,:))
       end select
     case (test_openmp)
       select case(mask_case)
@@ -255,16 +266,21 @@ program test_reduction_methods
         case (no_mask)
           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)
+          used=send_data(id_var4, cdata(is1:ie1, js1:je1, :, :), time, is_in=is1, js_in=js1)
         case (real_mask)
           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))
+          used=send_data(id_var4, cdata(is1:ie1, js1:je1, :, :), time, is_in=is1, js_in=js1, &
+            rmask=crmask(is1:ie1, js1:je1, :, :))
         case (logical_mask)
           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))
+          used=send_data(id_var4, cdata(is1:ie1, js1:je1, :, :), time, is_in=is1, js_in=js1, &
+            mask=clmask(is1:ie1, js1:je1, :, :))
         end select
       enddo
     end select

test_fms/diag_manager/test_time_max.sh

@@ -58,6 +58,11 @@ diag_files:
     output_name: var3_max
     reduction: max
     kind: r4
+  - module: ocn_mod
+    var_name: var4
+    output_name: var4_max
+    reduction: max
+    kind: r4
   - module: ocn_mod
     var_name: var3
     output_name: var3_Z_max
@@ -110,7 +115,7 @@ test_expect_success "Checking answers for the "max" reduction method, real mask
   mpirun -n 1 ../check_time_max
 '
 
-export OMP_NUM_THREADS=1
+export OMP_NUM_THREADS=2
 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 "max" reduction method with openmp (test $my_test_count)" '
@@ -137,7 +142,7 @@ test_expect_success "Running diag_manager with "max" reduction method with openm
 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=2
+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 = 2 \n \n/" | cat > input.nml

test_fms/diag_manager/test_time_min.sh

@@ -58,6 +58,11 @@ diag_files:
     output_name: var3_min
     reduction: min
     kind: r4
+  - module: ocn_mod
+    var_name: var4
+    output_name: var4_min
+    reduction: min
+    kind: r4
   - module: ocn_mod
     var_name: var3
     output_name: var3_Z_min

test_fms/diag_manager/test_time_none.sh

@@ -57,6 +57,11 @@ diag_files:
     output_name: var3_none
     reduction: none
     kind: r4
+  - module: ocn_mod
+    var_name: var4
+    output_name: var4_none
+    reduction: none
+    kind: r4
   - module: ocn_mod
     var_name: var3
     output_name: var3_Z

test_fms/diag_manager/test_time_sum.sh

@@ -55,6 +55,11 @@ diag_files:
     output_name: var3_sum
     reduction: sum
     kind: r4
+  - module: ocn_mod
+    var_name: var4
+    output_name: var4_sum
+    reduction: sum
+    kind: r4
   - module: ocn_mod
     var_name: var3
     output_name: var3_Z