From 6922db728251fd491d0aab14ff2850911a099f1c Mon Sep 17 00:00:00 2001 From: "Igor S. Gerasimov" Date: Thu, 20 Nov 2025 22:40:29 +0100 Subject: [PATCH 1/4] Do not use write in-place --- mpp/include/mpp_util_mpi.inc | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/mpp/include/mpp_util_mpi.inc b/mpp/include/mpp_util_mpi.inc index 2b1a28f37..f94415c18 100644 --- a/mpp/include/mpp_util_mpi.inc +++ b/mpp/include/mpp_util_mpi.inc @@ -38,24 +38,24 @@ subroutine mpp_error_basic( errortype, errormsg ) #endif integer, intent(in) :: errortype character(len=*), intent(in), optional :: errormsg - character(len=512) :: text + character(len=512) :: text, text_errortype integer :: errunit if( .NOT.module_is_initialized )call ABORT() select case( errortype ) case(NOTE) - text = 'NOTE' !just FYI + text_errortype = 'NOTE' !just FYI case(WARNING) - text = 'WARNING' !probable error + text_errortype = 'WARNING' !probable error case(FATAL) - text = 'FATAL' !fatal error + text_errortype = 'FATAL' !fatal error case default - text = 'WARNING: non-existent errortype (must be NOTE|WARNING|FATAL)' + text_errortype = 'WARNING: non-existent errortype (must be NOTE|WARNING|FATAL)' end select - if( npes.GT.1 )write( text,'(a,i6)' )trim(text)//' from PE', pe !this is the mpp part - if( PRESENT(errormsg) )text = trim(text)//': '//trim(errormsg) + if( npes.GT.1 ) write( text,'(a,i6)' ) trim(text_errortype) // ' from PE', pe !this is the mpp part + if( PRESENT(errormsg) )text = trim(text) // ': ' // trim(errormsg) !$OMP CRITICAL (MPP_ERROR_CRITICAL) select case( errortype ) case(NOTE) From 559440c23c8932278ca99325fcd316b9bb1600b6 Mon Sep 17 00:00:00 2001 From: "Igor S. Gerasimov" Date: Thu, 20 Nov 2025 23:21:01 +0100 Subject: [PATCH 2/4] missvalue accept r4 datatype --- test_fms/diag_manager/test_diag_update_buffer.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 index 1fff3f0d7..21d211c23 100644 --- a/test_fms/diag_manager/test_diag_update_buffer.F90 +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -183,7 +183,7 @@ program test_diag_update_buffer diag_field_id = 1 sample = 1 weight = 1.0 - missvalue = 1.0e-5 + missvalue = 1.0e-5_r4_kind pow_value = 1 phys_window = .false. need_compute = .false. From a9b46483458bf4c8ac35e31801a0c20602ab2bd5 Mon Sep 17 00:00:00 2001 From: "Igor S. Gerasimov" Date: Fri, 21 Nov 2025 00:22:10 +0100 Subject: [PATCH 3/4] Do not use temporary arrays as c_loc targets --- test_fms/exchange/test_xgrid.F90 | 37 +++++++++++++++++++++----------- 1 file changed, 24 insertions(+), 13 deletions(-) diff --git a/test_fms/exchange/test_xgrid.F90 b/test_fms/exchange/test_xgrid.F90 index f8a1eb243..82841dd3c 100644 --- a/test_fms/exchange/test_xgrid.F90 +++ b/test_fms/exchange/test_xgrid.F90 @@ -781,7 +781,8 @@ program xgrid_test subroutine test_unstruct_exchange() - real(r8_kind), allocatable :: atm_data_in(:,:), atm_data_sg(:,:) + real(r8_kind), allocatable :: atm_data_in_0(:,:), atm_data_in_1(:,:), atm_data_in_2(:,:), atm_data_in_3(:,:) + real(r8_kind), allocatable :: atm_data_sg(:,:) real(r8_kind), allocatable :: atm_data_sg_1(:,:), atm_data_sg_2(:,:), atm_data_sg_3(:,:) real(r8_kind), allocatable :: lnd_data_sg(:,:,:), ice_data_sg(:,:,:) real(r8_kind), allocatable :: atm_data_ug(:,:), tmp_sg(:,:,:) @@ -877,12 +878,18 @@ subroutine test_unstruct_exchange() allocate(atm_data_ug_2(isc_atm:iec_atm, jsc_atm:jec_atm ) ) allocate(atm_data_ug_3(isc_atm:iec_atm, jsc_atm:jec_atm ) ) - allocate(atm_data_in(isc_atm:iec_atm, jsc_atm:jec_atm ) ) + allocate(atm_data_in_0(isc_atm:iec_atm, jsc_atm:jec_atm ) ) + allocate(atm_data_in_1(isc_atm:iec_atm, jsc_atm:jec_atm ) ) + allocate(atm_data_in_2(isc_atm:iec_atm, jsc_atm:jec_atm ) ) + allocate(atm_data_in_3(isc_atm:iec_atm, jsc_atm:jec_atm ) ) allocate(atm_data_sg(isc_atm:iec_atm, jsc_atm:jec_atm ) ) allocate(atm_data_sg_1(isc_atm:iec_atm, jsc_atm:jec_atm ) ) allocate(atm_data_sg_2(isc_atm:iec_atm, jsc_atm:jec_atm ) ) allocate(atm_data_sg_3(isc_atm:iec_atm, jsc_atm:jec_atm ) ) - atm_data_in = 0 + atm_data_in_0 = 0 + atm_data_in_1 = 0 + atm_data_in_2 = 0 + atm_data_in_3 = 0 atm_data_sg = 0 atm_data_sg_1 = 0 atm_data_sg_2 = 0 @@ -914,11 +921,14 @@ subroutine test_unstruct_exchange() x_3 = 0 x_4 = 0 - call random_number(atm_data_in) - call put_to_xgrid(atm_data_in, 'ATM', x_1, Xmap, remap_method=remap_method) - call put_to_xgrid(atm_data_in+1, 'ATM', x_2, Xmap, remap_method=remap_method, complete=.false.) - call put_to_xgrid(atm_data_in+2, 'ATM', x_3, Xmap, remap_method=remap_method, complete=.false.) - call put_to_xgrid(atm_data_in+3, 'ATM', x_4, Xmap, remap_method=remap_method, complete=.true.) + call random_number(atm_data_in_0) + atm_data_in_1 = atm_data_in_0 + 1 + atm_data_in_2 = atm_data_in_0 + 2 + atm_data_in_3 = atm_data_in_0 + 3 + call put_to_xgrid(atm_data_in_0, 'ATM', x_1, Xmap, remap_method=remap_method) + call put_to_xgrid(atm_data_in_1, 'ATM', x_2, Xmap, remap_method=remap_method, complete=.false.) + call put_to_xgrid(atm_data_in_2, 'ATM', x_3, Xmap, remap_method=remap_method, complete=.false.) + call put_to_xgrid(atm_data_in_3, 'ATM', x_4, Xmap, remap_method=remap_method, complete=.true.) call get_from_xgrid(lnd_data_sg, 'LND', x_1, xmap) call get_from_xgrid(ice_data_sg, 'OCN', x_1, xmap) call put_to_xgrid(lnd_data_sg, 'LND', x_2, xmap) @@ -936,10 +946,10 @@ subroutine test_unstruct_exchange() y_3 = 0 y_4 = 0 - call put_to_xgrid(atm_data_in, 'ATM', y_1, Xmap_ug, remap_method=remap_method) - call put_to_xgrid(atm_data_in+1, 'ATM', y_2, Xmap_ug, remap_method=remap_method, complete=.false.) - call put_to_xgrid(atm_data_in+2, 'ATM', y_3, Xmap_ug, remap_method=remap_method, complete=.false.) - call put_to_xgrid(atm_data_in+3, 'ATM', y_4, Xmap_ug, remap_method=remap_method, complete=.true.) + call put_to_xgrid(atm_data_in_0, 'ATM', y_1, Xmap_ug, remap_method=remap_method) + call put_to_xgrid(atm_data_in_1, 'ATM', y_2, Xmap_ug, remap_method=remap_method, complete=.false.) + call put_to_xgrid(atm_data_in_2, 'ATM', y_3, Xmap_ug, remap_method=remap_method, complete=.false.) + call put_to_xgrid(atm_data_in_3, 'ATM', y_4, Xmap_ug, remap_method=remap_method, complete=.true.) call get_from_xgrid_ug(lnd_data_ug, 'LND', y_1, xmap_ug) call get_from_xgrid(ice_data_ug, 'OCN', y_1, xmap_ug) call put_to_xgrid_ug(lnd_data_ug, 'LND', y_2, xmap_ug) @@ -967,7 +977,8 @@ subroutine test_unstruct_exchange() if(ice_pe) deallocate(ice_data_sg, ice_data_ug) deallocate(tmp_sg, x_1, x_2, x_3, x_4, y_1, y_2, y_3, y_4) - deallocate(atm_data_in, atm_data_sg) + deallocate(atm_data_in_0, atm_data_in_1, atm_data_in_2, atm_data_in_3) + deallocate(atm_data_sg) deallocate(atm_data_sg_1, atm_data_sg_2, atm_data_sg_3) deallocate(atm_data_ug) deallocate(atm_data_ug_1, atm_data_ug_2, atm_data_ug_3) From abc38c0244bcae52ef45b9d5eb69311ecb35274a Mon Sep 17 00:00:00 2001 From: "Igor S. Gerasimov" Date: Fri, 21 Nov 2025 01:15:43 +0100 Subject: [PATCH 4/4] Fix order of deallocation send_buffer: mpp_send is non-blocking, so deallocation must happen after sync point --- mpp/include/mpp_domains_misc.inc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/mpp/include/mpp_domains_misc.inc b/mpp/include/mpp_domains_misc.inc index 64c20ed38..e2ad02858 100644 --- a/mpp/include/mpp_domains_misc.inc +++ b/mpp/include/mpp_domains_misc.inc @@ -336,7 +336,6 @@ end subroutine init_nonblock_type ! Force use of "scalar", integer pointer mpp interface call mpp_send(ibounds(1), plen=4, to_pe=pelist2(1), tag=COMM_TAG_1) call mpp_send(send_buffer(1),plen=im*jm, to_pe=pelist2(1), tag=COMM_TAG_2) - deallocate(send_buffer) else if(pelist2(1) == pe) then ! receive data and compare do p = pelist1(1), pelist1(size(pelist1(:))) @@ -371,12 +370,13 @@ end subroutine init_nonblock_type print*, trim(mesg)//": ", 'comparison between 1 pe and ', npes-1, ' pes is ok' endif ! release memery - deallocate(field1, send_buffer) + deallocate(field1) endif deallocate(field2) call mpp_sync() + if (allocated(send_buffer)) deallocate(send_buffer) end subroutine mpp_check_field_2d_type1