From 67ba35cc4b7512b27d2b3f2435f2ef43aefc9f05 Mon Sep 17 00:00:00 2001 From: Jian Sun Date: Thu, 11 Jun 2026 14:03:02 -0600 Subject: [PATCH 01/12] reduce memory usage in CTSM init --- src/biogeophys/UrbanParamsType.F90 | 5 +- src/cpl/share_esmf/clm_shmem_mod.F90 | 187 ++++++++++++++++++ .../share_esmf/lnd_set_decomp_and_domain.F90 | 55 +++--- src/main/clm_instMod.F90 | 5 +- src/main/initVerticalMod.F90 | 5 +- src/main/organicFileMod.F90 | 2 + src/main/surfrdMod.F90 | 6 + 7 files changed, 238 insertions(+), 27 deletions(-) create mode 100644 src/cpl/share_esmf/clm_shmem_mod.F90 diff --git a/src/biogeophys/UrbanParamsType.F90 b/src/biogeophys/UrbanParamsType.F90 index c6443897fe..9fd87f82dc 100644 --- a/src/biogeophys/UrbanParamsType.F90 +++ b/src/biogeophys/UrbanParamsType.F90 @@ -425,7 +425,10 @@ subroutine UrbanInput(begg, endg, mode) if (masterproc) write(iulog,*)'PCT_URBAN is not multi-density, nlevurb set to 0' end if - if ( nlevurb == 0 ) return + if ( nlevurb == 0 ) then + call ncd_pio_closefile(ncid) + return + end if ! Allocate dynamic memory allocate(urbinp%canyon_hwr(begg:endg, numurbl), & diff --git a/src/cpl/share_esmf/clm_shmem_mod.F90 b/src/cpl/share_esmf/clm_shmem_mod.F90 new file mode 100644 index 0000000000..0a40da5d2d --- /dev/null +++ b/src/cpl/share_esmf/clm_shmem_mod.F90 @@ -0,0 +1,187 @@ +module clm_shmem_mod + !----------------------------------------------------------------------------- + ! Per-node MPI-3 shared-memory helper for large arrays that would otherwise be + ! replicated identically on every MPI rank. One physical copy is allocated per + ! shared-memory node and mapped into every rank on that node, freeing + ! (ranks_per_node - 1) copies per node. + ! + ! Ported from CAM's cam_shmem_mod (src/utils/cam_shmem_mod.F90) and specialized + ! for the CTSM decomposition setup: it provides a default-integer rank-1 + ! allocator (the CAM module only has real r4/r8 2d-5d wrappers) plus a + ! node-leader sum-reduce that builds a globally-summed array in a node-shared + ! buffer without every rank holding its own global-sized copy. + ! + ! Usage (collective over the land communicator mpicom): + ! call clm_shmem_alloc_i4_1d(ptr, win, n) ! all ranks + ! if (clm_shmem_is_leader()) ptr(:) = 0 ! leader owns the storage + ! call clm_shmem_fence(win) ! publish the zeros + ! + ! call clm_shmem_leader_allreduce_sum_i4(ptr,win,n) ! fence; sum across nodes; fence + ! + ! call clm_shmem_free(ptr, win) ! collective over the node comm + ! + ! CLM is always built against MPI (it has no SPMD cpp guard), and mpi-serial + ! supplies the MPI-3 shared-memory entry points for single-task builds, so the + ! shared-memory path is compiled unconditionally. The F90 'mpi' module (not + ! mpif.h) is used because the TYPE(C_PTR) overloads of MPI_WIN_ALLOCATE_SHARED / + ! MPI_WIN_SHARED_QUERY are only guaranteed there (MPI-3.0). + !----------------------------------------------------------------------------- + + use mpi + use, intrinsic :: iso_c_binding, only : c_ptr, c_f_pointer + use spmdMod , only : mpicom + use abortutils, only : endrun + + implicit none + private + + public :: clm_shmem_alloc_i4_1d ! allocate a node-shared default-integer rank-1 array + public :: clm_shmem_leader_allreduce_sum_i4 ! sum a node-shared array across nodes, in place + public :: clm_shmem_free ! free a node-shared array (MPI_Win_free) + public :: clm_shmem_fence ! synchronize a window (publish writes) + public :: clm_shmem_is_leader ! .true. on the leader (rank 0) of this node + public :: clm_shmem_leader_comm ! communicator containing only node leaders + public :: clm_shmem_npes_per_node ! number of ranks sharing this node + + interface clm_shmem_free + module procedure clm_shmem_free_i4_1d + end interface clm_shmem_free + + logical, save :: initialized = .false. + integer, save :: node_comm = MPI_COMM_NULL ! ranks sharing a node + integer, save :: leader_comm = MPI_COMM_NULL ! one rank per node (the leaders) + integer, save :: node_rank = 0 + integer, save :: node_size = 1 + logical, save :: is_leader = .true. + +contains + + !============================================================================= + subroutine init_comms() + ! Lazily build the node-local and node-leader communicators. Collective over + ! mpicom; safe to call from every shared-memory request. + integer :: ierr, color + + if (initialized) return + + call mpi_comm_split_type(mpicom, MPI_COMM_TYPE_SHARED, 0, MPI_INFO_NULL, & + node_comm, ierr) + call mpi_comm_rank(node_comm, node_rank, ierr) + call mpi_comm_size(node_comm, node_size, ierr) + is_leader = (node_rank == 0) + + ! Communicator of node leaders only. masterproc (global rank 0) is a leader. + if (is_leader) then + color = 0 + else + color = MPI_UNDEFINED + end if + call mpi_comm_split(mpicom, color, 0, leader_comm, ierr) + + initialized = .true. + end subroutine init_comms + + !============================================================================= + subroutine clm_shmem_alloc_i4_1d(ptr, win, n) + ! Allocate a node-shared default-integer array of length n. Only the node + ! leader requests storage; peers map the leader's contiguous segment. + integer, pointer, intent(out) :: ptr(:) + integer, intent(out) :: win + integer, intent(in) :: n + + integer(kind=MPI_ADDRESS_KIND) :: winsize, qsize + integer :: ierr, disp_unit, qdisp + integer :: itmp + type(c_ptr) :: baseptr + + call init_comms() + + disp_unit = storage_size(itmp) / 8 ! bytes per default integer (robust to -i8) + if (is_leader) then + winsize = int(n, MPI_ADDRESS_KIND) * int(disp_unit, MPI_ADDRESS_KIND) + else + winsize = 0_MPI_ADDRESS_KIND + end if + + call mpi_win_allocate_shared(winsize, disp_unit, MPI_INFO_NULL, node_comm, & + baseptr, win, ierr) + if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_allocate_shared failed') + + ! Non-leaders learn the address of the leader's (rank 0) contiguous segment. + if (.not. is_leader) then + call mpi_win_shared_query(win, 0, qsize, qdisp, baseptr, ierr) + if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_shared_query failed') + end if + + call c_f_pointer(baseptr, ptr, [n]) + end subroutine clm_shmem_alloc_i4_1d + + !============================================================================= + subroutine clm_shmem_leader_allreduce_sum_i4(ptr, win, n) + ! Build a globally-summed array in the node-shared buffer ptr(1:n): fence so + ! every rank's stores are visible, then the node leaders sum their per-node + ! partials across nodes (over leader_comm) into the shared buffer, then fence + ! to publish the result to all ranks on the node. Collective over node_comm; + ! every rank on the node must call it. + integer, pointer, intent(inout) :: ptr(:) + integer, intent(in) :: win + integer, intent(in) :: n + + integer, allocatable :: tmp(:) + integer :: ierr + + call clm_shmem_fence(win) ! all node stores complete and visible to leader + if (is_leader) then + allocate(tmp(n)) + call mpi_allreduce(ptr, tmp, n, MPI_INTEGER, MPI_SUM, leader_comm, ierr) + if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Allreduce failed') + ptr(1:n) = tmp(1:n) + deallocate(tmp) + end if + call clm_shmem_fence(win) ! publish global result to all node ranks + end subroutine clm_shmem_leader_allreduce_sum_i4 + + !============================================================================= + subroutine clm_shmem_fence(win) + ! Collective over the node communicator; synchronizes the window so stores + ! become visible to all ranks on the node. + integer, intent(in) :: win + integer :: ierr + call mpi_win_fence(0, win, ierr) + if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_fence failed') + end subroutine clm_shmem_fence + + !============================================================================= + subroutine clm_shmem_free_i4_1d(ptr, win) + ! Free the node-shared window and disassociate the pointer. Collective over + ! the node communicator; a no-op when win == MPI_WIN_NULL. + integer, pointer :: ptr(:) + integer, intent(inout) :: win + integer :: ierr + if (win /= MPI_WIN_NULL) then + call mpi_win_free(win, ierr) + if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_free failed') + end if + if (associated(ptr)) nullify(ptr) + win = MPI_WIN_NULL + end subroutine clm_shmem_free_i4_1d + + !============================================================================= + logical function clm_shmem_is_leader() + call init_comms() + clm_shmem_is_leader = is_leader + end function clm_shmem_is_leader + + !============================================================================= + integer function clm_shmem_leader_comm() + call init_comms() + clm_shmem_leader_comm = leader_comm + end function clm_shmem_leader_comm + + !============================================================================= + integer function clm_shmem_npes_per_node() + call init_comms() + clm_shmem_npes_per_node = node_size + end function clm_shmem_npes_per_node + +end module clm_shmem_mod diff --git a/src/cpl/share_esmf/lnd_set_decomp_and_domain.F90 b/src/cpl/share_esmf/lnd_set_decomp_and_domain.F90 index 6fc69ab3f8..53b73b017f 100644 --- a/src/cpl/share_esmf/lnd_set_decomp_and_domain.F90 +++ b/src/cpl/share_esmf/lnd_set_decomp_and_domain.F90 @@ -21,6 +21,8 @@ module lnd_set_decomp_and_domain use clm_varctl , only : iulog, inst_suffix, FL => fname_len use abortutils , only : endrun use perf_mod , only : t_startf, t_stopf + use clm_shmem_mod, only : clm_shmem_alloc_i4_1d, clm_shmem_free, clm_shmem_fence + use clm_shmem_mod, only : clm_shmem_is_leader, clm_shmem_leader_allreduce_sum_i4 implicit none private ! except @@ -83,6 +85,7 @@ subroutine lnd_set_decomp_and_domain_from_readmesh(driver, vm, meshfile_lnd, mes integer , pointer :: gindex_ocn(:) ! global index space for just ocean points integer , pointer :: gindex_ctsm(:) ! global index space for land and ocean points integer , pointer :: lndmask_glob(:) + integer :: lndmask_win = -1 ! node-shared window handle for lndmask_glob (cmeps paths) real(r8) , pointer :: lndfrac_glob(:) real(r8) , pointer :: lndfrac_loc_input(:) => null() real(r8) , pointer :: dataptr1d(:) @@ -131,7 +134,7 @@ subroutine lnd_set_decomp_and_domain_from_readmesh(driver, vm, meshfile_lnd, mes ! obain land mask and land fraction by mapping ocean mesh conservatively to land mesh ! Note that lndmask_glob and lndfrac_loc_input are allocated in lnd_set_lndmask_from_maskmesh call lnd_set_lndmask_from_maskmesh(mesh_lndinput, mesh_maskinput, vm, gsize, lndmask_glob, & - lndfrac_loc_input, rc) + lndmask_win, lndfrac_loc_input, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return #ifdef DEBUG ! This will get added to the ESMF PET files if DEBUG=TRUE and CREATE_ESMF_PET_FILES=TRUE @@ -139,7 +142,7 @@ subroutine lnd_set_decomp_and_domain_from_readmesh(driver, vm, meshfile_lnd, mes #endif else ! obtain land mask from land mesh file - assume that land frac is identical to land mask - call lnd_set_lndmask_from_lndmesh(mesh_lndinput, vm, gsize, lndmask_glob, rc) + call lnd_set_lndmask_from_lndmesh(mesh_lndinput, vm, gsize, lndmask_glob, lndmask_win, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if else if (trim(driver) == 'lilac') then @@ -185,8 +188,14 @@ subroutine lnd_set_decomp_and_domain_from_readmesh(driver, vm, meshfile_lnd, mes ldomain%mask(g) = lndmask_glob(gindex_lnd(n)) end do - ! Deallocate global pointer memory - deallocate(lndmask_glob) + ! Deallocate global pointer memory. The cmeps paths allocate lndmask_glob as + ! a per-node shared-memory window (clm_shmem_alloc_i4_1d), so it must be freed + ! with clm_shmem_free, not deallocate; the lilac path uses a plain allocate. + if (trim(driver) == 'cmeps') then + call clm_shmem_free(lndmask_glob, lndmask_win) + else + deallocate(lndmask_glob) + end if ! Generate a ctsm global index that includes both land and ocean points nocn = size(gindex_ocn) @@ -474,7 +483,7 @@ subroutine lnd_get_global_dims(ni, nj, gsize, isgrid2d) end subroutine lnd_get_global_dims !=============================================================================== - subroutine lnd_set_lndmask_from_maskmesh(mesh_lnd, mesh_mask, vm, gsize, lndmask_glob, lndfrac_loc, rc) + subroutine lnd_set_lndmask_from_maskmesh(mesh_lnd, mesh_mask, vm, gsize, lndmask_glob, lndmask_win, lndfrac_loc, rc) ! If the landfrac/landmask file does not exists then determine the ! land fraction and land mask on the land grid by mapping the mask @@ -488,7 +497,8 @@ subroutine lnd_set_lndmask_from_maskmesh(mesh_lnd, mesh_mask, vm, gsize, lndmask type(ESMF_Mesh) , intent(in) :: mesh_mask type(ESMF_VM) , intent(in) :: vm integer , intent(in) :: gsize - integer , pointer :: lndmask_glob(:) + integer , pointer :: lndmask_glob(:) ! node-shared global land mask + integer , intent(out) :: lndmask_win ! its shared-memory window handle real(r8) , pointer :: lndfrac_loc(:) integer , intent(out) :: rc @@ -500,7 +510,6 @@ subroutine lnd_set_lndmask_from_maskmesh(mesh_lnd, mesh_mask, vm, gsize, lndmask type(ESMF_DistGrid) :: distgrid_mask integer , pointer :: gindex_input(:) ! global index space for land and ocean points integer , pointer :: lndmask_loc(:) - integer , pointer :: itemp_glob(:) real(r8) , pointer :: maskmask_loc(:) ! on ocean mesh real(r8) , pointer :: maskfrac_loc(:) ! on land mesh real(r8) , pointer :: dataptr1d(:) @@ -527,7 +536,12 @@ subroutine lnd_set_lndmask_from_maskmesh(mesh_lnd, mesh_mask, vm, gsize, lndmask klen = len_trim(flandfrac) - 3 ! remove the .nc flandfrac_status = flandfrac(1:klen)//'.status' - allocate(lndmask_glob(gsize)); lndmask_glob(:) = 0 + ! Allocate the global land mask once per shared-memory node (not once per rank). + ! Leader zeroes it; the compute branch below fills disjoint local points on each + ! rank and sums across nodes (clm_shmem_leader_allreduce_sum_i4). + call clm_shmem_alloc_i4_1d(lndmask_glob, lndmask_win, gsize) + if (clm_shmem_is_leader()) lndmask_glob(:) = 0 + call clm_shmem_fence(lndmask_win) ! Determine if lndfrac/lndmask file exists inquire(file=trim(flandfrac), exist=lexist) @@ -610,11 +624,7 @@ subroutine lnd_set_lndmask_from_maskmesh(mesh_lnd, mesh_mask, vm, gsize, lndmask do n = 1,lsize_lnd lndmask_glob(gindex_input(n)) = lndmask_loc(n) end do - allocate(itemp_glob(gsize)) - call ESMF_VMAllReduce(vm, sendData=lndmask_glob, recvData=itemp_glob, count=gsize, & - reduceflag=ESMF_REDUCE_SUM, rc=rc) - lndmask_glob(:) = int(itemp_glob(:)) - deallocate(itemp_glob) + call clm_shmem_leader_allreduce_sum_i4(lndmask_glob, lndmask_win, gsize) ! deallocate memory deallocate(maskmask_loc) @@ -626,13 +636,14 @@ subroutine lnd_set_lndmask_from_maskmesh(mesh_lnd, mesh_mask, vm, gsize, lndmask end subroutine lnd_set_lndmask_from_maskmesh !=============================================================================== - subroutine lnd_set_lndmask_from_lndmesh(mesh_lnd, vm, gsize, lndmask_glob, rc) + subroutine lnd_set_lndmask_from_lndmesh(mesh_lnd, vm, gsize, lndmask_glob, lndmask_win, rc) ! input/out variables type(ESMF_Mesh) , intent(in) :: mesh_lnd type(ESMF_VM) , intent(in) :: vm integer , intent(in) :: gsize - integer , pointer :: lndmask_glob(:) + integer , pointer :: lndmask_glob(:) ! node-shared global land mask + integer , intent(out) :: lndmask_win ! its shared-memory window handle integer , intent(out) :: rc ! local variables: @@ -640,7 +651,6 @@ subroutine lnd_set_lndmask_from_lndmesh(mesh_lnd, vm, gsize, lndmask_glob, rc) integer :: lsize integer , pointer :: gindex(:) integer , pointer :: lndmask_loc(:) - integer , pointer :: itemp_glob(:) type(ESMF_DistGrid) :: distgrid type(ESMF_Array) :: elemMaskArray !------------------------------------------------------------------------------- @@ -664,19 +674,20 @@ subroutine lnd_set_lndmask_from_lndmesh(mesh_lnd, vm, gsize, lndmask_glob, rc) ! Determine global landmask_glob - needed to determine the ctsm decomposition ! land frac, lats, lons and areas will be done below allocate(gindex(lsize)) - allocate(itemp_glob(gsize)) call ESMF_DistGridGet(distgrid, 0, seqIndexList=gindex, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - allocate(lndmask_glob(gsize)); lndmask_glob(:) = 0 + ! Allocate the global land mask once per shared-memory node (not once per rank) + ! and build it by summing each rank's disjoint local contributions across nodes + ! (the leader-only reduce replaces the all-rank ESMF_VMAllReduce; bit-for-bit). + call clm_shmem_alloc_i4_1d(lndmask_glob, lndmask_win, gsize) + if (clm_shmem_is_leader()) lndmask_glob(:) = 0 + call clm_shmem_fence(lndmask_win) do n = 1,lsize lndmask_glob(gindex(n)) = lndmask_loc(n) end do - call ESMF_VMAllReduce(vm, sendData=lndmask_glob, recvData=itemp_glob, count=gsize, & - reduceflag=ESMF_REDUCE_SUM, rc=rc) - lndmask_glob(:) = int(itemp_glob(:)) - deallocate(itemp_glob) + call clm_shmem_leader_allreduce_sum_i4(lndmask_glob, lndmask_win, gsize) deallocate(gindex) deallocate(lndmask_loc) diff --git a/src/main/clm_instMod.F90 b/src/main/clm_instMod.F90 index 7d9a0f6ad2..271ccf84f4 100644 --- a/src/main/clm_instMod.F90 +++ b/src/main/clm_instMod.F90 @@ -459,6 +459,9 @@ subroutine clm_instInit(bounds) ! Even for a FATES simulation, we call this to initialize product pools call bgc_vegetation_inst%Init(bounds, nlfilename, GetBalanceCheckSkipSteps(), params_ncid ) + ! Close parameter file - this was its last use (no subsequent reads through params_ncid) + call ncd_pio_closefile(params_ncid) + if (use_cn .or. use_fates) then call crop_inst%Init(bounds) end if @@ -505,8 +508,6 @@ subroutine clm_instInit(bounds) call print_accum_fields() - call ncd_pio_closefile(params_ncid) - call t_stopf('init_accflds') end subroutine clm_instInit diff --git a/src/main/initVerticalMod.F90 b/src/main/initVerticalMod.F90 index 64383e7a7c..1f6f19254e 100644 --- a/src/main/initVerticalMod.F90 +++ b/src/main/initVerticalMod.F90 @@ -651,6 +651,9 @@ subroutine initVertical(bounds, glc_behavior, thick_wall, thick_roof) end do deallocate(std) + ! Close surface dataset - all reads complete (STD_ELEV was the last read) + call ncd_pio_closefile(ncid) + !----------------------------------------------- ! SCA shape function defined !----------------------------------------------- @@ -667,8 +670,6 @@ subroutine initVertical(bounds, glc_behavior, thick_wall, thick_roof) end do - call ncd_pio_closefile(ncid) - end subroutine initVertical !----------------------------------------------------------------------- diff --git a/src/main/organicFileMod.F90 b/src/main/organicFileMod.F90 index 5b61a8c0db..93034e3fa4 100644 --- a/src/main/organicFileMod.F90 +++ b/src/main/organicFileMod.F90 @@ -102,6 +102,8 @@ subroutine organicrd(organic) dim1name=grlnd, readvar=readvar) if (.not. readvar) call endrun('organicrd: errror reading ORGANIC') + call ncd_pio_closefile(ncid) + if ( masterproc )then write(iulog,*) 'Successfully read organic matter data' write(iulog,*) diff --git a/src/main/surfrdMod.F90 b/src/main/surfrdMod.F90 index 188773dfcd..952680afa0 100644 --- a/src/main/surfrdMod.F90 +++ b/src/main/surfrdMod.F90 @@ -408,6 +408,9 @@ subroutine surfrd_get_num_patches (lfsurdat, actual_maxsoil_patches, actual_nump actual_numnatpft = 0 end if + ! Close surface dataset - no longer needed after reading dimensions + call ncd_pio_closefile(ncid) + !jt if(check_numpft.ne.actual_numpft)then if(actual_numcft+actual_numnatpft.ne.actual_maxsoil_patches)then write(iulog,*)'the sum of the cftdim and the natpft dim should match the lsmpft dim in the surface file' @@ -459,6 +462,9 @@ subroutine surfrd_get_nlevurb (lfsurdat, actual_nlevurb) ! Read nlevurb call ncd_inqdlen(ncid, dimid, actual_nlevurb, 'nlevurb') + ! Close surface dataset - no longer needed after reading nlevurb + call ncd_pio_closefile(ncid) + if ( masterproc )then write(iulog,*) 'Successfully read nlevurb from the surface data' write(iulog,*) From 599d8e8b8482c34f9c9e6a0c8418b8bdcbc0dcda Mon Sep 17 00:00:00 2001 From: Jian Sun Date: Fri, 19 Jun 2026 01:15:27 -0600 Subject: [PATCH 02/12] reuse already-built CLM mesh --- .../share_esmf/PrigentRoughnessStreamType.F90 | 73 +++++++++++++------ src/cpl/share_esmf/UrbanTimeVarType.F90 | 73 +++++++++++++------ 2 files changed, 102 insertions(+), 44 deletions(-) diff --git a/src/cpl/share_esmf/PrigentRoughnessStreamType.F90 b/src/cpl/share_esmf/PrigentRoughnessStreamType.F90 index 158c75e434..7f077559f3 100644 --- a/src/cpl/share_esmf/PrigentRoughnessStreamType.F90 +++ b/src/cpl/share_esmf/PrigentRoughnessStreamType.F90 @@ -101,28 +101,57 @@ subroutine Init(this, bounds, NLFilename) write(iulog,*) ' stream_varnames = ',stream_varnames end if - ! Initialize the cdeps data type sdat_rghn - call shr_strdata_init_from_inline(sdat_rghn, & - my_task = iam, & - logunit = iulog, & - compname = 'LND', & - model_clock = model_clock, & - model_mesh = mesh, & - stream_meshfile = control%stream_meshfile_prigentroughness, & - stream_lev_dimname = 'null', & - stream_mapalgo = control%prigentroughnessmapalgo, & - stream_filenames = (/trim(control%stream_fldFileName_prigentroughness)/), & - stream_fldlistFile = stream_varnames, & - stream_fldListModel = stream_varnames, & - stream_yearFirst = 1997, & - stream_yearLast = 1997, & - stream_yearAlign = 1, & - stream_offset = 0, & - stream_taxmode = 'extend', & - stream_dtlimit = 1.0e30_r8, & - stream_tintalgo = 'linear', & - stream_name = 'Prigent roughness', & - rc = rc) + ! Initialize the cdeps data type sdat_rghn. + ! When the stream is on the model grid (mapalgo='redist', as for the + ! ne1024pg2 Prigent file) reuse the already-built CLM model mesh instead + ! of letting CDEPS create a duplicate full ESMF mesh from the stream mesh + ! file -- at ne1024pg2 that duplicate is a large init memory/time cost. + if (trim(control%prigentroughnessmapalgo) == 'redist') then + call shr_strdata_init_from_inline(sdat_rghn, & + my_task = iam, & + logunit = iulog, & + compname = 'LND', & + model_clock = model_clock, & + model_mesh = mesh, & + stream_meshfile = control%stream_meshfile_prigentroughness, & + stream_lev_dimname = 'null', & + stream_mapalgo = control%prigentroughnessmapalgo, & + stream_filenames = (/trim(control%stream_fldFileName_prigentroughness)/), & + stream_fldlistFile = stream_varnames, & + stream_fldListModel = stream_varnames, & + stream_yearFirst = 1997, & + stream_yearLast = 1997, & + stream_yearAlign = 1, & + stream_offset = 0, & + stream_taxmode = 'extend', & + stream_dtlimit = 1.0e30_r8, & + stream_tintalgo = 'linear', & + stream_name = 'Prigent roughness', & + stream_mesh_in = mesh, & + rc = rc) + else + call shr_strdata_init_from_inline(sdat_rghn, & + my_task = iam, & + logunit = iulog, & + compname = 'LND', & + model_clock = model_clock, & + model_mesh = mesh, & + stream_meshfile = control%stream_meshfile_prigentroughness, & + stream_lev_dimname = 'null', & + stream_mapalgo = control%prigentroughnessmapalgo, & + stream_filenames = (/trim(control%stream_fldFileName_prigentroughness)/), & + stream_fldlistFile = stream_varnames, & + stream_fldListModel = stream_varnames, & + stream_yearFirst = 1997, & + stream_yearLast = 1997, & + stream_yearAlign = 1, & + stream_offset = 0, & + stream_taxmode = 'extend', & + stream_dtlimit = 1.0e30_r8, & + stream_tintalgo = 'linear', & + stream_name = 'Prigent roughness', & + rc = rc) + end if if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) then call ESMF_Finalize(endflag=ESMF_END_ABORT) end if diff --git a/src/cpl/share_esmf/UrbanTimeVarType.F90 b/src/cpl/share_esmf/UrbanTimeVarType.F90 index a05339ac5f..fd96649ba3 100644 --- a/src/cpl/share_esmf/UrbanTimeVarType.F90 +++ b/src/cpl/share_esmf/UrbanTimeVarType.F90 @@ -194,28 +194,57 @@ subroutine urbantv_init(this, bounds, NLFilename) write(iulog,*) ' ' endif - ! Initialize the cdeps data type this%sdat_urbantv - call shr_strdata_init_from_inline(this%sdat_urbantv, & - my_task = iam, & - logunit = iulog, & - compname = 'LND', & - model_clock = model_clock, & - model_mesh = mesh, & - stream_meshfile = trim(stream_meshfile_urbantv), & - stream_lev_dimname = 'null', & - stream_mapalgo = trim(urbantvmapalgo), & - stream_filenames = (/trim(stream_fldfilename_urbantv)/), & - stream_fldlistFile = stream_varnames(stream_varname_MIN:stream_varname_MAX), & - stream_fldListModel = stream_varnames(stream_varname_MIN:stream_varname_MAX), & - stream_yearFirst = stream_year_first_urbantv, & - stream_yearLast = stream_year_last_urbantv, & - stream_yearAlign = model_year_align_urbantv, & - stream_offset = 0, & - stream_taxmode = 'extend', & - stream_dtlimit = 1.0e30_r8, & - stream_tintalgo = urbantv_tintalgo, & - stream_name = 'Urban time varying data', & - rc = rc) + ! Initialize the cdeps data type this%sdat_urbantv. + ! When the stream is on the model grid (mapalgo='redist'; the urbantv mesh is + ! ne1024pg2, identical element count/ordering to the model mesh) reuse the + ! model mesh instead of building a duplicate full ESMF mesh from the stream + ! mesh file -- a large init memory/time cost at ne1024pg2. + if (trim(urbantvmapalgo) == 'redist') then + call shr_strdata_init_from_inline(this%sdat_urbantv, & + my_task = iam, & + logunit = iulog, & + compname = 'LND', & + model_clock = model_clock, & + model_mesh = mesh, & + stream_meshfile = trim(stream_meshfile_urbantv), & + stream_lev_dimname = 'null', & + stream_mapalgo = trim(urbantvmapalgo), & + stream_filenames = (/trim(stream_fldfilename_urbantv)/), & + stream_fldlistFile = stream_varnames(stream_varname_MIN:stream_varname_MAX), & + stream_fldListModel = stream_varnames(stream_varname_MIN:stream_varname_MAX), & + stream_yearFirst = stream_year_first_urbantv, & + stream_yearLast = stream_year_last_urbantv, & + stream_yearAlign = model_year_align_urbantv, & + stream_offset = 0, & + stream_taxmode = 'extend', & + stream_dtlimit = 1.0e30_r8, & + stream_tintalgo = urbantv_tintalgo, & + stream_name = 'Urban time varying data', & + stream_mesh_in = mesh, & + rc = rc) + else + call shr_strdata_init_from_inline(this%sdat_urbantv, & + my_task = iam, & + logunit = iulog, & + compname = 'LND', & + model_clock = model_clock, & + model_mesh = mesh, & + stream_meshfile = trim(stream_meshfile_urbantv), & + stream_lev_dimname = 'null', & + stream_mapalgo = trim(urbantvmapalgo), & + stream_filenames = (/trim(stream_fldfilename_urbantv)/), & + stream_fldlistFile = stream_varnames(stream_varname_MIN:stream_varname_MAX), & + stream_fldListModel = stream_varnames(stream_varname_MIN:stream_varname_MAX), & + stream_yearFirst = stream_year_first_urbantv, & + stream_yearLast = stream_year_last_urbantv, & + stream_yearAlign = model_year_align_urbantv, & + stream_offset = 0, & + stream_taxmode = 'extend', & + stream_dtlimit = 1.0e30_r8, & + stream_tintalgo = urbantv_tintalgo, & + stream_name = 'Urban time varying data', & + rc = rc) + end if if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) then call ESMF_Finalize(endflag=ESMF_END_ABORT) end if From 2a68d04176882b593ade9f53b763237abe0fe2c6 Mon Sep 17 00:00:00 2001 From: Jian Sun Date: Thu, 25 Jun 2026 15:23:37 -0600 Subject: [PATCH 03/12] temporary hold for a new cdeps tag --- .gitmodules | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index b5156d3190..08a6331398 100644 --- a/.gitmodules +++ b/.gitmodules @@ -91,8 +91,8 @@ fxDONOTUSEurl = https://github.com/ESCOMP/CMEPS.git [submodule "cdeps"] path = components/cdeps -url = https://github.com/ESCOMP/CDEPS.git -fxtag = cdeps1.0.96 +url = https://github.com/sjsprecious/CDEPS.git +fxtag = 1024ebc fxrequired = ToplevelRequired # Standard Fork to compare to with "git fleximod test" to ensure personal forks aren't committed fxDONOTUSEurl = https://github.com/ESCOMP/CDEPS.git From aa1f87b0f5423a62ea5f727a9904477d34ef078f Mon Sep 17 00:00:00 2001 From: Jian Sun Date: Mon, 29 Jun 2026 14:21:35 -0600 Subject: [PATCH 04/12] update interface with cdeps changes --- .gitmodules | 2 +- .../share_esmf/PrigentRoughnessStreamType.F90 | 73 ++++++------------- src/cpl/share_esmf/UrbanTimeVarType.F90 | 73 ++++++------------- 3 files changed, 45 insertions(+), 103 deletions(-) diff --git a/.gitmodules b/.gitmodules index 08a6331398..336a5a3d15 100644 --- a/.gitmodules +++ b/.gitmodules @@ -92,7 +92,7 @@ fxDONOTUSEurl = https://github.com/ESCOMP/CMEPS.git [submodule "cdeps"] path = components/cdeps url = https://github.com/sjsprecious/CDEPS.git -fxtag = 1024ebc +fxtag = af456c0 fxrequired = ToplevelRequired # Standard Fork to compare to with "git fleximod test" to ensure personal forks aren't committed fxDONOTUSEurl = https://github.com/ESCOMP/CDEPS.git diff --git a/src/cpl/share_esmf/PrigentRoughnessStreamType.F90 b/src/cpl/share_esmf/PrigentRoughnessStreamType.F90 index 7f077559f3..158c75e434 100644 --- a/src/cpl/share_esmf/PrigentRoughnessStreamType.F90 +++ b/src/cpl/share_esmf/PrigentRoughnessStreamType.F90 @@ -101,57 +101,28 @@ subroutine Init(this, bounds, NLFilename) write(iulog,*) ' stream_varnames = ',stream_varnames end if - ! Initialize the cdeps data type sdat_rghn. - ! When the stream is on the model grid (mapalgo='redist', as for the - ! ne1024pg2 Prigent file) reuse the already-built CLM model mesh instead - ! of letting CDEPS create a duplicate full ESMF mesh from the stream mesh - ! file -- at ne1024pg2 that duplicate is a large init memory/time cost. - if (trim(control%prigentroughnessmapalgo) == 'redist') then - call shr_strdata_init_from_inline(sdat_rghn, & - my_task = iam, & - logunit = iulog, & - compname = 'LND', & - model_clock = model_clock, & - model_mesh = mesh, & - stream_meshfile = control%stream_meshfile_prigentroughness, & - stream_lev_dimname = 'null', & - stream_mapalgo = control%prigentroughnessmapalgo, & - stream_filenames = (/trim(control%stream_fldFileName_prigentroughness)/), & - stream_fldlistFile = stream_varnames, & - stream_fldListModel = stream_varnames, & - stream_yearFirst = 1997, & - stream_yearLast = 1997, & - stream_yearAlign = 1, & - stream_offset = 0, & - stream_taxmode = 'extend', & - stream_dtlimit = 1.0e30_r8, & - stream_tintalgo = 'linear', & - stream_name = 'Prigent roughness', & - stream_mesh_in = mesh, & - rc = rc) - else - call shr_strdata_init_from_inline(sdat_rghn, & - my_task = iam, & - logunit = iulog, & - compname = 'LND', & - model_clock = model_clock, & - model_mesh = mesh, & - stream_meshfile = control%stream_meshfile_prigentroughness, & - stream_lev_dimname = 'null', & - stream_mapalgo = control%prigentroughnessmapalgo, & - stream_filenames = (/trim(control%stream_fldFileName_prigentroughness)/), & - stream_fldlistFile = stream_varnames, & - stream_fldListModel = stream_varnames, & - stream_yearFirst = 1997, & - stream_yearLast = 1997, & - stream_yearAlign = 1, & - stream_offset = 0, & - stream_taxmode = 'extend', & - stream_dtlimit = 1.0e30_r8, & - stream_tintalgo = 'linear', & - stream_name = 'Prigent roughness', & - rc = rc) - end if + ! Initialize the cdeps data type sdat_rghn + call shr_strdata_init_from_inline(sdat_rghn, & + my_task = iam, & + logunit = iulog, & + compname = 'LND', & + model_clock = model_clock, & + model_mesh = mesh, & + stream_meshfile = control%stream_meshfile_prigentroughness, & + stream_lev_dimname = 'null', & + stream_mapalgo = control%prigentroughnessmapalgo, & + stream_filenames = (/trim(control%stream_fldFileName_prigentroughness)/), & + stream_fldlistFile = stream_varnames, & + stream_fldListModel = stream_varnames, & + stream_yearFirst = 1997, & + stream_yearLast = 1997, & + stream_yearAlign = 1, & + stream_offset = 0, & + stream_taxmode = 'extend', & + stream_dtlimit = 1.0e30_r8, & + stream_tintalgo = 'linear', & + stream_name = 'Prigent roughness', & + rc = rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) then call ESMF_Finalize(endflag=ESMF_END_ABORT) end if diff --git a/src/cpl/share_esmf/UrbanTimeVarType.F90 b/src/cpl/share_esmf/UrbanTimeVarType.F90 index fd96649ba3..a05339ac5f 100644 --- a/src/cpl/share_esmf/UrbanTimeVarType.F90 +++ b/src/cpl/share_esmf/UrbanTimeVarType.F90 @@ -194,57 +194,28 @@ subroutine urbantv_init(this, bounds, NLFilename) write(iulog,*) ' ' endif - ! Initialize the cdeps data type this%sdat_urbantv. - ! When the stream is on the model grid (mapalgo='redist'; the urbantv mesh is - ! ne1024pg2, identical element count/ordering to the model mesh) reuse the - ! model mesh instead of building a duplicate full ESMF mesh from the stream - ! mesh file -- a large init memory/time cost at ne1024pg2. - if (trim(urbantvmapalgo) == 'redist') then - call shr_strdata_init_from_inline(this%sdat_urbantv, & - my_task = iam, & - logunit = iulog, & - compname = 'LND', & - model_clock = model_clock, & - model_mesh = mesh, & - stream_meshfile = trim(stream_meshfile_urbantv), & - stream_lev_dimname = 'null', & - stream_mapalgo = trim(urbantvmapalgo), & - stream_filenames = (/trim(stream_fldfilename_urbantv)/), & - stream_fldlistFile = stream_varnames(stream_varname_MIN:stream_varname_MAX), & - stream_fldListModel = stream_varnames(stream_varname_MIN:stream_varname_MAX), & - stream_yearFirst = stream_year_first_urbantv, & - stream_yearLast = stream_year_last_urbantv, & - stream_yearAlign = model_year_align_urbantv, & - stream_offset = 0, & - stream_taxmode = 'extend', & - stream_dtlimit = 1.0e30_r8, & - stream_tintalgo = urbantv_tintalgo, & - stream_name = 'Urban time varying data', & - stream_mesh_in = mesh, & - rc = rc) - else - call shr_strdata_init_from_inline(this%sdat_urbantv, & - my_task = iam, & - logunit = iulog, & - compname = 'LND', & - model_clock = model_clock, & - model_mesh = mesh, & - stream_meshfile = trim(stream_meshfile_urbantv), & - stream_lev_dimname = 'null', & - stream_mapalgo = trim(urbantvmapalgo), & - stream_filenames = (/trim(stream_fldfilename_urbantv)/), & - stream_fldlistFile = stream_varnames(stream_varname_MIN:stream_varname_MAX), & - stream_fldListModel = stream_varnames(stream_varname_MIN:stream_varname_MAX), & - stream_yearFirst = stream_year_first_urbantv, & - stream_yearLast = stream_year_last_urbantv, & - stream_yearAlign = model_year_align_urbantv, & - stream_offset = 0, & - stream_taxmode = 'extend', & - stream_dtlimit = 1.0e30_r8, & - stream_tintalgo = urbantv_tintalgo, & - stream_name = 'Urban time varying data', & - rc = rc) - end if + ! Initialize the cdeps data type this%sdat_urbantv + call shr_strdata_init_from_inline(this%sdat_urbantv, & + my_task = iam, & + logunit = iulog, & + compname = 'LND', & + model_clock = model_clock, & + model_mesh = mesh, & + stream_meshfile = trim(stream_meshfile_urbantv), & + stream_lev_dimname = 'null', & + stream_mapalgo = trim(urbantvmapalgo), & + stream_filenames = (/trim(stream_fldfilename_urbantv)/), & + stream_fldlistFile = stream_varnames(stream_varname_MIN:stream_varname_MAX), & + stream_fldListModel = stream_varnames(stream_varname_MIN:stream_varname_MAX), & + stream_yearFirst = stream_year_first_urbantv, & + stream_yearLast = stream_year_last_urbantv, & + stream_yearAlign = model_year_align_urbantv, & + stream_offset = 0, & + stream_taxmode = 'extend', & + stream_dtlimit = 1.0e30_r8, & + stream_tintalgo = urbantv_tintalgo, & + stream_name = 'Urban time varying data', & + rc = rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) then call ESMF_Finalize(endflag=ESMF_END_ABORT) end if From 2669220615c4e90679c24000f6ef4cc8143e6966 Mon Sep 17 00:00:00 2001 From: Jian Sun Date: Mon, 29 Jun 2026 19:04:50 -0600 Subject: [PATCH 05/12] fix failed tests for mpi-serial --- src/cpl/share_esmf/clm_shmem_mod.F90 | 53 ++++++++++++++++++++++++---- 1 file changed, 47 insertions(+), 6 deletions(-) diff --git a/src/cpl/share_esmf/clm_shmem_mod.F90 b/src/cpl/share_esmf/clm_shmem_mod.F90 index 0a40da5d2d..069e398326 100644 --- a/src/cpl/share_esmf/clm_shmem_mod.F90 +++ b/src/cpl/share_esmf/clm_shmem_mod.F90 @@ -20,11 +20,14 @@ module clm_shmem_mod ! ! call clm_shmem_free(ptr, win) ! collective over the node comm ! - ! CLM is always built against MPI (it has no SPMD cpp guard), and mpi-serial - ! supplies the MPI-3 shared-memory entry points for single-task builds, so the - ! shared-memory path is compiled unconditionally. The F90 'mpi' module (not - ! mpif.h) is used because the TYPE(C_PTR) overloads of MPI_WIN_ALLOCATE_SHARED / - ! MPI_WIN_SHARED_QUERY are only guaranteed there (MPI-3.0). + ! The MPI-3 shared-memory path is used for real MPI builds. mpi-serial does not + ! implement the MPI-2/MPI-3 one-sided / shared-memory interfaces, so for + ! mpi-serial builds (CPP macro NO_MPI2, set by CIME for MPILIB=mpi-serial) a + ! single-task fallback is compiled instead: each "node-shared" array is a plain + ! local allocation (one task is its own node and its own leader, so there is no + ! cross-rank sharing and the leader sum-reduce is a no-op). The F90 'mpi' module + ! (not mpif.h) is used because the TYPE(C_PTR) overloads of MPI_WIN_ALLOCATE_SHARED + ! / MPI_WIN_SHARED_QUERY are only guaranteed there (MPI-3.0). !----------------------------------------------------------------------------- use mpi @@ -47,6 +50,9 @@ module clm_shmem_mod module procedure clm_shmem_free_i4_1d end interface clm_shmem_free + ! Sentinel window handle used by the mpi-serial fallback (no real MPI window). + integer, parameter :: SHMEM_WIN_NONE = -1 + logical, save :: initialized = .false. integer, save :: node_comm = MPI_COMM_NULL ! ranks sharing a node integer, save :: leader_comm = MPI_COMM_NULL ! one rank per node (the leaders) @@ -60,10 +66,13 @@ module clm_shmem_mod subroutine init_comms() ! Lazily build the node-local and node-leader communicators. Collective over ! mpicom; safe to call from every shared-memory request. +#ifndef NO_MPI2 integer :: ierr, color +#endif if (initialized) return +#ifndef NO_MPI2 call mpi_comm_split_type(mpicom, MPI_COMM_TYPE_SHARED, 0, MPI_INFO_NULL, & node_comm, ierr) call mpi_comm_rank(node_comm, node_rank, ierr) @@ -77,6 +86,12 @@ subroutine init_comms() color = MPI_UNDEFINED end if call mpi_comm_split(mpicom, color, 0, leader_comm, ierr) +#else + ! mpi-serial: a single task is its own node and its own leader. + node_rank = 0 + node_size = 1 + is_leader = .true. +#endif initialized = .true. end subroutine init_comms @@ -89,13 +104,18 @@ subroutine clm_shmem_alloc_i4_1d(ptr, win, n) integer, intent(out) :: win integer, intent(in) :: n +#ifndef NO_MPI2 integer(kind=MPI_ADDRESS_KIND) :: winsize, qsize integer :: ierr, disp_unit, qdisp integer :: itmp type(c_ptr) :: baseptr +#else + integer :: istat +#endif call init_comms() +#ifndef NO_MPI2 disp_unit = storage_size(itmp) / 8 ! bytes per default integer (robust to -i8) if (is_leader) then winsize = int(n, MPI_ADDRESS_KIND) * int(disp_unit, MPI_ADDRESS_KIND) @@ -114,6 +134,12 @@ subroutine clm_shmem_alloc_i4_1d(ptr, win, n) end if call c_f_pointer(baseptr, ptr, [n]) +#else + ! mpi-serial: single task, no shared memory -- a plain local allocation. + allocate(ptr(n), stat=istat) + if (istat /= 0) call endrun('clm_shmem_mod: allocate failed (mpi-serial path)') + win = SHMEM_WIN_NONE +#endif end subroutine clm_shmem_alloc_i4_1d !============================================================================= @@ -127,10 +153,13 @@ subroutine clm_shmem_leader_allreduce_sum_i4(ptr, win, n) integer, intent(in) :: win integer, intent(in) :: n +#ifndef NO_MPI2 integer, allocatable :: tmp(:) integer :: ierr +#endif call clm_shmem_fence(win) ! all node stores complete and visible to leader +#ifndef NO_MPI2 if (is_leader) then allocate(tmp(n)) call mpi_allreduce(ptr, tmp, n, MPI_INTEGER, MPI_SUM, leader_comm, ierr) @@ -138,17 +167,23 @@ subroutine clm_shmem_leader_allreduce_sum_i4(ptr, win, n) ptr(1:n) = tmp(1:n) deallocate(tmp) end if +#else + ! mpi-serial: the single task owns the whole domain, so ptr already holds the + ! global array -- there is nothing to sum across nodes. +#endif call clm_shmem_fence(win) ! publish global result to all node ranks end subroutine clm_shmem_leader_allreduce_sum_i4 !============================================================================= subroutine clm_shmem_fence(win) ! Collective over the node communicator; synchronizes the window so stores - ! become visible to all ranks on the node. + ! become visible to all ranks on the node. A no-op for the mpi-serial path. integer, intent(in) :: win +#ifndef NO_MPI2 integer :: ierr call mpi_win_fence(0, win, ierr) if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_fence failed') +#endif end subroutine clm_shmem_fence !============================================================================= @@ -157,6 +192,7 @@ subroutine clm_shmem_free_i4_1d(ptr, win) ! the node communicator; a no-op when win == MPI_WIN_NULL. integer, pointer :: ptr(:) integer, intent(inout) :: win +#ifndef NO_MPI2 integer :: ierr if (win /= MPI_WIN_NULL) then call mpi_win_free(win, ierr) @@ -164,6 +200,11 @@ subroutine clm_shmem_free_i4_1d(ptr, win) end if if (associated(ptr)) nullify(ptr) win = MPI_WIN_NULL +#else + ! mpi-serial: ptr was a plain local allocation, so deallocate it. + if (associated(ptr)) deallocate(ptr) + win = SHMEM_WIN_NONE +#endif end subroutine clm_shmem_free_i4_1d !============================================================================= From d7f811dcdd46f6a38b1061f261d6d3b7d25c4080 Mon Sep 17 00:00:00 2001 From: Jian Sun Date: Thu, 2 Jul 2026 10:59:28 -0600 Subject: [PATCH 06/12] update cdeps tag --- .gitmodules | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index 336a5a3d15..ff72029122 100644 --- a/.gitmodules +++ b/.gitmodules @@ -91,8 +91,8 @@ fxDONOTUSEurl = https://github.com/ESCOMP/CMEPS.git [submodule "cdeps"] path = components/cdeps -url = https://github.com/sjsprecious/CDEPS.git -fxtag = af456c0 +url = https://github.com/ESCOMP/CDEPS.git +fxtag = cdeps1.0.100 fxrequired = ToplevelRequired # Standard Fork to compare to with "git fleximod test" to ensure personal forks aren't committed fxDONOTUSEurl = https://github.com/ESCOMP/CDEPS.git From acc0b2b080fc24a67b834fceb2019d46386f9b5e Mon Sep 17 00:00:00 2001 From: Jian Sun Date: Wed, 8 Jul 2026 20:04:07 -0600 Subject: [PATCH 07/12] revert update of cdeps module --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index ff72029122..b5156d3190 100644 --- a/.gitmodules +++ b/.gitmodules @@ -92,7 +92,7 @@ fxDONOTUSEurl = https://github.com/ESCOMP/CMEPS.git [submodule "cdeps"] path = components/cdeps url = https://github.com/ESCOMP/CDEPS.git -fxtag = cdeps1.0.100 +fxtag = cdeps1.0.96 fxrequired = ToplevelRequired # Standard Fork to compare to with "git fleximod test" to ensure personal forks aren't committed fxDONOTUSEurl = https://github.com/ESCOMP/CDEPS.git From 6e46c4f98a776ce4a1d72839287908bfea716898 Mon Sep 17 00:00:00 2001 From: Jian Sun Date: Tue, 21 Jul 2026 14:50:44 -0600 Subject: [PATCH 08/12] add comments required by Erik --- src/cpl/share_esmf/clm_shmem_mod.F90 | 31 ++++++++++++++++++++++------ 1 file changed, 25 insertions(+), 6 deletions(-) diff --git a/src/cpl/share_esmf/clm_shmem_mod.F90 b/src/cpl/share_esmf/clm_shmem_mod.F90 index 069e398326..21d4e128a6 100644 --- a/src/cpl/share_esmf/clm_shmem_mod.F90 +++ b/src/cpl/share_esmf/clm_shmem_mod.F90 @@ -20,6 +20,19 @@ module clm_shmem_mod ! ! call clm_shmem_free(ptr, win) ! collective over the node comm ! + ! Terminology (MPI-3 shared-memory concepts used throughout this module): + ! window - the shared allocation itself (an "MPI window", type MPI_Win), created once + ! per node and mapped into the address space of every rank on that node; "win" + ! is the integer handle used to reference and later free it. + ! leader - the single rank per node that owns the physical storage (node-local rank 0, + ! clm_shmem_is_leader()); it is the only rank that requests the allocation, + ! initializes it, and reduces across nodes. + ! fence - an MPI_Win_fence synchronization: a collective call over the node that makes + ! stores issued by one rank visible to the other ranks sharing the window. + ! color - the grouping key passed to MPI_Comm_split; here leaders get color 0 (so they + ! are gathered into leader_comm) while non-leaders get MPI_UNDEFINED (so they + ! are excluded from it). + ! ! The MPI-3 shared-memory path is used for real MPI builds. mpi-serial does not ! implement the MPI-2/MPI-3 one-sided / shared-memory interfaces, so for ! mpi-serial builds (CPP macro NO_MPI2, set by CIME for MPILIB=mpi-serial) a @@ -56,8 +69,8 @@ module clm_shmem_mod logical, save :: initialized = .false. integer, save :: node_comm = MPI_COMM_NULL ! ranks sharing a node integer, save :: leader_comm = MPI_COMM_NULL ! one rank per node (the leaders) - integer, save :: node_rank = 0 - integer, save :: node_size = 1 + integer, save :: node_rank = 0 ! this rank's index within node_comm (0 => leader) + integer, save :: node_size = 1 ! number of ranks sharing this node logical, save :: is_leader = .true. contains @@ -66,6 +79,11 @@ module clm_shmem_mod subroutine init_comms() ! Lazily build the node-local and node-leader communicators. Collective over ! mpicom; safe to call from every shared-memory request. + ! + ! NO_MPI2 is defined by CIME only for MPILIB=mpi-serial, whose stub library lacks the + ! MPI-2/MPI-3 one-sided and shared-memory routines. Throughout this module, therefore, + ! "#ifndef NO_MPI2" selects the real-MPI shared-memory path and the "#else" branch + ! selects the single-task mpi-serial fallback. #ifndef NO_MPI2 integer :: ierr, color #endif @@ -100,15 +118,16 @@ end subroutine init_comms subroutine clm_shmem_alloc_i4_1d(ptr, win, n) ! Allocate a node-shared default-integer array of length n. Only the node ! leader requests storage; peers map the leader's contiguous segment. - integer, pointer, intent(out) :: ptr(:) - integer, intent(out) :: win - integer, intent(in) :: n + integer, pointer, intent(out) :: ptr(:) ! Fortran pointer mapped onto the node-shared buffer + integer, intent(out) :: win ! MPI window handle for the allocation (pass to clm_shmem_free) + integer, intent(in) :: n ! number of elements to allocate (identical on every rank) #ifndef NO_MPI2 integer(kind=MPI_ADDRESS_KIND) :: winsize, qsize integer :: ierr, disp_unit, qdisp integer :: itmp - type(c_ptr) :: baseptr + type(c_ptr) :: baseptr ! shared-segment base address; the MPI-3 win routines return the mapped + ! address as a C pointer, which c_f_pointer then turns into the pointer ptr #else integer :: istat #endif From 7572cf3721c5fdfd505565c355ab3c55b5183f1e Mon Sep 17 00:00:00 2001 From: Jian Sun Date: Tue, 21 Jul 2026 15:02:11 -0600 Subject: [PATCH 09/12] add ptr size check suggested by Erik --- src/cpl/share_esmf/clm_shmem_mod.F90 | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/cpl/share_esmf/clm_shmem_mod.F90 b/src/cpl/share_esmf/clm_shmem_mod.F90 index 21d4e128a6..e890572b33 100644 --- a/src/cpl/share_esmf/clm_shmem_mod.F90 +++ b/src/cpl/share_esmf/clm_shmem_mod.F90 @@ -159,6 +159,13 @@ subroutine clm_shmem_alloc_i4_1d(ptr, win, n) if (istat /= 0) call endrun('clm_shmem_mod: allocate failed (mpi-serial path)') win = SHMEM_WIN_NONE #endif + + ! Post-condition: the allocation must have produced an associated pointer of length n. + ! A disassociated ptr here means the shared-memory allocation returned a null base + ! address (e.g. the MPI-3 path being unavailable); catching it now gives a clear error + ! instead of a confusing "reference to disassociated pointer" at the first use of ptr. + if (.not. associated(ptr)) call endrun('clm_shmem_mod: clm_shmem_alloc_i4_1d: allocation did not associate ptr') + if (size(ptr) /= n) call endrun('clm_shmem_mod: clm_shmem_alloc_i4_1d: allocated size does not match n') end subroutine clm_shmem_alloc_i4_1d !============================================================================= @@ -177,6 +184,12 @@ subroutine clm_shmem_leader_allreduce_sum_i4(ptr, win, n) integer :: ierr #endif + ! ptr must be the node-shared buffer of length n created by clm_shmem_alloc_i4_1d. + ! Guard against a caller passing an inconsistent n: the mpi_allreduce and the ptr(1:n) + ! store below would otherwise read or write past the end of the buffer. + if (.not. associated(ptr)) call endrun('clm_shmem_mod: clm_shmem_leader_allreduce_sum_i4: ptr is not associated') + if (size(ptr) /= n) call endrun('clm_shmem_mod: clm_shmem_leader_allreduce_sum_i4: size(ptr) does not match n') + call clm_shmem_fence(win) ! all node stores complete and visible to leader #ifndef NO_MPI2 if (is_leader) then From f0dc92f664380843becf4115d9fd95ecaf79e3af Mon Sep 17 00:00:00 2001 From: Jian Sun Date: Tue, 21 Jul 2026 19:15:42 -0600 Subject: [PATCH 10/12] try to fix izumi error --- src/cpl/share_esmf/clm_shmem_mod.F90 | 177 ++++++++++++++++++++++----- 1 file changed, 144 insertions(+), 33 deletions(-) diff --git a/src/cpl/share_esmf/clm_shmem_mod.F90 b/src/cpl/share_esmf/clm_shmem_mod.F90 index e890572b33..761584316d 100644 --- a/src/cpl/share_esmf/clm_shmem_mod.F90 +++ b/src/cpl/share_esmf/clm_shmem_mod.F90 @@ -44,7 +44,7 @@ module clm_shmem_mod !----------------------------------------------------------------------------- use mpi - use, intrinsic :: iso_c_binding, only : c_ptr, c_f_pointer + use, intrinsic :: iso_c_binding, only : c_ptr, c_f_pointer, c_associated, c_null_ptr use spmdMod , only : mpicom use abortutils, only : endrun @@ -66,12 +66,20 @@ module clm_shmem_mod ! Sentinel window handle used by the mpi-serial fallback (no real MPI window). integer, parameter :: SHMEM_WIN_NONE = -1 - logical, save :: initialized = .false. - integer, save :: node_comm = MPI_COMM_NULL ! ranks sharing a node - integer, save :: leader_comm = MPI_COMM_NULL ! one rank per node (the leaders) - integer, save :: node_rank = 0 ! this rank's index within node_comm (0 => leader) - integer, save :: node_size = 1 ! number of ranks sharing this node - logical, save :: is_leader = .true. + logical, save :: initialized = .false. + integer, save :: node_comm = MPI_COMM_NULL ! ranks sharing a node + integer, save :: leader_comm = MPI_COMM_NULL ! one rank per node (the leaders) + integer, save :: node_rank = 0 ! this rank's index within node_comm (0 => leader) + integer, save :: node_size = 1 ! number of ranks sharing this node + logical, save :: is_leader = .true. ! .true. on node rank 0 + ! Whether the MPI-3 shared-memory path is actually usable on this platform. Decided + ! once by a runtime probe in init_comms(): on some MPI stacks (e.g. certain MVAPICH2 + ! builds) MPI_Win_shared_query returns a null base to non-leaders, which would crash at + ! first use. When the probe fails, the module runs in a "private" fallback mode: every + ! rank keeps its own full-size copy and the leader-reduce becomes a plain MPI_Allreduce + ! over mpicom -- bit-for-bit with the pre-optimization all-rank reduce, just without the + ! per-node memory saving. Stays .false. for the mpi-serial (NO_MPI2) build. + logical, save :: shared_active = .false. contains @@ -104,16 +112,83 @@ subroutine init_comms() color = MPI_UNDEFINED end if call mpi_comm_split(mpicom, color, 0, leader_comm, ierr) + + ! Only trust the MPI-3 shared-memory path if a runtime probe confirms it works + ! end-to-end on this node (see probe_shared_mem and the shared_active comment above). + shared_active = probe_shared_mem() #else - ! mpi-serial: a single task is its own node and its own leader. + ! mpi-serial: a single task is its own node and its own leader; no shared memory. node_rank = 0 node_size = 1 is_leader = .true. + shared_active = .false. #endif initialized = .true. end subroutine init_comms +#ifndef NO_MPI2 + !============================================================================= + logical function probe_shared_mem() result(ok) + ! Verify that MPI-3 shared memory actually works on this node before relying on it. + ! The leader allocates a one-element shared window and writes a sentinel; every rank + ! maps the leader's segment (leader: its own base; peers: MPI_Win_shared_query) and + ! confirms it can read the sentinel back. This catches both a null base pointer and a + ! wrong/garbage mapping. Collective over mpicom. The final agreement is AND-reduced + ! over mpicom (not just node_comm) so the WHOLE job picks one mode: a mix of shared and + ! private ranks would deadlock the later reduce (shared leaders wait on leader_comm + ! while private ranks wait on mpicom). Returns the same value on every rank. + integer, parameter :: SENTINEL = 1234567 + integer(kind=MPI_ADDRESS_KIND) :: winsize, qsize + integer :: ierr, disp_unit, qdisp, itmp, pwin + integer :: iok(1), iok_all(1) + type(c_ptr) :: baseptr + integer, pointer :: p(:) + logical :: have_ptr, have_win + + disp_unit = storage_size(itmp) / 8 + if (is_leader) then + winsize = int(disp_unit, MPI_ADDRESS_KIND) + else + winsize = 0_MPI_ADDRESS_KIND + end if + + ! MPI_Win_allocate_shared is collective over node_comm and returns uniformly within a + ! node; different nodes are independent (each runs its own per-node window ops below). + call mpi_win_allocate_shared(winsize, disp_unit, MPI_INFO_NULL, node_comm, baseptr, pwin, ierr) + have_win = (ierr == MPI_SUCCESS) + + iok(1) = 0 + if (have_win) then + ! Peers replace their (zero-size) base with the leader's segment. + if (.not. is_leader) then + call mpi_win_shared_query(pwin, 0, qsize, qdisp, baseptr, ierr) + if (ierr /= MPI_SUCCESS) baseptr = c_null_ptr + end if + + have_ptr = c_associated(baseptr) + if (have_ptr) call c_f_pointer(baseptr, p, [1]) + + ! The fences are collective over node_comm and this whole node has a window, so all + ! its ranks call them; only the sentinel store/load is guarded by have_ptr. + call mpi_win_fence(0, pwin, ierr) + if (have_ptr .and. is_leader) p(1) = SENTINEL + call mpi_win_fence(0, pwin, ierr) + + if (have_ptr) then + if (p(1) == SENTINEL) iok(1) = 1 + end if + + call mpi_win_free(pwin, ierr) + end if + + ! Whole-job agreement -- every rank reaches this (no early return): shared memory is + ! usable only if EVERY rank mapped and read its node's segment correctly. + call mpi_allreduce(iok, iok_all, 1, MPI_INTEGER, MPI_MIN, mpicom, ierr) + ok = (iok_all(1) == 1) + end function probe_shared_mem +#endif + !============================================================================= subroutine clm_shmem_alloc_i4_1d(ptr, win, n) ! Allocate a node-shared default-integer array of length n. Only the node @@ -122,37 +197,50 @@ subroutine clm_shmem_alloc_i4_1d(ptr, win, n) integer, intent(out) :: win ! MPI window handle for the allocation (pass to clm_shmem_free) integer, intent(in) :: n ! number of elements to allocate (identical on every rank) + integer :: istat #ifndef NO_MPI2 integer(kind=MPI_ADDRESS_KIND) :: winsize, qsize integer :: ierr, disp_unit, qdisp integer :: itmp type(c_ptr) :: baseptr ! shared-segment base address; the MPI-3 win routines return the mapped ! address as a C pointer, which c_f_pointer then turns into the pointer ptr -#else - integer :: istat #endif call init_comms() #ifndef NO_MPI2 - disp_unit = storage_size(itmp) / 8 ! bytes per default integer (robust to -i8) - if (is_leader) then - winsize = int(n, MPI_ADDRESS_KIND) * int(disp_unit, MPI_ADDRESS_KIND) - else - winsize = 0_MPI_ADDRESS_KIND - end if + if (shared_active) then + disp_unit = storage_size(itmp) / 8 ! bytes per default integer (robust to -i8) + if (is_leader) then + winsize = int(n, MPI_ADDRESS_KIND) * int(disp_unit, MPI_ADDRESS_KIND) + else + winsize = 0_MPI_ADDRESS_KIND + end if - call mpi_win_allocate_shared(winsize, disp_unit, MPI_INFO_NULL, node_comm, & - baseptr, win, ierr) - if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_allocate_shared failed') + call mpi_win_allocate_shared(winsize, disp_unit, MPI_INFO_NULL, node_comm, & + baseptr, win, ierr) + if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_allocate_shared failed') - ! Non-leaders learn the address of the leader's (rank 0) contiguous segment. - if (.not. is_leader) then - call mpi_win_shared_query(win, 0, qsize, qdisp, baseptr, ierr) - if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_shared_query failed') - end if + ! Non-leaders learn the address of the leader's (rank 0) contiguous segment. + if (.not. is_leader) then + call mpi_win_shared_query(win, 0, qsize, qdisp, baseptr, ierr) + if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_shared_query failed') + end if - call c_f_pointer(baseptr, ptr, [n]) + ! Guard the base address itself: the associated(ptr) post-condition below cannot + ! detect a null base because c_f_pointer takes the shape from [n], not from baseptr. + ! init_comms's probe should already have set shared_active=.false. wherever this + ! would trip, so reaching this endrun is unexpected. + if (.not. c_associated(baseptr)) & + call endrun('clm_shmem_mod: clm_shmem_alloc_i4_1d: shared-memory base pointer is null') + call c_f_pointer(baseptr, ptr, [n]) + else + ! Real MPI but shared memory is unavailable on this platform: fall back to a + ! private per-rank allocation (freed with deallocate; summed over mpicom). + allocate(ptr(n), stat=istat) + if (istat /= 0) call endrun('clm_shmem_mod: allocate failed (private fallback path)') + win = SHMEM_WIN_NONE + end if #else ! mpi-serial: single task, no shared memory -- a plain local allocation. allocate(ptr(n), stat=istat) @@ -191,10 +279,23 @@ subroutine clm_shmem_leader_allreduce_sum_i4(ptr, win, n) if (size(ptr) /= n) call endrun('clm_shmem_mod: clm_shmem_leader_allreduce_sum_i4: size(ptr) does not match n') call clm_shmem_fence(win) ! all node stores complete and visible to leader + ! (a no-op in private mode; win == SHMEM_WIN_NONE) #ifndef NO_MPI2 - if (is_leader) then + if (shared_active) then + ! Shared mode: the node's partial sum lives in the one shared buffer; the leaders + ! reduce their per-node partials across nodes over leader_comm. + if (is_leader) then + allocate(tmp(n)) + call mpi_allreduce(ptr, tmp, n, MPI_INTEGER, MPI_SUM, leader_comm, ierr) + if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Allreduce failed') + ptr(1:n) = tmp(1:n) + deallocate(tmp) + end if + else + ! Private mode: every rank filled disjoint indices of its own full-size copy, so + ! sum across all ranks over mpicom -- bit-for-bit with the original all-rank reduce. allocate(tmp(n)) - call mpi_allreduce(ptr, tmp, n, MPI_INTEGER, MPI_SUM, leader_comm, ierr) + call mpi_allreduce(ptr, tmp, n, MPI_INTEGER, MPI_SUM, mpicom, ierr) if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Allreduce failed') ptr(1:n) = tmp(1:n) deallocate(tmp) @@ -204,6 +305,7 @@ subroutine clm_shmem_leader_allreduce_sum_i4(ptr, win, n) ! global array -- there is nothing to sum across nodes. #endif call clm_shmem_fence(win) ! publish global result to all node ranks + ! (a no-op in private mode) end subroutine clm_shmem_leader_allreduce_sum_i4 !============================================================================= @@ -213,6 +315,7 @@ subroutine clm_shmem_fence(win) integer, intent(in) :: win #ifndef NO_MPI2 integer :: ierr + if (win == SHMEM_WIN_NONE) return ! private-mode allocation: no window to synchronize call mpi_win_fence(0, win, ierr) if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_fence failed') #endif @@ -226,12 +329,18 @@ subroutine clm_shmem_free_i4_1d(ptr, win) integer, intent(inout) :: win #ifndef NO_MPI2 integer :: ierr - if (win /= MPI_WIN_NULL) then - call mpi_win_free(win, ierr) - if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_free failed') + if (win == SHMEM_WIN_NONE) then + ! private-mode fallback: ptr was a plain local allocation, so deallocate it. + if (associated(ptr)) deallocate(ptr) + else + ! shared-memory window: free it (never deallocate a c_f_pointer'd buffer). + if (win /= MPI_WIN_NULL) then + call mpi_win_free(win, ierr) + if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_free failed') + end if + if (associated(ptr)) nullify(ptr) end if - if (associated(ptr)) nullify(ptr) - win = MPI_WIN_NULL + win = SHMEM_WIN_NONE #else ! mpi-serial: ptr was a plain local allocation, so deallocate it. if (associated(ptr)) deallocate(ptr) @@ -242,7 +351,9 @@ end subroutine clm_shmem_free_i4_1d !============================================================================= logical function clm_shmem_is_leader() call init_comms() - clm_shmem_is_leader = is_leader + ! In private-fallback mode every rank owns its own full-size copy and must initialize + ! it, so every rank reports as a leader; in shared mode only node rank 0 does. + clm_shmem_is_leader = (is_leader .or. .not. shared_active) end function clm_shmem_is_leader !============================================================================= From 436e2b7a4afb4ede2b2a80354d74c7e2e5ed80a0 Mon Sep 17 00:00:00 2001 From: Jian Sun Date: Wed, 22 Jul 2026 15:51:25 -0600 Subject: [PATCH 11/12] rename clm_shmem_mod.F90 to shr_mpishmem_mod.F90, and change the intereface suggested by Erik --- .../share_esmf/lnd_set_decomp_and_domain.F90 | 28 ++-- ...clm_shmem_mod.F90 => shr_mpishmem_mod.F90} | 142 +++++++++--------- 2 files changed, 89 insertions(+), 81 deletions(-) rename src/cpl/share_esmf/{clm_shmem_mod.F90 => shr_mpishmem_mod.F90} (74%) diff --git a/src/cpl/share_esmf/lnd_set_decomp_and_domain.F90 b/src/cpl/share_esmf/lnd_set_decomp_and_domain.F90 index 53b73b017f..5e6adb3529 100644 --- a/src/cpl/share_esmf/lnd_set_decomp_and_domain.F90 +++ b/src/cpl/share_esmf/lnd_set_decomp_and_domain.F90 @@ -21,8 +21,8 @@ module lnd_set_decomp_and_domain use clm_varctl , only : iulog, inst_suffix, FL => fname_len use abortutils , only : endrun use perf_mod , only : t_startf, t_stopf - use clm_shmem_mod, only : clm_shmem_alloc_i4_1d, clm_shmem_free, clm_shmem_fence - use clm_shmem_mod, only : clm_shmem_is_leader, clm_shmem_leader_allreduce_sum_i4 + use shr_mpishmem_mod, only : shr_mpishmem_alloc_i4_1d, shr_mpishmem_free, shr_mpishmem_fence + use shr_mpishmem_mod, only : shr_mpishmem_is_leader, shr_mpishmem_leader_allreduce_sum_i4 implicit none private ! except @@ -189,10 +189,10 @@ subroutine lnd_set_decomp_and_domain_from_readmesh(driver, vm, meshfile_lnd, mes end do ! Deallocate global pointer memory. The cmeps paths allocate lndmask_glob as - ! a per-node shared-memory window (clm_shmem_alloc_i4_1d), so it must be freed - ! with clm_shmem_free, not deallocate; the lilac path uses a plain allocate. + ! a per-node shared-memory window (shr_mpishmem_alloc_i4_1d), so it must be freed + ! with shr_mpishmem_free, not deallocate; the lilac path uses a plain allocate. if (trim(driver) == 'cmeps') then - call clm_shmem_free(lndmask_glob, lndmask_win) + call shr_mpishmem_free(lndmask_glob, lndmask_win) else deallocate(lndmask_glob) end if @@ -538,10 +538,10 @@ subroutine lnd_set_lndmask_from_maskmesh(mesh_lnd, mesh_mask, vm, gsize, lndmask ! Allocate the global land mask once per shared-memory node (not once per rank). ! Leader zeroes it; the compute branch below fills disjoint local points on each - ! rank and sums across nodes (clm_shmem_leader_allreduce_sum_i4). - call clm_shmem_alloc_i4_1d(lndmask_glob, lndmask_win, gsize) - if (clm_shmem_is_leader()) lndmask_glob(:) = 0 - call clm_shmem_fence(lndmask_win) + ! rank and sums across nodes (shr_mpishmem_leader_allreduce_sum_i4). + call shr_mpishmem_alloc_i4_1d(mpicom, lndmask_glob, lndmask_win, gsize) + if (shr_mpishmem_is_leader(mpicom)) lndmask_glob(:) = 0 + call shr_mpishmem_fence(lndmask_win) ! Determine if lndfrac/lndmask file exists inquire(file=trim(flandfrac), exist=lexist) @@ -624,7 +624,7 @@ subroutine lnd_set_lndmask_from_maskmesh(mesh_lnd, mesh_mask, vm, gsize, lndmask do n = 1,lsize_lnd lndmask_glob(gindex_input(n)) = lndmask_loc(n) end do - call clm_shmem_leader_allreduce_sum_i4(lndmask_glob, lndmask_win, gsize) + call shr_mpishmem_leader_allreduce_sum_i4(mpicom, lndmask_glob, lndmask_win, gsize) ! deallocate memory deallocate(maskmask_loc) @@ -680,14 +680,14 @@ subroutine lnd_set_lndmask_from_lndmesh(mesh_lnd, vm, gsize, lndmask_glob, lndma ! Allocate the global land mask once per shared-memory node (not once per rank) ! and build it by summing each rank's disjoint local contributions across nodes ! (the leader-only reduce replaces the all-rank ESMF_VMAllReduce; bit-for-bit). - call clm_shmem_alloc_i4_1d(lndmask_glob, lndmask_win, gsize) - if (clm_shmem_is_leader()) lndmask_glob(:) = 0 - call clm_shmem_fence(lndmask_win) + call shr_mpishmem_alloc_i4_1d(mpicom, lndmask_glob, lndmask_win, gsize) + if (shr_mpishmem_is_leader(mpicom)) lndmask_glob(:) = 0 + call shr_mpishmem_fence(lndmask_win) do n = 1,lsize lndmask_glob(gindex(n)) = lndmask_loc(n) end do - call clm_shmem_leader_allreduce_sum_i4(lndmask_glob, lndmask_win, gsize) + call shr_mpishmem_leader_allreduce_sum_i4(mpicom, lndmask_glob, lndmask_win, gsize) deallocate(gindex) deallocate(lndmask_loc) diff --git a/src/cpl/share_esmf/clm_shmem_mod.F90 b/src/cpl/share_esmf/shr_mpishmem_mod.F90 similarity index 74% rename from src/cpl/share_esmf/clm_shmem_mod.F90 rename to src/cpl/share_esmf/shr_mpishmem_mod.F90 index 761584316d..c0ea316d21 100644 --- a/src/cpl/share_esmf/clm_shmem_mod.F90 +++ b/src/cpl/share_esmf/shr_mpishmem_mod.F90 @@ -1,31 +1,33 @@ -module clm_shmem_mod +module shr_mpishmem_mod !----------------------------------------------------------------------------- ! Per-node MPI-3 shared-memory helper for large arrays that would otherwise be ! replicated identically on every MPI rank. One physical copy is allocated per ! shared-memory node and mapped into every rank on that node, freeing ! (ranks_per_node - 1) copies per node. ! - ! Ported from CAM's cam_shmem_mod (src/utils/cam_shmem_mod.F90) and specialized - ! for the CTSM decomposition setup: it provides a default-integer rank-1 - ! allocator (the CAM module only has real r4/r8 2d-5d wrappers) plus a + ! Ported from CAM's cam_shmem_mod (src/utils/cam_shmem_mod.F90) and generalized + ! into a self-contained shared-memory utility: it provides a default-integer + ! rank-1 allocator (the CAM module only has real r4/r8 2d-5d wrappers) plus a ! node-leader sum-reduce that builds a globally-summed array in a node-shared - ! buffer without every rank holding its own global-sized copy. + ! buffer without every rank holding its own global-sized copy. The MPI + ! communicator is supplied by the caller on every entry point, so this module + ! has no dependency on any model-specific decomposition or SPMD module. ! - ! Usage (collective over the land communicator mpicom): - ! call clm_shmem_alloc_i4_1d(ptr, win, n) ! all ranks - ! if (clm_shmem_is_leader()) ptr(:) = 0 ! leader owns the storage - ! call clm_shmem_fence(win) ! publish the zeros + ! Usage (collective over the communicator mpicom supplied by the caller): + ! call shr_mpishmem_alloc_i4_1d(mpicom, ptr, win, n) ! all ranks + ! if (shr_mpishmem_is_leader(mpicom)) ptr(:) = 0 ! leader owns the storage + ! call shr_mpishmem_fence(win) ! publish the zeros ! - ! call clm_shmem_leader_allreduce_sum_i4(ptr,win,n) ! fence; sum across nodes; fence + ! call shr_mpishmem_leader_allreduce_sum_i4(mpicom,ptr,win,n) ! fence; sum across nodes; fence ! - ! call clm_shmem_free(ptr, win) ! collective over the node comm + ! call shr_mpishmem_free(ptr, win) ! collective over the node comm ! ! Terminology (MPI-3 shared-memory concepts used throughout this module): ! window - the shared allocation itself (an "MPI window", type MPI_Win), created once ! per node and mapped into the address space of every rank on that node; "win" ! is the integer handle used to reference and later free it. ! leader - the single rank per node that owns the physical storage (node-local rank 0, - ! clm_shmem_is_leader()); it is the only rank that requests the allocation, + ! shr_mpishmem_is_leader()); it is the only rank that requests the allocation, ! initializes it, and reduces across nodes. ! fence - an MPI_Win_fence synchronization: a collective call over the node that makes ! stores issued by one rank visible to the other ranks sharing the window. @@ -45,23 +47,22 @@ module clm_shmem_mod use mpi use, intrinsic :: iso_c_binding, only : c_ptr, c_f_pointer, c_associated, c_null_ptr - use spmdMod , only : mpicom - use abortutils, only : endrun + use shr_sys_mod, only : shr_sys_abort implicit none private - public :: clm_shmem_alloc_i4_1d ! allocate a node-shared default-integer rank-1 array - public :: clm_shmem_leader_allreduce_sum_i4 ! sum a node-shared array across nodes, in place - public :: clm_shmem_free ! free a node-shared array (MPI_Win_free) - public :: clm_shmem_fence ! synchronize a window (publish writes) - public :: clm_shmem_is_leader ! .true. on the leader (rank 0) of this node - public :: clm_shmem_leader_comm ! communicator containing only node leaders - public :: clm_shmem_npes_per_node ! number of ranks sharing this node + public :: shr_mpishmem_alloc_i4_1d ! allocate a node-shared default-integer rank-1 array + public :: shr_mpishmem_leader_allreduce_sum_i4 ! sum a node-shared array across nodes, in place + public :: shr_mpishmem_free ! free a node-shared array (MPI_Win_free) + public :: shr_mpishmem_fence ! synchronize a window (publish writes) + public :: shr_mpishmem_is_leader ! .true. on the leader (rank 0) of this node + public :: shr_mpishmem_leader_comm ! communicator containing only node leaders + public :: shr_mpishmem_npes_per_node ! number of ranks sharing this node - interface clm_shmem_free - module procedure clm_shmem_free_i4_1d - end interface clm_shmem_free + interface shr_mpishmem_free + module procedure shr_mpishmem_free_i4_1d + end interface shr_mpishmem_free ! Sentinel window handle used by the mpi-serial fallback (no real MPI window). integer, parameter :: SHMEM_WIN_NONE = -1 @@ -84,7 +85,7 @@ module clm_shmem_mod contains !============================================================================= - subroutine init_comms() + subroutine init_comms(mpicom) ! Lazily build the node-local and node-leader communicators. Collective over ! mpicom; safe to call from every shared-memory request. ! @@ -92,6 +93,7 @@ subroutine init_comms() ! MPI-2/MPI-3 one-sided and shared-memory routines. Throughout this module, therefore, ! "#ifndef NO_MPI2" selects the real-MPI shared-memory path and the "#else" branch ! selects the single-task mpi-serial fallback. + integer, intent(in) :: mpicom ! communicator to build the node/leader comms over #ifndef NO_MPI2 integer :: ierr, color #endif @@ -115,7 +117,7 @@ subroutine init_comms() ! Only trust the MPI-3 shared-memory path if a runtime probe confirms it works ! end-to-end on this node (see probe_shared_mem and the shared_active comment above). - shared_active = probe_shared_mem() + shared_active = probe_shared_mem(mpicom) #else ! mpi-serial: a single task is its own node and its own leader; no shared memory. node_rank = 0 @@ -129,7 +131,7 @@ end subroutine init_comms #ifndef NO_MPI2 !============================================================================= - logical function probe_shared_mem() result(ok) + logical function probe_shared_mem(mpicom) result(ok) ! Verify that MPI-3 shared memory actually works on this node before relying on it. ! The leader allocates a one-element shared window and writes a sentinel; every rank ! maps the leader's segment (leader: its own base; peers: MPI_Win_shared_query) and @@ -138,6 +140,7 @@ logical function probe_shared_mem() result(ok) ! over mpicom (not just node_comm) so the WHOLE job picks one mode: a mix of shared and ! private ranks would deadlock the later reduce (shared leaders wait on leader_comm ! while private ranks wait on mpicom). Returns the same value on every rank. + integer, intent(in) :: mpicom integer, parameter :: SENTINEL = 1234567 integer(kind=MPI_ADDRESS_KIND) :: winsize, qsize integer :: ierr, disp_unit, qdisp, itmp, pwin @@ -190,11 +193,12 @@ end function probe_shared_mem #endif !============================================================================= - subroutine clm_shmem_alloc_i4_1d(ptr, win, n) + subroutine shr_mpishmem_alloc_i4_1d(mpicom, ptr, win, n) ! Allocate a node-shared default-integer array of length n. Only the node ! leader requests storage; peers map the leader's contiguous segment. + integer, intent(in) :: mpicom ! communicator the node/leader comms are built over integer, pointer, intent(out) :: ptr(:) ! Fortran pointer mapped onto the node-shared buffer - integer, intent(out) :: win ! MPI window handle for the allocation (pass to clm_shmem_free) + integer, intent(out) :: win ! MPI window handle for the allocation (pass to shr_mpishmem_free) integer, intent(in) :: n ! number of elements to allocate (identical on every rank) integer :: istat @@ -206,7 +210,7 @@ subroutine clm_shmem_alloc_i4_1d(ptr, win, n) ! address as a C pointer, which c_f_pointer then turns into the pointer ptr #endif - call init_comms() + call init_comms(mpicom) #ifndef NO_MPI2 if (shared_active) then @@ -219,32 +223,32 @@ subroutine clm_shmem_alloc_i4_1d(ptr, win, n) call mpi_win_allocate_shared(winsize, disp_unit, MPI_INFO_NULL, node_comm, & baseptr, win, ierr) - if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_allocate_shared failed') + if (ierr /= MPI_SUCCESS) call shr_sys_abort('shr_mpishmem_mod: MPI_Win_allocate_shared failed') ! Non-leaders learn the address of the leader's (rank 0) contiguous segment. if (.not. is_leader) then call mpi_win_shared_query(win, 0, qsize, qdisp, baseptr, ierr) - if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_shared_query failed') + if (ierr /= MPI_SUCCESS) call shr_sys_abort('shr_mpishmem_mod: MPI_Win_shared_query failed') end if ! Guard the base address itself: the associated(ptr) post-condition below cannot ! detect a null base because c_f_pointer takes the shape from [n], not from baseptr. ! init_comms's probe should already have set shared_active=.false. wherever this - ! would trip, so reaching this endrun is unexpected. + ! would trip, so reaching this abort is unexpected. if (.not. c_associated(baseptr)) & - call endrun('clm_shmem_mod: clm_shmem_alloc_i4_1d: shared-memory base pointer is null') + call shr_sys_abort('shr_mpishmem_mod: shr_mpishmem_alloc_i4_1d: shared-memory base pointer is null') call c_f_pointer(baseptr, ptr, [n]) else ! Real MPI but shared memory is unavailable on this platform: fall back to a ! private per-rank allocation (freed with deallocate; summed over mpicom). allocate(ptr(n), stat=istat) - if (istat /= 0) call endrun('clm_shmem_mod: allocate failed (private fallback path)') + if (istat /= 0) call shr_sys_abort('shr_mpishmem_mod: allocate failed (private fallback path)') win = SHMEM_WIN_NONE end if #else ! mpi-serial: single task, no shared memory -- a plain local allocation. allocate(ptr(n), stat=istat) - if (istat /= 0) call endrun('clm_shmem_mod: allocate failed (mpi-serial path)') + if (istat /= 0) call shr_sys_abort('shr_mpishmem_mod: allocate failed (mpi-serial path)') win = SHMEM_WIN_NONE #endif @@ -252,17 +256,18 @@ subroutine clm_shmem_alloc_i4_1d(ptr, win, n) ! A disassociated ptr here means the shared-memory allocation returned a null base ! address (e.g. the MPI-3 path being unavailable); catching it now gives a clear error ! instead of a confusing "reference to disassociated pointer" at the first use of ptr. - if (.not. associated(ptr)) call endrun('clm_shmem_mod: clm_shmem_alloc_i4_1d: allocation did not associate ptr') - if (size(ptr) /= n) call endrun('clm_shmem_mod: clm_shmem_alloc_i4_1d: allocated size does not match n') - end subroutine clm_shmem_alloc_i4_1d + if (.not. associated(ptr)) call shr_sys_abort('shr_mpishmem_mod: shr_mpishmem_alloc_i4_1d: allocation did not associate ptr') + if (size(ptr) /= n) call shr_sys_abort('shr_mpishmem_mod: shr_mpishmem_alloc_i4_1d: allocated size does not match n') + end subroutine shr_mpishmem_alloc_i4_1d !============================================================================= - subroutine clm_shmem_leader_allreduce_sum_i4(ptr, win, n) + subroutine shr_mpishmem_leader_allreduce_sum_i4(mpicom, ptr, win, n) ! Build a globally-summed array in the node-shared buffer ptr(1:n): fence so ! every rank's stores are visible, then the node leaders sum their per-node ! partials across nodes (over leader_comm) into the shared buffer, then fence ! to publish the result to all ranks on the node. Collective over node_comm; ! every rank on the node must call it. + integer, intent(in) :: mpicom ! communicator for the private-mode fallback reduce integer, pointer, intent(inout) :: ptr(:) integer, intent(in) :: win integer, intent(in) :: n @@ -272,13 +277,13 @@ subroutine clm_shmem_leader_allreduce_sum_i4(ptr, win, n) integer :: ierr #endif - ! ptr must be the node-shared buffer of length n created by clm_shmem_alloc_i4_1d. + ! ptr must be the node-shared buffer of length n created by shr_mpishmem_alloc_i4_1d. ! Guard against a caller passing an inconsistent n: the mpi_allreduce and the ptr(1:n) ! store below would otherwise read or write past the end of the buffer. - if (.not. associated(ptr)) call endrun('clm_shmem_mod: clm_shmem_leader_allreduce_sum_i4: ptr is not associated') - if (size(ptr) /= n) call endrun('clm_shmem_mod: clm_shmem_leader_allreduce_sum_i4: size(ptr) does not match n') + if (.not. associated(ptr)) call shr_sys_abort('shr_mpishmem_mod: shr_mpishmem_leader_allreduce_sum_i4: ptr is not associated') + if (size(ptr) /= n) call shr_sys_abort('shr_mpishmem_mod: shr_mpishmem_leader_allreduce_sum_i4: size(ptr) does not match n') - call clm_shmem_fence(win) ! all node stores complete and visible to leader + call shr_mpishmem_fence(win) ! all node stores complete and visible to leader ! (a no-op in private mode; win == SHMEM_WIN_NONE) #ifndef NO_MPI2 if (shared_active) then @@ -287,7 +292,7 @@ subroutine clm_shmem_leader_allreduce_sum_i4(ptr, win, n) if (is_leader) then allocate(tmp(n)) call mpi_allreduce(ptr, tmp, n, MPI_INTEGER, MPI_SUM, leader_comm, ierr) - if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Allreduce failed') + if (ierr /= MPI_SUCCESS) call shr_sys_abort('shr_mpishmem_mod: MPI_Allreduce failed') ptr(1:n) = tmp(1:n) deallocate(tmp) end if @@ -296,7 +301,7 @@ subroutine clm_shmem_leader_allreduce_sum_i4(ptr, win, n) ! sum across all ranks over mpicom -- bit-for-bit with the original all-rank reduce. allocate(tmp(n)) call mpi_allreduce(ptr, tmp, n, MPI_INTEGER, MPI_SUM, mpicom, ierr) - if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Allreduce failed') + if (ierr /= MPI_SUCCESS) call shr_sys_abort('shr_mpishmem_mod: MPI_Allreduce failed') ptr(1:n) = tmp(1:n) deallocate(tmp) end if @@ -304,12 +309,12 @@ subroutine clm_shmem_leader_allreduce_sum_i4(ptr, win, n) ! mpi-serial: the single task owns the whole domain, so ptr already holds the ! global array -- there is nothing to sum across nodes. #endif - call clm_shmem_fence(win) ! publish global result to all node ranks + call shr_mpishmem_fence(win) ! publish global result to all node ranks ! (a no-op in private mode) - end subroutine clm_shmem_leader_allreduce_sum_i4 + end subroutine shr_mpishmem_leader_allreduce_sum_i4 !============================================================================= - subroutine clm_shmem_fence(win) + subroutine shr_mpishmem_fence(win) ! Collective over the node communicator; synchronizes the window so stores ! become visible to all ranks on the node. A no-op for the mpi-serial path. integer, intent(in) :: win @@ -317,12 +322,12 @@ subroutine clm_shmem_fence(win) integer :: ierr if (win == SHMEM_WIN_NONE) return ! private-mode allocation: no window to synchronize call mpi_win_fence(0, win, ierr) - if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_fence failed') + if (ierr /= MPI_SUCCESS) call shr_sys_abort('shr_mpishmem_mod: MPI_Win_fence failed') #endif - end subroutine clm_shmem_fence + end subroutine shr_mpishmem_fence !============================================================================= - subroutine clm_shmem_free_i4_1d(ptr, win) + subroutine shr_mpishmem_free_i4_1d(ptr, win) ! Free the node-shared window and disassociate the pointer. Collective over ! the node communicator; a no-op when win == MPI_WIN_NULL. integer, pointer :: ptr(:) @@ -336,7 +341,7 @@ subroutine clm_shmem_free_i4_1d(ptr, win) ! shared-memory window: free it (never deallocate a c_f_pointer'd buffer). if (win /= MPI_WIN_NULL) then call mpi_win_free(win, ierr) - if (ierr /= MPI_SUCCESS) call endrun('clm_shmem_mod: MPI_Win_free failed') + if (ierr /= MPI_SUCCESS) call shr_sys_abort('shr_mpishmem_mod: MPI_Win_free failed') end if if (associated(ptr)) nullify(ptr) end if @@ -346,26 +351,29 @@ subroutine clm_shmem_free_i4_1d(ptr, win) if (associated(ptr)) deallocate(ptr) win = SHMEM_WIN_NONE #endif - end subroutine clm_shmem_free_i4_1d + end subroutine shr_mpishmem_free_i4_1d !============================================================================= - logical function clm_shmem_is_leader() - call init_comms() + logical function shr_mpishmem_is_leader(mpicom) + integer, intent(in) :: mpicom + call init_comms(mpicom) ! In private-fallback mode every rank owns its own full-size copy and must initialize ! it, so every rank reports as a leader; in shared mode only node rank 0 does. - clm_shmem_is_leader = (is_leader .or. .not. shared_active) - end function clm_shmem_is_leader + shr_mpishmem_is_leader = (is_leader .or. .not. shared_active) + end function shr_mpishmem_is_leader !============================================================================= - integer function clm_shmem_leader_comm() - call init_comms() - clm_shmem_leader_comm = leader_comm - end function clm_shmem_leader_comm + integer function shr_mpishmem_leader_comm(mpicom) + integer, intent(in) :: mpicom + call init_comms(mpicom) + shr_mpishmem_leader_comm = leader_comm + end function shr_mpishmem_leader_comm !============================================================================= - integer function clm_shmem_npes_per_node() - call init_comms() - clm_shmem_npes_per_node = node_size - end function clm_shmem_npes_per_node + integer function shr_mpishmem_npes_per_node(mpicom) + integer, intent(in) :: mpicom + call init_comms(mpicom) + shr_mpishmem_npes_per_node = node_size + end function shr_mpishmem_npes_per_node -end module clm_shmem_mod +end module shr_mpishmem_mod From 8716b48f3b18b934aa6a76b64146270210f43d6f Mon Sep 17 00:00:00 2001 From: Jian Sun Date: Wed, 22 Jul 2026 16:00:09 -0600 Subject: [PATCH 12/12] move shr_mpishmem_mod.F90 to src/utils --- src/{cpl/share_esmf => utils}/shr_mpishmem_mod.F90 | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/{cpl/share_esmf => utils}/shr_mpishmem_mod.F90 (100%) diff --git a/src/cpl/share_esmf/shr_mpishmem_mod.F90 b/src/utils/shr_mpishmem_mod.F90 similarity index 100% rename from src/cpl/share_esmf/shr_mpishmem_mod.F90 rename to src/utils/shr_mpishmem_mod.F90