From 6ac3002997ea22d1ba256ebc44309bb2f8dc7675 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Mon, 24 Jun 2024 13:08:21 -0400 Subject: [PATCH] fix: add return status optional argument to coupler_types_send_data (#1530) --- coupler/coupler_types.F90 | 41 ++++++++++++++++++-- test_fms/coupler/test_atmos_ocean_fluxes.F90 | 3 +- test_fms/coupler/test_coupler.sh | 20 ++++++++++ test_fms/coupler/test_coupler_types.F90 | 31 +++++++++++++-- 4 files changed, 86 insertions(+), 9 deletions(-) diff --git a/coupler/coupler_types.F90 b/coupler/coupler_types.F90 index 515eb8ed8f..ab616ed981 100644 --- a/coupler/coupler_types.F90 +++ b/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 diff --git a/test_fms/coupler/test_atmos_ocean_fluxes.F90 b/test_fms/coupler/test_atmos_ocean_fluxes.F90 index 80a8294251..742ac4c50f 100644 --- a/test_fms/coupler/test_atmos_ocean_fluxes.F90 +++ b/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 !-------------------------------------- diff --git a/test_fms/coupler/test_coupler.sh b/test_fms/coupler/test_coupler.sh index 030a33269a..4512cca557 100755 --- a/test_fms/coupler/test_coupler.sh +++ b/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)" ' diff --git a/test_fms/coupler/test_coupler_types.F90 b/test_fms/coupler/test_coupler_types.F90 index 8beb9f4695..4204f768b6 100644 --- a/test_fms/coupler/test_coupler_types.F90 +++ b/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,6 +70,12 @@ 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 @@ -77,6 +83,9 @@ program test_coupler_types 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 \ No newline at end of file +end program