fix: add return status optional argument to coupler_types_send_data (#…

…1530)

coupler/coupler_types.F90

@@ -2944,10 +2944,12 @@ end subroutine CT_set_diags_3d
 
 
   !> @brief Write out all diagnostics of elements of a coupler_2d_bc_type
-  !! TODO this should really be a function in order to return the status of send_data call
-  subroutine CT_send_data_2d(var, Time)
+  subroutine CT_send_data_2d(var, Time, return_statuses)
     type(coupler_2d_bc_type), intent(in) :: var  !< BC_type structure with the diagnostics to write
     type(time_type),          intent(in) :: time !< The current model time
+    logical, allocatable, optional, intent(out) :: return_statuses(:,:) !< Return status of send data calls
+                                                          !! first index is index of boundary condition
+                                                          !! second index is field/value within that boundary condition
 
     integer :: m, n
     logical :: used
@@ -2966,18 +2968,33 @@ subroutine CT_send_data_2d(var, Time)
 
     ! num_bcs .lt. 1 -> loop doesn't run but shouldn't error out
     if(associated(var%bc) .or. var%num_bcs .lt. 1) then
+
+      ! allocate array for returned send data statuses
+      if( present(return_statuses) .and. var%num_bcs .gt. 0) then
+        allocate(return_statuses(var%num_bcs, var%bc(1)%num_fields))
+      endif
+
       do n = 1, var%num_bcs
         do m = 1, var%bc(n)%num_fields
           if (var%bc(n)%field(m)%id_diag > 0) then
             used = send_data(var%bc(n)%field(m)%id_diag, var%bc(n)%field(m)%values, Time)
+            if(allocated(return_statuses)) return_statuses(n,m) = used
           endif
         enddo
       enddo
+
     else if(associated(var%bc_r4)) then
+
+      ! allocate array for returned send data statuses
+      if( present(return_statuses) .and. var%num_bcs .gt. 0) then
+        allocate(return_statuses(var%num_bcs, var%bc_r4(1)%num_fields))
+      endif
+
       do n = 1, var%num_bcs
         do m = 1, var%bc_r4(n)%num_fields
           if (var%bc_r4(n)%field(m)%id_diag > 0) then
             used = send_data(var%bc_r4(n)%field(m)%id_diag, var%bc_r4(n)%field(m)%values, Time)
+            if(allocated(return_statuses)) return_statuses(n,m) = used
           endif
         enddo
       enddo
@@ -2988,10 +3005,12 @@ subroutine CT_send_data_2d(var, Time)
   end subroutine CT_send_data_2d
 
   !> @brief Write out all diagnostics of elements of a coupler_3d_bc_type
-  !! TODO this should really be a function in order to return the status of send_data call
-  subroutine CT_send_data_3d(var, Time)
+  subroutine CT_send_data_3d(var, Time, return_statuses)
     type(coupler_3d_bc_type), intent(in) :: var  !< BC_type structure with the diagnostics to write
     type(time_type),          intent(in) :: time !< The current model time
+    logical, allocatable, optional, intent(out) :: return_statuses(:,:) !< Return status of send data calls
+                                                          !! first index is index of boundary condition
+                                                          !! second index is field/value within that boundary condition
 
     integer :: m, n
     logical :: used
@@ -3010,18 +3029,32 @@ subroutine CT_send_data_3d(var, Time)
 
     ! num_bcs .lt. 1 -> loop doesn't run but shouldn't error out
     if(associated(var%bc) .or. var%num_bcs .lt. 1) then
+
+      ! allocate array for returned send data statuses
+      if( present(return_statuses) .and. var%num_bcs .gt. 0) then
+        allocate(return_statuses(var%num_bcs, var%bc(1)%num_fields))
+      endif
+
       do n = 1, var%num_bcs
         do m = 1, var%bc(n)%num_fields
           if (var%bc(n)%field(m)%id_diag > 0) then
             used = send_data(var%bc(n)%field(m)%id_diag, var%bc(n)%field(m)%values, Time)
+            if(allocated(return_statuses)) return_statuses(n,m) = used
           endif
         enddo
       enddo
     else if(associated(var%bc_r4)) then
+
+      ! allocate array for returned send data statuses
+      if( present(return_statuses) .and. var%num_bcs .gt. 0) then
+        allocate(return_statuses(var%num_bcs, var%bc_r4(1)%num_fields))
+      endif
+
       do n = 1, var%num_bcs
         do m = 1, var%bc_r4(n)%num_fields
           if (var%bc_r4(n)%field(m)%id_diag > 0) then
             used = send_data(var%bc_r4(n)%field(m)%id_diag, var%bc_r4(n)%field(m)%values, Time)
+            if(allocated(return_statuses)) return_statuses(n,m) = used
           endif
         enddo
       enddo

test_fms/coupler/test_atmos_ocean_fluxes.F90

@@ -23,7 +23,7 @@
 !! @description This program tests the two main subroutines in atmos_ocean_fluxes.
 program test_atmos_ocean_fluxes
 
