From 06a42239e4604cfe822c0202cb9e4dd3fdc60e16 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 30 Sep 2025 22:21:03 +0000 Subject: [PATCH 01/45] Some cleanup. Started adding LBC stream. Updates to NUOPC cap to integrate over correct forecast interval. --- CMakeLists.txt | 1 + mpas/MPAS-Model | 2 +- mpas/atmos_coupling.F90 | 111 +- mpas/atmos_model.F90 | 69 +- mpas/module_fcst_grid_comp.F90 | 98 +- mpas/module_mpas_config.F90 | 8 +- mpas/ufs_mpas_module.F90 | 2464 +++++++++++++++++++++++++++++++ mpas/ufs_mpas_subdriver.F90 | 2488 +++----------------------------- ufsatm_cap.F90 | 16 +- 9 files changed, 2946 insertions(+), 2311 deletions(-) create mode 100644 mpas/ufs_mpas_module.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index ceee4e502..9998f9ab5 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -221,6 +221,7 @@ if (MPAS) mpas/module_fcst_grid_comp.F90 mpas/atmos_coupling.F90 mpas/ufs_mpas_subdriver.F90 + mpas/ufs_mpas_module.F90 ${coupling_srcs} ${io_srcs} ccpp/data/MPAS_typedefs.F90 diff --git a/mpas/MPAS-Model b/mpas/MPAS-Model index 38d2177ae..9c44fa586 160000 --- a/mpas/MPAS-Model +++ b/mpas/MPAS-Model @@ -1 +1 @@ -Subproject commit 38d2177aef842a5c6abe26ffe876804b95fd9e0a +Subproject commit 9c44fa58682168af252b66c0412acbc4cc503585 diff --git a/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 index cd18a2284..e574027ab 100644 --- a/mpas/atmos_coupling.F90 +++ b/mpas/atmos_coupling.F90 @@ -5,7 +5,7 @@ ! ########################################################################################### module atmos_coupling_mod use mpas_kind_types, only : mpas_kind => RKIND - use ufs_mpas_subdriver, only : domain_ptr + use ufs_mpas_module, only : domain_ptr implicit none public :: MPAS_statein_type @@ -83,7 +83,8 @@ module atmos_coupling_mod ! from physics [kg K/m^3/s] (nlev,ncol) real(mpas_kind), pointer :: rho_tend(:,:) ! Dry air density tendency ! from physics [kg/m^3/s] (nlev,ncol) - + contains + procedure :: populate => populate_MPAS_statein end type MPAS_statein_type !> ####################################################################################### @@ -137,6 +138,8 @@ module atmos_coupling_mod ! (nlev,nvtx) real(mpas_kind), pointer :: divergence(:,:) ! Horizontal velocity divergence [s^-1] ! (nlev,ncol) + contains + procedure :: populate => populate_MPAS_stateout end type MPAS_stateout_type contains @@ -357,7 +360,7 @@ subroutine get_mpas_pio_decomp(varname) ! Arguments character(len=*), intent(in) :: varname ! Locals - character(len=*), parameter :: subname = 'ufs_mpas_subdriver::get_mpas_pio_decomp' + character(len=*), parameter :: subname = 'atmos_coupling::get_mpas_pio_decomp' integer, dimension(:), pointer :: indexArray, indices integer, pointer :: indexDimension type (field2DReal), pointer :: field2d @@ -459,5 +462,105 @@ subroutine mergeArrays(array1, array2) deallocate(array1) array1 => newArray end subroutine mergeArrays - + + !> ####################################################################################### + !> + !> ####################################################################################### + subroutine populate_MPAS_statein(state) + 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 + implicit none + class(MPAS_statein_type) :: state + type(mpas_pool_type), pointer :: state_pool, diag_pool, mesh_pool + integer, pointer :: nCells, nEdges, nVertices, nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, index_qv + + 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) + + ! Let dynamics import state point to memory managed by MPAS-Atmosphere + call mpas_pool_get_dimension(mesh_pool, 'nCells', nCells) + call mpas_pool_get_dimension(mesh_pool, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh_pool, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh_pool, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(mesh_pool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh_pool, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(mesh_pool, 'nVerticesSolve', nVerticesSolve) + call mpas_pool_get_dimension(state_pool, 'index_qv', index_qv) + state % nCells = nCells + state % nEdges = nEdges + state % nVertices = nVertices + state % nVertLevels = nVertLevels + state % nCellsSolve = nCellsSolve + state % nEdgesSolve = nEdgesSolve + state % nVerticesSolve = nVerticesSolve + state % index_qv = index_qv + + ! In MPAS timeLevel=1 is the current state. So the fields input to the dycore should + ! be in timeLevel=1. + call mpas_pool_get_array(state_pool, 'u', state % uperp, timeLevel=1) + call mpas_pool_get_array(state_pool, 'w', state % w, timeLevel=1) + call mpas_pool_get_array(state_pool, 'theta_m', state % theta_m, timeLevel=1) + call mpas_pool_get_array(state_pool, 'rho_zz', state % rho_zz, timeLevel=1) + call mpas_pool_get_array(state_pool, 'scalars', state % tracers, timeLevel=1) + call mpas_pool_get_array(diag_pool, 'rho_base', state % rho_base) + call mpas_pool_get_array(diag_pool, 'theta_base', state % theta_base) + call mpas_pool_get_array(mesh_pool, 'zgrid', state % zint) + call mpas_pool_get_array(mesh_pool, 'zz', state % zz) + call mpas_pool_get_array(mesh_pool, 'fzm', state % fzm) + call mpas_pool_get_array(mesh_pool, 'fzp', state % fzp) + call mpas_pool_get_array(mesh_pool, 'areaCell', state % areaCell) + call mpas_pool_get_array(mesh_pool, 'east', state % east) + call mpas_pool_get_array(mesh_pool, 'north', state % north) + call mpas_pool_get_array(mesh_pool, 'edgeNormalVectors', state % normal) + call mpas_pool_get_array(mesh_pool, 'cellsOnEdge', state % cellsOnEdge) + call mpas_pool_get_array(diag_pool, 'theta', state % theta) + call mpas_pool_get_array(diag_pool, 'exner', state % exner) + call mpas_pool_get_array(diag_pool, 'rho', state % rho) + call mpas_pool_get_array(diag_pool, 'uReconstructZonal', state % ux) + call mpas_pool_get_array(diag_pool, 'uReconstructMeridional', state % uy) + + end subroutine populate_MPAS_statein + + !> ####################################################################################### + !> + !> ####################################################################################### + subroutine populate_MPAS_stateout(stateout, statein) + implicit none + class(MPAS_stateout_type) :: stateout + type(MPAS_statein_type), intent(in) :: statein + + ! Let dynamics export state point to memory managed by MPAS-Atmosphere + ! Exception: pmiddry and pintdry are not managed by the MPAS infrastructure + stateout % nCells = statein % nCells + stateout % nEdges = statein % nEdges + stateout % nVertices = statein % nVertices + stateout % nVertLevels = statein % nVertLevels + stateout % nCellsSolve = statein % nCellsSolve + stateout % nEdgesSolve = statein % nEdgesSolve + stateout % nVerticesSolve = statein % nVerticesSolve + stateout % index_qv = statein % index_qv + + ! MPAS swaps pointers internally so that after a dycore timestep, the updated state is + ! in timeLevel=1. Thus we want stateout to also point to timeLevel=1. Can just copy + ! the pointers from statein. + stateout % uperp => statein % uperp + stateout % w => statein % w + stateout % theta_m => statein % theta_m + stateout % rho_zz => statein % rho_zz + stateout % tracers => statein % tracers + + ! These components don't have a time level index. + stateout % zint => statein % zint + stateout % zz => statein % zz + stateout % fzm => statein % fzm + stateout % fzp => statein % fzp + + stateout % theta => statein % theta + stateout % exner => statein % exner + stateout % rho => statein % rho + stateout % ux => statein % ux + stateout % uy => statein % uy + + end subroutine populate_MPAS_stateout end module atmos_coupling_mod diff --git a/mpas/atmos_model.F90 b/mpas/atmos_model.F90 index d4d82a4ab..094f69d6b 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 @@ -36,7 +37,7 @@ 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 : nCellsGlobal, ic_filename, lbc_filename use module_mpas_config, only : lonCellGlobal, latCellGlobal, areaCellGlobal use module_mpas_config, only : pi use mod_ufsatm_util, only : get_atmos_tracer_types @@ -53,6 +54,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,6 +64,7 @@ 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 @@ -74,15 +77,19 @@ module atmos_model_mod 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 ! 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. @@ -99,10 +106,10 @@ 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 ufs_mpas_subdriver, only : ufs_mpas_init + use ufs_mpas_subdriver, only : ufs_mpas_open_init, ufs_mpas_open_lbc + use ufs_mpas_module, only : ufs_mpas_define_scalars + use ufs_mpas_module, 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 @@ -128,10 +135,12 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm ! 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) @@ -171,10 +180,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,21 +204,13 @@ 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_init(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 - ! 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 @@ -274,7 +280,7 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm ! 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) - + ! 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') @@ -321,10 +327,10 @@ subroutine atmos_model_radiation_physics(Atmos) ! Call CCPP Timestep_initialize Group call mpp_clock_begin(setupClock) - call CCPP_step (step="timestep_init", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') + !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 @@ -335,10 +341,10 @@ subroutine atmos_model_radiation_physics(Atmos) ! Call CCPP Physics Group call mpp_clock_begin(physClock) - call CCPP_step (step="physics", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') + !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 !> ######################################################################################### @@ -353,7 +359,7 @@ subroutine atmos_model_dynamics(Atmos) type (atmos_control_type), intent(inout) :: Atmos ! Prepare MPAS dycore inputs with CCPP physics outputs. - call ufs_physics_to_mpas(UFSATM_stateout) + !call ufs_physics_to_mpas(UFSATM_stateout) ! Call MPAS dycore call mpp_clock_begin(mpasClock) @@ -361,7 +367,7 @@ subroutine atmos_model_dynamics(Atmos) call mpp_clock_end(mpasClock) ! Prepare CCPP physics inputs with MPAS dycore outputs. - call ufs_mpas_to_physics(UFSATM_statein) + !call ufs_mpas_to_physics(UFSATM_statein) end subroutine atmos_model_dynamics @@ -387,5 +393,14 @@ subroutine atmos_model_microphysics(Atmos) call mpp_clock_end(setupClock) end subroutine atmos_model_microphysics + !> ######################################################################################### + !> + !> ######################################################################################### + 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..af48151a4 100644 --- a/mpas/module_mpas_config.F90 +++ b/mpas/module_mpas_config.F90 @@ -54,13 +54,15 @@ module module_mpas_config character(len=256) :: lbc_filename !> 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(file_desc_t), target :: pioid_ic + type(file_desc_t), target :: pioid_lbc + 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 !> MPAS Grid information real(r8), target, allocatable :: zref(:) diff --git a/mpas/ufs_mpas_module.F90 b/mpas/ufs_mpas_module.F90 new file mode 100644 index 000000000..1b963d137 --- /dev/null +++ b/mpas/ufs_mpas_module.F90 @@ -0,0 +1,2464 @@ +!> ########################################################################################### +!> \file ufs_mpas_module.F90 +!> +!> 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/) +!> +!> ########################################################################################### +module ufs_mpas_module + 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 + implicit none + + public + + ! + type(core_type), pointer :: corelist => null() + type(domain_type), pointer :: domain_ptr => null() + type(mpas_Clock_type), pointer :: clock => null() + + ! + type (MPAS_Time_Type) :: LBC_intv_end + + ! + character(StrKIND), allocatable :: constituent_name(:) + integer, allocatable :: index_constituent_to_mpas_scalar(:) + integer, allocatable :: index_mpas_scalar_to_constituent(:) + logical, allocatable :: is_water_species(:) + + !> ######################################################################################### + !> + !> ######################################################################################### + 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) & + ] + + ! 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" 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 "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('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) & + ] + +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 + + !> ######################################################################################### + !> + !> 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, ierr) + use mpas_constants, only : rvord + use mpas_stream_manager, only : mpas_stream_mgr_read + 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_Time_type, MPAS_TimeInterval_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(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('r', 'lbc_in', pio_file_desc=pioid_lbc, ierr=ierr, timeLevel=2) + 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('r', 'lbc_in', pio_file_desc=pioid_lbc, ierr=ierr, timeLevel=2) + 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 + + !read_time = '2023-03-10_00:00:00' + !call mpas_set_time(currTime, dateTimeString=trim(read_time)) + currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) + call mpas_get_time(currTime, dateTimeString=read_time, ierr=ierr) + 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 + +!> ######################################################################################## + !> + !> \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 + + ! ########################################################################################## + ! \update: Dustin Swales April 2025 - Modified for use in UWM + ! ########################################################################################## + 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 + ! ######################################################################################### + ! \update: Dustin Swales April 2025 - Modified for use in UWM + ! ######################################################################################### + 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 + + ! ######################################################################################### + ! \update: Dustin Swales April 2025 - Modified for use in UWM + ! ######################################################################################### + 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 + !> ######################################################################################## + !> + !> 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(stream_mode, stream_name, pio_file_desc, timeLevel, 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_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 + use mpas_io_streams, only : MPAS_STREAM_EXACT_TIME + + character(*), intent(in) :: stream_mode + character(*), intent(in) :: stream_name + type(file_desc_t), pointer, intent(in) :: pio_file_desc + integer, intent(in) :: timeLevel + integer, intent(out) :: ierr + + 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 mpas_readstream(mpas_stream, timeLevel, 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, timeLevel, 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 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 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_module diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index 889caf6d7..fe04672a8 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -2,18 +2,11 @@ !> \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 @@ -21,36 +14,33 @@ !> the Physics. !> !> Other public routines used the UFSATM driver -!> ufs_mpas_open_init: Open MPAS Initial Condition file, return PIO file handle. +!> ufs_mpas_open_init : Open MPAS Initial Condition file, return PIO file handle. +!> ufs_mpas_open_lbc : Open MPAS Lateral Boundary 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 : ic_filename, pioid_ic, pio_subsystem_ic + use module_mpas_config, only : lbc_filename, pioid_lbc, pio_subsystem_lbc + use module_mpas_config, only : pio_iotype, pio_stride, pio_numiotasks, pio_iodesc + 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 : latCellGlobal, lonCellGlobal, areaCellGlobal + use ufs_mpas_module 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 + public :: ufs_mpas_open_lbc !> ######################################################################################### !> @@ -98,285 +88,15 @@ module ufs_mpas_subdriver 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(:) - 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 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 @@ -392,6 +112,8 @@ subroutine ufs_mpas_init_phase1(Cfg, time_start, time_end, total_time, calendar, 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 ! FMS use field_manager_mod, only : MODEL_ATMOS use fms2_io_mod, only : file_exists @@ -404,7 +126,7 @@ subroutine ufs_mpas_init_phase1(Cfg, time_start, time_end, total_time, calendar, integer, intent(in ) :: total_time character(17), intent(in ) :: calendar ! 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 (field3dReal), pointer :: scalarsField @@ -426,7 +148,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 +168,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 @@ -474,10 +200,14 @@ subroutine ufs_mpas_init_phase1(Cfg, time_start, time_end, total_time, calendar, 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,12 +239,18 @@ 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) @@ -524,26 +260,31 @@ subroutine ufs_mpas_init_phase1(Cfg, time_start, time_end, total_time, calendar, call mpas_pool_add_dimension(state, 'moist_start', 1) call mpas_pool_add_dimension(state, 'moist_end', Cfg % nwat) + ! ! Read in static (invariant) data - call dyn_mpas_read_write_stream( 'r', 'invariant') + ! + call dyn_mpas_read_write_stream( 'r', 'invariant', pio_file_desc=pioid_ic, ierr=ierr, timeLevel=1) + ! 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 - 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 + ! 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_rbf_interp_initialize(mesh) + call mpas_init_reconstruct(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) - if( ierr /= 0 ) then - call mpp_error(FATAL,subname//": Could not find sphere_radius PIO attribute") - endif +! ierr = pio_get_att(pioid_ic, pio_global, 'sphere_radius', 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 +295,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 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,7 +320,7 @@ 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, mpas_atm_run_compatibility 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_log, only : mpas_log_write @@ -582,11 +331,12 @@ 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' + character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_atm_core_init' type (mpas_pool_type), pointer :: state, mesh 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 @@ -594,6 +344,7 @@ subroutine ufs_mpas_init_phase2(Cfg) character (len=StrKIND), pointer :: initial_time1, initial_time2 type(field0dreal), pointer :: field_0d_real type(field2dreal), pointer :: field_2d_real + logical, pointer :: config_apply_lbcs ! ! Setup threading @@ -613,54 +364,54 @@ 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? ! ! 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 mpas_log_write('Building halo exchange groups.') 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 - ! 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('r', 'input-scalars', pio_file_desc=pioid_ic, ierr=ierr, timeLevel=1) + + ! + ! Read in restart data. + ! + !call mpas_log_write('Reading in MPAS restart stream.' + !call dyn_mpas_read_write_stream('r', 'restart', ierr=ierr, timeLevel=1) + + 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_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"') + block => domain_ptr % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_initialize_time_levels(state) + block => block % next + end do 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,41 +424,54 @@ 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 mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', mesh) - !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) - - call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) - call mpas_pool_get_array(state, 'xtime', xtime, timelevel=1) - xtime = startTimeStamp - - ! Initialize initial_time in second time level. We need to do this because initial state - ! is read into time level 1, and if we write output from the set of state arrays that - ! represent the original time level 2, the initial_time field will be invalid. - 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"') + 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 - call mpas_modify_att(field_0d_real % attlists(1) % attlist, 'units', & - 'seconds since ' // mpas_string_replace(initial_time1, '_', ' '), ierr=ierr) - + ! + ! Perform basic compatibility checks among the fields that were read and the run-time options that were selected + ! + !call mpas_atm_run_compatibility(domain_ptr % dminfo, domain_ptr % blocklist, domain_ptr % streamManager, ierr=ierr) if (ierr /= 0) then - call mpp_error(FATAL,subname//'Failed to set time units') + call mpas_log_write('Please correct issues with the model input fields and/or namelist.') + return end if + + block => domain_ptr % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'state', state) + + call atm_mpas_init_block(domain_ptr % dminfo, domain_ptr % streamManager, block, mesh, dt) + call mpas_pool_get_array(state, 'xtime', xtime, timelevel=1) + xtime = startTimeStamp + + ! Initialize initial_time in second time level. We need to do this because initial state + ! is read into time level 1, and if we write output from the set of state arrays that + ! represent the original time level 2, the initial_time field will be invalid. + 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_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 + block => block % next + end do + call exchange_halo_group(domain_ptr, 'initialization:pv_edge,ru,rw',ierr=ierr) if ( ierr /= 0 ) then call mpp_error(FATAL,subname//'Failed to exchange halo layers for group "initialization:ru,rw"') @@ -719,21 +483,9 @@ 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 @@ -744,7 +496,8 @@ subroutine ufs_mpas_run() ! 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 @@ -754,13 +507,14 @@ subroutine ufs_mpas_run() 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 ufs_mpas_module, only : ufs_mpas_atm_update_bdy_tend ! FMS use mpp_mod, only : FATAL, mpp_error ! 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 @@ -770,72 +524,111 @@ subroutine ufs_mpas_run() real (kind=R8KIND) :: integ_start_time, integ_stop_time logical, pointer :: config_apply_lbcs type(mpas_timeinterval_type) :: mpas_time_interval + real(RKIND), dimension(:,:), pointer :: theta1, ux1, uy1, theta2, ux2, uy2 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 mpas_pool_get_array(diag, 'theta', theta1) + call mpas_pool_get_array(diag, 'uReconstructZonal', ux1) + call mpas_pool_get_array(diag, 'uReconstructMeridional', uy1) + print*,'SWALES theta1 = ', theta1(1,1), ux1(1,1), uy1(1,1) ! 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()) - ! - call mpas_pool_get_config( domain_ptr % blocklist % configs, 'config_apply_lbcs', config_apply_lbcs) + ! Compute lateral boundary conditions (timeLevel=1) if (config_apply_lbcs) then - - endif + call ufs_mpas_atm_update_bdy_tend(clock, domain_ptr % blocklist, .true., 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 + + ! Need to compute this somewhere. + !timeLBCnew ! 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"') - endif - timeStop = timeNow + mpas_time_interval itimestep = 0 - do while (itimestep < 1)!(timeNow < timeStop) !DJS2025: Only one dycore inte + call mpas_log_write(' MPAS dynamics start') + do while (timeNow < 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)) + ! Compute lateral boundary conditions. + if (config_apply_lbcs) then + if (timeNow > timeLBCnew) then + call ufs_mpas_atm_update_bdy_tend(clock, domain_ptr % blocklist, .false., 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') call mpas_dmpar_get_time(integ_start_time) 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 - ! - ! 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 atm_compute_output_diagnostics(state, 1, diag, mesh) - + call mpas_pool_get_array(diag, 'theta', theta2) + call mpas_pool_get_array(diag, 'uReconstructZonal', ux2) + call mpas_pool_get_array(diag, 'uReconstructMeridional', uy2) + print*,'SWALES theta2 = ', theta2(1,1), ux2(1,1), uy2(1,1) + + ! + ! Write any output streams + ! end subroutine ufs_mpas_run @@ -856,7 +649,7 @@ subroutine ufs_mpas_open_init() ! Open MPAS Initial Condition file. if (file_exists(ic_filename)) then - ierr = pio_openfile(pio_subsystem, pioid, pio_iotype, ic_filename, pio_nowrite) + 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 @@ -864,6 +657,32 @@ subroutine ufs_mpas_open_init() 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 read MPAS namelist(s). @@ -1200,1861 +1019,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/ufsatm_cap.F90 b/ufsatm_cap.F90 index 0c9f0e6eb..ea4d299fd 100644 --- a/ufsatm_cap.F90 +++ b/ufsatm_cap.F90 @@ -38,7 +38,7 @@ 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_numiotasks, pio_iodesc, cpl_grid_id, & cplprint_flag, first_kdt, quilting, & quilting_restart @@ -145,7 +145,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) @@ -162,7 +162,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) @@ -442,8 +442,10 @@ 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) ! PIO debug related options ! pio_debug_level @@ -1382,10 +1384,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() From 2ccee6bb50d5953d51b794c000fc5ea8861d7993 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 22 Oct 2025 20:07:11 +0000 Subject: [PATCH 02/45] fix compilation failure related to mpas timekeeping operators --- mpas/ufs_mpas_subdriver.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index fe04672a8..aa31598a8 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -506,7 +506,7 @@ 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.) use ufs_mpas_module, only : ufs_mpas_atm_update_bdy_tend ! FMS use mpp_mod, only : FATAL, mpp_error @@ -572,7 +572,7 @@ subroutine ufs_mpas_run() timeStop = timeNow + mpas_time_interval itimestep = 0 call mpas_log_write(' MPAS dynamics start') - do while (timeNow < timeStop) + do while (timeNow .LT. timeStop) itimestep = itimestep + 1 call mpas_get_time(curr_time=timeNow, dateTimeString=timeStamp, ierr=ierr) @@ -585,7 +585,7 @@ subroutine ufs_mpas_run() ! Compute lateral boundary conditions. if (config_apply_lbcs) then - if (timeNow > timeLBCnew) then + if (timeNow .GT. timeLBCnew) then call ufs_mpas_atm_update_bdy_tend(clock, domain_ptr % blocklist, .false., ierr) if (ierr /= 0) then call mpas_log_write('Failed to process LBC data at next time after '//trim(timeStamp), messageType=MPAS_LOG_ERR) From ae366afd16d2b42bc909e8eece908f813467a14d Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 14 Nov 2025 18:46:22 +0000 Subject: [PATCH 03/45] Changes to decomposition in P2D. MPAS RTs on URSA now working. --- ccpp/data/GFS_typedefs.F90 | 19 +++++++++++++++---- mpas/atmos_coupling.F90 | 33 ++++++++++++++------------------- mpas/atmos_model.F90 | 25 ++++++++++++++----------- mpas/module_mpas_config.F90 | 3 +++ mpas/ufs_mpas_module.F90 | 12 ++++-------- mpas/ufs_mpas_subdriver.F90 | 3 +-- 6 files changed, 51 insertions(+), 44 deletions(-) diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index e3071f27e..2ea71b55e 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -6707,7 +6707,7 @@ subroutine control_print(Model) class(GFS_control_type) :: Model !--- local variables - integer :: i + integer :: i, mpierr if (Model%me == Model%master) then print *, ' ' @@ -6738,9 +6738,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 @@ -6751,10 +6754,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/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 index e574027ab..fcc4270a2 100644 --- a/mpas/atmos_coupling.F90 +++ b/mpas/atmos_coupling.F90 @@ -146,9 +146,6 @@ module atmos_coupling_mod !> ######################################################################################### !> Procedure to populate inputs to the CCPP physics using outputs the MPAS dynamical core. !> - !> Use indicesGlobal to map from MPAS dycore deceomposition to CCPP Physics contiguous data - !> structures. - !> !> ######################################################################################### subroutine ufs_mpas_to_physics(physics_state) use GFS_typedefs, only : GFS_statein_type @@ -163,7 +160,7 @@ subroutine ufs_mpas_to_physics(physics_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 :: iCol, iTracer integer, pointer :: nCellsSolve, num_scalars, nwat, index_qv, nVertLevels real(RKIND), pointer :: surface_p(:) @@ -194,17 +191,16 @@ subroutine ufs_mpas_to_physics(physics_state) ! 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) + do iCol = 1, nCellsSolve + physics_state % tgrs(iCol,:) = MPAS_state % theta(nVertLevels:1:-1,iCo) + physics_state % ugrs(iCol,:) = MPAS_state % ux(nVertLevels:1:-1,iCol) + physics_state % vgrs(iCol,:) = MPAS_state % uy(nVertLevels:1:-1,iCol) + physics_state % phil(iCol,:) = MPAS_state % zz(nVertLevels:1:-1,iCol) + physics_state % phii(iCol,:) = MPAS_state % zint(nVertLevels+1:1:-1,iCol) + physics_state % prslk(iCol,:) = MPAS_state % exner(nVertLevels:1:-1,iCol) + physics_state % vvl(iCol,:) = MPAS_state % w(nVertLevels:1:-1,iCol) 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,nVertLevels:1:-1,iCol) enddo enddo @@ -219,11 +215,10 @@ subroutine ufs_mpas_to_physics(physics_state) ! 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) + do iCol = 1, nCellsSolve + physics_state % pgr(iCol) = MPAS_state % pintdry(1,iCol) + physics_state % prsl(iCol,:) = MPAS_state % pmiddry(nVertLevels:1:-1,iCol) + physics_state % prsi(iCol,:) = MPAS_state % pintdry(nVertLevels+1:1:-1,iCol) enddo end subroutine ufs_mpas_to_physics diff --git a/mpas/atmos_model.F90 b/mpas/atmos_model.F90 index 7311c755d..5fa30a71e 100644 --- a/mpas/atmos_model.F90 +++ b/mpas/atmos_model.F90 @@ -37,8 +37,8 @@ module atmos_model_mod use fms_mod, only : stdlog use mpp_mod, only : stdout ! UFSATM - use module_mpas_config, only : 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 @@ -235,14 +235,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)) @@ -262,11 +262,14 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm UFSATM_statein, 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 + ! DJS2025: lonCell and latCell are defined by nCells, including halo points, whereas + ! xlon and xlat are allocated by nCellsSolve, excluding halo points. + ! Need to be able to grab lon and lat for nCellsSolve. + !UFSATM_grid % xlon = lonCell + !UFSATM_grid % xlat = latCell + !UFSATM_grid % xlon_d = lonCell*180./pi + !UFSATM_grid % xlat_d = latCell*180./pi + !UFSATM_grid % area = areaCellGlobal ! Populate UFSATM data containers with MPAS "input" stream. We need to do this becuase ! we are calling the physics before the dynamical core. diff --git a/mpas/module_mpas_config.F90 b/mpas/module_mpas_config.F90 index af48151a4..9659ddff2 100644 --- a/mpas/module_mpas_config.F90 +++ b/mpas/module_mpas_config.F90 @@ -79,11 +79,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 diff --git a/mpas/ufs_mpas_module.F90 b/mpas/ufs_mpas_module.F90 index 1b963d137..5fdad979f 100644 --- a/mpas/ufs_mpas_module.F90 +++ b/mpas/ufs_mpas_module.F90 @@ -578,9 +578,9 @@ subroutine ufs_mpas_compute_unit_vectors() 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 :: latCell, lonCell real(kind=RKIND), dimension(:,:), pointer :: east, north integer, pointer :: nCells integer :: iCell @@ -865,6 +865,7 @@ subroutine ufs_mpas_get_global_dims(nCellsGlobal, nEdgesGlobal, nVerticesGlobal, 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 @@ -873,9 +874,6 @@ subroutine ufs_mpas_get_global_dims(nCellsGlobal, nEdgesGlobal, nVerticesGlobal, integer, intent(out) :: nVertLevels integer, intent(out) :: maxNCells - integer, pointer :: nCellsSolve - integer, pointer :: nEdgesSolve - integer, pointer :: nVerticesSolve integer, pointer :: maxEdgesLocal integer, pointer :: nVertLevelsLocal @@ -921,20 +919,18 @@ subroutine ufs_mpas_get_global_coords(latCellGlobal, lonCellGlobal, areaCellGlob 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, 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 diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index aa31598a8..c90e74b94 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -28,7 +28,7 @@ module ufs_mpas_subdriver 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 : nEdgesSolve, nVerticesSolve, nVertLevelsSolve use module_mpas_config, only : dt_atmos, n_atmos use module_mpas_config, only : latCellGlobal, lonCellGlobal, areaCellGlobal use ufs_mpas_module @@ -518,7 +518,6 @@ subroutine ufs_mpas_run() 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 From 8749442dfd2ce7749d3c2990143ff3e7d6591939 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 14 Nov 2025 18:47:04 +0000 Subject: [PATCH 04/45] Omit from previous commit --- mpas/atmos_coupling.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 index fcc4270a2..1a3db289b 100644 --- a/mpas/atmos_coupling.F90 +++ b/mpas/atmos_coupling.F90 @@ -192,7 +192,7 @@ subroutine ufs_mpas_to_physics(physics_state) ! [k, i] -> [i, k] ! bottom-up -> top-down ordering convention do iCol = 1, nCellsSolve - physics_state % tgrs(iCol,:) = MPAS_state % theta(nVertLevels:1:-1,iCo) + physics_state % tgrs(iCol,:) = MPAS_state % theta(nVertLevels:1:-1,iCol) physics_state % ugrs(iCol,:) = MPAS_state % ux(nVertLevels:1:-1,iCol) physics_state % vgrs(iCol,:) = MPAS_state % uy(nVertLevels:1:-1,iCol) physics_state % phil(iCol,:) = MPAS_state % zz(nVertLevels:1:-1,iCol) From 73da07ab8a8e6c6f7badc1c754372cb539106112 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 20 Nov 2025 21:21:24 +0000 Subject: [PATCH 05/45] Progress towards regional MPAS. Work in progress. --- mpas/MPAS-Model | 2 +- mpas/ufs_mpas_module.F90 | 159 ++++++++++++++++++++++++++++++------ mpas/ufs_mpas_subdriver.F90 | 134 +++++++++++++++--------------- 3 files changed, 200 insertions(+), 95 deletions(-) diff --git a/mpas/MPAS-Model b/mpas/MPAS-Model index 9c44fa586..ac90200e1 160000 --- a/mpas/MPAS-Model +++ b/mpas/MPAS-Model @@ -1 +1 @@ -Subproject commit 9c44fa58682168af252b66c0412acbc4cc503585 +Subproject commit ac90200e197f47f533138939203ffe757f9dc423 diff --git a/mpas/ufs_mpas_module.F90 b/mpas/ufs_mpas_module.F90 index 5fdad979f..870b0fed1 100644 --- a/mpas/ufs_mpas_module.F90 +++ b/mpas/ufs_mpas_module.F90 @@ -9,9 +9,10 @@ !> !> ########################################################################################### module ufs_mpas_module - 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 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 mpas_atm_boundaries, only : LBC_intv_end implicit none public @@ -21,9 +22,6 @@ module ufs_mpas_module type(domain_type), pointer :: domain_ptr => null() type(mpas_Clock_type), pointer :: clock => null() - ! - type (MPAS_Time_Type) :: LBC_intv_end - ! character(StrKIND), allocatable :: constituent_name(:) integer, allocatable :: index_constituent_to_mpas_scalar(:) @@ -47,8 +45,8 @@ module ufs_mpas_module 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) & + var_info_type('lbc_theta' , 'real' , 2) & + !var_info_type('lbc_scalars' , 'real' , 3) & ] !> ######################################################################################### @@ -143,7 +141,7 @@ module ufs_mpas_module 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('scalars' , 'real' , 3), & var_info_type('theta' , 'real' , 2), & var_info_type('theta_base' , 'real' , 2), & var_info_type('u' , 'real' , 2), & @@ -341,7 +339,7 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) 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 @@ -401,7 +399,8 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) call mpas_pool_get_subpool(block % structs, 'lbc', lbc) if (firstCall) then - call dyn_mpas_read_write_stream('r', 'lbc_in', pio_file_desc=pioid_lbc, ierr=ierr, timeLevel=2) + 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) 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) @@ -409,7 +408,8 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) end if else call mpas_pool_shift_time_levels(lbc) - call dyn_mpas_read_write_stream('r', 'lbc_in', pio_file_desc=pioid_lbc, ierr=ierr, timeLevel=2) + 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) 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) @@ -420,11 +420,12 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) return end if - !read_time = '2023-03-10_00:00:00' + !read_time = '2023-03-10_18:00:00' !call mpas_set_time(currTime, dateTimeString=trim(read_time)) currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) call mpas_get_time(currTime, dateTimeString=read_time, ierr=ierr) call mpas_set_time(currTime,dateTimeString=trim(read_time)) + !print*,'read_time=',read_time ! ! Compute any derived fields from those that were read from the lbc_in stream ! @@ -503,7 +504,10 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) 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)) - + !print*,'SWALES ufs_mpas_atm_update_bdy_tend dd_intv = ',dd_intv + !print*,'SWALES ufs_mpas_atm_update_bdy_tend s_intv = ',s_intv + !print*,'SWALES ufs_mpas_atm_update_bdy_tend sn_intv = ',sn_intv + !print*,'SWALES ufs_mpas_atm_update_bdy_tend sd_intv = ',sd_intv dt = 1.0_RKIND / dt @@ -1176,9 +1180,7 @@ subroutine dyn_mpas_exchange_halo(field_name) 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, & @@ -1239,23 +1241,27 @@ end subroutine dyn_mpas_exchange_halo !> \update: Dustin Swales April 2025 - Modified for use in UWM !> !> ######################################################################################## - subroutine dyn_mpas_read_write_stream(stream_mode, stream_name, pio_file_desc, timeLevel, ierr) + subroutine dyn_mpas_read_write_stream(clock, stream_mode, stream_name, pio_file_desc, timeLevel, when, whence, actualWhen, 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_readstream, mpas_writestream + 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_atm_halos, only : exchange_halo_group use mpas_io_streams, only : MPAS_STREAM_EXACT_TIME - + use mpas_timekeeping, only : mpas_get_clock_time, MPAS_NOW + 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(out) :: ierr character(*), parameter :: subname = 'dyn_mpas_subdriver::dyn_mpas_read_write_stream' @@ -1263,11 +1269,34 @@ subroutine dyn_mpas_read_write_stream(stream_mode, stream_name, pio_file_desc, t type(mpas_pool_type), pointer :: mpas_pool type(mpas_stream_type), pointer :: mpas_stream type(var_info_type), allocatable :: var_info_list(:) - + character (len=StrKIND) :: local_when + integer :: local_whence + integer :: local_ierr + type (MPAS_Time_type) :: now_time + ierr = 0 call mpas_log_write('') - + ! + ! Optional arguments. + ! + if (present(actualWhen)) write(actualWhen,'(a)') '0000-01-01_00:00:00' + if (present(whence)) then + local_whence = whence + else + local_whence = MPAS_STREAM_EXACT_TIME + end if + + if (present(when)) then + local_when = when + else + now_time = mpas_get_clock_time(clock, MPAS_NOW, ierr=local_ierr) + if (local_ierr /= 0) then + call mpp_error(FATAL,subname//': Failed to get clock_time for "mpas_NOW"') + endif + !call mpas_get_time(now_time, dateTimeString=local_when) + end if + nullify(mpas_pool) nullify(mpas_stream) call mpas_log_write( '---------------------------------------------------------------------') @@ -1287,7 +1316,7 @@ subroutine dyn_mpas_read_write_stream(stream_mode, stream_name, pio_file_desc, t case ('r', 'read') call mpas_log_write('Reading stream "' // trim(adjustl(stream_name)) // '"') - call mpas_readstream(mpas_stream, timeLevel, ierr=ierr) + call read_stream(mpas_stream, timeLevel, local_when, local_whence, actualWhen, ierr) if (ierr /= mpas_stream_noerr) then call mpp_error(FATAL,subname//'Failed to read stream "' // trim(adjustl(stream_name)) // '"') @@ -1346,7 +1375,35 @@ subroutine dyn_mpas_read_write_stream(stream_mode, stream_name, pio_file_desc, t call mpas_log_write(subname // ' completed') end subroutine dyn_mpas_read_write_stream - + + !> ######################################################################################## + !> subroutine read_stream + !> + !> + !> ######################################################################################## + subroutine read_stream(stream, timeLevel, when, whence, actualWhen, ierr) + use mpas_io_streams, only : mpas_readstream + use mpas_derived_types, only : MPAS_Time_type, MPAS_TimeInterval_type + 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) :: timeLevel + character (len=*), intent(in) :: when + integer, intent(in) :: whence + character (len=*), intent(out), optional :: actualWhen + integer, intent(out) :: ierr + + type (MPAS_Time_type) :: now_time + type (MPAS_TimeInterval_type) :: filename_interval + integer :: local_ierr + character (len=StrKIND) :: temp_filename + + !call mpas_set_time(now_time, dateTimeString=whence, ierr=local_ierr) + !call mpas_set_timeInterval(filename_interval, timeString=stream % filename_interval) + + call mpas_readstream(stream, timeLevel, ierr=ierr) + + end subroutine read_stream !> ######################################################################################## !> subroutine dyn_mpas_init_stream_with_pool !> @@ -1492,7 +1549,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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 + cycle end if if (any(var_is_present .and. .not. var_is_tkr_compatible)) then @@ -1619,11 +1676,9 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) @@ -1634,7 +1689,6 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) @@ -2456,5 +2510,56 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, call mpas_log_write(subname // ' completed') end subroutine dyn_mpas_check_variable_status + !> ######################################################################################## + ! routine dyn_mpas_cell_to_edge_winds + ! + !> \brief Projects cell-centered winds to the normal component of velocity on edges + !> \author Michael Duda + !> \date 16 January 2020 + !> \details + !> Given zonal and meridional winds at cell centers, unit vectors in the east + !> and north directions at cell centers, and unit vectors in the normal + !> direction at edges, this routine projects the cell-centered winds onto + !> the normal vectors. + !> + !> Prior to calling this routine, the halos for the zonal and meridional + !> components of cell-centered winds should be updated. It is also critical + !> that the east, north, uZonal, and uMerid field are all allocated with + !> a "garbage" element; this is handled automatically for fields allocated + !> by the MPAS infrastructure. + !> + !> ######################################################################################## + subroutine dyn_mpas_cell_to_edge_winds(nEdges, uZonal, uMerid, east, north, edgeNormalVectors, & + cellsOnEdge, uNormal) + use mpas_kind_types, only : RKIND + integer, intent(in) :: nEdges + real(kind=RKIND), dimension(:,:), intent(in) :: uZonal, uMerid + real(kind=RKIND), dimension(:,:), intent(in) :: east, north, edgeNormalVectors + integer, dimension(:,:), intent(in) :: cellsOnEdge + real(kind=RKIND), dimension(:,:), intent(out) :: uNormal + + integer :: iEdge, cell1, cell2 + + character(len=*), parameter :: subname = 'ufs_mpas_subdriver::dyn_mpas_cell_to_edge_winds' + + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + uNormal(:,iEdge) = uZonal(:,cell1)*0.5_RKIND*(edgeNormalVectors(1,iEdge)*east(1,cell1) & + + edgeNormalVectors(2,iEdge)*east(2,cell1) & + + edgeNormalVectors(3,iEdge)*east(3,cell1)) & + + uMerid(:,cell1)*0.5_RKIND*(edgeNormalVectors(1,iEdge)*north(1,cell1) & + + edgeNormalVectors(2,iEdge)*north(2,cell1) & + + edgeNormalVectors(3,iEdge)*north(3,cell1)) & + + uZonal(:,cell2)*0.5_RKIND*(edgeNormalVectors(1,iEdge)*east(1,cell2) & + + edgeNormalVectors(2,iEdge)*east(2,cell2) & + + edgeNormalVectors(3,iEdge)*east(3,cell2)) & + + uMerid(:,cell2)*0.5_RKIND*(edgeNormalVectors(1,iEdge)*north(1,cell2) & + + edgeNormalVectors(2,iEdge)*north(2,cell2) & + + edgeNormalVectors(3,iEdge)*north(3,cell2)) + end do + + end subroutine dyn_mpas_cell_to_edge_winds end module ufs_mpas_module diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index c90e74b94..6d9b01523 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -114,6 +114,7 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni 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 @@ -189,7 +190,7 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni 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)) @@ -263,7 +264,7 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni ! ! Read in static (invariant) data ! - call dyn_mpas_read_write_stream( 'r', 'invariant', pio_file_desc=pioid_ic, ierr=ierr, timeLevel=1) + call dyn_mpas_read_write_stream(domain_ptr % clock, 'r', 'invariant', pio_file_desc=pioid_ic, ierr=ierr, timeLevel=1, whence=mpas_NOW) ! FROM CAM/driver/cam_mpas_subdriver.F90 ! Compute unit vectors giving the local north and east directions as well as @@ -277,12 +278,14 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', mesh) call mpas_rbf_interp_initialize(mesh) call mpas_init_reconstruct(mesh) + + !call dyn_mpas_cell_to_edge_winds() ! Read the global sphere_radius attribute. This is needed to normalize the cell areas. -! ierr = pio_get_att(pioid_ic, pio_global, 'sphere_radius', sphere_radius) -! if( ierr /= 0 ) then -! call mpp_error(FATAL,subname//": Could not find sphere_radius PIO attribute") -! endif + ierr = pio_get_att(pioid_ic, pio_global, 'sphere_radius', 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 @@ -323,6 +326,7 @@ subroutine ufs_mpas_atm_core_init(Cfg) use atm_core, only : atm_mpas_init_block, mpas_atm_run_compatibility 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 use mpas_log, only : mpas_log_write use mpas_attlist, only : mpas_modify_att use mpas_string_utils, only : mpas_string_replace @@ -332,7 +336,7 @@ subroutine ufs_mpas_atm_core_init(Cfg) type(mpas_pool_type), pointer :: tend_physics_pool ! Locals character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_atm_core_init' - type (mpas_pool_type), pointer :: state, mesh + type (mpas_pool_type), pointer :: state, mesh, diag integer :: ierr integer, pointer :: nVertLevels1, maxEdges1, maxEdges2, num_scalars real (kind=RKIND), pointer :: dt @@ -345,6 +349,7 @@ subroutine ufs_mpas_atm_core_init(Cfg) type(field0dreal), pointer :: field_0d_real type(field2dreal), pointer :: field_2d_real logical, pointer :: config_apply_lbcs + real(RKIND), dimension(:,:), pointer :: theta1 ! ! Setup threading @@ -375,12 +380,17 @@ subroutine ufs_mpas_atm_core_init(Cfg) ! ! Build halo exchange groups and set method for exchanging halos in a group ! - call mpas_log_write('Building halo exchange groups.') + 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.") + endif + ! 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) @@ -388,23 +398,19 @@ subroutine ufs_mpas_atm_core_init(Cfg) ! Read in initial-conditions ! call mpas_log_write('Reading in MPAS initial condition stream.') - call dyn_mpas_read_write_stream('r', 'input-scalars', pio_file_desc=pioid_ic, ierr=ierr, timeLevel=1) + call dyn_mpas_read_write_stream(clock, 'r', 'input-scalars', pio_file_desc=pioid_ic, ierr=ierr, timeLevel=1, whence=mpas_NOW) ! ! Read in restart data. ! !call mpas_log_write('Reading in MPAS restart stream.' - !call dyn_mpas_read_write_stream('r', 'restart', ierr=ierr, timeLevel=1) + !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') - block => domain_ptr % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_initialize_time_levels(state) - block => block % next - end do + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) + call mpas_pool_initialize_time_levels(state) end if call mpas_log_write('Initializing atmospheric variables') @@ -441,36 +447,20 @@ subroutine ufs_mpas_atm_core_init(Cfg) return end if - block => domain_ptr % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - - call atm_mpas_init_block(domain_ptr % dminfo, domain_ptr % streamManager, block, mesh, dt) - call mpas_pool_get_array(state, 'xtime', xtime, timelevel=1) - xtime = startTimeStamp - - ! Initialize initial_time in second time level. We need to do this because initial state - ! is read into time level 1, and if we write output from the set of state arrays that - ! represent the original time level 2, the initial_time field will be invalid. - 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_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 + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', mesh) + 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) - block => block % next - end do + call mpas_pool_get_array(state, 'xtime', xtime, timelevel=1) + xtime = startTimeStamp + + ! Initialize initial_time in second time level. We need to do this because initial state + ! is read into time level 1, and if we write output from the set of state arrays that + ! represent the original time level 2, the initial_time field will be invalid. + 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 call exchange_halo_group(domain_ptr, 'initialization:pv_edge,ru,rw',ierr=ierr) if ( ierr /= 0 ) then @@ -517,21 +507,26 @@ subroutine ufs_mpas_run() type (mpas_Time_type) :: timeNow, timeStop,timeLBCnew character(len=StrKIND) :: timeStamp integer :: ierr, itime, itimestep - integer, pointer :: index_qv - 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 logical, pointer :: config_apply_lbcs type(mpas_timeinterval_type) :: mpas_time_interval real(RKIND), dimension(:,:), pointer :: theta1, ux1, uy1, theta2, ux2, uy2 - + real(RKIND), dimension(:), pointer :: lon,lat + integer, pointer :: nCells_ptr,nCellsSolve_ptr 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) call mpas_pool_get_array(diag, 'theta', theta1) + call mpas_pool_get_array(mesh, 'lonCell', lon) + call mpas_pool_get_array(mesh, 'latCell', lat) call mpas_pool_get_array(diag, 'uReconstructZonal', ux1) call mpas_pool_get_array(diag, 'uReconstructMeridional', uy1) - print*,'SWALES theta1 = ', theta1(1,1), ux1(1,1), uy1(1,1) + lon = lon*180/3.14 + lat = lat*180/3.14 + call mpas_pool_get_dimension(mesh, 'nCells', nCells_ptr) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve_ptr) + print*,'MPAS_DEBUG0 ', lon(10), lat(10), theta1(10,1) ! Eventually, dt should be domain specific call mpas_pool_get_config( domain_ptr % blocklist % configs, 'config_dt', config_dt) @@ -554,8 +549,12 @@ subroutine ufs_mpas_run() call mpp_error(FATAL,subname//'Failed to set dynamics time step') endif - ! Compute lateral boundary conditions (timeLevel=1) + ! + ! Read initial boundary state + ! if (config_apply_lbcs) 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., ierr) if (ierr /= 0) then call mpas_log_write('Failed to process LBC data at next time after '//trim(timeStamp), messageType=MPAS_LOG_ERR) @@ -570,7 +569,8 @@ subroutine ufs_mpas_run() ! time step, and time level 2 stores the state advanced config_dt in time by timestep(...) timeStop = timeNow + mpas_time_interval itimestep = 0 - call mpas_log_write(' MPAS dynamics start') + call mpas_log_write('--------------------------------------------------') + call mpas_log_write('MPAS dynamics start timestep') do while (timeNow .LT. timeStop) itimestep = itimestep + 1 @@ -579,18 +579,21 @@ subroutine ufs_mpas_run() 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)) - ! Compute lateral boundary conditions. + ! + ! Read future boundary state and compute boundary tendencies + ! if (config_apply_lbcs) then - if (timeNow .GT. timeLBCnew) then - call ufs_mpas_atm_update_bdy_tend(clock, domain_ptr % blocklist, .false., 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 + !if (timeNow .GT. timeLBCnew) then + 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., 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 @@ -613,18 +616,15 @@ subroutine ufs_mpas_run() 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') + ! ! Compute diagnostic fields (theta, rho, pres) from ! the final prognostic state (theta_m, rho_zz, zz) ! call atm_compute_output_diagnostics(state, 1, diag, mesh) - call mpas_pool_get_array(diag, 'theta', theta2) - call mpas_pool_get_array(diag, 'uReconstructZonal', ux2) - call mpas_pool_get_array(diag, 'uReconstructMeridional', uy2) - print*,'SWALES theta2 = ', theta2(1,1), ux2(1,1), uy2(1,1) - + ! ! Write any output streams ! From 88b026996364dd61c9030199a03518e4b83340db Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 20 Nov 2025 23:39:08 +0000 Subject: [PATCH 06/45] Turned on some more pieces of the coupling --- mpas/atmos_model.F90 | 22 ++++++++++++++++++---- mpas/ufs_mpas_subdriver.F90 | 7 +++++++ 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/mpas/atmos_model.F90 b/mpas/atmos_model.F90 index 5fa30a71e..bec030cc1 100644 --- a/mpas/atmos_model.F90 +++ b/mpas/atmos_model.F90 @@ -273,6 +273,14 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm ! Populate UFSATM data containers with MPAS "input" stream. We need to do this becuase ! we are calling the physics before the 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 the same 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) ! Initialize the CCPP framework @@ -321,13 +329,19 @@ subroutine atmos_model_radiation_physics(Atmos) ! Call CCPP Timestep_initialize Group call mpp_clock_begin(setupClock) - !call CCPP_step (step="timestep_init", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') + 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 @@ -335,7 +349,7 @@ subroutine atmos_model_radiation_physics(Atmos) ! Call CCPP Physics Group call mpp_clock_begin(physClock) - !call CCPP_step (step="physics", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') + 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) @@ -353,7 +367,7 @@ subroutine atmos_model_dynamics(Atmos) type (atmos_control_type), intent(inout) :: Atmos ! Prepare MPAS dycore inputs with CCPP physics outputs. - !call ufs_physics_to_mpas(UFSATM_stateout) + call ufs_physics_to_mpas(UFSATM_stateout) ! Call MPAS dycore call mpp_clock_begin(mpasClock) @@ -361,7 +375,7 @@ subroutine atmos_model_dynamics(Atmos) call mpp_clock_end(mpasClock) ! Prepare CCPP physics inputs with MPAS dycore outputs. - !call ufs_mpas_to_physics(UFSATM_statein) + call ufs_mpas_to_physics(UFSATM_statein) end subroutine atmos_model_dynamics diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index 6d9b01523..84586be0f 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -516,6 +516,10 @@ subroutine ufs_mpas_run() 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) + + ! + ! DJS2025 BEGIN Diagnostic block + ! call atm_compute_output_diagnostics(state, 1, diag, mesh) call mpas_pool_get_array(diag, 'theta', theta1) call mpas_pool_get_array(mesh, 'lonCell', lon) @@ -527,6 +531,9 @@ subroutine ufs_mpas_run() call mpas_pool_get_dimension(mesh, 'nCells', nCells_ptr) call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve_ptr) print*,'MPAS_DEBUG0 ', lon(10), lat(10), theta1(10,1) + ! + ! DJS2025 END Diagnostic block + ! ! Eventually, dt should be domain specific call mpas_pool_get_config( domain_ptr % blocklist % configs, 'config_dt', config_dt) From 538a76e4615c1d486fe550f422c77b45426f47a2 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 8 Dec 2025 23:05:47 +0000 Subject: [PATCH 07/45] Dycore only working! --- mpas/atmos_coupling.F90 | 284 ++++++------------------------------ mpas/atmos_model.F90 | 47 +++--- mpas/ufs_mpas_subdriver.F90 | 28 +++- 3 files changed, 88 insertions(+), 271 deletions(-) diff --git a/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 index 1a3db289b..bc47e4eb8 100644 --- a/mpas/atmos_coupling.F90 +++ b/mpas/atmos_coupling.F90 @@ -11,14 +11,11 @@ module atmos_coupling_mod 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 - ! 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. !> !> ####################################################################################### @@ -83,14 +80,12 @@ module atmos_coupling_mod ! from physics [kg K/m^3/s] (nlev,ncol) real(mpas_kind), pointer :: rho_tend(:,:) ! Dry air density tendency ! from physics [kg/m^3/s] (nlev,ncol) - contains - procedure :: populate => populate_MPAS_statein end type MPAS_statein_type !> ####################################################################################### !> MPAS_stateout_type - !> !> Fields prognosed (or diagnosed) by the MPAS dynamical core. + !> !> ####################################################################################### type MPAS_stateout_type ! Dimensions @@ -138,13 +133,18 @@ module atmos_coupling_mod ! (nlev,nvtx) real(mpas_kind), pointer :: divergence(:,:) ! Horizontal velocity divergence [s^-1] ! (nlev,ncol) - contains - procedure :: populate => populate_MPAS_stateout 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 + !> + !> 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) @@ -162,8 +162,7 @@ subroutine ufs_mpas_to_physics(physics_state) type(mpas_pool_type), pointer :: mesh_pool integer :: iCol, iTracer integer, pointer :: nCellsSolve, num_scalars, nwat, index_qv, nVertLevels - real(RKIND), pointer :: surface_p(:) - + ! 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) @@ -187,7 +186,7 @@ subroutine ufs_mpas_to_physics(physics_state) 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) - + ! Copy fields from MPAS data containers to physics data containers. ! [k, i] -> [i, k] ! bottom-up -> top-down ordering convention @@ -220,14 +219,24 @@ subroutine ufs_mpas_to_physics(physics_state) physics_state % prsl(iCol,:) = MPAS_state % pmiddry(nVertLevels:1:-1,iCol) physics_state % prsi(iCol,:) = MPAS_state % pintdry(nVertLevels+1:1:-1,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 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 ! Arguments type(GFS_stateout_type), intent(in ) :: physics_state @@ -238,8 +247,26 @@ subroutine ufs_physics_to_mpas(physics_state) ! top-down -> bottom-up ordering convention ! Thermodynamic conversions from moist (CCPP) to dry (MPAS) - end subroutine ufs_physics_to_mpas + 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. !> @@ -250,6 +277,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) @@ -340,222 +370,4 @@ 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 - use mpas_derived_types, only : mpas_pool_type - ! Arguments - character(len=*), intent(in) :: varname - ! Locals - character(len=*), parameter :: subname = 'atmos_coupling::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) - - allocate(newArray(n1+n2)) - - newArray(1:n1) = array1(:) - newArray(n1+1:n1+n2) = array2(:) - - deallocate(array1) - array1 => newArray - end subroutine mergeArrays - - !> ####################################################################################### - !> - !> ####################################################################################### - subroutine populate_MPAS_statein(state) - 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 - implicit none - class(MPAS_statein_type) :: state - type(mpas_pool_type), pointer :: state_pool, diag_pool, mesh_pool - integer, pointer :: nCells, nEdges, nVertices, nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, index_qv - - 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) - - ! Let dynamics import state point to memory managed by MPAS-Atmosphere - call mpas_pool_get_dimension(mesh_pool, 'nCells', nCells) - call mpas_pool_get_dimension(mesh_pool, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh_pool, 'nVertices', nVertices) - call mpas_pool_get_dimension(mesh_pool, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(mesh_pool, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(mesh_pool, 'nEdgesSolve', nEdgesSolve) - call mpas_pool_get_dimension(mesh_pool, 'nVerticesSolve', nVerticesSolve) - call mpas_pool_get_dimension(state_pool, 'index_qv', index_qv) - state % nCells = nCells - state % nEdges = nEdges - state % nVertices = nVertices - state % nVertLevels = nVertLevels - state % nCellsSolve = nCellsSolve - state % nEdgesSolve = nEdgesSolve - state % nVerticesSolve = nVerticesSolve - state % index_qv = index_qv - - ! In MPAS timeLevel=1 is the current state. So the fields input to the dycore should - ! be in timeLevel=1. - call mpas_pool_get_array(state_pool, 'u', state % uperp, timeLevel=1) - call mpas_pool_get_array(state_pool, 'w', state % w, timeLevel=1) - call mpas_pool_get_array(state_pool, 'theta_m', state % theta_m, timeLevel=1) - call mpas_pool_get_array(state_pool, 'rho_zz', state % rho_zz, timeLevel=1) - call mpas_pool_get_array(state_pool, 'scalars', state % tracers, timeLevel=1) - call mpas_pool_get_array(diag_pool, 'rho_base', state % rho_base) - call mpas_pool_get_array(diag_pool, 'theta_base', state % theta_base) - call mpas_pool_get_array(mesh_pool, 'zgrid', state % zint) - call mpas_pool_get_array(mesh_pool, 'zz', state % zz) - call mpas_pool_get_array(mesh_pool, 'fzm', state % fzm) - call mpas_pool_get_array(mesh_pool, 'fzp', state % fzp) - call mpas_pool_get_array(mesh_pool, 'areaCell', state % areaCell) - call mpas_pool_get_array(mesh_pool, 'east', state % east) - call mpas_pool_get_array(mesh_pool, 'north', state % north) - call mpas_pool_get_array(mesh_pool, 'edgeNormalVectors', state % normal) - call mpas_pool_get_array(mesh_pool, 'cellsOnEdge', state % cellsOnEdge) - call mpas_pool_get_array(diag_pool, 'theta', state % theta) - call mpas_pool_get_array(diag_pool, 'exner', state % exner) - call mpas_pool_get_array(diag_pool, 'rho', state % rho) - call mpas_pool_get_array(diag_pool, 'uReconstructZonal', state % ux) - call mpas_pool_get_array(diag_pool, 'uReconstructMeridional', state % uy) - - end subroutine populate_MPAS_statein - - !> ####################################################################################### - !> - !> ####################################################################################### - subroutine populate_MPAS_stateout(stateout, statein) - implicit none - class(MPAS_stateout_type) :: stateout - type(MPAS_statein_type), intent(in) :: statein - - ! Let dynamics export state point to memory managed by MPAS-Atmosphere - ! Exception: pmiddry and pintdry are not managed by the MPAS infrastructure - stateout % nCells = statein % nCells - stateout % nEdges = statein % nEdges - stateout % nVertices = statein % nVertices - stateout % nVertLevels = statein % nVertLevels - stateout % nCellsSolve = statein % nCellsSolve - stateout % nEdgesSolve = statein % nEdgesSolve - stateout % nVerticesSolve = statein % nVerticesSolve - stateout % index_qv = statein % index_qv - - ! MPAS swaps pointers internally so that after a dycore timestep, the updated state is - ! in timeLevel=1. Thus we want stateout to also point to timeLevel=1. Can just copy - ! the pointers from statein. - stateout % uperp => statein % uperp - stateout % w => statein % w - stateout % theta_m => statein % theta_m - stateout % rho_zz => statein % rho_zz - stateout % tracers => statein % tracers - - ! These components don't have a time level index. - stateout % zint => statein % zint - stateout % zz => statein % zz - stateout % fzm => statein % fzm - stateout % fzp => statein % fzp - - stateout % theta => statein % theta - stateout % exner => statein % exner - stateout % rho => statein % rho - stateout % ux => statein % ux - stateout % uy => statein % uy - - end subroutine populate_MPAS_stateout end module atmos_coupling_mod diff --git a/mpas/atmos_model.F90 b/mpas/atmos_model.F90 index bec030cc1..029bad924 100644 --- a/mpas/atmos_model.F90 +++ b/mpas/atmos_model.F90 @@ -68,9 +68,9 @@ module atmos_model_mod 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 @@ -110,7 +110,7 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm use ufs_mpas_subdriver, only : ufs_mpas_open_init, ufs_mpas_open_lbc use ufs_mpas_module, only : ufs_mpas_define_scalars use ufs_mpas_module, only : constituent_name, is_water_species - use atmos_coupling_mod, only : ufs_mpas_to_physics, get_mpas_pio_decomp + use atmos_coupling_mod, only : ufs_mpas_to_physics use MPAS_init, only : MPAS_initialize ! Arguments @@ -217,10 +217,6 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm !> ######################################################################################### !> ######################################################################################### - ! 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 @@ -261,23 +257,13 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm call MPAS_initialize(UFSATM_control, UFSATM_intdiag, UFSATM_grid, UFSATM_tbd, UFSATM_sfcprop, & UFSATM_statein, UFSATM_cldprop, UFSATM_radtend, UFSATM_coupling, Cfg) - ! Get longitude/latitude/area from MPAS to use in the physics. - ! DJS2025: lonCell and latCell are defined by nCells, including halo points, whereas - ! xlon and xlat are allocated by nCellsSolve, excluding halo points. - ! Need to be able to grab lon and lat for nCellsSolve. - !UFSATM_grid % xlon = lonCell - !UFSATM_grid % xlat = latCell - !UFSATM_grid % xlon_d = lonCell*180./pi - !UFSATM_grid % xlat_d = latCell*180./pi - !UFSATM_grid % area = areaCellGlobal - ! Populate UFSATM data containers with MPAS "input" stream. We need to do this becuase - ! we are calling the physics before the dynamical core. + ! 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 the same routine + ! 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. ! @@ -302,7 +288,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) @@ -348,6 +334,7 @@ subroutine atmos_model_radiation_physics(Atmos) 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') @@ -361,21 +348,19 @@ 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_microphysics_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_microphysics_to_mpas(UFSATM_stateout) ! 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) end subroutine atmos_model_dynamics @@ -384,11 +369,17 @@ end subroutine atmos_model_dynamics !> !> ######################################################################################### subroutine atmos_model_microphysics(Atmos) + use atmos_coupling_mod, only : ufs_mpas_to_microphysics 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') @@ -401,8 +392,10 @@ subroutine atmos_model_microphysics(Atmos) call mpp_clock_end(setupClock) 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 diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index 84586be0f..f84318795 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -260,7 +260,8 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni 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) + ! ! Read in static (invariant) data ! @@ -278,6 +279,7 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', mesh) call mpas_rbf_interp_initialize(mesh) call mpas_init_reconstruct(mesh) + nullify (mesh) !call dyn_mpas_cell_to_edge_winds() @@ -371,6 +373,7 @@ subroutine ufs_mpas_atm_core_init(Cfg) call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) call mpas_atm_set_dims(nVertLevels1, maxEdges1, maxEdges2, num_scalars) Cfg % levs = nVertLevels1 !DJS: Do we need this? + nullify (state) ! ! Set "local" clock to point to the clock contained in the domain type @@ -411,6 +414,7 @@ subroutine ufs_mpas_atm_core_init(Cfg) call mpas_log_write('Initializing time levels') call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) call mpas_pool_initialize_time_levels(state) + nullify (state) end if call mpas_log_write('Initializing atmospheric variables') @@ -451,6 +455,7 @@ subroutine ufs_mpas_atm_core_init(Cfg) 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_array(state, 'xtime', xtime, timelevel=1) xtime = startTimeStamp @@ -461,6 +466,7 @@ subroutine ufs_mpas_atm_core_init(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 + nullify (state) call exchange_halo_group(domain_ptr, 'initialization:pv_edge,ru,rw',ierr=ierr) if ( ierr /= 0 ) then @@ -512,7 +518,8 @@ subroutine ufs_mpas_run() type(mpas_timeinterval_type) :: mpas_time_interval real(RKIND), dimension(:,:), pointer :: theta1, ux1, uy1, theta2, ux2, uy2 real(RKIND), dimension(:), pointer :: lon,lat - integer, pointer :: nCells_ptr,nCellsSolve_ptr + real(RKIND), allocatable :: lon_p(:), lat_p(:) + integer, pointer :: nCellsSolve 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) @@ -526,11 +533,15 @@ subroutine ufs_mpas_run() call mpas_pool_get_array(mesh, 'latCell', lat) call mpas_pool_get_array(diag, 'uReconstructZonal', ux1) call mpas_pool_get_array(diag, 'uReconstructMeridional', uy1) - lon = lon*180/3.14 - lat = lat*180/3.14 - call mpas_pool_get_dimension(mesh, 'nCells', nCells_ptr) - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve_ptr) - print*,'MPAS_DEBUG0 ', lon(10), lat(10), theta1(10,1) + + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + allocate(lon_p(nCellsSolve)) + allocate(lat_p(nCellsSolve)) + call mpas_pool_get_array(mesh, 'lonCell', lon) + call mpas_pool_get_array(mesh, 'latCell', lat) + lon_p = lon*180/3.14 + lat_p = lat*180/3.14 + !print*,'MPAS_DEBUG2 ', lon_p(10), lat_p(10), theta1(1,10) ! ! DJS2025 END Diagnostic block ! @@ -587,10 +598,11 @@ subroutine ufs_mpas_run() end if ! call mpas_log_write(' Start timestep at '//trim(timeStamp)) - ! ! Read future boundary state and compute boundary tendencies ! + ! DJS: Currently we are not updating the LBCs ars we integrate. Bad.Bad. + ! Need to extend ufs_mpas_atm_update_bdy_tend() accordingly. if (config_apply_lbcs) then !if (timeNow .GT. timeLBCnew) then call mpas_log_write('--------------------------------------------------') From f9bd651536c379b87f0a221420b415178d7e5288 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Tue, 6 Jan 2026 09:14:56 -0700 Subject: [PATCH 08/45] Stash for port to Ursa --- mpas/ufs_mpas_module.F90 | 40 ++++++++++++++++++++++++------------- mpas/ufs_mpas_subdriver.F90 | 5 +++-- 2 files changed, 29 insertions(+), 16 deletions(-) diff --git a/mpas/ufs_mpas_module.F90 b/mpas/ufs_mpas_module.F90 index 870b0fed1..762dc0b3e 100644 --- a/mpas/ufs_mpas_module.F90 +++ b/mpas/ufs_mpas_module.F90 @@ -10,9 +10,9 @@ !> ########################################################################################### module ufs_mpas_module use mpas_derived_types, only : core_type, domain_type, mpas_Clock_type - use mpas_derived_types, only : mpas_time_type + use mpas_derived_types, only : MPAS_Time_Type use mpas_kind_types, only : StrKIND - use mpas_atm_boundaries, only : LBC_intv_end + !use mpas_atm_boundaries, only : LBC_intv_end implicit none public @@ -27,6 +27,9 @@ module ufs_mpas_module integer, allocatable :: index_constituent_to_mpas_scalar(:) integer, allocatable :: index_mpas_scalar_to_constituent(:) logical, allocatable :: is_water_species(:) + + private + type (MPAS_Time_Type) :: LBC_intv_end !> ######################################################################################### !> @@ -328,7 +331,7 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) 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_Time_type, MPAS_TimeInterval_type + use mpas_derived_types, only : MPAS_TimeInterval_type use mpas_timekeeping, only : mpas_set_time use mpas_kind_types, only : StrKIND, RKIND use mpas_derived_types, only : MPAS_STREAM_LATEST_BEFORE @@ -420,12 +423,15 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) return end if - !read_time = '2023-03-10_18:00:00' - !call mpas_set_time(currTime, dateTimeString=trim(read_time)) - currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) - call mpas_get_time(currTime, dateTimeString=read_time, ierr=ierr) - call mpas_set_time(currTime,dateTimeString=trim(read_time)) - !print*,'read_time=',read_time + call mpas_set_time(currTime, dateTimeString=trim(read_time)) + call mpas_log_write(' ufs_mpas_atm_update_bdy_tend read_time = '//read_time) + + !currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) + !call mpas_get_time(currTime, dateTimeString=read_time, ierr=ierr) + !call mpas_set_time(currTime,dateTimeString=trim(read_time)) + !call mpas_log_write(' ufs_mpas_atm_update_bdy_tend read_time = '//read_time) + + ! ! Compute any derived fields from those that were read from the lbc_in stream ! @@ -501,13 +507,19 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) if (.not. firstCall) then lbc_interval = currTime - LBC_intv_end + 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(' ufs_mpas_atm_update_bdy_tend LBC_intv_end = '//trim(lbc_intv_start_string)) + call mpas_log_write(' ufs_mpas_atm_update_bdy_tend currTime = '//trim(lbc_intv_end_string)) + 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)) - !print*,'SWALES ufs_mpas_atm_update_bdy_tend dd_intv = ',dd_intv - !print*,'SWALES ufs_mpas_atm_update_bdy_tend s_intv = ',s_intv - !print*,'SWALES ufs_mpas_atm_update_bdy_tend sn_intv = ',sn_intv - !print*,'SWALES ufs_mpas_atm_update_bdy_tend sd_intv = ',sd_intv + !DJS This lbc_interval should increase? + call mpas_log_write(' ufs_mpas_atm_update_bdy_tend dd_intv = '//stringify([dd_intv])) + call mpas_log_write(' ufs_mpas_atm_update_bdy_tend s_intv = '//stringify([s_intv])) + call mpas_log_write(' ufs_mpas_atm_update_bdy_tend sn_intv = '//stringify([sn_intv])) + call mpas_log_write(' ufs_mpas_atm_update_bdy_tend sd_intv = '//stringify([sd_intv])) dt = 1.0_RKIND / dt @@ -1383,7 +1395,7 @@ end subroutine dyn_mpas_read_write_stream !> ######################################################################################## subroutine read_stream(stream, timeLevel, when, whence, actualWhen, ierr) use mpas_io_streams, only : mpas_readstream - use mpas_derived_types, only : MPAS_Time_type, MPAS_TimeInterval_type + use mpas_derived_types, only : MPAS_TimeInterval_type use mpas_derived_types, only : mpas_pool_type, mpas_stream_noerr, mpas_stream_type type(mpas_stream_type), pointer, intent(inout) :: stream diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index f84318795..70c7ee96c 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -601,13 +601,14 @@ subroutine ufs_mpas_run() ! ! Read future boundary state and compute boundary tendencies ! - ! DJS: Currently we are not updating the LBCs ars we integrate. Bad.Bad. + ! DJS: Currently we are not updating the LBCs as we integrate. Bad.Bad. ! Need to extend ufs_mpas_atm_update_bdy_tend() accordingly. if (config_apply_lbcs) then !if (timeNow .GT. timeLBCnew) then 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., ierr) + !call mpas_log_write(' '// + call ufs_mpas_atm_update_bdy_tend(clock, domain_ptr % blocklist, .false., 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 From acc8c4e29a6cb35d1221835344f2dc071589a023 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 7 Jan 2026 19:13:47 -0500 Subject: [PATCH 09/45] move private statement to fix compilation failure --- mpas/ufs_mpas_module.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/mpas/ufs_mpas_module.F90 b/mpas/ufs_mpas_module.F90 index 762dc0b3e..11127bebb 100644 --- a/mpas/ufs_mpas_module.F90 +++ b/mpas/ufs_mpas_module.F90 @@ -28,8 +28,7 @@ module ufs_mpas_module integer, allocatable :: index_mpas_scalar_to_constituent(:) logical, allocatable :: is_water_species(:) - private - type (MPAS_Time_Type) :: LBC_intv_end + private type (MPAS_Time_Type) :: LBC_intv_end !> ######################################################################################### !> From 440cad9af723e41b0fcda282fd8e290b069e58ba Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 7 Jan 2026 19:26:56 -0500 Subject: [PATCH 10/45] fix private syntax --- mpas/ufs_mpas_module.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mpas/ufs_mpas_module.F90 b/mpas/ufs_mpas_module.F90 index 11127bebb..6fb8b50f4 100644 --- a/mpas/ufs_mpas_module.F90 +++ b/mpas/ufs_mpas_module.F90 @@ -28,7 +28,7 @@ module ufs_mpas_module integer, allocatable :: index_mpas_scalar_to_constituent(:) logical, allocatable :: is_water_species(:) - private type (MPAS_Time_Type) :: LBC_intv_end + type(MPAS_Time_Type), private :: LBC_intv_end !> ######################################################################################### !> From 1b576df3d91eace664c97da596ffefe023f88e18 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 8 Jan 2026 23:02:08 +0000 Subject: [PATCH 11/45] Changes to ingest scalars/constituents/tracers/yadayada correctly --- mpas/atmos_model.F90 | 33 +++++++++++++++++++++++---------- mpas/ufs_mpas_module.F90 | 32 ++++++++++++-------------------- mpas/ufs_mpas_subdriver.F90 | 12 +++++++++--- 3 files changed, 44 insertions(+), 33 deletions(-) diff --git a/mpas/atmos_model.F90 b/mpas/atmos_model.F90 index 029bad924..9f01232bc 100644 --- a/mpas/atmos_model.F90 +++ b/mpas/atmos_model.F90 @@ -108,7 +108,6 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm use ufs_mpas_subdriver, only : MPAS_control_type use ufs_mpas_subdriver, only : ufs_mpas_init use ufs_mpas_subdriver, only : ufs_mpas_open_init, ufs_mpas_open_lbc - use ufs_mpas_module, only : ufs_mpas_define_scalars use ufs_mpas_module, only : constituent_name, is_water_species use atmos_coupling_mod, only : ufs_mpas_to_physics use MPAS_init, only : MPAS_initialize @@ -160,16 +159,35 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm ierr = check_nml_error(io, 'atmos_model_nml') 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) @@ -204,12 +222,7 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm logunits(2) = mpas_logfile_handle endif - call ufs_mpas_init(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) !> ######################################################################################### !> ######################################################################################### diff --git a/mpas/ufs_mpas_module.F90 b/mpas/ufs_mpas_module.F90 index 762dc0b3e..3a0d98870 100644 --- a/mpas/ufs_mpas_module.F90 +++ b/mpas/ufs_mpas_module.F90 @@ -12,7 +12,7 @@ module ufs_mpas_module 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 mpas_atm_boundaries, only : LBC_intv_end + use mpas_atm_boundaries, only : LBC_intv_end implicit none public @@ -27,9 +27,6 @@ module ufs_mpas_module integer, allocatable :: index_constituent_to_mpas_scalar(:) integer, allocatable :: index_mpas_scalar_to_constituent(:) logical, allocatable :: is_water_species(:) - - private - type (MPAS_Time_Type) :: LBC_intv_end !> ######################################################################################### !> @@ -48,8 +45,8 @@ module ufs_mpas_module 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) & + var_info_type('lbc_theta' , 'real' , 2), & + var_info_type('lbc_scalars' , 'real' , 3) & ] !> ######################################################################################### @@ -144,7 +141,7 @@ module ufs_mpas_module 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('scalars' , 'real' , 3), & var_info_type('theta' , 'real' , 2), & var_info_type('theta_base' , 'real' , 2), & var_info_type('u' , 'real' , 2), & @@ -717,12 +714,12 @@ subroutine ufs_mpas_define_scalars(mpas_from_ufs_cnst, ufs_from_mpas_cnst, ierr) end if ! - ! In UFS, the first scalar (if there are any) is always sphum (specific humidity); if this is not + ! 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)) /= 'sphum') then - call mpas_log_write(trim(subname)//': ERROR: The first constituent is not sphum', messageType=MPAS_LOG_ERR) + 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 @@ -1394,7 +1391,7 @@ end subroutine dyn_mpas_read_write_stream !> !> ######################################################################################## subroutine read_stream(stream, timeLevel, when, whence, actualWhen, ierr) - use mpas_io_streams, only : mpas_readstream + use mpas_io_streams, only : MPAS_readStream, MPAS_streamTime use mpas_derived_types, only : MPAS_TimeInterval_type use mpas_derived_types, only : mpas_pool_type, mpas_stream_noerr, mpas_stream_type @@ -1405,15 +1402,10 @@ subroutine read_stream(stream, timeLevel, when, whence, actualWhen, ierr) character (len=*), intent(out), optional :: actualWhen integer, intent(out) :: ierr - type (MPAS_Time_type) :: now_time - type (MPAS_TimeInterval_type) :: filename_interval - integer :: local_ierr - character (len=StrKIND) :: temp_filename - - !call mpas_set_time(now_time, dateTimeString=whence, ierr=local_ierr) - !call mpas_set_timeInterval(filename_interval, timeString=stream % filename_interval) - - call mpas_readstream(stream, timeLevel, ierr=ierr) + call MPAS_readStream(stream, timeLevel, ierr=ierr) + if (present(actualWhen)) then + call MPAS_streamTime(stream, timeLevel, actualWhen, ierr=ierr) + endif end subroutine read_stream !> ######################################################################################## diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index 70c7ee96c..bcae91658 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -96,7 +96,8 @@ module ufs_mpas_subdriver !> Follows mpas_init() in MPAS-Model/src/driver/mpas_subdriver.F !> !> ######################################################################################### - subroutine ufs_mpas_init(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 @@ -126,6 +127,7 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni 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' integer :: i, ndate1, ndate2, tod, ierr, ik, kk @@ -261,6 +263,11 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni 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 ! ! Read in static (invariant) data @@ -401,7 +408,7 @@ subroutine ufs_mpas_atm_core_init(Cfg) ! Read in initial-conditions ! call mpas_log_write('Reading in MPAS initial condition stream.') - call dyn_mpas_read_write_stream(clock, 'r', 'input-scalars', pio_file_desc=pioid_ic, ierr=ierr, timeLevel=1, whence=mpas_NOW) + call dyn_mpas_read_write_stream(clock, 'r', 'input', pio_file_desc=pioid_ic, ierr=ierr, timeLevel=1, whence=mpas_NOW) ! ! Read in restart data. @@ -607,7 +614,6 @@ subroutine ufs_mpas_run() !if (timeNow .GT. timeLBCnew) then call mpas_log_write('--------------------------------------------------') call mpas_log_write('Update lateral boundary conditions for timestep '//trim(timeStamp)) - !call mpas_log_write(' '// call ufs_mpas_atm_update_bdy_tend(clock, domain_ptr % blocklist, .false., ierr) if (ierr /= 0) then call mpas_log_write('Failed to process LBC data at next time after '//trim(timeStamp), messageType=MPAS_LOG_ERR) From 56ac1738c461878662af9761224e29b482fb9dbb Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 15 Jan 2026 17:46:59 +0000 Subject: [PATCH 12/45] update ccpp/physics branch --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index ac63f3193..477f5a348 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit ac63f31931368b6fbeb3114e5c611ad3473a73cb +Subproject commit 477f5a348488eb9ea3fa6d2d09e74a7858ce183b From 0374ed24dca18511e69337efd533ee4a864a107f Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 15 Jan 2026 17:26:14 -0500 Subject: [PATCH 13/45] add lat/lon from MPAS to physics state --- mpas/atmos_coupling.F90 | 18 +++++++++++++----- mpas/atmos_model.F90 | 2 +- 2 files changed, 14 insertions(+), 6 deletions(-) diff --git a/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 index bc47e4eb8..8b51ec3b6 100644 --- a/mpas/atmos_coupling.F90 +++ b/mpas/atmos_coupling.F90 @@ -106,7 +106,10 @@ module atmos_coupling_mod ! layer interface [1] (nlev) real(mpas_kind), pointer :: fzp(:) ! Interp weight from k-1 layer midpoint to k ! layer interface [dimensionless] (nlev) - + ! MPAS horizontal coordinate (invariant) + real(mpas_kind), pointer :: lat(:) ! latitude (ncol) + real(mpas_kind), pointer :: lon(:) ! longitude (ncol) + ! Indices for tracer (scalar) indices integer, pointer :: index_qv ! Tracer index for water-vapor mixing-ratio @@ -147,14 +150,14 @@ module atmos_coupling_mod !> 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, physics_grid) + use GFS_typedefs, only : GFS_statein_type, GFS_grid_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 ! Arguments - type(GFS_statein_type), intent(inout) :: physics_state + type(GFS_statein_type), intent(inout) :: physics_state, physics_grid ! Locals type(mpas_stateout_type) :: mpas_state type(mpas_pool_type), pointer :: state_pool @@ -186,6 +189,8 @@ subroutine ufs_mpas_to_physics(physics_state) 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(mesh_pool, 'latCell', MPAS_state % lat) + call mpas_pool_get_array(mesh_pool, 'lonCell', MPAS_state % lon) ! Copy fields from MPAS data containers to physics data containers. ! [k, i] -> [i, k] @@ -202,7 +207,10 @@ subroutine ufs_mpas_to_physics(physics_state) physics_state % qgrs(iCol,:,iTracer) = MPAS_state % tracers(iTracer,nVertLevels:1:-1,iCol) enddo enddo - + + physics_grid % xlat(:) = MPAS_state % lat(:) + physics_grid % xlon(:) = MPAS_state % lon(:) + ! Compute hydrostatic pressures allocate(MPAS_state % pmid( nVertLevels, nCellsSolve)) allocate(MPAS_state % pmiddry(nVertLevels, nCellsSolve)) diff --git a/mpas/atmos_model.F90 b/mpas/atmos_model.F90 index 9f01232bc..126ac75ec 100644 --- a/mpas/atmos_model.F90 +++ b/mpas/atmos_model.F90 @@ -280,7 +280,7 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm ! in a different "piece" later, but copying the Updated state from the dycore before calling ! the microphsyics. ! - call ufs_mpas_to_physics(UFSATM_statein) + call ufs_mpas_to_physics(UFSATM_statein, UFSATM_grid) ! Initialize the CCPP framework call CCPP_step (step="init", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') From 4000c89a53543e462d0b65ff94320799ef5a7745 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 15 Jan 2026 17:37:07 -0500 Subject: [PATCH 14/45] fix DDT for lat/lon --- mpas/atmos_coupling.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 index 8b51ec3b6..fa605c67d 100644 --- a/mpas/atmos_coupling.F90 +++ b/mpas/atmos_coupling.F90 @@ -157,7 +157,8 @@ subroutine ufs_mpas_to_physics(physics_state, physics_grid) use atm_core, only : atm_compute_output_diagnostics use mpas_kind_types, only : RKIND ! Arguments - type(GFS_statein_type), intent(inout) :: physics_state, physics_grid + type(GFS_statein_type), intent(inout) :: physics_state + type(GFS_grid_type), intent(inout) :: physics_grid ! Locals type(mpas_stateout_type) :: mpas_state type(mpas_pool_type), pointer :: state_pool From 6b73cf735dd50d951e06447a89b95bc2e5955388 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 15 Jan 2026 18:12:39 -0500 Subject: [PATCH 15/45] testing --- mpas/atmos_coupling.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 index fa605c67d..3e620e475 100644 --- a/mpas/atmos_coupling.F90 +++ b/mpas/atmos_coupling.F90 @@ -209,8 +209,8 @@ subroutine ufs_mpas_to_physics(physics_state, physics_grid) enddo enddo - physics_grid % xlat(:) = MPAS_state % lat(:) - physics_grid % xlon(:) = MPAS_state % lon(:) + physics_grid % xlat(1:iCol) = MPAS_state % lat(1:iCol) + physics_grid % xlon(1:iCol) = MPAS_state % lon(1:iCol) ! Compute hydrostatic pressures allocate(MPAS_state % pmid( nVertLevels, nCellsSolve)) From 12c44cb84a88aa31f70431f674c50d19fe8920a1 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 15 Jan 2026 23:51:31 +0000 Subject: [PATCH 16/45] fixed syntax - lat/lon transfer to physics working --- mpas/atmos_coupling.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 index 3e620e475..def96c157 100644 --- a/mpas/atmos_coupling.F90 +++ b/mpas/atmos_coupling.F90 @@ -209,8 +209,8 @@ subroutine ufs_mpas_to_physics(physics_state, physics_grid) enddo enddo - physics_grid % xlat(1:iCol) = MPAS_state % lat(1:iCol) - physics_grid % xlon(1:iCol) = MPAS_state % lon(1:iCol) + physics_grid % xlat(1:nCellsSolve) = MPAS_state % lat(1:nCellsSolve) + physics_grid % xlon(1:nCellsSolve) = MPAS_state % lon(1:nCellsSolve) ! Compute hydrostatic pressures allocate(MPAS_state % pmid( nVertLevels, nCellsSolve)) From c82de922be1bd3dd698db67dc00029fa5c681c4d Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 16 Jan 2026 15:35:15 -0500 Subject: [PATCH 17/45] move lat/lon read/transfer to ufs_mpas_grid_to_physics; fill out rest of grid DDT --- mpas/atmos_coupling.F90 | 104 ++++++++++++++++++++++++++++++++++------ mpas/atmos_model.F90 | 6 ++- 2 files changed, 94 insertions(+), 16 deletions(-) diff --git a/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 index def96c157..f1c9d7041 100644 --- a/mpas/atmos_coupling.F90 +++ b/mpas/atmos_coupling.F90 @@ -13,6 +13,7 @@ module atmos_coupling_mod public :: ufs_mpas_to_physics public :: ufs_microphysics_to_mpas public :: ufs_mpas_to_microphysics + public :: ufs_mpas_grid_to_physics !> ####################################################################################### !> MPAS_statein_type @@ -106,10 +107,7 @@ module atmos_coupling_mod ! layer interface [1] (nlev) real(mpas_kind), pointer :: fzp(:) ! Interp weight from k-1 layer midpoint to k ! layer interface [dimensionless] (nlev) - ! MPAS horizontal coordinate (invariant) - real(mpas_kind), pointer :: lat(:) ! latitude (ncol) - real(mpas_kind), pointer :: lon(:) ! longitude (ncol) - + ! Indices for tracer (scalar) indices integer, pointer :: index_qv ! Tracer index for water-vapor mixing-ratio @@ -150,15 +148,14 @@ module atmos_coupling_mod !> CCPP "state" needed by the physics. !> !> ######################################################################################### - subroutine ufs_mpas_to_physics(physics_state, physics_grid) - use GFS_typedefs, only : GFS_statein_type, GFS_grid_type + subroutine ufs_mpas_to_physics(physics_state) + use GFS_typedefs, only : GFS_statein_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 ! Arguments type(GFS_statein_type), intent(inout) :: physics_state - type(GFS_grid_type), intent(inout) :: physics_grid ! Locals type(mpas_stateout_type) :: mpas_state type(mpas_pool_type), pointer :: state_pool @@ -190,8 +187,6 @@ subroutine ufs_mpas_to_physics(physics_state, physics_grid) 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(mesh_pool, 'latCell', MPAS_state % lat) - call mpas_pool_get_array(mesh_pool, 'lonCell', MPAS_state % lon) ! Copy fields from MPAS data containers to physics data containers. ! [k, i] -> [i, k] @@ -207,11 +202,8 @@ subroutine ufs_mpas_to_physics(physics_state, physics_grid) do iTracer = 1,num_scalars physics_state % qgrs(iCol,:,iTracer) = MPAS_state % tracers(iTracer,nVertLevels:1:-1,iCol) enddo - enddo - - physics_grid % xlat(1:nCellsSolve) = MPAS_state % lat(1:nCellsSolve) - physics_grid % xlon(1:nCellsSolve) = MPAS_state % lon(1:nCellsSolve) - + enddo + ! Compute hydrostatic pressures allocate(MPAS_state % pmid( nVertLevels, nCellsSolve)) allocate(MPAS_state % pmiddry(nVertLevels, nCellsSolve)) @@ -378,5 +370,89 @@ subroutine hydrostatic_pressure(nCells, nVertLevels, qsize, index_qv, zz, zgrid, end do end do end subroutine hydrostatic_pressure + +!> ######################################################################################### +!> 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 mpp_mod, only : mpp_error + ! Arguments + type(GFS_grid_type), intent(inout) :: physics_grid + ! Locals + 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), parameter :: rad2deg = 180.0_RKIND/pii + + ierr = 0 + + ! 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) + nullify(config_len_disp) + call mpas_pool_get_config(domain_ptr % blocklist % configs, 'config_len_disp', config_len_disp) + + ! 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') + + 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 126ac75ec..9646b10c3 100644 --- a/mpas/atmos_model.F90 +++ b/mpas/atmos_model.F90 @@ -109,7 +109,7 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm use ufs_mpas_subdriver, only : ufs_mpas_init use ufs_mpas_subdriver, only : ufs_mpas_open_init, ufs_mpas_open_lbc use ufs_mpas_module, only : constituent_name, is_water_species - use atmos_coupling_mod, only : ufs_mpas_to_physics + use atmos_coupling_mod, only : ufs_mpas_to_physics, ufs_mpas_grid_to_physics use MPAS_init, only : MPAS_initialize ! Arguments @@ -269,6 +269,8 @@ 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_cldprop, UFSATM_radtend, UFSATM_coupling, Cfg) + + 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 MPAS dynamical core. @@ -280,7 +282,7 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm ! 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_grid) + call ufs_mpas_to_physics(UFSATM_statein) ! Initialize the CCPP framework call CCPP_step (step="init", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') From a2142eb6c27b745696d92cf45e93e5aa1eb43840 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 16 Jan 2026 20:49:51 +0000 Subject: [PATCH 18/45] fix compilation errors in atmos_coupling.F90 --- mpas/atmos_coupling.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 index f1c9d7041..cc3a02692 100644 --- a/mpas/atmos_coupling.F90 +++ b/mpas/atmos_coupling.F90 @@ -382,7 +382,8 @@ subroutine ufs_mpas_grid_to_physics(physics_grid) use mpas_kind_types, only : RKIND use mpas_constants, only : pii use mpas_log, only : mpas_log_write - use mpp_mod, only : mpp_error + use mpas_derived_types, only : MPAS_LOG_ERR, MPAS_LOG_WARN + use mpp_mod, only : mpp_error, FATAL ! Arguments type(GFS_grid_type), intent(inout) :: physics_grid ! Locals @@ -393,9 +394,10 @@ subroutine ufs_mpas_grid_to_physics(physics_grid) real(RKIND), pointer :: nominalMinDc real(RKIND), pointer :: config_len_disp - real(RKIND), parameter :: rad2deg = 180.0_RKIND/pii + 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) From b310590cbb2c535e9b7a09e71629035a60131314 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 22 Jan 2026 21:12:46 +0000 Subject: [PATCH 19/45] Updates for LBC scalars --- mpas/MPAS-Model | 2 +- mpas/ufs_mpas_module.F90 | 116 ++++++++++++++++++++++++++++++++---- mpas/ufs_mpas_subdriver.F90 | 50 ++++++++++++---- 3 files changed, 144 insertions(+), 24 deletions(-) diff --git a/mpas/MPAS-Model b/mpas/MPAS-Model index ac90200e1..ad992db61 160000 --- a/mpas/MPAS-Model +++ b/mpas/MPAS-Model @@ -1 +1 @@ -Subproject commit ac90200e197f47f533138939203ffe757f9dc423 +Subproject commit ad992db6153885498709f165c4beea91a0eae8ee diff --git a/mpas/ufs_mpas_module.F90 b/mpas/ufs_mpas_module.F90 index 3a0d98870..bc8e02128 100644 --- a/mpas/ufs_mpas_module.F90 +++ b/mpas/ufs_mpas_module.F90 @@ -467,6 +467,8 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) nVertLevels = nVertLevels_ptr nScalars = nScalars_ptr index_qv = index_qv_ptr + call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: nlbc_scalars = '//stringify([nScalars_ptr])) + call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: shape(lbc_scalars) = '//stringify([shape(scalars)) ! Compute lbc_rho_zz do k=1,nVertLevels @@ -542,7 +544,10 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) lbc_tend_rho(k,iCell) = (rho(k,iCell) - lbc_tend_rho(k,iCell)) * dt end do end do - + + call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: nCells = '//stringify([nCells])) + call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: nVertLevels = '//stringify([nVertLevels])) + call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: nScalars = '//stringify([nScalars])) do iCell=1,nCells+1 do k=1,nVertLevels do j = 1,nScalars @@ -860,6 +865,86 @@ subroutine ufs_mpas_define_scalars(mpas_from_ufs_cnst, ufs_from_mpas_cnst, ierr) call mpas_pool_add_dimension(tendPool, 'moist_end', num_moist) end subroutine ufs_mpas_define_scalars + + !> ######################################################################################## + !> + !> ######################################################################################## + 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))) + call mpas_log_write('IMP_DIAG scalarsField % constituentNames(j) = '//trim(scalarsField % constituentNames(j))) + end do + + end do + + 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 !> ######################################################################################## !> @@ -2350,11 +2435,14 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, case (3) call mpas_pool_get_field(domain_ptr % blocklist % allfields, & trim(adjustl(var_info % name)), field_3d_real, timelevel=1) - + call mpas_log_write('IMP_DIAG check_variable_status name = '//trim(adjustl(var_info % name))) if (.not. associated(field_3d_real)) then call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') end if - + call mpas_log_write('IMP_DIAG check_variable_status vararray = '//stringify([field_3d_real % isvararray])) + if (associated(field_3d_real % constituentnames)) then + call mpas_log_write('IMP_DIAG check_variable_status nconst = '//stringify([size(field_3d_real % constituentnames)])) + 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) @@ -2364,7 +2452,9 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, var_name_list(:) = field_3d_real % constituentnames(:) end if - + if (associated(field_3d_real % constituentnames)) then + call mpas_log_write('IMP_DIAG check_variable_status nconst2 = '//stringify([size(field_3d_real % constituentnames)])) + end if nullify(field_3d_real) case (4) call mpas_pool_get_field(domain_ptr % blocklist % allfields, & @@ -2413,6 +2503,7 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, '" for "' // trim(adjustl(var_info % name)) // '"') end select + call mpas_log_write('IMP_DIAG check_variable_status 1') if (.not. allocated(var_name_list)) then allocate(var_name_list(1), stat=ierr) @@ -2422,7 +2513,7 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, var_name_list(1) = var_info % name end if - + call mpas_log_write('IMP_DIAG check_variable_status 2') allocate(var_is_present(size(var_name_list)), stat=ierr) if (ierr /= 0) then @@ -2430,14 +2521,14 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, end if var_is_present(:) = .false. - + call mpas_log_write('IMP_DIAG check_variable_status 3') 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. - + call mpas_log_write('IMP_DIAG check_variable_status 4') if (.not. associated(pio_file)) then return end if @@ -2448,11 +2539,12 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, call mpas_log_write('Checking variable "' // trim(adjustl(var_info % name)) // & '" for presence and TKR compatibility') - + call mpas_log_write('IMP_DIAG check_variable_status 5 size(var_name_list) = '//stringify([size(var_name_list)])) do i = 1, size(var_name_list) ! Check if the variable is present on the file. + call mpas_log_write('IMP_DIAG check_variable_status 5 var_name_list(i) = '//trim(adjustl(var_name_list(i)))) ierr = pio_inq_varid(pio_file, trim(adjustl(var_name_list(i))), varid) - + call mpas_log_write('IMP_DIAG check_variable_status 5b') if (ierr /= pio_noerr) then cycle end if @@ -2492,10 +2584,10 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, case default cycle end select - + call mpas_log_write('IMP_DIAG check_variable_status 5c') ! Check if the variable is TK"R" compatible between MPAS and the file. ierr = pio_inq_varndims(pio_file, varid, varndims) - + call mpas_log_write('IMP_DIAG check_variable_status 5d') if (ierr /= pio_noerr) then cycle end if @@ -2506,7 +2598,7 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, var_is_tkr_compatible(i) = .true. end do - + call mpas_log_write('IMP_DIAG check_variable_status 6') 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)) diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index bcae91658..3d887dcf2 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -107,7 +107,7 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni use mpas_bootstrapping, only : mpas_bootstrap_framework_phase1 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_pool_type, mpas_IO_NETCDF, field3dReal, MPAS_STREAM_LATEST_BEFORE, 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 @@ -131,10 +131,10 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni ! Locals 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(:) ! Setup MPAS infrastructure allocate(corelist, stat=ierr) @@ -258,21 +258,41 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni 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_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) + 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 + ! ! Read in static (invariant) data ! call dyn_mpas_read_write_stream(domain_ptr % clock, 'r', 'invariant', pio_file_desc=pioid_ic, ierr=ierr, timeLevel=1, whence=mpas_NOW) + 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 @@ -323,7 +343,7 @@ end subroutine ufs_mpas_init 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 + 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 @@ -355,8 +375,7 @@ subroutine ufs_mpas_atm_core_init(Cfg) 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 @@ -409,11 +428,20 @@ subroutine ufs_mpas_atm_core_init(Cfg) ! 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) + 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 + + ! What is the shape of scalars? + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) + call mpas_pool_get_array(state, 'scalars',field_3d_real, timelevel=1) + call mpas_log_write('IMP_DIAG ufs_mpas_atm_core_init: shape(scalars) = '//stringify([shape(field_3d_real)])) ! ! Read in restart data. ! - !call mpas_log_write('Reading in MPAS restart stream.' + !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) @@ -614,7 +642,7 @@ subroutine ufs_mpas_run() !if (timeNow .GT. timeLBCnew) then 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., ierr) + !call ufs_mpas_atm_update_bdy_tend(clock, domain_ptr % blocklist, .false., 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 From af37da54ca7d26b3a190731374fdc80dda001fe7 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 22 Jan 2026 23:51:31 +0000 Subject: [PATCH 20/45] Start adding model grid fields needed for physics --- mpas/CMakeLists.txt | 2 ++ mpas/MPAS-Model | 2 +- mpas/atmos_coupling.F90 | 15 +++++++++----- mpas/ufs_mpas_module.F90 | 39 ++++++++++++++++++++++++++++++++++++- mpas/ufs_mpas_subdriver.F90 | 27 ++++++++++++++++--------- 5 files changed, 69 insertions(+), 16 deletions(-) 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 ad992db61..0a1c1ca1e 160000 --- a/mpas/MPAS-Model +++ b/mpas/MPAS-Model @@ -1 +1 @@ -Subproject commit ad992db6153885498709f165c4beea91a0eae8ee +Subproject commit 0a1c1ca1e36e57031ee17dfa6918721be5fe1905 diff --git a/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 index cc3a02692..8d9b05944 100644 --- a/mpas/atmos_coupling.F90 +++ b/mpas/atmos_coupling.F90 @@ -161,13 +161,18 @@ subroutine ufs_mpas_to_physics(physics_state) type(mpas_pool_type), pointer :: state_pool type(mpas_pool_type), pointer :: diag_pool type(mpas_pool_type), pointer :: mesh_pool + type(mpas_pool_type), pointer :: sfc_pool integer :: iCol, iTracer integer, pointer :: nCellsSolve, num_scalars, nwat, index_qv, nVertLevels - + integer, dimension(:), pointer :: isltyp ! 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) @@ -370,7 +375,7 @@ subroutine hydrostatic_pressure(nCells, nVertLevels, qsize, index_qv, zz, zgrid, end do end do end subroutine hydrostatic_pressure - + !> ######################################################################################### !> Procedure to transfer MPAS grid information to physics DDTs. !> diff --git a/mpas/ufs_mpas_module.F90 b/mpas/ufs_mpas_module.F90 index bc8e02128..488f867b0 100644 --- a/mpas/ufs_mpas_module.F90 +++ b/mpas/ufs_mpas_module.F90 @@ -149,6 +149,41 @@ module ufs_mpas_module var_info_type('xtime' , 'character' , 0) & ] + !> ######################################################################################### + !> 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) & + ] + !> ######################################################################################### !> This list corresponds to the "restart" stream in MPAS registry. !> It consists of variables that are members of the "diag" and "state" structure. @@ -468,7 +503,7 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) nScalars = nScalars_ptr index_qv = index_qv_ptr call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: nlbc_scalars = '//stringify([nScalars_ptr])) - call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: shape(lbc_scalars) = '//stringify([shape(scalars)) + call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: shape(lbc_scalars) = '//stringify([shape(scalars)])) ! Compute lbc_rho_zz do k=1,nVertLevels @@ -2045,6 +2080,8 @@ pure function parse_stream_name_fragment(stream_name_fragment) result(var_info_l 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 default allocate(var_info_list(0)) diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index 3d887dcf2..2517dac7e 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -135,6 +135,7 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni type (field3dReal), pointer :: scalarsField character (len=StrKIND), pointer :: initial_time, config_start_time integer, pointer :: num_scalars, mpas_from_ufs_cnst2(:), ufs_from_mpas_cnst2(:) + logical, pointer :: config_apply_lbcs ! Setup MPAS infrastructure allocate(corelist, stat=ierr) @@ -274,15 +275,18 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni ! ! Setup scalars for LBC pool and scalars_tend for LBC pool. ! - 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) - 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.') + 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) + 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 ! @@ -432,6 +436,11 @@ subroutine ufs_mpas_atm_core_init(Cfg) 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) + 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 ! What is the shape of scalars? call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) From 30174426d64b55f449afdfd20ec24ab2cd2efe1f Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 2 Feb 2026 20:21:55 +0000 Subject: [PATCH 21/45] More changes for LBCs --- mpas/ufs_mpas_module.F90 | 86 +++++++++++++++++++------------------ mpas/ufs_mpas_subdriver.F90 | 66 +++++++++++++++++----------- 2 files changed, 85 insertions(+), 67 deletions(-) diff --git a/mpas/ufs_mpas_module.F90 b/mpas/ufs_mpas_module.F90 index 488f867b0..c97774f65 100644 --- a/mpas/ufs_mpas_module.F90 +++ b/mpas/ufs_mpas_module.F90 @@ -357,7 +357,7 @@ end function stringify !> \update: Dustin Swales September 2025 - Modified for use in UWM !> !> ######################################################################################### - subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) + subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, nRecord, ierr) use mpas_constants, only : rvord use mpas_stream_manager, only : mpas_stream_mgr_read use mpas_log, only : mpas_log_write @@ -380,6 +380,7 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) 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 @@ -433,9 +434,10 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) call mpas_pool_get_subpool(block % structs, 'state', state) call mpas_pool_get_subpool(block % structs, 'lbc', lbc) + call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: nRecord = '//stringify([nRecord])) 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) + 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) @@ -444,7 +446,7 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) 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) + 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) @@ -456,13 +458,7 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) end if call mpas_set_time(currTime, dateTimeString=trim(read_time)) - call mpas_log_write(' ufs_mpas_atm_update_bdy_tend read_time = '//read_time) - - !currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) - !call mpas_get_time(currTime, dateTimeString=read_time, ierr=ierr) - !call mpas_set_time(currTime,dateTimeString=trim(read_time)) - !call mpas_log_write(' ufs_mpas_atm_update_bdy_tend read_time = '//read_time) - + call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: read_time = '//read_time) ! ! Compute any derived fields from those that were read from the lbc_in stream @@ -540,22 +536,26 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) end do if (.not. firstCall) then - lbc_interval = currTime - LBC_intv_end - 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(' ufs_mpas_atm_update_bdy_tend LBC_intv_end = '//trim(lbc_intv_start_string)) - call mpas_log_write(' ufs_mpas_atm_update_bdy_tend currTime = '//trim(lbc_intv_end_string)) + ! DJS2026: Implementation Diagnostics (To be removed) + 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('IMP_DIAG ufs_mpas_atm_update_bdy_tend: LBC_intv_end = '//trim(lbc_intv_start_string)) + call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: currTime = '//trim(lbc_intv_end_string)) + 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)) + + ! DJS2026: Implementation Diagnostics (To be removed) !DJS This lbc_interval should increase? - call mpas_log_write(' ufs_mpas_atm_update_bdy_tend dd_intv = '//stringify([dd_intv])) - call mpas_log_write(' ufs_mpas_atm_update_bdy_tend s_intv = '//stringify([s_intv])) - call mpas_log_write(' ufs_mpas_atm_update_bdy_tend sn_intv = '//stringify([sn_intv])) - call mpas_log_write(' ufs_mpas_atm_update_bdy_tend sd_intv = '//stringify([sd_intv])) + call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: dd_intv = '//stringify([dd_intv])) + call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: s_intv = '//stringify([s_intv])) + call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: sn_intv = '//stringify([sn_intv])) + call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: sd_intv = '//stringify([sd_intv])) dt = 1.0_RKIND / dt + call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: dt = '//stringify([dt])) do iEdge=1,nEdges+1 do k=1,nVertLevels @@ -571,6 +571,7 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, ierr) end do end do + print*,'SWALES theta/theta_tend = ',theta(1,2),lbc_tend_theta(1,2) do iCell=1,nCells+1 do k=1,nVertLevels lbc_tend_theta(k,iCell) = (theta(k,iCell) - lbc_tend_theta(k,iCell)) * dt @@ -1370,7 +1371,7 @@ end subroutine dyn_mpas_exchange_halo !> \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, ierr) + 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 @@ -1391,6 +1392,7 @@ subroutine dyn_mpas_read_write_stream(clock, stream_mode, stream_name, pio_file_ 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 character(*), parameter :: subname = 'dyn_mpas_subdriver::dyn_mpas_read_write_stream' @@ -1431,7 +1433,7 @@ subroutine dyn_mpas_read_write_stream(clock, stream_mode, stream_name, pio_file_ 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) + call dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file_desc, stream_mode, stream_name) if (.not. associated(mpas_pool)) then call mpp_error(FATAL,subname//'Failed to initialize stream "' // trim(adjustl(stream_name)) // '"') @@ -1445,7 +1447,7 @@ subroutine dyn_mpas_read_write_stream(clock, stream_mode, stream_name, pio_file_ case ('r', 'read') call mpas_log_write('Reading stream "' // trim(adjustl(stream_name)) // '"') - call read_stream(mpas_stream, timeLevel, local_when, local_whence, actualWhen, ierr) + call read_stream(mpas_stream, local_when, local_whence, actualWhen, nRecord, ierr) if (ierr /= mpas_stream_noerr) then call mpp_error(FATAL,subname//'Failed to read stream "' // trim(adjustl(stream_name)) // '"') @@ -1474,7 +1476,7 @@ subroutine dyn_mpas_read_write_stream(clock, stream_mode, stream_name, pio_file_ call prewrite_reindex(domain_ptr % blocklist % allfields, domain_ptr % packages, & mpas_pool, mpas_pool) - call mpas_writestream(mpas_stream, timeLevel, ierr=ierr) + 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)) // '"') @@ -1510,21 +1512,22 @@ end subroutine dyn_mpas_read_write_stream !> !> !> ######################################################################################## - subroutine read_stream(stream, timeLevel, when, whence, actualWhen, ierr) + subroutine read_stream(stream, when, whence, actualWhen, nRecord, ierr) use mpas_io_streams, only : MPAS_readStream, MPAS_streamTime use mpas_derived_types, only : MPAS_TimeInterval_type 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) :: timeLevel + !integer, intent(in) :: timeLevel character (len=*), intent(in) :: when - integer, intent(in) :: whence + integer, intent(in) :: whence + integer, intent(in) :: nRecord character (len=*), intent(out), optional :: actualWhen integer, intent(out) :: ierr - call MPAS_readStream(stream, timeLevel, ierr=ierr) + call MPAS_readStream(stream, nRecord, ierr=ierr) if (present(actualWhen)) then - call MPAS_streamTime(stream, timeLevel, actualWhen, ierr=ierr) + call MPAS_streamTime(stream, nRecord, actualWhen, ierr=ierr) endif end subroutine read_stream @@ -1547,7 +1550,7 @@ end subroutine read_stream !> !> ######################################################################################## subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stream_mode, & - stream_name, timeLevel) + stream_name) ! Module(s) from external libraries. use pio, only: file_desc_t, pio_file_is_open ! Module(s) from MPAS. @@ -1568,7 +1571,6 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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 @@ -1699,7 +1701,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1710,7 +1712,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1727,7 +1729,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1738,7 +1740,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1749,7 +1751,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1760,7 +1762,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1777,7 +1779,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1788,7 +1790,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1799,7 +1801,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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 @@ -1808,7 +1810,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1818,7 +1820,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1829,7 +1831,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index 2517dac7e..cfcf011c5 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -42,6 +42,8 @@ module ufs_mpas_subdriver public :: ufs_mpas_open_init public :: ufs_mpas_open_lbc + logical :: init_lbc = .true. + integer :: nRecord_lbc = 1 !> ######################################################################################### !> !> ######################################################################################### @@ -282,6 +284,7 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni 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 @@ -292,7 +295,7 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni ! ! Read in static (invariant) data ! - call dyn_mpas_read_write_stream(domain_ptr % clock, 'r', 'invariant', pio_file_desc=pioid_ic, ierr=ierr, timeLevel=1, whence=mpas_NOW) + 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 ') @@ -431,12 +434,12 @@ subroutine ufs_mpas_atm_core_init(Cfg) ! 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) + 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) + 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 ') @@ -546,14 +549,15 @@ 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(.LT.), operator(.GT.) + use mpas_timekeeping, only : mpas_set_timeInterval, operator(+), operator(.LT.), operator(.GT.), operator(.LE.) use ufs_mpas_module, only : ufs_mpas_atm_update_bdy_tend + use mpas_atm_boundaries, only : LBC_intv_end ! FMS use mpp_mod, only : FATAL, mpp_error ! 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_pool_type), pointer :: state, diag, mesh, lbc type (mpas_Time_type) :: timeNow, timeStop,timeLBCnew character(len=StrKIND) :: timeStamp integer :: ierr, itime, itimestep @@ -564,10 +568,12 @@ subroutine ufs_mpas_run() real(RKIND), dimension(:), pointer :: lon,lat real(RKIND), allocatable :: lon_p(:), lat_p(:) integer, pointer :: nCellsSolve + real (kind=RKIND), dimension(:,:), pointer :: theta, theta_tend + 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 mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', mesh) + ! ! DJS2025 BEGIN Diagnostic block ! @@ -611,24 +617,30 @@ subroutine ufs_mpas_run() call mpp_error(FATAL,subname//'Failed to set dynamics time step') endif + ! DO we need to update LBCs? + if (LBC_intv_end .LE. timeNow) then + call mpas_get_time(curr_time=timeNow, dateTimeString=timeStamp, ierr=ierr) + call mpas_log_write(' Time to update LBCs from '//trim(timeStamp)) + call mpas_get_time(curr_time=LBC_intv_end, dateTimeString=timeStamp, ierr=ierr) + call mpas_log_write(' Time to update LBCs to '//trim(timeStamp)) + endif + ! ! Read initial boundary state ! - if (config_apply_lbcs) then + 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., ierr) + 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. end if - ! Need to compute this somewhere. - !timeLBCnew - ! 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(...) + ! time step, and time level 2 stores the state advanced config_dt in time by timestep timeStop = timeNow + mpas_time_interval itimestep = 0 call mpas_log_write('--------------------------------------------------') @@ -640,25 +652,29 @@ subroutine ufs_mpas_run() if ( ierr /= 0 ) then call mpp_error(FATAL,subname//': Failed to get time mpas_NOW"') end if - ! call mpas_log_write(' Start timestep at '//trim(timeStamp)) + ! ! Read future boundary state and compute boundary tendencies ! - ! DJS: Currently we are not updating the LBCs as we integrate. Bad.Bad. - ! Need to extend ufs_mpas_atm_update_bdy_tend() accordingly. if (config_apply_lbcs) then - !if (timeNow .GT. timeLBCnew) then - 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., 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 + 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 end if - + + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'lbc', lbc) + call mpas_pool_get_array(lbc, 'lbc_theta', theta, 1) + call mpas_pool_get_array(lbc, 'lbc_theta', theta_tend, 2) + print*,'IMP_DEBUG theta = ',theta(1,2),theta_tend(1,2) + ! Integrate forward one dycore time step call mpas_timer_start('time integration') call mpas_dmpar_get_time(integ_start_time) From b9223519307760209e7b998010c81d9ea590ffa4 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 4 Feb 2026 23:00:50 +0000 Subject: [PATCH 22/45] LBCs working! --- .gitmodules | 4 +-- ccpp/physics | 2 +- mpas/ufs_mpas_module.F90 | 55 ++++++++++++------------------------- mpas/ufs_mpas_subdriver.F90 | 48 ++++---------------------------- 4 files changed, 25 insertions(+), 84 deletions(-) diff --git a/.gitmodules b/.gitmodules index 5e5f8d221..46cfa9cd3 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,8 +8,8 @@ branch = develop [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/ufs-community/ccpp-physics - branch = ufs/dev + url = https://github.com/dustinswales/ccpp-physics + branch = feature/mpas_in_ufs [submodule "upp"] path = upp url = https://github.com/NOAA-EMC/UPP diff --git a/ccpp/physics b/ccpp/physics index 477f5a348..c851dc512 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 477f5a348488eb9ea3fa6d2d09e74a7858ce183b +Subproject commit c851dc512cd1494a5b7bc7d711d01846321b5fb1 diff --git a/mpas/ufs_mpas_module.F90 b/mpas/ufs_mpas_module.F90 index c97774f65..945c2df83 100644 --- a/mpas/ufs_mpas_module.F90 +++ b/mpas/ufs_mpas_module.F90 @@ -434,7 +434,6 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, nRecord, ierr) call mpas_pool_get_subpool(block % structs, 'state', state) call mpas_pool_get_subpool(block % structs, 'lbc', lbc) - call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: nRecord = '//stringify([nRecord])) 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) @@ -458,7 +457,6 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, nRecord, ierr) end if call mpas_set_time(currTime, dateTimeString=trim(read_time)) - call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: read_time = '//read_time) ! ! Compute any derived fields from those that were read from the lbc_in stream @@ -492,14 +490,13 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, nRecord, ierr) 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 - call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: nlbc_scalars = '//stringify([nScalars_ptr])) - call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: shape(lbc_scalars) = '//stringify([shape(scalars)])) ! Compute lbc_rho_zz do k=1,nVertLevels @@ -536,26 +533,13 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, nRecord, ierr) end do if (.not. firstCall) then - ! DJS2026: Implementation Diagnostics (To be removed) - 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('IMP_DIAG ufs_mpas_atm_update_bdy_tend: LBC_intv_end = '//trim(lbc_intv_start_string)) - call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: currTime = '//trim(lbc_intv_end_string)) 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)) - ! DJS2026: Implementation Diagnostics (To be removed) - !DJS This lbc_interval should increase? - call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: dd_intv = '//stringify([dd_intv])) - call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: s_intv = '//stringify([s_intv])) - call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: sn_intv = '//stringify([sn_intv])) - call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: sd_intv = '//stringify([sd_intv])) - dt = 1.0_RKIND / dt - call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: dt = '//stringify([dt])) do iEdge=1,nEdges+1 do k=1,nVertLevels @@ -571,7 +555,6 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, nRecord, ierr) end do end do - print*,'SWALES theta/theta_tend = ',theta(1,2),lbc_tend_theta(1,2) do iCell=1,nCells+1 do k=1,nVertLevels lbc_tend_theta(k,iCell) = (theta(k,iCell) - lbc_tend_theta(k,iCell)) * dt @@ -581,9 +564,6 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, nRecord, ierr) end do end do - call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: nCells = '//stringify([nCells])) - call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: nVertLevels = '//stringify([nVertLevels])) - call mpas_log_write('IMP_DIAG ufs_mpas_atm_update_bdy_tend: nScalars = '//stringify([nScalars])) do iCell=1,nCells+1 do k=1,nVertLevels do j = 1,nScalars @@ -605,7 +585,6 @@ subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, nRecord, ierr) call mpas_log_write('----------------------------------------------------------------------') end if - LBC_intv_end = currTime end subroutine ufs_mpas_atm_update_bdy_tend @@ -972,7 +951,6 @@ subroutine ufs_mpas_define_lbc_scalars(mpas_from_ufs_cnst, ufs_from_mpas_cnst, i do j = 2, size(constituent_name) scalarsField % constituentNames(j) = 'lbc_'//trim(constituent_name(mpas_from_ufs_cnst(j))) - call mpas_log_write('IMP_DIAG scalarsField % constituentNames(j) = '//trim(scalarsField % constituentNames(j))) end do end do @@ -1433,7 +1411,7 @@ subroutine dyn_mpas_read_write_stream(clock, stream_mode, stream_name, pio_file_ 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) + 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)) // '"') @@ -1518,7 +1496,6 @@ subroutine read_stream(stream, when, whence, actualWhen, nRecord, ierr) 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) :: timeLevel character (len=*), intent(in) :: when integer, intent(in) :: whence integer, intent(in) :: nRecord @@ -1531,6 +1508,7 @@ subroutine read_stream(stream, when, whence, actualWhen, nRecord, ierr) endif end subroutine read_stream + !> ######################################################################################## !> subroutine dyn_mpas_init_stream_with_pool !> @@ -1550,7 +1528,7 @@ end subroutine read_stream !> !> ######################################################################################## subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stream_mode, & - stream_name) + stream_name, timeLevel) ! Module(s) from external libraries. use pio, only: file_desc_t, pio_file_is_open ! Module(s) from MPAS. @@ -1571,6 +1549,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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 @@ -1701,7 +1680,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1712,7 +1691,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1729,7 +1708,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1740,7 +1719,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1751,7 +1730,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1762,7 +1741,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1779,7 +1758,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1790,7 +1769,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1801,7 +1780,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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 @@ -1810,7 +1789,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1820,7 +1799,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') @@ -1831,7 +1810,7 @@ subroutine dyn_mpas_init_stream_with_pool(mpas_pool, mpas_stream, pio_file, stre 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) + 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)) // '"') diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index cfcf011c5..ab3fd8b35 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -318,10 +318,11 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni !call dyn_mpas_cell_to_edge_winds() ! Read the global sphere_radius attribute. This is needed to normalize the cell areas. - ierr = pio_get_att(pioid_ic, 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 + call mpas_log_write('sphere_radius = '//stringify([domain_ptr % sphere_radius])) ! FROM CAM/dyn_grid.F90:dyn_grid_init() ! Query global grid dimensions from MPAS @@ -557,45 +558,18 @@ subroutine ufs_mpas_run() ! 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, lbc + type (mpas_pool_type), pointer :: state, diag, mesh type (mpas_Time_type) :: timeNow, timeStop,timeLBCnew character(len=StrKIND) :: timeStamp integer :: ierr, itime, itimestep real (kind=R8KIND) :: integ_start_time, integ_stop_time logical, pointer :: config_apply_lbcs type(mpas_timeinterval_type) :: mpas_time_interval - real(RKIND), dimension(:,:), pointer :: theta1, ux1, uy1, theta2, ux2, uy2 - real(RKIND), dimension(:), pointer :: lon,lat - real(RKIND), allocatable :: lon_p(:), lat_p(:) - integer, pointer :: nCellsSolve - real (kind=RKIND), dimension(:,:), pointer :: theta, theta_tend 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) - ! - ! DJS2025 BEGIN Diagnostic block - ! - call atm_compute_output_diagnostics(state, 1, diag, mesh) - call mpas_pool_get_array(diag, 'theta', theta1) - call mpas_pool_get_array(mesh, 'lonCell', lon) - call mpas_pool_get_array(mesh, 'latCell', lat) - call mpas_pool_get_array(diag, 'uReconstructZonal', ux1) - call mpas_pool_get_array(diag, 'uReconstructMeridional', uy1) - - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) - allocate(lon_p(nCellsSolve)) - allocate(lat_p(nCellsSolve)) - call mpas_pool_get_array(mesh, 'lonCell', lon) - call mpas_pool_get_array(mesh, 'latCell', lat) - lon_p = lon*180/3.14 - lat_p = lat*180/3.14 - !print*,'MPAS_DEBUG2 ', lon_p(10), lat_p(10), theta1(1,10) - ! - ! DJS2025 END Diagnostic block - ! - ! 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) @@ -617,17 +591,10 @@ subroutine ufs_mpas_run() call mpp_error(FATAL,subname//'Failed to set dynamics time step') endif - ! DO we need to update LBCs? - if (LBC_intv_end .LE. timeNow) then - call mpas_get_time(curr_time=timeNow, dateTimeString=timeStamp, ierr=ierr) - call mpas_log_write(' Time to update LBCs from '//trim(timeStamp)) - call mpas_get_time(curr_time=LBC_intv_end, dateTimeString=timeStamp, ierr=ierr) - call mpas_log_write(' Time to update LBCs to '//trim(timeStamp)) - 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)) @@ -670,11 +637,6 @@ subroutine ufs_mpas_run() end if end if - call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'lbc', lbc) - call mpas_pool_get_array(lbc, 'lbc_theta', theta, 1) - call mpas_pool_get_array(lbc, 'lbc_theta', theta_tend, 2) - print*,'IMP_DEBUG theta = ',theta(1,2),theta_tend(1,2) - ! Integrate forward one dycore time step call mpas_timer_start('time integration') call mpas_dmpar_get_time(integ_start_time) From 07993cd0bfafab0df07f3d0c8254978a6f8bc8e7 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 4 Feb 2026 23:45:36 +0000 Subject: [PATCH 23/45] Updated/synced mpas dycore --- mpas/MPAS-Model | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mpas/MPAS-Model b/mpas/MPAS-Model index 0a1c1ca1e..a7069ac00 160000 --- a/mpas/MPAS-Model +++ b/mpas/MPAS-Model @@ -1 +1 @@ -Subproject commit 0a1c1ca1e36e57031ee17dfa6918721be5fe1905 +Subproject commit a7069ac00da054039f160a6fb17f12c23b613a98 From 74a906e2d5915be7cc3dd67a241887d7229c75d5 Mon Sep 17 00:00:00 2001 From: Soren Rasmussen Date: Sat, 7 Feb 2026 10:23:30 -0700 Subject: [PATCH 24/45] Write MPAS output file and whitespace cleanup --- mpas/module_mpas_config.F90 | 18 +++++-- mpas/ufs_mpas_subdriver.F90 | 105 ++++++++++++++++++++++++++++-------- ufsatm_cap.F90 | 10 +++- 3 files changed, 106 insertions(+), 27 deletions(-) diff --git a/mpas/module_mpas_config.F90 b/mpas/module_mpas_config.F90 index 9659ddff2..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,17 +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_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 - + 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(:) @@ -86,7 +96,7 @@ module module_mpas_config nVertLevelsSolve real(r4), pointer :: latCell(:), lonCell(:) - + !> Global gridded data integer :: nCellsGlobal ! global number of cells/columns integer :: nEdgesGlobal ! global number of edges @@ -96,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_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index ab3fd8b35..b8e4cd79b 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -33,7 +33,7 @@ module ufs_mpas_subdriver use module_mpas_config, only : latCellGlobal, lonCellGlobal, areaCellGlobal use ufs_mpas_module implicit none - + private public :: MPAS_control_type @@ -60,7 +60,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 @@ -87,11 +87,11 @@ 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 contains - + !> ######################################################################################### !> Procedure to initialize UWM with MPAS dynamical core. !> @@ -199,7 +199,7 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni 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') @@ -316,7 +316,7 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni nullify (mesh) !call dyn_mpas_cell_to_edge_winds() - + ! Read the global sphere_radius attribute. This is needed to normalize the cell areas. ierr = pio_get_att(pioid_ic, pio_global, 'sphere_radius', domain_ptr % sphere_radius) if( ierr /= 0 ) then @@ -339,7 +339,7 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni ! Initialize core ! call ufs_mpas_atm_core_init(Cfg) - + end subroutine ufs_mpas_init !> ######################################################################################## @@ -466,11 +466,11 @@ subroutine ufs_mpas_atm_core_init(Cfg) end if call mpas_log_write('Initializing atmospheric variables') - + ! How many calls to MPAS dycore for each ATMosphere time step? 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 ! @@ -498,7 +498,7 @@ subroutine ufs_mpas_atm_core_init(Cfg) call mpas_log_write('Please correct issues with the model input fields and/or namelist.') return end if - + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', mesh) call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) @@ -515,7 +515,7 @@ subroutine ufs_mpas_atm_core_init(Cfg) call mpas_pool_get_array(state, 'initial_time', initial_time2, timelevel=2) initial_time2 = initial_time1 nullify (state) - + call exchange_halo_group(domain_ptr, 'initialization:pv_edge,ru,rw',ierr=ierr) if ( ierr /= 0 ) then call mpp_error(FATAL,subname//'Failed to exchange halo layers for group "initialization:ru,rw"') @@ -562,14 +562,14 @@ subroutine ufs_mpas_run() type (mpas_Time_type) :: timeNow, timeStop,timeLBCnew character(len=StrKIND) :: timeStamp integer :: ierr, itime, itimestep - real (kind=R8KIND) :: integ_start_time, integ_stop_time + real (kind=R8KIND) :: integ_start_time, integ_stop_time logical, pointer :: config_apply_lbcs type(mpas_timeinterval_type) :: mpas_time_interval 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 mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'mesh', 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) @@ -579,7 +579,7 @@ subroutine ufs_mpas_run() 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"') @@ -669,13 +669,76 @@ subroutine ufs_mpas_run() ! ! Write any output streams ! + call ufs_mpas_write("output") + call ufs_mpas_write("restart") + end subroutine ufs_mpas_run - + subroutine ufs_mpas_write(stream_name) + use pio, only : pio_openfile, pio_createfile, PIO_WRITE, PIO_CLOBBER + use module_mpas_config, only : ic_filename, pioid_output, & + pio_subsystem_output, output_filename, restart_filename, & + pio_subsystem_output_file_created, & + TIMELEVEL_NOW, pio_subsystem_output_record + 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 + ! 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 = output_filename + else if (trim(stream_name) == "restart") then + filename = restart_filename + 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 (.not. pio_subsystem_output_file_created) then + ierr = pio_createfile(pio_subsystem_output, pioid_output, pio_iotype, & + trim(filename)) + if ( ierr /= 0 ) call mpp_error(FATAL, & + subname//": pio_createfile failed ") + pio_subsystem_output_file_created = .true. + else + ! ierr = pio_openfile(pio_subsystem_output, pioid_output, pio_iotype, & + ! output_filename, PIO_WRITE) + ! if ( ierr /= 0 ) call mpp_error(FATAL, subname//": pio_openfile failed") + stop "Appending to pio file has not been implemented yet" + end if + + 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=pio_subsystem_output_record, ierr=ierr) + if ( ierr /= 0 ) call mpp_error(FATAL, & + subname//": dyn_mpas_read_write_stream failed ") + + ! advance record so writing appends + pio_subsystem_output_record = pio_subsystem_output_record + 1 + ! TODO: resetting variables until appending to pio is fixed + pio_subsystem_output_record = 1 + pio_subsystem_output_file_created = .false. + if (debug) call mpas_log_write("exiting ufs_mpas_write") + end subroutine ufs_mpas_write + !> ######################################################################################### !> Procedure to open MPAS IC file. !> - !> ######################################################################################### + !> ######################################################################################### subroutine ufs_mpas_open_init() ! PIO use pio, only : pio_openfile, pio_nowrite @@ -723,7 +786,7 @@ subroutine ufs_mpas_open_lbc() call mpp_error(FATAL,subname//": Cannot find MPAS LBC file: "//trim(lbc_filename)) end if end subroutine ufs_mpas_open_lbc - + !> ######################################################################################### !> Procedure to read MPAS namelist(s). !> @@ -810,7 +873,7 @@ 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_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, & @@ -878,7 +941,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) @@ -935,7 +998,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 ! diff --git a/ufsatm_cap.F90 b/ufsatm_cap.F90 index 742e48c33..fb4c7e568 100644 --- a/ufsatm_cap.F90 +++ b/ufsatm_cap.F90 @@ -39,6 +39,7 @@ module ufsatm_cap_mod use module_mpas_config, only: output_fh, dt_atmos, calendar, & fcst_mpi_comm, pio_ioformat, pio_iotype, & 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 @@ -253,6 +254,7 @@ subroutine InitializeAdvertise(gcomp, rc) integer :: ngrids type(ESMF_Grid) :: src_grid, dst_grid type(ESMF_Field), allocatable :: dst_field_mask(:) + integer :: ierr ! !------------------------------------------------------------------------ ! @@ -447,7 +449,11 @@ subroutine InitializeAdvertise(gcomp, rc) 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 call NUOPC_CompAttributeGet(gcomp, name='pio_debug_level', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) @@ -1374,7 +1380,7 @@ end subroutine InitializeRealize !----------------------------------------------------------------------------- subroutine ModelAdvance(gcomp, rc) - + use mpi_f08, only : MPI_Wtime type(ESMF_GridComp) :: gcomp From e669b79e8d6089a7bb78c73330600b347decf9e9 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 9 Feb 2026 15:59:26 +0000 Subject: [PATCH 25/45] Move to MPAS UFS registry file. --- mpas/MPAS-Model | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mpas/MPAS-Model b/mpas/MPAS-Model index a7069ac00..ac26705d5 160000 --- a/mpas/MPAS-Model +++ b/mpas/MPAS-Model @@ -1 +1 @@ -Subproject commit a7069ac00da054039f160a6fb17f12c23b613a98 +Subproject commit ac26705d57cfc56dbc6e97d4c8ff54b8f64afe8d From 3ace3bd71f9a2bd6300cce89b9a0c083c9fd2cb6 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 9 Feb 2026 16:10:36 +0000 Subject: [PATCH 26/45] Revert "Move to MPAS UFS registry file." This reverts commit e669b79e8d6089a7bb78c73330600b347decf9e9. --- mpas/MPAS-Model | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mpas/MPAS-Model b/mpas/MPAS-Model index ac26705d5..a7069ac00 160000 --- a/mpas/MPAS-Model +++ b/mpas/MPAS-Model @@ -1 +1 @@ -Subproject commit ac26705d57cfc56dbc6e97d4c8ff54b8f64afe8d +Subproject commit a7069ac00da054039f160a6fb17f12c23b613a98 From 1532430d4a0c6d5a6eb24319b0ff416361cb0cbb Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 9 Feb 2026 22:52:25 +0000 Subject: [PATCH 27/45] Update registry files in MPAS and stream definitions in UWM --- mpas/MPAS-Model | 2 +- mpas/ufs_mpas_module.F90 | 66 ++++++++++++++++++++++++++++++------- mpas/ufs_mpas_subdriver.F90 | 41 ++++++++++------------- 3 files changed, 74 insertions(+), 35 deletions(-) diff --git a/mpas/MPAS-Model b/mpas/MPAS-Model index a7069ac00..99890240d 160000 --- a/mpas/MPAS-Model +++ b/mpas/MPAS-Model @@ -1 +1 @@ -Subproject commit a7069ac00da054039f160a6fb17f12c23b613a98 +Subproject commit 99890240d93a6b28a75f84c9f7248161797656ae diff --git a/mpas/ufs_mpas_module.F90 b/mpas/ufs_mpas_module.F90 index 945c2df83..906098971 100644 --- a/mpas/ufs_mpas_module.F90 +++ b/mpas/ufs_mpas_module.F90 @@ -125,12 +125,6 @@ module ufs_mpas_module 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" structure. @@ -149,10 +143,37 @@ module ufs_mpas_module 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. + !> 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), & @@ -181,7 +202,22 @@ module ufs_mpas_module 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('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) & ] !> ######################################################################################### @@ -211,13 +247,19 @@ module ufs_mpas_module !> 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('uReconstructMeridional' , 'real' , 2), & - var_info_type('uReconstructZonal' , 'real' , 2), & - var_info_type('vorticity' , 'real' , 2) & + var_info_type('theta' , 'real' , 2), & + var_info_type('u' , 'real' , 2), & + var_info_type('vorticity' , 'real' , 2), & + var_info_type('w' , 'real' , 2), & + var_info_type('zz' , 'real' , 2) & ] contains @@ -2063,6 +2105,8 @@ pure function parse_stream_name_fragment(stream_name_fragment) result(var_info_l 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)) diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index b8e4cd79b..45558fb6e 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -669,12 +669,20 @@ subroutine ufs_mpas_run() ! ! Write any output streams ! - call ufs_mpas_write("output") - call ufs_mpas_write("restart") + 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 + call ufs_mpas_write("output", timeStamp) + !call ufs_mpas_write("restart") end subroutine ufs_mpas_run - subroutine ufs_mpas_write(stream_name) + !> ######################################################################################### + !> Procedure to create and write to MPAS stream + !> + !> ######################################################################################### + subroutine ufs_mpas_write(stream_name, timestamp) use pio, only : pio_openfile, pio_createfile, PIO_WRITE, PIO_CLOBBER use module_mpas_config, only : ic_filename, pioid_output, & pio_subsystem_output, output_filename, restart_filename, & @@ -685,6 +693,7 @@ subroutine ufs_mpas_write(stream_name) 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' @@ -695,27 +704,18 @@ subroutine ufs_mpas_write(stream_name) logical, parameter :: debug = .true. if (trim(stream_name) == "output") then - filename = output_filename + filename = 'history.'//trim(timestamp)//'.nc' else if (trim(stream_name) == "restart") then - filename = restart_filename + filename = 'restart.'//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 (.not. pio_subsystem_output_file_created) then - ierr = pio_createfile(pio_subsystem_output, pioid_output, pio_iotype, & - trim(filename)) - if ( ierr /= 0 ) call mpp_error(FATAL, & - subname//": pio_createfile failed ") - pio_subsystem_output_file_created = .true. - else - ! ierr = pio_openfile(pio_subsystem_output, pioid_output, pio_iotype, & - ! output_filename, PIO_WRITE) - ! if ( ierr /= 0 ) call mpp_error(FATAL, subname//": pio_openfile failed") - stop "Appending to pio file has not been implemented yet" - end if + 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 @@ -723,15 +723,10 @@ subroutine ufs_mpas_write(stream_name) call dyn_mpas_read_write_stream(clock, "write", stream_name, pioid_output, & timeLevel=timelevel, whence=whence, & - nRecord=pio_subsystem_output_record, ierr=ierr) + nRecord=1, ierr=ierr) if ( ierr /= 0 ) call mpp_error(FATAL, & subname//": dyn_mpas_read_write_stream failed ") - ! advance record so writing appends - pio_subsystem_output_record = pio_subsystem_output_record + 1 - ! TODO: resetting variables until appending to pio is fixed - pio_subsystem_output_record = 1 - pio_subsystem_output_file_created = .false. if (debug) call mpas_log_write("exiting ufs_mpas_write") end subroutine ufs_mpas_write From 6da1c6160c3f21ed078d07ea41267343c4bdc546 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 24 Feb 2026 00:01:19 +0000 Subject: [PATCH 28/45] Cleanup --- mpas/ufs_mpas_module.F90 | 58 ++++--------------------------------- mpas/ufs_mpas_subdriver.F90 | 7 +++-- 2 files changed, 9 insertions(+), 56 deletions(-) diff --git a/mpas/ufs_mpas_module.F90 b/mpas/ufs_mpas_module.F90 index 906098971..8a4372555 100644 --- a/mpas/ufs_mpas_module.F90 +++ b/mpas/ufs_mpas_module.F90 @@ -259,7 +259,11 @@ module ufs_mpas_module var_info_type('u' , 'real' , 2), & var_info_type('vorticity' , 'real' , 2), & var_info_type('w' , 'real' , 2), & - var_info_type('zz' , 'real' , 2) & + var_info_type('zz' , 'real' , 2), & + 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) & ] contains @@ -2668,56 +2672,4 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, call mpas_log_write(subname // ' completed') end subroutine dyn_mpas_check_variable_status - !> ######################################################################################## - ! routine dyn_mpas_cell_to_edge_winds - ! - !> \brief Projects cell-centered winds to the normal component of velocity on edges - !> \author Michael Duda - !> \date 16 January 2020 - !> \details - !> Given zonal and meridional winds at cell centers, unit vectors in the east - !> and north directions at cell centers, and unit vectors in the normal - !> direction at edges, this routine projects the cell-centered winds onto - !> the normal vectors. - !> - !> Prior to calling this routine, the halos for the zonal and meridional - !> components of cell-centered winds should be updated. It is also critical - !> that the east, north, uZonal, and uMerid field are all allocated with - !> a "garbage" element; this is handled automatically for fields allocated - !> by the MPAS infrastructure. - !> - !> ######################################################################################## - subroutine dyn_mpas_cell_to_edge_winds(nEdges, uZonal, uMerid, east, north, edgeNormalVectors, & - cellsOnEdge, uNormal) - use mpas_kind_types, only : RKIND - integer, intent(in) :: nEdges - real(kind=RKIND), dimension(:,:), intent(in) :: uZonal, uMerid - real(kind=RKIND), dimension(:,:), intent(in) :: east, north, edgeNormalVectors - integer, dimension(:,:), intent(in) :: cellsOnEdge - real(kind=RKIND), dimension(:,:), intent(out) :: uNormal - - integer :: iEdge, cell1, cell2 - - character(len=*), parameter :: subname = 'ufs_mpas_subdriver::dyn_mpas_cell_to_edge_winds' - - do iEdge = 1, nEdges - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - uNormal(:,iEdge) = uZonal(:,cell1)*0.5_RKIND*(edgeNormalVectors(1,iEdge)*east(1,cell1) & - + edgeNormalVectors(2,iEdge)*east(2,cell1) & - + edgeNormalVectors(3,iEdge)*east(3,cell1)) & - + uMerid(:,cell1)*0.5_RKIND*(edgeNormalVectors(1,iEdge)*north(1,cell1) & - + edgeNormalVectors(2,iEdge)*north(2,cell1) & - + edgeNormalVectors(3,iEdge)*north(3,cell1)) & - + uZonal(:,cell2)*0.5_RKIND*(edgeNormalVectors(1,iEdge)*east(1,cell2) & - + edgeNormalVectors(2,iEdge)*east(2,cell2) & - + edgeNormalVectors(3,iEdge)*east(3,cell2)) & - + uMerid(:,cell2)*0.5_RKIND*(edgeNormalVectors(1,iEdge)*north(1,cell2) & - + edgeNormalVectors(2,iEdge)*north(2,cell2) & - + edgeNormalVectors(3,iEdge)*north(3,cell2)) - end do - - end subroutine dyn_mpas_cell_to_edge_winds - end module ufs_mpas_module diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index 45558fb6e..24460c1e8 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -315,8 +315,6 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni call mpas_init_reconstruct(mesh) nullify (mesh) - !call dyn_mpas_cell_to_edge_winds() - ! Read the global sphere_radius attribute. This is needed to normalize the cell areas. ierr = pio_get_att(pioid_ic, pio_global, 'sphere_radius', domain_ptr % sphere_radius) if( ierr /= 0 ) then @@ -604,6 +602,8 @@ subroutine ufs_mpas_run() 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 @@ -674,7 +674,6 @@ subroutine ufs_mpas_run() call mpp_error(FATAL,subname//': Failed to get time timeStop"') end if call ufs_mpas_write("output", timeStamp) - !call ufs_mpas_write("restart") end subroutine ufs_mpas_run @@ -707,6 +706,8 @@ subroutine ufs_mpas_write(stream_name, timestamp) 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) From c17e5eb1f0416c5dd08941cae0ef2f46dd037ada Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 24 Feb 2026 00:02:57 +0000 Subject: [PATCH 29/45] Sync physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index c851dc512..b116d90b2 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit c851dc512cd1494a5b7bc7d711d01846321b5fb1 +Subproject commit b116d90b242b4f773589e9a44bae19f52e180508 From 621ae26df370a81be267e84e579dc350303da818 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 2 Mar 2026 17:11:55 +0000 Subject: [PATCH 30/45] Synced physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index b116d90b2..0eaff258b 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit b116d90b242b4f773589e9a44bae19f52e180508 +Subproject commit 0eaff258b20cc9c0a5d194b70768c1cde07f715f From de7d66a286d91ecbb06527ddf7622c4e86b53864 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 9 Mar 2026 17:45:58 +0000 Subject: [PATCH 31/45] Reorg module contents --- CMakeLists.txt | 5 +- mpas/atmos_coupling.F90 | 4 +- mpas/atmos_model.F90 | 12 +- mpas/ufs_mpas_boundaries.F90 | 363 +++++++ mpas/ufs_mpas_constituents.F90 | 341 +++++++ mpas/{ufs_mpas_module.F90 => ufs_mpas_io.F90} | 932 +++--------------- mpas/ufs_mpas_subdriver.F90 | 153 +-- mpas/ufs_mpas_tools.F90 | 188 ++++ 8 files changed, 1067 insertions(+), 931 deletions(-) create mode 100644 mpas/ufs_mpas_boundaries.F90 create mode 100644 mpas/ufs_mpas_constituents.F90 rename mpas/{ufs_mpas_module.F90 => ufs_mpas_io.F90} (72%) create mode 100644 mpas/ufs_mpas_tools.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index d943442be..a6f84e8ab 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -241,8 +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_module.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/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 index 8d9b05944..7fbe186be 100644 --- a/mpas/atmos_coupling.F90 +++ b/mpas/atmos_coupling.F90 @@ -4,8 +4,8 @@ !> ! ########################################################################################### module atmos_coupling_mod - use mpas_kind_types, only : mpas_kind => RKIND - use ufs_mpas_module, only : domain_ptr + use mpas_kind_types, only : mpas_kind => RKIND + use ufs_mpas_io, only : domain_ptr implicit none public :: MPAS_statein_type diff --git a/mpas/atmos_model.F90 b/mpas/atmos_model.F90 index 9646b10c3..7b72fba68 100644 --- a/mpas/atmos_model.F90 +++ b/mpas/atmos_model.F90 @@ -105,12 +105,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 - use ufs_mpas_subdriver, only : ufs_mpas_open_init, ufs_mpas_open_lbc - use ufs_mpas_module, 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 + 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 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_module.F90 b/mpas/ufs_mpas_io.F90 similarity index 72% rename from mpas/ufs_mpas_module.F90 rename to mpas/ufs_mpas_io.F90 index 8a4372555..2eedb13d3 100644 --- a/mpas/ufs_mpas_module.F90 +++ b/mpas/ufs_mpas_io.F90 @@ -1,18 +1,27 @@ !> ########################################################################################### -!> \file ufs_mpas_module.F90 +!> \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. +!> 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_module +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 mpas_atm_boundaries, only : LBC_intv_end + 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 public @@ -22,12 +31,6 @@ module ufs_mpas_module 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(:) - !> ######################################################################################### !> !> ######################################################################################### @@ -123,7 +126,7 @@ module ufs_mpas_module 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. @@ -249,409 +252,142 @@ module ufs_mpas_module 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('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('surface_pressure' , 'real' , 1), & var_info_type('theta' , 'real' , 2), & - var_info_type('u' , '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), & - 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('w' , 'real' , 2) & + !var_info_type('zz' , 'real' , 2) & ] 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 + !> Procedure to open MPAS IC file. !> !> ######################################################################################### - 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 + 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 - delimiter = ', ' + call mpp_error(FATAL,subname//": Cannot find MPAS IC file: "//trim(ic_filename)) 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 + end subroutine ufs_mpas_open_init !> ######################################################################################### - !> - !> 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 + !> Procedure to open MPAS Lateral Boundary Condition file. !> !> ######################################################################################### - subroutine ufs_mpas_atm_update_bdy_tend(clock, block, firstCall, nRecord, ierr) - use mpas_constants, only : rvord - use mpas_stream_manager, only : mpas_stream_mgr_read - 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 - 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 + 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 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 + call mpp_error(FATAL,subname//": Cannot find MPAS LBC file: "//trim(lbc_filename)) end if - if (ierr /= 0) then - return + 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 - 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('----------------------------------------------------------------------') + 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 ") - end if - LBC_intv_end = currTime - - end subroutine ufs_mpas_atm_update_bdy_tend + output_var_info_list = parse_stream_name_fragment('output') + timelevel = TIMELEVEL_NOW + whence = MPAS_NOW -!> ######################################################################################## - !> - !> \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 - !> - !> ######################################################################################## + 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 @@ -691,320 +427,6 @@ subroutine ufs_mpas_compute_unit_vectors() 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 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 - - !> ######################################################################################## - !> - !> ######################################################################################## - 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 - - 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 !> ######################################################################################## !> @@ -1141,72 +563,7 @@ subroutine ufs_mpas_get_global_coords(latCellGlobal, lonCellGlobal, areaCellGlob deallocate(temp) end subroutine ufs_mpas_get_global_coords - - ! ########################################################################################## - ! \update: Dustin Swales April 2025 - Modified for use in UWM - ! ########################################################################################## - 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 - ! ######################################################################################### - ! \update: Dustin Swales April 2025 - Modified for use in UWM - ! ######################################################################################### - 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 - - ! ######################################################################################### - ! \update: Dustin Swales April 2025 - Modified for use in UWM - ! ######################################################################################### - 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 !> ######################################################################################## !> !> subroutine dyn_mpas_exchange_halo @@ -1395,9 +752,10 @@ end subroutine dyn_mpas_exchange_halo !> \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) + 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 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 @@ -1405,9 +763,9 @@ subroutine dyn_mpas_read_write_stream(clock, stream_mode, stream_name, pio_file_ 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 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 @@ -1418,7 +776,7 @@ subroutine dyn_mpas_read_write_stream(clock, stream_mode, stream_name, pio_file_ 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 @@ -2501,14 +1859,9 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, case (3) call mpas_pool_get_field(domain_ptr % blocklist % allfields, & trim(adjustl(var_info % name)), field_3d_real, timelevel=1) - call mpas_log_write('IMP_DIAG check_variable_status name = '//trim(adjustl(var_info % name))) if (.not. associated(field_3d_real)) then call mpp_error(FATAL,subname//'Failed to find variable "' // trim(adjustl(var_info % name)) // '"') end if - call mpas_log_write('IMP_DIAG check_variable_status vararray = '//stringify([field_3d_real % isvararray])) - if (associated(field_3d_real % constituentnames)) then - call mpas_log_write('IMP_DIAG check_variable_status nconst = '//stringify([size(field_3d_real % constituentnames)])) - 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) @@ -2518,9 +1871,6 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, var_name_list(:) = field_3d_real % constituentnames(:) end if - if (associated(field_3d_real % constituentnames)) then - call mpas_log_write('IMP_DIAG check_variable_status nconst2 = '//stringify([size(field_3d_real % constituentnames)])) - end if nullify(field_3d_real) case (4) call mpas_pool_get_field(domain_ptr % blocklist % allfields, & @@ -2569,7 +1919,6 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, '" for "' // trim(adjustl(var_info % name)) // '"') end select - call mpas_log_write('IMP_DIAG check_variable_status 1') if (.not. allocated(var_name_list)) then allocate(var_name_list(1), stat=ierr) @@ -2579,7 +1928,7 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, var_name_list(1) = var_info % name end if - call mpas_log_write('IMP_DIAG check_variable_status 2') + allocate(var_is_present(size(var_name_list)), stat=ierr) if (ierr /= 0) then @@ -2587,14 +1936,12 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, end if var_is_present(:) = .false. - call mpas_log_write('IMP_DIAG check_variable_status 3') 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. - call mpas_log_write('IMP_DIAG check_variable_status 4') if (.not. associated(pio_file)) then return end if @@ -2605,12 +1952,10 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, call mpas_log_write('Checking variable "' // trim(adjustl(var_info % name)) // & '" for presence and TKR compatibility') - call mpas_log_write('IMP_DIAG check_variable_status 5 size(var_name_list) = '//stringify([size(var_name_list)])) do i = 1, size(var_name_list) ! Check if the variable is present on the file. - call mpas_log_write('IMP_DIAG check_variable_status 5 var_name_list(i) = '//trim(adjustl(var_name_list(i)))) ierr = pio_inq_varid(pio_file, trim(adjustl(var_name_list(i))), varid) - call mpas_log_write('IMP_DIAG check_variable_status 5b') + if (ierr /= pio_noerr) then cycle end if @@ -2650,10 +1995,9 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, case default cycle end select - call mpas_log_write('IMP_DIAG check_variable_status 5c') + ! Check if the variable is TK"R" compatible between MPAS and the file. ierr = pio_inq_varndims(pio_file, varid, varndims) - call mpas_log_write('IMP_DIAG check_variable_status 5d') if (ierr /= pio_noerr) then cycle end if @@ -2664,7 +2008,7 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, var_is_tkr_compatible(i) = .true. end do - call mpas_log_write('IMP_DIAG check_variable_status 6') + 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)) @@ -2672,4 +2016,4 @@ subroutine dyn_mpas_check_variable_status(var_is_present, var_is_tkr_compatible, call mpas_log_write(subname // ' completed') end subroutine dyn_mpas_check_variable_status -end module ufs_mpas_module +end module ufs_mpas_io diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index 24460c1e8..43014a8e3 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -13,17 +13,11 @@ !> 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. -!> ufs_mpas_open_lbc : Open MPAS Lateral Boundary Condition file, return PIO file handle. -!> !> ########################################################################################### module ufs_mpas_subdriver use mpi_f08 use mpas_kind_types, only : StrKIND, rkind - use module_mpas_config, only : ic_filename, pioid_ic, pio_subsystem_ic - use module_mpas_config, only : lbc_filename, pioid_lbc, pio_subsystem_lbc - use module_mpas_config, only : pio_iotype, pio_stride, pio_numiotasks, pio_iodesc + 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 @@ -31,7 +25,11 @@ module ufs_mpas_subdriver use module_mpas_config, only : nEdgesSolve, nVerticesSolve, nVertLevelsSolve use module_mpas_config, only : dt_atmos, n_atmos use module_mpas_config, only : latCellGlobal, lonCellGlobal, areaCellGlobal - use ufs_mpas_module + use ufs_mpas_tools + use ufs_mpas_io + use ufs_mpas_boundaries + use ufs_mpas_constituents + implicit none private @@ -39,8 +37,6 @@ module ufs_mpas_subdriver public :: MPAS_control_type public :: ufs_mpas_init public :: ufs_mpas_run - public :: ufs_mpas_open_init - public :: ufs_mpas_open_lbc logical :: init_lbc = .true. integer :: nRecord_lbc = 1 @@ -109,7 +105,8 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni use mpas_bootstrapping, only : mpas_bootstrap_framework_phase1 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, MPAS_STREAM_LATEST_BEFORE, MPAS_STREAM_MGR_NOERR, MPAS_LOG_ERR + 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 @@ -320,7 +317,6 @@ subroutine ufs_mpas_init(Cfg, time_start, time_end, total_time, calendar, logUni if( ierr /= 0 ) then call mpp_error(FATAL,subname//": Could not find sphere_radius PIO attribute") endif - call mpas_log_write('sphere_radius = '//stringify([domain_ptr % sphere_radius])) ! FROM CAM/dyn_grid.F90:dyn_grid_init() ! Query global grid dimensions from MPAS @@ -358,7 +354,8 @@ subroutine ufs_mpas_atm_core_init(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, mpas_atm_run_compatibility + 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 @@ -444,11 +441,6 @@ subroutine ufs_mpas_atm_core_init(Cfg) call mpp_error(FATAL,'ERROR: Could not read from ''input'' stream ') end if - ! What is the shape of scalars? - call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) - call mpas_pool_get_array(state, 'scalars',field_3d_real, timelevel=1) - call mpas_log_write('IMP_DIAG ufs_mpas_atm_core_init: shape(scalars) = '//stringify([shape(field_3d_real)])) - ! ! Read in restart data. ! @@ -491,11 +483,19 @@ subroutine ufs_mpas_atm_core_init(Cfg) ! ! Perform basic compatibility checks among the fields that were read and the run-time options that were selected ! - !call mpas_atm_run_compatibility(domain_ptr % dminfo, domain_ptr % blocklist, domain_ptr % streamManager, ierr=ierr) + call mpas_atm_dynamics_checks(domain_ptr % dminfo, domain_ptr % blocklist, domain_ptr % streamManager, ierr) if (ierr /= 0) then - call mpas_log_write('Please correct issues with the model input fields and/or namelist.') + 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) @@ -549,8 +549,6 @@ subroutine ufs_mpas_run() 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(.LT.), operator(.GT.), operator(.LE.) - use ufs_mpas_module, only : ufs_mpas_atm_update_bdy_tend - use mpas_atm_boundaries, only : LBC_intv_end ! FMS use mpp_mod, only : FATAL, mpp_error ! Locals @@ -563,10 +561,12 @@ subroutine ufs_mpas_run() real (kind=R8KIND) :: integ_start_time, integ_stop_time logical, pointer :: config_apply_lbcs type(mpas_timeinterval_type) :: mpas_time_interval + real (kind=RKIND), dimension(:,:,:), pointer :: scalars 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) @@ -664,6 +664,9 @@ subroutine ufs_mpas_run() ! 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) ! @@ -677,112 +680,6 @@ subroutine ufs_mpas_run() end subroutine ufs_mpas_run - !> ######################################################################################### - !> Procedure to create and write to MPAS stream - !> - !> ######################################################################################### - subroutine ufs_mpas_write(stream_name, timestamp) - use pio, only : pio_openfile, pio_createfile, PIO_WRITE, PIO_CLOBBER - use module_mpas_config, only : ic_filename, pioid_output, & - pio_subsystem_output, output_filename, restart_filename, & - pio_subsystem_output_file_created, & - TIMELEVEL_NOW, pio_subsystem_output_record - 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 - - !> ######################################################################################### - !> 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 read MPAS namelist(s). !> 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 From 7dae4fdd06b1c6cc3616d1e3dec340d080630421 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 9 Mar 2026 22:15:15 +0000 Subject: [PATCH 32/45] Add control over output file frequency. Add timers to output section. --- mpas/atmos_model.F90 | 7 +++--- mpas/ufs_mpas_io.F90 | 7 +++--- mpas/ufs_mpas_subdriver.F90 | 46 +++++++++++++++++++++++++++++++------ ufsatm_cap.F90 | 4 +--- 4 files changed, 47 insertions(+), 17 deletions(-) diff --git a/mpas/atmos_model.F90 b/mpas/atmos_model.F90 index 7b72fba68..b7c841ae6 100644 --- a/mpas/atmos_model.F90 +++ b/mpas/atmos_model.F90 @@ -83,7 +83,7 @@ module atmos_model_mod 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 @@ -130,6 +130,7 @@ 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) @@ -373,9 +374,7 @@ subroutine atmos_model_dynamics(Atmos) call ufs_microphysics_to_mpas(UFSATM_stateout) ! Call MPAS dycore - call mpp_clock_begin(mpasClock) - call ufs_mpas_run() - call mpp_clock_end(mpasClock) + call ufs_mpas_run(mpasClock, outClock) end subroutine atmos_model_dynamics diff --git a/mpas/ufs_mpas_io.F90 b/mpas/ufs_mpas_io.F90 index 2eedb13d3..da70356a1 100644 --- a/mpas/ufs_mpas_io.F90 +++ b/mpas/ufs_mpas_io.F90 @@ -24,13 +24,15 @@ module ufs_mpas_io use ufs_mpas_tools, only : stringify implicit none - public - ! 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(:) + !> ######################################################################################### !> !> ######################################################################################### @@ -896,7 +898,6 @@ end subroutine dyn_mpas_read_write_stream !> ######################################################################################## subroutine read_stream(stream, when, whence, actualWhen, nRecord, ierr) use mpas_io_streams, only : MPAS_readStream, MPAS_streamTime - use mpas_derived_types, only : MPAS_TimeInterval_type use mpas_derived_types, only : mpas_pool_type, mpas_stream_noerr, mpas_stream_type type(mpas_stream_type), pointer, intent(inout) :: stream diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index 43014a8e3..1aa602357 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -23,7 +23,7 @@ module ufs_mpas_subdriver use module_mpas_config, only : maxNCells, maxEdges, nVertLevels use module_mpas_config, only : nCellsGlobal, nEdgesGlobal, nVerticesGlobal use module_mpas_config, only : nEdgesSolve, nVerticesSolve, nVertLevelsSolve - use module_mpas_config, only : dt_atmos, n_atmos + 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 @@ -358,7 +358,7 @@ subroutine ufs_mpas_atm_core_init(Cfg) 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 + 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 @@ -534,7 +534,7 @@ end subroutine ufs_mpas_atm_core_init !> 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 @@ -548,21 +548,27 @@ 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(.LT.), operator(.GT.), operator(.LE.) + 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,timeLBCnew character(len=StrKIND) :: timeStamp - integer :: ierr, itime, itimestep + 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) @@ -589,6 +595,25 @@ subroutine ufs_mpas_run() call mpp_error(FATAL,subname//'Failed to set dynamics time step') endif + ! + ! Set MPAS output file times + ! + 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, @@ -659,6 +684,7 @@ subroutine ufs_mpas_run() endif end do call mpas_log_write('MPAS dynamics stop timestep') + call mpp_clock_end(mpasClock) ! ! Compute diagnostic fields (theta, rho, pres) from @@ -672,11 +698,17 @@ subroutine ufs_mpas_run() ! ! 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 - call ufs_mpas_write("output", timeStamp) + + 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 + call mpp_clock_end(outClock) end subroutine ufs_mpas_run diff --git a/ufsatm_cap.F90 b/ufsatm_cap.F90 index 868a1d770..f68ce4547 100644 --- a/ufsatm_cap.F90 +++ b/ufsatm_cap.F90 @@ -622,7 +622,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 @@ -1232,7 +1232,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. @@ -1264,7 +1263,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) From cda6db264d804604ce5661ca6e8eb3a5551ab05d Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 12 Mar 2026 17:40:08 +0000 Subject: [PATCH 33/45] Add diagnostic calculation to P2D --- mpas/atmos_coupling.F90 | 112 ++++++++++++++++++++++++++++++++++++---- mpas/atmos_model.F90 | 15 ++++-- mpas/ufs_mpas_io.F90 | 2 +- 3 files changed, 115 insertions(+), 14 deletions(-) diff --git a/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 index 7fbe186be..303926d69 100644 --- a/mpas/atmos_coupling.F90 +++ b/mpas/atmos_coupling.F90 @@ -32,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 @@ -81,6 +81,12 @@ module atmos_coupling_mod ! from physics [kg K/m^3/s] (nlev,ncol) 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 !> ####################################################################################### @@ -100,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 @@ -134,6 +140,11 @@ 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 @@ -154,6 +165,8 @@ subroutine ufs_mpas_to_physics(physics_state) 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 ! Locals @@ -162,9 +175,12 @@ subroutine ufs_mpas_to_physics(physics_state) type(mpas_pool_type), pointer :: diag_pool type(mpas_pool_type), pointer :: mesh_pool type(mpas_pool_type), pointer :: sfc_pool - integer :: iCol, iTracer - integer, pointer :: nCellsSolve, num_scalars, nwat, index_qv, nVertLevels + 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) @@ -188,11 +204,13 @@ 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 @@ -201,7 +219,7 @@ subroutine ufs_mpas_to_physics(physics_state) physics_state % ugrs(iCol,:) = MPAS_state % ux(nVertLevels:1:-1,iCol) physics_state % vgrs(iCol,:) = MPAS_state % uy(nVertLevels:1:-1,iCol) physics_state % phil(iCol,:) = MPAS_state % zz(nVertLevels:1:-1,iCol) - physics_state % phii(iCol,:) = MPAS_state % zint(nVertLevels+1:1:-1,iCol) + physics_state % phii(iCol,:) = MPAS_state % zgrid(nVertLevels+1:1:-1,iCol) physics_state % prslk(iCol,:) = MPAS_state % exner(nVertLevels:1:-1,iCol) physics_state % vvl(iCol,:) = MPAS_state % w(nVertLevels:1:-1,iCol) do iTracer = 1,num_scalars @@ -209,12 +227,28 @@ subroutine ufs_mpas_to_physics(physics_state) enddo 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. @@ -233,6 +267,18 @@ subroutine ufs_mpas_to_physics(physics_state) end subroutine ufs_mpas_to_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) @@ -244,15 +290,63 @@ end subroutine ufs_mpas_to_physics !> ######################################################################################### 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) + ! 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 !> ######################################################################################### @@ -272,7 +366,7 @@ subroutine ufs_mpas_to_microphysics(physics_state) 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. !> diff --git a/mpas/atmos_model.F90 b/mpas/atmos_model.F90 index b7c841ae6..e042e5562 100644 --- a/mpas/atmos_model.F90 +++ b/mpas/atmos_model.F90 @@ -325,10 +325,14 @@ 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) + ! Call CCPP Timestep_initialize Group call mpp_clock_begin(setupClock) call CCPP_step (step="timestep_init", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') @@ -364,14 +368,14 @@ 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_microphysics_to_mpas + 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. ! NOT YET IMPLEMENTED - call ufs_microphysics_to_mpas(UFSATM_stateout) + call ufs_physics_to_mpas() ! Call MPAS dycore call ufs_mpas_run(mpasClock, outClock) @@ -383,7 +387,7 @@ end subroutine atmos_model_dynamics !> !> ######################################################################################### subroutine atmos_model_microphysics(Atmos) - use atmos_coupling_mod, only : ufs_mpas_to_microphysics + use atmos_coupling_mod, only : ufs_mpas_to_microphysics, ufs_microphysics_to_mpas type (atmos_control_type), intent(inout) :: Atmos ! Locals integer :: ierr @@ -405,6 +409,9 @@ 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 !> ######################################################################################### @@ -417,5 +424,5 @@ subroutine update_atmos_model_state(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/ufs_mpas_io.F90 b/mpas/ufs_mpas_io.F90 index da70356a1..7e28108a1 100644 --- a/mpas/ufs_mpas_io.F90 +++ b/mpas/ufs_mpas_io.F90 @@ -259,7 +259,7 @@ module ufs_mpas_io !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('surface_pressure' , 'real' , 1), & var_info_type('theta' , 'real' , 2), & !var_info_type('u' , 'real' , 2), & var_info_type('uReconstructMeridional' , 'real' , 2), & From 5482114a9a56bb0cefdce062507b03218b67c38f Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 19 Mar 2026 21:42:58 +0000 Subject: [PATCH 34/45] Some P2D changes --- ccpp/data/GFS_typedefs.F90 | 59 +++++++++++++++++++++++++------------- ccpp/physics | 2 +- mpas/atmos_coupling.F90 | 42 ++++++++++++++++----------- mpas/atmos_model.F90 | 4 +-- 4 files changed, 67 insertions(+), 40 deletions(-) diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 4f9dba1a5..bae5d551f 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -5493,26 +5493,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) diff --git a/ccpp/physics b/ccpp/physics index 0eaff258b..d520ac0d9 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 0eaff258b20cc9c0a5d194b70768c1cde07f715f +Subproject commit d520ac0d944e0aee437ecd7346d25689f94b9dac diff --git a/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 index 303926d69..d4c33e220 100644 --- a/mpas/atmos_coupling.F90 +++ b/mpas/atmos_coupling.F90 @@ -159,8 +159,8 @@ module atmos_coupling_mod !> 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 @@ -169,6 +169,7 @@ subroutine ufs_mpas_to_physics(physics_state) ! 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 @@ -213,20 +214,28 @@ subroutine ufs_mpas_to_physics(physics_state) ! Copy fields from MPAS data containers to physics data containers. ! [k, i] -> [i, k] - ! bottom-up -> top-down ordering convention + ! Retain bottom-up convention do iCol = 1, nCellsSolve - physics_state % tgrs(iCol,:) = MPAS_state % theta(nVertLevels:1:-1,iCol) - physics_state % ugrs(iCol,:) = MPAS_state % ux(nVertLevels:1:-1,iCol) - physics_state % vgrs(iCol,:) = MPAS_state % uy(nVertLevels:1:-1,iCol) - physics_state % phil(iCol,:) = MPAS_state % zz(nVertLevels:1:-1,iCol) - physics_state % phii(iCol,:) = MPAS_state % zgrid(nVertLevels+1:1:-1,iCol) - physics_state % prslk(iCol,:) = MPAS_state % exner(nVertLevels:1:-1,iCol) - physics_state % vvl(iCol,:) = MPAS_state % w(nVertLevels:1:-1,iCol) + 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,iCol) + 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) @@ -253,13 +262,12 @@ subroutine ufs_mpas_to_physics(physics_state) ! Copy MPAS pressures into physics data containers. ! [k, i] -> [i, k] - ! bottom-up -> top-down ordering convention + ! Retain bottom-up convention do iCol = 1, nCellsSolve - physics_state % pgr(iCol) = MPAS_state % pintdry(1,iCol) - physics_state % prsl(iCol,:) = MPAS_state % pmiddry(nVertLevels:1:-1,iCol) - physics_state % prsi(iCol,:) = MPAS_state % pintdry(nVertLevels+1:1:-1,iCol) + 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) @@ -541,7 +549,7 @@ subroutine ufs_mpas_grid_to_physics(physics_grid) end if end if if (ierr/=0) call mpp_error(FATAL, 'Call to ufs_mpas_grid_to_physics() failed') - + do i=1, nCellsSolve physics_grid % xlat(i) = lat(i) physics_grid % xlon(i) = lon(i) diff --git a/mpas/atmos_model.F90 b/mpas/atmos_model.F90 index e042e5562..0b0ccd6f6 100644 --- a/mpas/atmos_model.F90 +++ b/mpas/atmos_model.F90 @@ -283,7 +283,7 @@ subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm ! in a different "piece" later, but copying the Updated state from the dycore before calling ! the microphsyics. ! - call ufs_mpas_to_physics(UFSATM_statein) + 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') @@ -331,7 +331,7 @@ subroutine atmos_model_radiation_physics(Atmos) integer :: ierr ! Populate physics inputs with MPAS data. - call ufs_mpas_to_physics(UFSATM_statein) + call ufs_mpas_to_physics(UFSATM_statein, UFSATM_sfcprop) ! Call CCPP Timestep_initialize Group call mpp_clock_begin(setupClock) From d0fab1ab435287d51ef90990da304c1274ce752c Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 20 Mar 2026 15:09:33 +0000 Subject: [PATCH 35/45] Housekeeping --- mpas/atmos_model.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/mpas/atmos_model.F90 b/mpas/atmos_model.F90 index 0b0ccd6f6..4163dc53a 100644 --- a/mpas/atmos_model.F90 +++ b/mpas/atmos_model.F90 @@ -28,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 @@ -122,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 ) @@ -155,9 +154,10 @@ 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 ! From ee69a66885f5e526f0a23648cbcf8e7cad83b823 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 30 Mar 2026 15:22:21 +0000 Subject: [PATCH 36/45] Use Pnetcdf as the default for PIO --- ufsatm_cap.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ufsatm_cap.F90 b/ufsatm_cap.F90 index f68ce4547..9dac93893 100644 --- a/ufsatm_cap.F90 +++ b/ufsatm_cap.F90 @@ -385,7 +385,7 @@ subroutine InitializeAdvertise(gcomp, rc) return end if else - cvalue = 'NETCDF' + cvalue = 'PNETCDF' pio_iotype = PIO_IOTYPE_NETCDF end if From 53a1d415fb95f24af4d110cbc6e9d13d106d6db2 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 30 Mar 2026 15:26:42 +0000 Subject: [PATCH 37/45] Sync physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index d520ac0d9..e328c04d3 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit d520ac0d944e0aee437ecd7346d25689f94b9dac +Subproject commit e328c04d35c2fcd6c16042c926e76ee847296eb8 From 474e5c44c2959b539ceccdeba29d118f69a59ded Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 9 Apr 2026 21:22:25 +0000 Subject: [PATCH 38/45] Sync physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index e328c04d3..90b2b1159 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit e328c04d35c2fcd6c16042c926e76ee847296eb8 +Subproject commit 90b2b11597c92e7ba7e6c0ef7d3dc1f2dd25bb81 From a18818f287fb8838cc0c6f75558369ffee3bd036 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 20 Apr 2026 15:19:23 +0000 Subject: [PATCH 39/45] Address reviewer comments --- ccpp/data/GFS_typedefs.F90 | 2 +- mpas/ufs_mpas_io.F90 | 30 ++---------------------------- ufsatm_cap.F90 | 1 - 3 files changed, 3 insertions(+), 30 deletions(-) diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index fad0b3523..c719a8f04 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -6898,7 +6898,7 @@ subroutine control_print(Model) class(GFS_control_type) :: Model !--- local variables - integer :: i, mpierr + integer :: i if (Model%me == Model%master) then print *, ' ' diff --git a/mpas/ufs_mpas_io.F90 b/mpas/ufs_mpas_io.F90 index 7e28108a1..046f57315 100644 --- a/mpas/ufs_mpas_io.F90 +++ b/mpas/ufs_mpas_io.F90 @@ -784,34 +784,10 @@ subroutine dyn_mpas_read_write_stream(clock, stream_mode, stream_name, pio_file_ type(mpas_pool_type), pointer :: mpas_pool type(mpas_stream_type), pointer :: mpas_stream type(var_info_type), allocatable :: var_info_list(:) - character (len=StrKIND) :: local_when - integer :: local_whence - integer :: local_ierr - type (MPAS_Time_type) :: now_time ierr = 0 call mpas_log_write('') - ! - ! Optional arguments. - ! - if (present(actualWhen)) write(actualWhen,'(a)') '0000-01-01_00:00:00' - if (present(whence)) then - local_whence = whence - else - local_whence = MPAS_STREAM_EXACT_TIME - end if - - if (present(when)) then - local_when = when - else - now_time = mpas_get_clock_time(clock, MPAS_NOW, ierr=local_ierr) - if (local_ierr /= 0) then - call mpp_error(FATAL,subname//': Failed to get clock_time for "mpas_NOW"') - endif - !call mpas_get_time(now_time, dateTimeString=local_when) - end if - nullify(mpas_pool) nullify(mpas_stream) call mpas_log_write( '---------------------------------------------------------------------') @@ -831,7 +807,7 @@ subroutine dyn_mpas_read_write_stream(clock, stream_mode, stream_name, pio_file_ case ('r', 'read') call mpas_log_write('Reading stream "' // trim(adjustl(stream_name)) // '"') - call read_stream(mpas_stream, local_when, local_whence, actualWhen, nRecord, ierr) + 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)) // '"') @@ -896,13 +872,11 @@ end subroutine dyn_mpas_read_write_stream !> !> !> ######################################################################################## - subroutine read_stream(stream, when, whence, actualWhen, nRecord, ierr) + 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 - character (len=*), intent(in) :: when - integer, intent(in) :: whence integer, intent(in) :: nRecord character (len=*), intent(out), optional :: actualWhen integer, intent(out) :: ierr diff --git a/ufsatm_cap.F90 b/ufsatm_cap.F90 index 9dac93893..faf105da5 100644 --- a/ufsatm_cap.F90 +++ b/ufsatm_cap.F90 @@ -273,7 +273,6 @@ subroutine InitializeAdvertise(gcomp, rc) integer :: ngrids type(ESMF_Grid) :: src_grid, dst_grid type(ESMF_Field), allocatable :: dst_field_mask(:) - integer :: ierr ! !------------------------------------------------------------------------ ! From 1a7f1bbdbd8c992975f3873bd967403ff3c9bf7b Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 20 Apr 2026 15:22:26 +0000 Subject: [PATCH 40/45] Update physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 90b2b1159..53462ba4f 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 90b2b11597c92e7ba7e6c0ef7d3dc1f2dd25bb81 +Subproject commit 53462ba4fe6ceaa68d3b88fed2182790fc775633 From fd2767aa3ec21ab2abb7b1e1ba86cbfc263029f7 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 20 Apr 2026 15:50:03 +0000 Subject: [PATCH 41/45] Omission from previous commit --- mpas/atmos_model.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mpas/atmos_model.F90 b/mpas/atmos_model.F90 index 4163dc53a..2ae082fca 100644 --- a/mpas/atmos_model.F90 +++ b/mpas/atmos_model.F90 @@ -269,7 +269,7 @@ 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_cldprop, UFSATM_radtend, UFSATM_coupling, Cfg) + UFSATM_statein, UFSATM_stateout, UFSATM_cldprop, UFSATM_radtend, UFSATM_coupling, Cfg) call ufs_mpas_grid_to_physics(UFSATM_grid) From 8533630ea97a4b548379c16efa252a0f40a0583e Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 23 Apr 2026 19:34:32 +0000 Subject: [PATCH 42/45] Update physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 53462ba4f..3411caabe 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 53462ba4fe6ceaa68d3b88fed2182790fc775633 +Subproject commit 3411caabea936780c9b5838597b354528cbdb3aa From 0a19557ed06318f63204f9a713ef8acd1cc37c00 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 23 Apr 2026 20:16:59 +0000 Subject: [PATCH 43/45] doh --- ufsatm_cap.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ufsatm_cap.F90 b/ufsatm_cap.F90 index faf105da5..ff342c4f6 100644 --- a/ufsatm_cap.F90 +++ b/ufsatm_cap.F90 @@ -385,7 +385,7 @@ subroutine InitializeAdvertise(gcomp, rc) end if else cvalue = 'PNETCDF' - pio_iotype = PIO_IOTYPE_NETCDF + pio_iotype = PIO_IOTYPE_PNETCDF end if ! pio_root From ae12357e77b37cd41cae59cc9f1bd628eb1e9ae7 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 24 Apr 2026 21:10:12 +0000 Subject: [PATCH 44/45] Update default nml settings --- mpas/ufs_mpas_subdriver.F90 | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/mpas/ufs_mpas_subdriver.F90 b/mpas/ufs_mpas_subdriver.F90 index 1aa602357..59b86dda8 100644 --- a/mpas/ufs_mpas_subdriver.F90 +++ b/mpas/ufs_mpas_subdriver.F90 @@ -671,6 +671,7 @@ subroutine ufs_mpas_run(mpasClock, outClock) 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. @@ -749,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 @@ -773,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 @@ -798,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, & @@ -886,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) @@ -946,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) From 72f2ad58c43c83a02197cfa102596ba8d1402a1a Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 29 Apr 2026 17:05:55 +0000 Subject: [PATCH 45/45] Update physics hash and .gitmodule --- .gitmodules | 4 ++-- ccpp/physics | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index 46cfa9cd3..5e5f8d221 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,8 +8,8 @@ branch = develop [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/dustinswales/ccpp-physics - branch = feature/mpas_in_ufs + url = https://github.com/ufs-community/ccpp-physics + branch = ufs/dev [submodule "upp"] path = upp url = https://github.com/NOAA-EMC/UPP diff --git a/ccpp/physics b/ccpp/physics index 3411caabe..6904ad4b5 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 3411caabea936780c9b5838597b354528cbdb3aa +Subproject commit 6904ad4b5563ca1a63203993b35fa68de794340f