diff --git a/CMakeLists.txt b/CMakeLists.txt index f3d605a810..a49f62920f 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -880,40 +880,40 @@ if(UNIT_TESTS) get_filename_component (TName ${testFile} NAME_WE) add_executable(${TName}_r8 ${testFile}) - target_compile_definitions(${TName}_r8 PRIVATE "${r8_defs}") + target_compile_definitions(${TName}_r8 PRIVATE "${r8_defs} ${fms_defs}") set_target_properties(${TName}_r8 PROPERTIES COMPILE_FLAGS ${r8_flags}) - target_link_libraries(${TName}_r8 PUBLIC FMS::fms + target_link_libraries(${TName}_r8 PUBLIC ${fmsLibraryName} PRIVATE testLibs ) add_executable(${TName}_r4 ${testFile}) - target_compile_definitions(${TName}_r4 PRIVATE "${r4_defs}") + target_compile_definitions(${TName}_r4 PRIVATE "${r4_defs} ${fms_defs}") # seems counterintuitive but r4 tests use r8 default # they specify kind values explicitly with the preprocessor where needed (TEST_FMS_KIND_) set_target_properties(${TName}_r4 PROPERTIES COMPILE_FLAGS ${r8_flags}) - target_link_libraries(${TName}_r4 PUBLIC FMS::fms + target_link_libraries(${TName}_r4 PUBLIC ${fmsLibraryName} PRIVATE testLibs ) add_executable(${TName}_i8 ${testFile}) - target_compile_definitions(${TName}_i8 PRIVATE "${r8_defs}") + target_compile_definitions(${TName}_i8 PRIVATE "${r8_defs} ${fms_defs}") set_target_properties(${TName}_i8 PROPERTIES COMPILE_FLAGS ${r8_flags}) - target_link_libraries(${TName}_i8 PUBLIC FMS::fms + target_link_libraries(${TName}_i8 PUBLIC ${fmsLibraryName} PRIVATE testLibs ) add_executable(${TName}_i4 ${testFile}) - target_compile_definitions(${TName}_i4 PRIVATE "${r8_defs}") + target_compile_definitions(${TName}_i4 PRIVATE "${r8_defs} ${fms_defs}") set_target_properties(${TName}_i4 PROPERTIES COMPILE_FLAGS ${r8_flags}) - target_link_libraries(${TName}_i4 PUBLIC FMS::fms + target_link_libraries(${TName}_i4 PUBLIC ${fmsLibraryName} PRIVATE testLibs ) if(WITH_YAML) - target_link_libraries(${TName}_r4 PRIVATE yaml ${LIBYAML_LIBRARIES}) - target_link_libraries(${TName}_r8 PRIVATE yaml ${LIBYAML_LIBRARIES}) - target_link_libraries(${TName}_i4 PRIVATE yaml ${LIBYAML_LIBRARIES}) - target_link_libraries(${TName}_i8 PRIVATE yaml ${LIBYAML_LIBRARIES}) + target_link_libraries(${TName}_r4 PRIVATE PkgConfig::YAML) + target_link_libraries(${TName}_r8 PRIVATE PkgConfig::YAML) + target_link_libraries(${TName}_i4 PRIVATE PkgConfig::YAML) + target_link_libraries(${TName}_i8 PRIVATE PkgConfig::YAML) endif() if(OPENMP) diff --git a/mpp/Makefile.am b/mpp/Makefile.am index 6e8e2c6fb1..f5b5bde381 100644 --- a/mpp/Makefile.am +++ b/mpp/Makefile.am @@ -57,7 +57,6 @@ libmpp_la_SOURCES = \ include/mpp_do_checkV.fh \ include/mpp_do_get_boundary.fh \ include/mpp_do_get_boundary_ad.fh \ - include/mpp_do_global_field.fh \ include/mpp_do_global_field_ad.fh \ include/mpp_do_redistribute.fh \ include/mpp_do_update.fh \ @@ -87,6 +86,8 @@ libmpp_la_SOURCES = \ include/mpp_global_sum_ad.fh \ include/mpp_global_sum_tl.fh \ include/mpp_group_update.fh \ + include/mpp_pack.fh \ + include/mpp_pack.inc \ include/mpp_read_2Ddecomp.fh \ include/mpp_read_compressed.fh \ include/mpp_read_distributed_ascii.fh \ @@ -151,6 +152,8 @@ mpp_mod.$(FC_MODEXT): \ include/mpp_type_nocomm.fh \ include/mpp_gather.fh \ include/mpp_scatter.fh \ + include/mpp_pack.fh \ + include/mpp_pack.inc \ include/system_clock.fh mpp_data_mod.$(FC_MODEXT): \ mpp_parameter_mod.$(FC_MODEXT) \ @@ -193,7 +196,6 @@ mpp_domains_mod.$(FC_MODEXT): \ include/mpp_update_domains2D_nonblock.fh \ include/mpp_update_nest_domains.fh \ include/mpp_domains_reduce.inc \ - include/mpp_do_global_field.fh \ include/mpp_do_global_field_ad.fh \ include/mpp_global_field.fh \ include/mpp_global_field_ad.fh \ @@ -203,7 +205,9 @@ mpp_domains_mod.$(FC_MODEXT): \ include/mpp_global_sum_tl.fh \ include/mpp_unstruct_domain.inc \ include/mpp_global_field_ug.fh \ - include/mpp_unstruct_pass_data.fh + include/mpp_unstruct_pass_data.fh \ + include/mpp_pack.fh \ + include/mpp_pack.inc mpp_efp_mod.$(FC_MODEXT): mpp_parameter_mod.$(FC_MODEXT) mpp_mod.$(FC_MODEXT) mpp_memutils_mod.$(FC_MODEXT): mpp_mod.$(FC_MODEXT) mpp_pset_mod.$(FC_MODEXT): mpp_mod.$(FC_MODEXT) gfdl_nompi_f08.$(FC_MODEXT) diff --git a/mpp/include/mpp_data_mpi.inc b/mpp/include/mpp_data_mpi.inc index b717c78e2b..466a533f8d 100644 --- a/mpp/include/mpp_data_mpi.inc +++ b/mpp/include/mpp_data_mpi.inc @@ -38,8 +38,8 @@ integer, parameter :: mpp_from_pe = -999, ptr_from = -999 !-------------------------------------------------------------------! ! The following data is used in mpp_domains_mod and its components ! !-------------------------------------------------------------------! -real(r8_kind), allocatable :: mpp_domains_stack(:) !< stack used to hold data for domain operations -real(r8_kind), allocatable :: mpp_domains_stack_nonblock(:) !< stack used for non-blocking domain operations +real(r8_kind), allocatable, target :: mpp_domains_stack(:) !< stack used to hold data for domain operations +real(r8_kind), allocatable, target :: mpp_domains_stack_nonblock(:) !< stack used for non-blocking domain operations !--- some dummy variables with dummy values that will never be used integer, parameter :: ptr_domains_stack = -999 integer, parameter :: ptr_domains_stack_nonblock = -999 diff --git a/mpp/include/mpp_data_nocomm.inc b/mpp/include/mpp_data_nocomm.inc index f7de0670e4..62d4bd8065 100644 --- a/mpp/include/mpp_data_nocomm.inc +++ b/mpp/include/mpp_data_nocomm.inc @@ -38,8 +38,8 @@ integer, parameter :: mpp_from_pe = -999, ptr_from = -999 !-------------------------------------------------------------------! ! The following data is used in mpp_domains_mod and its components ! !-------------------------------------------------------------------! -real(r8_kind), allocatable :: mpp_domains_stack(:) -real(r8_kind), allocatable :: mpp_domains_stack_nonblock(:) +real(r8_kind), allocatable, target :: mpp_domains_stack(:) +real(r8_kind), allocatable, target :: mpp_domains_stack_nonblock(:) !--- some dummy variables with dummy values that will never be used integer, parameter :: ptr_domains_stack = -999 integer, parameter :: ptr_domains_stack_nonblock = -999 diff --git a/mpp/include/mpp_do_global_field.fh b/mpp/include/mpp_do_global_field.fh deleted file mode 100644 index 1a665e1a50..0000000000 --- a/mpp/include/mpp_do_global_field.fh +++ /dev/null @@ -1,523 +0,0 @@ -!*********************************************************************** -!* Apache License 2.0 -!* -!* This file is part of the GFDL Flexible Modeling System (FMS). -!* -!* Licensed under the Apache License, Version 2.0 (the "License"); -!* you may not use this file except in compliance with the License. -!* You may obtain a copy of the License at -!* -!* http://www.apache.org/licenses/LICENSE-2.0 -!* -!* FMS is distributed in the hope that it will be useful, but WITHOUT -!* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied; -!* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -!* PARTICULAR PURPOSE. See the License for the specific language -!* governing permissions and limitations under the License. -!*********************************************************************** -!> @addtogroup mpp_domains_mod -!> @{ - - !> Gets a global field from a local field - !! local field may be on compute OR data domain - subroutine MPP_DO_GLOBAL_FIELD_3D_( domain, local, global, tile, ishift, jshift, flags, default_data) - type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: local(:,:,:) - integer, intent(in) :: tile, ishift, jshift - MPP_TYPE_, intent(out) :: global(domain%x(tile)%global%begin:,domain%y(tile)%global%begin:,:) - integer, intent(in), optional :: flags - MPP_TYPE_, intent(in), optional :: default_data - - integer :: i, j, k, m, n, nd, num_words, lpos, rpos, ioff, joff, from_pe, root_pe, tile_id - integer :: ke, isc, iec, jsc, jec, is, ie, js, je, num_word_me - integer :: ipos, jpos - logical :: xonly, yonly, root_only, global_on_this_pe - MPP_TYPE_ :: clocal ((domain%x(1)%compute%size+ishift) *(domain%y(1)%compute%size+jshift) *size(local,3)) - MPP_TYPE_ :: cremote((domain%x(1)%compute%max_size+ishift)*(domain%y(1)%compute%max_size+jshift)*size(local,3)) - integer :: stackuse - character(len=8) :: text - - pointer( ptr_local, clocal ) - pointer( ptr_remote, cremote ) - - stackuse = size(clocal(:))+size(cremote(:)) - if( stackuse.GT.mpp_domains_stack_size )then - write( text, '(i8)' )stackuse - call mpp_error( FATAL, & - 'MPP_DO_GLOBAL_FIELD user stack overflow: call mpp_domains_set_stack_size('//trim(text)// & - & ') from all PEs.' ) - end if - mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, stackuse ) - - ptr_local = LOC(mpp_domains_stack) - ptr_remote = LOC(mpp_domains_stack(size(clocal(:))+1)) - - if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GLOBAL_FIELD: must first call mpp_domains_init.' ) - - xonly = .FALSE. - yonly = .FALSE. - root_only = .FALSE. - if( PRESENT(flags) ) then - xonly = BTEST(flags,EAST) - yonly = BTEST(flags,SOUTH) - if( .NOT.xonly .AND. .NOT.yonly )call mpp_error( WARNING, & - 'MPP_GLOBAL_FIELD: you must have flags=XUPDATE, YUPDATE or XUPDATE+YUPDATE' ) - if(xonly .AND. yonly) then - xonly = .false.; yonly = .false. - endif - root_only = BTEST(flags, ROOT_GLOBAL) - if( (xonly .or. yonly) .AND. root_only ) then - call mpp_error( WARNING, 'MPP_GLOBAL_FIELD: flags = XUPDATE+GLOBAL_ROOT_ONLY or ' // & - 'flags = YUPDATE+GLOBAL_ROOT_ONLY is not supported, will ignore GLOBAL_ROOT_ONLY' ) - root_only = .FALSE. - endif - endif - - global_on_this_pe = .NOT. root_only .OR. domain%pe == domain%tile_root_pe - ipos = 0; jpos = 0 - if(global_on_this_pe ) then - if(size(local,3).NE.size(global,3) ) call mpp_error( FATAL, & - 'MPP_GLOBAL_FIELD: mismatch of third dimension size of global and local') - if( size(global,1).NE.(domain%x(tile)%global%size+ishift) .OR. & - size(global,2).NE.(domain%y(tile)%global%size+jshift))then - if(xonly) then - if(size(global,1).NE.(domain%x(tile)%global%size+ishift) .OR. & - size(global,2).NE.(domain%y(tile)%compute%size+jshift)) & - call mpp_error( FATAL, & - & 'MPP_GLOBAL_FIELD: incoming arrays do not match domain for xonly global field.' ) - jpos = -domain%y(tile)%compute%begin + 1 - else if(yonly) then - if(size(global,1).NE.(domain%x(tile)%compute%size+ishift) .OR. & - size(global,2).NE.(domain%y(tile)%global%size+jshift)) & - call mpp_error( FATAL, & - & 'MPP_GLOBAL_FIELD: incoming arrays do not match domain for yonly global field.' ) - ipos = -domain%x(tile)%compute%begin + 1 - else - call mpp_error( FATAL, 'MPP_GLOBAL_FIELD: incoming arrays do not match domain.' ) - endif - endif - endif - - if( size(local,1).EQ.(domain%x(tile)%compute%size+ishift) .AND. & - size(local,2).EQ.(domain%y(tile)%compute%size+jshift) )then - !local is on compute domain - ioff = -domain%x(tile)%compute%begin + 1 - joff = -domain%y(tile)%compute%begin + 1 - else if( size(local,1).EQ.(domain%x(tile)%memory%size+ishift) .AND. & - size(local,2).EQ.(domain%y(tile)%memory%size+jshift) )then - !local is on data domain - ioff = -domain%x(tile)%domain_data%begin + 1 - joff = -domain%y(tile)%domain_data%begin + 1 - else - call mpp_error( FATAL, & - & 'MPP_GLOBAL_FIELD_: incoming field array must match either compute domain or memory domain.') - end if - - ke = size(local,3) - isc = domain%x(tile)%compute%begin; iec = domain%x(tile)%compute%end+ishift - jsc = domain%y(tile)%compute%begin; jec = domain%y(tile)%compute%end+jshift - - num_word_me = (iec-isc+1)*(jec-jsc+1)*ke - -! make contiguous array from compute domain - m = 0 - if(global_on_this_pe) then - !z1l: initialize global = 0 to support mask domain - if(PRESENT(default_data)) then - global = default_data - else -#ifdef LOGICAL_VARIABLE - global = .false. -#else - global = 0 -#endif - endif - - do k = 1, ke - do j = jsc, jec - do i = isc, iec - m = m + 1 - clocal(m) = local(i+ioff,j+joff,k) - global(i+ipos,j+jpos,k) = clocal(m) !always fill local domain directly - end do - end do - end do - else - do k = 1, ke - do j = jsc, jec - do i = isc, iec - m = m + 1 - clocal(m) = local(i+ioff,j+joff,k) - end do - end do - end do - endif - -! if there is more than one tile on this pe, then no decomposition for all tiles on this pe, so we can just return - if(size(domain%x(:))>1) then - !--- the following is needed to avoid deadlock. - if( tile == size(domain%x(:)) ) call mpp_sync_self( ) - return - end if - - root_pe = mpp_root_pe() - -!fill off-domains (note loops begin at an offset of 1) - if( xonly )then - nd = size(domain%x(1)%list(:)) - do n = 1,nd-1 - lpos = mod(domain%x(1)%pos+nd-n,nd) - rpos = mod(domain%x(1)%pos +n,nd) - from_pe = domain%x(1)%list(rpos)%pe - rpos = from_pe - root_pe ! for concurrent run, root_pe may not be 0. - if (from_pe == NULL_PE) then - num_words = 0 - else - num_words = (domain%list(rpos)%x(1)%compute%size+ishift) & - * (domain%list(rpos)%y(1)%compute%size+jshift) * ke - endif - ! Force use of scalar, integer ptr interface - call mpp_transmit( put_data=clocal(1), plen=num_word_me, to_pe=domain%x(1)%list(lpos)%pe, & - get_data=cremote(1), glen=num_words, from_pe=from_pe ) - m = 0 - if (from_pe /= NULL_PE) then - is = domain%list(rpos)%x(1)%compute%begin; ie = domain%list(rpos)%x(1)%compute%end+ishift - do k = 1, ke - do j = jsc, jec - do i = is, ie - m = m + 1 - global(i,j+jpos,k) = cremote(m) - end do - end do - end do - endif - call mpp_sync_self() !-ensure MPI_ISEND is done. - end do - else if( yonly )then - nd = size(domain%y(1)%list(:)) - do n = 1,nd-1 - lpos = mod(domain%y(1)%pos+nd-n,nd) - rpos = mod(domain%y(1)%pos +n,nd) - from_pe = domain%y(1)%list(rpos)%pe - rpos = from_pe - root_pe - if (from_pe == NULL_PE) then - num_words = 0 - else - num_words = (domain%list(rpos)%x(1)%compute%size+ishift) & - * (domain%list(rpos)%y(1)%compute%size+jshift) * ke - endif - ! Force use of scalar, integer pointer interface - call mpp_transmit( put_data=clocal(1), plen=num_word_me, to_pe=domain%y(1)%list(lpos)%pe, & - get_data=cremote(1), glen=num_words, from_pe=from_pe ) - m = 0 - if (from_pe /= NULL_PE) then - js = domain%list(rpos)%y(1)%compute%begin; je = domain%list(rpos)%y(1)%compute%end+jshift - do k = 1,ke - do j = js, je - do i = isc, iec - m = m + 1 - global(i+ipos,j,k) = cremote(m) - end do - end do - end do - endif - call mpp_sync_self() !-ensure MPI_ISEND is done. - end do - else - tile_id = domain%tile_id(1) - nd = size(domain%list(:)) - if(root_only) then - if(domain%pe .NE. domain%tile_root_pe) then - call mpp_send( clocal(1), plen=num_word_me, to_pe=domain%tile_root_pe, tag=COMM_TAG_1 ) - else - do n = 1,nd-1 - rpos = mod(domain%pos+n,nd) - if( domain%list(rpos)%tile_id(1) .NE. tile_id ) cycle - num_words = (domain%list(rpos)%x(1)%compute%size+ishift) * & - & (domain%list(rpos)%y(1)%compute%size+jshift) * ke - call mpp_recv(cremote(1), glen=num_words, from_pe=domain%list(rpos)%pe, tag=COMM_TAG_1 ) - m = 0 - is = domain%list(rpos)%x(1)%compute%begin; ie = domain%list(rpos)%x(1)%compute%end+ishift - js = domain%list(rpos)%y(1)%compute%begin; je = domain%list(rpos)%y(1)%compute%end+jshift - - do k = 1,ke - do j = js, je - do i = is, ie - m = m + 1 - global(i,j,k) = cremote(m) - end do - end do - end do - end do - endif - else - do n = 1,nd-1 - lpos = mod(domain%pos+nd-n,nd) - if( domain%list(lpos)%tile_id(1).NE. tile_id ) cycle ! global field only within tile - call mpp_send( clocal(1), plen=num_word_me, to_pe=domain%list(lpos)%pe, tag=COMM_TAG_2 ) - end do - do n = 1,nd-1 - rpos = mod(domain%pos+n,nd) - if( domain%list(rpos)%tile_id(1) .NE. tile_id ) cycle ! global field only within tile - num_words = (domain%list(rpos)%x(1)%compute%size+ishift) * & - & (domain%list(rpos)%y(1)%compute%size+jshift) * ke - call mpp_recv( cremote(1), glen=num_words, from_pe=domain%list(rpos)%pe, tag=COMM_TAG_2 ) - m = 0 - is = domain%list(rpos)%x(1)%compute%begin; ie = domain%list(rpos)%x(1)%compute%end+ishift - js = domain%list(rpos)%y(1)%compute%begin; je = domain%list(rpos)%y(1)%compute%end+jshift - - do k = 1,ke - do j = js, je - do i = is, ie - m = m + 1 - global(i,j,k) = cremote(m) - end do - end do - end do - end do - endif - end if - - call mpp_sync_self() - - return - end subroutine MPP_DO_GLOBAL_FIELD_3D_ - - - subroutine MPP_DO_GLOBAL_FIELD_A2A_3D_( domain, local, global, tile, ishift, jshift, flags, default_data) -!get a global field from a local field -!local field may be on compute OR data domain - type(domain2D), intent(in) :: domain - integer, intent(in) :: tile, ishift, jshift - MPP_TYPE_, intent(in), contiguous, target :: local(:,:,:) - MPP_TYPE_, intent(out), contiguous, target :: global(domain%x(tile)%global%begin:,domain%y(tile)%global%begin:,:) - integer, intent(in), optional :: flags - MPP_TYPE_, intent(in), optional :: default_data - - integer :: i, n, nd, ioff, joff, root_pe - integer :: ke, isc, iec, jsc, jec, is, ie, js, je - integer :: ipos, jpos - logical :: xonly, yonly, root_only, global_on_this_pe - - ! Alltoallw vectors - MPP_TYPE_, dimension(:), pointer :: plocal, pglobal - - integer, dimension(:), allocatable :: sendcounts(:), recvcounts(:) - integer, dimension(:), allocatable :: sdispls(:), rdispls(:) - type(mpp_type), allocatable :: sendtypes(:), recvtypes(:) - integer, dimension(3) :: array_of_subsizes, array_of_starts - integer :: n_sends, n_ax, pe - integer :: isg, jsg - integer, allocatable :: pelist(:), axis_pelist(:), pelist_idx(:) - - if (.NOT.module_is_initialized) & - call mpp_error( FATAL, 'MPP_GLOBAL_FIELD: must first call mpp_domains_init.' ) - - ! Validate flag consistency and configure the function - xonly = .FALSE. - yonly = .FALSE. - root_only = .FALSE. - if( PRESENT(flags) ) then - xonly = BTEST(flags,EAST) - yonly = BTEST(flags,SOUTH) - if( .NOT.xonly .AND. .NOT.yonly )call mpp_error( WARNING, & - 'MPP_GLOBAL_FIELD: you must have flags=XUPDATE, YUPDATE or XUPDATE+YUPDATE' ) - if(xonly .AND. yonly) then - xonly = .false.; yonly = .false. - endif - root_only = BTEST(flags, ROOT_GLOBAL) - if( (xonly .or. yonly) .AND. root_only ) then - call mpp_error( WARNING, 'MPP_GLOBAL_FIELD: flags = XUPDATE+GLOBAL_ROOT_ONLY or ' // & - 'flags = YUPDATE+GLOBAL_ROOT_ONLY is not supported, will ignore GLOBAL_ROOT_ONLY' ) - root_only = .FALSE. - endif - endif - - global_on_this_pe = .NOT. root_only .OR. domain%pe == domain%tile_root_pe - - ! Calculate offset for truncated global fields - ! NOTE: We do not check contiguity of global subarrays, and assume that - ! they have been copied to a contigous array. - ipos = 0; jpos = 0 - if(global_on_this_pe ) then - if(size(local,3).NE.size(global,3) ) call mpp_error( FATAL, & - 'MPP_GLOBAL_FIELD: mismatch of third dimension size of global and local') - if( size(global,1).NE.(domain%x(tile)%global%size+ishift) .OR. & - size(global,2).NE.(domain%y(tile)%global%size+jshift))then - if(xonly) then - if(size(global,1).NE.(domain%x(tile)%global%size+ishift) .OR. & - size(global,2).NE.(domain%y(tile)%compute%size+jshift)) & - call mpp_error( FATAL, & - & 'MPP_GLOBAL_FIELD: incoming arrays do not match domain for xonly global field.' ) - jpos = -domain%y(tile)%compute%begin + 1 - else if(yonly) then - if(size(global,1).NE.(domain%x(tile)%compute%size+ishift) .OR. & - size(global,2).NE.(domain%y(tile)%global%size+jshift)) & - call mpp_error( FATAL, & - & 'MPP_GLOBAL_FIELD: incoming arrays do not match domain for yonly global field.' ) - ipos = -domain%x(tile)%compute%begin + 1 - else - call mpp_error( FATAL, 'MPP_GLOBAL_FIELD: incoming arrays do not match domain.' ) - endif - endif - endif - - ! NOTE: Since local is assumed to contiguously match the data domain, this - ! is not a useful check. But maybe someday we can support compute - ! domains. - if( size(local,1).EQ.(domain%x(tile)%compute%size+ishift) .AND. & - size(local,2).EQ.(domain%y(tile)%compute%size+jshift) )then - !local is on compute domain - ioff = -domain%x(tile)%compute%begin - joff = -domain%y(tile)%compute%begin - else if( size(local,1).EQ.(domain%x(tile)%memory%size+ishift) .AND. & - size(local,2).EQ.(domain%y(tile)%memory%size+jshift) )then - !local is on data domain - ioff = -domain%x(tile)%domain_data%begin - joff = -domain%y(tile)%domain_data%begin - else - call mpp_error( FATAL, & - & 'MPP_GLOBAL_FIELD_: incoming field array must match either compute domain or memory domain.' ) - end if - - ke = size(local,3) - isc = domain%x(tile)%compute%begin; iec = domain%x(tile)%compute%end+ishift - jsc = domain%y(tile)%compute%begin; jec = domain%y(tile)%compute%end+jshift - isg = domain%x(1)%global%begin; jsg = domain%y(1)%global%begin - - if(global_on_this_pe) then - !z1l: initialize global = 0 to support mask domain - if(PRESENT(default_data)) then - global = default_data - else -#ifdef LOGICAL_VARIABLE - global = .false. -#else - global = 0 -#endif - endif - endif - - ! if there is more than one tile on this pe, then no decomposition for - ! all tiles on this pe, so we can just return - if(size(domain%x(:))>1) then - !--- the following is needed to avoid deadlock. - if( tile == size(domain%x(:)) ) call mpp_sync_self( ) - return - end if - - root_pe = mpp_root_pe() - - ! Generate the pelist - ! TODO: Add these to the domain API - if (xonly) then - n_ax = size(domain%x(1)%list(:)) - allocate(axis_pelist(n_ax)) - axis_pelist = [ (domain%x(1)%list(i)%pe, i = 0, n_ax-1) ] - - nd = count(axis_pelist >= 0) - allocate(pelist(nd), pelist_idx(0:nd-1)) - pelist = pack(axis_pelist, mask=(axis_pelist >= 0)) - pelist_idx = pack([(i, i=0, n_ax-1)], mask=(axis_pelist >= 0)) - - deallocate(axis_pelist) - else if (yonly) then - n_ax = size(domain%y(1)%list(:)) - allocate(axis_pelist(n_ax)) - axis_pelist = [ (domain%y(1)%list(i)%pe, i = 0, n_ax-1) ] - - nd = count(axis_pelist >= 0) - allocate(pelist(nd), pelist_idx(0:nd-1)) - pelist = pack(axis_pelist, mask=(axis_pelist >= 0)) - pelist_idx = pack([(i, i=0, n_ax-1)], mask=(axis_pelist >= 0)) - - deallocate(axis_pelist) - else - nd = size(domain%list(:)) - allocate(pelist(nd), pelist_idx(0:nd-1)) - call mpp_get_pelist(domain, pelist) - pelist_idx = [ (i, i=0, nd-1) ] - end if - - ! Allocate message data buffers - allocate(sendcounts(0:nd-1)) - allocate(sdispls(0:nd-1)) - allocate(sendtypes(0:nd-1)) - sendcounts(:) = 0 - sdispls(:) = 0 - sendtypes(:) = mpp_byte - - allocate(recvcounts(0:nd-1)) - allocate(rdispls(0:nd-1)) - allocate(recvtypes(0:nd-1)) - recvcounts(:) = 0 - rdispls(:) = 0 - recvtypes(:) = mpp_byte - - array_of_subsizes = [iec - isc + 1, jec - jsc + 1, size(local, 3)] - array_of_starts = [isc + ioff, jsc + joff, 0] - - n_sends = merge(1, nd, root_only) ! 1 if root_only else nd - do n = 0, n_sends - 1 - sendcounts(n) = 1 - - call mpp_type_create( & - local, & - array_of_subsizes, & - array_of_starts, & - sendtypes(n) & - ) - end do - - ! Receive configuration - if (global_on_this_pe) then - do n = 0, nd - 1 - recvcounts(n) = 1 - pe = pelist_idx(n) - - if (xonly) then - is = domain%x(1)%list(pe)%compute%begin - ie = domain%x(1)%list(pe)%compute%end + ishift - js = jsc; je = jec - else if (yonly) then - is = isc; ie = iec - js = domain%y(1)%list(pe)%compute%begin - je = domain%y(1)%list(pe)%compute%end + jshift - else - is = domain%list(pe)%x(1)%compute%begin - ie = domain%list(pe)%x(1)%compute%end + ishift - js = domain%list(pe)%y(1)%compute%begin - je = domain%list(pe)%y(1)%compute%end + jshift - end if - - array_of_subsizes = [ie - is + 1, je - js + 1, ke] - array_of_starts = [is - isg + ipos, js - jsg + jpos, 0] - - call mpp_type_create( & - global, & - array_of_subsizes, & - array_of_starts, & - recvtypes(n) & - ) - end do - end if - - plocal(1:size(local)) => local - pglobal(1:size(global)) => global - - call mpp_alltoall(plocal, sendcounts, sdispls, sendtypes, & - pglobal, recvcounts, rdispls, recvtypes, & - pelist) - - plocal => null() - pglobal => null() - - ! Cleanup - deallocate(pelist) - deallocate(sendcounts, sdispls, sendtypes) - deallocate(recvcounts, rdispls, recvtypes) - - call mpp_sync_self() - - end subroutine MPP_DO_GLOBAL_FIELD_A2A_3D_ -!> @} diff --git a/mpp/include/mpp_domains_reduce.inc b/mpp/include/mpp_domains_reduce.inc index 66aaffdcf4..826b2f66ac 100644 --- a/mpp/include/mpp_domains_reduce.inc +++ b/mpp/include/mpp_domains_reduce.inc @@ -792,119 +792,6 @@ ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -#define MPP_TYPE_INIT_VALUE 0. -#undef MPP_GLOBAL_FIELD_2D_ -#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_r8_2d -#undef MPP_GLOBAL_FIELD_3D_ -#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_r8_3d -#undef MPP_GLOBAL_FIELD_4D_ -#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_r8_4d -#undef MPP_GLOBAL_FIELD_5D_ -#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_r8_5d -#undef MPP_TYPE_ -#define MPP_TYPE_ real(r8_kind) -#include - -#ifdef OVERLOAD_C8 -#undef MPP_GLOBAL_FIELD_2D_ -#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_c8_2d -#undef MPP_GLOBAL_FIELD_3D_ -#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_c8_3d -#undef MPP_GLOBAL_FIELD_4D_ -#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_c8_4d -#undef MPP_GLOBAL_FIELD_5D_ -#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_c8_5d -#undef MPP_TYPE_ -#define MPP_TYPE_ complex(c8_kind) -#include -#endif - -#undef MPP_TYPE_INIT_VALUE -#define MPP_TYPE_INIT_VALUE 0 -#undef MPP_GLOBAL_FIELD_2D_ -#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_i8_2d -#undef MPP_GLOBAL_FIELD_3D_ -#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_i8_3d -#undef MPP_GLOBAL_FIELD_4D_ -#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_i8_4d -#undef MPP_GLOBAL_FIELD_5D_ -#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_i8_5d -#undef MPP_TYPE_ -#define MPP_TYPE_ integer(i8_kind) -#include - -#undef MPP_TYPE_INIT_VALUE -#define MPP_TYPE_INIT_VALUE .false. -#undef MPP_GLOBAL_FIELD_2D_ -#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_l8_2d -#undef MPP_GLOBAL_FIELD_3D_ -#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_l8_3d -#undef MPP_GLOBAL_FIELD_4D_ -#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_l8_4d -#undef MPP_GLOBAL_FIELD_5D_ -#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_l8_5d -#undef MPP_TYPE_ -#define MPP_TYPE_ logical(l8_kind) -#include - -#undef MPP_TYPE_INIT_VALUE -#define MPP_TYPE_INIT_VALUE 0. -#undef MPP_GLOBAL_FIELD_2D_ -#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_r4_2d -#undef MPP_GLOBAL_FIELD_3D_ -#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_r4_3d -#undef MPP_GLOBAL_FIELD_4D_ -#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_r4_4d -#undef MPP_GLOBAL_FIELD_5D_ -#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_r4_5d -#undef MPP_TYPE_ -#define MPP_TYPE_ real(r4_kind) -#include - -#ifdef OVERLOAD_C4 -#undef MPP_GLOBAL_FIELD_2D_ -#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_c4_2d -#undef MPP_GLOBAL_FIELD_3D_ -#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_c4_3d -#undef MPP_GLOBAL_FIELD_4D_ -#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_c4_4d -#undef MPP_GLOBAL_FIELD_5D_ -#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_c4_5d -#undef MPP_TYPE_ -#define MPP_TYPE_ complex(c4_kind) -#include -#endif - -#undef MPP_TYPE_INIT_VALUE -#define MPP_TYPE_INIT_VALUE 0 -#undef MPP_GLOBAL_FIELD_2D_ -#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_i4_2d -#undef MPP_GLOBAL_FIELD_3D_ -#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_i4_3d -#undef MPP_GLOBAL_FIELD_4D_ -#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_i4_4d -#undef MPP_GLOBAL_FIELD_5D_ -#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_i4_5d -#undef MPP_TYPE_ -#define MPP_TYPE_ integer(i4_kind) -#include - -#undef MPP_TYPE_INIT_VALUE -#define MPP_TYPE_INIT_VALUE .false. -#undef MPP_GLOBAL_FIELD_2D_ -#define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_l4_2d -#undef MPP_GLOBAL_FIELD_3D_ -#define MPP_GLOBAL_FIELD_3D_ mpp_global_field2D_l4_3d -#undef MPP_GLOBAL_FIELD_4D_ -#define MPP_GLOBAL_FIELD_4D_ mpp_global_field2D_l4_4d -#undef MPP_GLOBAL_FIELD_5D_ -#define MPP_GLOBAL_FIELD_5D_ mpp_global_field2D_l4_5d -#undef MPP_TYPE_ -#define MPP_TYPE_ logical(l4_kind) -#include -#undef MPP_TYPE_INIT_VALUE - -!**************************************************** #define MPP_TYPE_INIT_VALUE 0. #undef MPP_GLOBAL_FIELD_2D_AD_ #define MPP_GLOBAL_FIELD_2D_AD_ mpp_global_field2D_r8_2d_ad @@ -1018,77 +905,73 @@ #undef MPP_TYPE_INIT_VALUE !**************************************************** -#undef MPP_DO_GLOBAL_FIELD_3D_ -#undef MPP_DO_GLOBAL_FIELD_A2A_3D_ -#define MPP_DO_GLOBAL_FIELD_3D_ mpp_do_global_field2D_r8_3d -#define MPP_DO_GLOBAL_FIELD_A2A_3D_ mpp_do_global_field2D_a2a_r8_3d +#undef MPP_GLOBAL_FIELD_ +#define MPP_GLOBAL_FIELD_ mpp_global_field_r8 #undef MPP_TYPE_ #define MPP_TYPE_ real(r8_kind) -#include +#undef DEFAULT_VALUE_ +#define DEFAULT_VALUE_ 0._r8_kind +#include #ifdef OVERLOAD_C8 -#undef MPP_DO_GLOBAL_FIELD_3D_ -#undef MPP_DO_GLOBAL_FIELD_A2A_3D_ -#define MPP_DO_GLOBAL_FIELD_3D_ mpp_do_global_field2D_c8_3d -#define MPP_DO_GLOBAL_FIELD_A2A_3D_ mpp_do_global_field2D_a2a_c8_3d +#undef MPP_GLOBAL_FIELD_ +#define MPP_GLOBAL_FIELD_ mpp_global_field_c8 #undef MPP_TYPE_ #define MPP_TYPE_ complex(c8_kind) -#include +#undef DEFAULT_VALUE_ +#define DEFAULT_VALUE_ (0._r8_kind,0._r8_kind) +#include #endif -#undef MPP_DO_GLOBAL_FIELD_3D_ -#undef MPP_DO_GLOBAL_FIELD_A2A_3D_ -#define MPP_DO_GLOBAL_FIELD_3D_ mpp_do_global_field2D_i8_3d -#define MPP_DO_GLOBAL_FIELD_A2A_3D_ mpp_do_global_field2D_a2a_i8_3d +#undef MPP_GLOBAL_FIELD_ +#define MPP_GLOBAL_FIELD_ mpp_global_field_i8 #undef MPP_TYPE_ #define MPP_TYPE_ integer(i8_kind) -#include +#undef DEFAULT_VALUE_ +#define DEFAULT_VALUE_ 0_i8_kind +#include -#undef MPP_DO_GLOBAL_FIELD_3D_ -#undef MPP_DO_GLOBAL_FIELD_A2A_3D_ -#define MPP_DO_GLOBAL_FIELD_3D_ mpp_do_global_field2D_l8_3d -#define MPP_DO_GLOBAL_FIELD_A2A_3D_ mpp_do_global_field2D_a2a_l8_3d -#define LOGICAL_VARIABLE +#undef MPP_GLOBAL_FIELD_ +#define MPP_GLOBAL_FIELD_ mpp_global_field_l8 #undef MPP_TYPE_ #define MPP_TYPE_ logical(l8_kind) -#include -#undef LOGICAL_VARIABLE +#undef DEFAULT_VALUE_ +#define DEFAULT_VALUE_ .false._l8_kind +#include -#undef MPP_DO_GLOBAL_FIELD_3D_ -#undef MPP_DO_GLOBAL_FIELD_A2A_3D_ -#define MPP_DO_GLOBAL_FIELD_3D_ mpp_do_global_field2D_r4_3d -#define MPP_DO_GLOBAL_FIELD_A2A_3D_ mpp_do_global_field2D_a2a_r4_3d +#undef MPP_GLOBAL_FIELD_ +#define MPP_GLOBAL_FIELD_ mpp_global_field_r4 #undef MPP_TYPE_ #define MPP_TYPE_ real(r4_kind) -#include +#undef DEFAULT_VALUE_ +#define DEFAULT_VALUE_ 0._r4_kind +#include #ifdef OVERLOAD_C4 -#undef MPP_DO_GLOBAL_FIELD_3D_ -#undef MPP_DO_GLOBAL_FIELD_A2A_3D_ -#define MPP_DO_GLOBAL_FIELD_3D_ mpp_do_global_field2D_c4_3d -#define MPP_DO_GLOBAL_FIELD_A2A_3D_ mpp_do_global_field2D_a2a_c4_3d +#undef MPP_GLOBAL_FIELD_ +#define MPP_GLOBAL_FIELD_ mpp_global_field_c4 #undef MPP_TYPE_ #define MPP_TYPE_ complex(c4_kind) -#include +#undef DEFAULT_VALUE_ +#define DEFAULT_VALUE_ (0._r4_kind,0._r4_kind) +#include #endif -#undef MPP_DO_GLOBAL_FIELD_3D_ -#undef MPP_DO_GLOBAL_FIELD_A2A_3D_ -#define MPP_DO_GLOBAL_FIELD_3D_ mpp_do_global_field2D_i4_3d -#define MPP_DO_GLOBAL_FIELD_A2A_3D_ mpp_do_global_field2D_a2a_i4_3d +#undef MPP_GLOBAL_FIELD_ +#define MPP_GLOBAL_FIELD_ mpp_global_field_i4 #undef MPP_TYPE_ #define MPP_TYPE_ integer(i4_kind) -#include +#undef DEFAULT_VALUE_ +#define DEFAULT_VALUE_ 0_i4_kind +#include -#undef MPP_DO_GLOBAL_FIELD_3D_ -#undef MPP_DO_GLOBAL_FIELD_A2A_3D_ -#define MPP_DO_GLOBAL_FIELD_3D_ mpp_do_global_field2D_l4_3d -#define MPP_DO_GLOBAL_FIELD_A2A_3D_ mpp_do_global_field2D_a2a_l4_3d -#define LOGICAL_VARIABLE +#undef MPP_GLOBAL_FIELD_ +#define MPP_GLOBAL_FIELD_ mpp_global_field_l4 #undef MPP_TYPE_ #define MPP_TYPE_ logical(l4_kind) -#include -#undef LOGICAL_VARIABLE +#undef DEFAULT_VALUE_ +#define DEFAULT_VALUE_ .false._l4_kind +#include !**************************************************** #undef MPP_DO_GLOBAL_FIELD_3D_AD_ #define MPP_DO_GLOBAL_FIELD_3D_AD_ mpp_do_global_field2D_r8_3d_ad diff --git a/mpp/include/mpp_global_field.fh b/mpp/include/mpp_global_field.fh index 044f6f8050..b5a6f8181b 100644 --- a/mpp/include/mpp_global_field.fh +++ b/mpp/include/mpp_global_field.fh @@ -19,100 +19,258 @@ !> @{ !> get a global field from a local field !! local field may be on compute OR data domain - subroutine MPP_GLOBAL_FIELD_2D_( domain, local, global, flags, position,tile_count, default_data) - type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: local(:,:) - MPP_TYPE_, intent(out) :: global(:,:) - integer, intent(in), optional :: flags - integer, intent(in), optional :: position - integer, intent(in), optional :: tile_count - MPP_TYPE_, intent(in), optional :: default_data - MPP_TYPE_ :: local3D (size( local,1),size( local,2),1) - MPP_TYPE_ :: global3D(size(global,1),size(global,2),1) - pointer( lptr, local3D ) - pointer( gptr, global3D ) - ! initialize output, check if type macro logical - global = MPP_TYPE_INIT_VALUE - lptr = LOC( local) - gptr = LOC(global) - call mpp_global_field( domain, local3D, global3D, flags, position,tile_count, default_data ) - - end subroutine MPP_GLOBAL_FIELD_2D_ - - subroutine MPP_GLOBAL_FIELD_3D_( domain, local, global, flags, position, tile_count, default_data) - type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: local(:,:,:) - MPP_TYPE_, intent(out) :: global(:,:,:) + !> Gets a global field from a local field + !! local field may be on compute OR data domain + subroutine MPP_GLOBAL_FIELD_( domain, local, global, flags, position, tile_count, default_data, xdim, ydim) + type(domain2D), intent(in) :: domain + MPP_TYPE_, intent(in) :: local(..) + MPP_TYPE_, intent(out) :: global(..) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: tile_count MPP_TYPE_, intent(in), optional :: default_data + integer, intent(in), optional :: xdim, ydim !< Indices of the domain-decomposed dimensions. In typical + !! Fortran-based code, xdim=1 and ydim=2. + + integer :: i, j, k, m, n, nd, num_words, lpos, rpos, ioff, joff, from_pe, root_pe, tile_id + integer :: ke, isc, iec, jsc, jec, is, ie, js, je, num_word_me + integer :: ipos, jpos, n_per_gridpoint_local, n_per_gridpoint_global + logical :: xonly, yonly, root_only, global_on_this_pe + integer :: ix, iy + MPP_TYPE_, pointer, dimension(:) :: clocal, cremote + integer :: stackuse + character(len=8) :: text + type(c_ptr) :: stack_cptr !< Workaround for GFortran bug - integer :: ishift, jshift - integer :: tile - integer :: isize, jsize + integer :: tile, ishift, jshift, ipos0, jpos0 + integer :: size_clocal, size_cremote - tile = 1; if(PRESENT(tile_count)) tile = tile_count + tile = 1 + if(present(tile_count)) tile = tile_count call mpp_get_domain_shift(domain, ishift, jshift, position) - ! The alltoallw method requires that local and global be contiguous. - ! We presume that `local` is contiguous if it matches the data domain; - ! `global` is presumed to always be contiguous. - ! Ideally we would use the F2015 function IS_CONTIGUOUS() to validate - ! contiguity, but it is not yet suppored in many compilers. - - ! Also worth noting that many of the nD->3D conversion also assumes - ! contiguity, so there many be other issues here. - - isize = domain%x(tile)%domain_data%size + ishift - jsize = domain%y(tile)%domain_data%size + jshift - if ((size(local, 1) .eq. isize) .and. (size(local, 2) .eq. jsize) & - .and. use_alltoallw) then - call mpp_do_global_field_a2a(domain, local, global, tile, & - ishift, jshift, flags, default_data) + ipos0 = -domain%x(tile)%global%begin + 1 + jpos0 = -domain%y(tile)%global%begin + 1 + + if (present(xdim)) then + ix = xdim + else + ix = 1 + endif + + if (present(ydim)) then + iy = ydim else - call mpp_do_global_field(domain, local, global, tile, & - ishift, jshift, flags, default_data) + iy = 2 + endif + + n_per_gridpoint_local = size(local) / (size(local,ix) * size(local,iy)) + n_per_gridpoint_global = size(global) / (size(global,ix) * size(global,iy)) + size_clocal = (domain%x(1)%compute%size+ishift) * (domain%y(1)%compute%size+jshift) * n_per_gridpoint_local + size_cremote = (domain%x(1)%compute%max_size+ishift) * (domain%y(1)%compute%max_size+jshift) * & + n_per_gridpoint_local + + stackuse = size_clocal + size_cremote + if( stackuse.GT.mpp_domains_stack_size )then + write( text, '(i8)' )stackuse + call mpp_error( FATAL, & + 'MPP_DO_GLOBAL_FIELD user stack overflow: call mpp_domains_set_stack_size('//trim(text)// & + & ') from all PEs.' ) end if - end subroutine MPP_GLOBAL_FIELD_3D_ + mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, stackuse ) - subroutine MPP_GLOBAL_FIELD_4D_( domain, local, global, flags, position,tile_count, default_data ) - type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: local(:,:,:,:) - MPP_TYPE_, intent(out) :: global(:,:,:,:) - integer, intent(in), optional :: flags - integer, intent(in), optional :: position - integer, intent(in), optional :: tile_count - MPP_TYPE_, intent(in), optional :: default_data + stack_cptr = c_loc(mpp_domains_stack(1)) + call c_f_pointer(stack_cptr, clocal, [size_clocal]) - MPP_TYPE_ :: local3D (size( local,1),size( local,2),size( local,3)*size(local,4)) - MPP_TYPE_ :: global3D(size(global,1),size(global,2),size(global,3)*size(local,4)) - pointer( lptr, local3D ) - pointer( gptr, global3D ) - global = MPP_TYPE_INIT_VALUE - lptr = LOC(local) - gptr = LOC(global) - call mpp_global_field( domain, local3D, global3D, flags, position,tile_count, default_data ) - end subroutine MPP_GLOBAL_FIELD_4D_ - - subroutine MPP_GLOBAL_FIELD_5D_( domain, local, global, flags, position,tile_count, default_data ) - type(domain2D), intent(in) :: domain - MPP_TYPE_, intent(in) :: local(:,:,:,:,:) - MPP_TYPE_, intent(out) :: global(:,:,:,:,:) - integer, intent(in), optional :: flags - integer, intent(in), optional :: position - integer, intent(in), optional :: tile_count - MPP_TYPE_, intent(in), optional :: default_data + stack_cptr = c_loc(mpp_domains_stack(1+size_clocal)) + call c_f_pointer(stack_cptr, cremote, [size_cremote]) + + if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_GLOBAL_FIELD: must first call mpp_domains_init.' ) + + xonly = .FALSE. + yonly = .FALSE. + root_only = .FALSE. + if( PRESENT(flags) ) then + xonly = BTEST(flags,EAST) + yonly = BTEST(flags,SOUTH) + if( .NOT.xonly .AND. .NOT.yonly )call mpp_error( WARNING, & + 'MPP_GLOBAL_FIELD: you must have flags=XUPDATE, YUPDATE or XUPDATE+YUPDATE' ) + if(xonly .AND. yonly) then + xonly = .false.; yonly = .false. + endif + root_only = BTEST(flags, ROOT_GLOBAL) + if( (xonly .or. yonly) .AND. root_only ) then + call mpp_error( WARNING, 'MPP_GLOBAL_FIELD: flags = XUPDATE+GLOBAL_ROOT_ONLY or ' // & + 'flags = YUPDATE+GLOBAL_ROOT_ONLY is not supported, will ignore GLOBAL_ROOT_ONLY' ) + root_only = .FALSE. + endif + endif + + global_on_this_pe = .NOT. root_only .OR. domain%pe == domain%tile_root_pe + ipos = 0; jpos = 0 + if(global_on_this_pe ) then + if(n_per_gridpoint_local.ne.n_per_gridpoint_global) then + call mpp_error(FATAL, 'MPP_GLOBAL_FIELD: mismatch of global and local dimension sizes') + endif + if( size(global,ix).NE.(domain%x(tile)%global%size+ishift) .OR. & + size(global,iy).NE.(domain%y(tile)%global%size+jshift))then + if(xonly) then + if(size(global,ix).NE.(domain%x(tile)%global%size+ishift) .OR. & + size(global,iy).NE.(domain%y(tile)%compute%size+jshift)) & + call mpp_error( FATAL, & + & 'MPP_GLOBAL_FIELD: incoming arrays do not match domain for xonly global field.' ) + jpos = -domain%y(tile)%compute%begin + 1 + else if(yonly) then + if(size(global,ix).NE.(domain%x(tile)%compute%size+ishift) .OR. & + size(global,iy).NE.(domain%y(tile)%global%size+jshift)) & + call mpp_error( FATAL, & + & 'MPP_GLOBAL_FIELD: incoming arrays do not match domain for yonly global field.' ) + ipos = -domain%x(tile)%compute%begin + 1 + else + call mpp_error( FATAL, 'MPP_GLOBAL_FIELD: incoming arrays do not match domain.' ) + endif + endif + endif + + if( size(local,ix).EQ.(domain%x(tile)%compute%size+ishift) .AND. & + size(local,iy).EQ.(domain%y(tile)%compute%size+jshift) )then + !local is on compute domain + ioff = -domain%x(tile)%compute%begin + 1 + joff = -domain%y(tile)%compute%begin + 1 + else if( size(local,ix).EQ.(domain%x(tile)%memory%size+ishift) .AND. & + size(local,iy).EQ.(domain%y(tile)%memory%size+jshift) )then + !local is on data domain + ioff = -domain%x(tile)%domain_data%begin + 1 + joff = -domain%y(tile)%domain_data%begin + 1 + else + call mpp_error( FATAL, & + & 'MPP_GLOBAL_FIELD_: incoming field array must match either compute domain or memory domain.') + end if + + !ke = size(local,3) + ke = n_per_gridpoint_local + isc = domain%x(tile)%compute%begin; iec = domain%x(tile)%compute%end+ishift + jsc = domain%y(tile)%compute%begin; jec = domain%y(tile)%compute%end+jshift + + num_word_me = (iec-isc+1)*(jec-jsc+1)*n_per_gridpoint_local + +! make contiguous array from compute domain + m = 0 + if(global_on_this_pe) then + !z1l: initialize global = 0 to support mask domain + if(present(default_data)) then + call arr_init(global, default_data) + else + call arr_init(global, DEFAULT_VALUE_) + endif + + call arr2vec(local, clocal, ix, iy, ioff+isc, ioff+iec, joff+jsc, joff+jec) + + ! Fill local domain directly + call vec2arr(clocal, global, ix, iy, ipos0+ipos+isc, ipos0+ipos+iec, jpos0+jpos+jsc, jpos0+jpos+jec) + else + call arr2vec(local, clocal, ix, iy, ioff+isc, ioff+iec, joff+jsc, joff+jec) + endif + +! if there is more than one tile on this pe, then no decomposition for all tiles on this pe, so we can just return + if(size(domain%x(:))>1) then + !--- the following is needed to avoid deadlock. + if( tile == size(domain%x(:)) ) call mpp_sync_self( ) + return + end if + + root_pe = mpp_root_pe() + +!fill off-domains (note loops begin at an offset of 1) + if( xonly )then + nd = size(domain%x(1)%list(:)) + do n = 1,nd-1 + lpos = mod(domain%x(1)%pos+nd-n,nd) + rpos = mod(domain%x(1)%pos +n,nd) + from_pe = domain%x(1)%list(rpos)%pe + rpos = from_pe - root_pe ! for concurrent run, root_pe may not be 0. + if (from_pe == NULL_PE) then + num_words = 0 + else + num_words = (domain%list(rpos)%x(1)%compute%size+ishift) & + * (domain%list(rpos)%y(1)%compute%size+jshift) * ke + endif + ! Force use of scalar, integer ptr interface + call mpp_transmit( put_data=clocal(1), plen=num_word_me, to_pe=domain%x(1)%list(lpos)%pe, & + get_data=cremote(1), glen=num_words, from_pe=from_pe ) + m = 0 + if (from_pe /= NULL_PE) then + is = domain%list(rpos)%x(1)%compute%begin; ie = domain%list(rpos)%x(1)%compute%end+ishift + call vec2arr(cremote, global, ix, iy, ipos0+is, ipos0+ie, jpos0+jpos+jsc, jpos0+jpos+jec) + endif + call mpp_sync_self() !-ensure MPI_ISEND is done. + end do + else if( yonly )then + nd = size(domain%y(1)%list(:)) + do n = 1,nd-1 + lpos = mod(domain%y(1)%pos+nd-n,nd) + rpos = mod(domain%y(1)%pos +n,nd) + from_pe = domain%y(1)%list(rpos)%pe + rpos = from_pe - root_pe + if (from_pe == NULL_PE) then + num_words = 0 + else + num_words = (domain%list(rpos)%x(1)%compute%size+ishift) & + * (domain%list(rpos)%y(1)%compute%size+jshift) * ke + endif + ! Force use of scalar, integer pointer interface + call mpp_transmit( put_data=clocal(1), plen=num_word_me, to_pe=domain%y(1)%list(lpos)%pe, & + get_data=cremote(1), glen=num_words, from_pe=from_pe ) + m = 0 + if (from_pe /= NULL_PE) then + js = domain%list(rpos)%y(1)%compute%begin; je = domain%list(rpos)%y(1)%compute%end+jshift + call vec2arr(cremote, global, ix, iy, ipos0+ipos+isc, ipos0+ipos+iec, jpos0+js, jpos0+je) + endif + call mpp_sync_self() !-ensure MPI_ISEND is done. + end do + else + tile_id = domain%tile_id(1) + nd = size(domain%list(:)) + if(root_only) then + if(domain%pe .NE. domain%tile_root_pe) then + call mpp_send( clocal(1), plen=num_word_me, to_pe=domain%tile_root_pe, tag=COMM_TAG_1 ) + else + do n = 1,nd-1 + rpos = mod(domain%pos+n,nd) + if( domain%list(rpos)%tile_id(1) .NE. tile_id ) cycle + num_words = (domain%list(rpos)%x(1)%compute%size+ishift) * & + & (domain%list(rpos)%y(1)%compute%size+jshift) * ke + call mpp_recv(cremote(1), glen=num_words, from_pe=domain%list(rpos)%pe, tag=COMM_TAG_1 ) + m = 0 + is = domain%list(rpos)%x(1)%compute%begin; ie = domain%list(rpos)%x(1)%compute%end+ishift + js = domain%list(rpos)%y(1)%compute%begin; je = domain%list(rpos)%y(1)%compute%end+jshift + + call vec2arr(cremote, global, ix, iy, ipos0+is, ipos0+ie, jpos0+js, jpos0+je) + end do + endif + else + do n = 1,nd-1 + lpos = mod(domain%pos+nd-n,nd) + if( domain%list(lpos)%tile_id(1).NE. tile_id ) cycle ! global field only within tile + call mpp_send( clocal(1), plen=num_word_me, to_pe=domain%list(lpos)%pe, tag=COMM_TAG_2 ) + end do + do n = 1,nd-1 + rpos = mod(domain%pos+n,nd) + if( domain%list(rpos)%tile_id(1) .NE. tile_id ) cycle ! global field only within tile + num_words = (domain%list(rpos)%x(1)%compute%size+ishift) * & + & (domain%list(rpos)%y(1)%compute%size+jshift) * ke + call mpp_recv( cremote(1), glen=num_words, from_pe=domain%list(rpos)%pe, tag=COMM_TAG_2 ) + m = 0 + is = domain%list(rpos)%x(1)%compute%begin; ie = domain%list(rpos)%x(1)%compute%end+ishift + js = domain%list(rpos)%y(1)%compute%begin; je = domain%list(rpos)%y(1)%compute%end+jshift + + call vec2arr(cremote, global, ix, iy, ipos0+is, ipos0+ie, jpos0+js, jpos0+je) + end do + endif + end if - MPP_TYPE_ :: local3D (size( local,1),size( local,2),size( local,3)*size( local,4)*size(local,5)) - MPP_TYPE_ :: global3D(size(global,1),size(global,2),size(global,3)*size(global,4)*size(local,5)) - pointer( lptr, local3D ) - pointer( gptr, global3D ) - global = MPP_TYPE_INIT_VALUE - lptr = LOC(local) - gptr = LOC(global) - call mpp_global_field( domain, local3D, global3D, flags, position,tile_count, default_data ) - end subroutine MPP_GLOBAL_FIELD_5D_ + call mpp_sync_self + end subroutine MPP_GLOBAL_FIELD_ !> @} diff --git a/mpp/include/mpp_pack.fh b/mpp/include/mpp_pack.fh new file mode 100644 index 0000000000..3c8c5d0c06 --- /dev/null +++ b/mpp/include/mpp_pack.fh @@ -0,0 +1,197 @@ +!*********************************************************************** +!* Apache License 2.0 +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* Licensed under the Apache License, Version 2.0 (the "License"); +!* you may not use this file except in compliance with the License. +!* You may obtain a copy of the License at +!* +!* http://www.apache.org/licenses/LICENSE-2.0 +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied; +!* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A +!* PARTICULAR PURPOSE. See the License for the specific language +!* governing permissions and limitations under the License. +!*********************************************************************** + + !> @brief Pack a multi-dimensional, domain-decomposed array into a contiguous 1D array. This is + !! typically used to prepare a contiguous array which will be transmitted via MPI. + subroutine ARR2VEC_ (arr, vec, xdim, ydim, is, ie, js, je) + MPP_TYPE_, intent(in) :: arr(..) !< The array to be packed + MPP_TYPE_, intent(out) :: vec(:) !< The vector to copy the data into + integer, intent(in) :: xdim, ydim !< Indices of the domain-decomposed dimensions. In typical Fortran-based + !! code, xdim=1 and ydim=2. + integer, intent(in) :: is, ie, js, je !< Starting and ending indices of the x and y dimensions, expressed + !! in terms of the 1-based indices seen within ARR2VEC_. These indices + !! may be different from the indices used in the calling code! If `arr` + !! is defined over the data domain, e.g. dimension(isd:ied,jsd:jed,...), + !! and you wish to pack only the compute domain, the following values + !! should be passed: + !! is = isc - isd + 1 + !! ie = iec - isd + 1 + !! js = jsc - jsd + 1 + !! je = jec - jsd + 1 + integer, allocatable, dimension(:) :: lb, ub !< These are 1 and shape(arr) respectively for all dimensions + !! except the domain-decomposed dimensions, for which they are + !! set according to the is,ie,js,je options. + integer :: n, m + integer :: i1, i2, i3, i4, i5 + + n = rank(arr) + allocate (lb(n), ub(n)) + + lb = 1 + ub = shape(arr) + + lb(xdim) = is + lb(ydim) = js + + ub(xdim) = ie + ub(ydim) = je + + m = 0 + select rank(arr) + rank (2) + do i2=lb(2),ub(2) + do i1=lb(1),ub(1) + m = m + 1 + vec(m) = arr(i1, i2) + enddo + enddo + rank (3) + do i3=lb(3),ub(3) + do i2=lb(2),ub(2) + do i1=lb(1),ub(1) + m = m + 1 + vec(m) = arr(i1, i2, i3) + enddo + enddo + enddo + rank (4) + do i4=lb(4),ub(4) + do i3=lb(3),ub(3) + do i2=lb(2),ub(2) + do i1=lb(1),ub(1) + m = m + 1 + vec(m) = arr(i1, i2, i3, i4) + enddo + enddo + enddo + enddo + rank (5) + do i5=lb(5),ub(5) + do i4=lb(4),ub(4) + do i3=lb(3),ub(3) + do i2=lb(2),ub(2) + do i1=lb(1),ub(1) + m = m + 1 + vec(m) = arr(i1, i2, i3, i4, i5) + enddo + enddo + enddo + enddo + enddo + end select + end subroutine ARR2VEC_ + + !> @brief Unpack a contiguous 1D array into a multi-dimensional array. This is typically used to transform + !! data obtained from an MPI call into the format that is expected by the calling code. + subroutine VEC2ARR_ (vec, arr, xdim, ydim, is, ie, js, je) + MPP_TYPE_, intent(in) :: vec(:) !< The 1D array to be unpacked + MPP_TYPE_, intent(out) :: arr(..) !< The multi-dimensional array to copy the data into + integer, intent(in) :: xdim, ydim !< Indices of the domain-decomposed dimensions. In typical Fortran-based + !! code, xdim=1 and ydim=2. + integer, intent(in) :: is, ie, js, je !< Starting and ending indices of the x and y dimensions, expressed + !! in terms of the 1-based indices seen within VEC2ARR_. These indices + !! may be different from the indices used in the calling code! If `arr` + !! is defined over the data domain, e.g. dimension(isd:ied,jsd:jed,...), + !! and you wish to unpack only the compute domain, the following values + !! should be passed: + !! is = isc - isd + 1 + !! ie = iec - isd + 1 + !! js = jsc - jsd + 1 + !! je = jec - jsd + 1 + integer, allocatable, dimension(:) :: lb, ub !< These are 1 and shape(arr) respectively for all dimensions + !! except the domain-decomposed dimensions, for which they are + !! set according to the is,ie,js,je options. + integer :: n, m + integer :: i1, i2, i3, i4, i5 + + n = rank(arr) + allocate (lb(n), ub(n)) + + lb = 1 + ub = shape(arr) + + lb(xdim) = is + lb(ydim) = js + + ub(xdim) = ie + ub(ydim) = je + + m = 0 + select rank(arr) + rank (2) + do i2=lb(2),ub(2) + do i1=lb(1),ub(1) + m = m + 1 + arr(i1, i2) = vec(m) + enddo + enddo + rank (3) + do i3=lb(3),ub(3) + do i2=lb(2),ub(2) + do i1=lb(1),ub(1) + m = m + 1 + arr(i1, i2, i3) = vec(m) + enddo + enddo + enddo + rank (4) + do i4=lb(4),ub(4) + do i3=lb(3),ub(3) + do i2=lb(2),ub(2) + do i1=lb(1),ub(1) + m = m + 1 + arr(i1, i2, i3, i4) = vec(m) + enddo + enddo + enddo + enddo + rank (5) + do i5=lb(5),ub(5) + do i4=lb(4),ub(4) + do i3=lb(3),ub(3) + do i2=lb(2),ub(2) + do i1=lb(1),ub(1) + m = m + 1 + arr(i1, i2, i3, i4, i5) = vec(m) + enddo + enddo + enddo + enddo + enddo + end select + end subroutine VEC2ARR_ + + !> @brief Initialize an assumed-rank array to `val`. This is used when initializing an assumed-rank array + !! outside of a `select rank` block. + subroutine ARR_INIT_ (arr, val) + MPP_TYPE_, dimension(..), intent(out) :: arr !< The array to be initialized + MPP_TYPE_, intent(in) :: val !< The value to initialize to + + select rank (arr) + rank(1) + arr = val + rank(2) + arr = val + rank(3) + arr = val + rank(4) + arr = val + rank(5) + arr = val + end select + end subroutine ARR_INIT_ diff --git a/mpp/include/mpp_pack.inc b/mpp/include/mpp_pack.inc new file mode 100644 index 0000000000..1e8b9164d6 --- /dev/null +++ b/mpp/include/mpp_pack.inc @@ -0,0 +1,83 @@ +#undef MPP_TYPE_ +#define MPP_TYPE_ real(r8_kind) +#undef ARR2VEC_ +#define ARR2VEC_ arr2vec_r8 +#undef VEC2ARR_ +#define VEC2ARR_ vec2arr_r8 +#undef ARR_INIT_ +#define ARR_INIT_ arr_init_r8 +#include + +#ifdef OVERLOAD_C8 +#undef MPP_TYPE_ +#define MPP_TYPE_ complex(c8_kind) +#undef ARR2VEC_ +#define ARR2VEC_ arr2vec_c8 +#undef VEC2ARR_ +#define VEC2ARR_ vec2arr_c8 +#undef ARR_INIT_ +#define ARR_INIT_ arr_init_c8 +#include +#endif + +#undef MPP_TYPE_ +#define MPP_TYPE_ integer(i8_kind) +#undef ARR2VEC_ +#define ARR2VEC_ arr2vec_i8 +#undef VEC2ARR_ +#define VEC2ARR_ vec2arr_i8 +#undef ARR_INIT_ +#define ARR_INIT_ arr_init_i8 +#include + +#undef MPP_TYPE_ +#define MPP_TYPE_ logical(l8_kind) +#undef ARR2VEC_ +#define ARR2VEC_ arr2vec_l8 +#undef VEC2ARR_ +#define VEC2ARR_ vec2arr_l8 +#undef ARR_INIT_ +#define ARR_INIT_ arr_init_l8 +#include + +#undef MPP_TYPE_ +#define MPP_TYPE_ real(r4_kind) +#undef ARR2VEC_ +#define ARR2VEC_ arr2vec_r4 +#undef VEC2ARR_ +#define VEC2ARR_ vec2arr_r4 +#undef ARR_INIT_ +#define ARR_INIT_ arr_init_r4 +#include + +#ifdef OVERLOAD_C4 +#undef MPP_TYPE_ +#define MPP_TYPE_ complex(c4_kind) +#undef ARR2VEC_ +#define ARR2VEC_ arr2vec_c4 +#undef VEC2ARR_ +#define VEC2ARR_ vec2arr_c4 +#undef ARR_INIT_ +#define ARR_INIT_ arr_init_c4 +#include +#endif + +#undef MPP_TYPE_ +#define MPP_TYPE_ integer(i4_kind) +#undef ARR2VEC_ +#define ARR2VEC_ arr2vec_i4 +#undef VEC2ARR_ +#define VEC2ARR_ vec2arr_i4 +#undef ARR_INIT_ +#define ARR_INIT_ arr_init_i4 +#include + +#undef MPP_TYPE_ +#define MPP_TYPE_ logical(l4_kind) +#undef ARR2VEC_ +#define ARR2VEC_ arr2vec_l4 +#undef VEC2ARR_ +#define VEC2ARR_ vec2arr_l4 +#undef ARR_INIT_ +#define ARR_INIT_ arr_init_l4 +#include diff --git a/mpp/mpp_domains.F90 b/mpp/mpp_domains.F90 index 722430f1b4..da9a1ff848 100644 --- a/mpp/mpp_domains.F90 +++ b/mpp/mpp_domains.F90 @@ -96,6 +96,7 @@ module mpp_domains_mod use gfdl_nompi_f08 #endif + use iso_c_binding, only : c_f_pointer, c_loc, c_ptr use mpp_parameter_mod, only : MPP_DEBUG, MPP_VERBOSE, MPP_DOMAIN_TIME use mpp_parameter_mod, only : GLOBAL_DATA_DOMAIN, CYCLIC_GLOBAL_DOMAIN, GLOBAL,CYCLIC use mpp_parameter_mod, only : AGRID, BGRID_SW, BGRID_NE, CGRID_NE, CGRID_SW, DGRID_NE, DGRID_SW @@ -1784,42 +1785,18 @@ module mpp_domains_mod !! @endcode !> @ingroup mpp_domains_mod interface mpp_global_field - module procedure mpp_global_field2D_r8_2d - module procedure mpp_global_field2D_r8_3d - module procedure mpp_global_field2D_r8_4d - module procedure mpp_global_field2D_r8_5d + module procedure mpp_global_field_r8 #ifdef OVERLOAD_C8 - module procedure mpp_global_field2D_c8_2d - module procedure mpp_global_field2D_c8_3d - module procedure mpp_global_field2D_c8_4d - module procedure mpp_global_field2D_c8_5d + module procedure mpp_global_field_c8 #endif - module procedure mpp_global_field2D_i8_2d - module procedure mpp_global_field2D_i8_3d - module procedure mpp_global_field2D_i8_4d - module procedure mpp_global_field2D_i8_5d - module procedure mpp_global_field2D_l8_2d - module procedure mpp_global_field2D_l8_3d - module procedure mpp_global_field2D_l8_4d - module procedure mpp_global_field2D_l8_5d - module procedure mpp_global_field2D_r4_2d - module procedure mpp_global_field2D_r4_3d - module procedure mpp_global_field2D_r4_4d - module procedure mpp_global_field2D_r4_5d + module procedure mpp_global_field_i8 + module procedure mpp_global_field_l8 + module procedure mpp_global_field_r4 #ifdef OVERLOAD_C4 - module procedure mpp_global_field2D_c4_2d - module procedure mpp_global_field2D_c4_3d - module procedure mpp_global_field2D_c4_4d - module procedure mpp_global_field2D_c4_5d + module procedure mpp_global_field_c4 #endif - module procedure mpp_global_field2D_i4_2d - module procedure mpp_global_field2D_i4_3d - module procedure mpp_global_field2D_i4_4d - module procedure mpp_global_field2D_i4_5d - module procedure mpp_global_field2D_l4_2d - module procedure mpp_global_field2D_l4_3d - module procedure mpp_global_field2D_l4_4d - module procedure mpp_global_field2D_l4_5d + module procedure mpp_global_field_i4 + module procedure mpp_global_field_l4 end interface !> @ingroup mpp_domains_mod @@ -1862,38 +1839,6 @@ module mpp_domains_mod module procedure mpp_global_field2D_l4_5d_ad end interface -!> Private helper interface used by @ref mpp_global_field -!> @ingroup mpp_domains_mod - interface mpp_do_global_field - module procedure mpp_do_global_field2D_r8_3d -#ifdef OVERLOAD_C8 - module procedure mpp_do_global_field2D_c8_3d -#endif - module procedure mpp_do_global_field2D_i8_3d - module procedure mpp_do_global_field2D_l8_3d - module procedure mpp_do_global_field2D_r4_3d -#ifdef OVERLOAD_C4 - module procedure mpp_do_global_field2D_c4_3d -#endif - module procedure mpp_do_global_field2D_i4_3d - module procedure mpp_do_global_field2D_l4_3d - end interface - - interface mpp_do_global_field_a2a - module procedure mpp_do_global_field2D_a2a_r8_3d -#ifdef OVERLOAD_C8 - module procedure mpp_do_global_field2D_a2a_c8_3d -#endif - module procedure mpp_do_global_field2D_a2a_i8_3d - module procedure mpp_do_global_field2D_a2a_l8_3d - module procedure mpp_do_global_field2D_a2a_r4_3d -#ifdef OVERLOAD_C4 - module procedure mpp_do_global_field2D_a2a_c4_3d -#endif - module procedure mpp_do_global_field2D_a2a_i4_3d - module procedure mpp_do_global_field2D_a2a_l4_3d - end interface - !> Same functionality as @ref mpp_global_field but for unstructured domains !> @ingroup mpp_domains_mod interface mpp_global_field_ug @@ -2349,6 +2294,57 @@ module mpp_domains_mod module procedure nullify_domain2d_list end interface + !> Private interface to pack an array into a vector + !> @ingroup mpp_domains_mod + interface arr2vec + module procedure arr2vec_r8 +#ifdef OVERLOAD_C8 + module procedure arr2vec_c8 +#endif + module procedure arr2vec_i8 + module procedure arr2vec_l8 + module procedure arr2vec_r4 +#ifdef OVERLOAD_C4 + module procedure arr2vec_c4 +#endif + module procedure arr2vec_i4 + module procedure arr2vec_l4 + end interface + + !> Private interface to unpack a vector into an array + !> @ingroup mpp_domains_mod + interface vec2arr + module procedure vec2arr_r8 +#ifdef OVERLOAD_C8 + module procedure vec2arr_c8 +#endif + module procedure vec2arr_i8 + module procedure vec2arr_l8 + module procedure vec2arr_r4 +#ifdef OVERLOAD_C4 + module procedure vec2arr_c4 +#endif + module procedure vec2arr_i4 + module procedure vec2arr_l4 + end interface + + !> Private interface to initialize an assumed-rank array + !> @ingroup mpp_domains_mod + interface arr_init + module procedure arr_init_r8 +#ifdef OVERLOAD_C8 + module procedure arr_init_c8 +#endif + module procedure arr_init_i8 + module procedure arr_init_l8 + module procedure arr_init_r4 +#ifdef OVERLOAD_C4 + module procedure arr_init_c4 +#endif + module procedure arr_init_i4 + module procedure arr_init_l4 + end interface + ! Include variable "version" to be written to log file. #include public version @@ -2363,5 +2359,6 @@ module mpp_domains_mod #include #include #include +#include end module mpp_domains_mod diff --git a/test_fms/mpp/test_mpp_global_field.F90 b/test_fms/mpp/test_mpp_global_field.F90 index 514f750c05..ee3e1293ea 100644 --- a/test_fms/mpp/test_mpp_global_field.F90 +++ b/test_fms/mpp/test_mpp_global_field.F90 @@ -25,7 +25,8 @@ program test_mpp_global_field use mpp_domains_mod, only: mpp_define_layout, mpp_define_domains use mpp_domains_mod, only: mpp_get_compute_domain, mpp_get_data_domain, mpp_domains_set_stack_size use mpp_domains_mod, only: mpp_global_field - use fms_test_mod, only: permutable_indices_2d, permutable_indices_3d, factorial, arr_init, arr_compare + use fms_test_mod, only: permutable_indices_2d, permutable_indices_3d, factorial, arr_init, arr_compare, & + permute_arr implicit none @@ -90,6 +91,7 @@ subroutine run_tests_2d(test_params, p) type(permutable_indices_2d) :: compute, data, global, global_with_halo, global_x, global_y integer, allocatable :: pelist(:) FMS_TEST_TYPE_ (FMS_TEST_KIND_), allocatable :: global0(:,:), local(:,:), global1(:,:) + integer :: indx(2), ix, iy !> set up domain call mpp_define_layout([1,nx,1,ny], npes, layout) @@ -123,6 +125,11 @@ subroutine run_tests_2d(test_params, p) call global_x%permute(p) call global_y%permute(p) + indx(1:2) = [1, 2] + call permute_arr(indx, p) + ix = findloc(indx, 1, dim=1) + iy = findloc(indx, 2, dim=1) + !> assign global allocate(global0(global_with_halo%lb(1):global_with_halo%ub(1), global_with_halo%lb(2):global_with_halo%ub(2))) global0 = zero @@ -136,7 +143,7 @@ subroutine run_tests_2d(test_params, p) !> test the data on data domain global1 = zero - call mpp_global_field(domain, local, global1, position=test_params%position) + call mpp_global_field(domain, local, global1, position=test_params%position, xdim=ix, ydim=iy) call arr_compare(global0(global%lb(1):global%ub(1), global%lb(2):global%ub(2)), global1, & 'mpp_global_field on data domain with ' // trim(test_params%name)) @@ -159,19 +166,21 @@ subroutine run_tests_2d(test_params, p) !> xupdate global1 = zero - call mpp_global_field(domain, local, global1, flags=XUPDATE, position=test_params%position) + call mpp_global_field(domain, local, global1, flags=XUPDATE, position=test_params%position, & + xdim=ix, ydim=iy) call arr_compare(global0(global_x%lb(1):global_x%ub(1),global_x%lb(2):global_x%ub(2)), & global1(global_x%lb(1):global_x%ub(1),global_x%lb(2):global_x%ub(2)), & 'mpp_global_field xupdate only on data domain with ' // trim(test_params%name)) !> yupdate global1 = zero - call mpp_global_field(domain, local, global1, flags=YUPDATE, position=test_params%position) + call mpp_global_field(domain, local, global1, flags=YUPDATE, position=test_params%position, & + xdim=ix, ydim=iy) call arr_compare(global0(global_y%lb(1):global_y%ub(1),global_y%lb(2):global_y%ub(2)), & global1(global_y%lb(1):global_y%ub(1),global_y%lb(2):global_y%ub(2)), & 'mpp_global_field yupdate only on data domain with ' // trim(test_params%name)) - call mpp_global_field(domain, local, global1, position=test_params%position) + call mpp_global_field(domain, local, global1, position=test_params%position, xdim=ix, ydim=iy) call arr_compare(global0(global%lb(1):global%ub(1), global%lb(2):global%ub(2)), global1, & 'mpp_global_field on data domain with ' // trim(test_params%name)) @@ -182,20 +191,22 @@ subroutine run_tests_2d(test_params, p) local(:,:) = global0(compute%lb(1):compute%ub(1), compute%lb(2):compute%ub(2)) global1 = zero - call mpp_global_field(domain, local, global1, position=test_params%position) + call mpp_global_field(domain, local, global1, position=test_params%position, xdim=ix, ydim=iy) call arr_compare(global0(global%lb(1):global%ub(1), global%lb(2):global%ub(2)), global1, & 'mpp_global_field on compute domain with ' // trim(test_params%name)) !> xupdate global1 = zero - call mpp_global_field(domain, local, global1, flags=XUPDATE, position=test_params%position) + call mpp_global_field(domain, local, global1, flags=XUPDATE, position=test_params%position, & + xdim=ix, ydim=iy) call arr_compare(global0(global_x%lb(1):global_x%ub(1),global_x%lb(2):global_x%ub(2)), & global1(global_x%lb(1):global_x%ub(1),global_x%lb(2):global_x%ub(2)), & 'mpp_global_field xupdate only on compute domain with ' // trim(test_params%name)) !> yupdate global1 = zero - call mpp_global_field(domain, local, global1, flags=YUPDATE, position=test_params%position) + call mpp_global_field(domain, local, global1, flags=YUPDATE, position=test_params%position, & + xdim=ix, ydim=iy) call arr_compare(global0(global_y%lb(1):global_y%ub(1),global_y%lb(2):global_y%ub(2)), & global1(global_y%lb(1):global_y%ub(1),global_y%lb(2):global_y%ub(2)), & 'mpp_global_field yupdate only on compute domain with ' // trim(test_params%name)) @@ -210,6 +221,7 @@ subroutine run_tests_3d(test_params, p) type(permutable_indices_3d) :: compute, data, global, global_with_halo, global_x, global_y integer, allocatable :: pelist(:) FMS_TEST_TYPE_ (FMS_TEST_KIND_), allocatable :: global0(:,:,:), local(:,:,:), global1(:,:,:) + integer :: indx(3), ix, iy !> set up domain call mpp_define_layout([1,nx,1,ny], npes, layout) @@ -248,6 +260,11 @@ subroutine run_tests_3d(test_params, p) call global_x%permute(p) call global_y%permute(p) + indx(1:3) = [1, 2, 3] + call permute_arr(indx, p) + ix = findloc(indx, 1, dim=1) + iy = findloc(indx, 2, dim=1) + !> assign global0 allocate(global0(global_with_halo%lb(1):global_with_halo%ub(1), global_with_halo%lb(2):global_with_halo%ub(2), & global_with_halo%lb(3):global_with_halo%ub(3))) @@ -263,7 +280,7 @@ subroutine run_tests_3d(test_params, p) !> test the data on data domain global1 = zero - call mpp_global_field(domain, local, global1, position=test_params%position) + call mpp_global_field(domain, local, global1, position=test_params%position, xdim=ix, ydim=iy) call arr_compare(global0(global%lb(1):global%ub(1), global%lb(2):global%ub(2), global%lb(3):global%ub(3)), & global1, 'mpp_global_field on data domain with ' // trim(test_params%name)) @@ -286,7 +303,8 @@ subroutine run_tests_3d(test_params, p) !> xupdate global1 = zero - call mpp_global_field(domain, local, global1, flags=XUPDATE, position=test_params%position) + call mpp_global_field(domain, local, global1, flags=XUPDATE, position=test_params%position, & + xdim=ix, ydim=iy) call arr_compare(global0(global_x%lb(1):global_x%ub(1), global_x%lb(2):global_x%ub(2), & global_x%lb(3):global_x%ub(3)), global1(global_x%lb(1):global_x%ub(1), & global_x%lb(2):global_x%ub(2), global_x%lb(3):global_x%ub(3)), & @@ -294,13 +312,14 @@ subroutine run_tests_3d(test_params, p) !> yupdate global1 = zero - call mpp_global_field(domain, local, global1, flags=YUPDATE, position=test_params%position) + call mpp_global_field(domain, local, global1, flags=YUPDATE, position=test_params%position, & + xdim=ix, ydim=iy) call arr_compare(global0(global_y%lb(1):global_y%ub(1), global_y%lb(2):global_y%ub(2), & global_y%lb(3):global_y%ub(3)), global1(global_y%lb(1):global_y%ub(1), & global_y%lb(2):global_y%ub(2), global_y%lb(3):global_y%ub(3)), & 'mpp_global_field yupdate only on data domain with ' // trim(test_params%name)) - call mpp_global_field(domain, local, global1, position=test_params%position) + call mpp_global_field(domain, local, global1, position=test_params%position, xdim=ix, ydim=iy) call arr_compare(global0(global%lb(1):global%ub(1), global%lb(2):global%ub(2), global%lb(3):global%ub(3)), & global1, 'mpp_global_field on data domain with ' // trim(test_params%name)) @@ -311,13 +330,14 @@ subroutine run_tests_3d(test_params, p) local(:,:,:) = global0(compute%lb(1):compute%ub(1), compute%lb(2):compute%ub(2), compute%lb(3):compute%ub(3)) global1 = zero - call mpp_global_field(domain, local, global1, position=test_params%position) + call mpp_global_field(domain, local, global1, position=test_params%position, xdim=ix, ydim=iy) call arr_compare(global0(global%lb(1):global%ub(1), global%lb(2):global%ub(2), global%lb(3):global%ub(3)), & global1, 'mpp_global_field on compute domain with ' // trim(test_params%name)) !> xupdate global1 = zero - call mpp_global_field(domain, local, global1, flags=XUPDATE, position=test_params%position) + call mpp_global_field(domain, local, global1, flags=XUPDATE, position=test_params%position, & + xdim=ix, ydim=iy) call arr_compare(global0(global_x%lb(1):global_x%ub(1), global_x%lb(2):global_x%ub(2), & global_x%lb(3):global_x%ub(3)), global1(global_x%lb(1):global_x%ub(1), & global_x%lb(2):global_x%ub(2), global_x%lb(3):global_x%ub(3)), & @@ -325,7 +345,8 @@ subroutine run_tests_3d(test_params, p) !> yupdate global1 = zero - call mpp_global_field(domain, local, global1, flags=YUPDATE, position=test_params%position) + call mpp_global_field(domain, local, global1, flags=YUPDATE, position=test_params%position, & + xdim=ix, ydim=iy) call arr_compare(global0(global_y%lb(1):global_y%ub(1), global_y%lb(2):global_y%ub(2), & global_y%lb(3):global_y%ub(3)), global1(global_y%lb(1):global_y%ub(1), & global_y%lb(2):global_y%ub(2), global_y%lb(3):global_y%ub(3)), &