-  use fms_mod, only: fms_init
+  use fms_mod, only: fms_init, fms_end
   use coupler_types_mod, only: coupler_1d_bc_type
   use field_manager_mod, only: fm_exists, fm_get_value
   use fm_util_mod, only: fm_util_get_real_array
@@ -81,6 +81,7 @@ program test_atmos_ocean_fluxes
   call test_atmos_ocean_fluxes_init
   !> checking gas_fluxes, gas_fields_atm, and gas_fields_ice have been initialized correctly
   call test_coupler_1d_bc_type
+  call fms_end
 
 contains
   !--------------------------------------

test_fms/coupler/test_coupler.sh

@@ -26,6 +26,7 @@
 # Set common test settings.
 . ../test-lib.sh
 
+rm -f input.nml
 touch input.nml
 
 # diag_table for test
@@ -112,6 +113,25 @@ test_expect_success "coupler types interfaces (r8_kind)" '
   mpirun -n 4 ./test_coupler_types_r8
 '
 
+# delete lines from the table to make sure we see the difference in the send_data return status
+sed -i '8,12{d}' diag_table
+sed -i '10,13{d}' diag_table.yaml
+sed -i '18,25{d}' diag_table.yaml
+cat <<_EOF > input.nml
+&test_coupler_types_nml
+   fail_return_status=.true.
+/
+_EOF
+
+
+test_expect_success "coupler types interfaces - check send_data return vals (r4_kind)" '
+  mpirun -n 4 ./test_coupler_types_r4
+'
+
+test_expect_success "coupler types interfaces - check send_data return vals (r8_kind)" '
+  mpirun -n 4 ./test_coupler_types_r8
+'
+
 mkdir RESTART
 
 test_expect_success "coupler register restart 2D(r4_kind)" '

test_fms/coupler/test_coupler_types.F90

@@ -31,7 +31,7 @@
 program test_coupler_types
 
 use   fms_mod,            only: fms_init, fms_end, stdout, string
-use   mpp_mod,            only: mpp_error, mpp_pe, mpp_root_pe, FATAL, mpp_sync, mpp_init
+use   mpp_mod,            only: mpp_error, mpp_pe, mpp_root_pe, FATAL, mpp_sync, mpp_init, input_nml_file
 use   mpp_domains_mod,    only: domain2d, mpp_define_domains, mpp_define_io_domain, mpp_get_data_domain, domain1D
 use   mpp_domains_mod,    only: mpp_domains_set_stack_size
 use   coupler_types_mod,  only: coupler_3d_bc_type, coupler_2d_bc_type, coupler_1d_bc_type
@@ -70,13 +70,22 @@ program test_coupler_types
 character(len=128) :: chksum_2d, chksum_3d
 real(FMS_CP_TEST_KIND_), allocatable :: expected_2d(:,:), expected_3d(:,:,:)
 integer :: err, ncid, dim1D, varid, day
+logical, allocatable :: return_stats(:,:)
+
+logical :: fail_return_status = .false. !< if true checks for one of the coupler_type_send_data calls to fail and
+                                        !! return a false value
+
+NAMELIST /test_coupler_types_nml/ fail_return_status
 
 call fms_init
 call time_manager_init
 call fms2_io_init
 call mpp_init
 call set_calendar_type(JULIAN)
 
+read(input_nml_file, test_coupler_types_nml, iostat=err)
+if(err > 0) call mpp_error(FATAL, "test_coupler_types:: error reading test input nml")
+
 ! basic domain set up
 nlat=60; nlon=60; nz=12
 layout = (/2, 2/)
@@ -216,8 +225,22 @@ program test_coupler_types
   time_t = set_date(1, 1, day)
   call coupler_type_increment_data(bc_2d_cp, bc_2d_new) ! increment _new with cp
   call coupler_type_increment_data(bc_3d_cp, bc_3d_new)
-  call coupler_type_send_data(bc_2d_new, time_t)
-  call coupler_type_send_data(bc_3d_new, time_t)
+  call coupler_type_send_data(bc_2d_new, time_t, return_stats)
+  if( fail_return_status ) then
+    if( ALL(return_stats) ) call mpp_error(FATAL, "test_coupler_types:: send_data calls returned true, "// &
+                                                  "expected false return value from incorrect diag_table")
+  else
+    if( .not. ALL(return_stats) ) call mpp_error(FATAL, &
+                                  "test_coupler_types:: coupler_type_send_data returned false with valid diag_table")
+  endif
+  call coupler_type_send_data(bc_3d_new, time_t, return_stats)
+  if( fail_return_status ) then
+    if( ALL(return_stats) ) call mpp_error(FATAL, "test_coupler_types:: send_data calls returned true, "// &
+                                                  "expected false return value from incorrect diag_table")
+  else
+    if( .not. ALL(return_stats) ) call mpp_error(FATAL, &
+                                  "test_coupler_types:: coupler_type_send_data returned false with valid diag_table")
+  endif
 enddo
 time_t = set_date(1, 2, 1)
 call diag_manager_end(time_t)
@@ -314,4 +337,4 @@ subroutine check_field_data_3d(bc_3d, expected)
   enddo
 end subroutine check_field_data_3d
 
-end program
+end program