diff --git a/CMakeLists.txt b/CMakeLists.txt index 04007e378..a6f84e8ab 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -241,7 +241,11 @@ if (MPAS) mpas/module_mpas_config.F90 mpas/module_fcst_grid_comp.F90 mpas/atmos_coupling.F90 + mpas/ufs_mpas_tools.F90 mpas/ufs_mpas_subdriver.F90 + mpas/ufs_mpas_io.F90 + mpas/ufs_mpas_boundaries.F90 + mpas/ufs_mpas_constituents.F90 ${coupling_srcs} ${io_srcs} ccpp/data/MPAS_typedefs.F90 diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 156e91efc..c719a8f04 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -5537,26 +5537,45 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, & if( Model%ntoz <= 0 ) & Model%ntoz = get_physics_tracer_index('spo3', Model) #endif - Model%ntcw = get_physics_tracer_index('liq_wat', Model) - Model%ntiw = get_physics_tracer_index('ice_wat', Model) - Model%ntrw = get_physics_tracer_index('rainwat', Model) - Model%ntsw = get_physics_tracer_index('snowwat', Model) - Model%ntgl = get_physics_tracer_index('graupel', Model) - Model%nthl = get_physics_tracer_index('hailwat', Model) - Model%ntclamt = get_physics_tracer_index('cld_amt', Model) - Model%ntlnc = get_physics_tracer_index('water_nc', Model) - Model%ntinc = get_physics_tracer_index('ice_nc', Model) - Model%ntrnc = get_physics_tracer_index('rain_nc', Model) - Model%ntsnc = get_physics_tracer_index('snow_nc', Model) - Model%ntgnc = get_physics_tracer_index('graupel_nc', Model) - Model%nthnc = get_physics_tracer_index('hail_nc', Model) - Model%ntccn = get_physics_tracer_index('ccn_nc', Model) - Model%ntccna = get_physics_tracer_index('ccna_nc', Model) - Model%ntgv = get_physics_tracer_index('graupel_vol', Model) - Model%nthv = get_physics_tracer_index('hail_vol', Model) - Model%ntrz = get_physics_tracer_index('rain_ref', Model) - Model%ntgz = get_physics_tracer_index('graupel_ref', Model) - Model%nthz = get_physics_tracer_index('hail_ref', Model) + if (Model%dycore_active == Model%dycore_fv3) then + Model%ntcw = get_physics_tracer_index('liq_wat', Model) + Model%ntiw = get_physics_tracer_index('ice_wat', Model) + Model%ntrw = get_physics_tracer_index('rainwat', Model) + Model%ntsw = get_physics_tracer_index('snowwat', Model) + Model%ntgl = get_physics_tracer_index('graupel', Model) + Model%nthl = get_physics_tracer_index('hailwat', Model) + Model%ntclamt = get_physics_tracer_index('cld_amt', Model) + Model%ntlnc = get_physics_tracer_index('water_nc', Model) + Model%ntinc = get_physics_tracer_index('ice_nc', Model) + Model%ntrnc = get_physics_tracer_index('rain_nc', Model) + Model%ntsnc = get_physics_tracer_index('snow_nc', Model) + Model%ntgnc = get_physics_tracer_index('graupel_nc', Model) + Model%nthnc = get_physics_tracer_index('hail_nc', Model) + Model%ntccn = get_physics_tracer_index('ccn_nc', Model) + Model%ntccna = get_physics_tracer_index('ccna_nc', Model) + Model%ntgv = get_physics_tracer_index('graupel_vol', Model) + Model%nthv = get_physics_tracer_index('hail_vol', Model) + Model%ntrz = get_physics_tracer_index('rain_ref', Model) + Model%ntgz = get_physics_tracer_index('graupel_ref', Model) + Model%nthz = get_physics_tracer_index('hail_ref', Model) + Model%ntwa = get_physics_tracer_index('liq_aero', Model) + Model%ntia = get_physics_tracer_index('ice_aero', Model) + endif + if (Model%dycore_active == Model%dycore_mpas) then + Model%ntcw = get_physics_tracer_index('qc', Model) + Model%ntiw = get_physics_tracer_index('qi', Model) + Model%ntrw = get_physics_tracer_index('qr', Model) + Model%ntsw = get_physics_tracer_index('qs', Model) + Model%ntgl = get_physics_tracer_index('qg', Model) + Model%nthl = get_physics_tracer_index('qh', Model) + Model%ntinc = get_physics_tracer_index('ni', Model) + Model%ntrnc = get_physics_tracer_index('nr', Model) + Model%ntsnc = get_physics_tracer_index('ns', Model) + Model%ntgnc = get_physics_tracer_index('ng', Model) + Model%nthnc = get_physics_tracer_index('nh', Model) + Model%ntwa = get_physics_tracer_index('nwfa', Model) + Model%ntia = get_physics_tracer_index('nifa', Model) + endif Model%ntke = get_physics_tracer_index('sgs_tke', Model) Model%ntsigma = get_physics_tracer_index('sigmab', Model) Model%ntomega = get_physics_tracer_index('omegab', Model) @@ -6911,9 +6930,12 @@ subroutine control_print(Model) if (Model%dycore_active == Model%dycore_fv3) then print *, ' hydrostatic : ', Model%hydrostatic endif - print *, ' ' - print *, 'grid extent parameters' - if (Model%dycore_active == Model%dycore_fv3) then + endif + + if (Model%dycore_active == Model%dycore_fv3) then + if (Model%me == Model%master) then + print *, ' ' + print *, 'grid extent parameters (FV3)' print *, ' isc : ', Model%isc print *, ' jsc : ', Model%jsc print *, ' nx : ', Model%nx @@ -6924,10 +6946,18 @@ subroutine control_print(Model) print *, ' lonr : ', Model%lonr print *, ' latr : ', Model%latr end if + endif + + if (Model%dycore_active == Model%dycore_mpas) then + print *, ' ' + print *, 'grid extent parameters (MPAS) for processor ',Model%me print *, ' nblks : ', Model%nblks print *, ' blksz(1) : ', Model%blksz(1) print *, ' blksz(nblks) : ', Model%blksz(Model%nblks) print *, ' Model%ncols : ', Model%ncols + endif + + if (Model%me == Model%master) then print *, ' ' print *, 'coupling parameters' print *, ' cplflx : ', Model%cplflx diff --git a/ccpp/physics b/ccpp/physics index a57d1a6e4..6904ad4b5 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit a57d1a6e412819893067bae38f9e2eae1a0680f4 +Subproject commit 6904ad4b5563ca1a63203993b35fa68de794340f diff --git a/mpas/CMakeLists.txt b/mpas/CMakeLists.txt index ea02adabd..2937e7033 100644 --- a/mpas/CMakeLists.txt +++ b/mpas/CMakeLists.txt @@ -42,6 +42,8 @@ install(DIRECTORY ${CMAKE_BINARY_DIR}/${MPAS_MODULE_DIR}/ DESTINATION ${CMAKE_IN ############################################################################### # Build MPAS libraries... ############################################################################### +add_definitions(-DMPAS_CAM_DYCORE) +add_definitions(-DMPAS_UFS_DYCORE) # MPAS Utilities (Externals) add_subdirectory(MPAS-Model/src/external/ezxml) diff --git a/mpas/MPAS-Model b/mpas/MPAS-Model index 38d2177ae..99890240d 160000 --- a/mpas/MPAS-Model +++ b/mpas/MPAS-Model @@ -1 +1 @@ -Subproject commit 38d2177aef842a5c6abe26ffe876804b95fd9e0a +Subproject commit 99890240d93a6b28a75f84c9f7248161797656ae diff --git a/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 index cd18a2284..d4c33e220 100644 --- a/mpas/atmos_coupling.F90 +++ b/mpas/atmos_coupling.F90 @@ -4,21 +4,19 @@ !> ! ########################################################################################### module atmos_coupling_mod - use mpas_kind_types, only : mpas_kind => RKIND - use ufs_mpas_subdriver, only : domain_ptr + use mpas_kind_types, only : mpas_kind => RKIND + use ufs_mpas_io, only : domain_ptr implicit none public :: MPAS_statein_type public :: MPAS_stateout_type public :: ufs_mpas_to_physics - public :: ufs_physics_to_mpas + public :: ufs_microphysics_to_mpas + public :: ufs_mpas_to_microphysics + public :: ufs_mpas_grid_to_physics - ! Indices for MPAS domain deceomposition on each task. - integer, dimension(:), pointer :: indicesGlobal - !> ####################################################################################### !> MPAS_statein_type - !> !> Fields needed by the MPAS dynamical core for forward integration. !> !> ####################################################################################### @@ -34,7 +32,7 @@ module atmos_coupling_mod integer, pointer :: nVerticesSolve ! Number of vertices, excluding halo vertices ! MPAS vertical coordiante (invariant) - real(mpas_kind), pointer :: zint(:,:) ! Geometric height [m] at layer interfaces (nlev+1,ncol) + real(mpas_kind), pointer :: zgrid(:,:) ! Geometric height [m] at layer interfaces (nlev+1,ncol) real(mpas_kind), pointer :: zz(:,:) ! Vertical coordinate metric [1] at layer ! midpoints (nlev,ncol) real(mpas_kind), pointer :: fzm(:) ! Interp weight from k layer midpoint to k @@ -84,12 +82,17 @@ module atmos_coupling_mod real(mpas_kind), pointer :: rho_tend(:,:) ! Dry air density tendency ! from physics [kg/m^3/s] (nlev,ncol) + ! Diagnostics + real(mpas_kind), pointer :: pressure_b(:,:) + real(mpas_kind), pointer :: pressure_p(:,:) + real(mpas_kind), pointer :: surface_pressure(:) + end type MPAS_statein_type !> ####################################################################################### !> MPAS_stateout_type - !> !> Fields prognosed (or diagnosed) by the MPAS dynamical core. + !> !> ####################################################################################### type MPAS_stateout_type ! Dimensions @@ -103,7 +106,7 @@ module atmos_coupling_mod integer, pointer :: nVerticesSolve ! Number of vertices, excluding halo vertices ! MPAS vertical coordiante (invariant) - real(mpas_kind), pointer :: zint(:,:) ! Geometric height [m] at layer interfaces (nlev+1,ncol) + real(mpas_kind), pointer :: zgrid(:,:) ! Geometric height [m] at layer interfaces (nlev+1,ncol) real(mpas_kind), pointer :: zz(:,:) ! Vertical coordinate metric [1] at layer ! midpoints (nlev,ncol) real(mpas_kind), pointer :: fzm(:) ! Interp weight from k layer midpoint to k @@ -137,37 +140,56 @@ module atmos_coupling_mod ! (nlev,nvtx) real(mpas_kind), pointer :: divergence(:,:) ! Horizontal velocity divergence [s^-1] ! (nlev,ncol) + ! Diagnostics + real(mpas_kind), pointer :: pressure_b(:,:) + real(mpas_kind), pointer :: pressure_p(:,:) + real(mpas_kind), pointer :: surface_pressure(:) + end type MPAS_stateout_type contains !> ######################################################################################### - !> Procedure to populate inputs to the CCPP physics using outputs the MPAS dynamical core. + !> Procedure to convert input "MPAS" variables to "CCPP" variables. + !> Called prior to MPAS dynamical core (initial-step only). + !> + !> Analogous to MPAS_to_physics in src/core_atmosphere/physics/mpas_atmphys_interface.F !> - !> Use indicesGlobal to map from MPAS dycore deceomposition to CCPP Physics contiguous data - !> structures. + !> This procedure accesses MPAS data using MPAS native procedures and stores the data + !> locally in the data-containers defined above. The MPAS "state" is then translated to the + !> CCPP "state" needed by the physics. !> !> ######################################################################################### - subroutine ufs_mpas_to_physics(physics_state) - use GFS_typedefs, only : GFS_statein_type + subroutine ufs_mpas_to_physics(physics_state, surface_state) + use GFS_typedefs, only : GFS_statein_type, GFS_sfcprop_type use mpas_derived_types, only : mpas_pool_type use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_array, mpas_pool_get_dimension use atm_core, only : atm_compute_output_diagnostics use mpas_kind_types, only : RKIND + use mpas_constants, only : gravity + ! Arguments type(GFS_statein_type), intent(inout) :: physics_state + type(GFS_sfcprop_type), intent(inout) :: surface_state ! Locals type(mpas_stateout_type) :: mpas_state type(mpas_pool_type), pointer :: state_pool type(mpas_pool_type), pointer :: diag_pool type(mpas_pool_type), pointer :: mesh_pool - integer :: iCell, iCol, iTracer - integer, pointer :: nCellsSolve, num_scalars, nwat, index_qv, nVertLevels - real(RKIND), pointer :: surface_p(:) + type(mpas_pool_type), pointer :: sfc_pool + integer :: iCol, iLay, iTracer + integer, pointer :: nCellsSolve, num_scalars, nwat, nVertLevels, index_qv + integer, dimension(:), pointer :: isltyp + real(kind=RKIND) :: rho1, rho2, tem1, tem2 + real(kind=RKIND),dimension(:,:),pointer :: qv, qc, qr, qi, qs, qg ! Access MPAS data pools. - call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state_pool) - call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'diag', diag_pool) - call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', mesh_pool) + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state_pool) + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'diag', diag_pool) + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', mesh_pool) + + ! DJS to GFS: Sanity check to ensure data is in "sfc_pool" to pass to physics types. + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'sfc_input', sfc_pool) + call mpas_pool_get_array(sfc_pool, 'isltyp', isltyp, 1) ! Get MPAS dimensions call mpas_pool_get_dimension(mesh_pool, 'nCellsSolve', nCellsSolve) @@ -183,64 +205,175 @@ subroutine ufs_mpas_to_physics(physics_state) call mpas_pool_get_array(state_pool, 'scalars', MPAS_state % tracers, timeLevel=1) call mpas_pool_get_array(state_pool, 'w', MPAS_state % w, timeLevel=1) call mpas_pool_get_array(diag_pool, 'exner', MPAS_state % exner) - call mpas_pool_get_array(mesh_pool, 'zgrid', MPAS_state % zint) + call mpas_pool_get_array(mesh_pool, 'zgrid', MPAS_state % zgrid) call mpas_pool_get_array(mesh_pool, 'zz', MPAS_state % zz) call mpas_pool_get_array(state_pool, 'theta_m', MPAS_state % theta_m, timeLevel=1) call mpas_pool_get_array(state_pool, 'rho_zz', MPAS_state % rho_zz, timeLevel=1) + call mpas_pool_get_array(diag_pool, 'pressure_base', MPAS_state % pressure_b) + call mpas_pool_get_array(diag_pool, 'pressure_p', MPAS_state % pressure_p) ! Copy fields from MPAS data containers to physics data containers. ! [k, i] -> [i, k] - ! bottom-up -> top-down ordering convention - do iCell = 1, nCellsSolve - iCol = indicesGlobal(iCell) - physics_state % tgrs(iCol,:) = MPAS_state % theta(nVertLevels:1:-1,iCell) - physics_state % ugrs(iCol,:) = MPAS_state % ux(nVertLevels:1:-1,iCell) - physics_state % vgrs(iCol,:) = MPAS_state % uy(nVertLevels:1:-1,iCell) - physics_state % phil(iCol,:) = MPAS_state % zz(nVertLevels:1:-1,iCell) - physics_state % phii(iCol,:) = MPAS_state % zint(nVertLevels+1:1:-1,iCell) - physics_state % prslk(iCol,:) = MPAS_state % exner(nVertLevels:1:-1,iCell) - physics_state % vvl(iCol,:) = MPAS_state % w(nVertLevels:1:-1,iCell) + ! Retain bottom-up convention + do iCol = 1, nCellsSolve + physics_state % tgrs(iCol,:) = MPAS_state % theta(:,iCol)*MPAS_state % exner(:,iCol) + physics_state % ugrs(iCol,:) = MPAS_state % ux(:,iCol) + physics_state % vgrs(iCol,:) = MPAS_state % uy(:,iCol) + physics_state % phil(iCol,:) = MPAS_state % zz(:,iCol) + physics_state % phii(iCol,:) = MPAS_state % zgrid(:,iCol) + physics_state % prslk(iCol,:) = MPAS_state % exner(:,iCol) + ! MPAS provides vertical velocity at interfaces, compute layer mean. + do iLay=1,nVertLevels + physics_state % vvl(iCol,iLay) = 0.5*(MPAS_state % w(iLay,iCol) + MPAS_state % w(iLay+1,iCol)) + enddo do iTracer = 1,num_scalars - physics_state % qgrs(iCol,:,iTracer) = MPAS_state % tracers(iTracer,nVertLevels:1:-1,iCell) + physics_state % qgrs(iCol,:,iTracer) = MPAS_state % tracers(iTracer,:,iCol) enddo + enddo + + ! Set surface temperature to lowest level temperature (revisit for coupling) + do iCol = 1, nCellsSolve + surface_state % tsfc(iCol) = MPAS_state % theta(1,iCol)*MPAS_state % exner(1,iCol) enddo + ! Calculation of the surface pressure using hydrostatic assumption down to the surface. + ! (from mpas_atmphys_interface.F:MPAS_to_physics()) + call mpas_pool_get_array(diag_pool, 'surface_pressure' ,MPAS_state % surface_pressure) + do iCol = 1, nCellsSolve + tem1 = MPAS_state % zgrid(2,iCol) - MPAS_state % zgrid(1,iCol) + tem2 = MPAS_state % zgrid(3,iCol) - MPAS_state % zgrid(2,iCol) + rho1 = MPAS_state % rho_zz(1,iCol) * MPAS_state % zz(1,iCol) * (1. + MPAS_state % tracers(index_qv,1,iCol)) + rho2 = MPAS_state % rho_zz(2,iCol) * MPAS_state % zz(2,iCol) * (1. + MPAS_state % tracers(index_qv,2,iCol)) + MPAS_state % surface_pressure(iCol) = 0.5*gravity*(MPAS_state % zgrid(2,iCol) - MPAS_state % zgrid(1,iCol)) & + * (rho1 - 0.5*(rho2-rho1)*tem1/(tem1+tem2)) + MPAS_state % surface_pressure(iCol) = MPAS_state % surface_pressure(iCol) + & + MPAS_state % pressure_p(1,iCol) + & + MPAS_state % pressure_b(1,iCol) + enddo + + ! Compute hydrostatic pressures allocate(MPAS_state % pmid( nVertLevels, nCellsSolve)) allocate(MPAS_state % pmiddry(nVertLevels, nCellsSolve)) allocate(MPAS_state % pintdry(nVertLevels+1, nCellsSolve)) call hydrostatic_pressure(nCellsSolve, nVertLevels, nwat, index_qv, MPAS_state % zz, & - MPAS_state % zint, MPAS_state % rho_zz, MPAS_state % theta_m, MPAS_state % exner, & + MPAS_state % zgrid, MPAS_state % rho_zz, MPAS_state % theta_m, MPAS_state % exner, & MPAS_state % tracers, MPAS_state % pmiddry, MPAS_state % pintdry, MPAS_state % pmid) ! Copy MPAS pressures into physics data containers. ! [k, i] -> [i, k] - ! bottom-up -> top-down ordering convention - do iCell = 1, nCellsSolve - iCol = indicesGlobal(iCell) - physics_state % pgr(iCol) = MPAS_state % pintdry(1,iCell) - physics_state % prsl(iCol,:) = MPAS_state % pmiddry(nVertLevels:1:-1,iCell) - physics_state % prsi(iCol,:) = MPAS_state % pintdry(nVertLevels+1:1:-1,iCell) + ! Retain bottom-up convention + do iCol = 1, nCellsSolve + physics_state % pgr(iCol) = MPAS_state % pintdry(nVertLevels+1,iCol) + physics_state % prsl(iCol,:) = MPAS_state % pmiddry(:,iCol) + physics_state % prsi(iCol,:) = MPAS_state % pintdry(:,iCol) enddo + ! Housekeeping + nullify (mesh_pool) + nullify (state_pool) + nullify (diag_pool) + end subroutine ufs_mpas_to_physics !> ######################################################################################### - !> Procedure to populate inputs to the MPAS dynamical core using outputs from the CCPP - !> physics. + !> Procedure to update state with physics tendencies prior to calling MPAS dynamical core. + !> + !> Analogous to phys_get_tend in physics/mpas_atmphys_todynamics.F + !> Instead of updating the state with physics tendencies from the MPAS "tend_pool", we + !> will use tendencies from the CCPP Physics. + !> + !> ######################################################################################### + subroutine ufs_physics_to_mpas() + + end subroutine ufs_physics_to_mpas + + !> ######################################################################################### + !> Procedure to convert of output "CCPP" variables to "MPAS" variables + !> Called prior to MPAS dynamical core (integration) + !> + !> This procedure updates the MPAS "state" using prognosed physics/microphysics variables. + !> + !> Analogous to microphysics_to_MPAS in src/core_atmosphere/physics/mpas_atmphys_interface.F !> !> ######################################################################################### - subroutine ufs_physics_to_mpas(physics_state) + subroutine ufs_microphysics_to_mpas(physics_state) use GFS_typedefs, only : GFS_stateout_type + use mpas_derived_types, only : mpas_pool_type + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_array, mpas_pool_get_dimension + use mpas_constants, only : gravity + use mpas_kind_types, only : RKIND + ! Arguments type(GFS_stateout_type), intent(in ) :: physics_state ! Locals type(mpas_statein_type) :: mpas_state + type(mpas_pool_type), pointer :: diag_pool + type(mpas_pool_type), pointer :: mesh_pool + type(mpas_pool_type), pointer :: state_pool + integer, pointer :: nCellsSolve, index_qv + integer :: iCol + real(kind=RKIND) :: rho1, rho2, tem1, tem2 + + ! Access MPAS data pools + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state_pool) + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'diag', diag_pool) + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', mesh_pool) + + ! Get MPAS dimensions + call mpas_pool_get_dimension(mesh_pool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(state_pool, 'index_qv', index_qv) + + ! Grab fields from MPAS pools + call mpas_pool_get_array(state_pool, 'scalars', MPAS_state % tracers, timeLevel=1) + call mpas_pool_get_array(mesh_pool, 'zgrid', MPAS_state % zgrid) + call mpas_pool_get_array(mesh_pool, 'zz', MPAS_state % zz) + call mpas_pool_get_array(state_pool, 'rho_zz', MPAS_state % rho_zz, timeLevel=1) + call mpas_pool_get_array(diag_pool, 'pressure_base', MPAS_state % pressure_b) + call mpas_pool_get_array(diag_pool, 'pressure_p', MPAS_state % pressure_p) ! [i, k] -> [k, i] ! top-down -> bottom-up ordering convention ! Thermodynamic conversions from moist (CCPP) to dry (MPAS) - end subroutine ufs_physics_to_mpas + ! Calculation of the surface pressure using hydrostatic assumption down to the surface. + ! (from mpas_atmphys_interface.F:MPAS_to_physics()) + call mpas_pool_get_array(diag_pool, 'surface_pressure' ,MPAS_state % surface_pressure) + do iCol = 1, nCellsSolve + tem1 = MPAS_state % zgrid(2,iCol) - MPAS_state % zgrid(1,iCol) + tem2 = MPAS_state % zgrid(3,iCol) - MPAS_state % zgrid(2,iCol) + rho1 = MPAS_state % rho_zz(1,iCol) * MPAS_state % zz(1,iCol) * (1. + MPAS_state % tracers(index_qv,1,iCol)) + rho2 = MPAS_state % rho_zz(2,iCol) * MPAS_state % zz(2,iCol) * (1. + MPAS_state % tracers(index_qv,2,iCol)) + MPAS_state % surface_pressure(iCol) = 0.5*gravity*(MPAS_state % zgrid(2,iCol) - MPAS_state % zgrid(1,iCol)) & + * (rho1 - 0.5*(rho2-rho1)*tem1/(tem1+tem2)) + MPAS_state % surface_pressure(iCol) = MPAS_state % surface_pressure(iCol) + & + MPAS_state % pressure_p(1,iCol) + & + MPAS_state % pressure_b(1,iCol) + enddo + + ! Housekeeping + nullify (state_pool) + nullify (mesh_pool) + nullify (diag_pool) + + end subroutine ufs_microphysics_to_mpas + + !> ######################################################################################### + !> Procedure to convert of "MPAS" variables to "CCPP" variables. + !> Called prior to CCPP Microphysics Group. + !> + !> Analogous to microphysics_from_MPAS in src/core_atmosphere/physics/mpas_atmphys_interface.F + !> + !> This procedure accesses MPAS data using MPAS native procedures and stores the data + !> locally in the data-containers defined above. The MPAS "state" is then translated to the + !> CCPP "state" needed by the microphysics. + !> + !> ######################################################################################### + subroutine ufs_mpas_to_microphysics(physics_state) + use GFS_typedefs, only : GFS_statein_type + ! Arguments + type(GFS_statein_type), intent(inout) :: physics_state + + end subroutine ufs_mpas_to_microphysics !> ######################################################################################### !> Procedure to compute dry hydrostatic pressure at layer interfaces and midpoints. @@ -252,6 +385,9 @@ end subroutine ufs_physics_to_mpas !> !> \update: Dustin Swales April 2025 - Modified for use in UWM !> + !> DJS to GJF: We shouldn't need this once you port the MPAS_to_physics/MPAS_to_microphysics + !> routines from MPAS. + !> !> ######################################################################################### subroutine hydrostatic_pressure(nCells, nVertLevels, qsize, index_qv, zz, zgrid, rho_zz, & theta_m, exner, q, pmiddry, pintdry,pmid) @@ -342,122 +478,90 @@ subroutine hydrostatic_pressure(nCells, nVertLevels, qsize, index_qv, zz, zgrid, end do end subroutine hydrostatic_pressure - !> ######################################################################################### - !> Procedure to retreieve MPAS domain decomposition , for . - !> Called from atmos_model.F90:_init() - !> - !> ######################################################################################### - subroutine get_mpas_pio_decomp(varname) - use mpas_kind_types, only : StrKIND, RKIND - use mpas_pool_routines, only : mpas_pool_get_field_info, mpas_pool_get_field - use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_array - use mpas_pool_routines, only : mpas_pool_get_dimension - use mpas_derived_types, only : mpas_pool_field_info_type, field2DReal, field3DReal +!> ######################################################################################### +!> Procedure to transfer MPAS grid information to physics DDTs. +!> +!> ######################################################################################### + subroutine ufs_mpas_grid_to_physics(physics_grid) + use GFS_typedefs, only : GFS_grid_type use mpas_derived_types, only : mpas_pool_type + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_config + use mpas_kind_types, only : RKIND + use mpas_constants, only : pii + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_ERR, MPAS_LOG_WARN + use mpp_mod, only : mpp_error, FATAL ! Arguments - character(len=*), intent(in) :: varname + type(GFS_grid_type), intent(inout) :: physics_grid ! Locals - character(len=*), parameter :: subname = 'ufs_mpas_subdriver::get_mpas_pio_decomp' - integer, dimension(:), pointer :: indexArray, indices - integer, pointer :: indexDimension - type (field2DReal), pointer :: field2d - type (field3DReal), pointer :: field3d - type (mpas_pool_field_info_type) :: fieldInfo - character (len=StrKIND) :: elementName, elementNamePlural - logical :: meshFieldDim, cellFieldDIm - integer :: i - - ! - call mpas_pool_get_field_info(domain_ptr % blocklist % allFields, trim(varname), fieldInfo) - if (trim(varname) == 'scalars') then - nullify(field3d) - if (fieldInfo % nTimeLevels > 1) then - call mpas_pool_get_field(domain_ptr % blocklist % allFields, trim(varname), field3d, & - timeLevel=fieldInfo % nTimeLevels ) - else - call mpas_pool_get_field(domain_ptr % blocklist % allFields, trim(varname), field3d) - endif - if ( field3d % isDecomposed ) then - meshFieldDim = .false. - cellFieldDIm = .false. - if (trim(field3d % dimNames(fieldInfo % nDims)) == 'nCells') then - elementName = 'Cell' - elementNamePlural = 'Cells' - meshFieldDim = .true. - cellFieldDIm = .true. - else if (trim(field3d % dimNames(fieldInfo % nDims)) == 'nEdges') then - elementName = 'Edge' - elementNamePlural = 'Edges' - meshFieldDim = .true. - else if (trim(field3d % dimNames(fieldInfo % nDims)) == 'nVertices') then - elementName = 'Vertex' - elementNamePlural = 'Vertices' - meshFieldDim = .true. - end if - endif - nullify(field3d) - else - nullify(field2d) - if (fieldInfo % nTimeLevels > 1) then - call mpas_pool_get_field(domain_ptr % blocklist % allFields, trim(varname), field2d, & - timeLevel=fieldInfo % nTimeLevels ) - else - call mpas_pool_get_field(domain_ptr % blocklist % allFields, trim(varname), field2d) - endif - if ( field2d % isDecomposed ) then - meshFieldDim = .false. - cellFieldDIm = .false. - if (trim(field2d % dimNames(fieldInfo % nDims)) == 'nCells') then - elementName = 'Cell' - elementNamePlural = 'Cells' - meshFieldDim = .true. - cellFieldDIm = .true. - else if (trim(field2d % dimNames(fieldInfo % nDims)) == 'nEdges') then - elementName = 'Edge' - elementNamePlural = 'Edges' - meshFieldDim = .true. - else if (trim(field2d % dimNames(fieldInfo % nDims)) == 'nVertices') then - elementName = 'Vertex' - elementNamePlural = 'Vertices' - meshFieldDim = .true. - end if - endif - nullify(field2d) - endif - ! - if ( meshFieldDim ) then - allocate(indices(0)) - call mpas_pool_get_array(domain_ptr % blocklist % allFields, 'indexTo' // & - trim(elementName) // 'ID', indexArray) - call mpas_pool_get_dimension(domain_ptr % blocklist % dimensions, 'n' // & - trim(elementNamePlural) // 'Solve', indexDimension) - call mergeArrays(indices, indexArray(1:indexDimension)) - endif - ! Save indices for P2D coupling in run phase(s). - if ( cellFieldDIm ) then - allocate(indicesGlobal(indexDimension)) - indicesGlobal = indices - endif - - end subroutine get_mpas_pio_decomp - - subroutine mergeArrays(array1, array2) - implicit none - integer, dimension(:), pointer :: array1 - integer, dimension(:), intent(in) :: array2 - integer :: n1, n2 - integer, dimension(:), pointer :: newArray - - n1 = size(array1) - n2 = size(array2) + type(mpas_pool_type), pointer :: mesh_pool + integer :: i, ierr + integer, pointer :: nCellsSolve + real(RKIND), pointer :: lat(:), lon(:), area(:), meshDensity(:) + + real(RKIND), pointer :: nominalMinDc + real(RKIND), pointer :: config_len_disp + real(RKIND) :: rad2deg + + ierr = 0 + rad2deg = 180.0_RKIND/pii + + ! Access MPAS data pools. + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', mesh_pool) + + ! Get MPAS dimensions + call mpas_pool_get_dimension(mesh_pool, 'nCellsSolve', nCellsSolve) + + call mpas_pool_get_array(mesh_pool, 'latCell', lat) + call mpas_pool_get_array(mesh_pool, 'lonCell', lon) + call mpas_pool_get_array(mesh_pool, 'areaCell', area) + call mpas_pool_get_array(mesh_pool, 'meshDensity', meshDensity) + + ! (from mpas_atm_core.F/atm_core_init Determine horizontal length scale used by horizontal diffusion and 3-d divergence damping + nullify(nominalMinDc) + call mpas_pool_get_array(mesh_pool, 'nominalMinDc', nominalMinDc) - allocate(newArray(n1+n2)) + nullify(config_len_disp) + call mpas_pool_get_config(domain_ptr % blocklist % configs, 'config_len_disp', config_len_disp) - newArray(1:n1) = array1(:) - newArray(n1+1:n1+n2) = array2(:) + ! If config_len_disp was specified as a valid value, use that + if (config_len_disp > 0.0_RKIND) then + ! But if nominalMinDc was available in the input file and is different, print a warning + if (nominalMinDc > 0.0_RKIND .and. abs(nominalMinDc - config_len_disp) > 1.0e-6_RKIND * config_len_disp) then + call mpas_log_write('nominalMinDc was read from input file as a positive value ($r) that differs', & + realArgs=[nominalMinDc], messageType=MPAS_LOG_WARN) + call mpas_log_write('from the specified config_len_disp value ($r)', & + realArgs=[config_len_disp], messageType=MPAS_LOG_WARN) + end if + nominalMinDc = config_len_disp + ! Otherwise, try to use nominalMinDc + else + if (nominalMinDc > 0.0_RKIND) then + call mpas_log_write('Setting config_len_disp to $r based on nominalMinDc value in input file', realArgs=[nominalMinDc]) + config_len_disp = nominalMinDc + else + call mpas_log_write('Both config_len_disp and nominalMinDc are <= 0.0.', messageType=MPAS_LOG_ERR) + call mpas_log_write('Please either specify config_len_disp in the &nhyd_model namelist group,', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('or use an input file that provides a valid value for the nominalMinDc variable.', & + messageType=MPAS_LOG_ERR) + ierr = 1 + end if + end if + if (ierr/=0) call mpp_error(FATAL, 'Call to ufs_mpas_grid_to_physics() failed') - deallocate(array1) - array1 => newArray - end subroutine mergeArrays + do i=1, nCellsSolve + physics_grid % xlat(i) = lat(i) + physics_grid % xlon(i) = lon(i) + physics_grid % xlat_d(i) = physics_grid % xlat(i) * rad2deg + physics_grid % xlon_d(i) = physics_grid % xlon(i) * rad2deg + physics_grid % sinlat(i) = sin(physics_grid % xlat(i)) + physics_grid % coslat(i) = sqrt(1.0_RKIND - physics_grid % sinlat(i) * physics_grid % sinlat(i)) + physics_grid % area(i) = area(i) + !formula for dx comes from mpas_atmphys_driver_gwdo.F instead of sqrt(area) as in FV3 + physics_grid % dx(i) = config_len_disp / meshDensity(i)**0.25 + end do + + end subroutine ufs_mpas_grid_to_physics end module atmos_coupling_mod diff --git a/mpas/atmos_model.F90 b/mpas/atmos_model.F90 index b851eacaa..2ae082fca 100644 --- a/mpas/atmos_model.F90 +++ b/mpas/atmos_model.F90 @@ -9,6 +9,7 @@ module atmos_model_mod use mpi_f08, only : MPI_Comm, MPI_CHARACTER, MPI_INTEGER, MPI_REAL8, MPI_LOGICAL ! MPAS use MPAS_typedefs, only : MPAS_kind_phys => kind_phys + use atmos_coupling_mod, only : MPAS_statein_type, MPAS_stateout_type ! CCPP use CCPP_data, only : UFSATM_control => GFS_control use CCPP_data, only : UFSATM_intdiag => GFS_intdiag @@ -27,8 +28,6 @@ module atmos_model_mod use time_manager_mod, only : time_type, get_time, get_date, operator(+), operator(-) use field_manager_mod, only : MODEL_ATMOS use tracer_manager_mod, only : get_number_tracers, get_tracer_names, get_tracer_index - use fms_mod, only : check_nml_error - use fms2_io_mod, only : file_exists use mpp_mod, only : input_nml_file, mpp_error, FATAL use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_clock_id, mpp_clock_begin use mpp_mod, only : mpp_clock_end, CLOCK_COMPONENT, MPP_CLOCK_SYNC @@ -36,8 +35,8 @@ module atmos_model_mod use fms_mod, only : stdlog use mpp_mod, only : stdout ! UFSATM - use module_mpas_config, only : pio_numiotasks, nCellsGlobal, ic_filename, lbc_filename - use module_mpas_config, only : lonCellGlobal, latCellGlobal, areaCellGlobal + use module_mpas_config, only : nCellsGlobal, ic_filename, lbc_filename, nCellsSolve + use module_mpas_config, only : lonCell, latCell, areaCellGlobal use module_mpas_config, only : pi use mod_ufsatm_util, only : get_atmos_tracer_types #ifdef _OPENMP @@ -53,6 +52,7 @@ module atmos_model_mod public :: atmos_model_radiation_physics public :: atmos_model_microphysics public :: atmos_model_dynamics + public :: update_atmos_model_state !> ######################################################################################### !> Type containing information on MPAS enabled UFSATM forecast. @@ -62,27 +62,32 @@ module atmos_model_mod type(time_type) :: Time ! current time type(time_type) :: Time_step ! atmospheric time step. type(time_type) :: Time_init ! reference time. + logical :: isAtCapTime ! true if currTime is at the cap driverClock's currTime integer :: nblks ! Number of physics blocks. end type atmos_control_type - ! Index map between MPAS tracers and CAM constituents - integer, dimension(:), pointer :: mpas_from_ufs_cnst => null() ! indices into UFS constituent array ! Index map between MPAS tracers and UFS constituents + integer, dimension(:), pointer :: mpas_from_ufs_cnst => null() ! indices into UFS constituent array + ! Index map between UFS tracers and MPAS constituents integer, dimension(:), pointer :: ufs_from_mpas_cnst => null() ! indices into MPAS tracers array ! Namelist integer :: blocksize = 1 logical :: dycore_only = .false. logical :: debug = .false. + logical :: regional = .false. - namelist /atmos_model_nml/ blocksize, dycore_only, debug, ccpp_suite, ic_filename, lbc_filename + namelist /atmos_model_nml/ blocksize, dycore_only, debug, ccpp_suite, ic_filename, lbc_filename, & + regional ! Component Timers - integer :: setupClock, radClock, physClock, mpasClock, mpClock, atmiClock + integer :: setupClock, radClock, physClock, mpasClock, mpClock, atmiClock, outClock ! DJS2025: For UFS WM RTs unitl output is setup for MPAS. integer, parameter :: mpas_logfile_handle = 42323 - + + type(MPAS_statein_type) :: MPAS_statein + type(MPAS_stateout_type) :: MPAS_stateout contains !> ######################################################################################### !> Procedure to initialize UWM ATMosphere with MPAS dynamical core. @@ -98,13 +103,12 @@ module atmos_model_mod !> !> ######################################################################################### subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm, calendar) - use ufs_mpas_subdriver, only : MPAS_control_type - use ufs_mpas_subdriver, only : ufs_mpas_init_phase1, ufs_mpas_init_phase2 - use ufs_mpas_subdriver, only : ufs_mpas_open_init - use ufs_mpas_subdriver, only : dyn_mpas_read_write_stream, ufs_mpas_define_scalars - use ufs_mpas_subdriver, only : constituent_name, is_water_species - use atmos_coupling_mod, only : ufs_mpas_to_physics, get_mpas_pio_decomp - use MPAS_init, only : MPAS_initialize + use ufs_mpas_subdriver, only : MPAS_control_type + use ufs_mpas_subdriver, only : ufs_mpas_init + use ufs_mpas_io, only : ufs_mpas_open_init, ufs_mpas_open_lbc + use ufs_mpas_constituents, only : constituent_name, is_water_species + use atmos_coupling_mod, only : ufs_mpas_to_physics, ufs_mpas_grid_to_physics + use MPAS_init, only : MPAS_initialize ! Arguments type(atmos_control_type), intent(inout) :: Atmos @@ -116,6 +120,7 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm integer :: i, io, ierr, nConstituents, sec, iCol type(MPAS_control_type) :: Cfg integer :: times(6), timee(6), ttime, logUnits(2), nthrds + logical :: file_exists ! Set up timers setupClock = mpp_clock_id( 'Time-Step Setup ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) @@ -124,14 +129,17 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm physClock = mpp_clock_id( 'Physics ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) mpasClock = mpp_clock_id( 'MPAS Dycore ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) mpClock = mpp_clock_id( 'Microphysics ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) + outClock = mpp_clock_id( 'MPAS Output ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) ! Start timer for this procedure (init). call mpp_clock_begin(atmiClock) - ! Set model time + ! Set atmospheric model time. + Atmos % isAtCapTime = .false. Atmos % Time_init = Time_init Atmos % Time = Time Atmos % Time_step = Time_step + call get_time (Atmos % Time_step, sec) Cfg%dt_phys = real(sec) @@ -146,21 +154,41 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm Cfg%mpi_comm = mpicomm ! Read in ATMosphere namelist. - if (file_exists('input.nml')) then - read(input_nml_file, nml=atmos_model_nml, iostat=io) - ierr = check_nml_error(io, 'atmos_model_nml') + inquire(file = 'input.nml', exist=file_exists) + if (file_exists) then + read(input_nml_file, nml=atmos_model_nml, iostat=ierr) + if (ierr/=0) call mpp_error(FATAL, 'ERROR When Reading in ATM Namelist') endif - ! Get tracer name(s) and type(s). + ! + ! Handle constituents (scalars/tracers) + ! + + ! Get constituent name(s) and type(s). + ! Active constituents are defined in the FMS "field_table". call get_number_tracers(MODEL_ATMOS, num_tracers=Cfg % nConstituents) allocate (Cfg % tracer_names(Cfg % nConstituents), Cfg % tracer_types(Cfg % nConstituents)) do i = 1, Cfg % nConstituents call get_tracer_names(MODEL_ATMOS, i, Cfg % tracer_names(i)) enddo call get_atmos_tracer_types(Cfg % tracer_types) + + ! Get number of water species. + ! DJS Asks? With FV3, this is set during dycore initialization. How do we get this information + ! here? Does MPAS have a routine for this? + ! + ! It would be simple, albeit not the most elegant thing, but we could create a simple routine + ! that has a list of "known MPAS water species" and compare each "tracer_name" to that. + ! A more robust solution IMO would be to quiery the field table entries for a "water-species" + ! attribute, or something along those lines. Actually, I think this is straightforward if we + ! extend ../ufsatm_util.F90. - ! DJS2025: There are 9 tracers, but only 6 are water. How do we get to 6? - ! With FV3, this is set during dycore initialization. Set and Revisit later. + ! + ! From field_tables: + ! For RRFS MPAS we have: 11 water tracers (ql,qc,qi,qr,qs,qg,nc,nc,ni,nr,ng) + ! 2 prog. tracers (o3,sgs-tke) + ! For GFSv17 MPAS we have: 6 water species (ql,qc,qi,qr,qs,qg) + ! 4 prog. tracers (o3,sgs-tke,cld_amt,sigma_b) Cfg % nwat = 6 call get_number_tracers(MODEL_ATMOS, num_tracers=Cfg % nConstituents) @@ -171,10 +199,15 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm is_water_species(:) = .false. is_water_species(1:Cfg % nwat) = .true. - ! Open (PIO) MPAS IC data file. + ! Open (PIO) MPAS Initial Condition (IC) file. call ufs_mpas_open_init() - - ! Call MPAS initialization phase 1. + + ! Open (PIO) MPAS Lateral Boundary Condition (LBC) file. + if (regional) then + call ufs_mpas_open_lbc() + endif + + ! Call MPAS initialization. ! - Set up MPAS framework ! - Read in MPAS namelists ! - Set up MPAS logging @@ -190,31 +223,14 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm logunits(2) = mpas_logfile_handle endif - call ufs_mpas_init_phase1(Cfg, times, timee, ttime, calendar, logUnits) - - call ufs_mpas_define_scalars(mpas_from_ufs_cnst, ufs_from_mpas_cnst, ierr) - if (ierr /= 0) then - call mpp_error(FATAL,'ERROR: Set-up of constituents for MPAS-A dycore failed.') - end if + call ufs_mpas_init(Cfg, times, timee, ttime, calendar, logUnits, mpas_from_ufs_cnst, ufs_from_mpas_cnst) - ! Read in MPAS IC data. Populate MPAS data containers and MPAS "input" stream. - call dyn_mpas_read_write_stream( 'r', 'input-scalars') - - ! Complete the MPAS dycore initialization. - ! - Set up threading. - ! - Call MPAS core_atmosphere init. - call ufs_mpas_init_phase2(Cfg) - !> ######################################################################################### !> ######################################################################################### !> END MPAS DYCORE INITIALIZATION !> ######################################################################################### !> ######################################################################################### - ! Set domain decomposition needed for P2D step - ! Use 'theta', but any MPAS field defined on the cell center will work. - call get_mpas_pio_decomp('theta') - !> ######################################################################################### !> ######################################################################################### !> BEGIN CCPP PHYSICS INITIALIZATION @@ -229,14 +245,14 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm Cfg%nlunit = stdlog() ! Number of physics blocks - Atmos % nblks = nCellsGlobal / blocksize - if (mod(nCellsGlobal, blocksize) .gt. 0) Atmos % nblks = Atmos % nblks + 1 - + Atmos % nblks = nCellsSolve / blocksize + if (mod(nCellsSolve, blocksize) .gt. 0) Atmos % nblks = Atmos % nblks + 1 + ! Physics block sizes. Cfg % nblks = Atmos % nblks allocate(Cfg % blksz(Atmos % nblks)) Cfg % blksz(:) = blocksize - Cfg % blksz(Atmos % nblks) = nCellsGlobal - (Atmos % nblks - 1)*blocksize + Cfg % blksz(Atmos % nblks) = nCellsSolve - (Atmos % nblks - 1)*blocksize allocate(UFSATM_interstitial(nthrds+1)) @@ -254,18 +270,21 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm ! Read in physics namelist and allocate data containers. call MPAS_initialize(UFSATM_control, UFSATM_intdiag, UFSATM_grid, UFSATM_tbd, UFSATM_sfcprop, & UFSATM_statein, UFSATM_stateout, UFSATM_cldprop, UFSATM_radtend, UFSATM_coupling, Cfg) - - ! Get longitude/latitude/area from MPAS to use in the physics. - UFSATM_grid % xlon = lonCellGlobal - UFSATM_grid % xlat = latCellGlobal - UFSATM_grid % xlon_d = lonCellGlobal*180./pi - UFSATM_grid % xlat_d = latCellGlobal*180./pi - UFSATM_grid % area = areaCellGlobal + + call ufs_mpas_grid_to_physics(UFSATM_grid) ! Populate UFSATM data containers with MPAS "input" stream. We need to do this becuase - ! we are calling the physics before the dynamical core. - call ufs_mpas_to_physics(UFSATM_statein) - + ! we are calling the physics before the MPAS dynamical core. + ! + ! DJS to GJF: See fcst_run_phase_1 in module_fcst_grid_comp.F90. That is where we call the + ! "pieces" of the Atmospheric timestep defined below. + ! Since we are calling the radiation/physics first, we need to take the MPAS Initial state + ! and map it to the physics data containers (e.g. Typdefs). We will use a similar routine + ! in a different "piece" later, but copying the Updated state from the dycore before calling + ! the microphsyics. + ! + call ufs_mpas_to_physics(UFSATM_statein, UFSATM_sfcprop) + ! Initialize the CCPP framework call CCPP_step (step="init", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP init step failed') @@ -285,7 +304,7 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm end subroutine atmos_model_init !> ######################################################################################### - !> Procedure to finalize model. + !> Procedure to finalize atmospheric forecast. !> !> ######################################################################################### subroutine atmos_model_end(Atmos) @@ -306,30 +325,41 @@ end subroutine atmos_model_end !> !> ######################################################################################### subroutine atmos_model_radiation_physics(Atmos) + use atmos_coupling_mod, only : ufs_mpas_to_physics type (atmos_control_type), intent(inout) :: Atmos ! Locals integer :: ierr + ! Populate physics inputs with MPAS data. + call ufs_mpas_to_physics(UFSATM_statein, UFSATM_sfcprop) + ! Call CCPP Timestep_initialize Group call mpp_clock_begin(setupClock) call CCPP_step (step="timestep_init", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP timestep_init step failed') call mpp_clock_end(setupClock) - + ! Call CCPP Radiation Group call mpp_clock_begin(radClock) if (UFSATM_control%lsswr .or. UFSATM_control%lslwr) then + ! DJS to GJF: If you un comment this line, you will get an error in the RRTMG radiation. + ! Needless to say, I didn't see why, but I assume it is due to one of the many instances + ! that we will need to identify as being FV3/MPAS specifc. Mostly in the Typedefs I suspect, + ! but there may be interstitial schemes (NOTE that I added an new MPAS specific interstital file + ! already, GFS_rad_time_vary.mpas.F90. I don't think it is complete. + ! !call CCPP_step (step="radiation", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP radiation step failed') endif call mpp_clock_end(radClock) ! Call CCPP Physics Group + ! NOT YET IMPLEMENTED in SDF call mpp_clock_begin(physClock) call CCPP_step (step="physics", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP physics step failed') call mpp_clock_end(physClock) - + end subroutine atmos_model_radiation_physics !> ######################################################################################### @@ -338,21 +368,17 @@ end subroutine atmos_model_radiation_physics !> ######################################################################################### subroutine atmos_model_dynamics(Atmos) use ufs_mpas_subdriver, only : ufs_mpas_run - use atmos_coupling_mod, only : ufs_physics_to_mpas, ufs_mpas_to_physics + use atmos_coupling_mod, only : ufs_physics_to_mpas use MPAS_init, only : MPAS_initialize type (atmos_control_type), intent(inout) :: Atmos ! Prepare MPAS dycore inputs with CCPP physics outputs. - call ufs_physics_to_mpas(UFSATM_stateout) + ! NOT YET IMPLEMENTED + call ufs_physics_to_mpas() ! Call MPAS dycore - call mpp_clock_begin(mpasClock) - call ufs_mpas_run() - call mpp_clock_end(mpasClock) - - ! Prepare CCPP physics inputs with MPAS dycore outputs. - call ufs_mpas_to_physics(UFSATM_statein) + call ufs_mpas_run(mpasClock, outClock) end subroutine atmos_model_dynamics @@ -361,11 +387,17 @@ end subroutine atmos_model_dynamics !> !> ######################################################################################### subroutine atmos_model_microphysics(Atmos) + use atmos_coupling_mod, only : ufs_mpas_to_microphysics, ufs_microphysics_to_mpas type (atmos_control_type), intent(inout) :: Atmos ! Locals integer :: ierr - + + ! Prepare CCPP physics inputs with MPAS dycore outputs. + ! NOT YET IMPLEMENTED + call ufs_mpas_to_microphysics(UFSATM_statein) + ! Call CCPP Microphysics Group + ! NOT YET IMPLEMENTED in SDF call mpp_clock_begin(mpClock) call CCPP_step (step="microphysics", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP microphysics step failed') @@ -377,6 +409,20 @@ subroutine atmos_model_microphysics(Atmos) if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP timestep_finalize step failed') call mpp_clock_end(setupClock) + ! Prepare MPAS dycore inputs with CCPP physics outputs. + call ufs_microphysics_to_mpas(UFSATM_stateout) + end subroutine atmos_model_microphysics - + + !> ######################################################################################### + !> Procedure to advance the model forecast time + !> + !> ######################################################################################### + subroutine update_atmos_model_state(Atmos) + type (atmos_control_type), intent(inout) :: Atmos + + ! Advance time + Atmos % Time = Atmos % Time + Atmos % Time_step + end subroutine update_atmos_model_state + end module atmos_model_mod diff --git a/mpas/module_fcst_grid_comp.F90 b/mpas/module_fcst_grid_comp.F90 index 721ea8acc..210b63a85 100644 --- a/mpas/module_fcst_grid_comp.F90 +++ b/mpas/module_fcst_grid_comp.F90 @@ -17,7 +17,7 @@ module module_fcst_grid_comp NO_CALENDAR, date_to_string, get_date, get_time use atmos_model_mod, only: atmos_model_init, atmos_model_end, atmos_control_type use atmos_model_mod, only: atmos_model_radiation_physics, atmos_model_dynamics, & - atmos_model_microphysics + atmos_model_microphysics, update_atmos_model_state use constants_mod, only: constants_init use fms_mod, only: error_mesg, fms_init, fms_end, write_version_number, & uppercase @@ -28,6 +28,7 @@ module module_fcst_grid_comp use diag_manager_mod, only: diag_manager_init, diag_manager_end, & diag_manager_set_time_end use module_mpas_config, only: dt_atmos, fcst_mpi_comm, fcst_ntasks, calendar + use CCPP_data, only: GFS_control implicit none private @@ -76,6 +77,11 @@ subroutine SetServices(fcst_comp, rc) userRoutine=fcst_run_phase_1, phase=1, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + ! Run Phase 2 + call ESMF_GridCompSetEntryPoint(fcst_comp, ESMF_METHOD_RUN, & + userRoutine=fcst_run_phase_2, phase=2, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + ! Finalize call ESMF_GridCompSetEntryPoint(fcst_comp, ESMF_METHOD_FINALIZE, & userRoutine=fcst_finalize, rc=rc) @@ -290,25 +296,105 @@ subroutine fcst_run_phase_1(fcst_comp, importState, exportState, clock, rc) ! Locals integer :: seconds real(kind=8) :: mpi_wtime, tbeg1 + logical,save :: first=.true. + integer,save :: dt_cap=0 + type(ESMF_Time) :: currTime,stopTime + + ! Timing info. + tbeg1 = mpi_wtime() - ! Initialize ESMF error message. + ! Initialize ESMF error message. rc = ESMF_SUCCESS - - ! Timing info (debug mode) - tbeg1 = mpi_wtime() + call get_time(Atmos%Time - Atmos%Time_init, seconds) n_atmsteps = seconds/dt_atmos + + if (first) then + call ESMF_ClockGet(clock, currTime=currTime, stopTime=stopTime, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_TimeIntervalGet(stopTime-currTime, s=dt_cap, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + first=.false. + endif + + if ( dt_cap > 0 .and. mod(seconds, dt_cap) == 0 ) then + Atmos%isAtCapTime = .true. + else + Atmos%isAtCapTime = .false. + endif + ! Call forecast integration subroutines... call atmos_model_radiation_physics (Atmos) call atmos_model_dynamics (Atmos) call atmos_model_microphysics (Atmos) - + !call update_atmos_model_state(Atmos) + ! Timing info (debug mode) if (mype == 0) write(*,'(A,I16,A,F16.6)')'PASS(fcstRUN phase 1), n_atmsteps = ', & n_atmsteps,' time is ',mpi_wtime()-tbeg1 end subroutine fcst_run_phase_1 + ! ########################################################################################### + ! Run phase(2) for the ESMF forecast grid component + ! ########################################################################################### + subroutine fcst_run_phase_2(fcst_comp, importState, exportState, clock, rc) + type(ESMF_GridComp) :: fcst_comp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer,intent(out) :: rc + + real(kind=8) :: mpi_wtime, tbeg1 + integer :: FBCount, i + logical :: isPresent + character(len=esmf_maxstr),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + type(ESMF_FieldBundle) :: fcstExportFB + ! Timing info. + tbeg1 = mpi_wtime() + + ! Initialize ESMF error message. + rc = ESMF_SUCCESS + + call update_atmos_model_state(Atmos) + + ! update fhzero + call ESMF_StateGet(exportState, itemCount=FBCount, rc=rc) + + allocate (itemNameList(FBCount)) + allocate (itemTypeList(FBCount)) + call ESMF_StateGet(exportState, & + itemNameList=itemNameList, & + itemTypeList=itemTypeList, & + rc=rc) + do i=1, FBcount + if (itemTypeList(i) == ESMF_STATEITEM_FIELDBUNDLE) then + call ESMF_StateGet(exportState, itemName=itemNameList(i), & + fieldbundle=fcstExportFB, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_AttributeGet(fcstExportFB, convention="NetCDF", purpose="MPAS", & + name="fhzero", isPresent=isPresent, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (isPresent) then + call ESMF_AttributeSet(fcstExportFB, convention="NetCDF", purpose="FV3", name="fhzero", value=GFS_control%fhzero, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + endif + else + !***### anything but a FieldBundle in the state is unexpected here + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg="Only FieldBundles supported in fcstState.", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + enddo + + if (mype == 0) write(*,'(A,I16,A,F16.6)')'PASS: fcstRUN phase 2, n_atmsteps = ', & + n_atmsteps,' time is ',mpi_wtime()-tbeg1 + + end subroutine fcst_run_phase_2 ! ########################################################################################### ! Finalize the ESMF forecast grid component. ! ########################################################################################### diff --git a/mpas/module_mpas_config.F90 b/mpas/module_mpas_config.F90 index 2ab507bab..16a9f5961 100644 --- a/mpas/module_mpas_config.F90 +++ b/mpas/module_mpas_config.F90 @@ -38,7 +38,7 @@ module module_mpas_config !> Flag to decide if write grid component writes out restart files logical :: quilting_restart = .false. - + !> Output frequency if this array has only two elements and the value of !! the second eletment is -1. Otherwise, it is the specific output forecast !! hours @@ -53,15 +53,27 @@ module module_mpas_config !> MPAS Lateral Boundary Condition file (via UFSATM NML) character(len=256) :: lbc_filename + !> MPAS output filenames + character(len=256) :: output_filename = "output.mpas.nc" + character(len=256) :: restart_filename = "restart.mpas.nc" + !> PIO - type(iosystem_desc_t), pointer :: pio_subsystem + type(iosystem_desc_t), pointer :: pio_subsystem_ic + type(iosystem_desc_t), pointer :: pio_subsystem_lbc + type(iosystem_desc_t), pointer :: pio_subsystem_output + type(file_desc_t), target :: pioid_ic + type(file_desc_t), target :: pioid_lbc + type(file_desc_t), target :: pioid_output + type(io_desc_t) :: pio_iodesc integer :: pio_iotype integer :: pio_ioformat integer :: pio_stride integer :: pio_numiotasks - type(file_desc_t), target :: pioid - type(io_desc_t) :: pio_iodesc - + logical :: pio_subsystem_output_file_created = .false. + integer :: pio_subsystem_output_record = 1 + integer, parameter :: TIMELEVEL_NOW = 1 ! current time + integer, parameter :: TIMELEVEL_NEXT = 2 ! updated/next time + !> MPAS Grid information real(r8), target, allocatable :: zref(:) real(r8), target, allocatable :: zref_edge(:) @@ -77,11 +89,14 @@ module module_mpas_config integer :: nVertLevels ! number of vertical layers (midpoints) integer, pointer :: & + nCells, & ! number of cells in task nCellsSolve, & ! number of cells that a task solves nEdgesSolve, & ! number of edges (velocity) that a task solves nVerticesSolve, & ! number of vertices (vorticity) that a task solves nVertLevelsSolve + real(r4), pointer :: latCell(:), lonCell(:) + !> Global gridded data integer :: nCellsGlobal ! global number of cells/columns integer :: nEdgesGlobal ! global number of edges @@ -91,5 +106,5 @@ module module_mpas_config real(r4), allocatable :: latCellGlobal(:) real(r4), allocatable :: lonCellGlobal(:) real(r4), allocatable :: areaCellGlobal(:) - + end module module_mpas_config diff --git a/mpas/ufs_mpas_boundaries.F90 b/mpas/ufs_mpas_boundaries.F90 new file mode 100644 index 000000000..8f4d72962 --- /dev/null +++ b/mpas/ufs_mpas_boundaries.F90 @@ -0,0 +1,363 @@ +!> ########################################################################################### +!> \file ufs_mpas_boundaries.F90 +!> +!> Routines adopted from MPAS src/core_atmosphere/dynamics/mpas_atm_boundaries.F for use in +!> the UFS Weather Model. +!> +!> ########################################################################################### +module ufs_mpas_boundaries + use mpas_atm_boundaries, only : LBC_intv_end + use ufs_mpas_io + + implicit none + + public :: ufs_mpas_atm_update_bdy_tend, ufs_mpas_atm_bdy_checks + +contains + + !> ######################################################################################### + !> + !> routine ufs_mpas_atm_update_bdy_tend + !> + !> \brief Reads new boundary data and updates the LBC tendencies + !> \author Michael Duda + !> \date 27 September 2016 + !> \details + !> This routine reads from the 'lbc_in' stream all variables in the 'lbc' + !> pool. When called with firstCall=.true., the latest time before the + !> present is read into time level 2 of the lbc pool; otherwise, the + !> contents of time level 2 are shifted to time level 1, the earliest + !> time strictly later than the present is read into time level 2, and + !> the tendencies for all fields in the lbc pool are computed and stored + !> in time level 1. + !> + !> \update: Dustin Swales September 2025 - Modified for use in UWM + !> + !> ######################################################################################### + subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, nRecord, ierr) + use mpas_constants, only : rvord + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_STREAM_MGR_NOERR, MPAS_LOG_ERR + use mpas_derived_types, only : mpas_pool_type, mpas_Clock_type, block_type + use mpas_derived_types, only : MPAS_TimeInterval_type, MPAS_Time_Type + use mpas_timekeeping, only : mpas_set_time + use mpas_kind_types, only : StrKIND, RKIND + use mpas_derived_types, only : MPAS_STREAM_LATEST_BEFORE + use mpas_derived_types, only : MPAS_STREAM_EARLIEST_STRICTLY_AFTER + use mpas_timekeeping, only : mpas_get_timeInterval, mpas_get_time, operator(-) + use mpas_timekeeping, only : mpas_get_clock_time, MPAS_NOW + use mpas_pool_routines, only : mpas_pool_get_config, mpas_pool_get_subpool + use mpas_pool_routines, only : mpas_pool_shift_time_levels, mpas_pool_get_array + use mpas_pool_routines, only : mpas_pool_get_dimension + use module_mpas_config, only : lbc_filename, pioid_lbc, pio_subsystem_lbc + + implicit none + + type (mpas_clock_type), intent(in) :: clock + type (block_type), intent(inout) :: block + logical, intent(in) :: firstCall + integer, intent(in) :: nRecord + integer, intent(out) :: ierr + + character(len=StrKIND) :: lbc_intv_start_string + character(len=StrKIND) :: lbc_intv_end_string + + type (mpas_pool_type), pointer :: mesh + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: lbc + real (kind=RKIND) :: dt + + integer, pointer :: nCells_ptr + integer, pointer :: nEdges_ptr + integer, pointer :: nVertLevels_ptr + integer, pointer :: index_qv_ptr + integer, pointer :: nScalars_ptr + integer :: nCells, nEdges, nVertLevels, index_qv, nScalars + + real (kind=RKIND), dimension(:,:), pointer :: u + real (kind=RKIND), dimension(:,:), pointer :: ru + real (kind=RKIND), dimension(:,:), pointer :: rho_edge + real (kind=RKIND), dimension(:,:), pointer :: w + real (kind=RKIND), dimension(:,:), pointer :: theta + real (kind=RKIND), dimension(:,:), pointer :: rtheta_m + real (kind=RKIND), dimension(:,:), pointer :: rho_zz + real (kind=RKIND), dimension(:,:), pointer :: rho + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_u + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_ru + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho_edge + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_w + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_theta + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rtheta_m + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho_zz + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho + real (kind=RKIND), dimension(:,:,:), pointer :: lbc_tend_scalars + + integer, dimension(:,:), pointer :: cellsOnEdge + real (kind=RKIND), dimension(:,:), pointer :: zz + + integer :: dd_intv, s_intv, sn_intv, sd_intv + type (MPAS_Time_Type) :: currTime + type (MPAS_TimeInterval_Type) :: lbc_interval + character(len=StrKIND) :: read_time + integer :: iEdge, iCell, k, j + integer :: cell1, cell2 + + + ierr = 0 + + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'lbc', lbc) + + if (firstCall) then + call dyn_mpas_read_write_stream(clock, 'r', 'lbc_in', pio_file_desc=pioid_lbc, ierr=ierr, timeLevel=2, & + whence = MPAS_STREAM_LATEST_BEFORE, actualWhen=read_time, nRecord=nRecord) + if (ierr /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Could not read from ''lbc_in'' stream on or before the current date '// & + 'to update lateral boundary tendencies', messageType=MPAS_LOG_ERR) + ierr = 1 + end if + else + call mpas_pool_shift_time_levels(lbc) + call dyn_mpas_read_write_stream(clock, 'r', 'lbc_in', pio_file_desc=pioid_lbc, ierr=ierr, timeLevel=2, & + whence = MPAS_STREAM_EARLIEST_STRICTLY_AFTER, actualWhen=read_time, nRecord=nRecord) + if (ierr /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Could not read from ''lbc_in'' stream after the current date '// & + 'to update lateral boundary tendencies', messageType=MPAS_LOG_ERR) + ierr = 1 + end if + end if + if (ierr /= 0) then + return + end if + + call mpas_set_time(currTime, dateTimeString=trim(read_time)) + + ! + ! Compute any derived fields from those that were read from the lbc_in stream + ! + call mpas_pool_get_array(lbc, 'lbc_u', u, 2) + call mpas_pool_get_array(lbc, 'lbc_ru', ru, 2) + call mpas_pool_get_array(lbc, 'lbc_rho_edge', rho_edge, 2) + call mpas_pool_get_array(lbc, 'lbc_w', w, 2) + call mpas_pool_get_array(lbc, 'lbc_theta', theta, 2) + call mpas_pool_get_array(lbc, 'lbc_rtheta_m', rtheta_m, 2) + call mpas_pool_get_array(lbc, 'lbc_rho_zz', rho_zz, 2) + call mpas_pool_get_array(lbc, 'lbc_rho', rho, 2) + call mpas_pool_get_array(lbc, 'lbc_scalars', scalars, 2) + + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_dimension(mesh, 'nCells', nCells_ptr) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges_ptr) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels_ptr) + call mpas_pool_get_dimension(state, 'num_scalars', nScalars_ptr) + call mpas_pool_get_dimension(lbc, 'index_qv', index_qv_ptr) + call mpas_pool_get_array(mesh, 'zz', zz) + + if (.not. firstCall) then + call mpas_pool_get_array(lbc, 'lbc_u', lbc_tend_u, 1) + call mpas_pool_get_array(lbc, 'lbc_ru', lbc_tend_ru, 1) + call mpas_pool_get_array(lbc, 'lbc_rho_edge', lbc_tend_rho_edge, 1) + call mpas_pool_get_array(lbc, 'lbc_w', lbc_tend_w, 1) + call mpas_pool_get_array(lbc, 'lbc_theta', lbc_tend_theta, 1) + call mpas_pool_get_array(lbc, 'lbc_rtheta_m', lbc_tend_rtheta_m, 1) + call mpas_pool_get_array(lbc, 'lbc_rho_zz', lbc_tend_rho_zz, 1) + call mpas_pool_get_array(lbc, 'lbc_rho', lbc_tend_rho, 1) + call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_tend_scalars, 1) + endif + + ! Dereference the pointers to avoid non-array pointer for OpenACC + nCells = nCells_ptr + nEdges = nEdges_ptr + nVertLevels = nVertLevels_ptr + nScalars = nScalars_ptr + index_qv = index_qv_ptr + + ! Compute lbc_rho_zz + do k=1,nVertLevels + zz(k,nCells+1) = 1.0_RKIND ! Avoid potential division by zero in the following line + end do + + do iCell=1,nCells+1 + do k=1,nVertLevels + rho_zz(k,iCell) = rho(k,iCell) / zz(k,iCell) + end do + end do + + ! Average lbc_rho_zz to edges + do iEdge=1,nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + if (cell1 > 0 .and. cell2 > 0) then + do k = 1, nVertLevels + rho_edge(k,iEdge) = 0.5_RKIND * (rho_zz(k,cell1) + rho_zz(k,cell2)) + end do + end if + end do + + do iEdge=1,nEdges+1 + do k=1,nVertLevels + ru(k,iEdge) = u(k,iEdge) * rho_edge(k,iEdge) + end do + end do + + do iCell=1,nCells+1 + do k=1,nVertLevels + rtheta_m(k,iCell) = theta(k,iCell) * rho_zz(k,iCell) * (1.0_RKIND + rvord * scalars(index_qv,k,iCell)) + end do + end do + + if (.not. firstCall) then + + lbc_interval = currTime - LBC_intv_end + call mpas_get_timeInterval(interval=lbc_interval, DD=dd_intv, S=s_intv, S_n=sn_intv, S_d=sd_intv, ierr=ierr) + dt = 86400.0_RKIND * real(dd_intv, kind=RKIND) + real(s_intv, kind=RKIND) & + + (real(sn_intv, kind=RKIND) / real(sd_intv, kind=RKIND)) + + dt = 1.0_RKIND / dt + + do iEdge=1,nEdges+1 + do k=1,nVertLevels + lbc_tend_u(k,iEdge) = (u(k,iEdge) - lbc_tend_u(k,iEdge)) * dt + lbc_tend_ru(k,iEdge) = (ru(k,iEdge) - lbc_tend_ru(k,iEdge)) * dt + lbc_tend_rho_edge(k,iEdge) = (rho_edge(k,iEdge) - lbc_tend_rho_edge(k,iEdge)) * dt + end do + end do + + do iCell=1,nCells+1 + do k=1,nVertLevels+1 + lbc_tend_w(k,iCell) = (w(k,iCell) - lbc_tend_w(k,iCell)) * dt + end do + end do + + do iCell=1,nCells+1 + do k=1,nVertLevels + lbc_tend_theta(k,iCell) = (theta(k,iCell) - lbc_tend_theta(k,iCell)) * dt + lbc_tend_rtheta_m(k,iCell) = (rtheta_m(k,iCell) - lbc_tend_rtheta_m(k,iCell)) * dt + lbc_tend_rho_zz(k,iCell) = (rho_zz(k,iCell) - lbc_tend_rho_zz(k,iCell)) * dt + lbc_tend_rho(k,iCell) = (rho(k,iCell) - lbc_tend_rho(k,iCell)) * dt + end do + end do + + do iCell=1,nCells+1 + do k=1,nVertLevels + do j = 1,nScalars + lbc_tend_scalars(j,k,iCell) = (scalars(j,k,iCell) - lbc_tend_scalars(j,k,iCell)) * dt + end do + end do + end do + + ! + ! Logging the lbc start and end times appears to be backwards, but + ! until the end of this function, LBC_intv_end == the last interval + ! time and currTime == the next interval time. + ! + call mpas_get_time(LBC_intv_end, dateTimeString=lbc_intv_start_string) + call mpas_get_time(currTime, dateTimeString=lbc_intv_end_string) + call mpas_log_write('----------------------------------------------------------------------') + call mpas_log_write('Updated lateral boundary conditions. LBCs are now valid') + call mpas_log_write('from '//trim(lbc_intv_start_string)//' to '//trim(lbc_intv_end_string)) + call mpas_log_write('----------------------------------------------------------------------') + + end if + LBC_intv_end = currTime + + end subroutine ufs_mpas_atm_update_bdy_tend + + !> ######################################################################################## + ! + ! routine ufs_mpas_atm_bdy_checks + ! + !> \brief Checks compatibility of limited-area settings + !> \author Michael Duda + !> \date 12 May 2019 + !> \details + !> This routine checks that settings related to limited-area simulations + !> are compatible. Specifically, the following are checked by this routine: + !> + !> 1) If config_apply_lbcs = true, the bdyMaskCell field must have non-zero elements + !> 2) If config_apply_lbcs = false, the bdyMaskCell field must not have non-zero elements + !> + !> If any of the above are not true, this routine prints an error message and + !> returns a non-zero value in ierr; otherwise, a value of 0 is returned. + !> + !> \update: Dustin Swales March 2026 - Modified for use in UWM + !> + !> ######################################################################################## + subroutine ufs_mpas_atm_bdy_checks(dminfo, blockList, ierr) + use mpas_log, only : mpas_log_write + use mpas_kind_types, only : StrKIND + use mpas_derived_types, only : dm_info, block_type, mpas_pool_type, MPAS_LOG_ERR + use mpas_pool_routines, only : mpas_pool_get_config, mpas_pool_get_dimension + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_array + use mpas_dmpar, only : mpas_dmpar_max_int + + implicit none + + type (dm_info), pointer :: dminfo + type (block_type), pointer :: blockList + integer, intent(out) :: ierr + + character(len=StrKIND) :: input_interval + logical, pointer :: config_apply_lbcs => null() + integer, pointer :: nCellsSolve => null() + type (mpas_pool_type), pointer :: meshPool => null() + type (block_type), pointer :: block => null() + integer, dimension(:), pointer :: bdyMaskCell => null() + integer :: maxvar2d_local, maxvar2d_global + + call mpas_pool_get_config(blocklist % configs, 'config_apply_lbcs', config_apply_lbcs) + + call mpas_log_write('') + call mpas_log_write('Checking consistency of limited-area settings...') + call mpas_log_write(' - config_apply_lbcs = $l', logicArgs=(/config_apply_lbcs/)) + + ! + ! Check whether any elements of bdyMaskCell have non-zero values + ! + maxvar2d_local = -huge(maxvar2d_local) + block => blockList + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_array(meshPool, 'bdyMaskCell', bdyMaskCell) + + maxvar2d_local = max(maxvar2d_local, maxval(bdyMaskCell(1:nCellsSolve))) + + block => block % next + end do + + call mpas_dmpar_max_int(dminfo, maxvar2d_local, maxvar2d_global) + call mpas_log_write(' - Maximum value in bdyMaskCell = $i', intArgs=(/maxvar2d_global/)) + + ! + ! If there are boundary cells, config_apply_lbcs must be set to true + ! + if (.not. config_apply_lbcs .and. maxvar2d_global > 0) then + call mpas_log_write('Boundary cells found in the bdyMaskCell field, but config_apply_lbcs = false.', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('Please ensure that config_apply_lbcs = true for limited-area simulations.', & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + ! + ! If there are no boundary cells, config_apply_lbcs must be set to false + ! + if (config_apply_lbcs .and. maxvar2d_global == 0) then + call mpas_log_write('config_apply_lbcs = true, but no boundary cells found in the bdyMaskCell field.', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('Please ensure that config_apply_lbcs = false for global simulations.', & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + call mpas_log_write(' ----- done checking limited-area settings -----') + call mpas_log_write('') + ierr = 0 + + end subroutine ufs_mpas_atm_bdy_checks +end module ufs_mpas_boundaries diff --git a/mpas/ufs_mpas_constituents.F90 b/mpas/ufs_mpas_constituents.F90 new file mode 100644 index 000000000..9b55be52b --- /dev/null +++ b/mpas/ufs_mpas_constituents.F90 @@ -0,0 +1,341 @@ +!> ########################################################################################### +!> \file ufs_mpas_constituents.F90 +!> +!> This module contains the interface between MPAS constituents and the UFS Weather Model. +!> +!> ########################################################################################### +module ufs_mpas_constituents + use mpas_kind_types, only : StrKIND + use ufs_mpas_io, only : domain_ptr + implicit none + + public + + ! These are setup during ATM initialization. + character(StrKIND), allocatable :: constituent_name(:) + integer, allocatable :: index_constituent_to_mpas_scalar(:) + integer, allocatable :: index_mpas_scalar_to_constituent(:) + logical, allocatable :: is_water_species(:) +contains + !> ######################################################################################### + !> + !> \brief Define the names of constituents at run-time + !> \author Michael Duda + !> \date 21 May 2020 + !> \details + !> Given an array of constituent names, which must have size equal to the number + !> of scalars that were set in the call to ufs_mpas_init_phase1, and given + !> a function to identify which scalars are moisture species, this routine defines + !> scalar constituents for the MPAS-A dycore. + !> Because the MPAS-A dycore expects all moisture constituents to appear in + !> a contiguous range of constituent indices, this routine may in general need + !> to reorder the constituents; to allow for mapping of indices between UFS + !> physics and the MPAS-A dycore, this routine returns index mapping arrays + !> mpas_from_ufs_cnst and ufs_from_mpas_cnst. + !> + !> \update: Dustin Swales April 2025 - Modified for use in UWM + !> + !> ######################################################################################### + subroutine ufs_mpas_define_scalars(mpas_from_ufs_cnst, ufs_from_mpas_cnst, ierr) + use mpas_derived_types, only : mpas_pool_type, field3dReal + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_field, & + mpas_pool_get_dimension, mpas_pool_add_dimension + use mpas_attlist, only : mpas_add_att + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_ERR + ! FMS + use mpp_mod, only : FATAL, mpp_error + + ! Arguments + integer, dimension(:), pointer :: mpas_from_ufs_cnst, ufs_from_mpas_cnst + integer, intent(out) :: ierr + + ! Local variables + character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_define_scalars' + integer :: i, j, timeLevs + integer, pointer :: num_scalars + integer :: num_moist + integer :: idx_passive + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: tendPool + type (field3dReal), pointer :: scalarsField + character(len=128) :: tempstr + character :: moisture_char + + ierr = 0 + + ! + ! Define scalars + ! + nullify(statePool) + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', statePool) + + if (.not. associated(statePool)) then + call mpas_log_write(trim(subname)//': ERROR: The ''state'' pool was not found.', & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + nullify(num_scalars) + call mpas_pool_get_dimension(statePool, 'num_scalars', num_scalars) + + ! + ! The num_scalars dimension should have been defined by atm_core_interface::atm_allocate_scalars, and + ! if this dimension does not exist, something has gone wrong + ! + if (.not. associated(num_scalars)) then + call mpas_log_write(trim(subname)//': ERROR: The ''num_scalars'' dimension does not exist in the ''state'' pool.', & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + ! + ! If at runtime there are not num_scalars names in the array of constituent names provided by UFS, + ! something has gone wrong + ! + if (size(constituent_name) /= num_scalars) then + call mpas_log_write(trim(subname)//': ERROR: The number of constituent names is not equal to the num_scalars dimension', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('size(constituent_name) = $i, num_scalars = $i', intArgs=[size(constituent_name), num_scalars], & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + ! + ! In UFS, the first scalar (if there are any) is always qv (specific humidity); if this is not + ! the case, something has gone wrong + ! + if (size(constituent_name) > 0) then + if (trim(constituent_name(1)) /= 'qv') then + call mpas_log_write(trim(subname)//': ERROR: The first constituent is not qv', messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + end if + + ! + ! Determine which of the constituents are moisture species + ! + allocate(mpas_from_ufs_cnst(num_scalars), stat=ierr) + if( ierr /= 0 ) call mpp_error(FATAL,subname//':failed to allocate mpas_from_ufs_cnst array') + mpas_from_ufs_cnst(:) = 0 + num_moist = 0 + do i = 1, size(constituent_name) + if (is_water_species(i)) then + num_moist = num_moist + 1 + mpas_from_ufs_cnst(num_moist) = i + end if + end do + + ! + ! If UFS has no scalars, let the only scalar in MPAS be 'qv' (a moisture species) + ! + if (num_scalars == 1 .and. size(constituent_name) == 0) then + num_moist = 1 + end if + + ! + ! Assign non-moisture constituents to mpas_from_ufs_cnst(num_moist+1:size(constituent_name)) + ! + idx_passive = num_moist + 1 + do i = 1, size(constituent_name) + ! If UFS constituent i is not already mapped as a moist constituent + if (.not. is_water_species(i)) then + mpas_from_ufs_cnst(idx_passive) = i + idx_passive = idx_passive + 1 + end if + end do + + ! + ! Create inverse map, ufs_from_mpas_cnst + ! + allocate(ufs_from_mpas_cnst(num_scalars), stat=ierr) + if( ierr /= 0 ) call mpp_error(FATAL,subname//':failed to allocate ufs_from_mpas_cnst array') + ufs_from_mpas_cnst(:) = 0 + + do i = 1, size(constituent_name) + ufs_from_mpas_cnst(mpas_from_ufs_cnst(i)) = i + end do + + timeLevs = 2 + + do i = 1, timeLevs + nullify(scalarsField) + call mpas_pool_get_field(statePool, 'scalars', scalarsField, timeLevel=i) + + if (.not. associated(scalarsField)) then + call mpas_log_write(trim(subname)//': ERROR: The ''scalars'' field was not found in the ''state'' pool', & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + if (i == 1) call mpas_pool_add_dimension(statePool, 'index_qv', 1) + scalarsField % constituentNames(1) = 'qv' + call mpas_add_att(scalarsField % attLists(1) % attList, 'units', 'kg kg^{-1}') + call mpas_add_att(scalarsField % attLists(1) % attList, 'long_name', 'Water vapor mixing ratio') + + do j = 2, size(constituent_name) + scalarsField % constituentNames(j) = trim(constituent_name(mpas_from_ufs_cnst(j))) + end do + + end do + + call mpas_pool_add_dimension(statePool, 'moist_start', 1) + call mpas_pool_add_dimension(statePool, 'moist_end', num_moist) + + ! + ! Print a tabular summary of the mapping between constituent indices + ! + call mpas_log_write('') + call mpas_log_write(' i MPAS constituent mpas_from_ufs_cnst(i) i UFS constituent ufs_from_mpas_cnst(i)') + call mpas_log_write('------------------------------------------ ------------------------------------------') + do i = 1, min(num_scalars, size(constituent_name)) + if (i <= num_moist) then + moisture_char = '*' + else + moisture_char = ' ' + end if + write(tempstr, '(i3,1x,a16,1x,i18,8x,i3,1x,a16,1x,i18)') i, trim(scalarsField % constituentNames(i))//moisture_char, & + mpas_from_ufs_cnst(i), & + i, trim(constituent_name(i)), & + ufs_from_mpas_cnst(i) + call mpas_log_write(trim(tempstr)) + end do + call mpas_log_write('------------------------------------------ ------------------------------------------') + call mpas_log_write('* = constituent used as a moisture species in MPAS-A dycore') + call mpas_log_write('') + + ! + ! Define scalars_tend + ! + nullify(tendPool) + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'tend', tendPool) + + if (.not. associated(tendPool)) then + call mpas_log_write(trim(subname)//': ERROR: The ''tend'' pool was not found.', & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + timeLevs = 1 + + do i = 1, timeLevs + nullify(scalarsField) + call mpas_pool_get_field(tendPool, 'scalars_tend', scalarsField, timeLevel=i) + + if (.not. associated(scalarsField)) then + call mpas_log_write(trim(subname)//': ERROR: The ''scalars_tend'' field was not found in the ''tend'' pool', & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + if (i == 1) call mpas_pool_add_dimension(tendPool, 'index_qv', 1) + scalarsField % constituentNames(1) = 'tend_qv' + call mpas_add_att(scalarsField % attLists(1) % attList, 'units', 'kg m^{-3} s^{-1}') + call mpas_add_att(scalarsField % attLists(1) % attList, 'long_name', 'Tendency of water vapor mixing ratio') + + do j = 2, size(constituent_name) + scalarsField % constituentNames(j) = 'tend_'//trim(constituent_name(mpas_from_ufs_cnst(j))) + end do + end do + + call mpas_pool_add_dimension(tendPool, 'moist_start', 1) + call mpas_pool_add_dimension(tendPool, 'moist_end', num_moist) + + end subroutine ufs_mpas_define_scalars + + !> ######################################################################################### + !> + !> \brief Define the names of lateral-boundary condition constituents at run-time. + !> \author Dustin Swales + !> \date 01 March 2026 + !> \details + !> Follows ufs_mpas_define_scalars, but for scalars in the LBC pool. + !> + !> ######################################################################################### + subroutine ufs_mpas_define_lbc_scalars(mpas_from_ufs_cnst, ufs_from_mpas_cnst, ierr) + use mpas_derived_types, only : mpas_pool_type, field3dReal, MPAS_LOG_ERR + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_field + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_add_dimension + use mpas_attlist, only : mpas_add_att + use mpas_log, only : mpas_log_write + + ! Arguments + integer, dimension(:), pointer :: mpas_from_ufs_cnst, ufs_from_mpas_cnst + integer, intent(out) :: ierr + + ! Local variables + character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_define_lbc_scalars' + type (mpas_pool_type), pointer :: lbcPool + integer, pointer :: num_scalars + integer :: i, j, timeLevs, num_moist + type (field3dReal), pointer :: scalarsField + + ierr = 0 + + ! + ! Define lbc_scalars + ! + nullify(lbcPool) + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'lbc', lbcPool) + + if (.not. associated(lbcPool)) then + call mpas_log_write(trim(subname)//': ERROR: The ''lbc'' pool was not found.', & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + nullify(num_scalars) + call mpas_pool_get_dimension(lbcPool, 'num_scalars', num_scalars) + + ! + ! The num_scalars dimension should have been defined by atm_core_interface::atm_allocate_lbc_scalars, and + ! if this dimension does not exist, something has gone wrong. + ! + if (.not. associated(num_scalars)) then + call mpas_log_write(trim(subname)//': ERROR: The ''num_scalars'' dimension does not exist in the ''lbc'' pool.', & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + timeLevs = 2 + + do i = 1, timeLevs + nullify(scalarsField) + call mpas_pool_get_field(lbcPool, 'lbc_scalars', scalarsField, timeLevel=i) + + if (.not. associated(scalarsField)) then + call mpas_log_write(trim(subname)//': ERROR: The ''lbc_scalars'' field was not found in the ''lbc'' pool', & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + if (i == 1) call mpas_pool_add_dimension(lbcPool, 'index_qv', 1) + scalarsField % constituentNames(1) = 'lbc_qv' + call mpas_add_att(scalarsField % attLists(1) % attList, 'units', 'kg kg^{-1}') + call mpas_add_att(scalarsField % attLists(1) % attList, 'long_name', 'Water vapor mixing ratio') + + do j = 2, size(constituent_name) + scalarsField % constituentNames(j) = 'lbc_'//trim(constituent_name(mpas_from_ufs_cnst(j))) + end do + + end do + + ! Define lbc_scalars_tend + ! DJS: No need to do this for LBCs. Tendency/State for LBC stored in LBC pool created + ! in ufs_mpas_update_bdy_tend() + + call mpas_pool_add_dimension(lbcPool, 'moist_start', 1) + call mpas_pool_add_dimension(lbcPool, 'moist_end', num_moist) + + end subroutine ufs_mpas_define_lbc_scalars +end module ufs_mpas_constituents diff --git a/mpas/ufs_mpas_io.F90 b/mpas/ufs_mpas_io.F90 new file mode 100644 index 000000000..046f57315 --- /dev/null +++ b/mpas/ufs_mpas_io.F90 @@ -0,0 +1,1994 @@ +!> ########################################################################################### +!> \file ufs_mpas_io.F90 +!> +!> Routines from the subdrivers for MPAS-A and CAM-SIMA have been adopted/modified here for +!> use within the UFS Weather Model for input/output. +!> +!> MPAS-A Subdriver: MPAS-Model/src/driver/mpas_subdriver.F +!> CAM-CESM (external): src/dynamics/mpas/driver/cam_mpas_subdriver.F90 +!> (https://github.com/ESCOMP/CAM/blob/cam_development/) +!> CAM-SIMA (external): src/dynamics/mpas/driver/dyn_mpas_subdriver.F90 +!> (https://github.com/ESCOMP/CAM-SIMA/blob/development/) +!> +!> +!> ########################################################################################### +module ufs_mpas_io + use mpas_derived_types, only : core_type, domain_type, mpas_Clock_type + use mpas_derived_types, only : MPAS_Time_Type + use mpas_kind_types, only : StrKIND + use module_mpas_config, only : pio_iotype, pio_stride, pio_numiotasks, pio_iodesc + use module_mpas_config, only : lbc_filename, pioid_lbc, pio_subsystem_lbc + use module_mpas_config, only : ic_filename, pioid_ic, pio_subsystem_ic + use module_mpas_config, only : pioid_output, pio_subsystem_output + use module_mpas_config, only : TIMELEVEL_NOW + use ufs_mpas_tools, only : stringify + implicit none + + ! + type(core_type), pointer :: corelist => null() + type(domain_type), pointer :: domain_ptr => null() + type(mpas_Clock_type), pointer :: clock => null() + + ! + integer :: out_file_index + type (MPAS_Time_Type), allocatable :: mpas_output_times(:) + + !> ######################################################################################### + !> + !> ######################################################################################### + type :: var_info_type + character(64) :: name = '' + character(10) :: type = '' + integer :: rank = 0 + end type var_info_type + + !> ######################################################################################### + !> This list corresponds to the "lbc_in" stream in core_atmosphere/Registry.xml + !> It consists of variables that are members of the "lbc" structure. + !> ######################################################################################### + type(var_info_type), parameter :: lbc_in_var_info_list(*) = [ & + var_info_type('lbc_u' , 'real' , 2), & + var_info_type('lbc_w' , 'real' , 2), & + var_info_type('lbc_rho' , 'real' , 2), & + var_info_type('lbc_theta' , 'real' , 2), & + var_info_type('lbc_scalars' , 'real' , 3) & + ] + + !> ######################################################################################### + !> This list corresponds to the "invariant" stream in MPAS registry. + !> It consists of variables that are members of the "mesh" structure. + !> ######################################################################################### + type(var_info_type), parameter :: invariant_var_info_list(*) = [ & + var_info_type('angleEdge' , 'real' , 1), & + var_info_type('areaCell' , 'real' , 1), & + var_info_type('areaTriangle' , 'real' , 1), & + var_info_type('bdyMaskCell' , 'integer' , 1), & + var_info_type('bdyMaskEdge' , 'integer' , 1), & + var_info_type('bdyMaskVertex' , 'integer' , 1), & + var_info_type('cellTangentPlane' , 'real' , 3), & + var_info_type('cell_gradient_coef_x' , 'real' , 2), & + var_info_type('cell_gradient_coef_y' , 'real' , 2), & + var_info_type('cellsOnCell' , 'integer' , 2), & + var_info_type('cellsOnEdge' , 'integer' , 2), & + var_info_type('cellsOnVertex' , 'integer' , 2), & + var_info_type('cf1' , 'real' , 0), & + var_info_type('cf2' , 'real' , 0), & + var_info_type('cf3' , 'real' , 0), & + var_info_type('coeffs_reconstruct' , 'real' , 3), & + var_info_type('dcEdge' , 'real' , 1), & + var_info_type('defc_a' , 'real' , 2), & + var_info_type('defc_b' , 'real' , 2), & + var_info_type('deriv_two' , 'real' , 3), & + var_info_type('dss' , 'real' , 2), & + var_info_type('dvEdge' , 'real' , 1), & + var_info_type('dzu' , 'real' , 1), & + var_info_type('edgeNormalVectors' , 'real' , 2), & + var_info_type('edgesOnCell' , 'integer' , 2), & + var_info_type('edgesOnEdge' , 'integer' , 2), & + var_info_type('edgesOnVertex' , 'integer' , 2), & + var_info_type('fEdge' , 'real' , 1), & + var_info_type('fVertex' , 'real' , 1), & + var_info_type('fzm' , 'real' , 1), & + var_info_type('fzp' , 'real' , 1), & + var_info_type('indexToCellID' , 'integer' , 1), & + var_info_type('indexToEdgeID' , 'integer' , 1), & + var_info_type('indexToVertexID' , 'integer' , 1), & + var_info_type('kiteAreasOnVertex' , 'real' , 2), & + var_info_type('latCell' , 'real' , 1), & + var_info_type('latEdge' , 'real' , 1), & + var_info_type('latVertex' , 'real' , 1), & + var_info_type('localVerticalUnitVectors' , 'real' , 2), & + var_info_type('lonCell' , 'real' , 1), & + var_info_type('lonEdge' , 'real' , 1), & + var_info_type('lonVertex' , 'real' , 1), & + var_info_type('meshDensity' , 'real' , 1), & + var_info_type('nEdgesOnCell' , 'integer' , 1), & + var_info_type('nEdgesOnEdge' , 'integer' , 1), & + var_info_type('nominalMinDc' , 'real' , 0), & + var_info_type('qv_init' , 'real' , 1), & + var_info_type('rdzu' , 'real' , 1), & + var_info_type('rdzw' , 'real' , 1), & + var_info_type('t_init' , 'real' , 2), & + var_info_type('u_init' , 'real' , 1), & + var_info_type('v_init' , 'real' , 1), & + var_info_type('verticesOnCell' , 'integer' , 2), & + var_info_type('verticesOnEdge' , 'integer' , 2), & + var_info_type('weightsOnEdge' , 'real' , 2), & + var_info_type('xCell' , 'real' , 1), & + var_info_type('xEdge' , 'real' , 1), & + var_info_type('xVertex' , 'real' , 1), & + var_info_type('yCell' , 'real' , 1), & + var_info_type('yEdge' , 'real' , 1), & + var_info_type('yVertex' , 'real' , 1), & + var_info_type('zCell' , 'real' , 1), & + var_info_type('zEdge' , 'real' , 1), & + var_info_type('zVertex' , 'real' , 1), & + var_info_type('zb' , 'real' , 3), & + var_info_type('zb3' , 'real' , 3), & + var_info_type('zgrid' , 'real' , 2), & + var_info_type('zxu' , 'real' , 2), & + var_info_type('zz' , 'real' , 2) & + ] + + !> ######################################################################################### + !> This list corresponds to the "input" stream in MPAS registry. + !> It consists of variables that are members of the "diag" and "state" structure. + !> Only variables that are specific to the "input" stream are included. + !> ######################################################################################### + type(var_info_type), parameter :: input_var_info_list(*) = [ & + var_info_type('Time' , 'real' , 0), & + var_info_type('initial_time' , 'character' , 0), & + var_info_type('rho' , 'real' , 2), & + var_info_type('rho_base' , 'real' , 2), & + var_info_type('scalars' , 'real' , 3), & + var_info_type('theta' , 'real' , 2), & + var_info_type('theta_base' , 'real' , 2), & + var_info_type('u' , 'real' , 2), & + var_info_type('w' , 'real' , 2), & + var_info_type('xtime' , 'character' , 0) & + ] + + !> ######################################################################################### + !> This list corresponds to the "ugwp_oro_data_in" stream in MPAS registry. + !> It consists of variables that are members of the "sfc_input" structure. + !> ######################################################################################### + type(var_info_type), parameter :: ugwp_oro_data_var_info_list(*) = [ & + var_info_type('var2dls' , 'real' , 1), & + var_info_type('conls' , 'real' , 1), & + var_info_type('oa1ls' , 'real' , 1), & + var_info_type('oa2ls' , 'real' , 1), & + var_info_type('oa3ls' , 'real' , 1), & + var_info_type('oa4ls' , 'real' , 1), & + var_info_type('ol1ls' , 'real' , 1), & + var_info_type('ol2ls' , 'real' , 1), & + var_info_type('ol3ls' , 'real' , 1), & + var_info_type('ol4ls' , 'real' , 1), & + var_info_type('var2dss' , 'real' , 1), & + var_info_type('conss' , 'real' , 1), & + var_info_type('oa1ss' , 'real' , 1), & + var_info_type('oa2ss' , 'real' , 1), & + var_info_type('oa3ss' , 'real' , 1), & + var_info_type('oa4ss' , 'real' , 1), & + var_info_type('ol1ss' , 'real' , 1), & + var_info_type('ol2ss' , 'real' , 1), & + var_info_type('ol3ss' , 'real' , 1), & + var_info_type('ol4ss' , 'real' , 1) & + ] + + !> ######################################################################################### + !> This list corresponds to the "sfc_input" stream in MPAS registry. + !> It consists of variables that are members of the "sfc_input" structure. + !> Only variables needed to initialize the CCPP physics surface schemes are included. + !> ######################################################################################### + type(var_info_type), parameter :: sfc_input_var_info_list(*) = [ & + var_info_type('isltyp' , 'integer' , 1), & + var_info_type('ivgtyp' , 'integer' , 1), & + var_info_type('sfc_albbck' , 'real' , 1), & + var_info_type('skintemp' , 'real' , 1), & + var_info_type('snow' , 'real' , 1), & + var_info_type('snowc' , 'real' , 1), & + var_info_type('snowh' , 'real' , 1), & + var_info_type('sst' , 'real' , 1), & + var_info_type('tmn' , 'real' , 1), & + var_info_type('vegfra' , 'real' , 1), & + var_info_type('seaice' , 'real' , 1), & + var_info_type('xice' , 'real' , 1), & + var_info_type('xland' , 'real' , 1), & + var_info_type('dzs' , 'real' , 2), & + var_info_type('sh2o' , 'real' , 2), & + var_info_type('smois' , 'real' , 2), & + var_info_type('tslb' , 'real' , 2), & + var_info_type('ter' , 'real' , 1), & + var_info_type('landmask' , 'integer' , 1), & + var_info_type('mminlu' , 'character' , 0), & + var_info_type('isice_lu' , 'integer' , 0), & + var_info_type('iswater_lu' , 'integer' , 0), & + var_info_type('shdmin' , 'real' , 1), & + var_info_type('shdmax' , 'real' , 1), & + var_info_type('snoalb' , 'real' , 1), & + var_info_type('greenfrac' , 'real' , 2), & + var_info_type('albedo12m' , 'real' , 2), & + var_info_type('soilcomp' , 'real' , 2), & + var_info_type('soilcl1' , 'real' , 1), & + var_info_type('soilcl2' , 'real' , 1), & + var_info_type('soilcl3' , 'real' , 1), & + var_info_type('soilcl4' , 'real' , 1), & + var_info_type('var2d' , 'real' , 1), & + var_info_type('con' , 'real' , 1), & + var_info_type('oa1' , 'real' , 1), & + var_info_type('oa2' , 'real' , 1), & + var_info_type('oa3' , 'real' , 1), & + var_info_type('oa4' , 'real' , 1), & + var_info_type('ol1' , 'real' , 1), & + var_info_type('ol2' , 'real' , 1), & + var_info_type('ol3' , 'real' , 1), & + var_info_type('ol4' , 'real' , 1) & + ] + + !> ######################################################################################### + !> This list corresponds to the "restart" stream in MPAS registry. + !> It consists of variables that are members of the "diag" and "state" structure. + !> Only variables that are specific to the "restart" stream are included. + !> ######################################################################################### + type(var_info_type), parameter :: restart_var_info_list(*) = [ & + var_info_type('exner' , 'real' , 2), & + var_info_type('exner_base' , 'real' , 2), & + var_info_type('pressure_base' , 'real' , 2), & + var_info_type('pressure_p' , 'real' , 2), & + var_info_type('rho_p' , 'real' , 2), & + var_info_type('rho_zz' , 'real' , 2), & + var_info_type('rtheta_base' , 'real' , 2), & + var_info_type('rtheta_p' , 'real' , 2), & + var_info_type('ru' , 'real' , 2), & + var_info_type('ru_p' , 'real' , 2), & + var_info_type('rw' , 'real' , 2), & + var_info_type('rw_p' , 'real' , 2), & + var_info_type('theta_m' , 'real' , 2) & + ] + + !> ######################################################################################### + !> This list corresponds to the "output" stream in MPAS registry. + !> It consists of variables that are members of the "diag" structure. + !> Only variables that are specific to the "output" stream are included. + !> ######################################################################################### + type(var_info_type), parameter :: output_var_info_list(*) = [ & + var_info_type('Time' , 'real' , 0), & + var_info_type('initial_time' , 'character' , 0), & + !var_info_type('divergence' , 'real' , 2), & + !var_info_type('pressure' , 'real' , 2), & + !var_info_type('relhum' , 'real' , 2), & + !var_info_type('rho' , 'real' , 2), & + var_info_type('scalars' , 'real' , 3), & + var_info_type('surface_pressure' , 'real' , 1), & + var_info_type('theta' , 'real' , 2), & + !var_info_type('u' , 'real' , 2), & + var_info_type('uReconstructMeridional' , 'real' , 2), & + var_info_type('uReconstructZonal' , 'real' , 2), & + var_info_type('vorticity' , 'real' , 2), & + var_info_type('w' , 'real' , 2) & + !var_info_type('zz' , 'real' , 2) & + ] + +contains + + !> ######################################################################################### + !> Procedure to open MPAS IC file. + !> + !> ######################################################################################### + subroutine ufs_mpas_open_init() + ! PIO + use pio, only : pio_openfile, pio_nowrite + ! FMS + use fms2_io_mod, only : file_exists + use mpp_mod, only : FATAL, mpp_error + ! Arguments + ! Locals + integer :: ierr + character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_open_init' + + ! Open MPAS Initial Condition file. + if (file_exists(ic_filename)) then + ierr = pio_openfile(pio_subsystem_ic, pioid_ic, pio_iotype, ic_filename, pio_nowrite) + if (ierr /= 0) then + call mpp_error(FATAL,subname//": Failed opening MPAS IC File, "//trim(ic_filename)) + end if + else + call mpp_error(FATAL,subname//": Cannot find MPAS IC file: "//trim(ic_filename)) + end if + end subroutine ufs_mpas_open_init + + !> ######################################################################################### + !> Procedure to open MPAS Lateral Boundary Condition file. + !> + !> ######################################################################################### + subroutine ufs_mpas_open_lbc() + ! PIO + use pio, only : pio_openfile, pio_nowrite + ! FMS + use fms2_io_mod, only : file_exists + use mpp_mod, only : FATAL, mpp_error + ! Arguments + ! Locals + integer :: ierr + character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_open_lbc' + + ! Open MPAS Initial Condition file. + if (file_exists(lbc_filename)) then + ierr = pio_openfile(pio_subsystem_lbc, pioid_lbc, pio_iotype, lbc_filename, pio_nowrite) + if (ierr /= 0) then + call mpp_error(FATAL,subname//": Failed opening MPAS LBC File, "//trim(lbc_filename)) + end if + else + call mpp_error(FATAL,subname//": Cannot find MPAS LBC file: "//trim(lbc_filename)) + end if + end subroutine ufs_mpas_open_lbc + + !> ######################################################################################### + !> Procedure to create and write to MPAS stream + !> + !> ######################################################################################### + subroutine ufs_mpas_write(stream_name, timestamp) + ! PIO + use pio, only : pio_openfile, pio_createfile, PIO_WRITE, PIO_CLOBBER + use mpas_log, only : mpas_log_write + use mpas_timekeeping, only : MPAS_NOW, MPAS_STREAM_EARLIEST_STRICTLY_AFTER + use mpp_mod, only : mpp_error, FATAL + ! Arguments + character(len=*), intent(in) :: stream_name + character(len=*), intent(in) :: timestamp + ! Locals + character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_write' + character(len=:), allocatable :: filename + integer :: ierr + type(var_info_type), allocatable :: output_var_info_list(:) + integer :: timelevel, whence + logical, parameter :: debug = .true. + + if (trim(stream_name) == "output") then + filename = 'history.'//trim(timestamp)//'.nc' + else if (trim(stream_name) == "restart") then + filename = 'restart.'//trim(timestamp)//'.nc' + else if (trim(stream_name) == "input") then + filename = 'input.'//trim(timestamp)//'.nc' + else + stop "Invalid stream_name to ufs_mpas_write: stream_name =" & + //trim(stream_name) + end if + + if (debug) call mpas_log_write("entering ufs_mpas_write") + if (debug) call mpas_log_write("creating "//trim(stream_name)//" stream file: "//trim(filename)) + ierr = pio_createfile(pio_subsystem_output, pioid_output, pio_iotype, trim(filename)) + if ( ierr /= 0 ) call mpp_error(FATAL, subname//": pio_createfile failed ") + + output_var_info_list = parse_stream_name_fragment('output') + timelevel = TIMELEVEL_NOW + whence = MPAS_NOW + + call dyn_mpas_read_write_stream(clock, "write", stream_name, pioid_output, & + timeLevel=timelevel, whence=whence, & + nRecord=1, ierr=ierr) + if ( ierr /= 0 ) call mpp_error(FATAL, & + subname//": dyn_mpas_read_write_stream failed ") + + if (debug) call mpas_log_write("exiting ufs_mpas_write") + end subroutine ufs_mpas_write + + !> ######################################################################################## + !> + !> \brief Computes local unit north, east, and edge-normal vectors + !> \author Michael Duda + !> \date 15 January 2020 + !> \details + !> This routine computes the local unit north and east vectors at all cell + !> centers, storing the resulting fields in the mesh pool as 'north' and + !> 'east'. It also computes the edge-normal unit vectors by calling + !> the mpas_initialize_vectors routine. Before this routine is called, + !> the mesh pool must contain 'latCell' and 'lonCell' fields that are valid + !> for all cells (not just solve cells), plus any fields that are required + !> by the mpas_initialize_vectors routine. + !> + !> \update: Dustin Swales April 2025 - Modified for use in UWM + !> + !> ######################################################################################## + subroutine ufs_mpas_compute_unit_vectors() + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_dimension, mpas_pool_get_array + use mpas_derived_types, only : mpas_pool_type + use mpas_kind_types, only : RKIND + use mpas_vector_operations, only : mpas_initialize_vectors + use module_mpas_config, only : nCellsSolve, latCell, lonCell + + type (mpas_pool_type), pointer :: meshPool + real(kind=RKIND), dimension(:,:), pointer :: east, north + integer, pointer :: nCells + integer :: iCell + + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nCells', nCells) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'east', east) + call mpas_pool_get_array(meshPool, 'north', north) + + do iCell = 1, nCells + east(1,iCell) = -sin(lonCell(iCell)) + east(2,iCell) = cos(lonCell(iCell)) + east(3,iCell) = 0.0_RKIND + + ! Normalize + east(1:3,iCell) = east(1:3,iCell) / sqrt(sum(east(1:3,iCell) * east(1:3,iCell))) + + north(1,iCell) = -cos(lonCell(iCell))*sin(latCell(iCell)) + north(2,iCell) = -sin(lonCell(iCell))*sin(latCell(iCell)) + north(3,iCell) = cos(latCell(iCell)) + + ! Normalize + north(1:3,iCell) = north(1:3,iCell) / sqrt(sum(north(1:3,iCell) * north(1:3,iCell))) + + end do + + call mpas_initialize_vectors(meshPool) + + end subroutine ufs_mpas_compute_unit_vectors + + !> ######################################################################################## + !> + !> \brief Returns global mesh dimensions + !> \author Michael Duda + !> \date 22 August 2019 + !> \details + !> This routine returns on all tasks the number of global cells, edges, + !> vertices, maxEdges, vertical layers, and the maximum number of cells owned by any task. + !> + !> \update: Dustin Swales April 2025 - Modified for use in UWM + !> + !> ######################################################################################## + subroutine ufs_mpas_get_global_dims(nCellsGlobal, nEdgesGlobal, nVerticesGlobal, maxEdges,& + nVertLevels, maxNCells) + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_dimension + use mpas_derived_types, only : mpas_pool_type + use mpas_dmpar, only : mpas_dmpar_sum_int, mpas_dmpar_max_int + use module_mpas_config, only : nCellsSolve, nEdgesSolve, nVerticesSolve + + integer, intent(out) :: nCellsGlobal + integer, intent(out) :: nEdgesGlobal + integer, intent(out) :: nVerticesGlobal + integer, intent(out) :: maxEdges + integer, intent(out) :: nVertLevels + integer, intent(out) :: maxNCells + + integer, pointer :: maxEdgesLocal + integer, pointer :: nVertLevelsLocal + + type (mpas_pool_type), pointer :: meshPool + + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(meshPool, 'nVerticesSolve', nVerticesSolve) + call mpas_pool_get_dimension(meshPool, 'maxEdges', maxEdgesLocal) + call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevelsLocal) + + call mpas_dmpar_sum_int(domain_ptr % dminfo, nCellsSolve, nCellsGlobal) + call mpas_dmpar_sum_int(domain_ptr % dminfo, nEdgesSolve, nEdgesGlobal) + call mpas_dmpar_sum_int(domain_ptr % dminfo, nVerticesSolve, nVerticesGlobal) + + maxEdges = maxEdgesLocal + nVertLevels = nVertLevelsLocal + + call mpas_dmpar_max_int(domain_ptr % dminfo, nCellsSolve, maxNCells) + + end subroutine ufs_mpas_get_global_dims + + !> ######################################################################################## + !> + !> \brief Returns global coordinate arrays + !> \author Michael Duda + !> \date 22 August 2019 + !> \details + !> This routine returns on all tasks arrays of latitude, longitude, and cell + !> area for all (global) cells. + !> + !> It is assumed that latCellGlobal, lonCellGlobal, and areaCellGlobal have + !> been allocated by the caller with a size equal to the global number of + !> cells in the mesh. + !> + !> \update: Dustin Swales April 2025 - Modified for use in UWM + !> + !> ######################################################################################## + subroutine ufs_mpas_get_global_coords(latCellGlobal, lonCellGlobal, areaCellGlobal) + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_dimension, mpas_pool_get_array + use mpas_derived_types, only : mpas_pool_type + use mpas_kind_types, only : RKIND + use mpas_dmpar, only : mpas_dmpar_sum_int, mpas_dmpar_max_real_array + use mpp_mod, only : FATAL, mpp_error + use module_mpas_config, only : nCellsSolve, latCell, lonCell + real (kind=RKIND), dimension(:), intent(out) :: latCellGlobal + real (kind=RKIND), dimension(:), intent(out) :: lonCellGlobal + real (kind=RKIND), dimension(:), intent(out) :: areaCellGlobal + + integer :: iCell + + integer, dimension(:), pointer :: indexToCellID + + type (mpas_pool_type), pointer :: meshPool + integer :: nCellsGlobal,ierr + + real (kind=RKIND), dimension(:), pointer :: areaCell + real (kind=RKIND), dimension(:), pointer :: temp + + character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_get_global_coords' + + + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_array(meshPool, 'indexToCellID', indexToCellID) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + call mpas_pool_get_array(meshPool, 'areaCell', areaCell) + + call mpas_dmpar_sum_int(domain_ptr % dminfo, nCellsSolve, nCellsGlobal) + + ! check: size(latCellGlobal) ?= nCellsGlobal + allocate(temp(nCellsGlobal), stat=ierr) + if( ierr /= 0 ) call mpp_error(FATAL,subname//':failed to allocate temp array') + + ! + ! latCellGlobal + ! + temp(:) = -huge(temp(0)) + do iCell=1,nCellsSolve + temp(indexToCellID(iCell)) = latCell(iCell) + end do + + call mpas_dmpar_max_real_array(domain_ptr % dminfo, nCellsGlobal, temp, latCellGlobal) + + ! + ! lonCellGlobal + ! + temp(:) = -huge(temp(0)) + do iCell=1,nCellsSolve + temp(indexToCellID(iCell)) = lonCell(iCell) + end do + + call mpas_dmpar_max_real_array(domain_ptr % dminfo, nCellsGlobal, temp, lonCellGlobal) + + ! + ! areaCellGlobal + ! + temp(:) = -huge(temp(0)) + do iCell=1,nCellsSolve + temp(indexToCellID(iCell)) = areaCell(iCell) + end do + + call mpas_dmpar_max_real_array(domain_ptr % dminfo, nCellsGlobal, temp, areaCellGlobal) + + deallocate(temp) + + end subroutine ufs_mpas_get_global_coords + + !> ######################################################################################## + !> + !> subroutine dyn_mpas_exchange_halo + !> + !> summary: Update the halo layers of the named field. + !> author: Michael Duda + !> date: 16 January 2020 + !> + !> Given a field name that is defined in MPAS registry, this subroutine updates + !> the halo layers for that field. + !> Ported and refactored for CAM-SIMA. (KCW, 2024-03-18) + !> + !> \update: Dustin Swales April 2025 - Modified for use in UWM + !> + !> ######################################################################################## + subroutine dyn_mpas_exchange_halo(field_name) + ! Module(s) from MPAS. + use mpas_derived_types, only : field1dinteger, field2dinteger, field3dinteger, & + field1dreal, field2dreal, field3dreal, field4dreal, & + field5dreal, mpas_pool_field_info_type, mpas_pool_integer,& + mpas_pool_real + use mpas_dmpar, only : mpas_dmpar_exch_halo_field + use mpas_pool_routines, only : mpas_pool_get_field, mpas_pool_get_field_info + use mpp_mod, only : FATAL, mpp_error + use mpas_log, only : mpas_log_write + character(*), intent(in) :: field_name + + character(*), parameter :: subname = 'dyn_mpas_subdriver::dyn_mpas_exchange_halo' + type(field1dinteger), pointer :: field_1d_integer + type(field2dinteger), pointer :: field_2d_integer + type(field3dinteger), pointer :: field_3d_integer + type(field1dreal), pointer :: field_1d_real + type(field2dreal), pointer :: field_2d_real + type(field3dreal), pointer :: field_3d_real + type(field4dreal), pointer :: field_4d_real + type(field5dreal), pointer :: field_5d_real + type(mpas_pool_field_info_type) :: mpas_pool_field_info + + call mpas_log_write(subname // ' entered') + + nullify(field_1d_integer) + nullify(field_2d_integer) + nullify(field_3d_integer) + nullify(field_1d_real) + nullify(field_2d_real) + nullify(field_3d_real) + nullify(field_4d_real) + nullify(field_5d_real) + + call mpas_log_write('Inquiring field information for "' // trim(adjustl(field_name)) // '"') + + call mpas_pool_get_field_info(domain_ptr % blocklist % allfields, & + trim(adjustl(field_name)), mpas_pool_field_info) + + if (mpas_pool_field_info % fieldtype == -1 .or. & + mpas_pool_field_info % ndims == -1 .or. & + mpas_pool_field_info % nhalolayers == -1) then + call mpp_error(FATAL,subname//'Invalid field information for "' // trim(adjustl(field_name)) // '"') + end if + + ! No halo layers to exchange. This field is not decomposed. + if (mpas_pool_field_info % nhalolayers == 0) then + call mpas_log_write('Skipping field "' // trim(adjustl(field_name)) // '" due to not decomposed') + return + end if + + call mpas_log_write('Exchanging halo layers for "' // trim(adjustl(field_name)) // '"') + + select case (mpas_pool_field_info % fieldtype) + case (mpas_pool_integer) + select case (mpas_pool_field_info % ndims) + case (1) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(field_name)), field_1d_integer, timelevel=1) + + if (.not. associated(field_1d_integer)) then + call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') + end if + + call mpas_dmpar_exch_halo_field(field_1d_integer) + + nullify(field_1d_integer) + case (2) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(field_name)), field_2d_integer, timelevel=1) + + if (.not. associated(field_2d_integer)) then + call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') + end if + + call mpas_dmpar_exch_halo_field(field_2d_integer) + + nullify(field_2d_integer) + case (3) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(field_name)), field_3d_integer, timelevel=1) + + if (.not. associated(field_3d_integer)) then + call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') + end if + + call mpas_dmpar_exch_halo_field(field_3d_integer) + + nullify(field_3d_integer) + case default + call mpp_error(FATAL,subname//'Unsupported field rank ' // stringify([mpas_pool_field_info % ndims])) + end select + case (mpas_pool_real) + select case (mpas_pool_field_info % ndims) + case (1) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(field_name)), field_1d_real, timelevel=1) + + if (.not. associated(field_1d_real)) then + call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') + end if + + call mpas_dmpar_exch_halo_field(field_1d_real) + + nullify(field_1d_real) + case (2) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(field_name)), field_2d_real, timelevel=1) + + if (.not. associated(field_2d_real)) then + call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') + end if + call mpas_dmpar_exch_halo_field(field_2d_real) + nullify(field_2d_real) + case (3) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(field_name)), field_3d_real, timelevel=1) + + if (.not. associated(field_3d_real)) then + call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') + end if + + call mpas_dmpar_exch_halo_field(field_3d_real) + + nullify(field_3d_real) + case (4) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(field_name)), field_4d_real, timelevel=1) + + if (.not. associated(field_4d_real)) then + call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') + end if + + call mpas_dmpar_exch_halo_field(field_4d_real) + + nullify(field_4d_real) + case (5) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(field_name)), field_5d_real, timelevel=1) + + if (.not. associated(field_5d_real)) then + call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') + end if + + call mpas_dmpar_exch_halo_field(field_5d_real) + + nullify(field_5d_real) + case default + call mpp_error(FATAL,subname//'Unsupported field rank ' // stringify([mpas_pool_field_info % ndims])) + end select + case default + call mpp_error(FATAL,subname//'Unsupported field type (Must be one of: integer, real)') + end select + + call mpas_log_write(subname // ' completed') + end subroutine dyn_mpas_exchange_halo + + !> ######################################################################################## + !> subroutine dyn_mpas_read_write_stream + !> + !> summary: Read or write an MPAS stream. + !> author: Kuan-Chih Wang + !> date: 2024-03-15 + !> + !> In the context of MPAS, the concept of a "pool" resembles a group of + !> (related) variables, while the concept of a "stream" resembles a file. + !> This subroutine reads or writes an MPAS stream. It provides the mechanism + !> for CAM-SIMA to input/output data to/from MPAS dynamical core. + !> Analogous to the `{read,write}_stream` subroutines in MPAS stream manager. + !> + !> \update: Dustin Swales April 2025 - Modified for use in UWM + !> + !> ######################################################################################## + subroutine dyn_mpas_read_write_stream(clock, stream_mode, stream_name, pio_file_desc, & + timeLevel, when, whence, actualWhen, nRecord, ierr) + ! Module(s) from external libraries. + use pio, only : file_desc_t + use mpp_mod, only : FATAL, mpp_error + ! Module(s) from MPAS. + use mpas_derived_types, only : mpas_pool_type, mpas_stream_noerr, mpas_stream_type + use mpas_io_streams, only : mpas_closestream, mpas_writestream + use mpas_pool_routines, only : mpas_pool_destroy_pool + use mpas_stream_manager, only : postread_reindex, prewrite_reindex, postwrite_reindex + use mpas_log, only : mpas_log_write + use mpas_io_streams, only : MPAS_STREAM_EXACT_TIME + use mpas_timekeeping, only : mpas_get_clock_time, MPAS_NOW + ! Arguments + type (mpas_clock_type), intent(in) :: clock + character(*), intent(in) :: stream_mode + character(*), intent(in) :: stream_name + type(file_desc_t), pointer, intent(in) :: pio_file_desc + integer, intent(in) :: timeLevel + character (len=*), intent(in), optional :: when + integer, intent(in), optional :: whence + character (len=*), intent(out), optional :: actualWhen + integer, intent(in) :: nRecord + integer, intent(out) :: ierr + ! Local variables + character(*), parameter :: subname = 'dyn_mpas_subdriver::dyn_mpas_read_write_stream' + integer :: i + type(mpas_pool_type), pointer :: mpas_pool + type(mpas_stream_type), pointer :: mpas_stream + type(var_info_type), allocatable :: var_info_list(:) + + ierr = 0 + call mpas_log_write('') + + nullify(mpas_pool) + nullify(mpas_stream) + call mpas_log_write( '---------------------------------------------------------------------') + call mpas_log_write( 'Initializing stream "' // trim(adjustl(stream_name)) // '"') + + call dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file_desc, stream_mode, stream_name, timeLevel) + + if (.not. associated(mpas_pool)) then + call mpp_error(FATAL,subname//'Failed to initialize stream "' // trim(adjustl(stream_name)) // '"') + end if + + if (.not. associated(mpas_stream)) then + call mpp_error(FATAL,subname//'Failed to initialize stream "' // trim(adjustl(stream_name)) // '"') + end if + + select case (trim(adjustl(stream_mode))) + case ('r', 'read') + call mpas_log_write('Reading stream "' // trim(adjustl(stream_name)) // '"') + + call read_stream(mpas_stream, actualWhen, nRecord, ierr) + + if (ierr /= mpas_stream_noerr) then + call mpp_error(FATAL,subname//'Failed to read stream "' // trim(adjustl(stream_name)) // '"') + end if + + ! Exchange halo layers because new data have just been read. + var_info_list = parse_stream_name(stream_name) + + do i = 1, size(var_info_list) + call dyn_mpas_exchange_halo(var_info_list(i) % name) + if ( ierr /= 0 ) then + call mpp_error(FATAL,subname//'Failed to exchange halo layers for group '//var_info_list(i) % name) + end if + end do + + ! For any connectivity arrays in this stream, convert global indexes to local indexes. + call postread_reindex(domain_ptr % blocklist % allfields, domain_ptr % packages, & + mpas_pool, mpas_pool) + case ('w', 'write') + call mpas_log_write('Writing stream "' // trim(adjustl(stream_name)) // '"') + + ! WARNING: + ! The `{pre,post}write_reindex` subroutines are STATEFUL because they store information inside their module + ! (i.e., module variables). They MUST be called in pairs, like below, to prevent undefined behaviors. + ! For any connectivity arrays in this stream, temporarily convert local indexes to global indexes. + call prewrite_reindex(domain_ptr % blocklist % allfields, domain_ptr % packages, & + mpas_pool, mpas_pool) + + call mpas_writestream(mpas_stream, 1, ierr=ierr) + + if (ierr /= mpas_stream_noerr) then + call mpp_error(FATAL,subname//'Failed to write stream "' // trim(adjustl(stream_name)) // '"') + end if + + ! For any connectivity arrays in this stream, reset global indexes back to local indexes. + call postwrite_reindex(domain_ptr % blocklist % allfields, mpas_pool) + case default + call mpp_error(FATAL,subname//'Unsupported stream mode "' // trim(adjustl(stream_mode)) // '"') + end select + + call mpas_log_write('Closing stream "' // trim(adjustl(stream_name)) // '"') + call mpas_log_write( '---------------------------------------------------------------------') + + call mpas_closestream(mpas_stream, ierr=ierr) + + if (ierr /= mpas_stream_noerr) then + call mpp_error(FATAL,subname//'Failed to close stream "' // trim(adjustl(stream_name)) // '"') + end if + + ! Deallocate temporary pointers to avoid memory leaks. + call mpas_pool_destroy_pool(mpas_pool) + nullify(mpas_pool) + + deallocate(mpas_stream) + nullify(mpas_stream) + call mpas_log_write(subname // ' completed') + + end subroutine dyn_mpas_read_write_stream + + !> ######################################################################################## + !> subroutine read_stream + !> + !> + !> ######################################################################################## + subroutine read_stream(stream, actualWhen, nRecord, ierr) + use mpas_io_streams, only : MPAS_readStream, MPAS_streamTime + use mpas_derived_types, only : mpas_pool_type, mpas_stream_noerr, mpas_stream_type + + type(mpas_stream_type), pointer, intent(inout) :: stream + integer, intent(in) :: nRecord + character (len=*), intent(out), optional :: actualWhen + integer, intent(out) :: ierr + + call MPAS_readStream(stream, nRecord, ierr=ierr) + if (present(actualWhen)) then + call MPAS_streamTime(stream, nRecord, actualWhen, ierr=ierr) + endif + + end subroutine read_stream + + !> ######################################################################################## + !> subroutine dyn_mpas_init_stream_with_pool + !> + !> summary: Initialize an MPAS stream with an accompanying MPAS pool. + !> author: Kuan-Chih Wang + !> date: 2024-03-14 + !> + !> In the context of MPAS, the concept of a "pool" resembles a group of + !> (related) variables, while the concept of a "stream" resembles a file. + !> This subroutine initializes an MPAS stream with an accompanying MPAS pool by + !> adding variable and attribute information to them. After that, MPAS is ready + !> to perform IO on them. + !> Analogous to the `build_stream` and `mpas_stream_mgr_add_field` + !> subroutines in MPAS stream manager. + !> + !> \update: Dustin Swales April 2025 - Modified for use in UWM + !> + !> ######################################################################################## + subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stream_mode, & + stream_name, timeLevel) + ! Module(s) from external libraries. + use pio, only: file_desc_t, pio_file_is_open + ! Module(s) from MPAS. + use mpas_derived_types, only : field0dchar, field1dchar, field0dinteger, field1dinteger,& + field2dinteger, field3dinteger, field0dreal, field1dreal,& + field2dreal, field3dreal, field4dreal, field5dreal, & + mpas_io_native_precision, mpas_io_pnetcdf, mpas_io_read, & + mpas_io_write, mpas_pool_type, mpas_stream_noerr, & + mpas_stream_type + use mpas_io_streams, only : mpas_createstream, mpas_streamaddfield + use mpas_pool_routines, only : mpas_pool_add_config, mpas_pool_create_pool, mpas_pool_get_field + use mpas_kind_types, only : StrKIND, RKIND + use mpp_mod, only : FATAL, mpp_error + use mpas_log, only : mpas_log_write + + type(mpas_pool_type), pointer, intent(out) :: mpas_pool + type(mpas_stream_type), pointer, intent(out) :: mpas_stream + type(file_desc_t), pointer, intent(in) :: pio_file + character(*), intent(in) :: stream_mode + character(*), intent(in) :: stream_name + integer, intent(in) :: timeLevel + + interface add_stream_attribute + procedure :: add_stream_attribute_0d + procedure :: add_stream_attribute_1d + end interface add_stream_attribute + + character(*), parameter :: subname = 'dyn_mpas_subdriver::dyn_mpas_init_stream_with_pool' + character(strkind) :: stream_filename + integer :: i, ierr, stream_format + !> Whether a variable is present on the file (i.e., `pio_file`). + logical, allocatable :: var_is_present(:) + !> Whether a variable is type, kind, and rank compatible with what MPAS expects on the file (i.e., `pio_file`). + logical, allocatable :: var_is_tkr_compatible(:) + type(field0dchar), pointer :: field_0d_char + type(field1dchar), pointer :: field_1d_char + type(field0dinteger), pointer :: field_0d_integer + type(field1dinteger), pointer :: field_1d_integer + type(field2dinteger), pointer :: field_2d_integer + type(field3dinteger), pointer :: field_3d_integer + type(field0dreal), pointer :: field_0d_real + type(field1dreal), pointer :: field_1d_real + type(field2dreal), pointer :: field_2d_real + type(field3dreal), pointer :: field_3d_real + type(field4dreal), pointer :: field_4d_real + type(field5dreal), pointer :: field_5d_real + type(var_info_type), allocatable :: var_info_list(:) + + call mpas_log_write(subname // ' entered') + + nullify(field_0d_char) + nullify(field_1d_char) + nullify(field_0d_integer) + nullify(field_1d_integer) + nullify(field_2d_integer) + nullify(field_3d_integer) + nullify(field_0d_real) + nullify(field_1d_real) + nullify(field_2d_real) + nullify(field_3d_real) + nullify(field_4d_real) + nullify(field_5d_real) + + call mpas_pool_create_pool(mpas_pool) + + allocate(mpas_stream, stat=ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate stream "' // trim(adjustl(stream_name)) // '"') + end if + + ! Not actually used because a PIO file descriptor is directly supplied. + stream_filename = 'external stream' + stream_format = mpas_io_pnetcdf + + call mpas_log_write('Checking PIO file descriptor') + + if (.not. associated(pio_file)) then + call mpp_error(FATAL,subname//'Invalid PIO file descriptor') + end if + + if (.not. pio_file_is_open(pio_file)) then + call mpp_error(FATAL,subname//'Invalid PIO file descriptor') + end if + + select case (trim(adjustl(stream_mode))) + case ('r', 'read') + call mpas_log_write('Creating stream "' // trim(adjustl(stream_name)) // '" for reading') + + call mpas_createstream( & + mpas_stream, domain_ptr % iocontext, stream_filename, stream_format, mpas_io_read, & + clobberrecords=.false., clobberfiles=.false., truncatefiles=.false., & + precision=mpas_io_native_precision, pio_file_desc=pio_file, ierr=ierr) + case ('w', 'write') + call mpas_log_write('Creating stream "' // trim(adjustl(stream_name)) // '" for writing') + + call mpas_createstream( & + mpas_stream, domain_ptr % iocontext, stream_filename, stream_format, mpas_io_write, & + clobberrecords=.false., clobberfiles=.false., truncatefiles=.false., & + precision=mpas_io_native_precision, pio_file_desc=pio_file, ierr=ierr) + case default + call mpp_error(FATAL,subname//'Unsupported stream mode "' // trim(adjustl(stream_mode)) // '"') + end select + + if (ierr /= mpas_stream_noerr) then + call mpp_error(FATAL,subname//'Failed to create stream "' // trim(adjustl(stream_name)) // '"') + end if + + var_info_list = parse_stream_name(stream_name) + + ! Add variables contained in `var_info_list` to stream. + do i = 1, size(var_info_list) + call mpas_log_write('var_info_list(' // stringify([i]) // ') % name = ' // stringify([var_info_list(i) % name])) + call mpas_log_write('var_info_list(' // stringify([i]) // ') % type = ' // stringify([var_info_list(i) % type])) + call mpas_log_write('var_info_list(' // stringify([i]) // ') % rank = ' // stringify([var_info_list(i) % rank])) + + if (trim(adjustl(stream_mode)) == 'r' .or. trim(adjustl(stream_mode)) == 'read') then + call dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, pio_file, var_info_list(i)) + + ! Do not hard crash the model if a variable is missing and cannot be read. + ! This can happen if users attempt to initialize/restart the model with data generated by + ! older versions of MPAS. Print a debug message to let users decide if this is acceptable. + if (.not. any(var_is_present)) then + call mpas_log_write('Skipping variable "' // trim(adjustl(var_info_list(i) % name)) // '" due to not present') + + cycle + end if + + if (any(var_is_present .and. .not. var_is_tkr_compatible)) then + call mpas_log_write('Skipping variable "' // trim(adjustl(var_info_list(i) % name)) // '" due to not TKR compatible') + + !cycle + end if + end if + + ! Add "" to pool with the value of `1`. + ! The existence of "" in pool causes it to be considered for IO in MPAS. + call mpas_pool_add_config(mpas_pool, trim(adjustl(var_info_list(i) % name)), 1) + ! Add ":packages" to pool with the value of an empty character string. + ! This causes "" to be always considered active for IO in MPAS. + !call mpas_pool_add_config(mpas_pool, trim(adjustl(var_info_list(i) % name) // ':packages'), '') + + ! Add "" to stream. + call mpas_log_write('Adding variable "' // trim(adjustl(var_info_list(i) % name)) // & + '" to stream "' // trim(adjustl(stream_name)) // '"') + + select case (trim(adjustl(var_info_list(i) % type))) + case ('character') + select case (var_info_list(i) % rank) + case (0) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info_list(i) % name)), field_0d_char, timelevel=timeLevel) + + if (.not. associated(field_0d_char)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') + end if + + call mpas_streamaddfield(mpas_stream, field_0d_char, ierr=ierr) + + nullify(field_0d_char) + case (1) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info_list(i) % name)), field_1d_char, timelevel=timeLevel) + + if (.not. associated(field_1d_char)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') + end if + + call mpas_streamaddfield(mpas_stream, field_1d_char, ierr=ierr) + + nullify(field_1d_char) + case default + call mpp_error(FATAL,subname//'Unsupported variable rank ' // stringify([var_info_list(i) % rank]) // & + ' for "' // trim(adjustl(var_info_list(i) % name)) // '"') + end select + case ('integer') + select case (var_info_list(i) % rank) + case (0) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info_list(i) % name)), field_0d_integer, timelevel=timeLevel) + + if (.not. associated(field_0d_integer)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') + end if + + call mpas_streamaddfield(mpas_stream, field_0d_integer, ierr=ierr) + + nullify(field_0d_integer) + case (1) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info_list(i) % name)), field_1d_integer, timelevel=timeLevel) + + if (.not. associated(field_1d_integer)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') + end if + + call mpas_streamaddfield(mpas_stream, field_1d_integer, ierr=ierr) + + nullify(field_1d_integer) + case (2) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info_list(i) % name)), field_2d_integer, timelevel=timeLevel) + + if (.not. associated(field_2d_integer)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') + end if + + call mpas_streamaddfield(mpas_stream, field_2d_integer, ierr=ierr) + + nullify(field_2d_integer) + case (3) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info_list(i) % name)), field_3d_integer, timelevel=timeLevel) + + if (.not. associated(field_3d_integer)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') + end if + + call mpas_streamaddfield(mpas_stream, field_3d_integer, ierr=ierr) + + nullify(field_3d_integer) + case default + call mpp_error(FATAL,subname//'Unsupported variable rank ' // stringify([var_info_list(i) % rank]) // & + ' for "' // trim(adjustl(var_info_list(i) % name)) // '"') + end select + case ('real') + select case (var_info_list(i) % rank) + case (0) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info_list(i) % name)), field_0d_real, timelevel=timeLevel) + + if (.not. associated(field_0d_real)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') + end if + + call mpas_streamaddfield(mpas_stream, field_0d_real, ierr=ierr) + + nullify(field_0d_real) + case (1) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info_list(i) % name)), field_1d_real, timelevel=timeLevel) + + if (.not. associated(field_1d_real)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') + end if + + call mpas_streamaddfield(mpas_stream, field_1d_real, ierr=ierr) + + nullify(field_1d_real) + case (2) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info_list(i) % name)), field_2d_real, timelevel=timeLevel) + if (.not. associated(field_2d_real)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') + end if + call mpas_streamaddfield(mpas_stream, field_2d_real, ierr=ierr) + + nullify(field_2d_real) + case (3) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info_list(i) % name)), field_3d_real, timelevel=timeLevel) + + if (.not. associated(field_3d_real)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') + end if + call mpas_streamaddfield(mpas_stream, field_3d_real, ierr=ierr) + + nullify(field_3d_real) + case (4) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info_list(i) % name)), field_4d_real, timelevel=timeLevel) + + if (.not. associated(field_4d_real)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') + end if + + call mpas_streamaddfield(mpas_stream, field_4d_real, ierr=ierr) + + nullify(field_4d_real) + case (5) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info_list(i) % name)), field_5d_real, timelevel=timeLevel) + + if (.not. associated(field_5d_real)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') + end if + + call mpas_streamaddfield(mpas_stream, field_5d_real, ierr=ierr) + + nullify(field_5d_real) + case default + call mpp_error(FATAL,subname//'Unsupported variable rank ' // stringify([var_info_list(i) % rank]) // & + ' for "' // trim(adjustl(var_info_list(i) % name)) // '"') + end select + case default + call mpp_error(FATAL,subname//'Unsupported variable type "' // trim(adjustl(var_info_list(i) % type)) // & + '" for "' // trim(adjustl(var_info_list(i) % name)) // '"') + end select + + if (ierr /= mpas_stream_noerr) then + call mpp_error(FATAL,subname//'Failed to add variable "' // trim(adjustl(var_info_list(i) % name)) // & + '" to stream "' // trim(adjustl(stream_name)) // '"') + end if + end do + + if (trim(adjustl(stream_mode)) == 'w' .or. trim(adjustl(stream_mode)) == 'write') then + ! Add MPAS-specific attributes to stream. + + ! Attributes related to MPAS core (i.e., `core_type`). + call add_stream_attribute('conventions', domain_ptr % core % conventions) + call add_stream_attribute('core_name', domain_ptr % core % corename) + call add_stream_attribute('git_version', domain_ptr % core % git_version) + call add_stream_attribute('model_name', domain_ptr % core % modelname) + call add_stream_attribute('source', domain_ptr % core % source) + + ! Attributes related to MPAS domain (i.e., `domain_type`). + call add_stream_attribute('is_periodic', domain_ptr % is_periodic) + call add_stream_attribute('mesh_spec', domain_ptr % mesh_spec) + call add_stream_attribute('on_a_sphere', domain_ptr % on_a_sphere) + call add_stream_attribute('parent_id', domain_ptr % parent_id) + call add_stream_attribute('sphere_radius', domain_ptr % sphere_radius) + call add_stream_attribute('x_period', domain_ptr % x_period) + call add_stream_attribute('y_period', domain_ptr % y_period) + end if + + call mpas_log_write(subname // ' completed') + contains + !> Helper subroutine for adding a 0-d stream attribute by calling `mpas_writestreamatt` with error checking. + !> (KCW, 2024-03-14) + subroutine add_stream_attribute_0d(attribute_name, attribute_value) + ! Module(s) from MPAS. + use mpas_io_streams, only : mpas_writestreamatt + use mpas_log, only : mpas_log_write + character(*), intent(in) :: attribute_name + class(*), intent(in) :: attribute_value + + call mpas_log_write('Adding attribute "' // trim(adjustl(attribute_name)) // & + '" to stream "' // trim(adjustl(stream_name)) // '"') + + select type (attribute_value) + type is (character(*)) + call mpas_writestreamatt(mpas_stream, & + trim(adjustl(attribute_name)), trim(adjustl(attribute_value)), syncval=.false., ierr=ierr) + type is (integer) + call mpas_writestreamatt(mpas_stream, & + trim(adjustl(attribute_name)), attribute_value, syncval=.false., ierr=ierr) + type is (logical) + if (attribute_value) then + ! Logical `.true.` becomes character string "YES". + call mpas_writestreamatt(mpas_stream, & + trim(adjustl(attribute_name)), 'YES', syncval=.false., ierr=ierr) + else + ! Logical `.false.` becomes character string "NO". + call mpas_writestreamatt(mpas_stream, & + trim(adjustl(attribute_name)), 'NO', syncval=.false., ierr=ierr) + end if + type is (real(rkind)) + call mpas_writestreamatt(mpas_stream, & + trim(adjustl(attribute_name)), attribute_value, syncval=.false., ierr=ierr) + class default + call mpp_error(FATAL,subname//'Unsupported attribute type (Must be one of: character, integer, logical, real)') + end select + + if (ierr /= mpas_stream_noerr) then + call mpp_error(FATAL,subname//'Failed to add attribute "' // trim(adjustl(attribute_name)) // & + '" to stream "' // trim(adjustl(stream_name)) // '"') + end if + end subroutine add_stream_attribute_0d + + !> Helper subroutine for adding a 1-d stream attribute by calling `mpas_writestreamatt` with error checking. + !> (KCW, 2024-03-14) + subroutine add_stream_attribute_1d(attribute_name, attribute_value) + ! Module(s) from MPAS. + use mpas_io_streams, only : mpas_writestreamatt + use mpas_log, only : mpas_log_write + character(*), intent(in) :: attribute_name + class(*), intent(in) :: attribute_value(:) + + call mpas_log_write('Adding attribute "' // trim(adjustl(attribute_name)) // & + '" to stream "' // trim(adjustl(stream_name)) // '"') + + select type (attribute_value) + type is (integer) + call mpas_writestreamatt(mpas_stream, & + trim(adjustl(attribute_name)), attribute_value, syncval=.false., ierr=ierr) + type is (real(rkind)) + call mpas_writestreamatt(mpas_stream, & + trim(adjustl(attribute_name)), attribute_value, syncval=.false., ierr=ierr) + class default + call mpp_error(FATAL,subname//'Unsupported attribute type (Must be one of: integer, real)') + end select + + if (ierr /= mpas_stream_noerr) then + call mpp_error(FATAL,subname//'Failed to add attribute "' // trim(adjustl(attribute_name)) // & + '" to stream "' // trim(adjustl(stream_name)) // '"') + end if + end subroutine add_stream_attribute_1d + end subroutine dyn_mpas_init_stream_with_pool + + !> ######################################################################################## + !> + !> Parse a stream name, which consists of one or more stream name fragments, and return the + !> corresponding variable information as a list of `var_info_type`. Multiple stream name + !> fragments should be separated by "+" (i.e., a plus, meaning "addition" + !> operation) or "-" (i.e., a minus, meaning "subtraction" operation). + !> A stream name fragment can be a predefined stream name (e.g., "invariant", "input", etc.) + !> or a single variable name. For example, a stream name of "invariant+input+restart" means + !> the union of variables in the "invariant", "input", and "restart" streams. + !> Duplicate variable information in the resulting list is discarded. + !> + !> (KCW, 2024-06-01) + !> + !> \update: Dustin Swales April 2025 - Modified for use in UWM + !> + !> ######################################################################################## + pure function parse_stream_name(stream_name) result(var_info_list) + character(*), intent(in) :: stream_name + type(var_info_type), allocatable :: var_info_list(:) + + character(*), parameter :: supported_stream_name_operator = '+-' + character(1) :: stream_name_operator + character(:), allocatable :: stream_name_fragment + character(len(invariant_var_info_list % name)), allocatable :: var_name_list(:) + integer :: i, j, n, offset + type(var_info_type), allocatable :: var_info_list_buffer(:) + + n = len_trim(stream_name) + + if (n == 0) then + ! Empty character string means empty list. + var_info_list = parse_stream_name_fragment('') + + return + end if + + i = scan(stream_name, supported_stream_name_operator) + + if (i == 0) then + ! No operators are present in the stream name. It is just a single stream name fragment. + stream_name_fragment = stream_name + var_info_list = parse_stream_name_fragment(stream_name_fragment) + + return + end if + + offset = 0 + var_info_list = parse_stream_name_fragment('') + + do while (.true.) + ! Extract operator from the stream name. + if (offset > 0) then + stream_name_operator = stream_name(offset:offset) + else + stream_name_operator = '+' + end if + + ! Extract stream name fragment from the stream name. + if (i > 1) then + stream_name_fragment = stream_name(offset + 1:offset + i - 1) + else + stream_name_fragment = '' + end if + + ! Process the stream name fragment according to the operator. + if (len_trim(stream_name_fragment) > 0) then + var_info_list_buffer = parse_stream_name_fragment(stream_name_fragment) + + select case (stream_name_operator) + case ('+') + var_info_list = [var_info_list, var_info_list_buffer] + case ('-') + do j = 1, size(var_info_list_buffer) + var_name_list = var_info_list % name + var_info_list = pack(var_info_list, var_name_list /= var_info_list_buffer(j) % name) + end do + case default + ! Do nothing for unknown operators. Should not happen at all. + end select + end if + + offset = offset + i + + ! Terminate loop when everything in the stream name has been processed. + if (offset + 1 > n) then + exit + end if + + i = scan(stream_name(offset + 1:), supported_stream_name_operator) + + ! Run the loop one last time for the remaining stream name fragment. + if (i == 0) then + i = n - offset + 1 + end if + end do + + ! Discard duplicate variable information by names. + var_name_list = var_info_list % name + var_info_list = var_info_list(index_unique(var_name_list)) + end function parse_stream_name + + !> ######################################################################################## + !> + !> Parse a stream name fragment and return the corresponding variable information as a list + !> of `var_info_type`. + !> A stream name fragment can be a predefined stream name (e.g., "invariant", "input", etc.) + !> or a single variable name. + !> + !> (KCW, 2024-06-01) + !> + !> \update: Dustin Swales April 2025 - Modified for use in UWM + !> + !> ######################################################################################## + pure function parse_stream_name_fragment(stream_name_fragment) result(var_info_list) + character(*), intent(in) :: stream_name_fragment + type(var_info_type), allocatable :: var_info_list(:) + + character(len(invariant_var_info_list % name)), allocatable :: var_name_list(:) + type(var_info_type), allocatable :: var_info_list_buffer(:) + + select case (trim(adjustl(stream_name_fragment))) + case ('') + allocate(var_info_list(0)) + case ('invariant') + allocate(var_info_list, source=invariant_var_info_list) + case ('input') + allocate(var_info_list, source=input_var_info_list) + case ('restart') + allocate(var_info_list, source=restart_var_info_list) + case ('output') + allocate(var_info_list, source=output_var_info_list) + case ('lbc_in') + allocate(var_info_list, source=lbc_in_var_info_list) + case ('sfc_input') + allocate(var_info_list, source=sfc_input_var_info_list) + case ('ugwp_oro_data') + allocate(var_info_list, source=ugwp_oro_data_var_info_list) + case default + allocate(var_info_list(0)) + + var_name_list = invariant_var_info_list % name + + if (any(var_name_list == trim(adjustl(stream_name_fragment)))) then + var_info_list_buffer = pack(invariant_var_info_list, var_name_list == trim(adjustl(stream_name_fragment))) + var_info_list = [var_info_list, var_info_list_buffer] + end if + + var_name_list = input_var_info_list % name + + if (any(var_name_list == trim(adjustl(stream_name_fragment)))) then + var_info_list_buffer = pack(input_var_info_list, var_name_list == trim(adjustl(stream_name_fragment))) + var_info_list = [var_info_list, var_info_list_buffer] + end if + + var_name_list = restart_var_info_list % name + + if (any(var_name_list == trim(adjustl(stream_name_fragment)))) then + var_info_list_buffer = pack(restart_var_info_list, var_name_list == trim(adjustl(stream_name_fragment))) + var_info_list = [var_info_list, var_info_list_buffer] + end if + + var_name_list = output_var_info_list % name + + if (any(var_name_list == trim(adjustl(stream_name_fragment)))) then + var_info_list_buffer = pack(output_var_info_list, var_name_list == trim(adjustl(stream_name_fragment))) + var_info_list = [var_info_list, var_info_list_buffer] + end if + + var_name_list = lbc_in_var_info_list % name + + if (any(var_name_list == trim(adjustl(stream_name_fragment)))) then + var_info_list_buffer = pack(lbc_in_var_info_list, var_name_list == trim(adjustl(stream_name_fragment))) + var_info_list = [var_info_list, var_info_list_buffer] + end if + end select + end function parse_stream_name_fragment + + !> ######################################################################################## + !> + !> Return the index of unique elements in `array`, which can be any intrinsic data types, + !> as an integer array. + !> If `array` contains zero element or is of unsupported data types, an empty integer array + !> is produced. For example, `index_unique([1, 2, 3, 1, 2, 3, 4, 5])` returns `[1, 2, 3, 7, 8]`. + !> + !> (KCW, 2024-03-22) + !> + !> \update: Dustin Swales April 2025 - Modified for use in UWM + !> + !> ######################################################################################## + pure function index_unique(array) + use, intrinsic :: iso_fortran_env, only: int32, int64, real32, real64 + + class(*), intent(in) :: array(:) + integer, allocatable :: index_unique(:) + + character(:), allocatable :: array_c(:) + integer :: i, n + logical :: mask_unique(size(array)) + + n = size(array) + + if (n == 0) then + allocate(index_unique(0)) + + return + end if + + mask_unique = .false. + + select type (array) + type is (character(*)) + ! Workaround for a bug in GNU Fortran >= 12. This is perhaps the manifestation of GCC Bugzilla Bug 100819. + ! When a character string array is passed as the actual argument to an unlimited polymorphic dummy argument, + ! its array index and length parameter are mishandled. + allocate(character(len(array)) :: array_c(size(array))) + + array_c(:) = array(:) + + do i = 1, n + if (.not. any(array_c(i) == array_c .and. mask_unique)) then + mask_unique(i) = .true. + end if + end do + deallocate(array_c) + type is (integer(int32)) + do i = 1, n + if (.not. any(array(i) == array .and. mask_unique)) then + mask_unique(i) = .true. + end if + end do + type is (integer(int64)) + do i = 1, n + if (.not. any(array(i) == array .and. mask_unique)) then + mask_unique(i) = .true. + end if + end do + type is (logical) + do i = 1, n + if (.not. any((array(i) .eqv. array) .and. mask_unique)) then + mask_unique(i) = .true. + end if + end do + type is (real(real32)) + do i = 1, n + if (.not. any(array(i) == array .and. mask_unique)) then + mask_unique(i) = .true. + end if + end do + type is (real(real64)) + do i = 1, n + if (.not. any(array(i) == array .and. mask_unique)) then + mask_unique(i) = .true. + end if + end do + class default + allocate(index_unique(0)) + + return + end select + + index_unique = pack([(i, i = 1, n)], mask_unique) + end function index_unique + !> ######################################################################################## + !> subroutine dyn_mpas_check_variable_status + !> + !> summary: Check and return variable status on the given file. + !> author: Kuan-Chih Wang + !> date: 2024-06-04 + !> + !> On the given file (i.e., `pio_file`), this subroutine checks whether the + !> given variable (i.e., `var_info`) is present, and whether it is "TKR" + !> compatible with what MPAS expects. "TKR" means type, kind, and rank. + !> This subroutine can handle both ordinary variables and variable arrays. + !> They are indicated by the `var` and `var_array` elements, respectively, + !> in MPAS registry. For an ordinary variable, the checks are performed on + !> itself. Otherwise, for a variable array, the checks are performed on its + !> constituent parts instead. + !> + !> \update: Dustin Swales April 2025 - Modified for use in UWM + !> + !> ######################################################################################## + subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, pio_file,& + var_info) + ! Module(s) from external libraries. + use pio, only: file_desc_t, pio_file_is_open, pio_char, pio_int, pio_real, pio_double, & + pio_inq_varid, pio_inq_varndims, pio_inq_vartype, pio_noerr + ! Module(s) from MPAS. + use mpas_derived_types, only : field0dchar, field1dchar, field0dinteger, field1dinteger,& + field2dinteger, field3dinteger, field0dreal, field1dreal,& + field2dreal, field3dreal, field4dreal, field5dreal + use mpas_kind_types, only : r4kind, r8kind + use mpas_pool_routines, only : mpas_pool_get_field + use mpas_log, only : mpas_log_write + use mpas_kind_types, only : StrKIND, RKIND + use mpp_mod, only : FATAL, mpp_error + + logical, allocatable, intent(out) :: var_is_present(:) + logical, allocatable, intent(out) :: var_is_tkr_compatible(:) + type(file_desc_t), pointer, intent(in) :: pio_file + type(var_info_type), intent(in) :: var_info + + character(*), parameter :: subname = 'dyn_mpas_subdriver::dyn_mpas_check_variable_status' + character(strkind), allocatable :: var_name_list(:) + integer :: i, ierr, varid, varndims, vartype + type(field0dchar), pointer :: field_0d_char + type(field1dchar), pointer :: field_1d_char + type(field0dinteger), pointer :: field_0d_integer + type(field1dinteger), pointer :: field_1d_integer + type(field2dinteger), pointer :: field_2d_integer + type(field3dinteger), pointer :: field_3d_integer + type(field0dreal), pointer :: field_0d_real + type(field1dreal), pointer :: field_1d_real + type(field2dreal), pointer :: field_2d_real + type(field3dreal), pointer :: field_3d_real + type(field4dreal), pointer :: field_4d_real + type(field5dreal), pointer :: field_5d_real + + call mpas_log_write(subname // ' entered') + + nullify(field_0d_char) + nullify(field_1d_char) + nullify(field_0d_integer) + nullify(field_1d_integer) + nullify(field_2d_integer) + nullify(field_3d_integer) + nullify(field_0d_real) + nullify(field_1d_real) + nullify(field_2d_real) + nullify(field_3d_real) + nullify(field_4d_real) + nullify(field_5d_real) + + ! Extract a list of variable names to check on the file. + ! For an ordinary variable, this list just contains its name. + ! For a variable array, this list contains the names of its constituent parts. + select case (trim(adjustl(var_info % type))) + case ('character') + select case (var_info % rank) + case (0) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info % name)), field_0d_char, timelevel=1) + + if (.not. associated(field_0d_char)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name))) + end if + + if (field_0d_char % isvararray .and. associated(field_0d_char % constituentnames)) then + allocate(var_name_list(size(field_0d_char % constituentnames)), stat=ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate var_name_list') + end if + + var_name_list(:) = field_0d_char % constituentnames(:) + end if + + nullify(field_0d_char) + case (1) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info % name)), field_1d_char, timelevel=1) + + if (.not. associated(field_1d_char)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name))) + end if + + if (field_1d_char % isvararray .and. associated(field_1d_char % constituentnames)) then + allocate(var_name_list(size(field_1d_char % constituentnames)), stat=ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate var_name_list') + end if + + var_name_list(:) = field_1d_char % constituentnames(:) + end if + + nullify(field_1d_char) + case default + call mpp_error(FATAL,subname//'Unsupported variable rank ' // stringify([var_info % rank]) // & + ' for "' // trim(adjustl(var_info % name)) // '"') + end select + case ('integer') + select case (var_info % rank) + case (0) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info % name)), field_0d_integer, timelevel=1) + + if (.not. associated(field_0d_integer)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') + end if + + if (field_0d_integer % isvararray .and. associated(field_0d_integer % constituentnames)) then + allocate(var_name_list(size(field_0d_integer % constituentnames)), stat=ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate var_name_list') + end if + + var_name_list(:) = field_0d_integer % constituentnames(:) + end if + + nullify(field_0d_integer) + case (1) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info % name)), field_1d_integer, timelevel=1) + + if (.not. associated(field_1d_integer)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') + end if + + if (field_1d_integer % isvararray .and. associated(field_1d_integer % constituentnames)) then + allocate(var_name_list(size(field_1d_integer % constituentnames)), stat=ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate var_name_list') + end if + + var_name_list(:) = field_1d_integer % constituentnames(:) + end if + + nullify(field_1d_integer) + case (2) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info % name)), field_2d_integer, timelevel=1) + + if (.not. associated(field_2d_integer)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') + end if + + if (field_2d_integer % isvararray .and. associated(field_2d_integer % constituentnames)) then + allocate(var_name_list(size(field_2d_integer % constituentnames)), stat=ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate var_name_list') + end if + + var_name_list(:) = field_2d_integer % constituentnames(:) + end if + + nullify(field_2d_integer) + case (3) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info % name)), field_3d_integer, timelevel=1) + + if (.not. associated(field_3d_integer)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') + end if + + if (field_3d_integer % isvararray .and. associated(field_3d_integer % constituentnames)) then + allocate(var_name_list(size(field_3d_integer % constituentnames)), stat=ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate var_name_list') + end if + + var_name_list(:) = field_3d_integer % constituentnames(:) + end if + + nullify(field_3d_integer) + case default + call mpp_error(FATAL,subname//'Unsupported variable rank ' // stringify([var_info % rank]) // & + ' for "' // trim(adjustl(var_info % name)) // '"') + end select + case ('real') + select case (var_info % rank) + case (0) + + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info % name)), field_0d_real, timelevel=1) + + if (.not. associated(field_0d_real)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') + end if + + if (field_0d_real % isvararray .and. associated(field_0d_real % constituentnames)) then + allocate(var_name_list(size(field_0d_real % constituentnames)), stat=ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate var_name_list') + end if + + var_name_list(:) = field_0d_real % constituentnames(:) + end if + + nullify(field_0d_real) + case (1) + + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info % name)), field_1d_real, timelevel=1) + + if (.not. associated(field_1d_real)) then + call mpas_log_write(subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') + end if + + if (field_1d_real % isvararray .and. associated(field_1d_real % constituentnames)) then + allocate(var_name_list(size(field_1d_real % constituentnames)), stat=ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate var_name_list') + end if + + var_name_list(:) = field_1d_real % constituentnames(:) + end if + + nullify(field_1d_real) + case (2) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info % name)), field_2d_real, timelevel=1) + + if (.not. associated(field_2d_real)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') + end if + + if (field_2d_real % isvararray .and. associated(field_2d_real % constituentnames)) then + allocate(var_name_list(size(field_2d_real % constituentnames)), stat=ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate var_name_list') + end if + + var_name_list(:) = field_2d_real % constituentnames(:) + end if + + nullify(field_2d_real) + case (3) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info % name)), field_3d_real, timelevel=1) + if (.not. associated(field_3d_real)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') + end if + if (field_3d_real % isvararray .and. associated(field_3d_real % constituentnames)) then + allocate(var_name_list(size(field_3d_real % constituentnames)), stat=ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate var_name_list') + end if + + var_name_list(:) = field_3d_real % constituentnames(:) + end if + nullify(field_3d_real) + case (4) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info % name)), field_4d_real, timelevel=1) + + if (.not. associated(field_4d_real)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') + end if + + if (field_4d_real % isvararray .and. associated(field_4d_real % constituentnames)) then + allocate(var_name_list(size(field_4d_real % constituentnames)), stat=ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate var_name_list') + end if + + var_name_list(:) = field_4d_real % constituentnames(:) + end if + + nullify(field_4d_real) + case (5) + call mpas_pool_get_field(domain_ptr % blocklist % allfields, & + trim(adjustl(var_info % name)), field_5d_real, timelevel=1) + + if (.not. associated(field_5d_real)) then + call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') + end if + + if (field_5d_real % isvararray .and. associated(field_5d_real % constituentnames)) then + allocate(var_name_list(size(field_5d_real % constituentnames)), stat=ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate var_name_list') + end if + + var_name_list(:) = field_5d_real % constituentnames(:) + end if + + nullify(field_5d_real) + case default + call mpp_error(FATAL,subname//'Unsupported variable rank ' // stringify([var_info % rank]) // & + ' for "' // trim(adjustl(var_info % name)) // '"') + end select + case default + call mpp_error(FATAL,subname//'Unsupported variable type "' // trim(adjustl(var_info % type)) // & + '" for "' // trim(adjustl(var_info % name)) // '"') + end select + + if (.not. allocated(var_name_list)) then + allocate(var_name_list(1), stat=ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate var_name_list') + end if + + var_name_list(1) = var_info % name + end if + + allocate(var_is_present(size(var_name_list)), stat=ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate var_is_present') + end if + + var_is_present(:) = .false. + allocate(var_is_tkr_compatible(size(var_name_list)), stat=ierr) + if (ierr /= 0) then + call mpp_error(FATAL,subname//'Failed to allocate var_is_tkr_compatible') + end if + + var_is_tkr_compatible(:) = .false. + if (.not. associated(pio_file)) then + return + end if + + if (.not. pio_file_is_open(pio_file)) then + return + end if + + call mpas_log_write('Checking variable "' // trim(adjustl(var_info % name)) // & + '" for presence and TKR compatibility') + do i = 1, size(var_name_list) + ! Check if the variable is present on the file. + ierr = pio_inq_varid(pio_file, trim(adjustl(var_name_list(i))), varid) + + if (ierr /= pio_noerr) then + cycle + end if + + var_is_present(i) = .true. + + ! Check if the variable is "TK"R compatible between MPAS and the file. + ierr = pio_inq_vartype(pio_file, varid, vartype) + + if (ierr /= pio_noerr) then + cycle + end if + + select case (trim(adjustl(var_info % type))) + case ('character') + if (vartype /= pio_char) then + cycle + end if + case ('integer') + if (vartype /= pio_int) then + cycle + end if + case ('real') + ! When MPAS dynamical core is compiled at single precision, pairing it with double precision input data + ! is not allowed to prevent loss of precision. + if (rkind == r4kind .and. vartype /= pio_real) then + + cycle + end if + + ! When MPAS dynamical core is compiled at double precision, pairing it with single and double precision + ! input data is allowed. + if (rkind == r8kind .and. vartype /= pio_real .and. vartype /= pio_double) then + + cycle + end if + case default + cycle + end select + + ! Check if the variable is TK"R" compatible between MPAS and the file. + ierr = pio_inq_varndims(pio_file, varid, varndims) + if (ierr /= pio_noerr) then + cycle + end if + + if (varndims /= var_info % rank) then + cycle + end if + + var_is_tkr_compatible(i) = .true. + end do + + call mpas_log_write('var_name_list = ' // stringify(var_name_list)) + call mpas_log_write('var_is_present = ' // stringify(var_is_present)) + call mpas_log_write('var_is_tkr_compatible = ' // stringify(var_is_tkr_compatible)) + + call mpas_log_write(subname // ' completed') + end subroutine dyn_mpas_check_variable_status + +end module ufs_mpas_io diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index 889caf6d7..59b86dda8 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -2,56 +2,44 @@ !> \file ufs_mpas_subdriver.F90 !> UFSATM subdriver for MPAS dynamical core. !> -!> Routines from the subdrivers for MPAS-A and CAM-SIMA have been adopted/modified here for use -!> within the UFS Weather Model. -!> MPAS-A Subdriver: MPAS-Model/src/driver/mpas_subdriver.F -!> CAM-SIMA (external): src/dynamics/mpas/driver/dyn_mpas_subdriver.F90 -!> (https://github.com/ESCOMP/CAM-SIMA/blob/development/) -!> !> Overview: !> Initialization is broken down into two phases, with ufs_mpas_define_scalars() called in !> between: -!> ufs_mpas_init_phase1: Initialize MPAS framework, Read in namelist, Read static data. -!> ufs_mpas_define_scalars: Set up scalars/tracers/constituents/... -!> ufs_mpas_init_phase2: Complete MPAS initialization +!> ufs_mpas_init : Initialize MPAS framework, Read in namelist, Read static data. +!> ufs_mpas_atm_core_init : Complete MPAS initialization !> !> Forward integration of the dycore is handled in ufs_mpas_run. The current forecast time, !> forecast interval, and MPAS dycore time step are used to integrate the model forward in !> time. Afterwards, atm_compute_output_diagnostics() is called to compute fields needed by !> the Physics. !> -!> Other public routines used the UFSATM driver -!> ufs_mpas_open_init: Open MPAS Initial Condition file, return PIO file handle. -!> !> ########################################################################################### module ufs_mpas_subdriver use mpi_f08 - use mpas_derived_types, only : core_type, domain_type, mpas_Clock_type use mpas_kind_types, only : StrKIND, rkind - use module_mpas_config, only : pio_subsystem, pio_stride, pio_numiotasks, pio_iodesc - use module_mpas_config, only : ic_filename, lbc_filename - use module_mpas_config, only : pio_iotype, fcst_mpi_comm, pioid + use module_mpas_config, only : pioid_ic + use module_mpas_config, only : fcst_mpi_comm use module_mpas_config, only : zref, zref_edge, sphere_radius, pref, pref_edge use module_mpas_config, only : maxNCells, maxEdges, nVertLevels use module_mpas_config, only : nCellsGlobal, nEdgesGlobal, nVerticesGlobal - use module_mpas_config, only : nCellsSolve, nEdgesSolve, nVerticesSolve, nVertLevelsSolve - use module_mpas_config, only : dt_atmos, n_atmos + use module_mpas_config, only : nEdgesSolve, nVerticesSolve, nVertLevelsSolve + use module_mpas_config, only : dt_atmos, n_atmos, output_fh use module_mpas_config, only : latCellGlobal, lonCellGlobal, areaCellGlobal + use ufs_mpas_tools + use ufs_mpas_io + use ufs_mpas_boundaries + use ufs_mpas_constituents + implicit none - + private public :: MPAS_control_type - public :: ufs_mpas_init_phase1 - public :: ufs_mpas_define_scalars - public :: ufs_mpas_init_phase2 + public :: ufs_mpas_init public :: ufs_mpas_run - public :: ufs_mpas_open_init - public :: corelist, domain_ptr - public :: constituent_name - public :: is_water_species - public :: dyn_mpas_read_write_stream + logical :: init_lbc = .true. + integer :: nRecord_lbc = 1 !> ######################################################################################### !> !> ######################################################################################### @@ -68,7 +56,7 @@ module ufs_mpas_subdriver integer :: master !< master MPI-rank type(MPI_Comm) :: mpi_comm !< forecast tasks mpi communicator - ! ESMF + ! ESMF integer :: fcst_ntasks !< total number of forecast tasks ! Log file identifier @@ -95,288 +83,19 @@ module ufs_mpas_subdriver integer :: nwat !< number of hydrometeors in dcyore (including water vapor) character(len=32), pointer :: tracer_names(:) !< tracers names to dereference tracer id integer, pointer :: tracer_types(:) !< tracers types: 0=generic, 1=chem,prog, 2=chem,diag - - end type MPAS_control_type - - !> ######################################################################################### - ! - !> ######################################################################################### - type :: var_info_type - private - character(64) :: name = '' - character(10) :: type = '' - integer :: rank = 0 - end type var_info_type - - !> ######################################################################################### - !> This list corresponds to the "invariant" stream in MPAS registry. - !> It consists of variables that are members of the "mesh" struct. - !> ######################################################################################### - type(var_info_type), parameter :: invariant_var_info_list(*) = [ & - var_info_type('angleEdge' , 'real' , 1), & - var_info_type('areaCell' , 'real' , 1), & - var_info_type('areaTriangle' , 'real' , 1), & - var_info_type('bdyMaskCell' , 'integer' , 1), & - var_info_type('bdyMaskEdge' , 'integer' , 1), & - var_info_type('bdyMaskVertex' , 'integer' , 1), & - var_info_type('cellTangentPlane' , 'real' , 3), & - var_info_type('cell_gradient_coef_x' , 'real' , 2), & - var_info_type('cell_gradient_coef_y' , 'real' , 2), & - var_info_type('cellsOnCell' , 'integer' , 2), & - var_info_type('cellsOnEdge' , 'integer' , 2), & - var_info_type('cellsOnVertex' , 'integer' , 2), & - var_info_type('cf1' , 'real' , 0), & - var_info_type('cf2' , 'real' , 0), & - var_info_type('cf3' , 'real' , 0), & - var_info_type('coeffs_reconstruct' , 'real' , 3), & - var_info_type('dcEdge' , 'real' , 1), & - var_info_type('defc_a' , 'real' , 2), & - var_info_type('defc_b' , 'real' , 2), & - var_info_type('deriv_two' , 'real' , 3), & - var_info_type('dss' , 'real' , 2), & - var_info_type('dvEdge' , 'real' , 1), & - var_info_type('dzu' , 'real' , 1), & - var_info_type('edgeNormalVectors' , 'real' , 2), & - var_info_type('edgesOnCell' , 'integer' , 2), & - var_info_type('edgesOnEdge' , 'integer' , 2), & - var_info_type('edgesOnVertex' , 'integer' , 2), & - var_info_type('fEdge' , 'real' , 1), & - var_info_type('fVertex' , 'real' , 1), & - var_info_type('fzm' , 'real' , 1), & - var_info_type('fzp' , 'real' , 1), & - var_info_type('indexToCellID' , 'integer' , 1), & - var_info_type('indexToEdgeID' , 'integer' , 1), & - var_info_type('indexToVertexID' , 'integer' , 1), & - var_info_type('kiteAreasOnVertex' , 'real' , 2), & - var_info_type('latCell' , 'real' , 1), & - var_info_type('latEdge' , 'real' , 1), & - var_info_type('latVertex' , 'real' , 1), & - var_info_type('localVerticalUnitVectors' , 'real' , 2), & - var_info_type('lonCell' , 'real' , 1), & - var_info_type('lonEdge' , 'real' , 1), & - var_info_type('lonVertex' , 'real' , 1), & - var_info_type('meshDensity' , 'real' , 1), & - var_info_type('nEdgesOnCell' , 'integer' , 1), & - var_info_type('nEdgesOnEdge' , 'integer' , 1), & - var_info_type('nominalMinDc' , 'real' , 0), & - var_info_type('qv_init' , 'real' , 1), & - var_info_type('rdzu' , 'real' , 1), & - var_info_type('rdzw' , 'real' , 1), & - var_info_type('t_init' , 'real' , 2), & - var_info_type('u_init' , 'real' , 1), & - var_info_type('v_init' , 'real' , 1), & - var_info_type('verticesOnCell' , 'integer' , 2), & - var_info_type('verticesOnEdge' , 'integer' , 2), & - var_info_type('weightsOnEdge' , 'real' , 2), & - var_info_type('xCell' , 'real' , 1), & - var_info_type('xEdge' , 'real' , 1), & - var_info_type('xVertex' , 'real' , 1), & - var_info_type('yCell' , 'real' , 1), & - var_info_type('yEdge' , 'real' , 1), & - var_info_type('yVertex' , 'real' , 1), & - var_info_type('zCell' , 'real' , 1), & - var_info_type('zEdge' , 'real' , 1), & - var_info_type('zVertex' , 'real' , 1), & - var_info_type('zb' , 'real' , 3), & - var_info_type('zb3' , 'real' , 3), & - var_info_type('zgrid' , 'real' , 2), & - var_info_type('zxu' , 'real' , 2), & - var_info_type('zz' , 'real' , 2) & - ] - - ! Whether a variable should be in input or restart can be determined by looking at - ! the `atm_init_coupled_diagnostics` subroutine in MPAS. - ! If a variable first appears on the LHS of an equation, it should be in restart. - ! If a variable first appears on the RHS of an equation, it should be in input. - ! The remaining ones of interest should be in output. - - !> ######################################################################################### - !> This list corresponds to the "input" stream in MPAS registry. - !> It consists of variables that are members of the "diag" and "state" struct. - !> Only variables that are specific to the "input" stream are included. - !> ######################################################################################### - type(var_info_type), parameter :: input_var_info_list(*) = [ & - var_info_type('Time' , 'real' , 0), & - var_info_type('initial_time' , 'character' , 0), & - var_info_type('rho' , 'real' , 2), & - var_info_type('rho_base' , 'real' , 2), & - var_info_type('scalars' , 'real' , 3), & - var_info_type('theta' , 'real' , 2), & - var_info_type('theta_base' , 'real' , 2), & - var_info_type('u' , 'real' , 2), & - var_info_type('w' , 'real' , 2), & - var_info_type('xtime' , 'character' , 0) & - ] - - !> ######################################################################################### - !> This list corresponds to the "restart" stream in MPAS registry. - !> It consists of variables that are members of the "diag" and "state" struct. - !> Only variables that are specific to the "restart" stream are included. - !> ######################################################################################### - type(var_info_type), parameter :: restart_var_info_list(*) = [ & - var_info_type('exner' , 'real' , 2), & - var_info_type('exner_base' , 'real' , 2), & - var_info_type('pressure_base' , 'real' , 2), & - var_info_type('pressure_p' , 'real' , 2), & - var_info_type('rho_p' , 'real' , 2), & - var_info_type('rho_zz' , 'real' , 2), & - var_info_type('rtheta_base' , 'real' , 2), & - var_info_type('rtheta_p' , 'real' , 2), & - var_info_type('ru' , 'real' , 2), & - var_info_type('ru_p' , 'real' , 2), & - var_info_type('rw' , 'real' , 2), & - var_info_type('rw_p' , 'real' , 2), & - var_info_type('theta_m' , 'real' , 2) & - ] - - !> ######################################################################################### - !> This list corresponds to the "output" stream in MPAS registry. - !> It consists of variables that are members of the "diag" struct. - !> Only variables that are specific to the "output" stream are included. - !> ######################################################################################### - type(var_info_type), parameter :: output_var_info_list(*) = [ & - var_info_type('divergence' , 'real' , 2), & - var_info_type('pressure' , 'real' , 2), & - var_info_type('relhum' , 'real' , 2), & - var_info_type('surface_pressure' , 'real' , 1), & - var_info_type('uReconstructMeridional' , 'real' , 2), & - var_info_type('uReconstructZonal' , 'real' , 2), & - var_info_type('vorticity' , 'real' , 2) & - ] - !> ######################################################################################### - !> - !> ######################################################################################### - type(core_type), pointer :: corelist => null() - type(domain_type), pointer :: domain_ptr => null() - type(mpas_Clock_type), pointer :: clock => null() - - character(StrKIND), allocatable :: constituent_name(:) - integer, allocatable :: index_constituent_to_mpas_scalar(:) - integer, allocatable :: index_mpas_scalar_to_constituent(:) - logical, allocatable :: is_water_species(:) + end type MPAS_control_type contains - !> ######################################################################################### - !> Convert one or more values of any intrinsic data types to a character string for pretty - !> printing. - !> If `value` contains more than one element, the elements will be stringified, delimited by `separator`, then concatenated. - !> If `value` contains exactly one element, the element will be stringified without using `separator`. - !> If `value` contains zero element or is of unsupported data types, an empty character string is produced. - !> If `separator` is not supplied, it defaults to ", " (i.e., a comma and a space). - !> (KCW, 2024-02-04) - !> Ported for UWM (DJS: 2025) - !> ######################################################################################### - pure function stringify(value, separator) - use, intrinsic :: iso_fortran_env, only: int32, int64, real32, real64 - - class(*), intent(in) :: value(:) - character(*), optional, intent(in) :: separator - character(:), allocatable :: stringify - integer, parameter :: sizelimit = 1024 - - character(:), allocatable :: buffer, delimiter, format - character(:), allocatable :: value_c(:) - integer :: i, n, offset - - if (present(separator)) then - delimiter = separator - else - delimiter = ', ' - end if - - n = min(size(value), sizelimit) - - if (n == 0) then - stringify = '' - - return - end if - - select type (value) - type is (character(*)) - allocate(character(len(value) * n + len(delimiter) * (n - 1)) :: buffer) - - buffer(:) = '' - offset = 0 - - ! Workaround for a bug in GNU Fortran >= 12. This is perhaps the manifestation of GCC Bugzilla Bug 100819. - ! When a character string array is passed as the actual argument to an unlimited polymorphic dummy argument, - ! its array index and length parameter are mishandled. - allocate(character(len(value)) :: value_c(size(value))) - - value_c(:) = value(:) - - do i = 1, n - if (len(delimiter) > 0 .and. i > 1) then - buffer(offset + 1:offset + len(delimiter)) = delimiter - offset = offset + len(delimiter) - end if - - if (len_trim(adjustl(value_c(i))) > 0) then - buffer(offset + 1:offset + len_trim(adjustl(value_c(i)))) = trim(adjustl(value_c(i))) - offset = offset + len_trim(adjustl(value_c(i))) - end if - end do - - deallocate(value_c) - type is (integer(int32)) - allocate(character(11 * n + len(delimiter) * (n - 1)) :: buffer) - allocate(character(17 + len(delimiter) + floor(log10(real(n))) + 1) :: format) - - write(format, '(a, i0, 3a)') '(ss, ', n, '(i0, :, "', delimiter, '"))' - write(buffer, format) value - type is (integer(int64)) - allocate(character(20 * n + len(delimiter) * (n - 1)) :: buffer) - allocate(character(17 + len(delimiter) + floor(log10(real(n))) + 1) :: format) - - write(format, '(a, i0, 3a)') '(ss, ', n, '(i0, :, "', delimiter, '"))' - write(buffer, format) value - type is (logical) - allocate(character(1 * n + len(delimiter) * (n - 1)) :: buffer) - allocate(character(13 + len(delimiter) + floor(log10(real(n))) + 1) :: format) - - write(format, '(a, i0, 3a)') '(', n, '(l1, :, "', delimiter, '"))' - write(buffer, format) value - type is (real(real32)) - allocate(character(13 * n + len(delimiter) * (n - 1)) :: buffer) - - if (maxval(abs(value)) < 1.0e5_real32) then - allocate(character(20 + len(delimiter) + floor(log10(real(n))) + 1) :: format) - write(format, '(a, i0, 3a)') '(ss, ', n, '(f13.6, :, "', delimiter, '"))' - else - allocate(character(23 + len(delimiter) + floor(log10(real(n))) + 1) :: format) - write(format, '(a, i0, 3a)') '(ss, ', n, '(es13.6e2, :, "', delimiter, '"))' - end if - - write(buffer, format) value - type is (real(real64)) - allocate(character(13 * n + len(delimiter) * (n - 1)) :: buffer) - - if (maxval(abs(value)) < 1.0e5_real64) then - allocate(character(20 + len(delimiter) + floor(log10(real(n))) + 1) :: format) - write(format, '(a, i0, 3a)') '(ss, ', n, '(f13.6, :, "', delimiter, '"))' - else - allocate(character(23 + len(delimiter) + floor(log10(real(n))) + 1) :: format) - write(format, '(a, i0, 3a)') '(ss, ', n, '(es13.6e2, :, "', delimiter, '"))' - end if - - write(buffer, format) value - class default - stringify = '' - - return - end select - - stringify = trim(buffer) - end function stringify - !> ######################################################################################### !> Procedure to initialize UWM with MPAS dynamical core. !> + !> Follows mpas_init() in MPAS-Model/src/driver/mpas_subdriver.F + !> !> ######################################################################################### - subroutine ufs_mpas_init_phase1(Cfg, time_start, time_end, total_time, calendar, logUnits) + subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUnits, & + mpas_from_ufs_cnst, ufs_from_mpas_cnst) ! MPAS use mpas_pool_routines, only : mpas_pool_add_config, mpas_pool_get_subpool use mpas_pool_routines, only : mpas_pool_add_dimension, mpas_pool_get_field @@ -387,11 +106,15 @@ subroutine ufs_mpas_init_phase1(Cfg, time_start, time_end, total_time, calendar, use mpas_bootstrapping, only : mpas_bootstrap_framework_phase2 use mpas_stream_inquiry, only : mpas_stream_inquiry_new_streaminfo use mpas_derived_types, only : mpas_pool_type, mpas_IO_NETCDF, field3dReal + use mpas_derived_types, only : MPAS_STREAM_MGR_NOERR, MPAS_LOG_ERR use mpas_kind_types, only : StrKIND, RKIND use mpas_log, only : mpas_log_write use atm_core_interface, only : atm_setup_core, atm_setup_domain use mpas_constants, only : mpas_constants_compute_derived, pi => pii use mpas_attlist, only : mpas_add_att + use mpas_rbf_interpolation, only : mpas_rbf_interp_initialize + use mpas_vector_reconstruction, only : mpas_init_reconstruct + use mpas_timekeeping, only : mpas_NOW ! FMS use field_manager_mod, only : MODEL_ATMOS use fms2_io_mod, only : file_exists @@ -403,13 +126,15 @@ subroutine ufs_mpas_init_phase1(Cfg, time_start, time_end, total_time, calendar, integer, intent(in ) :: time_start(6), time_end(6), logUnits(2) integer, intent(in ) :: total_time character(17), intent(in ) :: calendar + integer, pointer, intent(in ) :: mpas_from_ufs_cnst(:), ufs_from_mpas_cnst(:) ! Locals - character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_init_phase1' + character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_init' integer :: i, ndate1, ndate2, tod, ierr, ik, kk - type (mpas_pool_type), pointer :: state, mesh, tend + type (mpas_pool_type), pointer :: state, mesh, tend, lbc type (field3dReal), pointer :: scalarsField character (len=StrKIND), pointer :: initial_time, config_start_time - integer, pointer :: num_scalars + integer, pointer :: num_scalars, mpas_from_ufs_cnst2(:), ufs_from_mpas_cnst2(:) + logical, pointer :: config_apply_lbcs ! Setup MPAS infrastructure allocate(corelist, stat=ierr) @@ -426,7 +151,9 @@ subroutine ufs_mpas_init_phase1(Cfg, time_start, time_end, total_time, calendar, call mpas_allocate_domain(domain_ptr) domain_ptr % domainID = 0 - ! Initialize MPAS infrastructure + ! + ! Initialize MPAS infrastructure (phase 1) + ! call mpas_framework_init_phase1(domain_ptr % dminfo, external_comm=fcst_mpi_comm) call atm_setup_core(corelist) @@ -444,7 +171,9 @@ subroutine ufs_mpas_init_phase1(Cfg, time_start, time_end, total_time, calendar, call mpp_error(FATAL,subname//": Log setup failed for MPAS-A dycore") end if + ! ! Read MPAS namelist. + ! if (file_exists('input.nml')) then call read_mpas_namelist('input.nml', domain_ptr % configs, Cfg % mpi_comm, Cfg % master, Cfg % me) else @@ -463,21 +192,25 @@ subroutine ufs_mpas_init_phase1(Cfg, time_start, time_end, total_time, calendar, call mpas_pool_add_config(domain_ptr % configs, 'config_stop_time', date2yyyymmdd(ndate2)//'_'//sec2hms(tod)) call mpas_log_write('config_stop_time = '//date2yyyymmdd(ndate2)//'_'//sec2hms(tod)) - ! Set forecaste run time (config_run_duration) #DJS2025 this is not correct. need to fix, but works for current test. + ! Set forecaste run time (config_run_duration) tod = max(ndate2 - ndate1 - 1,0) call mpas_pool_add_config(domain_ptr % configs, 'config_run_duration', trim(int2str(tod))//'_'//sec2hms(total_time)) call mpas_log_write('config_run_duration = '//trim(int2str(tod))//'_'//sec2hms(total_time)) - + ! Set other MPAS required configuration information. call mpas_pool_add_config(domain_ptr % configs, 'config_restart_timestamp_name', 'restart_timestamp') call mpas_pool_add_config(domain_ptr % configs, 'config_IAU_option', 'off') call mpas_pool_add_config(domain_ptr % configs, 'config_do_DAcycling', .false.) call mpas_pool_add_config(domain_ptr % configs, 'config_halo_exch_method', 'mpas_halo') + ! ! Initialize MPAS infrastructure (phase 2) - call mpas_framework_init_phase2(domain_ptr, io_system=pio_subsystem, calendar = trim(calendar)) + ! + call mpas_framework_init_phase2(domain_ptr, io_system=pio_subsystem_ic, calendar = trim(calendar)) + ! ! Before defining packages, initialize the stream inquiry instance for the domain + ! domain_ptr % streamInfo => mpas_stream_inquiry_new_streaminfo() if (.not. associated(domain_ptr % streamInfo)) then call mpp_error(FATAL,subname//": Failed to instantiate streamInfo object for "//trim(domain_ptr % core % coreName)) @@ -509,41 +242,83 @@ subroutine ufs_mpas_init_phase1(Cfg, time_start, time_end, total_time, calendar, ! allocate scalars separately from other Registry-defined fields call mpas_pool_add_config(domain_ptr % configs, 'cam_pcnst', Cfg % nConstituents) - ! Call MPAS framework bootstrap phase 1 - call mpas_bootstrap_framework_phase1(domain_ptr, "external mesh file", mpas_IO_NETCDF, pio_file_desc=pioid) + ! Call MPAS framework bootstrap (phase 1) + call mpas_bootstrap_framework_phase1(domain_ptr, "external mesh file", mpas_IO_NETCDF, pio_file_desc=pioid_ic) + ! ! Finalize the setup of blocks and fields - call mpas_bootstrap_framework_phase2(domain_ptr, pio_file_desc=pioid) - + ! + call mpas_bootstrap_framework_phase2(domain_ptr, pio_file_desc=pioid_ic) + + ! + ! END OF MPAS-Model/src/driver/mpas_subdriver.F:mpas_init() + ! + ! Add num_scalars from "state" pool to "dimensions". call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) call mpas_pool_add_dimension(domain_ptr % blocklist % dimensions, 'num_scalars', num_scalars) - nullify(num_scalars) + + ! + ! Setup scalars for State pool and scalars for Tend pool + ! call mpas_pool_add_dimension(state, 'index_qv', 1) call mpas_pool_add_dimension(state, 'moist_start', 1) call mpas_pool_add_dimension(state, 'moist_end', Cfg % nwat) + nullify (state) + call ufs_mpas_define_scalars(mpas_from_ufs_cnst, ufs_from_mpas_cnst, ierr) + if (ierr /= 0) then + call mpp_error(FATAL,'ERROR: Set-up of constituents for MPAS-A dycore failed.') + end if + ! + ! Setup scalars for LBC pool and scalars_tend for LBC pool. + ! + call mpas_pool_get_config( domain_ptr % blocklist % configs, 'config_apply_lbcs', config_apply_lbcs) + if (config_apply_lbcs) then + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'lbc', lbc) + call mpas_pool_get_dimension(domain_ptr % blocklist % dimensions, 'num_scalars', num_scalars) + call mpas_pool_add_dimension(lbc, 'num_scalars', num_scalars) + call mpas_pool_add_dimension(lbc, 'moist_start', 1) + call mpas_pool_add_dimension(lbc, 'moist_end', Cfg % nwat) + call mpas_pool_add_dimension(lbc, 'index_qv', 1) + nullify (lbc) + call ufs_mpas_define_lbc_scalars(mpas_from_ufs_cnst, ufs_from_mpas_cnst, ierr) + if (ierr /= 0) then + call mpp_error(FATAL,'ERROR: Set-up of LBC constituents for MPAS-A dycore failed.') + end if + end if + + ! ! Read in static (invariant) data - call dyn_mpas_read_write_stream( 'r', 'invariant') + ! + call dyn_mpas_read_write_stream(domain_ptr % clock, 'r', 'invariant', pio_file_desc=pioid_ic, ierr=ierr, timeLevel=1, whence=mpas_NOW, nRecord=1) + if (ierr /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Could not read from ''invariant'' stream ',messageType=MPAS_LOG_ERR) + call mpp_error(FATAL,'ERROR: Could not read from ''invariant'' stream ') + end if + ! FROM CAM/driver/cam_mpas_subdriver.F90 ! Compute unit vectors giving the local north and east directions as well as ! the unit normal vector for edges call ufs_mpas_compute_unit_vectors() - - ! Access dimensions that are made public via this module + + ! FROM CAM/dyn_grid.F90:setup_time_invariant() + ! Initialize fields needed for reconstruction of cell-centered winds from edge-normal winds + ! Note: This same pair of calls happens a second time later in the initialization of + ! the MPAS-A dycore (in atm_mpas_init_block), but the redundant calls do no harm call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', mesh) - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(mesh, 'nEdgesSolve', nEdgesSolve) - call mpas_pool_get_dimension(mesh, 'nVerticesSolve', nVerticesSolve) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevelsSolve) ! MPAS always solves over the full column + call mpas_rbf_interp_initialize(mesh) + call mpas_init_reconstruct(mesh) + nullify (mesh) ! Read the global sphere_radius attribute. This is needed to normalize the cell areas. - ierr = pio_get_att(pioid, pio_global, 'sphere_radius', sphere_radius) + ierr = pio_get_att(pioid_ic, pio_global, 'sphere_radius', domain_ptr % sphere_radius) if( ierr /= 0 ) then call mpp_error(FATAL,subname//": Could not find sphere_radius PIO attribute") endif + ! FROM CAM/dyn_grid.F90:dyn_grid_init() ! Query global grid dimensions from MPAS call ufs_mpas_get_global_dims(nCellsGlobal, nEdgesGlobal, nVerticesGlobal, maxEdges, nVertLevels, maxNCells) @@ -554,15 +329,23 @@ subroutine ufs_mpas_init_phase1(Cfg, time_start, time_end, total_time, calendar, allocate(latCellGlobal(nCellsGlobal), lonCellGlobal(nCellsGlobal), areaCellGlobal(nCellsGlobal)) call ufs_mpas_get_global_coords(latCellGlobal, lonCellGlobal, areaCellGlobal) - end subroutine ufs_mpas_init_phase1 + ! + ! Initialize core + ! + call ufs_mpas_atm_core_init(Cfg) + + end subroutine ufs_mpas_init !> ######################################################################################## !> Procedure to initialize UWM with MPAS dynamical core. - !> + !> + !> Follows atm_core_init() in MPAS-Model/src/core_atmosphere/mpas_atm_core.F. + !> !> ######################################################################################## - subroutine ufs_mpas_init_phase2(Cfg) + subroutine ufs_mpas_atm_core_init(Cfg) use mpas_kind_types, only : StrKIND, RKIND use mpas_derived_types, only : mpas_pool_type, mpas_Time_Type, field0DReal, field2dreal + use mpas_derived_types, only : block_type, field3dreal, MPAS_STREAM_MGR_NOERR, MPAS_LOG_ERR use mpas_domain_routines, only : mpas_pool_get_dimension use mpas_pool_routines, only : mpas_pool_get_subpool use mpas_pool_routines, only : mpas_pool_initialize_time_levels, mpas_pool_get_config @@ -571,9 +354,11 @@ subroutine ufs_mpas_init_phase2(Cfg) use mpas_atm_threading, only : mpas_atm_threading_init use mpp_mod, only : FATAL, mpp_error use mpas_atm_halos, only : atm_build_halo_groups, exchange_halo_group - use atm_core, only : atm_mpas_init_block, core_clock => clock + use atm_core, only : atm_mpas_init_block + use atm_time_integration, only : mpas_atm_dynamics_checks use atm_time_integration, only : mpas_atm_dynamics_init use mpas_timekeeping, only : mpas_get_clock_time, mpas_get_time, mpas_START_TIME + use mpas_timekeeping, only : mpas_NOW, mpas_set_timeInterval, operator(+) use mpas_log, only : mpas_log_write use mpas_attlist, only : mpas_modify_att use mpas_string_utils, only : mpas_string_replace @@ -582,18 +367,20 @@ subroutine ufs_mpas_init_phase2(Cfg) type(mpas_control_type), intent(inout) :: Cfg type(mpas_pool_type), pointer :: tend_physics_pool ! Locals - character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_init_phase2' - type (mpas_pool_type), pointer :: state, mesh + character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_atm_core_init' + type (mpas_pool_type), pointer :: state, mesh, diag integer :: ierr integer, pointer :: nVertLevels1, maxEdges1, maxEdges2, num_scalars real (kind=RKIND), pointer :: dt + type (block_type), pointer :: block logical, pointer :: config_do_restart type (mpas_Time_Type) :: startTime character(len=StrKIND) :: startTimeStamp character (len=StrKIND), pointer :: xtime character (len=StrKIND), pointer :: initial_time1, initial_time2 - type(field0dreal), pointer :: field_0d_real - type(field2dreal), pointer :: field_2d_real + real(RKIND), dimension(:,:,:), pointer :: field_3d_real + logical, pointer :: config_apply_lbcs + real(RKIND), dimension(:,:), pointer :: theta1 ! ! Setup threading @@ -613,55 +400,67 @@ subroutine ufs_mpas_init_phase2(Cfg) call mpas_pool_get_dimension(state, 'maxEdges', maxEdges1) call mpas_pool_get_dimension(state, 'maxEdges2', maxEdges2) call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - call mpas_atm_set_dims(nVertLevels1, maxEdges1, maxEdges2, num_scalars) - Cfg % levs = nVertLevels1 + Cfg % levs = nVertLevels1 !DJS: Do we need this? + nullify (state) ! ! Set "local" clock to point to the clock contained in the domain type ! clock => domain_ptr % clock - core_clock => domain_ptr % clock ! ! Build halo exchange groups and set method for exchanging halos in a group ! call mpas_log_write('Building halo exchange groups.') - nullify(exchange_halo_group) call atm_build_halo_groups(domain_ptr, ierr) - if (ierr /= 0) then call mpp_error(FATAL,subname//": failed to build MPAS-A halo exchange groups.") end if if (.not. associated(exchange_halo_group)) then call mpp_error(FATAL,subname//": failed to build MPAS-A halo exchange groups.") - end if + endif - ! Variables in MPAS "state" pool have more than one time level. Copy the values from the first time level of - ! such variables into all subsequent time levels to initialize them. + ! call mpas_pool_get_config(domain_ptr % blocklist % configs, 'config_do_restart', config_do_restart) call mpas_pool_get_config(domain_ptr % blocklist % configs, 'config_dt', dt) + ! + ! Read in initial-conditions + ! + call mpas_log_write('Reading in MPAS initial condition stream.') + call dyn_mpas_read_write_stream(clock, 'r', 'input', pio_file_desc=pioid_ic, ierr=ierr, timeLevel=1, whence=mpas_NOW, nRecord=1) + if (ierr /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Could not read from ''input'' stream ',messageType=MPAS_LOG_ERR) + call mpp_error(FATAL,'ERROR: Could not read from ''input'' stream ') + end if + call dyn_mpas_read_write_stream(clock, 'r', 'sfc_input', pio_file_desc=pioid_ic, ierr=ierr, timeLevel=1, whence=mpas_NOW, nRecord=1) + if (ierr /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Could not read from ''sfc_input'' stream ',messageType=MPAS_LOG_ERR) + call mpp_error(FATAL,'ERROR: Could not read from ''input'' stream ') + end if + + ! + ! Read in restart data. + ! + !call mpas_log_write('Reading in MPAS restart stream.') + !call dyn_mpas_read_write_stream(clock, 'r', 'restart', ierr=ierr, timeLevel=1, whence=mpas_NOW) + + if (.not. config_do_restart) then call mpas_log_write('Initializing time levels') - call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) call mpas_pool_initialize_time_levels(state) - nullify(state) - end if - nullify (config_do_restart) - - call exchange_halo_group(domain_ptr, 'initialization:u',ierr=ierr) - if ( ierr /= 0 ) then - call mpp_error(FATAL,subname//'Failed to exchange halo layers for group "initialization:u"') + nullify (state) end if call mpas_log_write('Initializing atmospheric variables') - + ! How many calls to MPAS dycore for each ATMosphere time step? - Cfg%dt_dycore = dt - n_atmos = dt_atmos/dt - + Cfg%dt_dycore = dt ! DJS: Does this need to be here? + n_atmos = dt_atmos/dt ! DJS: Does this need to be here? + ! ! Set startTimeStamp based on the start time of the simulation clock ! @@ -673,14 +472,37 @@ subroutine ufs_mpas_init_phase2(Cfg) if ( ierr /= 0 ) then call mpp_error(FATAL,subname//': Failed to get time mpas_START_TIME"') end if + call mpas_log_write('Setting simulation start time :'//startTimeStamp) + + ! + call exchange_halo_group(domain_ptr, 'initialization:u',ierr=ierr) + if ( ierr /= 0 ) then + call mpp_error(FATAL,subname//'Failed to exchange halo layers for group "initialization:u"') + end if + + ! + ! Perform basic compatibility checks among the fields that were read and the run-time options that were selected + ! + call mpas_atm_dynamics_checks(domain_ptr % dminfo, domain_ptr % blocklist, domain_ptr % streamManager, ierr) + if (ierr /= 0) then + call mpas_log_write('Failed dynamics compatibility test.') + return + end if + call mpas_pool_get_config( domain_ptr % blocklist % configs, 'config_apply_lbcs', config_apply_lbcs) + if (config_apply_lbcs) then + call ufs_mpas_atm_bdy_checks(domain_ptr % dminfo, domain_ptr % blocklist, ierr) + if (ierr /= 0) then + call mpas_log_write('Failed regional compatibility test.') + return + end if + end if - call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', mesh) - !call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) call atm_mpas_init_block(domain_ptr % dminfo, domain_ptr % streamManager, domain_ptr % blocklist, mesh, dt) + nullify (mesh) - call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) call mpas_pool_get_array(state, 'xtime', xtime, timelevel=1) xtime = startTimeStamp @@ -690,23 +512,7 @@ subroutine ufs_mpas_init_phase2(Cfg) call mpas_pool_get_array(state, 'initial_time', initial_time1, timelevel=1) call mpas_pool_get_array(state, 'initial_time', initial_time2, timelevel=2) initial_time2 = initial_time1 - - ! - ! Set time units to CF-compliant "seconds since ". - ! - call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) - call mpas_pool_get_field(state, 'Time', field_0d_real, timelevel=1) - - if (.not. associated(field_0d_real)) then - call mpp_error(FATAL,subname//'Failed to find variable "Time"') - end if - - call mpas_modify_att(field_0d_real % attlists(1) % attlist, 'units', & - 'seconds since ' // mpas_string_replace(initial_time1, '_', ' '), ierr=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to set time units') - end if + nullify (state) call exchange_halo_group(domain_ptr, 'initialization:pv_edge,ru,rw',ierr=ierr) if ( ierr /= 0 ) then @@ -719,32 +525,21 @@ subroutine ufs_mpas_init_phase2(Cfg) call mpas_log_write('Initializing the dynamics') call mpas_atm_dynamics_init(domain_ptr) - ! - ! Some additional "scratch" fields are needed for interoperability with CAM-SIMA, but they are not initialized by - ! `mpas_atm_dynamics_init`. Initialize them below. - ! -! call mpas_pool_get_field(domain_ptr % blocklist % allfields, 'tend_uzonal', field_2d_real, timelevel=1) -! call mpas_allocate_scratch_field(field_2d_real) -! nullify(field_2d_real) - -! call mpas_pool_get_field(domain_ptr % blocklist % allfields, 'tend_umerid', field_2d_real, timelevel=1) -! call mpas_allocate_scratch_field(field_2d_real) -! nullify(field_2d_real) - call mpas_log_write('Successful initialization of MPAS dynamical core') - end subroutine ufs_mpas_init_phase2 + end subroutine ufs_mpas_atm_core_init !> ######################################################################################### !> Routine to call MPAS dynamical core !> Loop over dynamical time-step(s) and increment MPAS state (timelevel 1->2) !> !> ######################################################################################### - subroutine ufs_mpas_run() + subroutine ufs_mpas_run(mpasClock, outClock) ! MPAS use atm_core, only : atm_do_timestep, atm_compute_output_diagnostics use mpas_domain_routines, only : mpas_pool_get_dimension - use mpas_derived_types, only : mpas_Time_type, mpas_pool_type, MPAS_TimeInterval_type + use mpas_derived_types, only : mpas_Time_type, mpas_pool_type, MPAS_TimeInterval_type, field2DReal + use mpas_derived_types, only : MPAS_LOG_ERR use mpas_kind_types, only : StrKIND, RKIND, R8KIND use mpas_constants, only : rvord use mpas_pool_routines, only : mpas_pool_get_config, mpas_pool_get_subpool @@ -753,62 +548,119 @@ subroutine ufs_mpas_run() use mpas_timer, only : mpas_timer_start, mpas_timer_stop use mpas_timekeeping, only : mpas_advance_clock, mpas_get_clock_time, mpas_get_time use mpas_timekeeping, only : mpas_NOW, mpas_is_clock_stop_time, mpas_dmpar_get_time - use mpas_timekeeping, only : mpas_set_timeInterval, operator(+), operator(<) + use mpas_timekeeping, only : mpas_set_timeInterval, operator(+), operator(.LT.), operator(.GT.), operator(.LE.), operator(.EQ.) ! FMS use mpp_mod, only : FATAL, mpp_error + use mpp_mod, only : mpp_clock_begin, mpp_clock_end + ! Arguments + integer, intent(inout) :: mpasClock, outClock ! Locals character(len=*), parameter :: subname = 'ufs_mpas_run::ufs_mpas_run' real (kind=RKIND), pointer :: config_dt type (mpas_pool_type), pointer :: state, diag, mesh - type (mpas_Time_type) :: timeNow, timeStop + type (mpas_Time_type) :: timeNow, timeStop,timeLBCnew character(len=StrKIND) :: timeStamp - integer :: ierr, itime, itimestep - integer, pointer :: index_qv - integer, pointer :: nCellsSolve - real(kind=RKIND), dimension(:,:), pointer :: theta_m, rho_zz, zz, theta, rho - real(kind=RKIND), dimension(:,:,:), pointer :: scalars - real (kind=R8KIND) :: integ_start_time, integ_stop_time + integer :: ierr, itime, itimestep, iout + real (kind=R8KIND) :: integ_start_time, integ_stop_time logical, pointer :: config_apply_lbcs - type(mpas_timeinterval_type) :: mpas_time_interval + type(mpas_timeinterval_type) :: mpas_time_interval, mpas_output_interval + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + + ! Start dynamics timer + call mpp_clock_begin(mpasClock) call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'diag', diag) call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', mesh) - + call atm_compute_output_diagnostics(state, 1, diag, mesh) + ! Eventually, dt should be domain specific call mpas_pool_get_config( domain_ptr % blocklist % configs, 'config_dt', config_dt) + call mpas_pool_get_config( domain_ptr % blocklist % configs, 'config_apply_lbcs', config_apply_lbcs) + + ! Set up clock + timeNow = mpas_get_clock_time(clock, mpas_NOW, ierr=ierr) + if (ierr /= 0) then + call mpp_error(FATAL,subname//': Failed to get clock_time for "mpas_NOW"') + endif + + call mpas_get_time(curr_time=timeNow, dateTimeString=timeStamp, ierr=ierr) + if (ierr /= 0) then + call mpp_error(FATAL,subname//': Failed to get clock_time for "mpas_NOW"') + endif + + ! Set dycore interval call MPAS_set_timeInterval(mpas_time_interval, S=dt_atmos, ierr=ierr) if (ierr /= 0) then call mpp_error(FATAL,subname//'Failed to set dynamics time step') endif ! - ! Read initial boundary state - ! NOT YET IMPLEMENTED (Follow src/core_atmosphere/mpas_atm_core.F:atm_core_run()) + ! Set MPAS output file times ! - call mpas_pool_get_config( domain_ptr % blocklist % configs, 'config_apply_lbcs', config_apply_lbcs) - if (config_apply_lbcs) then - - endif - - ! During integration, time level 1 stores the model state at the beginning of the - ! time step, and time level 2 stores the state advanced config_dt in time by timestep(...) - timeNow = mpas_get_clock_time(clock, mpas_NOW, ierr) - if (ierr /= 0) then - call mpp_error(FATAL,subname//': Failed to get clock_time for "mpas_NOW"') + if (.not. allocated(mpas_output_times)) then + allocate(mpas_output_times(size(output_fh))) + mpas_output_times(1) = timeNow + do iout=2,size(output_fh) + call mpas_set_timeInterval(mpas_output_interval, S=int(3600.*output_fh(iout)), ierr=ierr) + mpas_output_times(iout) = timeNow + mpas_output_interval + if ( ierr /= 0 ) then + call mpp_error(FATAL,subname//': Failed to set output file names"') + end if + enddo + ! Also, write IC state to history file while we're here. + call ufs_mpas_write("output", timeStamp) + ! Start output file counter + out_file_index = 2 endif + ! + ! Read initial boundary state + ! During integration, time level 1 stores the boundary tendencies (next-current) file records, + ! and time level 2 stores the state at the next file record. + if (config_apply_lbcs .and. init_lbc) then + call mpas_log_write('--------------------------------------------------') + call mpas_log_write('Compute initial lateral boundary conditions for timestep '//trim(timeStamp)) + call ufs_mpas_atm_update_bdy_tend(clock, domain_ptr % blocklist, .true., nRecord_lbc, ierr) + if (ierr /= 0) then + call mpas_log_write('Failed to process LBC data at next time after '//trim(timeStamp), messageType=MPAS_LOG_ERR) + return + end if + init_lbc = .false. + ! Also, write IC state to history file while we're here. + call ufs_mpas_write("output", timeStamp) + end if + + ! During integration, time level 1 stores the model state at the beginning of the + ! time step, and time level 2 stores the state advanced config_dt in time by timestep timeStop = timeNow + mpas_time_interval itimestep = 0 - do while (itimestep < 1)!(timeNow < timeStop) !DJS2025: Only one dycore inte + call mpas_log_write('--------------------------------------------------') + call mpas_log_write('MPAS dynamics start timestep') + do while (timeNow .LT. timeStop) itimestep = itimestep + 1 - ! + call mpas_get_time(curr_time=timeNow, dateTimeString=timeStamp, ierr=ierr) if ( ierr /= 0 ) then call mpp_error(FATAL,subname//': Failed to get time mpas_NOW"') end if - call mpas_log_write('') - call mpas_log_write(' MPAS dynamics start timestep '//trim(timeStamp)) + call mpas_log_write(' Start timestep at '//trim(timeStamp)) + + ! + ! Read future boundary state and compute boundary tendencies + ! + if (config_apply_lbcs) then + if (LBC_intv_end .LE. timeNow) then + nRecord_lbc = nRecord_lbc + 1 + call mpas_log_write('--------------------------------------------------') + call mpas_log_write('Update lateral boundary conditions for timestep '//trim(timeStamp)) + call ufs_mpas_atm_update_bdy_tend(clock, domain_ptr % blocklist, .false., nRecord_lbc, ierr) + if (ierr /= 0) then + call mpas_log_write('Failed to process LBC data at next time after '//trim(timeStamp), messageType=MPAS_LOG_ERR) + return + end if + end if + end if ! Integrate forward one dycore time step call mpas_timer_start('time integration') @@ -816,55 +668,51 @@ subroutine ufs_mpas_run() call atm_do_timestep(domain_ptr, config_dt, itimestep) call mpas_dmpar_get_time(integ_stop_time) call mpas_timer_stop('time integration') - !call mpas_log_write(' Timing for integration step: $r s', realArgs=(/real(integ_stop_time - integ_start_time, kind=RKIND)/)) + call mpas_log_write(' Timing for integration step: $r s', realArgs=(/real(integ_stop_time - integ_start_time, kind=RKIND)/)) ! Move time level 2 fields back into time level 1 for next time step call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) call mpas_pool_shift_time_levels(state) ! Advance clock. - call mpas_advance_clock(clock) - timeNow = mpas_get_clock_time(clock, mpas_NOW, ierr) + call mpas_advance_clock(clock, ierr=ierr) + if (ierr /= 0) then + call mpp_error(FATAL,subname//': Failed to advance clock') + endif + timeNow = mpas_get_clock_time(clock, mpas_NOW, ierr=ierr) if (ierr /= 0) then call mpp_error(FATAL,subname//': Failed to get clock_time for "mpas_NOW"') endif - end do + call mpas_log_write('MPAS dynamics stop timestep') + call mpp_clock_end(mpasClock) ! - ! Compute diagnostic fields from the final prognostic state + ! Compute diagnostic fields (theta, rho, pres) from + ! the final prognostic state (theta_m, rho_zz, zz) ! + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'diag', diag) + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', mesh) call atm_compute_output_diagnostics(state, 1, diag, mesh) - end subroutine ufs_mpas_run - - - !> ######################################################################################### - !> Procedure to open MPAS IC file. - !> - !> ######################################################################################### - subroutine ufs_mpas_open_init() - ! PIO - use pio, only : pio_openfile, pio_nowrite - ! FMS - use fms2_io_mod, only : file_exists - use mpp_mod, only : FATAL, mpp_error - ! Arguments - ! Locals - integer :: ierr - character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_open_init' + ! + ! Write any output streams + ! + call mpp_clock_begin(outClock) + call mpas_get_time(curr_time=timeStop, dateTimeString=timeStamp, ierr=ierr) + if ( ierr /= 0 ) then + call mpp_error(FATAL,subname//': Failed to get time timeStop"') + end if - ! Open MPAS Initial Condition file. - if (file_exists(ic_filename)) then - ierr = pio_openfile(pio_subsystem, pioid, pio_iotype, ic_filename, pio_nowrite) - if (ierr /= 0) then - call mpp_error(FATAL,subname//": Failed opening MPAS IC File, "//trim(ic_filename)) - end if - else - call mpp_error(FATAL,subname//": Cannot find MPAS IC file: "//trim(ic_filename)) + if (timeStop .EQ. mpas_output_times(out_file_index)) then + call ufs_mpas_write("output", timeStamp) + out_file_index = out_file_index + 1 end if - end subroutine ufs_mpas_open_init - + call mpp_clock_end(outClock) + + end subroutine ufs_mpas_run + !> ######################################################################################### !> Procedure to read MPAS namelist(s). !> @@ -902,12 +750,14 @@ subroutine read_mpas_namelist(nml_file, configPool, mpicomm, master, me) real(r8) :: mpas_h_theta_eddy_visc4 = 0.0_r8 real(r8) :: mpas_v_theta_eddy_visc2 = 0.0_r8 character (len=StrKIND) :: mpas_horiz_mixing = '2d_smagorinsky' - real(r8) :: mpas_len_disp = 120000.0_r8 + real(r8) :: mpas_len_disp = 0.0_r8 real(r8) :: mpas_visc4_2dsmag = 0.05_r8 real(r8) :: mpas_del4u_div_factor = 10.0_r8 integer :: mpas_w_adv_order = 3 integer :: mpas_theta_adv_order = 3 integer :: mpas_scalar_adv_order = 3 + real(r8) :: mpas_h_scalar_filter4 = 0.0_r8 + logical :: mpas_scalar_eddy_mix = .false. integer :: mpas_u_vadv_order = 3 integer :: mpas_w_vadv_order = 3 integer :: mpas_theta_vadv_order = 3 @@ -926,10 +776,10 @@ subroutine read_mpas_namelist(nml_file, configPool, mpicomm, master, me) real(r8) :: mpas_zd = 22000.0_r8 real(r8) :: mpas_xnutr = 0.2_r8 real(r8) :: mpas_cam_coef = 0.0_r8 - integer :: mpas_cam_damping_levels = 0 - logical :: mpas_rayleigh_damp_u = .true. + integer :: mpas_cam_damping_levels = 4 + logical :: mpas_rayleigh_damp_u = .false. real(r8) :: mpas_rayleigh_damp_u_timescale_days = 5.0_r8 - integer :: mpas_number_rayleigh_damp_u_levels = 3 + integer :: mpas_number_rayleigh_damp_u_levels = 6 ! Namelist limited_area logical :: mpas_apply_lbcs = .false. ! Namelist PIO @@ -951,7 +801,8 @@ subroutine read_mpas_namelist(nml_file, configPool, mpicomm, master, me) mpas_h_mom_eddy_visc2, mpas_h_mom_eddy_visc4, mpas_v_mom_eddy_visc2, & mpas_h_theta_eddy_visc2, mpas_h_theta_eddy_visc4, mpas_v_theta_eddy_visc2, & mpas_horiz_mixing, mpas_len_disp, mpas_visc4_2dsmag, mpas_del4u_div_factor, & - mpas_w_adv_order, mpas_theta_adv_order, mpas_scalar_adv_order, mpas_u_vadv_order, & + mpas_w_adv_order, mpas_theta_adv_order, mpas_scalar_adv_order, mpas_h_scalar_filter4,& + mpas_scalar_eddy_mix, mpas_u_vadv_order, & mpas_w_vadv_order, mpas_theta_vadv_order, mpas_scalar_vadv_order, & mpas_scalar_advection, mpas_positive_definite, mpas_monotonic, mpas_coef_3rd_order, & mpas_smagorinsky_coef, mpas_mix_full, mpas_epssm, mpas_smdiv, mpas_apvm_upwinding, & @@ -1019,7 +870,7 @@ subroutine read_mpas_namelist(nml_file, configPool, mpicomm, master, me) ! ! MPI Broadcast to all - ! + ! call mpi_bcast(mpas_time_integration, StrKIND, mpi_character, master, mpicomm, mpierr) call mpi_bcast(mpas_time_integration_order, 1, mpi_integer, master, mpicomm, mpierr) call mpi_bcast(mpas_dt, 1, mpi_real8, master, mpicomm, mpierr) @@ -1039,6 +890,8 @@ subroutine read_mpas_namelist(nml_file, configPool, mpicomm, master, me) call mpi_bcast(mpas_w_adv_order, 1, mpi_integer, master, mpicomm, mpierr) call mpi_bcast(mpas_theta_adv_order, 1, mpi_integer, master, mpicomm, mpierr) call mpi_bcast(mpas_scalar_adv_order, 1, mpi_integer, master, mpicomm, mpierr) + call mpi_bcast(mpas_h_scalar_filter4, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_scalar_eddy_mix, 1, mpi_logical, master, mpicomm, mpierr) call mpi_bcast(mpas_u_vadv_order, 1, mpi_integer, master, mpicomm, mpierr) call mpi_bcast(mpas_w_vadv_order, 1, mpi_integer, master, mpicomm, mpierr) call mpi_bcast(mpas_theta_vadv_order, 1, mpi_integer, master, mpicomm, mpierr) @@ -1076,7 +929,7 @@ subroutine read_mpas_namelist(nml_file, configPool, mpicomm, master, me) call mpi_bcast(mpas_print_global_minmax_vel, 1, mpi_logical, master, mpicomm, mpierr) call mpi_bcast(mpas_print_detailed_minmax_vel, 1, mpi_logical, master, mpicomm, mpierr) call mpi_bcast(mpas_print_global_minmax_sca, 1, mpi_logical, master, mpicomm, mpierr) - + ! ! Set MPAS configuration information pool variables ! @@ -1099,6 +952,8 @@ subroutine read_mpas_namelist(nml_file, configPool, mpicomm, master, me) call mpas_pool_add_config(configPool, 'config_w_adv_order', mpas_w_adv_order) call mpas_pool_add_config(configPool, 'config_theta_adv_order', mpas_theta_adv_order) call mpas_pool_add_config(configPool, 'config_scalar_adv_order', mpas_scalar_adv_order) + call mpas_pool_add_config(configPool, 'config_h_scalar_filter4', real(mpas_h_scalar_filter4)) + call mpas_pool_add_config(configPool, 'config_scalar_eddy_mix', mpas_scalar_eddy_mix) call mpas_pool_add_config(configPool, 'config_u_vadv_order', mpas_u_vadv_order) call mpas_pool_add_config(configPool, 'config_w_vadv_order', mpas_w_vadv_order) call mpas_pool_add_config(configPool, 'config_theta_vadv_order', mpas_theta_vadv_order) @@ -1200,1861 +1055,4 @@ subroutine read_mpas_namelist(nml_file, configPool, mpicomm, master, me) end if end subroutine read_mpas_namelist - !> ######################################################################################## - ! subroutine dyn_mpas_read_write_stream - ! - !> summary: Read or write an MPAS stream. - !> author: Kuan-Chih Wang - !> date: 2024-03-15 - !> - !> In the context of MPAS, the concept of a "pool" resembles a group of - !> (related) variables, while the concept of a "stream" resembles a file. - !> This subroutine reads or writes an MPAS stream. It provides the mechanism - !> for CAM-SIMA to input/output data to/from MPAS dynamical core. - !> Analogous to the `{read,write}_stream` subroutines in MPAS stream manager. - ! - !> ######################################################################################## - subroutine dyn_mpas_read_write_stream(stream_mode, stream_name) - ! Module(s) from external libraries. - use pio, only: file_desc_t - use mpp_mod, only : FATAL, mpp_error - ! Module(s) from MPAS. - use mpas_derived_types, only : mpas_pool_type, mpas_stream_noerr, mpas_stream_type - use mpas_io_streams, only : mpas_closestream, mpas_readstream, mpas_writestream - use mpas_pool_routines, only : mpas_pool_destroy_pool - use mpas_stream_manager, only : postread_reindex, prewrite_reindex, postwrite_reindex - use mpas_log, only : mpas_log_write - use mpas_atm_halos, only : exchange_halo_group - - character(*), intent(in) :: stream_mode - character(*), intent(in) :: stream_name - - character(*), parameter :: subname = 'dyn_mpas_subdriver::dyn_mpas_read_write_stream' - integer :: i, ierr - type(mpas_pool_type), pointer :: mpas_pool - type(mpas_stream_type), pointer :: mpas_stream - type(var_info_type), allocatable :: var_info_list(:) - - call mpas_log_write('') - - nullify(mpas_pool) - nullify(mpas_stream) - - call mpas_log_write( 'Initializing stream "' // trim(adjustl(stream_name)) // '"') - - call dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pioid, stream_mode, stream_name) - - if (.not. associated(mpas_pool)) then - call mpp_error(FATAL,subname//'Failed to initialize stream "' // trim(adjustl(stream_name)) // '"') - end if - - if (.not. associated(mpas_stream)) then - call mpp_error(FATAL,subname//'Failed to initialize stream "' // trim(adjustl(stream_name)) // '"') - end if - - select case (trim(adjustl(stream_mode))) - case ('r', 'read') - call mpas_log_write('Reading stream "' // trim(adjustl(stream_name)) // '"') - - call mpas_readstream(mpas_stream, 1, ierr=ierr) - - if (ierr /= mpas_stream_noerr) then - call mpp_error(FATAL,subname//'Failed to read stream "' // trim(adjustl(stream_name)) // '"') - end if - - ! Exchange halo layers because new data have just been read. - var_info_list = parse_stream_name(stream_name) - - do i = 1, size(var_info_list) - call dyn_mpas_exchange_halo(var_info_list(i) % name) - if ( ierr /= 0 ) then - call mpp_error(FATAL,subname//'Failed to exchange halo layers for group '//var_info_list(i) % name) - end if - end do - - ! For any connectivity arrays in this stream, convert global indexes to local indexes. - call postread_reindex(domain_ptr % blocklist % allfields, domain_ptr % packages, & - mpas_pool, mpas_pool) - case ('w', 'write') - call mpas_log_write('Writing stream "' // trim(adjustl(stream_name)) // '"') - - ! WARNING: - ! The `{pre,post}write_reindex` subroutines are STATEFUL because they store information inside their module - ! (i.e., module variables). They MUST be called in pairs, like below, to prevent undefined behaviors. - - ! For any connectivity arrays in this stream, temporarily convert local indexes to global indexes. - call prewrite_reindex(domain_ptr % blocklist % allfields, domain_ptr % packages, & - mpas_pool, mpas_pool) - - call mpas_writestream(mpas_stream, 1, ierr=ierr) - - if (ierr /= mpas_stream_noerr) then - call mpp_error(FATAL,subname//'Failed to write stream "' // trim(adjustl(stream_name)) // '"') - end if - - ! For any connectivity arrays in this stream, reset global indexes back to local indexes. - call postwrite_reindex(domain_ptr % blocklist % allfields, mpas_pool) - case default - call mpp_error(FATAL,subname//'Unsupported stream mode "' // trim(adjustl(stream_mode)) // '"') - end select - - call mpas_log_write('Closing stream "' // trim(adjustl(stream_name)) // '"') - - call mpas_closestream(mpas_stream, ierr=ierr) - - if (ierr /= mpas_stream_noerr) then - call mpp_error(FATAL,subname//'Failed to close stream "' // trim(adjustl(stream_name)) // '"') - end if - - ! Deallocate temporary pointers to avoid memory leaks. - call mpas_pool_destroy_pool(mpas_pool) - nullify(mpas_pool) - - deallocate(mpas_stream) - nullify(mpas_stream) - - call mpas_log_write(subname // ' completed') - end subroutine dyn_mpas_read_write_stream - - !> ######################################################################################## - ! subroutine dyn_mpas_exchange_halo - ! - !> summary: Update the halo layers of the named field. - !> author: Michael Duda - !> date: 16 January 2020 - !> - !> Given a field name that is defined in MPAS registry, this subroutine updates - !> the halo layers for that field. - !> Ported and refactored for CAM-SIMA. (KCW, 2024-03-18) - !> Ported and refactored for UWM (DJS: 2025) - ! - !> ######################################################################################## - subroutine dyn_mpas_exchange_halo(field_name) - ! Module(s) from MPAS. - use mpas_derived_types, only : field1dinteger, field2dinteger, field3dinteger, & - field1dreal, field2dreal, field3dreal, field4dreal, & - field5dreal, mpas_pool_field_info_type, mpas_pool_integer,& - mpas_pool_real - use mpas_dmpar, only : mpas_dmpar_exch_halo_field - use mpas_pool_routines, only : mpas_pool_get_field, mpas_pool_get_field_info - use mpp_mod, only : FATAL, mpp_error - use mpas_log, only : mpas_log_write - character(*), intent(in) :: field_name - - character(*), parameter :: subname = 'dyn_mpas_subdriver::dyn_mpas_exchange_halo' - type(field1dinteger), pointer :: field_1d_integer - type(field2dinteger), pointer :: field_2d_integer - type(field3dinteger), pointer :: field_3d_integer - type(field1dreal), pointer :: field_1d_real - type(field2dreal), pointer :: field_2d_real - type(field3dreal), pointer :: field_3d_real - type(field4dreal), pointer :: field_4d_real - type(field5dreal), pointer :: field_5d_real - type(mpas_pool_field_info_type) :: mpas_pool_field_info - - call mpas_log_write(subname // ' entered') - - nullify(field_1d_integer) - nullify(field_2d_integer) - nullify(field_3d_integer) - nullify(field_1d_real) - nullify(field_2d_real) - nullify(field_3d_real) - nullify(field_4d_real) - nullify(field_5d_real) - - call mpas_log_write('Inquiring field information for "' // trim(adjustl(field_name)) // '"') - - call mpas_pool_get_field_info(domain_ptr % blocklist % allfields, & - trim(adjustl(field_name)), mpas_pool_field_info) - - if (mpas_pool_field_info % fieldtype == -1 .or. & - mpas_pool_field_info % ndims == -1 .or. & - mpas_pool_field_info % nhalolayers == -1) then - call mpp_error(FATAL,subname//'Invalid field information for "' // trim(adjustl(field_name)) // '"') - end if - - ! No halo layers to exchange. This field is not decomposed. - if (mpas_pool_field_info % nhalolayers == 0) then - call mpas_log_write('Skipping field "' // trim(adjustl(field_name)) // '" due to not decomposed') - - return - end if - - call mpas_log_write('Exchanging halo layers for "' // trim(adjustl(field_name)) // '"') - - select case (mpas_pool_field_info % fieldtype) - case (mpas_pool_integer) - select case (mpas_pool_field_info % ndims) - case (1) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(field_name)), field_1d_integer, timelevel=1) - - if (.not. associated(field_1d_integer)) then - call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') - end if - - call mpas_dmpar_exch_halo_field(field_1d_integer) - - nullify(field_1d_integer) - case (2) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(field_name)), field_2d_integer, timelevel=1) - - if (.not. associated(field_2d_integer)) then - call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') - end if - - call mpas_dmpar_exch_halo_field(field_2d_integer) - - nullify(field_2d_integer) - case (3) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(field_name)), field_3d_integer, timelevel=1) - - if (.not. associated(field_3d_integer)) then - call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') - end if - - call mpas_dmpar_exch_halo_field(field_3d_integer) - - nullify(field_3d_integer) - case default - call mpp_error(FATAL,subname//'Unsupported field rank ' // stringify([mpas_pool_field_info % ndims])) - end select - case (mpas_pool_real) - select case (mpas_pool_field_info % ndims) - case (1) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(field_name)), field_1d_real, timelevel=1) - - if (.not. associated(field_1d_real)) then - call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') - end if - - call mpas_dmpar_exch_halo_field(field_1d_real) - - nullify(field_1d_real) - case (2) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(field_name)), field_2d_real, timelevel=1) - - if (.not. associated(field_2d_real)) then - call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') - end if - - call mpas_dmpar_exch_halo_field(field_2d_real) - - nullify(field_2d_real) - case (3) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(field_name)), field_3d_real, timelevel=1) - - if (.not. associated(field_3d_real)) then - call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') - end if - - call mpas_dmpar_exch_halo_field(field_3d_real) - - nullify(field_3d_real) - case (4) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(field_name)), field_4d_real, timelevel=1) - - if (.not. associated(field_4d_real)) then - call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') - end if - - call mpas_dmpar_exch_halo_field(field_4d_real) - - nullify(field_4d_real) - case (5) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(field_name)), field_5d_real, timelevel=1) - - if (.not. associated(field_5d_real)) then - call mpp_error(FATAL,subname//'Failed to find field "' // trim(adjustl(field_name)) // '"') - end if - - call mpas_dmpar_exch_halo_field(field_5d_real) - - nullify(field_5d_real) - case default - call mpp_error(FATAL,subname//'Unsupported field rank ' // stringify([mpas_pool_field_info % ndims])) - end select - case default - call mpp_error(FATAL,subname//'Unsupported field type (Must be one of: integer, real)') - end select - - call mpas_log_write(subname // ' completed') - end subroutine dyn_mpas_exchange_halo - - !> ######################################################################################## - ! subroutine dyn_mpas_init_stream_with_pool - ! - !> summary: Initialize an MPAS stream with an accompanying MPAS pool. - !> author: Kuan-Chih Wang - !> date: 2024-03-14 - !> - !> In the context of MPAS, the concept of a "pool" resembles a group of - !> (related) variables, while the concept of a "stream" resembles a file. - !> This subroutine initializes an MPAS stream with an accompanying MPAS pool by - !> adding variable and attribute information to them. After that, MPAS is ready - !> to perform IO on them. - !> Analogous to the `build_stream` and `mpas_stream_mgr_add_field` - !> subroutines in MPAS stream manager. - !> - !> Ported and refactored for UWM (DJS: 2025) - ! - !> ######################################################################################## - subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stream_mode, & - stream_name) - ! Module(s) from external libraries. - use pio, only: file_desc_t, pio_file_is_open - ! Module(s) from MPAS. - use mpas_derived_types, only : field0dchar, field1dchar, field0dinteger, field1dinteger,& - field2dinteger, field3dinteger, field0dreal, field1dreal,& - field2dreal, field3dreal, field4dreal, field5dreal, & - mpas_io_native_precision, mpas_io_pnetcdf, mpas_io_read, & - mpas_io_write, mpas_pool_type, mpas_stream_noerr, & - mpas_stream_type - use mpas_io_streams, only : mpas_createstream, mpas_streamaddfield - use mpas_pool_routines, only : mpas_pool_add_config, mpas_pool_create_pool, mpas_pool_get_field - use mpas_kind_types, only : StrKIND, RKIND - use mpp_mod, only : FATAL, mpp_error - use mpas_log, only : mpas_log_write - - type(mpas_pool_type), pointer, intent(out) :: mpas_pool - type(mpas_stream_type), pointer, intent(out) :: mpas_stream - type(file_desc_t), pointer, intent(in) :: pio_file - character(*), intent(in) :: stream_mode - character(*), intent(in) :: stream_name - - interface add_stream_attribute - procedure :: add_stream_attribute_0d - procedure :: add_stream_attribute_1d - end interface add_stream_attribute - - character(*), parameter :: subname = 'dyn_mpas_subdriver::dyn_mpas_init_stream_with_pool' - character(strkind) :: stream_filename - integer :: i, ierr, stream_format - !> Whether a variable is present on the file (i.e., `pio_file`). - logical, allocatable :: var_is_present(:) - !> Whether a variable is type, kind, and rank compatible with what MPAS expects on the file (i.e., `pio_file`). - logical, allocatable :: var_is_tkr_compatible(:) - type(field0dchar), pointer :: field_0d_char - type(field1dchar), pointer :: field_1d_char - type(field0dinteger), pointer :: field_0d_integer - type(field1dinteger), pointer :: field_1d_integer - type(field2dinteger), pointer :: field_2d_integer - type(field3dinteger), pointer :: field_3d_integer - type(field0dreal), pointer :: field_0d_real - type(field1dreal), pointer :: field_1d_real - type(field2dreal), pointer :: field_2d_real - type(field3dreal), pointer :: field_3d_real - type(field4dreal), pointer :: field_4d_real - type(field5dreal), pointer :: field_5d_real - type(var_info_type), allocatable :: var_info_list(:) - - call mpas_log_write(subname // ' entered') - - nullify(field_0d_char) - nullify(field_1d_char) - nullify(field_0d_integer) - nullify(field_1d_integer) - nullify(field_2d_integer) - nullify(field_3d_integer) - nullify(field_0d_real) - nullify(field_1d_real) - nullify(field_2d_real) - nullify(field_3d_real) - nullify(field_4d_real) - nullify(field_5d_real) - - call mpas_pool_create_pool(mpas_pool) - - allocate(mpas_stream, stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate stream "' // trim(adjustl(stream_name)) // '"') - end if - - ! Not actually used because a PIO file descriptor is directly supplied. - stream_filename = 'external stream' - stream_format = mpas_io_pnetcdf - - call mpas_log_write('Checking PIO file descriptor') - - if (.not. associated(pio_file)) then - call mpp_error(FATAL,subname//'Invalid PIO file descriptor') - end if - - if (.not. pio_file_is_open(pio_file)) then - call mpp_error(FATAL,subname//'Invalid PIO file descriptor') - end if - - select case (trim(adjustl(stream_mode))) - case ('r', 'read') - call mpas_log_write('Creating stream "' // trim(adjustl(stream_name)) // '" for reading') - - call mpas_createstream( & - mpas_stream, domain_ptr % iocontext, stream_filename, stream_format, mpas_io_read, & - clobberrecords=.false., clobberfiles=.false., truncatefiles=.false., & - precision=mpas_io_native_precision, pio_file_desc=pio_file, ierr=ierr) - case ('w', 'write') - call mpas_log_write('Creating stream "' // trim(adjustl(stream_name)) // '" for writing') - - call mpas_createstream( & - mpas_stream, domain_ptr % iocontext, stream_filename, stream_format, mpas_io_write, & - clobberrecords=.false., clobberfiles=.false., truncatefiles=.false., & - precision=mpas_io_native_precision, pio_file_desc=pio_file, ierr=ierr) - case default - call mpp_error(FATAL,subname//'Unsupported stream mode "' // trim(adjustl(stream_mode)) // '"') - end select - - if (ierr /= mpas_stream_noerr) then - call mpp_error(FATAL,subname//'Failed to create stream "' // trim(adjustl(stream_name)) // '"') - end if - - var_info_list = parse_stream_name(stream_name) - - ! Add variables contained in `var_info_list` to stream. - do i = 1, size(var_info_list) - call mpas_log_write('var_info_list(' // stringify([i]) // ') % name = ' // stringify([var_info_list(i) % name])) - call mpas_log_write('var_info_list(' // stringify([i]) // ') % type = ' // stringify([var_info_list(i) % type])) - call mpas_log_write('var_info_list(' // stringify([i]) // ') % rank = ' // stringify([var_info_list(i) % rank])) - - if (trim(adjustl(stream_mode)) == 'r' .or. trim(adjustl(stream_mode)) == 'read') then - call dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, pio_file, var_info_list(i)) - - ! Do not hard crash the model if a variable is missing and cannot be read. - ! This can happen if users attempt to initialize/restart the model with data generated by - ! older versions of MPAS. Print a debug message to let users decide if this is acceptable. - if (.not. any(var_is_present)) then - call mpas_log_write('Skipping variable "' // trim(adjustl(var_info_list(i) % name)) // '" due to not present') - - cycle - end if - - if (any(var_is_present .and. .not. var_is_tkr_compatible)) then - call mpas_log_write('Skipping variable "' // trim(adjustl(var_info_list(i) % name)) // '" due to not TKR compatible') - - !cycle - end if - end if - - ! Add "" to pool with the value of `1`. - ! The existence of "" in pool causes it to be considered for IO in MPAS. - call mpas_pool_add_config(mpas_pool, trim(adjustl(var_info_list(i) % name)), 1) - ! Add ":packages" to pool with the value of an empty character string. - ! This causes "" to be always considered active for IO in MPAS. - !call mpas_pool_add_config(mpas_pool, trim(adjustl(var_info_list(i) % name) // ':packages'), '') - - ! Add "" to stream. - call mpas_log_write('Adding variable "' // trim(adjustl(var_info_list(i) % name)) // & - '" to stream "' // trim(adjustl(stream_name)) // '"') - - select case (trim(adjustl(var_info_list(i) % type))) - case ('character') - select case (var_info_list(i) % rank) - case (0) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info_list(i) % name)), field_0d_char, timelevel=1) - - if (.not. associated(field_0d_char)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') - end if - - call mpas_streamaddfield(mpas_stream, field_0d_char, ierr=ierr) - - nullify(field_0d_char) - case (1) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info_list(i) % name)), field_1d_char, timelevel=1) - - if (.not. associated(field_1d_char)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') - end if - - call mpas_streamaddfield(mpas_stream, field_1d_char, ierr=ierr) - - nullify(field_1d_char) - case default - call mpp_error(FATAL,subname//'Unsupported variable rank ' // stringify([var_info_list(i) % rank]) // & - ' for "' // trim(adjustl(var_info_list(i) % name)) // '"') - end select - case ('integer') - select case (var_info_list(i) % rank) - case (0) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info_list(i) % name)), field_0d_integer, timelevel=1) - - if (.not. associated(field_0d_integer)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') - end if - - call mpas_streamaddfield(mpas_stream, field_0d_integer, ierr=ierr) - - nullify(field_0d_integer) - case (1) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info_list(i) % name)), field_1d_integer, timelevel=1) - - if (.not. associated(field_1d_integer)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') - end if - - call mpas_streamaddfield(mpas_stream, field_1d_integer, ierr=ierr) - - nullify(field_1d_integer) - case (2) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info_list(i) % name)), field_2d_integer, timelevel=1) - - if (.not. associated(field_2d_integer)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') - end if - - call mpas_streamaddfield(mpas_stream, field_2d_integer, ierr=ierr) - - nullify(field_2d_integer) - case (3) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info_list(i) % name)), field_3d_integer, timelevel=1) - - if (.not. associated(field_3d_integer)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') - end if - - call mpas_streamaddfield(mpas_stream, field_3d_integer, ierr=ierr) - - nullify(field_3d_integer) - case default - call mpp_error(FATAL,subname//'Unsupported variable rank ' // stringify([var_info_list(i) % rank]) // & - ' for "' // trim(adjustl(var_info_list(i) % name)) // '"') - end select - case ('real') - select case (var_info_list(i) % rank) - case (0) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info_list(i) % name)), field_0d_real, timelevel=1) - - if (.not. associated(field_0d_real)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') - end if - - call mpas_streamaddfield(mpas_stream, field_0d_real, ierr=ierr) - - nullify(field_0d_real) - case (1) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info_list(i) % name)), field_1d_real, timelevel=1) - - if (.not. associated(field_1d_real)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') - end if - - call mpas_streamaddfield(mpas_stream, field_1d_real, ierr=ierr) - - nullify(field_1d_real) - case (2) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info_list(i) % name)), field_2d_real, timelevel=1) - - if (.not. associated(field_2d_real)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') - end if - - call mpas_streamaddfield(mpas_stream, field_2d_real, ierr=ierr) - - nullify(field_2d_real) - case (3) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info_list(i) % name)), field_3d_real, timelevel=1) - - if (.not. associated(field_3d_real)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') - end if - - call mpas_streamaddfield(mpas_stream, field_3d_real, ierr=ierr) - - nullify(field_3d_real) - case (4) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info_list(i) % name)), field_4d_real, timelevel=1) - - if (.not. associated(field_4d_real)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') - end if - - call mpas_streamaddfield(mpas_stream, field_4d_real, ierr=ierr) - - nullify(field_4d_real) - case (5) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info_list(i) % name)), field_5d_real, timelevel=1) - - if (.not. associated(field_5d_real)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info_list(i) % name)) // '"') - end if - - call mpas_streamaddfield(mpas_stream, field_5d_real, ierr=ierr) - - nullify(field_5d_real) - case default - call mpp_error(FATAL,subname//'Unsupported variable rank ' // stringify([var_info_list(i) % rank]) // & - ' for "' // trim(adjustl(var_info_list(i) % name)) // '"') - end select - case default - call mpp_error(FATAL,subname//'Unsupported variable type "' // trim(adjustl(var_info_list(i) % type)) // & - '" for "' // trim(adjustl(var_info_list(i) % name)) // '"') - end select - - if (ierr /= mpas_stream_noerr) then - call mpp_error(FATAL,subname//'Failed to add variable "' // trim(adjustl(var_info_list(i) % name)) // & - '" to stream "' // trim(adjustl(stream_name)) // '"') - end if - end do - - if (trim(adjustl(stream_mode)) == 'w' .or. trim(adjustl(stream_mode)) == 'write') then - ! Add MPAS-specific attributes to stream. - - ! Attributes related to MPAS core (i.e., `core_type`). - call add_stream_attribute('conventions', domain_ptr % core % conventions) - call add_stream_attribute('core_name', domain_ptr % core % corename) - call add_stream_attribute('git_version', domain_ptr % core % git_version) - call add_stream_attribute('model_name', domain_ptr % core % modelname) - call add_stream_attribute('source', domain_ptr % core % source) - - ! Attributes related to MPAS domain (i.e., `domain_type`). - call add_stream_attribute('is_periodic', domain_ptr % is_periodic) - call add_stream_attribute('mesh_spec', domain_ptr % mesh_spec) - call add_stream_attribute('on_a_sphere', domain_ptr % on_a_sphere) - call add_stream_attribute('parent_id', domain_ptr % parent_id) - call add_stream_attribute('sphere_radius', domain_ptr % sphere_radius) - call add_stream_attribute('x_period', domain_ptr % x_period) - call add_stream_attribute('y_period', domain_ptr % y_period) - end if - - call mpas_log_write(subname // ' completed') - contains - !> Helper subroutine for adding a 0-d stream attribute by calling `mpas_writestreamatt` with error checking. - !> (KCW, 2024-03-14) - subroutine add_stream_attribute_0d(attribute_name, attribute_value) - ! Module(s) from MPAS. - use mpas_io_streams, only : mpas_writestreamatt - use mpas_log, only : mpas_log_write - character(*), intent(in) :: attribute_name - class(*), intent(in) :: attribute_value - - call mpas_log_write('Adding attribute "' // trim(adjustl(attribute_name)) // & - '" to stream "' // trim(adjustl(stream_name)) // '"') - - select type (attribute_value) - type is (character(*)) - call mpas_writestreamatt(mpas_stream, & - trim(adjustl(attribute_name)), trim(adjustl(attribute_value)), syncval=.false., ierr=ierr) - type is (integer) - call mpas_writestreamatt(mpas_stream, & - trim(adjustl(attribute_name)), attribute_value, syncval=.false., ierr=ierr) - type is (logical) - if (attribute_value) then - ! Logical `.true.` becomes character string "YES". - call mpas_writestreamatt(mpas_stream, & - trim(adjustl(attribute_name)), 'YES', syncval=.false., ierr=ierr) - else - ! Logical `.false.` becomes character string "NO". - call mpas_writestreamatt(mpas_stream, & - trim(adjustl(attribute_name)), 'NO', syncval=.false., ierr=ierr) - end if - type is (real(rkind)) - call mpas_writestreamatt(mpas_stream, & - trim(adjustl(attribute_name)), attribute_value, syncval=.false., ierr=ierr) - class default - call mpp_error(FATAL,subname//'Unsupported attribute type (Must be one of: character, integer, logical, real)') - end select - - if (ierr /= mpas_stream_noerr) then - call mpp_error(FATAL,subname//'Failed to add attribute "' // trim(adjustl(attribute_name)) // & - '" to stream "' // trim(adjustl(stream_name)) // '"') - end if - end subroutine add_stream_attribute_0d - - !> Helper subroutine for adding a 1-d stream attribute by calling `mpas_writestreamatt` with error checking. - !> (KCW, 2024-03-14) - subroutine add_stream_attribute_1d(attribute_name, attribute_value) - ! Module(s) from MPAS. - use mpas_io_streams, only : mpas_writestreamatt - use mpas_log, only : mpas_log_write - character(*), intent(in) :: attribute_name - class(*), intent(in) :: attribute_value(:) - - call mpas_log_write('Adding attribute "' // trim(adjustl(attribute_name)) // & - '" to stream "' // trim(adjustl(stream_name)) // '"') - - select type (attribute_value) - type is (integer) - call mpas_writestreamatt(mpas_stream, & - trim(adjustl(attribute_name)), attribute_value, syncval=.false., ierr=ierr) - type is (real(rkind)) - call mpas_writestreamatt(mpas_stream, & - trim(adjustl(attribute_name)), attribute_value, syncval=.false., ierr=ierr) - class default - call mpp_error(FATAL,subname//'Unsupported attribute type (Must be one of: integer, real)') - end select - - if (ierr /= mpas_stream_noerr) then - call mpp_error(FATAL,subname//'Failed to add attribute "' // trim(adjustl(attribute_name)) // & - '" to stream "' // trim(adjustl(stream_name)) // '"') - end if - end subroutine add_stream_attribute_1d - end subroutine dyn_mpas_init_stream_with_pool - - !> Parse a stream name, which consists of one or more stream name fragments, and return the corresponding variable information - !> as a list of `var_info_type`. Multiple stream name fragments should be separated by "+" (i.e., a plus, meaning "addition" - !> operation) or "-" (i.e., a minus, meaning "subtraction" operation). - !> A stream name fragment can be a predefined stream name (e.g., "invariant", "input", etc.) or a single variable name. - !> For example, a stream name of "invariant+input+restart" means the union of variables in the "invariant", "input", and - !> "restart" streams. - !> Duplicate variable information in the resulting list is discarded. - !> (KCW, 2024-06-01) - pure function parse_stream_name(stream_name) result(var_info_list) - character(*), intent(in) :: stream_name - type(var_info_type), allocatable :: var_info_list(:) - - character(*), parameter :: supported_stream_name_operator = '+-' - character(1) :: stream_name_operator - character(:), allocatable :: stream_name_fragment - character(len(invariant_var_info_list % name)), allocatable :: var_name_list(:) - integer :: i, j, n, offset - type(var_info_type), allocatable :: var_info_list_buffer(:) - - n = len_trim(stream_name) - - if (n == 0) then - ! Empty character string means empty list. - var_info_list = parse_stream_name_fragment('') - - return - end if - - i = scan(stream_name, supported_stream_name_operator) - - if (i == 0) then - ! No operators are present in the stream name. It is just a single stream name fragment. - stream_name_fragment = stream_name - var_info_list = parse_stream_name_fragment(stream_name_fragment) - - return - end if - - offset = 0 - var_info_list = parse_stream_name_fragment('') - - do while (.true.) - ! Extract operator from the stream name. - if (offset > 0) then - stream_name_operator = stream_name(offset:offset) - else - stream_name_operator = '+' - end if - - ! Extract stream name fragment from the stream name. - if (i > 1) then - stream_name_fragment = stream_name(offset + 1:offset + i - 1) - else - stream_name_fragment = '' - end if - - ! Process the stream name fragment according to the operator. - if (len_trim(stream_name_fragment) > 0) then - var_info_list_buffer = parse_stream_name_fragment(stream_name_fragment) - - select case (stream_name_operator) - case ('+') - var_info_list = [var_info_list, var_info_list_buffer] - case ('-') - do j = 1, size(var_info_list_buffer) - var_name_list = var_info_list % name - var_info_list = pack(var_info_list, var_name_list /= var_info_list_buffer(j) % name) - end do - case default - ! Do nothing for unknown operators. Should not happen at all. - end select - end if - - offset = offset + i - - ! Terminate loop when everything in the stream name has been processed. - if (offset + 1 > n) then - exit - end if - - i = scan(stream_name(offset + 1:), supported_stream_name_operator) - - ! Run the loop one last time for the remaining stream name fragment. - if (i == 0) then - i = n - offset + 1 - end if - end do - - ! Discard duplicate variable information by names. - var_name_list = var_info_list % name - var_info_list = var_info_list(index_unique(var_name_list)) - end function parse_stream_name - - !> Parse a stream name fragment and return the corresponding variable information as a list of `var_info_type`. - !> A stream name fragment can be a predefined stream name (e.g., "invariant", "input", etc.) or a single variable name. - !> (KCW, 2024-06-01) - pure function parse_stream_name_fragment(stream_name_fragment) result(var_info_list) - character(*), intent(in) :: stream_name_fragment - type(var_info_type), allocatable :: var_info_list(:) - - character(len(invariant_var_info_list % name)), allocatable :: var_name_list(:) - type(var_info_type), allocatable :: var_info_list_buffer(:) - - select case (trim(adjustl(stream_name_fragment))) - case ('') - allocate(var_info_list(0)) - case ('invariant') - allocate(var_info_list, source=invariant_var_info_list) - case ('input') - allocate(var_info_list, source=input_var_info_list) - case ('restart') - allocate(var_info_list, source=restart_var_info_list) - case ('output') - allocate(var_info_list, source=output_var_info_list) - case default - allocate(var_info_list(0)) - - var_name_list = invariant_var_info_list % name - - if (any(var_name_list == trim(adjustl(stream_name_fragment)))) then - var_info_list_buffer = pack(invariant_var_info_list, var_name_list == trim(adjustl(stream_name_fragment))) - var_info_list = [var_info_list, var_info_list_buffer] - end if - - var_name_list = input_var_info_list % name - - if (any(var_name_list == trim(adjustl(stream_name_fragment)))) then - var_info_list_buffer = pack(input_var_info_list, var_name_list == trim(adjustl(stream_name_fragment))) - var_info_list = [var_info_list, var_info_list_buffer] - end if - - var_name_list = restart_var_info_list % name - - if (any(var_name_list == trim(adjustl(stream_name_fragment)))) then - var_info_list_buffer = pack(restart_var_info_list, var_name_list == trim(adjustl(stream_name_fragment))) - var_info_list = [var_info_list, var_info_list_buffer] - end if - - var_name_list = output_var_info_list % name - - if (any(var_name_list == trim(adjustl(stream_name_fragment)))) then - var_info_list_buffer = pack(output_var_info_list, var_name_list == trim(adjustl(stream_name_fragment))) - var_info_list = [var_info_list, var_info_list_buffer] - end if - end select - end function parse_stream_name_fragment - - !> Return the index of unique elements in `array`, which can be any intrinsic data types, as an integer array. - !> If `array` contains zero element or is of unsupported data types, an empty integer array is produced. - !> For example, `index_unique([1, 2, 3, 1, 2, 3, 4, 5])` returns `[1, 2, 3, 7, 8]`. - !> (KCW, 2024-03-22) - pure function index_unique(array) - use, intrinsic :: iso_fortran_env, only: int32, int64, real32, real64 - - class(*), intent(in) :: array(:) - integer, allocatable :: index_unique(:) - - character(:), allocatable :: array_c(:) - integer :: i, n - logical :: mask_unique(size(array)) - - n = size(array) - - if (n == 0) then - allocate(index_unique(0)) - - return - end if - - mask_unique = .false. - - select type (array) - type is (character(*)) - ! Workaround for a bug in GNU Fortran >= 12. This is perhaps the manifestation of GCC Bugzilla Bug 100819. - ! When a character string array is passed as the actual argument to an unlimited polymorphic dummy argument, - ! its array index and length parameter are mishandled. - allocate(character(len(array)) :: array_c(size(array))) - - array_c(:) = array(:) - - do i = 1, n - if (.not. any(array_c(i) == array_c .and. mask_unique)) then - mask_unique(i) = .true. - end if - end do - - deallocate(array_c) - type is (integer(int32)) - do i = 1, n - if (.not. any(array(i) == array .and. mask_unique)) then - mask_unique(i) = .true. - end if - end do - type is (integer(int64)) - do i = 1, n - if (.not. any(array(i) == array .and. mask_unique)) then - mask_unique(i) = .true. - end if - end do - type is (logical) - do i = 1, n - if (.not. any((array(i) .eqv. array) .and. mask_unique)) then - mask_unique(i) = .true. - end if - end do - type is (real(real32)) - do i = 1, n - if (.not. any(array(i) == array .and. mask_unique)) then - mask_unique(i) = .true. - end if - end do - type is (real(real64)) - do i = 1, n - if (.not. any(array(i) == array .and. mask_unique)) then - mask_unique(i) = .true. - end if - end do - class default - allocate(index_unique(0)) - - return - end select - - index_unique = pack([(i, i = 1, n)], mask_unique) - end function index_unique - - !> ######################################################################################## - ! subroutine dyn_mpas_check_variable_status - ! - !> summary: Check and return variable status on the given file. - !> author: Kuan-Chih Wang - !> date: 2024-06-04 - !> - !> On the given file (i.e., `pio_file`), this subroutine checks whether the - !> given variable (i.e., `var_info`) is present, and whether it is "TKR" - !> compatible with what MPAS expects. "TKR" means type, kind, and rank. - !> This subroutine can handle both ordinary variables and variable arrays. - !> They are indicated by the `var` and `var_array` elements, respectively, - !> in MPAS registry. For an ordinary variable, the checks are performed on - !> itself. Otherwise, for a variable array, the checks are performed on its - !> constituent parts instead. - ! - !> ######################################################################################## - subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, pio_file,& - var_info) - ! Module(s) from external libraries. - use pio, only: file_desc_t, pio_file_is_open, pio_char, pio_int, pio_real, pio_double, & - pio_inq_varid, pio_inq_varndims, pio_inq_vartype, pio_noerr - ! Module(s) from MPAS. - use mpas_derived_types, only : field0dchar, field1dchar, field0dinteger, field1dinteger,& - field2dinteger, field3dinteger, field0dreal, field1dreal,& - field2dreal, field3dreal, field4dreal, field5dreal - use mpas_kind_types, only : r4kind, r8kind - use mpas_pool_routines, only : mpas_pool_get_field - use mpas_log, only : mpas_log_write - use mpas_kind_types, only : StrKIND, RKIND - use mpp_mod, only : FATAL, mpp_error - - logical, allocatable, intent(out) :: var_is_present(:) - logical, allocatable, intent(out) :: var_is_tkr_compatible(:) - type(file_desc_t), pointer, intent(in) :: pio_file - type(var_info_type), intent(in) :: var_info - - character(*), parameter :: subname = 'dyn_mpas_subdriver::dyn_mpas_check_variable_status' - character(strkind), allocatable :: var_name_list(:) - integer :: i, ierr, varid, varndims, vartype - type(field0dchar), pointer :: field_0d_char - type(field1dchar), pointer :: field_1d_char - type(field0dinteger), pointer :: field_0d_integer - type(field1dinteger), pointer :: field_1d_integer - type(field2dinteger), pointer :: field_2d_integer - type(field3dinteger), pointer :: field_3d_integer - type(field0dreal), pointer :: field_0d_real - type(field1dreal), pointer :: field_1d_real - type(field2dreal), pointer :: field_2d_real - type(field3dreal), pointer :: field_3d_real - type(field4dreal), pointer :: field_4d_real - type(field5dreal), pointer :: field_5d_real - - call mpas_log_write(subname // ' entered') - - nullify(field_0d_char) - nullify(field_1d_char) - nullify(field_0d_integer) - nullify(field_1d_integer) - nullify(field_2d_integer) - nullify(field_3d_integer) - nullify(field_0d_real) - nullify(field_1d_real) - nullify(field_2d_real) - nullify(field_3d_real) - nullify(field_4d_real) - nullify(field_5d_real) - - ! Extract a list of variable names to check on the file. - ! For an ordinary variable, this list just contains its name. - ! For a variable array, this list contains the names of its constituent parts. - select case (trim(adjustl(var_info % type))) - case ('character') - select case (var_info % rank) - case (0) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info % name)), field_0d_char, timelevel=1) - - if (.not. associated(field_0d_char)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name))) - end if - - if (field_0d_char % isvararray .and. associated(field_0d_char % constituentnames)) then - allocate(var_name_list(size(field_0d_char % constituentnames)), stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate var_name_list') - end if - - var_name_list(:) = field_0d_char % constituentnames(:) - end if - - nullify(field_0d_char) - case (1) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info % name)), field_1d_char, timelevel=1) - - if (.not. associated(field_1d_char)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name))) - end if - - if (field_1d_char % isvararray .and. associated(field_1d_char % constituentnames)) then - allocate(var_name_list(size(field_1d_char % constituentnames)), stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate var_name_list') - end if - - var_name_list(:) = field_1d_char % constituentnames(:) - end if - - nullify(field_1d_char) - case default - call mpp_error(FATAL,subname//'Unsupported variable rank ' // stringify([var_info % rank]) // & - ' for "' // trim(adjustl(var_info % name)) // '"') - end select - case ('integer') - select case (var_info % rank) - case (0) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info % name)), field_0d_integer, timelevel=1) - - if (.not. associated(field_0d_integer)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') - end if - - if (field_0d_integer % isvararray .and. associated(field_0d_integer % constituentnames)) then - allocate(var_name_list(size(field_0d_integer % constituentnames)), stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate var_name_list') - end if - - var_name_list(:) = field_0d_integer % constituentnames(:) - end if - - nullify(field_0d_integer) - case (1) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info % name)), field_1d_integer, timelevel=1) - - if (.not. associated(field_1d_integer)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') - end if - - if (field_1d_integer % isvararray .and. associated(field_1d_integer % constituentnames)) then - allocate(var_name_list(size(field_1d_integer % constituentnames)), stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate var_name_list') - end if - - var_name_list(:) = field_1d_integer % constituentnames(:) - end if - - nullify(field_1d_integer) - case (2) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info % name)), field_2d_integer, timelevel=1) - - if (.not. associated(field_2d_integer)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') - end if - - if (field_2d_integer % isvararray .and. associated(field_2d_integer % constituentnames)) then - allocate(var_name_list(size(field_2d_integer % constituentnames)), stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate var_name_list') - end if - - var_name_list(:) = field_2d_integer % constituentnames(:) - end if - - nullify(field_2d_integer) - case (3) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info % name)), field_3d_integer, timelevel=1) - - if (.not. associated(field_3d_integer)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') - end if - - if (field_3d_integer % isvararray .and. associated(field_3d_integer % constituentnames)) then - allocate(var_name_list(size(field_3d_integer % constituentnames)), stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate var_name_list') - end if - - var_name_list(:) = field_3d_integer % constituentnames(:) - end if - - nullify(field_3d_integer) - case default - call mpp_error(FATAL,subname//'Unsupported variable rank ' // stringify([var_info % rank]) // & - ' for "' // trim(adjustl(var_info % name)) // '"') - end select - case ('real') - select case (var_info % rank) - case (0) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info % name)), field_0d_real, timelevel=1) - - if (.not. associated(field_0d_real)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') - end if - - if (field_0d_real % isvararray .and. associated(field_0d_real % constituentnames)) then - allocate(var_name_list(size(field_0d_real % constituentnames)), stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate var_name_list') - end if - - var_name_list(:) = field_0d_real % constituentnames(:) - end if - - nullify(field_0d_real) - case (1) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info % name)), field_1d_real, timelevel=1) - - if (.not. associated(field_1d_real)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') - end if - - if (field_1d_real % isvararray .and. associated(field_1d_real % constituentnames)) then - allocate(var_name_list(size(field_1d_real % constituentnames)), stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate var_name_list') - end if - - var_name_list(:) = field_1d_real % constituentnames(:) - end if - - nullify(field_1d_real) - case (2) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info % name)), field_2d_real, timelevel=1) - - if (.not. associated(field_2d_real)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') - end if - - if (field_2d_real % isvararray .and. associated(field_2d_real % constituentnames)) then - allocate(var_name_list(size(field_2d_real % constituentnames)), stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate var_name_list') - end if - - var_name_list(:) = field_2d_real % constituentnames(:) - end if - - nullify(field_2d_real) - case (3) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info % name)), field_3d_real, timelevel=1) - - if (.not. associated(field_3d_real)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') - end if - - if (field_3d_real % isvararray .and. associated(field_3d_real % constituentnames)) then - allocate(var_name_list(size(field_3d_real % constituentnames)), stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate var_name_list') - end if - - var_name_list(:) = field_3d_real % constituentnames(:) - end if - - nullify(field_3d_real) - case (4) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info % name)), field_4d_real, timelevel=1) - - if (.not. associated(field_4d_real)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') - end if - - if (field_4d_real % isvararray .and. associated(field_4d_real % constituentnames)) then - allocate(var_name_list(size(field_4d_real % constituentnames)), stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate var_name_list') - end if - - var_name_list(:) = field_4d_real % constituentnames(:) - end if - - nullify(field_4d_real) - case (5) - call mpas_pool_get_field(domain_ptr % blocklist % allfields, & - trim(adjustl(var_info % name)), field_5d_real, timelevel=1) - - if (.not. associated(field_5d_real)) then - call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') - end if - - if (field_5d_real % isvararray .and. associated(field_5d_real % constituentnames)) then - allocate(var_name_list(size(field_5d_real % constituentnames)), stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate var_name_list') - end if - - var_name_list(:) = field_5d_real % constituentnames(:) - end if - - nullify(field_5d_real) - case default - call mpp_error(FATAL,subname//'Unsupported variable rank ' // stringify([var_info % rank]) // & - ' for "' // trim(adjustl(var_info % name)) // '"') - end select - case default - call mpp_error(FATAL,subname//'Unsupported variable type "' // trim(adjustl(var_info % type)) // & - '" for "' // trim(adjustl(var_info % name)) // '"') - end select - - if (.not. allocated(var_name_list)) then - allocate(var_name_list(1), stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate var_name_list') - end if - - var_name_list(1) = var_info % name - end if - - allocate(var_is_present(size(var_name_list)), stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate var_is_present') - end if - - var_is_present(:) = .false. - - allocate(var_is_tkr_compatible(size(var_name_list)), stat=ierr) - - if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to allocate var_is_tkr_compatible') - end if - - var_is_tkr_compatible(:) = .false. - - if (.not. associated(pio_file)) then - return - end if - - if (.not. pio_file_is_open(pio_file)) then - return - end if - - call mpas_log_write('Checking variable "' // trim(adjustl(var_info % name)) // & - '" for presence and TKR compatibility') - - do i = 1, size(var_name_list) - ! Check if the variable is present on the file. - ierr = pio_inq_varid(pio_file, trim(adjustl(var_name_list(i))), varid) - - if (ierr /= pio_noerr) then - cycle - end if - - var_is_present(i) = .true. - - ! Check if the variable is "TK"R compatible between MPAS and the file. - ierr = pio_inq_vartype(pio_file, varid, vartype) - - if (ierr /= pio_noerr) then - cycle - end if - - select case (trim(adjustl(var_info % type))) - case ('character') - if (vartype /= pio_char) then - cycle - end if - case ('integer') - if (vartype /= pio_int) then - cycle - end if - case ('real') - ! When MPAS dynamical core is compiled at single precision, pairing it with double precision input data - ! is not allowed to prevent loss of precision. - if (rkind == r4kind .and. vartype /= pio_real) then - cycle - end if - - ! When MPAS dynamical core is compiled at double precision, pairing it with single and double precision - ! input data is allowed. - if (rkind == r8kind .and. vartype /= pio_real .and. vartype /= pio_double) then - cycle - end if - case default - cycle - end select - - ! Check if the variable is TK"R" compatible between MPAS and the file. - ierr = pio_inq_varndims(pio_file, varid, varndims) - - if (ierr /= pio_noerr) then - cycle - end if - - if (varndims /= var_info % rank) then - cycle - end if - - var_is_tkr_compatible(i) = .true. - end do - - call mpas_log_write('var_name_list = ' // stringify(var_name_list)) - call mpas_log_write('var_is_present = ' // stringify(var_is_present)) - call mpas_log_write('var_is_tkr_compatible = ' // stringify(var_is_tkr_compatible)) - - call mpas_log_write(subname // ' completed') - end subroutine dyn_mpas_check_variable_status - - !> ######################################################################################## - !> - !> \brief Computes local unit north, east, and edge-normal vectors - !> \author Michael Duda - !> \date 15 January 2020 - !> \details - !> This routine computes the local unit north and east vectors at all cell - !> centers, storing the resulting fields in the mesh pool as 'north' and - !> 'east'. It also computes the edge-normal unit vectors by calling - !> the mpas_initialize_vectors routine. Before this routine is called, - !> the mesh pool must contain 'latCell' and 'lonCell' fields that are valid - !> for all cells (not just solve cells), plus any fields that are required - !> by the mpas_initialize_vectors routine. - !> - !> \update: Dustin Swales April 2025 - Modified for use in UWM - !> - !> ######################################################################################## - subroutine ufs_mpas_compute_unit_vectors() - use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_dimension, mpas_pool_get_array - use mpas_derived_types, only : mpas_pool_type - use mpas_kind_types, only : RKIND - use mpas_vector_operations, only : mpas_initialize_vectors - - type (mpas_pool_type), pointer :: meshPool - real(kind=RKIND), dimension(:), pointer :: latCell, lonCell - real(kind=RKIND), dimension(:,:), pointer :: east, north - integer, pointer :: nCells - integer :: iCell - - call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', meshPool) - call mpas_pool_get_dimension(meshPool, 'nCells', nCells) - call mpas_pool_get_array(meshPool, 'latCell', latCell) - call mpas_pool_get_array(meshPool, 'lonCell', lonCell) - call mpas_pool_get_array(meshPool, 'east', east) - call mpas_pool_get_array(meshPool, 'north', north) - - do iCell = 1, nCells - east(1,iCell) = -sin(lonCell(iCell)) - east(2,iCell) = cos(lonCell(iCell)) - east(3,iCell) = 0.0_RKIND - - ! Normalize - east(1:3,iCell) = east(1:3,iCell) / sqrt(sum(east(1:3,iCell) * east(1:3,iCell))) - - north(1,iCell) = -cos(lonCell(iCell))*sin(latCell(iCell)) - north(2,iCell) = -sin(lonCell(iCell))*sin(latCell(iCell)) - north(3,iCell) = cos(latCell(iCell)) - - ! Normalize - north(1:3,iCell) = north(1:3,iCell) / sqrt(sum(north(1:3,iCell) * north(1:3,iCell))) - - end do - - call mpas_initialize_vectors(meshPool) - - end subroutine ufs_mpas_compute_unit_vectors - - !> ######################################################################################## - !> - !> \brief Define the names of constituents at run-time - !> \author Michael Duda - !> \date 21 May 2020 - !> \details - !> Given an array of constituent names, which must have size equal to the number - !> of scalars that were set in the call to ufs_mpas_init_phase1, and given - !> a function to identify which scalars are moisture species, this routine defines - !> scalar constituents for the MPAS-A dycore. - !> Because the MPAS-A dycore expects all moisture constituents to appear in - !> a contiguous range of constituent indices, this routine may in general need - !> to reorder the constituents; to allow for mapping of indices between UFS - !> physics and the MPAS-A dycore, this routine returns index mapping arrays - !> mpas_from_ufs_cnst and ufs_from_mpas_cnst. - !> - !> \update: Dustin Swales April 2025 - Modified for use in UWM - !> - !> ######################################################################################## - subroutine ufs_mpas_define_scalars(mpas_from_ufs_cnst, ufs_from_mpas_cnst, ierr) - use mpas_derived_types, only : mpas_pool_type, field3dReal - use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_field, & - mpas_pool_get_dimension, mpas_pool_add_dimension - use mpas_attlist, only : mpas_add_att - use mpas_log, only : mpas_log_write - use mpas_derived_types, only : MPAS_LOG_ERR - ! FMS - use mpp_mod, only : FATAL, mpp_error - - ! Arguments - integer, dimension(:), pointer :: mpas_from_ufs_cnst, ufs_from_mpas_cnst - integer, intent(out) :: ierr - - ! Local variables - character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_define_scalars' - integer :: i, j, timeLevs - integer, pointer :: num_scalars - integer :: num_moist - integer :: idx_passive - type (mpas_pool_type), pointer :: statePool - type (mpas_pool_type), pointer :: tendPool - type (field3dReal), pointer :: scalarsField - character(len=128) :: tempstr - character :: moisture_char - - ierr = 0 - - ! - ! Define scalars - ! - nullify(statePool) - call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', statePool) - - if (.not. associated(statePool)) then - call mpas_log_write(trim(subname)//': ERROR: The ''state'' pool was not found.', & - messageType=MPAS_LOG_ERR) - ierr = 1 - return - end if - - nullify(num_scalars) - call mpas_pool_get_dimension(statePool, 'num_scalars', num_scalars) - - ! - ! The num_scalars dimension should have been defined by atm_core_interface::atm_allocate_scalars, and - ! if this dimension does not exist, something has gone wrong - ! - if (.not. associated(num_scalars)) then - call mpas_log_write(trim(subname)//': ERROR: The ''num_scalars'' dimension does not exist in the ''state'' pool.', & - messageType=MPAS_LOG_ERR) - ierr = 1 - return - end if - - ! - ! If at runtime there are not num_scalars names in the array of constituent names provided by UFS, - ! something has gone wrong - ! - if (size(constituent_name) /= num_scalars) then - call mpas_log_write(trim(subname)//': ERROR: The number of constituent names is not equal to the num_scalars dimension', & - messageType=MPAS_LOG_ERR) - call mpas_log_write('size(constituent_name) = $i, num_scalars = $i', intArgs=[size(constituent_name), num_scalars], & - messageType=MPAS_LOG_ERR) - ierr = 1 - return - end if - - ! - ! In UFS, the first scalar (if there are any) is always sphum (specific humidity); if this is not - ! the case, something has gone wrong - ! - if (size(constituent_name) > 0) then - if (trim(constituent_name(1)) /= 'sphum') then - call mpas_log_write(trim(subname)//': ERROR: The first constituent is not sphum', messageType=MPAS_LOG_ERR) - ierr = 1 - return - end if - end if - - ! - ! Determine which of the constituents are moisture species - ! - allocate(mpas_from_ufs_cnst(num_scalars), stat=ierr) - if( ierr /= 0 ) call mpp_error(FATAL,subname//':failed to allocate mpas_from_ufs_cnst array') - mpas_from_ufs_cnst(:) = 0 - num_moist = 0 - do i = 1, size(constituent_name) - if (is_water_species(i)) then - num_moist = num_moist + 1 - mpas_from_ufs_cnst(num_moist) = i - end if - end do - - ! - ! If UFS has no scalars, let the only scalar in MPAS be 'qv' (a moisture species) - ! - if (num_scalars == 1 .and. size(constituent_name) == 0) then - num_moist = 1 - end if - - ! - ! Assign non-moisture constituents to mpas_from_ufs_cnst(num_moist+1:size(constituent_name)) - ! - idx_passive = num_moist + 1 - do i = 1, size(constituent_name) - - ! If UFS constituent i is not already mapped as a moist constituent - if (.not. is_water_species(i)) then - mpas_from_ufs_cnst(idx_passive) = i - idx_passive = idx_passive + 1 - end if - end do - - ! - ! Create inverse map, ufs_from_mpas_cnst - ! - allocate(ufs_from_mpas_cnst(num_scalars), stat=ierr) - if( ierr /= 0 ) call mpp_error(FATAL,subname//':failed to allocate ufs_from_mpas_cnst array') - ufs_from_mpas_cnst(:) = 0 - - do i = 1, size(constituent_name) - ufs_from_mpas_cnst(mpas_from_ufs_cnst(i)) = i - end do - - timeLevs = 2 - - do i = 1, timeLevs - nullify(scalarsField) - call mpas_pool_get_field(statePool, 'scalars', scalarsField, timeLevel=i) - - if (.not. associated(scalarsField)) then - call mpas_log_write(trim(subname)//': ERROR: The ''scalars'' field was not found in the ''state'' pool', & - messageType=MPAS_LOG_ERR) - ierr = 1 - return - end if - - if (i == 1) call mpas_pool_add_dimension(statePool, 'index_qv', 1) - scalarsField % constituentNames(1) = 'qv' - call mpas_add_att(scalarsField % attLists(1) % attList, 'units', 'kg kg^{-1}') - call mpas_add_att(scalarsField % attLists(1) % attList, 'long_name', 'Water vapor mixing ratio') - - do j = 2, size(constituent_name) - scalarsField % constituentNames(j) = trim(constituent_name(mpas_from_ufs_cnst(j))) - end do - - end do - - call mpas_pool_add_dimension(statePool, 'moist_start', 1) - call mpas_pool_add_dimension(statePool, 'moist_end', num_moist) - - ! - ! Print a tabular summary of the mapping between constituent indices - ! - call mpas_log_write('') - call mpas_log_write(' i MPAS constituent mpas_from_ufs_cnst(i) i UFS constituent ufs_from_mpas_cnst(i)') - call mpas_log_write('------------------------------------------ ------------------------------------------') - do i = 1, min(num_scalars, size(constituent_name)) - if (i <= num_moist) then - moisture_char = '*' - else - moisture_char = ' ' - end if - write(tempstr, '(i3,1x,a16,1x,i18,8x,i3,1x,a16,1x,i18)') i, trim(scalarsField % constituentNames(i))//moisture_char, & - mpas_from_ufs_cnst(i), & - i, trim(constituent_name(i)), & - ufs_from_mpas_cnst(i) - call mpas_log_write(trim(tempstr)) - end do - call mpas_log_write('------------------------------------------ ------------------------------------------') - call mpas_log_write('* = constituent used as a moisture species in MPAS-A dycore') - call mpas_log_write('') - - - ! - ! Define scalars_tend - ! - nullify(tendPool) - call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'tend', tendPool) - - if (.not. associated(tendPool)) then - call mpas_log_write(trim(subname)//': ERROR: The ''tend'' pool was not found.', & - messageType=MPAS_LOG_ERR) - ierr = 1 - return - end if - - timeLevs = 1 - - do i = 1, timeLevs - nullify(scalarsField) - call mpas_pool_get_field(tendPool, 'scalars_tend', scalarsField, timeLevel=i) - - if (.not. associated(scalarsField)) then - call mpas_log_write(trim(subname)//': ERROR: The ''scalars_tend'' field was not found in the ''tend'' pool', & - messageType=MPAS_LOG_ERR) - ierr = 1 - return - end if - - if (i == 1) call mpas_pool_add_dimension(tendPool, 'index_qv', 1) - scalarsField % constituentNames(1) = 'tend_qv' - call mpas_add_att(scalarsField % attLists(1) % attList, 'units', 'kg m^{-3} s^{-1}') - call mpas_add_att(scalarsField % attLists(1) % attList, 'long_name', 'Tendency of water vapor mixing ratio') - - do j = 2, size(constituent_name) - scalarsField % constituentNames(j) = 'tend_'//trim(constituent_name(mpas_from_ufs_cnst(j))) - end do - end do - - call mpas_pool_add_dimension(tendPool, 'moist_start', 1) - call mpas_pool_add_dimension(tendPool, 'moist_end', num_moist) - - end subroutine ufs_mpas_define_scalars - - !> ######################################################################################## - !> - !> \brief Returns global mesh dimensions - !> \author Michael Duda - !> \date 22 August 2019 - !> \details - !> This routine returns on all tasks the number of global cells, edges, - !> vertices, maxEdges, vertical layers, and the maximum number of cells owned by any task. - !> - !> \update: Dustin Swales April 2025 - Modified for use in UWM - !> - !> ######################################################################################## - subroutine ufs_mpas_get_global_dims(nCellsGlobal, nEdgesGlobal, nVerticesGlobal, maxEdges,& - nVertLevels, maxNCells) - use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_dimension - use mpas_derived_types, only : mpas_pool_type - use mpas_dmpar, only : mpas_dmpar_sum_int, mpas_dmpar_max_int - - integer, intent(out) :: nCellsGlobal - integer, intent(out) :: nEdgesGlobal - integer, intent(out) :: nVerticesGlobal - integer, intent(out) :: maxEdges - integer, intent(out) :: nVertLevels - integer, intent(out) :: maxNCells - - integer, pointer :: nCellsSolve - integer, pointer :: nEdgesSolve - integer, pointer :: nVerticesSolve - integer, pointer :: maxEdgesLocal - integer, pointer :: nVertLevelsLocal - - type (mpas_pool_type), pointer :: meshPool - - call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', meshPool) - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(meshPool, 'nEdgesSolve', nEdgesSolve) - call mpas_pool_get_dimension(meshPool, 'nVerticesSolve', nVerticesSolve) - call mpas_pool_get_dimension(meshPool, 'maxEdges', maxEdgesLocal) - call mpas_pool_get_dimension(meshPool, 'nVertLevels', nVertLevelsLocal) - - call mpas_dmpar_sum_int(domain_ptr % dminfo, nCellsSolve, nCellsGlobal) - call mpas_dmpar_sum_int(domain_ptr % dminfo, nEdgesSolve, nEdgesGlobal) - call mpas_dmpar_sum_int(domain_ptr % dminfo, nVerticesSolve, nVerticesGlobal) - - maxEdges = maxEdgesLocal - nVertLevels = nVertLevelsLocal - - call mpas_dmpar_max_int(domain_ptr % dminfo, nCellsSolve, maxNCells) - - end subroutine ufs_mpas_get_global_dims - - !> ######################################################################################## - !> - !> \brief Returns global coordinate arrays - !> \author Michael Duda - !> \date 22 August 2019 - !> \details - !> This routine returns on all tasks arrays of latitude, longitude, and cell - !> area for all (global) cells. - !> - !> It is assumed that latCellGlobal, lonCellGlobal, and areaCellGlobal have - !> been allocated by the caller with a size equal to the global number of - !> cells in the mesh. - !> - !> \update: Dustin Swales April 2025 - Modified for use in UWM - !> - !> ######################################################################################## - subroutine ufs_mpas_get_global_coords(latCellGlobal, lonCellGlobal, areaCellGlobal) - use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_dimension, mpas_pool_get_array - use mpas_derived_types, only : mpas_pool_type - use mpas_kind_types, only : RKIND - use mpas_dmpar, only : mpas_dmpar_sum_int, mpas_dmpar_max_real_array - use mpp_mod, only : FATAL, mpp_error - real (kind=RKIND), dimension(:), intent(out) :: latCellGlobal - real (kind=RKIND), dimension(:), intent(out) :: lonCellGlobal - real (kind=RKIND), dimension(:), intent(out) :: areaCellGlobal - - integer :: iCell - - integer, pointer :: nCellsSolve - integer, dimension(:), pointer :: indexToCellID - - type (mpas_pool_type), pointer :: meshPool - integer :: nCellsGlobal,ierr - - real (kind=RKIND), dimension(:), pointer :: latCell - real (kind=RKIND), dimension(:), pointer :: lonCell - real (kind=RKIND), dimension(:), pointer :: areaCell - real (kind=RKIND), dimension(:), pointer :: temp - - character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_get_global_coords' - - - call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', meshPool) - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_array(meshPool, 'indexToCellID', indexToCellID) - call mpas_pool_get_array(meshPool, 'latCell', latCell) - call mpas_pool_get_array(meshPool, 'lonCell', lonCell) - call mpas_pool_get_array(meshPool, 'areaCell', areaCell) - - call mpas_dmpar_sum_int(domain_ptr % dminfo, nCellsSolve, nCellsGlobal) - - ! check: size(latCellGlobal) ?= nCellsGlobal - allocate(temp(nCellsGlobal), stat=ierr) - if( ierr /= 0 ) call mpp_error(FATAL,subname//':failed to allocate temp array') - - ! - ! latCellGlobal - ! - temp(:) = -huge(temp(0)) - do iCell=1,nCellsSolve - temp(indexToCellID(iCell)) = latCell(iCell) - end do - - call mpas_dmpar_max_real_array(domain_ptr % dminfo, nCellsGlobal, temp, latCellGlobal) - - ! - ! lonCellGlobal - ! - temp(:) = -huge(temp(0)) - do iCell=1,nCellsSolve - temp(indexToCellID(iCell)) = lonCell(iCell) - end do - - call mpas_dmpar_max_real_array(domain_ptr % dminfo, nCellsGlobal, temp, lonCellGlobal) - - ! - ! areaCellGlobal - ! - temp(:) = -huge(temp(0)) - do iCell=1,nCellsSolve - temp(indexToCellID(iCell)) = areaCell(iCell) - end do - - call mpas_dmpar_max_real_array(domain_ptr % dminfo, nCellsGlobal, temp, areaCellGlobal) - - deallocate(temp) - - end subroutine ufs_mpas_get_global_coords - - ! ########################################################################################## - ! - ! ########################################################################################## - character(len=10) function date2yyyymmdd (date) - ! Input arguments - integer, intent(in) :: date - - ! Local workspace - integer :: year ! year of yyyy-mm-dd - integer :: month ! month of yyyy-mm-dd - integer :: day ! day of yyyy-mm-dd - - year = date / 10000 - month = (date - year*10000) / 100 - day = date - year*10000 - month*100 - - write(date2yyyymmdd,80) year, month, day -80 format(i4.4,'-',i2.2,'-',i2.2) - - end function date2yyyymmdd - ! ######################################################################################### - ! - ! ######################################################################################### - character(len=8) function sec2hms (seconds) - ! Input arguments - integer, intent(in) :: seconds - - ! Local workspace - integer :: hours ! hours of hh:mm:ss - integer :: minutes ! minutes of hh:mm:ss - integer :: secs ! seconds of hh:mm:ss - - hours = seconds / 3600 - minutes = (seconds - hours*3600) / 60 - secs = (seconds - hours*3600 - minutes*60) - - write(sec2hms,80) hours, minutes, secs -80 format(i2.2,':',i2.2,':',i2.2) - - end function sec2hms - - ! ######################################################################################### - ! - ! ######################################################################################### - character(len=10) function int2str(n) - ! return default integer as a left justified string - ! arguments - integer, intent(in) :: n - - write(int2str,'(i0)') n - - end function int2str - - character(len=10) function log2str(n) - ! return default integer as a left justified string - ! arguments - logical, intent(in) :: n - - if (n) then - write(log2str,'(a4)') 'TRUE' - else - write(log2str,'(a4)') 'FALSE' - endif - - end function log2str - end module ufs_mpas_subdriver diff --git a/mpas/ufs_mpas_tools.F90 b/mpas/ufs_mpas_tools.F90 new file mode 100644 index 000000000..99d6f9149 --- /dev/null +++ b/mpas/ufs_mpas_tools.F90 @@ -0,0 +1,188 @@ +!> ########################################################################################### +!> \file ufs_mpas_tools.F90 +!> +!> +!> ########################################################################################### +module ufs_mpas_tools + implicit none + + public +contains + !> ######################################################################################### + !> Convert one or more values of any intrinsic data types to a character string for pretty + !> printing. + !> + !> If `value` contains more than one element, the elements will be stringified, delimited by + !> `separator`, then concatenated. + !> If `value` contains exactly one element, the element will be stringified without using + !> `separator`. + !> If `value` contains zero element or is of unsupported data types, an empty character + !> string is produced. + !> If `separator` is not supplied, it defaults to ", " (i.e., a comma and a space). + !> (KCW, 2024-02-04) + !> + !> \update: Dustin Swales April 2025 - Modified for use in UWM + !> + !> ######################################################################################### + pure function stringify(value, separator) + use, intrinsic :: iso_fortran_env, only: int32, int64, real32, real64 + + class(*), intent(in) :: value(:) + character(*), optional, intent(in) :: separator + character(:), allocatable :: stringify + + integer, parameter :: sizelimit = 1024 + + character(:), allocatable :: buffer, delimiter, format + character(:), allocatable :: value_c(:) + integer :: i, n, offset + + if (present(separator)) then + delimiter = separator + else + delimiter = ', ' + end if + + n = min(size(value), sizelimit) + + if (n == 0) then + stringify = '' + + return + end if + + select type (value) + type is (character(*)) + allocate(character(len(value) * n + len(delimiter) * (n - 1)) :: buffer) + + buffer(:) = '' + offset = 0 + + ! Workaround for a bug in GNU Fortran >= 12. This is perhaps the manifestation of GCC Bugzilla Bug 100819. + ! When a character string array is passed as the actual argument to an unlimited polymorphic dummy argument, + ! its array index and length parameter are mishandled. + allocate(character(len(value)) :: value_c(size(value))) + + value_c(:) = value(:) + + do i = 1, n + if (len(delimiter) > 0 .and. i > 1) then + buffer(offset + 1:offset + len(delimiter)) = delimiter + offset = offset + len(delimiter) + end if + + if (len_trim(adjustl(value_c(i))) > 0) then + buffer(offset + 1:offset + len_trim(adjustl(value_c(i)))) = trim(adjustl(value_c(i))) + offset = offset + len_trim(adjustl(value_c(i))) + end if + end do + + deallocate(value_c) + type is (integer(int32)) + allocate(character(11 * n + len(delimiter) * (n - 1)) :: buffer) + allocate(character(17 + len(delimiter) + floor(log10(real(n))) + 1) :: format) + + write(format, '(a, i0, 3a)') '(ss, ', n, '(i0, :, "', delimiter, '"))' + write(buffer, format) value + type is (integer(int64)) + allocate(character(20 * n + len(delimiter) * (n - 1)) :: buffer) + allocate(character(17 + len(delimiter) + floor(log10(real(n))) + 1) :: format) + + write(format, '(a, i0, 3a)') '(ss, ', n, '(i0, :, "', delimiter, '"))' + write(buffer, format) value + type is (logical) + allocate(character(1 * n + len(delimiter) * (n - 1)) :: buffer) + allocate(character(13 + len(delimiter) + floor(log10(real(n))) + 1) :: format) + + write(format, '(a, i0, 3a)') '(', n, '(l1, :, "', delimiter, '"))' + write(buffer, format) value + type is (real(real32)) + allocate(character(13 * n + len(delimiter) * (n - 1)) :: buffer) + + if (maxval(abs(value)) < 1.0e5_real32) then + allocate(character(20 + len(delimiter) + floor(log10(real(n))) + 1) :: format) + write(format, '(a, i0, 3a)') '(ss, ', n, '(f13.6, :, "', delimiter, '"))' + else + allocate(character(23 + len(delimiter) + floor(log10(real(n))) + 1) :: format) + write(format, '(a, i0, 3a)') '(ss, ', n, '(es13.6e2, :, "', delimiter, '"))' + end if + + write(buffer, format) value + type is (real(real64)) + allocate(character(13 * n + len(delimiter) * (n - 1)) :: buffer) + + if (maxval(abs(value)) < 1.0e5_real64) then + allocate(character(20 + len(delimiter) + floor(log10(real(n))) + 1) :: format) + write(format, '(a, i0, 3a)') '(ss, ', n, '(f13.6, :, "', delimiter, '"))' + else + allocate(character(23 + len(delimiter) + floor(log10(real(n))) + 1) :: format) + write(format, '(a, i0, 3a)') '(ss, ', n, '(es13.6e2, :, "', delimiter, '"))' + end if + + write(buffer, format) value + class default + stringify = '' + + return + end select + + stringify = trim(buffer) + end function stringify + + ! ########################################################################################## + ! Convert into --
+ ! ########################################################################################## + character(len=10) function date2yyyymmdd (date) + integer, intent(in) :: date ! yyyymmdd + integer :: year ! year of yyyy-mm-dd + integer :: month ! month of yyyy-mm-dd + integer :: day ! day of yyyy-mm-dd + + year = date / 10000 + month = (date - year*10000) / 100 + day = date - year*10000 - month*100 + + write(date2yyyymmdd,80) year, month, day +80 format(i4.4,'-',i2.2,'-',i2.2) + + end function date2yyyymmdd + + ! ######################################################################################### + ! Convert into :: + ! ######################################################################################### + character(len=8) function sec2hms (seconds) + integer, intent(in) :: seconds ! seconds + integer :: hours ! hours of hh:mm:ss + integer :: minutes ! minutes of hh:mm:ss + integer :: secs ! seconds of hh:mm:ss + + hours = seconds / 3600 + minutes = (seconds - hours*3600) / 60 + secs = (seconds - hours*3600 - minutes*60) + + write(sec2hms,80) hours, minutes, secs +80 format(i2.2,':',i2.2,':',i2.2) + + end function sec2hms + + ! ######################################################################################### + ! Convert into a left justified string. + ! ######################################################################################### + character(len=10) function int2str(n) + integer, intent(in) :: n + write(int2str,'(i0)') n + end function int2str + + !> ######################################################################################### + !> Convert as a left justified string. + !> ######################################################################################### + character(len=10) function log2str(n) + logical, intent(in) :: n + if (n) then + write(log2str,'(a4)') 'TRUE' + else + write(log2str,'(a4)') 'FALSE' + endif + end function log2str + +end module ufs_mpas_tools diff --git a/ufsatm_cap.F90 b/ufsatm_cap.F90 index 5643160a9..ff342c4f6 100644 --- a/ufsatm_cap.F90 +++ b/ufsatm_cap.F90 @@ -38,7 +38,8 @@ module ufsatm_cap_mod #ifdef MPAS use module_mpas_config, only: output_fh, dt_atmos, calendar, & fcst_mpi_comm, pio_ioformat, pio_iotype, & - pio_subsystem, pio_stride, & + pio_subsystem_ic, pio_stride, pio_subsystem_lbc, & + pio_subsystem_output, & pio_numiotasks, pio_iodesc, cpl_grid_id, & cplprint_flag, first_kdt, quilting, & quilting_restart @@ -161,7 +162,7 @@ subroutine SetServices(gcomp, rc) call NUOPC_CompSpecialize(gcomp, specLabel=label_Advance, & specPhaseLabel="phase1", specRoutine=ModelAdvance_phase1, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -#ifdef FV3 + ! setup Run/Advance phase: phase2 call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, & phaseLabelList=(/"phase2"/), userRoutine=routine_Run, rc=rc) @@ -178,7 +179,7 @@ subroutine SetServices(gcomp, rc) call NUOPC_CompSpecialize(gcomp, specLabel=label_SetRunClock, & specRoutine=ModelSetRunClock, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - +#ifdef FV3 ! specializations required to support 'inline' run sequences call NUOPC_CompSpecialize(gcomp, specLabel=label_CheckImport, & specPhaseLabel="phase1", specRoutine=ufsatm_checkimport, rc=rc) @@ -383,8 +384,8 @@ subroutine InitializeAdvertise(gcomp, rc) return end if else - cvalue = 'NETCDF' - pio_iotype = PIO_IOTYPE_NETCDF + cvalue = 'PNETCDF' + pio_iotype = PIO_IOTYPE_PNETCDF end if ! pio_root @@ -466,8 +467,14 @@ subroutine InitializeAdvertise(gcomp, rc) end if ! Initialize PIO - allocate(pio_subsystem) - call pio_init(mype, fcst_mpi_comm%mpi_val, pio_numiotasks, 0, pio_stride, pio_rearranger, pio_subsystem, base=pio_root) + allocate(pio_subsystem_ic) + call pio_init(mype, fcst_mpi_comm%mpi_val, pio_numiotasks, 0, pio_stride, pio_rearranger, pio_subsystem_ic, base=pio_root) + allocate(pio_subsystem_lbc) + call pio_init(mype, fcst_mpi_comm%mpi_val, pio_numiotasks, 0, pio_stride, pio_rearranger, pio_subsystem_lbc, base=pio_root) + + allocate(pio_subsystem_output) + call pio_init(mype, fcst_mpi_comm%mpi_val, pio_numiotasks, 0, pio_stride, & + pio_rearranger, pio_subsystem_output, base=pio_root) ! PIO debug related options ! pio_debug_level @@ -614,7 +621,7 @@ subroutine InitializeAdvertise(gcomp, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return endif ! quilting -! + ! call ESMF_ConfigGetAttribute(config=CF, value=dt_atmos, label ='dt_atmos:', rc=rc) call ESMF_ConfigGetAttribute(config=CF, value=nfhmax, label ='nhours_fcst:',rc=rc) if(mype == 0) print *,'af ufs config,dt_atmos=',dt_atmos,'nfhmax=',nfhmax @@ -1224,7 +1231,6 @@ subroutine InitializeAdvertise(gcomp, rc) endif ! !-- set up output forecast time if output_fh is specified -#ifdef FV3 if (noutput_fh > 0 ) then !--- use output_fh to sepcify output forecast time loutput_fh = .true. @@ -1256,7 +1262,6 @@ subroutine InitializeAdvertise(gcomp, rc) endif ! end loutput_fh endif if(mype==0) print *,'output_fh=',output_fh(1:size(output_fh)),'lflname_fulltime=',lflname_fulltime -#endif if ( quilting ) then do i=1, write_groups call ESMF_InfoGetFromHost(wrtState(i), info=info, rc=rc) @@ -1404,7 +1409,7 @@ end subroutine InitializeRealize !----------------------------------------------------------------------------- subroutine ModelAdvance(gcomp, rc) - + use mpi_f08, only : MPI_Wtime type(ESMF_GridComp) :: gcomp @@ -1424,10 +1429,10 @@ subroutine ModelAdvance(gcomp, rc) call ModelAdvance_phase1(gcomp, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -#ifdef FV3 + call ModelAdvance_phase2(gcomp, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -#endif + if (profile_memory) call ESMF_VMLogMemInfo("Leaving UFSATM ModelAdvance: ") timere = MPI_Wtime()