diff --git a/.gitmodules b/.gitmodules index a01232401..a773677e6 100644 --- a/.gitmodules +++ b/.gitmodules @@ -14,3 +14,7 @@ path = upp url = https://github.com/NOAA-EMC/UPP branch = develop +[submodule "mpas/MPAS-Model"] + path = mpas/MPAS-Model + url = https://github.com/ufs-community/MPAS-Model.git + branch = feature/mpas-in-ufs diff --git a/CMakeLists.txt b/CMakeLists.txt index 857a8b50d..ceee4e502 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -18,10 +18,14 @@ if(BUILD_CI_TESTING) if (FV3) project(ufsatm_fv3 VERSION 1.0 LANGUAGES C CXX Fortran) endif() + if (MPAS) + project(ufsatm_mpas VERSION 1.0 LANGUAGES C CXX Fortran) + endif() include(ci/CMakeLists.txt) endif() # Set variables for all dycore build options in UFSATM. +set(DYCORE_TARGET_MPAS ufsatm_mpas) set(DYCORE_TARGET_FV3 ufsatm_fv3) ############################################################################### @@ -56,14 +60,38 @@ if(BUILD_CI_TESTING) add_subdirectory(tests) endif() +# Not used yet by MPAS in UFSATM, but needed by ufsatm_cap.F90 to work. +list(APPEND coupling_srcs + cpl/module_block_data.F90 + cpl/module_cplfields.F90 + cpl/module_cap_cpl.F90 + cpl/module_cplscalars.F90) + +list(APPEND io_srcs + io/module_write_netcdf.F90 + io/module_write_restart_netcdf.F90 + io/module_fv3_io_def.F90 + io/module_write_internal_state.F90 + io/module_wrt_grid_comp.F90) + +# Eventually these could be shared by MPAS, and merged with {io_srcs} list. +list(APPEND fv3_io_srcs + io/fv3atm_common_io.F90 + io/fv3atm_clm_lake_io.F90 + io/fv3atm_rrfs_sd_io.F90 + io/fv3atm_sfc_io.F90 + io/fv3atm_oro_io.F90 + io/fv3atm_history_io.F90 + io/fv3atm_restart_io.F90) + ############################################################################### ### UFSATM with FV3 dynamical core ############################################################################### if (FV3) + add_definitions(-DFV3) set(DYCORE_TARGET ${DYCORE_TARGET_FV3} CACHE INTERNAL "DYCORE_TARGET Options: fv3atm") - set(DYCORE_TARGET_CAP_MOD fv3atm_cap_mod PARENT_SCOPE) - + set(DYCORE_TARGET_CAP_MOD ufsatm_cap_mod PARENT_SCOPE) # These ifdefs need to be turned ON in the dycore. set(use_WRTCOMP ON) @@ -83,7 +111,7 @@ if (FV3) if(INLINE_POST) set(BUILD_POSTEXEC OFF) add_subdirectory(upp) - set(POST_SRC fv3/io/post_nems_routines.F90 fv3/io/post_fv3.F90) + set(POST_SRC io/post_nems_routines.F90 io/post_fv3.F90) list(APPEND _ufsatm_defs_private INLINE_POST) endif() @@ -130,27 +158,15 @@ if (FV3) # FV3 drivers and dependencies add_library(${DYCORE_TARGET} + ufsatm_cap.F90 + ufsatm_util.F90 fv3/atmos_model.F90 - fv3/fv3_cap.F90 fv3/module_fv3_config.F90 fv3/module_fcst_grid_comp.F90 fv3/stochastic_physics/stochastic_physics_wrapper.F90 - cpl/module_block_data.F90 - cpl/module_cplfields.F90 - cpl/module_cap_cpl.F90 - cpl/module_cplscalars.F90 - fv3/io/fv3atm_common_io.F90 - fv3/io/fv3atm_clm_lake_io.F90 - fv3/io/fv3atm_rrfs_sd_io.F90 - fv3/io/fv3atm_sfc_io.F90 - fv3/io/fv3atm_oro_io.F90 - fv3/io/fv3atm_history_io.F90 - fv3/io/fv3atm_restart_io.F90 - fv3/io/module_write_netcdf.F90 - fv3/io/module_write_restart_netcdf.F90 - fv3/io/module_fv3_io_def.F90 - fv3/io/module_write_internal_state.F90 - fv3/io/module_wrt_grid_comp.F90 + ${coupling_srcs} + ${fv3_io_srcs} + ${io_srcs} ${moving_nest_srcs} ${POST_SRC} ) @@ -159,8 +175,75 @@ if (FV3) list(APPEND _ufsatm_defs_private GFS_PHYS INTERNAL_FILE_NML use_WRTCOMP) +else() + remove_definitions(-DFV3) endif() +############################################################################### +### UFSATM with MPAS dynamical core. +############################################################################### +if (MPAS) + add_definitions(-DMPAS) + set(DYCORE_TARGET ${DYCORE_TARGET_MPAS}) + + # Include MPAS Cmake tools. + include(${CMAKE_CURRENT_SOURCE_DIR}/mpas/MPAS-Model/cmake/Functions/MPAS_Functions.cmake) + + # Set any pre-processor directive needed in MPAS dycore. + get_mpas_version(MPAS_VERSION) + set(MPAS_ALL_CORES atmosphere) + set(MPAS_CORES atmosphere CACHE STRING "MPAS cores to build. Options: ${MPAS_ALL_CORES}") + if(MPAS_CORES MATCHES " ") #Convert strings separated with spaces to CMake list separated with ';' + string(REPLACE " " ";" MPAS_CORES ${MPAS_CORES}) + set(MPAS_CORES ${MPAS_CORES} CACHE STRING "MPAS cores to build. Options: ${MPAS_ALL_CORES}" FORCE) + endif() + set(MPAS_CAM_DYCORE TRUE) + set(MPAS_USE_PIO TRUE) + add_definitions(-DMPAS_USE_MPI_F08) + add_definitions(-DMPAS_PIO_SUPPORT) + add_definitions(-DMPAS_CAM_DYCORE) + add_definitions(-DMPAS_UFS_DYCORE) + add_definitions(-DSINGLE_PRECISION) + + # Source files for MPAS dynamical core drivers. + set(MPAS_MAIN_SRC ${CMAKE_CURRENT_SOURCE_DIR}/mpas/MPAS-Model/src/driver/mpas.F) + set(MPAS_SUBDRIVER_SRC ${CMAKE_CURRENT_SOURCE_DIR}/mpas/MPAS-Model/src/driver/mpas_subdriver.F) + + # MPAS dynamical core + add_subdirectory(mpas) + + # MPAS drivers and dependencies + add_library(${DYCORE_TARGET} + ufsatm_cap.F90 + ufsatm_util.F90 + mpas/atmos_model.F90 + mpas/module_mpas_config.F90 + mpas/module_fcst_grid_comp.F90 + mpas/atmos_coupling.F90 + mpas/ufs_mpas_subdriver.F90 + ${coupling_srcs} + ${io_srcs} + ccpp/data/MPAS_typedefs.F90 + ccpp/driver/MPAS_init.F90 + ) + add_dependencies(${DYCORE_TARGET} mpas mpasccpp) + + if(NOT MPAS_GIT_VERSION) + find_package(Git QUIET) + if(GIT_FOUND) + execute_process(COMMAND ${GIT_EXECUTABLE} describe --dirty + WORKING_DIRECTORY "${CMAKE_CURRENT_SOURCE_DIR}/mpas/MPAS-Model" + OUTPUT_VARIABLE _mpas_git_version + ERROR_QUIET OUTPUT_STRIP_TRAILING_WHITESPACE) + else() + set(_mpas_git_version "Unknown") + endif() + set(MPAS_GIT_VERSION ${_mpas_git_version} CACHE STRING "MPAS-Model git version") + message(STATUS "Setting MPAS_GIT_VERSION ${_mpas_git_version}") + endif() +else() + remove_definitions(-DMPAS) +endif() ############################################################################### ### Link libraries @@ -183,7 +266,11 @@ if (FV3) endif() endif() - +if (MPAS) + target_link_libraries(${DYCORE_TARGET} PUBLIC mpas + mpasccpp + fms) +endif() # Always include EMC libraries in dycore install target_link_libraries(${DYCORE_TARGET} PUBLIC w3emc::w3emc_d diff --git a/README.md b/README.md index 56ef866d1..97251daf3 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ -# fv3atm +# ufsatm This repository contains a driver and key subcomponents of the atmospheric component of the NOAA's [Unified Forecast System @@ -7,19 +7,27 @@ atmospheric component of the NOAA's [Unified Forecast System The subcomponents include: - - The Finite-Volume Cubed-Sphere (FV3) dynamical core, originally -from the [Geophysical Fluid Dynamics -Laboratory](https://www.gfdl.noaa.gov/). - - The Common Community Physics Package (CCPP) supported by the +- The Finite-Volume Cubed-Sphere (FV3) dynamical core, originally + from the [Geophysical Fluid Dynamics Laboratory](https://www.gfdl.noaa.gov/). + +- The Model for Prediction Across Scales - Atmosphere (MPAS-A) dynamical + core developed by [NSF-NCAR Mesoscale and Micrometeorology Laboratory (MMM)](https://www.mmm.ucar.edu). + - [MPAS Model](https://github.com/ufs-community/MPAS-Model) + - [MPAS documentation](https://www.mmm.ucar.edu/models/mpas) + +- The Common Community Physics Package (CCPP) supported by the [Developmental Testbed Center (DTC)](https://dtcenter.org/community-code/common-community-physics-package-ccpp), including: - [CCPP Framework](https://github.com/NCAR/ccpp-framework). - [CCPP Physics](https://github.com/NCAR/ccpp-physics) - - wrapper code to call [UFS stochastic + +- wrapper code to call [UFS stochastic physics](https://stochastic-physics.readthedocs.io/en/latest/) - - The io code handles netCDF I/O. - - The cpl coupler code connects the different components and allows + +- The io code handles netCDF I/O. + +- The cpl coupler code connects the different components and allows them to communicate. ## Prerequisites @@ -41,13 +49,13 @@ This package also requires the following external packages: - [ESMF](https://github.com/esmf-org/esmf) - [GFDL's Flexible Modeling System](https://github.com/NOAA-GFDL/FMS) -## Obtaining fv3atm +## Obtaining ufsatm -To obtain fv3atm, clone the git repository, and update the submodules: +To obtain ufsatm, clone the git repository, and update the submodules: ``` -git clone https://github.com/NOAA-EMC/fv3atm.git -cd fv3atm +git clone https://github.com/NOAA-EMC/ufsatm.git +cd ufsatm git submodule update --init --recursive ``` diff --git a/ccpp/CCPP_driver.F90 b/ccpp/CCPP_driver.F90 index 3d4a8e07f..f06379712 100644 --- a/ccpp/CCPP_driver.F90 +++ b/ccpp/CCPP_driver.F90 @@ -45,7 +45,7 @@ module CCPP_driver !------------------------------- ! CCPP step !------------------------------- - subroutine CCPP_step (step, nblks, ierr) + subroutine CCPP_step (step, nblks, ierr, dycore) #ifdef _OPENMP use omp_lib @@ -56,6 +56,7 @@ subroutine CCPP_step (step, nblks, ierr) character(len=*), intent(in) :: step integer, intent(in) :: nblks integer, intent(out) :: ierr + character(len=*), intent(in) :: dycore ! Local variables integer :: nb, nt, ntX integer :: ierr2 @@ -66,6 +67,7 @@ subroutine CCPP_step (step, nblks, ierr) ierr = 0 + ! CCPP Framework init (same for all dynamical cores) if (trim(step)=="init") then ! Get and set number of OpenMP threads (module @@ -105,7 +107,7 @@ subroutine CCPP_step (step, nblks, ierr) cdata_block(nb,nt)%thrd_cnt = nthrdsX end do end do - + ! Physics init (same for all dynamical cores) else if (trim(step)=="physics_init") then ! Since the physics init step is independent of the blocking structure, @@ -120,7 +122,7 @@ subroutine CCPP_step (step, nblks, ierr) return end if - ! Timestep init = time_vary + ! Timestep init = time_vary (dycore specific) else if (trim(step)=="timestep_init") then ! Since the physics timestep init step is independent of the blocking structure, @@ -135,20 +137,39 @@ subroutine CCPP_step (step, nblks, ierr) return end if - ! call timestep_init for "phys_ps"---required for Land IAU - call ccpp_physics_timestep_init(cdata_domain, suite_name=trim(ccpp_suite),group_name="phys_ps", ierr=ierr) - if (ierr/=0) then - write(0,'(a)') "An error occurred in ccpp_physics_timestep_init for group phys_ps" - write(0,'(a)') trim(cdata_domain%errmsg) - return - end if + if (trim(dycore)=='fv3') then + ! call timestep_init for "phys_ps"---required for Land IAU + call ccpp_physics_timestep_init(cdata_domain, suite_name=trim(ccpp_suite),group_name="phys_ps", ierr=ierr) + if (ierr/=0) then + write(0,'(a)') "An error occurred in ccpp_physics_timestep_init for group phys_ps" + write(0,'(a)') trim(cdata_domain%errmsg) + return + end if + + ! call timestep_init for "phys_ts"---required for Land IAU + call ccpp_physics_timestep_init(cdata_domain, suite_name=trim(ccpp_suite),group_name="phys_ts", ierr=ierr) + if (ierr/=0) then + write(0,'(a)') "An error occurred in ccpp_physics_timestep_init for group phys_ts" + write(0,'(a)') trim(cdata_domain%errmsg) + return + end if + endif - ! call timestep_init for "phys_ts"---required for Land IAU - call ccpp_physics_timestep_init(cdata_domain, suite_name=trim(ccpp_suite),group_name="phys_ts", ierr=ierr) - if (ierr/=0) then - write(0,'(a)') "An error occurred in ccpp_physics_timestep_init for group phys_ts" - write(0,'(a)') trim(cdata_domain%errmsg) - return + if (trim(dycore)=='mpas') then + ! Physics group + call ccpp_physics_timestep_init(cdata_domain, suite_name=trim(ccpp_suite),group_name="physics", ierr=ierr) + if (ierr/=0) then + write(0,'(a)') "An error occurred in ccpp_physics_timestep_init for group physics" + write(0,'(a)') trim(cdata_domain%errmsg) + return + end if + + call ccpp_physics_timestep_init(cdata_domain, suite_name=trim(ccpp_suite),group_name="microphysics", ierr=ierr) + if (ierr/=0) then + write(0,'(a)') "An error occurred in ccpp_physics_timestep_init for group microphysics" + write(0,'(a)') trim(cdata_domain%errmsg) + return + end if end if !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -187,7 +208,7 @@ subroutine CCPP_step (step, nblks, ierr) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Radiation, physics and and stochastic physics - threaded regions using blocked data structures - else if (trim(step)=="radiation" .or. trim(step)=="physics" .or. trim(step)=="stochastics") then + else if (trim(step)=="radiation" .or. trim(step)=="physics" .or. trim(step)=="stochastics" .or. trim(step)=="microphysics") then ! Set number of threads available to physics schemes to one, ! because threads are used on the host model side for blocking @@ -197,7 +218,8 @@ subroutine CCPP_step (step, nblks, ierr) !$OMP default (none) & !$OMP shared (nblks, nthrdsX, non_uniform_blocks, & !$OMP cdata_block, ccpp_suite, step, & -!$OMP GFS_Control, GFS_Interstitial) & +!$OMP GFS_Control, GFS_Interstitial, & +!$OMP dycore) & !$OMP private (nb, nt, ntX, ierr2) & !$OMP reduction (+:ierr) #ifdef _OPENMP @@ -216,39 +238,66 @@ subroutine CCPP_step (step, nblks, ierr) end if !--- Call CCPP radiation/physics/stochastics group if (trim(step)=="physics") then - ! Reset GFS_Interstitial DDT physics fields for this thread - call GFS_Interstitial(ntX)%phys_reset(GFS_control) - ! Process-split physics - call ccpp_physics_run(cdata_block(nb,ntX), suite_name=trim(ccpp_suite), group_name="phys_ps", ierr=ierr2) - if (ierr2/=0) then - write(0,'(2a,3(a,i4),a)') "An error occurred in ccpp_physics_run for group ", "phys_ps", & - ", block/chunk ", nb, " and thread ", nt, " (ntX=", ntX, "):" - write(0,'(a)') trim(cdata_block(nb,ntX)%errmsg) - ierr = ierr + ierr2 - endif - ! Time-split physics - call ccpp_physics_run(cdata_block(nb,ntX), suite_name=trim(ccpp_suite), group_name="phys_ts", ierr=ierr2) - if (ierr2/=0) then - write(0,'(2a,3(a,i4),a)') "An error occurred in ccpp_physics_run for group ", "phys_ts", & - ", block/chunk ", nb, " and thread ", nt, " (ntX=", ntX, "):" - write(0,'(a)') trim(cdata_block(nb,ntX)%errmsg) - ierr = ierr + ierr2 - endif + if (trim(dycore)=="fv3") then + ! Reset GFS_Interstitial DDT physics fields for this thread + call GFS_Interstitial(ntX)%phys_reset(GFS_control) + ! Process-split physics + call ccpp_physics_run(cdata_block(nb,ntX), suite_name=trim(ccpp_suite), group_name="phys_ps", ierr=ierr2) + if (ierr2/=0) then + write(0,'(2a,3(a,i4),a)') "An error occurred in ccpp_physics_run for group ", "phys_ps", & + ", block/chunk ", nb, " and thread ", nt, " (ntX=", ntX, "):" + write(0,'(a)') trim(cdata_block(nb,ntX)%errmsg) + ierr = ierr + ierr2 + endif + ! Time-split physics + call ccpp_physics_run(cdata_block(nb,ntX), suite_name=trim(ccpp_suite), group_name="phys_ts", ierr=ierr2) + if (ierr2/=0) then + write(0,'(2a,3(a,i4),a)') "An error occurred in ccpp_physics_run for group ", "phys_ts", & + ", block/chunk ", nb, " and thread ", nt, " (ntX=", ntX, "):" + write(0,'(a)') trim(cdata_block(nb,ntX)%errmsg) + ierr = ierr + ierr2 + endif + endif + if (trim(dycore)=="mpas") then + ! Physics + call ccpp_physics_run(cdata_block(nb,ntX), suite_name=trim(ccpp_suite), group_name="physics", ierr=ierr2) + if (ierr2/=0) then + write(0,'(2a,3(a,i4),a)') "An error occurred in ccpp_physics_run for group ", "physics", & + ", block/chunk ", nb, " and thread ", nt, " (ntX=", ntX, "):" + write(0,'(a)') trim(cdata_block(nb,ntX)%errmsg) + ierr = ierr + ierr2 + endif + endif else - if (trim(step)=="radiation") then - ! Reset GFS_Interstitial DDT radiation fields for this thread - call GFS_Interstitial(ntX)%rad_reset(GFS_control) - end if - ! Radiation - call ccpp_physics_run(cdata_block(nb,ntX), suite_name=trim(ccpp_suite), group_name=trim(step), ierr=ierr2) - if (ierr2/=0) then - write(0,'(2a,3(a,i4),a)') "An error occurred in ccpp_physics_run for group ", trim(step), & - ", block/chunk ", nb, " and thread ", nt, " (ntX=", ntX, "):" - write(0,'(a)') trim(cdata_block(nb,ntX)%errmsg) - ierr = ierr + ierr2 - endif - end if - end do + if (trim(step)=="radiation") then + ! Reset GFS_Interstitial DDT radiation fields for this thread + call GFS_Interstitial(ntX)%rad_reset(GFS_control) + endif + ! Radiation + call ccpp_physics_run(cdata_block(nb,ntX), suite_name=trim(ccpp_suite), group_name=trim(step), ierr=ierr2) + if (ierr2/=0) then + write(0,'(2a,3(a,i4),a)') "An error occurred in ccpp_physics_run for group ", trim(step), & + ", block/chunk ", nb, " and thread ", nt, " (ntX=", ntX, "):" + write(0,'(a)') trim(cdata_block(nb,ntX)%errmsg) + ierr = ierr + ierr2 + endif + ! Microphysics (MPAS only) + if (trim(step)=="microphysics") then + if (trim(dycore)=="mpas") then + call ccpp_physics_run(cdata_block(nb,ntX), suite_name=trim(ccpp_suite), group_name="microphysics", ierr=ierr2) + if (ierr2/=0) then + write(0,'(2a,3(a,i4),a)') "An error occurred in ccpp_physics_run for group ", "microphysics", & + ", block/chunk ", nb, " and thread ", nt, " (ntX=", ntX, "):" + write(0,'(a)') trim(cdata_block(nb,ntX)%errmsg) + ierr = ierr + ierr2 + endif + else + write(0,'(a)') "An error occurred in ccpp_physics_run for group microphysics. Group microphysics only valid with MPAS dycore." + ierr = ierr + 1 + endif + endif + endif + end do !$OMP end do !$OMP end parallel @@ -269,23 +318,40 @@ subroutine CCPP_step (step, nblks, ierr) return end if - ! call timestep_finalize for "phys_ps"---required for Land IAU - call ccpp_physics_timestep_finalize(cdata_domain, suite_name=trim(ccpp_suite), group_name="phys_ps", ierr=ierr) - if (ierr/=0) then - write(0,'(a)') "An error occurred in ccpp_physics_timestep_finalize for group phys_ps" - write(0,'(a)') trim(cdata_domain%errmsg) - return - end if - - ! call timestep_finalize for "phys_ts"---required for Land IAU - call ccpp_physics_timestep_finalize(cdata_domain, suite_name=trim(ccpp_suite), group_name="phys_ts", ierr=ierr) - if (ierr/=0) then - write(0,'(a)') "An error occurred in ccpp_physics_timestep_finalize for group phys_ts" - write(0,'(a)') trim(cdata_domain%errmsg) - return - end if + if (trim(dycore)=='fv3') then + ! call timestep_finalize for "phys_ps"---required for Land IAU + call ccpp_physics_timestep_finalize(cdata_domain, suite_name=trim(ccpp_suite), group_name="phys_ps", ierr=ierr) + if (ierr/=0) then + write(0,'(a)') "An error occurred in ccpp_physics_timestep_finalize for group phys_ps" + write(0,'(a)') trim(cdata_domain%errmsg) + return + end if + + ! call timestep_finalize for "phys_ts"---required for Land IAU + call ccpp_physics_timestep_finalize(cdata_domain, suite_name=trim(ccpp_suite), group_name="phys_ts", ierr=ierr) + if (ierr/=0) then + write(0,'(a)') "An error occurred in ccpp_physics_timestep_finalize for group phys_ts" + write(0,'(a)') trim(cdata_domain%errmsg) + return + end if + endif + if (trim(dycore)=='mpas') then + call ccpp_physics_timestep_finalize(cdata_domain, suite_name=trim(ccpp_suite), group_name="physics", ierr=ierr) + if (ierr/=0) then + write(0,'(a)') "An error occurred in ccpp_physics_timestep_finalize for group physics" + write(0,'(a)') trim(cdata_domain%errmsg) + return + end if + + call ccpp_physics_timestep_finalize(cdata_domain, suite_name=trim(ccpp_suite), group_name="microphysics", ierr=ierr) + if (ierr/=0) then + write(0,'(a)') "An error occurred in ccpp_physics_timestep_finalize for group microphysics" + write(0,'(a)') trim(cdata_domain%errmsg) + return + end if + endif - ! Physics finalize + ! Physics finalize (same for all dynamical cores) else if (trim(step)=="physics_finalize") then ! Since the physics finalize step is independent of the blocking structure, @@ -300,7 +366,7 @@ subroutine CCPP_step (step, nblks, ierr) return end if - ! Finalize + ! Finalize (same for all dynamical cores) else if (trim(step)=="finalize") then ! Deallocate cdata structure for blocks and threads if (allocated(cdata_block)) deallocate(cdata_block) diff --git a/ccpp/CMakeLists.txt b/ccpp/CMakeLists.txt index f0554c57e..64d6b6be8 100644 --- a/ccpp/CMakeLists.txt +++ b/ccpp/CMakeLists.txt @@ -1,27 +1,41 @@ -cmake_minimum_required(VERSION 3.0) +cmake_minimum_required(VERSION 3.19) project(CCPP-UFS LANGUAGES C CXX Fortran) set(PROJECT "CCPP-UFS") +#------------------------------------------------------------------------------ +# Which dycore are we coupling the CCPP to? +#------------------------------------------------------------------------------ + #------------------------------------------------------------------------------ # FV3 dynamical core #------------------------------------------------------------------------------ if (FV3) message(STATUS "Build CCPP interface to FV3 dynamical core") set(CCPP_TARGET fv3ccpp) - set(CCPP_PREBUILD_CONFIG config/ccpp_prebuild_config.py) + set(CCPP_PREBUILD_CONFIG config/ccpp_prebuild_config_fv3.py) set(DYCORE_CCPP_SRCS driver/GFS_diagnostics.F90 driver/GFS_restart.F90 driver/GFS_init.F90 CCPP_driver.F90 ) - #list(TRANSFORM DYCORE_CCPP_SRCS PREPEND ../ccpp/driver/) # Add dycore-specific preprocessor flag (needed for some physics schemes) add_definitions(-DFV3) +endif() +#------------------------------------------------------------------------------ +# MPAS dynamical core +#------------------------------------------------------------------------------ +if (MPAS) + message(STATUS "Build CCPP interface to MPAS dynamical core") + set(CCPP_TARGET mpasccpp) + set(CCPP_PREBUILD_CONFIG config/ccpp_prebuild_config_mpas.py) + set(DYCORE_CCPP_SRCS + CCPP_driver.F90 + ) endif() #------------------------------------------------------------------------------ @@ -130,7 +144,7 @@ add_library( # Compile GFS_diagnostics.F90 without optimization, this leads to out of memory errors on wcoss_dell_p3 if (FV3) - set_property(SOURCE ../fv3/ccpp/driver/GFS_diagnostics.F90 APPEND_STRING PROPERTY COMPILE_FLAGS "-O0") + set_property(SOURCE driver/GFS_diagnostics.F90 APPEND_STRING PROPERTY COMPILE_FLAGS "-O0") endif() target_link_libraries(${CCPP_TARGET} PUBLIC ccpp_framework) diff --git a/ccpp/config/ccpp_prebuild_config.py b/ccpp/config/ccpp_prebuild_config_fv3.py similarity index 100% rename from ccpp/config/ccpp_prebuild_config.py rename to ccpp/config/ccpp_prebuild_config_fv3.py diff --git a/ccpp/config/ccpp_prebuild_config_mpas.py b/ccpp/config/ccpp_prebuild_config_mpas.py new file mode 100755 index 000000000..bb85073ad --- /dev/null +++ b/ccpp/config/ccpp_prebuild_config_mpas.py @@ -0,0 +1,159 @@ +#!/usr/bin/env python + +# CCPP prebuild config for MPAS - Model for Prediction Across Scales + + +############################################################################### +# Definitions # +############################################################################### + +HOST_MODEL_IDENTIFIER = "MPAS" + +# Add all files with metadata tables on the host model side and in CCPP, +# relative to basedir = top-level directory of host model. This includes +# kind and type definitions used in CCPP physics. Also add any internal +# dependencies of these files to the list. +VARIABLE_DEFINITION_FILES = [ + # actual variable definition files + 'framework/src/ccpp_types.F90', + 'physics/physics/hooks/machine.F', + 'physics/physics/Radiation/RRTMG/radsw_param.f', + 'physics/physics/Radiation/RRTMG/radlw_param.f', + 'physics/physics/photochem/module_ozphys.F90', + 'physics/physics/MP/TEMPO/TEMPO/module_mp_tempo_params.F90', + 'physics/physics/photochem/module_h2ophys.F90', + 'physics/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90', + '../ccpp/data/CCPP_typedefs.F90', + '../ccpp/data/GFS_typedefs.F90', + '../ccpp/data/MPAS_typedefs.F90', + '../ccpp/data/CCPP_data.F90' + ] + +TYPEDEFS_NEW_METADATA = { + 'ccpp_types' : { + 'ccpp_t' : 'cdata', + 'MPI_Comm' : '', + 'ccpp_types' : '', + }, + 'machine' : { + 'machine' : '', + }, + 'module_radlw_parameters' : { + 'module_radsw_parameters' : '', + }, + 'module_radlw_parameters' : { + 'module_radlw_parameters' : '', + }, + 'module_ozphys' : { + 'module_ozphys' : '', + 'ty_ozphys' : '', + }, + 'module_mp_tempo_params' : { + 'module_mp_tempo_params' : '', + 'ty_tempo_cfg' : '', + }, + 'module_h2ophys' : { + 'module_h2ophys' : '', + 'ty_h2ophys' : '', + }, + 'land_iau_mod' : { + 'land_iau_mod' : '', + 'land_iau_external_data_type' : '', + 'land_iau_state_type' : '', + 'land_iau_control_type' : '', + }, + 'CCPP_typedefs' : { + 'GFS_interstitial_type' : 'GFS_Interstitial(cdata%thrd_no)', + 'GFDL_interstitial_type' : 'GFDL_interstitial', + 'CCPP_typedefs' : '', + }, + 'CCPP_data' : { + 'CCPP_data' : '', + }, + 'MPAS_typedefs' : { + 'MPAS_typedefs' : '', + }, + 'GFS_typedefs' : { + 'GFS_control_type' : 'GFS_Control', + 'GFS_statein_type' : 'GFS_Statein', + 'GFS_stateout_type' : 'GFS_Stateout', + 'GFS_grid_type' : 'GFS_Grid', + 'GFS_tbd_type' : 'GFS_Tbd', + 'GFS_cldprop_type' : 'GFS_Cldprop', + 'GFS_sfcprop_type' : 'GFS_Sfcprop', + 'GFS_radtend_type' : 'GFS_Radtend', + 'GFS_coupling_type' : 'GFS_Coupling', + 'GFS_diag_type' : 'GFS_Intdiag', + 'GFS_typedefs' : '', + }, + } + +# Add all physics scheme files relative to basedir +SCHEME_FILES = [ + # Relative path to source (from where ccpp_prebuild.py is called) : [ list of physics sets in which scheme may be called ]; + # current restrictions are that each scheme can only belong to one physics set, and all schemes within one group in the + # suite definition file have to belong to the same physics set + 'physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.F90', + 'physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rad_time_vary.mpas.F90', + 'physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_time_vary_pre.fv3.F90', + 'physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_surface.F90', + 'physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_post.F90', + 'physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.F90', + 'physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.F90', + 'physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.F90', + 'physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_pre.F90', + 'physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_cloud_diagnostics.F90', + 'physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_mp.F90', + 'physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_cloud_overlap.F90', + 'physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_post.F90', + 'physics/physics/Radiation/RRTMG/radsw_main.F90', + 'physics/physics/Radiation/RRTMG/radlw_main.F90', + 'physics/physics/Radiation/RRTMG/rrtmg_lw_post.F90', + 'physics/physics/Radiation/RRTMG/rrtmg_sw_post.F90', + 'physics/physics/Radiation/RRTMG/rad_sw_pre.F90', + 'physics/physics/Radiation/RRTMGP/rrtmgp_aerosol_optics.F90', + 'physics/physics/Radiation/RRTMGP/rrtmgp_lw_main.F90', + 'physics/physics/Radiation/RRTMGP/rrtmgp_sw_main.F90', + 'physics/physics/photochem/module_h2ophys.F90', + 'physics/physics/photochem/module_ozphys.F90' +] + +# Default build dir, relative to current working directory, +# if not specified as command-line argument +DEFAULT_BUILD_DIR = 'build' + +# Auto-generated makefile/cmakefile snippets that contain all type definitions +TYPEDEFS_MAKEFILE = '{build_dir}/physics/CCPP_TYPEDEFS.mk' +TYPEDEFS_CMAKEFILE = '{build_dir}/physics/CCPP_TYPEDEFS.cmake' +TYPEDEFS_SOURCEFILE = '{build_dir}/physics/CCPP_TYPEDEFS.sh' + +# Auto-generated makefile/cmakefile snippets that contain all schemes +SCHEMES_MAKEFILE = '{build_dir}/physics/CCPP_SCHEMES.mk' +SCHEMES_CMAKEFILE = '{build_dir}/physics/CCPP_SCHEMES.cmake' +SCHEMES_SOURCEFILE = '{build_dir}/physics/CCPP_SCHEMES.sh' + +# Auto-generated makefile/cmakefile snippets that contain all caps +CAPS_MAKEFILE = '{build_dir}/physics/CCPP_CAPS.mk' +CAPS_CMAKEFILE = '{build_dir}/physics/CCPP_CAPS.cmake' +CAPS_SOURCEFILE = '{build_dir}/physics/CCPP_CAPS.sh' + +# Directory where to put all auto-generated physics caps +CAPS_DIR = '{build_dir}/physics' + +# Directory where the suite definition files are stored +SUITES_DIR = '../ccpp/suites' + +# Directory where to write static API to +STATIC_API_DIR = '{build_dir}/physics' +STATIC_API_CMAKEFILE = '{build_dir}/physics/CCPP_STATIC_API.cmake' +STATIC_API_SOURCEFILE = '{build_dir}/physics/CCPP_STATIC_API.sh' + +# Directory for writing HTML pages generated from metadata files +# used by metadata2html.py for generating scientific documentation +METADATA_HTML_OUTPUT_DIR = '{build_dir}/physics/physics/docs' + +# HTML document containing the model-defined CCPP variables +HTML_VARTABLE_FILE = '{build_dir}/physics/CCPP_VARIABLES_MPAS.html' + +# LaTeX document containing the provided vs requested CCPP variables +LATEX_VARTABLE_FILE = '{build_dir}/framework/doc/DevelopersGuide/CCPP_VARIABLES_MPAS.tex' diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index a5febdbb2..ef1ec2095 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -778,6 +778,11 @@ module GFS_typedefs ! integer :: fire_aux_data_levels !< vertical levels of fire auxiliary data +!--- dycore control parameters + integer :: dycore_active !< Choice of dynamical core + integer :: dycore_fv3 = 1 !< Choice of FV3 dynamical core + integer :: dycore_mpas = 2 !< Choice of MPAS dynamical core + !--- coupling parameters logical :: cplflx !< default no cplflx collection logical :: cplice !< default no cplice collection (used together with cplflx) @@ -3365,15 +3370,15 @@ end subroutine coupling_create !---------------------- ! GFS_control_type%init !---------------------- - subroutine control_initialize (Model, nlunit, fn_nml, me, master, & - logunit, isc, jsc, nx, ny, levs, & - cnx, cny, gnx, gny, dt_dycore, & + subroutine control_initialize (Model, nlunit, fn_nml, me, & + master, logunit, levs, dt_dycore, & dt_phys, iau_offset, idat, jdat, & nwat, tracer_names, tracer_types, & - input_nml_file, tile_num, blksz, & - ak, bk, restart, hydrostatic, & - communicator, ntasks, nthreads) - + input_nml_file, blksz, restart, & + communicator, ntasks, nthreads, & + tile_num, isc, jsc, nx, ny, cnx, & + cny, gnx, gny, ak, bk, hydrostatic) + !--- modules use physcons, only: con_rerth, con_pi use mersenne_twister, only: random_setseed, random_number @@ -3387,16 +3392,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & integer, intent(in) :: me integer, intent(in) :: master integer, intent(in) :: logunit - integer, intent(in) :: tile_num - integer, intent(in) :: isc - integer, intent(in) :: jsc - integer, intent(in) :: nx - integer, intent(in) :: ny integer, intent(in) :: levs - integer, intent(in) :: cnx - integer, intent(in) :: cny - integer, intent(in) :: gnx - integer, intent(in) :: gny real(kind=kind_phys), intent(in) :: dt_dycore real(kind=kind_phys), intent(in) :: dt_phys integer, intent(in) :: iau_offset @@ -3407,13 +3403,23 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & integer, intent(in) :: tracer_types(:) character(len=:), intent(in), dimension(:), pointer :: input_nml_file integer, intent(in) :: blksz(:) - real(kind=kind_phys), dimension(:), intent(in) :: ak - real(kind=kind_phys), dimension(:), intent(in) :: bk logical, intent(in) :: restart - logical, intent(in) :: hydrostatic type(MPI_Comm), intent(in) :: communicator integer, intent(in) :: ntasks integer, intent(in) :: nthreads + !--- optional variables (Dycore specific) + integer, optional, intent(in) :: tile_num + integer, optional, intent(in) :: isc + integer, optional, intent(in) :: jsc + integer, optional, intent(in) :: nx + integer, optional, intent(in) :: ny + integer, optional, intent(in) :: cnx + integer, optional, intent(in) :: cny + integer, optional, intent(in) :: gnx + integer, optional, intent(in) :: gny + logical, optional, intent(in) :: hydrostatic + real(kind_phys), optional, dimension(:), intent(in) :: ak + real(kind_phys), optional, dimension(:), intent(in) :: bk !--- local variables integer :: i, j, n @@ -4306,6 +4312,58 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- NRL ozone physics character(len=128) :: err_message + !--- If initializing model with FV3 dynamical core. + if (Model%dycore_active == Model%dycore_fv3) then + if (.not. present(tile_num)) then + write(6,*) 'ERROR: is required when using FV3 dynamical core' + stop + endif + if (.not. present(isc)) then + write(6,*) 'ERROR: is required when using FV3 dynamical core' + stop + endif + if (.not. present(jsc)) then + write(6,*) 'ERROR: is required when using FV3 dynamical core' + stop + endif + if (.not. present(nx)) then + write(6,*) 'ERROR: is required when using FV3 dynamical core' + stop + endif + if (.not. present(ny)) then + write(6,*) 'ERROR: is required when using FV3 dynamical core' + stop + endif + if (.not. present(cnx)) then + write(6,*) 'ERROR: is required when using FV3 dynamical core' + stop + endif + if (.not. present(cny)) then + write(6,*) 'ERROR: is required when using FV3 dynamical core' + stop + endif + if (.not. present(gnx)) then + write(6,*) 'ERROR: is required when using FV3 dynamical core' + stop + endif + if (.not. present(gny)) then + write(6,*) 'ERROR: is required when using FV3 dynamical core' + stop + endif + if (.not. present(hydrostatic)) then + write(6,*) 'ERROR: is required when using FV3 dynamical core' + stop + endif + if (.not. present(ak)) then + write(6,*) 'ERROR: is required when using FV3 dynamical core' + stop + endif + if (.not. present(bk)) then + write(6,*) 'ERROR: is required when using FV3 dynamical core' + stop + endif + endif + ! dtend selection: default is to match all variables: dtend_select(1)='*' do ipat=2,pat_count @@ -4454,23 +4512,28 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%sfcpress_id = sfcpress_id Model%gen_coord_hybrid = gen_coord_hybrid - !--- set some grid extent parameters - Model%tile_num = tile_num - Model%isc = isc - Model%jsc = jsc - Model%nx = nx - Model%ny = ny + !--- set some grid extent parameters (dycore specific) + if (Model%dycore_active == Model%dycore_fv3) then + Model%tile_num = tile_num + Model%isc = isc + Model%jsc = jsc + Model%nx = nx + Model%ny = ny + allocate (Model%ak(1:size(ak))) + allocate (Model%bk(1:size(bk))) + Model%ak = ak + Model%bk = bk + Model%cnx = cnx + Model%cny = cny + Model%lonr = gnx ! number longitudinal points + Model%latr = gny ! number of latitudinal points from pole to pole + endif + if (Model%dycore_active == Model%dycore_mpas) then + + end if Model%levs = levs - allocate (Model%ak(1:size(ak))) - allocate (Model%bk(1:size(bk))) - Model%ak = ak - Model%bk = bk Model%levsp1 = Model%levs + 1 Model%levsm1 = Model%levs - 1 - Model%cnx = cnx - Model%cny = cny - Model%lonr = gnx ! number longitudinal points - Model%latr = gny ! number of latitudinal points from pole to pole Model%nblks = size(blksz) allocate (Model%blksz(1:Model%nblks)) Model%blksz = blksz @@ -5826,28 +5889,38 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%first_time_step = .true. Model%restart = restart Model%lsm_cold_start = .not. restart - Model%hydrostatic = hydrostatic if (Model%me == Model%master) then print *,'in atm phys init, phour=',Model%phour,'fhour=',Model%fhour,'zhour=',Model%zhour,'kdt=',Model%kdt endif - - if(Model%hydrostatic .and. Model%lightning_threat) then - write(0,*) 'Turning off lightning threat index for hydrostatic run.' - Model%lightning_threat = .false. - lightning_threat = .false. + if (Model%dycore_active == Model%dycore_fv3) then + Model%hydrostatic = hydrostatic + if(Model%hydrostatic .and. Model%lightning_threat) then + write(0,*) 'Turning off lightning threat index for hydrostatic run.' + Model%lightning_threat = .false. + lightning_threat = .false. + endif endif - Model%jdat(1:8) = jdat(1:8) - allocate (Model%si(Model%levs+1)) - !--- Define sigma level for radiation initialization + !--- Define sigma level for radiation initialization (FV3) !--- The formula converting hybrid sigma pressure coefficients to sigma coefficients follows Eckermann (2009, MWR) !--- ps is replaced with p0. The value of p0 uses that in http://www.emc.ncep.noaa.gov/officenotes/newernotes/on461.pdf !--- ak/bk have been flipped from their original FV3 orientation and are defined sfc -> toa - Model%si(1:Model%levs+1) = (ak(1:Model%levs+1) + bk(1:Model%levs+1) * con_p0 - ak(Model%levs+1)) / (con_p0 - ak(Model%levs+1)) + allocate (Model%si(Model%levs+1)) + if (Model%dycore_active == Model%dycore_fv3) then + Model%si(1:Model%levs+1) = (ak(1:Model%levs+1) + bk(1:Model%levs+1) * con_p0 - ak(Model%levs+1)) / (con_p0 - ak(Model%levs+1)) + end if + ! DJS2025: NOT YET IMPLEMENTED + if (Model%dycore_active == Model%dycore_mpas) then + Model%si(1:Model%levs+1) = 1._kind_phys + endif + + ! --- Set default time + Model%jdat(1:8) = jdat(1:8) Model%sec = 0 Model%yearlen = 365 Model%julian = -9999. + !--- Set vertical flag used by radiation schemes Model%top_at_1 = .false. if (Model%do_RRTMGP) then @@ -6445,6 +6518,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & ! Model%upd_slc = land_iau_upd_slc ! Model%do_stcsmc_adjustment = land_iau_do_stcsmc_adjustment ! Model%min_T_increment = land_iau_min_T_increment + call Model%print () end subroutine control_initialize @@ -6649,18 +6723,23 @@ subroutine control_print(Model) print *, ' thermodyn_id : ', Model%thermodyn_id print *, ' sfcpress_id : ', Model%sfcpress_id print *, ' gen_coord_hybrid : ', Model%gen_coord_hybrid - print *, ' hydrostatic : ', Model%hydrostatic + if (Model%dycore_active == Model%dycore_fv3) then + print *, ' hydrostatic : ', Model%hydrostatic + endif print *, ' ' print *, 'grid extent parameters' - print *, ' isc : ', Model%isc - print *, ' jsc : ', Model%jsc - print *, ' nx : ', Model%nx - print *, ' ny : ', Model%ny - print *, ' levs : ', Model%levs - print *, ' cnx : ', Model%cnx - print *, ' cny : ', Model%cny - print *, ' lonr : ', Model%lonr - print *, ' latr : ', Model%latr + if (Model%dycore_active == Model%dycore_fv3) then + print *, ' isc : ', Model%isc + print *, ' jsc : ', Model%jsc + print *, ' nx : ', Model%nx + print *, ' ny : ', Model%ny + print *, ' levs : ', Model%levs + print *, ' cnx : ', Model%cnx + print *, ' cny : ', Model%cny + print *, ' lonr : ', Model%lonr + print *, ' latr : ', Model%latr + end if + print *, ' nblks : ', Model%nblks print *, ' blksz(1) : ', Model%blksz(1) print *, ' blksz(nblks) : ', Model%blksz(Model%nblks) print *, ' Model%ncols : ', Model%ncols diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index 096d7c4cc..d34d80462 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -3685,6 +3685,24 @@ units = index dimensions = () type = integer +[dycore_active] + standard_name = control_for_dynamical_core + long_name = choice of dynamical core + units = flag + dimensions = () + type = integer +[dycore_fv3] + standard_name = identifier_for_fv3_dynamical_core + long_name = identifier for FV3 dynamical core + units = flag + dimensions = () + type = integer +[dycore_mpas] + standard_name = identifier_for_mpas_dynamical_core + long_name = identifier for MPAS dynamical core + units = flag + dimensions = () + type = integer [tile_num] standard_name = index_of_cubed_sphere_tile long_name = tile number diff --git a/ccpp/data/MPAS_typedefs.F90 b/ccpp/data/MPAS_typedefs.F90 new file mode 100644 index 000000000..31bbec27b --- /dev/null +++ b/ccpp/data/MPAS_typedefs.F90 @@ -0,0 +1,12 @@ +! ########################################################################################### +!> \file MPAS_typedefs.F90 +! ########################################################################################### +module MPAS_typedefs + use mpi_f08 + use machine, only: kind_phys, kind_dbl_prec, kind_sngl_prec + implicit none + +!> \section arg_table_MPAS_typedefs +!! \htmlinclude MPAS_typedefs.html +!! +end module MPAS_typedefs diff --git a/ccpp/data/MPAS_typedefs.meta b/ccpp/data/MPAS_typedefs.meta new file mode 100644 index 000000000..21c41ebb1 --- /dev/null +++ b/ccpp/data/MPAS_typedefs.meta @@ -0,0 +1,10 @@ +######################################################################## +[ccpp-table-properties] + name = MPAS_typedefs + type = module + relative_path = ../physics/physics/ + dependencies = hooks/machine.F + +[ccpp-arg-table] + name = MPAS_typedefs + type = module diff --git a/ccpp/driver/GFS_init.F90 b/ccpp/driver/GFS_init.F90 index af1b768bc..25419e714 100644 --- a/ccpp/driver/GFS_init.F90 +++ b/ccpp/driver/GFS_init.F90 @@ -64,22 +64,26 @@ subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & #endif !--- set control properties (including namelist read) + Model%dycore_active = Model%dycore_fv3 call Model%init (Init_parm%nlunit, Init_parm%fn_nml, & Init_parm%me, Init_parm%master, & - Init_parm%logunit, Init_parm%isc, & - Init_parm%jsc, Init_parm%nx, Init_parm%ny, & - Init_parm%levs, Init_parm%cnx, Init_parm%cny, & - Init_parm%gnx, Init_parm%gny, & + Init_parm%logunit, Init_parm%levs, & Init_parm%dt_dycore, Init_parm%dt_phys, & Init_parm%iau_offset, Init_parm%bdat, & Init_parm%cdat, Init_parm%nwat, & Init_parm%tracer_names, & Init_parm%tracer_types, & - Init_parm%input_nml_file, Init_parm%tile_num, & - Init_parm%blksz, Init_parm%ak, Init_parm%bk, & - Init_parm%restart, Init_parm%hydrostatic, & - Init_parm%fcst_mpi_comm, & - Init_parm%fcst_ntasks, nthrds) + Init_parm%input_nml_file, Init_parm%blksz, & + Init_parm%restart, Init_parm%fcst_mpi_comm, & + Init_parm%fcst_ntasks, nthrds, & + ! Below only needed for FV3 dynamical core. + tile_num = Init_parm%tile_num, & + isc = Init_parm%isc, jsc = Init_parm%jsc, & + nx = Init_parm%nx, ny = Init_parm%ny, & + cnx = Init_parm%cnx, cny = Init_parm%cny, & + gnx = Init_parm%gnx, gny = Init_parm%gny, & + ak = Init_parm%ak, bk = Init_parm%bk, & + hydrostatic = Init_parm%hydrostatic) call Statein%create(Model) call Stateout%create(Model) diff --git a/ccpp/driver/MPAS_init.F90 b/ccpp/driver/MPAS_init.F90 new file mode 100644 index 000000000..f1e570fe1 --- /dev/null +++ b/ccpp/driver/MPAS_init.F90 @@ -0,0 +1,108 @@ +! ########################################################################################### +!> \file MPAS_init.F90 +!> +! ########################################################################################### +module MPAS_init + use machine, only : kind_phys + use ufs_mpas_subdriver, only : MPAS_control_type + use GFS_typedefs, only : GFS_control_type, GFS_diag_type, GFS_grid_type, GFS_tbd_type + use GFS_typedefs, only : GFS_sfcprop_type, GFS_statein_type, GFS_cldprop_type + use GFS_typedefs, only : GFS_radtend_type + use GFS_typedefs, only : GFS_coupling_type + use CCPP_typedefs, only : GFS_interstitial_type + + implicit none + + public :: MPAS_initialize + +contains + !> ######################################################################################### + !> Procedure to initialize MPAS interface to CCPP Physics. + !> + !> ######################################################################################### + subroutine MPAS_initialize (Model, Diag, Grid, Tbd, SfcProp, Statein, CldProp, RadTend, & + Coupling, Init_parm, Interstitial) +#ifdef _OPENMP + use omp_lib +#endif + + ! Inputs + type(GFS_control_type), intent(inout) :: Model + type(GFS_diag_type), intent(inout) :: Diag + type(GFS_grid_type), intent(inout) :: Grid + type(GFS_tbd_type), intent(inout) :: Tbd + type(GFS_sfcprop_type), intent(inout) :: SfcProp + type(GFS_statein_type), intent(inout) :: Statein + type(GFS_cldprop_type), intent(inout) :: Cldprop + type(GFS_radtend_type), intent(inout) :: Radtend + type(GFS_coupling_type), intent(inout) :: Coupling + type(MPAS_control_type), intent(inout) :: Init_parm + type(GFS_interstitial_type), intent(inout) :: Interstitial(:) + + ! Locals + integer :: nb + integer :: nblks + integer :: nt + integer :: nthrds + logical :: non_uniform_blocks + integer :: ix + + nblks = size(Init_parm%blksz) + +#ifdef _OPENMP + nthrds = omp_get_max_threads() +#else + nthrds = 1 +#endif + + ! Set control properties (including physics namelist read) + Model%dycore_active = Model%dycore_mpas + call Model%init(Init_parm%nlunit, Init_parm%fn_nml, Init_parm%me, Init_parm%master, & + Init_parm%logunit, Init_parm%levs, real(Init_parm%dt_dycore, kind_phys), & + real(Init_parm%dt_phys, kind_phys), Init_parm%iau_offset, Init_parm%bdat, & + Init_parm%cdat, Init_parm%nwat, Init_parm%tracer_names, Init_parm%tracer_types, & + Init_parm%input_nml_file, Init_parm%blksz, Init_parm%restart, Init_parm%mpi_comm, & + Init_parm%fcst_ntasks, nthrds) + + ! Allocate data containers for physics. + call Grid%create(Model) + call Diag%create(Model) + call Tbd%create(Model) + call SfcProp%create(Model) + call Statein%create(Model) + call Cldprop%create(Model) + call Radtend%create(Model) + call Coupling%create(Model) + + ! This logic deals with non-uniform block sizes for CCPP. When non-uniform block sizes + ! are used, it is required that only the last block has a different (smaller) size than + ! all other blocks. This is the standard in FV3. If this is the case, set non_uniform_blocks + ! to .true. and initialize nthreads+1 elements of the interstitial array. The extra element + ! will be used by the thread that runs over the last, smaller block. + if (minval(Init_parm%blksz)==maxval(Init_parm%blksz)) then + non_uniform_blocks = .false. + elseif (all(minloc(Init_parm%blksz)==(/size(Init_parm%blksz)/))) then + non_uniform_blocks = .true. + else + write(0,'(2a)') 'For non-uniform blocksizes, only the last element ', & + 'in Init_parm%blksz can be different from the others' + stop + endif + + ! Initialize the Interstitial data type in parallel so that + ! each thread creates (touches) its Interstitial(nt) first. + !$OMP parallel do default (shared) & + !$OMP schedule (static,1) & + !$OMP private (nt) + do nt=1,nthrds + call Interstitial(nt)%create(maxval(Init_parm%blksz), Model) + enddo + !$OMP end parallel do + + if (non_uniform_blocks) then + call Interstitial(nthrds+1)%create(Init_parm%blksz(nblks), Model) + end if + + end subroutine MPAS_initialize + +end module MPAS_init diff --git a/ccpp/physics b/ccpp/physics index 8292b660e..2c4dbd1fa 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 8292b660ec9d692577c5490738335341dd4420eb +Subproject commit 2c4dbd1fabbea6c332eea2ba97a15bd80a55e630 diff --git a/ccpp/suites/suite_MPAS_RRFS.xml b/ccpp/suites/suite_MPAS_RRFS.xml new file mode 100644 index 000000000..2f8f81c3c --- /dev/null +++ b/ccpp/suites/suite_MPAS_RRFS.xml @@ -0,0 +1,28 @@ + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_rrtmg_pre + GFS_radiation_surface + rad_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + + + diff --git a/fv3/atmos_model.F90 b/fv3/atmos_model.F90 index e4ab41774..611f99b20 100644 --- a/fv3/atmos_model.F90 +++ b/fv3/atmos_model.F90 @@ -91,7 +91,7 @@ module atmos_model_mod GFS_interstitial use GFS_init, only: GFS_initialize use CCPP_driver, only: CCPP_step, non_uniform_blocks - +use mod_ufsatm_util, only: get_atmos_tracer_types use stochastic_physics_wrapper_mod, only: stochastic_physics_wrapper,stochastic_physics_wrapper_end use fv3atm_history_io_mod, only: fv3atm_diag_register, fv3atm_diag_output, & @@ -294,7 +294,7 @@ subroutine update_atmos_radiation_physics (Atmos) !--- execute the atmospheric setup step call mpp_clock_begin(setupClock) - call CCPP_step (step="timestep_init", nblks=Atm_block%nblks, ierr=ierr) + call CCPP_step (step="timestep_init", nblks=Atm_block%nblks, ierr=ierr, dycore='fv3') if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP timestep_init step failed') if (GFS_Control%do_sppt .or. GFS_Control%do_shum .or. GFS_Control%do_skeb .or. & @@ -369,7 +369,7 @@ subroutine update_atmos_radiation_physics (Atmos) call mpp_clock_begin(radClock) ! Performance improvement. Only enter if it is time to call the radiation physics. if (GFS_control%lsswr .or. GFS_control%lslwr) then - call CCPP_step (step="radiation", nblks=Atm_block%nblks, ierr=ierr) + call CCPP_step (step="radiation", nblks=Atm_block%nblks, ierr=ierr, dycore='fv3') if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP radiation step failed') endif call mpp_clock_end(radClock) @@ -384,7 +384,7 @@ subroutine update_atmos_radiation_physics (Atmos) !--- execute the atmospheric physics step1 subcomponent (main physics driver) call mpp_clock_begin(physClock) - call CCPP_step (step="physics", nblks=Atm_block%nblks, ierr=ierr) + call CCPP_step (step="physics", nblks=Atm_block%nblks, ierr=ierr, dycore='fv3') if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP physics step failed') call mpp_clock_end(physClock) @@ -401,7 +401,7 @@ subroutine update_atmos_radiation_physics (Atmos) !--- execute the atmospheric physics step2 subcomponent (stochastic physics driver) call mpp_clock_begin(physClock) - call CCPP_step (step="stochastics", nblks=Atm_block%nblks, ierr=ierr) + call CCPP_step (step="stochastics", nblks=Atm_block%nblks, ierr=ierr, dycore='fv3') if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP stochastics step failed') call mpp_clock_end(physClock) @@ -416,7 +416,7 @@ subroutine update_atmos_radiation_physics (Atmos) !--- execute the atmospheric timestep finalize step call mpp_clock_begin(setupClock) - call CCPP_step (step="timestep_finalize", nblks=Atm_block%nblks, ierr=ierr) + call CCPP_step (step="timestep_finalize", nblks=Atm_block%nblks, ierr=ierr, dycore='fv3') if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP timestep_finalize step failed') call mpp_clock_end(setupClock) @@ -769,10 +769,10 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) endif ! Initialize the CCPP framework - call CCPP_step (step="init", nblks=Atm_block%nblks, ierr=ierr) + call CCPP_step (step="init", nblks=Atm_block%nblks, ierr=ierr, dycore='fv3') if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP init step failed') ! Initialize the CCPP physics - call CCPP_step (step="physics_init", nblks=Atm_block%nblks, ierr=ierr) + call CCPP_step (step="physics_init", nblks=Atm_block%nblks, ierr=ierr, dycore='fv3') if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP physics_init step failed') if (GFS_Control%do_sppt .or. GFS_Control%do_shum .or. GFS_Control%do_skeb .or. & @@ -1137,11 +1137,11 @@ subroutine atmos_model_end (Atmos) ! Fast physics (from dynamics) are finalized in atmosphere_end above; ! standard/slow physics (from CCPP) are finalized in CCPP_step 'physics_finalize'. - call CCPP_step (step="physics_finalize", nblks=Atm_block%nblks, ierr=ierr) + call CCPP_step (step="physics_finalize", nblks=Atm_block%nblks, ierr=ierr, dycore='fv3') if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP physics_finalize step failed') ! The CCPP framework for all cdata structures is finalized in CCPP_step 'finalize'. - call CCPP_step (step="finalize", nblks=Atm_block%nblks, ierr=ierr) + call CCPP_step (step="finalize", nblks=Atm_block%nblks, ierr=ierr, dycore='fv3') if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP finalize step failed') deallocate (Atmos%lon, Atmos%lat) @@ -1202,111 +1202,6 @@ subroutine get_atmos_model_ungridded_dim(nlev, nsoillev, ntracers) end subroutine get_atmos_model_ungridded_dim ! -!####################################################################### -! -! -! Identify and return usage and type id of atmospheric tracers. -! Ids are defined as: -! 0 = generic tracer -! 1 = chemistry - prognostic -! 2 = chemistry - diagnostic -! -! Tracers are identified via the additional 'tracer_usage' keyword and -! their optional 'type' qualifier. A tracer is assumed prognostic if -! 'type' is not provided. See examples from the field_table file below: -! -! Prognostic tracer: -! ------------------ -! "TRACER", "atmos_mod", "so2" -! "longname", "so2 mixing ratio" -! "units", "ppm" -! "tracer_usage", "chemistry" -! "profile_type", "fixed", "surface_value=5.e-6" / -! -! Diagnostic tracer: -! ------------------ -! "TRACER", "atmos_mod", "pm25" -! "longname", "PM2.5" -! "units", "ug/m3" -! "tracer_usage", "chemistry", "type=diagnostic" -! "profile_type", "fixed", "surface_value=5.e-6" / -! -! For atmospheric chemistry, the order of both prognostic and diagnostic -! tracers is validated against the model's internal assumptions. -! -! -subroutine get_atmos_tracer_types(tracer_types) - - use field_manager_mod, only: parse - use tracer_manager_mod, only: query_method - - integer, intent(out) :: tracer_types(:) - - !--- local variables - logical :: found - integer :: n, num_tracers, num_types - integer :: id_max, id_min, id_num, ip_max, ip_min, ip_num - character(len=32) :: tracer_usage - character(len=128) :: control, tracer_type - - !--- begin - - !--- validate array size - call get_number_tracers(MODEL_ATMOS, num_tracers=num_tracers) - - if (size(tracer_types) < num_tracers) & - call mpp_error(FATAL, 'insufficient size of tracer type array') - - !--- initialize tracer indices - id_min = num_tracers + 1 - id_max = -id_min - ip_min = id_min - ip_max = id_max - id_num = 0 - ip_num = 0 - - do n = 1, num_tracers - tracer_types(n) = 0 - found = query_method('tracer_usage',MODEL_ATMOS,n,tracer_usage,control) - if (found) then - if (trim(tracer_usage) == 'chemistry') then - !--- set default to prognostic - tracer_type = 'prognostic' - num_types = parse(control, 'type', tracer_type) - select case (trim(tracer_type)) - case ('diagnostic') - tracer_types(n) = 2 - id_num = id_num + 1 - id_max = n - if (id_num == 1) id_min = n - case ('prognostic') - tracer_types(n) = 1 - ip_num = ip_num + 1 - ip_max = n - if (ip_num == 1) ip_min = n - end select - end if - end if - end do - - if (ip_num > 0) then - !--- check if prognostic tracers are contiguous - if (ip_num > ip_max - ip_min + 1) & - call mpp_error(FATAL, 'prognostic chemistry tracers must be contiguous') - end if - - if (id_num > 0) then - !--- check if diagnostic tracers are contiguous - if (id_num > id_max - id_min + 1) & - call mpp_error(FATAL, 'diagnostic chemistry tracers must be contiguous') - end if - - !--- prognostic tracers must precede diagnostic ones - if (ip_max > id_min) & - call mpp_error(FATAL, 'diagnostic chemistry tracers must follow prognostic ones') - -end subroutine get_atmos_tracer_types -! !####################################################################### ! diff --git a/fv3/io/fv3atm_clm_lake_io.F90 b/io/fv3atm_clm_lake_io.F90 similarity index 100% rename from fv3/io/fv3atm_clm_lake_io.F90 rename to io/fv3atm_clm_lake_io.F90 diff --git a/fv3/io/fv3atm_common_io.F90 b/io/fv3atm_common_io.F90 similarity index 100% rename from fv3/io/fv3atm_common_io.F90 rename to io/fv3atm_common_io.F90 diff --git a/fv3/io/fv3atm_history_io.F90 b/io/fv3atm_history_io.F90 similarity index 100% rename from fv3/io/fv3atm_history_io.F90 rename to io/fv3atm_history_io.F90 diff --git a/fv3/io/fv3atm_oro_io.F90 b/io/fv3atm_oro_io.F90 similarity index 100% rename from fv3/io/fv3atm_oro_io.F90 rename to io/fv3atm_oro_io.F90 diff --git a/fv3/io/fv3atm_restart_io.F90 b/io/fv3atm_restart_io.F90 similarity index 100% rename from fv3/io/fv3atm_restart_io.F90 rename to io/fv3atm_restart_io.F90 diff --git a/fv3/io/fv3atm_rrfs_sd_io.F90 b/io/fv3atm_rrfs_sd_io.F90 similarity index 100% rename from fv3/io/fv3atm_rrfs_sd_io.F90 rename to io/fv3atm_rrfs_sd_io.F90 diff --git a/fv3/io/fv3atm_sfc_io.F90 b/io/fv3atm_sfc_io.F90 similarity index 100% rename from fv3/io/fv3atm_sfc_io.F90 rename to io/fv3atm_sfc_io.F90 diff --git a/fv3/io/module_fv3_io_def.F90 b/io/module_fv3_io_def.F90 similarity index 100% rename from fv3/io/module_fv3_io_def.F90 rename to io/module_fv3_io_def.F90 diff --git a/fv3/io/module_write_internal_state.F90 b/io/module_write_internal_state.F90 similarity index 100% rename from fv3/io/module_write_internal_state.F90 rename to io/module_write_internal_state.F90 diff --git a/fv3/io/module_write_netcdf.F90 b/io/module_write_netcdf.F90 similarity index 100% rename from fv3/io/module_write_netcdf.F90 rename to io/module_write_netcdf.F90 diff --git a/fv3/io/module_write_restart_netcdf.F90 b/io/module_write_restart_netcdf.F90 similarity index 100% rename from fv3/io/module_write_restart_netcdf.F90 rename to io/module_write_restart_netcdf.F90 diff --git a/fv3/io/module_wrt_grid_comp.F90 b/io/module_wrt_grid_comp.F90 similarity index 100% rename from fv3/io/module_wrt_grid_comp.F90 rename to io/module_wrt_grid_comp.F90 diff --git a/fv3/io/post_fv3.F90 b/io/post_fv3.F90 similarity index 100% rename from fv3/io/post_fv3.F90 rename to io/post_fv3.F90 diff --git a/fv3/io/post_nems_routines.F90 b/io/post_nems_routines.F90 similarity index 100% rename from fv3/io/post_nems_routines.F90 rename to io/post_nems_routines.F90 diff --git a/mpas/CMakeLists.txt b/mpas/CMakeLists.txt new file mode 100644 index 000000000..8954cf774 --- /dev/null +++ b/mpas/CMakeLists.txt @@ -0,0 +1,128 @@ +cmake_minimum_required(VERSION 3.19) + +project(MPAS + VERSION 1.0.0 + LANGUAGES Fortran) + +include(${CMAKE_CURRENT_SOURCE_DIR}/MPAS-Model/cmake/Functions/MPAS_Functions.cmake) + +list(INSERT CMAKE_MODULE_PATH 0 ${CMAKE_CURRENT_SOURCE_DIR}/cmake/Modules) +set(CMAKE_DIRECTORY_LABELS ${PROJECT_NAME}) +include(GNUInstallDirs) + +# Build product output locations +set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin) +set(CMAKE_LIBRARY_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/lib) +set(CMAKE_ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/lib) + +# Set default build type to RelWithDebInfo +if(NOT CMAKE_BUILD_TYPE) + message(STATUS "Setting default build type to Release. Specify CMAKE_BUILD_TYPE to override.") + set(CMAKE_BUILD_TYPE "Release" CACHE STRING "CMake Build type" FORCE) + set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release" "MinSizeRel" "RelWithDebInfo") +endif() + +# Find C pre-processor +if(CMAKE_C_COMPILER_ID MATCHES GNU) + find_program(CPP_EXECUTABLE NAMES cpp REQUIRED) + set(CPP_EXTRA_FLAGS -traditional) +elseif(CMAKE_C_COMPILER_ID MATCHES "(Apple)?Clang" ) + find_program(CPP_EXECUTABLE NAMES cpp REQUIRED) +else() + message(STATUS "Unknown compiler: ${CMAKE_C_COMPILER_ID}") + set(CPP_EXECUTABLE ${CMAKE_C_COMPILER}) +endif() + +# Fortran module output directory for build interface +set(MPAS_MODULE_DIR ${PROJECT_NAME}/module/${CMAKE_Fortran_COMPILER_ID}/${CMAKE_Fortran_COMPILER_VERSION}) + +# Install Fortran module directory +install(DIRECTORY ${CMAKE_BINARY_DIR}/${MPAS_MODULE_DIR}/ DESTINATION ${CMAKE_INSTALL_LIBDIR}/${MPAS_MODULE_DIR}/) + +############################################################################### +# Build MPAS libraries... +############################################################################### + +# MPAS Utilities (Externals) +add_subdirectory(MPAS-Model/src/external/ezxml) + +# ESMF libraries. +if(NOT ESMF_FOUND) + find_package(ESMF REQUIRED) +endif() +add_definitions(-DMPAS_EXTERNAL_ESMF_LIB -DMPAS_NO_ESMF_INIT) +add_library(${PROJECT_NAME}::external::esmf ALIAS esmf) + +# MPAS Namelist +add_subdirectory(MPAS-Model/src/tools/input_gen) # Targets: namelist_gen, streams_gen + +# MPAS Registry +add_subdirectory(MPAS-Model/src/tools/registry) # Targets: mpas_parse_ + +# MPAS framework +add_subdirectory(MPAS-Model/src/framework) # Target: MPAS::framework + +# MPAS operators +add_subdirectory(MPAS-Model/src/operators) # Target: MPAS::operators + +# MPAS atmosphere +add_subdirectory(MPAS-Model/src/core_atmosphere) # Target: core_atmosphere +add_library(mpas ALIAS core_atmosphere) + +############################################################################### +# Package Configurations +############################################################################### +include(CMakePackageConfigHelpers) + +# Build-tree target exports +export(EXPORT ${PROJECT_NAME}ExportsExternal NAMESPACE ${PROJECT_NAME}::external:: FILE ${PROJECT_NAME}-targets-external.cmake) +export(EXPORT ${PROJECT_NAME}Exports NAMESPACE ${PROJECT_NAME}:: FILE ${PROJECT_NAME}-targets.cmake) +export(EXPORT ${PROJECT_NAME}ExportsCore NAMESPACE ${PROJECT_NAME}::core:: FILE ${PROJECT_NAME}-targets-core.cmake) + +# CMake Config file install location +set(CONFIG_INSTALL_DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}) +install(DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/cmake/Modules DESTINATION ${CONFIG_INSTALL_DESTINATION}) + +#### +set(BINDIR ${CMAKE_BINARY_DIR}/bin) +set(CORE_DATADIR_ROOT ${CMAKE_BINARY_DIR}/${PROJECT_NAME}) +set(CMAKE_MODULE_INSTALL_PATH ${CMAKE_CURRENT_SOURCE_DIR}/cmake/Modules) +string(TOLOWER ${PROJECT_NAME} PROJECT_NAME_LOWER) +configure_package_config_file( + MPAS-Model/cmake/PackageConfig.cmake.in ${PROJECT_NAME_LOWER}-config.cmake + INSTALL_DESTINATION . + INSTALL_PREFIX ${CMAKE_CURRENT_BINARY_DIR} + PATH_VARS BINDIR CORE_DATADIR_ROOT CMAKE_MODULE_INSTALL_PATH) + +### +set(BINDIR ${CMAKE_INSTALL_BINDIR}) +set(CORE_DATADIR_ROOT ${CMAKE_INSTALL_DATADIR}/${PROJECT_NAME}) +set(CMAKE_MODULE_INSTALL_PATH ${CONFIG_INSTALL_DESTINATION}/Modules) +configure_package_config_file( + MPAS-Model/cmake/PackageConfig.cmake.in install/${PROJECT_NAME_LOWER}-config.cmake + INSTALL_DESTINATION ${CONFIG_INSTALL_DESTINATION} + PATH_VARS BINDIR CORE_DATADIR_ROOT CMAKE_MODULE_INSTALL_PATH) +install(FILES ${CMAKE_CURRENT_BINARY_DIR}/install/${PROJECT_NAME_LOWER}-config.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) + +### +write_basic_package_version_file( + ${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME_LOWER}-config-version.cmake + VERSION ${PROJECT_VERSION} + COMPATIBILITY AnyNewerVersion) +install(FILES ${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME_LOWER}-config-version.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) + +### +install(EXPORT ${PROJECT_NAME}ExportsExternal + NAMESPACE ${PROJECT_NAME}::external:: + FILE ${PROJECT_NAME_LOWER}-targets-external.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) +install(EXPORT ${PROJECT_NAME}Exports + NAMESPACE ${PROJECT_NAME}:: + FILE ${PROJECT_NAME_LOWER}-targets.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) +install(EXPORT ${PROJECT_NAME}ExportsCore + NAMESPACE ${PROJECT_NAME}::core:: + FILE ${PROJECT_NAME_LOWER}-targets-core.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) diff --git a/mpas/MPAS-Model b/mpas/MPAS-Model new file mode 160000 index 000000000..38d2177ae --- /dev/null +++ b/mpas/MPAS-Model @@ -0,0 +1 @@ +Subproject commit 38d2177aef842a5c6abe26ffe876804b95fd9e0a diff --git a/mpas/atmos_coupling.F90 b/mpas/atmos_coupling.F90 new file mode 100644 index 000000000..cd18a2284 --- /dev/null +++ b/mpas/atmos_coupling.F90 @@ -0,0 +1,463 @@ +! ########################################################################################### +!> \file atmos_coupling.F90 +!> Procedures for coupling the MPAS dynamical core to the CCPP Physics. +!> +! ########################################################################################### +module atmos_coupling_mod + use mpas_kind_types, only : mpas_kind => RKIND + use ufs_mpas_subdriver, only : domain_ptr + + implicit none + public :: MPAS_statein_type + public :: MPAS_stateout_type + public :: ufs_mpas_to_physics + public :: ufs_physics_to_mpas + + ! 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. + !> + !> ####################################################################################### + type MPAS_statein_type + ! Dimensions + integer, pointer :: nCells ! Number of cells, including halo cells + integer, pointer :: nEdges ! Number of edges, including halo edges + integer, pointer :: nVertices ! Number of vertices, including halo vertices + integer, pointer :: nVertLevels ! Number of vertical layers + ! + integer, pointer :: nCellsSolve ! Number of cells, excluding halo cells + integer, pointer :: nEdgesSolve ! Number of edges, excluding halo edges + 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 :: zz(:,:) ! Vertical coordinate metric [1] at layer + ! midpoints (nlev,ncol) + real(mpas_kind), pointer :: fzm(:) ! Interp weight from k layer midpoint to k + ! layer interface [1] (nlev) + real(mpas_kind), pointer :: fzp(:) ! Interp weight from k-1 layer midpoint to k + ! layer interface [dimensionless] (nlev) + ! Cell area (invariant) + real(mpas_kind), pointer :: areaCell(:) ! cell area [m^2] + + ! For edge-normal velocity calculations (invariant) + real(mpas_kind), pointer :: east(:,:) ! Cartesian components of unit east vector + ! at cell centers [dimensionless] (3,ncol) + real(mpas_kind), pointer :: north(:,:) ! Cartesian components of unit north vector + ! at cell centers [dimensionless] (3,ncol) + real(mpas_kind), pointer :: normal(:,:) ! Cartesian components of the vector normal + ! to an edge and tangential to the surface + ! of the sphere [dimensionless] (3,ncol) + integer, pointer :: cellsOnEdge(:,:) ! Indices of cells separated by an edge (2,nedge) + + ! Indices for tracer (scalar) indices + integer, pointer :: index_qv ! Tracer index for water-vapor mixing-ratio + + ! Base state variables + real(mpas_kind), pointer :: rho_base(:,:) ! Base-state dry air density [kg/m^3] (nlev,ncol) + real(mpas_kind), pointer :: theta_base(:,:) ! Base-state potential temperature [K] (nlev,ncol) + + ! State that is directly prognosed by the dycore + real(mpas_kind), pointer :: uperp(:,:) ! Normal velocity at edges [m/s] (nlev ,nedge) + real(mpas_kind), pointer :: w(:,:) ! Vertical velocity [m/s] (nlev+1,ncol) + real(mpas_kind), pointer :: theta_m(:,:) ! Moist potential temperature [K] (nlev ,ncol) + real(mpas_kind), pointer :: rho_zz(:,:) ! Dry density [kg/m^3] + ! divided by d(zeta)/dz (nlev ,ncol) + real(mpas_kind), pointer :: tracers(:,:,:) ! Tracers [kg/kg dry air] (nq,nlev ,ncol) + + ! State that may be directly derived from dycore prognostic state + real(mpas_kind), pointer :: theta(:,:) ! Potential temperature [K] (nlev,ncol) + real(mpas_kind), pointer :: exner(:,:) ! Exner function [-] (nlev,ncol) + real(mpas_kind), pointer :: rho(:,:) ! Dry density [kg/m^3] (nlev,ncol) + real(mpas_kind), pointer :: ux(:,:) ! Zonal veloc at center [m/s] (nlev,ncol) + real(mpas_kind), pointer :: uy(:,:) ! Meridional veloc at center [m/s] (nlev,ncol) + + ! Tendencies from physics + real(mpas_kind), pointer :: ru_tend(:,:) ! Normal horizontal momentum tendency + ! from physics [kg/m^2/s] (nlev,nedge) + real(mpas_kind), pointer :: rtheta_tend(:,:) ! Tendency of rho*theta/zz + ! 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) + + end type MPAS_statein_type + + !> ####################################################################################### + !> MPAS_stateout_type + !> + !> Fields prognosed (or diagnosed) by the MPAS dynamical core. + !> ####################################################################################### + type MPAS_stateout_type + ! Dimensions + integer, pointer :: nCells ! Number of cells, including halo cells + integer, pointer :: nEdges ! Number of edges, including halo edges + integer, pointer :: nVertices ! Number of vertices, including halo vertices + integer, pointer :: nVertLevels ! Number of vertical layers + ! + integer, pointer :: nCellsSolve ! Number of cells, excluding halo cells + integer, pointer :: nEdgesSolve ! Number of edges, excluding halo edges + 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 :: zz(:,:) ! Vertical coordinate metric [1] at layer + ! midpoints (nlev,ncol) + real(mpas_kind), pointer :: fzm(:) ! Interp weight from k layer midpoint to k + ! layer interface [1] (nlev) + real(mpas_kind), pointer :: fzp(:) ! Interp weight from k-1 layer midpoint to k + ! layer interface [dimensionless] (nlev) + + ! Indices for tracer (scalar) indices + integer, pointer :: index_qv ! Tracer index for water-vapor mixing-ratio + + ! State that is directly prognosed by the dycore + real(mpas_kind), pointer :: uperp(:,:) ! Normal velocity at edges [m/s] (nlev ,nedge) + real(mpas_kind), pointer :: w(:,:) ! Vertical velocity [m/s] (nlev+1,ncol) + real(mpas_kind), pointer :: theta_m(:,:) ! Moist potential temperature [K] (nlev ,ncol) + real(mpas_kind), pointer :: rho_zz(:,:) ! Dry density [kg/m^3] + ! divided by d(zeta)/dz (nlev ,ncol) + real(mpas_kind), pointer :: tracers(:,:,:) ! Tracers [kg/kg dry air] (nq,nlev ,ncol) + + ! State that may be directly derived from dycore prognostic state. + real(mpas_kind), pointer :: theta(:,:) ! Potential temperature [K] (nlev,ncol) + real(mpas_kind), pointer :: exner(:,:) ! Exner function [-] (nlev,ncol) + real(mpas_kind), pointer :: rho(:,:) ! Dry density [kg/m^3] (nlev,ncol) + real(mpas_kind), pointer :: ux(:,:) ! Zonal veloc at center [m/s] (nlev,ncol) + real(mpas_kind), pointer :: uy(:,:) ! Meridional veloc at center [m/s] (nlev,ncol) + real(mpas_kind), pointer :: pmiddry(:,:) ! Dry hydrostatic pressure [Pa] + ! at layer midpoints (nlev,ncol) + real(mpas_kind), pointer :: pintdry(:,:) ! Dry hydrostatic pressure [Pa] + ! at layer interfaces (nlev+1,ncol) + real(mpas_kind), pointer :: pmid(:,:) ! Pressure at layer midpoints (nlev,ncol) + real(mpas_kind), pointer :: vorticity(:,:) ! Relative vertical vorticity [s^-1] + ! (nlev,nvtx) + real(mpas_kind), pointer :: divergence(:,:) ! Horizontal velocity divergence [s^-1] + ! (nlev,ncol) + end type MPAS_stateout_type + +contains + !> ######################################################################################### + !> 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 + 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 + ! Locals + type(mpas_stateout_type) :: mpas_state + type(mpas_pool_type), pointer :: state_pool + type(mpas_pool_type), pointer :: diag_pool + type(mpas_pool_type), pointer :: mesh_pool + integer :: iCell, iCol, iTracer + integer, pointer :: nCellsSolve, num_scalars, nwat, index_qv, nVertLevels + real(RKIND), pointer :: surface_p(:) + + ! 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, 'num_scalars', num_scalars) + call mpas_pool_get_dimension(state_pool, 'index_qv', index_qv) + call mpas_pool_get_dimension(state_pool, 'moist_end', nwat) + call mpas_pool_get_dimension(mesh_pool, 'nVertLevels', nVertLevels) + + ! Grab fields from MPAS pools + call mpas_pool_get_array(diag_pool, 'theta', MPAS_state % theta) + call mpas_pool_get_array(diag_pool, 'uReconstructZonal', MPAS_state % ux) + call mpas_pool_get_array(diag_pool, 'uReconstructMeridional', MPAS_state % uy) + 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, '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 + 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 iTracer = 1,num_scalars + physics_state % qgrs(iCol,:,iTracer) = MPAS_state % tracers(iTracer,nVertLevels:1:-1,iCell) + enddo + 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 % tracers, MPAS_state % pmiddry, MPAS_state % pintdry, MPAS_state % pmid) + + ! Copy MPAS pressures into physics data containers. + ! [k, i] -> [i, k] + ! bottom-up -> top-down ordering convention + do iCell = 1, nCellsSolve + iCol = indicesGlobal(iCell) + physics_state % pgr(iCol) = MPAS_state % pintdry(1,iCell) + physics_state % prsl(iCol,:) = MPAS_state % pmiddry(nVertLevels:1:-1,iCell) + physics_state % prsi(iCol,:) = MPAS_state % pintdry(nVertLevels+1:1:-1,iCell) + enddo + end subroutine ufs_mpas_to_physics + + !> ######################################################################################### + !> Procedure to populate inputs to the MPAS dynamical core using outputs from the CCPP + !> physics. + !> + !> ######################################################################################### + subroutine ufs_physics_to_mpas(physics_state) + use GFS_typedefs, only : GFS_stateout_type + ! Arguments + type(GFS_stateout_type), intent(in ) :: physics_state + ! Locals + type(mpas_statein_type) :: mpas_state + + ! [i, k] -> [k, i] + ! top-down -> bottom-up ordering convention + ! Thermodynamic conversions from moist (CCPP) to dry (MPAS) + + end subroutine ufs_physics_to_mpas + + !> ######################################################################################### + !> Procedure to compute dry hydrostatic pressure at layer interfaces and midpoints. + !> + !> Given arrays of zz, zgrid, rho_zz, and theta_m from the MPAS-A prognostic state, compute + !> dry hydrostatic pressure at layer interfaces and midpoints. + !> The vertical dimension for 3-d arrays is innermost, and k=1 represents the lowest layer + !> or level in the fields. + !> + !> \update: Dustin Swales April 2025 - Modified for use in UWM + !> + !> ######################################################################################### + subroutine hydrostatic_pressure(nCells, nVertLevels, qsize, index_qv, zz, zgrid, rho_zz, & + theta_m, exner, q, pmiddry, pintdry,pmid) + use mpas_constants, only: cp, rgas, cv, gravity, p0, Rv_over_Rd => rvord + use mpas_kind_types, only: RKIND + ! Arguments + integer, intent(in) :: nCells + integer, intent(in) :: nVertLevels + integer, intent(in) :: qsize + integer, intent(in) :: index_qv + real(RKIND), dimension(nVertLevels, nCells), intent(in) :: zz ! d(zeta)/dz [-] + real(RKIND), dimension(nVertLevels+1, nCells), intent(in) :: zgrid ! geometric heights of layer interfaces [m] + real(RKIND), dimension(nVertLevels, nCells), intent(in) :: rho_zz ! dry density / zz [kg m^-3] + real(RKIND), dimension(nVertLevels, nCells), intent(in) :: theta_m ! modified potential temperature + real(RKIND), dimension(nVertLevels, nCells), intent(in) :: exner ! Exner function + real(RKIND), dimension(qsize,nVertLevels, nCells), intent(in) :: q ! water vapor dry mixing ratio + real(RKIND), dimension(nVertLevels, nCells), intent(out):: pmiddry ! layer midpoint dry hydrostatic pressure [Pa] + real(RKIND), dimension(nVertLevels+1, nCells), intent(out):: pintdry ! layer interface dry hydrostatic pressure [Pa] + real(RKIND), dimension(nVertLevels, nCells), intent(out):: pmid ! layer midpoint hydrostatic pressure [Pa] + + ! Local variables + integer :: iCell, k, idx + real(RKIND), dimension(nVertLevels) :: dz ! Geometric layer thickness in column + real(RKIND), dimension(nVertLevels) :: dp,dpdry ! Pressure thickness + real(RKIND), dimension(nVertLevels+1,nCells) :: pint ! hydrostatic pressure at interface + real(RKIND) :: sum_water + real(RKIND) :: pk,rhok,rhodryk,thetavk,kap1,kap2,tvk,tk + real(RKIND), parameter :: epsilon = 0.05_RKIND + real(RKIND) :: dp_epsilon, dpdry_epsilon + + ! + ! For each column, integrate downward from model top to compute dry hydrostatic pressure at layer + ! midpoints and interfaces. The pressure averaged to layer midpoints should be consistent with + ! the ideal gas law using the rho_zz and theta values prognosed by MPAS at layer midpoints. + ! + do iCell = 1, nCells + dz(:) = zgrid(2:nVertLevels+1,iCell) - zgrid(1:nVertLevels,iCell) + do k = nVertLevels, 1, -1 + rhodryk = zz(k,iCell)* rho_zz(k,iCell) !full CAM physics density + rhok = 1.0_RKIND + do idx=2,qsize!dry_air_species_num+1,thermodynamic_active_species_num + rhok = rhok+q(idx,k,iCell) + end do + rhok = rhok*rhodryk + dp(k) = gravity*dz(k)*rhok + dpdry(k) = gravity*dz(k)*rhodryk + end do + + k = nVertLevels + sum_water = 1.0_RKIND + do idx=2,qsize!dry_air_species_num+1,thermodynamic_active_species_num + sum_water = sum_water+q(idx,k,iCell) + end do + rhok = sum_water*zz(k,iCell) * rho_zz(k,iCell) + thetavk = theta_m(k,iCell)/sum_water + tvk = thetavk*exner(k,iCell) + pk = dp(k)*rgas*tvk/(gravity*dz(k)) + ! + ! model top pressure consistently diagnosed using the assumption that the mid level + ! is at height z(nVertLevels-1)+0.5*dz + ! + pintdry(nVertLevels+1,iCell) = pk-0.5_RKIND*dz(nVertLevels)*rhok*gravity !hydrostatic + pint (nVertLevels+1,iCell) = pintdry(nVertLevels+1,iCell) + do k = nVertLevels, 1, -1 + ! + ! compute hydrostatic dry interface pressure so that (pintdry(k+1)-pintdry(k))/g is pseudo density + ! + sum_water = 1.0_RKIND + do idx=2,qsize!dry_air_species_num+1,thermodynamic_active_species_num + sum_water = sum_water+q(idx,k,iCell) + end do + thetavk = theta_m(k,iCell)/sum_water!convert modified theta to virtual theta + tvk = thetavk*exner(k,iCell) + tk = tvk*sum_water/(1.0_RKIND+Rv_over_Rd*q(index_qv,k,iCell)) + pint (k,iCell) = pint (k+1,iCell)+dp(k) + pintdry(k,iCell) = pintdry(k+1,iCell)+dpdry(k) + pmid(k,iCell) = dp(k) *rgas*tvk/(gravity*dz(k)) + pmiddry(k,iCell) = dpdry(k)*rgas*tk /(gravity*dz(k)) + ! + ! PMID is not necessarily bounded by the hydrostatic interface pressure. + ! (has been found to be an issue at ~3.75km resolution in surface layer) + ! + dp_epsilon = dp(k) * epsilon + dpdry_epsilon = dpdry(k)*epsilon + pmid (k, iCell) = max(min(pmid (k, iCell), pint (k, iCell) - dp_epsilon), pint (k + 1, iCell) + dp_epsilon) + pmiddry(k, iCell) = max(min(pmiddry(k, iCell), pintdry(k, iCell) - dpdry_epsilon), pintdry(k + 1, iCell) + dpdry_epsilon) + end do + 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 = 'ufs_mpas_subdriver::get_mpas_pio_decomp' + integer, dimension(:), pointer :: indexArray, indices + integer, pointer :: indexDimension + type (field2DReal), pointer :: field2d + type (field3DReal), pointer :: field3d + type (mpas_pool_field_info_type) :: fieldInfo + character (len=StrKIND) :: elementName, elementNamePlural + logical :: meshFieldDim, cellFieldDIm + integer :: i + + ! + call mpas_pool_get_field_info(domain_ptr % blocklist % allFields, trim(varname), fieldInfo) + if (trim(varname) == 'scalars') then + nullify(field3d) + if (fieldInfo % nTimeLevels > 1) then + call mpas_pool_get_field(domain_ptr % blocklist % allFields, trim(varname), field3d, & + timeLevel=fieldInfo % nTimeLevels ) + else + call mpas_pool_get_field(domain_ptr % blocklist % allFields, trim(varname), field3d) + endif + if ( field3d % isDecomposed ) then + meshFieldDim = .false. + cellFieldDIm = .false. + if (trim(field3d % dimNames(fieldInfo % nDims)) == 'nCells') then + elementName = 'Cell' + elementNamePlural = 'Cells' + meshFieldDim = .true. + cellFieldDIm = .true. + else if (trim(field3d % dimNames(fieldInfo % nDims)) == 'nEdges') then + elementName = 'Edge' + elementNamePlural = 'Edges' + meshFieldDim = .true. + else if (trim(field3d % dimNames(fieldInfo % nDims)) == 'nVertices') then + elementName = 'Vertex' + elementNamePlural = 'Vertices' + meshFieldDim = .true. + end if + endif + nullify(field3d) + else + nullify(field2d) + if (fieldInfo % nTimeLevels > 1) then + call mpas_pool_get_field(domain_ptr % blocklist % allFields, trim(varname), field2d, & + timeLevel=fieldInfo % nTimeLevels ) + else + call mpas_pool_get_field(domain_ptr % blocklist % allFields, trim(varname), field2d) + endif + if ( field2d % isDecomposed ) then + meshFieldDim = .false. + cellFieldDIm = .false. + if (trim(field2d % dimNames(fieldInfo % nDims)) == 'nCells') then + elementName = 'Cell' + elementNamePlural = 'Cells' + meshFieldDim = .true. + cellFieldDIm = .true. + else if (trim(field2d % dimNames(fieldInfo % nDims)) == 'nEdges') then + elementName = 'Edge' + elementNamePlural = 'Edges' + meshFieldDim = .true. + else if (trim(field2d % dimNames(fieldInfo % nDims)) == 'nVertices') then + elementName = 'Vertex' + elementNamePlural = 'Vertices' + meshFieldDim = .true. + end if + endif + nullify(field2d) + endif + ! + if ( meshFieldDim ) then + allocate(indices(0)) + call mpas_pool_get_array(domain_ptr % blocklist % allFields, 'indexTo' // & + trim(elementName) // 'ID', indexArray) + call mpas_pool_get_dimension(domain_ptr % blocklist % dimensions, 'n' // & + trim(elementNamePlural) // 'Solve', indexDimension) + call mergeArrays(indices, indexArray(1:indexDimension)) + endif + ! Save indices for P2D coupling in run phase(s). + if ( cellFieldDIm ) then + allocate(indicesGlobal(indexDimension)) + indicesGlobal = indices + endif + + end subroutine get_mpas_pio_decomp + + subroutine mergeArrays(array1, array2) + implicit none + integer, dimension(:), pointer :: array1 + integer, dimension(:), intent(in) :: array2 + integer :: n1, n2 + integer, dimension(:), pointer :: newArray + + n1 = size(array1) + n2 = size(array2) + + allocate(newArray(n1+n2)) + + newArray(1:n1) = array1(:) + newArray(n1+1:n1+n2) = array2(:) + + deallocate(array1) + array1 => newArray + end subroutine mergeArrays + +end module atmos_coupling_mod diff --git a/mpas/atmos_model.F90 b/mpas/atmos_model.F90 new file mode 100644 index 000000000..d4d82a4ab --- /dev/null +++ b/mpas/atmos_model.F90 @@ -0,0 +1,391 @@ +! ########################################################################################### +!> \file atmos_model.F90 +!> Driver for the UFS ATMospheric model with MPAS dynamical core and CCPP Physics. +!> Contains routines to advance the atmospheric model state by one forecast time step. +!> +! ########################################################################################### +module atmos_model_mod + ! Fortran + use mpi_f08, only : MPI_Comm, MPI_CHARACTER, MPI_INTEGER, MPI_REAL8, MPI_LOGICAL + ! MPAS + use MPAS_typedefs, only : MPAS_kind_phys => kind_phys + ! CCPP + use CCPP_data, only : UFSATM_control => GFS_control + use CCPP_data, only : UFSATM_intdiag => GFS_intdiag + use CCPP_data, only : UFSATM_interstitial => GFS_interstitial + use CCPP_data, only : UFSATM_grid => GFS_grid + use CCPP_data, only : UFSATM_tbd => GFS_tbd + use CCPP_data, only : UFSATM_sfcprop => GFS_sfcprop + use CCPP_data, only : UFSATM_statein => GFS_statein + use CCPP_data, only : UFSATM_stateout => GFS_stateout + use CCPP_data, only : UFSATM_cldprop => GFS_cldprop + use CCPP_data, only : UFSATM_radtend => GFS_radtend + use CCPP_data, only : UFSATM_coupling => GFS_coupling + use CCPP_data, only : ccpp_suite + use CCPP_driver, only : CCPP_step + ! FMS + 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 + use fms_mod, only : clock_flag_default + use fms_mod, only : stdlog + use mpp_mod, only : stdout + ! UFSATM + use module_mpas_config, only : pio_numiotasks, nCellsGlobal, ic_filename, lbc_filename + use module_mpas_config, only : lonCellGlobal, latCellGlobal, areaCellGlobal + use module_mpas_config, only : pi + use mod_ufsatm_util, only : get_atmos_tracer_types +#ifdef _OPENMP + use omp_lib +#endif + implicit none + + private + + public :: atmos_control_type + public :: atmos_model_init + public :: atmos_model_end + public :: atmos_model_radiation_physics + public :: atmos_model_microphysics + public :: atmos_model_dynamics + + !> ######################################################################################### + !> Type containing information on MPAS enabled UFSATM forecast. + !> + !> ######################################################################################### + type atmos_control_type + type(time_type) :: Time ! current time + type(time_type) :: Time_step ! atmospheric time step. + type(time_type) :: Time_init ! reference time. + 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 :: ufs_from_mpas_cnst => null() ! indices into MPAS tracers array + + ! Namelist + integer :: blocksize = 1 + logical :: dycore_only = .false. + logical :: debug = .false. + + namelist /atmos_model_nml/ blocksize, dycore_only, debug, ccpp_suite, ic_filename, lbc_filename + + ! 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 + +contains + !> ######################################################################################### + !> Procedure to initialize UWM ATMosphere with MPAS dynamical core. + !> + !> - Read in ATMosphere namelist + !> - Initialize MPAS framework + !> - Read in MPAS namelist + !> - Initialize MPAS dynamical core + !> - Read in MPAS initial conditions + !> - Read in physics namelist + !> - Initialize CCPP framework + !> - Initialize CCPP Physics + !> + !> ######################################################################################### + subroutine atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, mpicomm, calendar) + use ufs_mpas_subdriver, only : MPAS_control_type + use ufs_mpas_subdriver, only : ufs_mpas_init_phase1, ufs_mpas_init_phase2 + use ufs_mpas_subdriver, only : ufs_mpas_open_init + use ufs_mpas_subdriver, only : dyn_mpas_read_write_stream, ufs_mpas_define_scalars + use ufs_mpas_subdriver, only : constituent_name, is_water_species + use atmos_coupling_mod, only : ufs_mpas_to_physics, get_mpas_pio_decomp + use MPAS_init, only : MPAS_initialize + + ! Arguments + type(atmos_control_type), intent(inout) :: Atmos + type(time_type), intent(in ) :: Time_init, Time, Time_step, Time_end + type(MPI_Comm), intent(in ) :: mpicomm + character(17), intent(in ) :: calendar + + ! Locals + integer :: i, io, ierr, nConstituents, sec, iCol + type(MPAS_control_type) :: Cfg + integer :: times(6), timee(6), ttime, logUnits(2), nthrds + + ! Set up timers + setupClock = mpp_clock_id( 'Time-Step Setup ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) + atmiClock = mpp_clock_id( 'ATMosphere Setup ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) + radClock = mpp_clock_id( 'Radiation ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) + 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 ) + + ! Start timer for this procedure (init). + call mpp_clock_begin(atmiClock) + + ! Set model time + 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) + + ! Get forecast start/stop times (year/month/day/hour/minute/second) + call get_date(Time_init,times(1),times(2),times(3),times(4),times(5),times(6)) + call get_date(Time_end, timee(1),timee(2),timee(3),timee(4),timee(5),timee(6)) + call get_time(Time_end - Time_init, ttime) + + ! Set MPI bookeeping parameters. + Cfg%me = mpp_pe() + Cfg%master = mpp_root_pe() + 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') + endif + + ! Get tracer name(s) and type(s). + 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) + + ! 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. + Cfg % nwat = 6 + + call get_number_tracers(MODEL_ATMOS, num_tracers=Cfg % nConstituents) + allocate (constituent_name(Cfg % nConstituents), is_water_species(Cfg % nConstituents)) + do i = 1, Cfg % nConstituents + call get_tracer_names(MODEL_ATMOS, i, constituent_name(i)) + enddo + is_water_species(:) = .false. + is_water_species(1:Cfg % nwat) = .true. + + ! Open (PIO) MPAS IC data file. + call ufs_mpas_open_init() + + ! Call MPAS initialization phase 1. + ! - Set up MPAS framework + ! - Read in MPAS namelists + ! - Set up MPAS logging + ! - Read in static data, setup MPAS invariant stream + ! - Setup physical constants used by MPAS dycore + logUnits(1) = stdout() + logUnits(2) = stdlog() + + ! DJS2025: This is for UWM RT logging only. Can be removed when MPAS output is added. + if (Cfg % master == Cfg % me) then + open(unit=mpas_logfile_handle, file='mpas_log.txt', action='write', status='unknown') + logunits(1) = mpas_logfile_handle + logunits(2) = mpas_logfile_handle + endif + + call ufs_mpas_init_phase1(Cfg, times, timee, ttime, calendar, logUnits) + + call ufs_mpas_define_scalars(mpas_from_ufs_cnst, ufs_from_mpas_cnst, ierr) + if (ierr /= 0) then + call mpp_error(FATAL,'ERROR: Set-up of constituents for MPAS-A dycore failed.') + end if + + ! Read in MPAS IC data. Populate MPAS data containers and MPAS "input" stream. + call dyn_mpas_read_write_stream( 'r', 'input-scalars') + + ! Complete the MPAS dycore initialization. + ! - Set up threading. + ! - Call MPAS core_atmosphere init. + call ufs_mpas_init_phase2(Cfg) + + !> ######################################################################################### + !> ######################################################################################### + !> END MPAS DYCORE INITIALIZATION + !> ######################################################################################### + !> ######################################################################################### + + ! Set domain decomposition needed for P2D step + ! Use 'theta', but any MPAS field defined on the cell center will work. + call get_mpas_pio_decomp('theta') + + !> ######################################################################################### + !> ######################################################################################### + !> BEGIN CCPP PHYSICS INITIALIZATION + !> ######################################################################################### + !> ######################################################################################### +#ifdef _OPENMP + nthrds = omp_get_max_threads() +#else + nthrds = 1 +#endif + ! Set file ID for log file + Cfg%nlunit = stdlog() + + ! Number of physics blocks + Atmos % nblks = nCellsGlobal / blocksize + if (mod(nCellsGlobal, 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 + + ! Allocate physics interstitial data container (UFSATM_interstitial) + ! When Cfg % blksz(Atmos % nblks) is smaller than blocksize. + if (minval(Cfg % blksz)==maxval(Cfg % blksz)) then + allocate(UFSATM_interstitial(nthrds)) + else if (all(minloc(Cfg % blksz)==(/size(Cfg % blksz)/))) then + allocate(UFSATM_interstitial(nthrds+1)) + else + call mpp_error(FATAL, 'For non-uniform blocksizes, only the last element ' // & + 'in Cfg%blksz can be different from the others') + end if + + ! Update time (UFS specific time formatting array) + Cfg%bdat(:) = 0 + call get_date (Time_init, Cfg%bdat(1), Cfg%bdat(2), Cfg%bdat(3), Cfg%bdat(5), Cfg%bdat(6), Cfg%bdat(7)) + Cfg%cdat(:) = 0 + call get_date (Time, Cfg%cdat(1), Cfg%cdat(2), Cfg%cdat(3), Cfg%cdat(5), Cfg%cdat(6), Cfg%cdat(7)) + + ! Allocate required to work around GNU compiler bug 100886 https://gcc.gnu.org/bugzilla/show_bug.cgi?id=100886 + allocate(Cfg%input_nml_file, mold=input_nml_file) + Cfg%input_nml_file => input_nml_file + Cfg%fn_nml='using internal file' + + ! 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_interstitial) + + ! 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 + + ! 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') + + ! Initialize the CCPP physics + call CCPP_step (step="physics_init", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') + if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP physics_init step failed') + + ! Initialize stochastic physics pattern generation / cellular automata + ! NOT YET IMPLEMENTED + + ! Initialize three-dimensional physics. + ! NOT YET IMPLEMENTED + + call mpp_clock_end(atmiClock) + ! + end subroutine atmos_model_init + + !> ######################################################################################### + !> Procedure to finalize model. + !> + !> ######################################################################################### + subroutine atmos_model_end(Atmos) + type (atmos_control_type), intent(inout) :: Atmos + ! Locals + integer :: ierr + + close(unit=mpas_logfile_handle) + + ! Finalize the CCPP physics. + call CCPP_step (step="finalize", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') + if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP finalize step failed') + + end subroutine atmos_model_end + + !> ######################################################################################### + !> Procedure to call atmospheric radiation and physics groups (CCPP). + !> + !> ######################################################################################### + subroutine atmos_model_radiation_physics(Atmos) + type (atmos_control_type), intent(inout) :: Atmos + ! Locals + integer :: ierr + + ! Call CCPP Timestep_initialize Group + call mpp_clock_begin(setupClock) + call CCPP_step (step="timestep_init", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') + if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP timestep_init step failed') + call mpp_clock_end(setupClock) + + ! Call CCPP Radiation Group + call mpp_clock_begin(radClock) + if (UFSATM_control%lsswr .or. UFSATM_control%lslwr) then + !call CCPP_step (step="radiation", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') + if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP radiation step failed') + endif + call mpp_clock_end(radClock) + + ! Call CCPP Physics Group + call mpp_clock_begin(physClock) + call CCPP_step (step="physics", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') + if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP physics step failed') + call mpp_clock_end(physClock) + + end subroutine atmos_model_radiation_physics + + !> ######################################################################################### + !> Procedure to call atmospheric dynamics (MPAS). + !> + !> ######################################################################################### + 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 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) + + ! 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 + + !> ######################################################################################### + !> Procedure to call microphysics group (CCPP). + !> + !> ######################################################################################### + subroutine atmos_model_microphysics(Atmos) + type (atmos_control_type), intent(inout) :: Atmos + ! Locals + integer :: ierr + + ! Call CCPP Microphysics Group + 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') + call mpp_clock_end(mpClock) + + ! Call CCPP Timestep_finalize Group + call mpp_clock_begin(setupClock) + call CCPP_step (step="timestep_finalize", nblks=Atmos % nblks, ierr=ierr, dycore='mpas') + if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP timestep_finalize step failed') + call mpp_clock_end(setupClock) + + end subroutine atmos_model_microphysics + +end module atmos_model_mod diff --git a/mpas/module_fcst_grid_comp.F90 b/mpas/module_fcst_grid_comp.F90 new file mode 100644 index 000000000..721ea8acc --- /dev/null +++ b/mpas/module_fcst_grid_comp.F90 @@ -0,0 +1,338 @@ +#define ESMF_ERR_ABORT(rc) \ +if (rc /= ESMF_SUCCESS) write(0,*) 'rc=',rc,__FILE__,__LINE__; if(ESMF_LogFoundError(rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) call ESMF_Finalize(endflag=ESMF_END_ABORT) +! ########################################################################################### +!> \file module_fcst_grid_comp.F90 +!> +!> ESMF forecast gridded component for MPAS ATMosphere. +!> +! ########################################################################################### +module module_fcst_grid_comp + use mpi_f08 + use esmf + use nuopc + use time_manager_mod, only: time_type, set_calendar_type, set_time, set_date, & + month_name, operator(+), operator(-), operator (<), & + operator (>), operator (/=), operator (/), operator (==), & + operator (*), THIRTY_DAY_MONTHS, JULIAN, GREGORIAN, NOLEAP, & + 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 + use constants_mod, only: constants_init + use fms_mod, only: error_mesg, fms_init, fms_end, write_version_number, & + uppercase + use mpp_mod, only: mpp_init, mpp_pe, mpp_npes, mpp_root_pe, & + mpp_set_current_pelist, mpp_error, FATAL, WARNING, NOTE + use mpp_mod, only: mpp_clock_id, mpp_clock_begin + use sat_vapor_pres_mod, only: sat_vapor_pres_init + 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 + + implicit none + private + + !---- model defined-types ---- + type(atmos_control_type), save :: Atmos + integer :: n_atmsteps + + !----- coupled model data ----- + integer :: calendar_type = -99 + integer :: date_init(6) + + integer :: mype = 0 + + public SetServices + +contains + + ! ######################################################################################### + ! ESMF entrypoints for forecast grid-component. + ! ######################################################################################### + subroutine SetServices(fcst_comp, rc) + type(ESMF_GridComp) :: fcst_comp + integer, intent(out) :: rc + + rc = ESMF_SUCCESS + + ! Initialize + call ESMF_GridCompSetEntryPoint(fcst_comp, ESMF_METHOD_INITIALIZE, & + userRoutine=fcst_initialize, phase=1, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + ! Advertise + call ESMF_GridCompSetEntryPoint(fcst_comp, ESMF_METHOD_INITIALIZE, & + userRoutine=fcst_advertise, phase=2, rc=rc) + + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + ! Realize + call ESMF_GridCompSetEntryPoint(fcst_comp, ESMF_METHOD_INITIALIZE, & + userRoutine=fcst_realize, phase=3, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + ! Run Phase 1 + call ESMF_GridCompSetEntryPoint(fcst_comp, ESMF_METHOD_RUN, & + userRoutine=fcst_run_phase_1, phase=1, 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) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + end subroutine SetServices + + ! ######################################################################################### + ! Initialize the ESMF forecast grid component. + ! ######################################################################################### + subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) + type(esmf_GridComp) :: fcst_comp + type(ESMF_State) :: importState, exportState + type(esmf_Clock) :: clock + integer,intent(out) :: rc + + ! Locals + integer :: i, j, k, n + type(ESMF_VM) :: VM + type(ESMF_Time) :: CurrTime, StartTime, StopTime + type(ESMF_Config) :: cf + real(kind=8) :: tbeg1 + logical :: fexist + integer :: initClock, io_unit, calendar_type_res, date_res(6), date_init_res(6) + integer,dimension(6) :: date, date_end, days + type(time_type) :: Time_init, Time, Time_step, Time_end, Time_restart, Time_step_restart + + ! Initialize ESMF error message. + rc = ESMF_SUCCESS + + ! Timing info (debug mode) + tbeg1 = mpi_wtime() + + call ESMF_VMGetCurrent(vm=vm,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_VMGet(vm=vm, localPet=mype, mpiCommunicator=fcst_mpi_comm%mpi_val, & + petCount=fcst_ntasks, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (mype == 0) write(*,*)'in fcst_initialize, fcst_ntasks=',fcst_ntasks + + CF = ESMF_ConfigCreate(rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + ! Load resoure file. + call ESMF_ConfigLoadFile(config=CF ,filename='model_configure' ,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call fms_init(fcst_mpi_comm%mpi_val) + call mpp_init() + initClock = mpp_clock_id( 'Initialization' ) + call mpp_clock_begin (initClock) !nesting problem + + call constants_init + call sat_vapor_pres_init + + select case( uppercase(trim(calendar)) ) + case( 'JULIAN' ) + calendar_type = JULIAN + case( 'GREGORIAN' ) + calendar_type = GREGORIAN + case( 'NOLEAP' ) + calendar_type = NOLEAP + case( 'THIRTY_DAY' ) + calendar_type = THIRTY_DAY_MONTHS + case( 'NO_CALENDAR' ) + calendar_type = NO_CALENDAR + case default + call mpp_error ( FATAL, 'fcst_initialize: calendar must be one of '// & + 'JULIAN|GREGORIAN|NOLEAP|THIRTY_DAY|NO_CALENDAR.' ) + end select + + call set_calendar_type (calendar_type) + + ! + ! Set atmos time. + ! + call ESMF_ClockGet(clock, CurrTime=CurrTime, StartTime=StartTime, & + StopTime=StopTime, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + date_init = 0 + call ESMF_TimeGet (StartTime, & + YY=date_init(1), MM=date_init(2), DD=date_init(3), & + H=date_init(4), M =date_init(5), S =date_init(6), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + Time_init = set_date (date_init(1), date_init(2), date_init(3), & + date_init(4), date_init(5), date_init(6)) + if (mype == 0) write(*,'(A,6I5)') 'in fcst_initialize, StartTime=',date_init + + date=0 + call ESMF_TimeGet (CurrTime, & + YY=date(1), MM=date(2), DD=date(3), & + H=date(4), M =date(5), S =date(6), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + Time = set_date (date(1), date(2), date(3), & + date(4), date(5), date(6)) + if (mype == 0) write(*,'(A,6I5)') 'in fcst_initialize, CurrTime =',date + + date_end=0 + call ESMF_TimeGet (StopTime, & + YY=date_end(1), MM=date_end(2), DD=date_end(3), & + H=date_end(4), M =date_end(5), S =date_end(6), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + Time_end = set_date (date_end(1), date_end(2), date_end(3), & + date_end(4), date_end(5), date_end(6)) + if (mype == 0) write(*,'(A,6I5)') 'in fcst_initialize, StopTime =',date_end + + ! + ! If this is a restarted run ('INPUT/coupler.res' file exists, compare date and date_init + ! to the values in 'coupler.res'. + ! + if (mype == 0) then + inquire(FILE='INPUT/coupler.res', EXIST=fexist) + if (fexist) then ! file exists, this is a restart run + + open(newunit=io_unit, file='INPUT/coupler.res', status='old', action='read', err=998) + read (io_unit,*,err=999) calendar_type_res + read (io_unit,*) date_init_res + read (io_unit,*) date_res + close(io_unit) + + if(date_res(1) == 0 .and. date_init_res(1) /= 0) date_res = date_init_res + + if(mype == 0) write(*,'(A,6(I4))') 'in fcst_initialize, INPUT/coupler.res: date_init=',date_init_res + if(mype == 0) write(*,'(A,6(I4))') 'in fcst_initialize, INPUT/coupler.res: date =',date_res + + if (calendar_type /= calendar_type_res) then + write(0,'(A)') 'fcst_initialize ERROR: calendar_type /= calendar_type_res' + write(0,'(A,6(I4))')' calendar_type = ', calendar_type + write(0,'(A,6(I4))')' calendar_type_res = ', calendar_type_res + call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + + if (.not. ALL(date_init.EQ.date_init_res)) then + write(0,'(A)') 'fcst_initialize ERROR: date_init /= date_init_res' + write(0,'(A,6(I4))')' date_init = ', date_init + write(0,'(A,6(I4))')' date_init_res = ', date_init_res + call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + + if (.not. ALL(date.EQ.date_res)) then + write(0,'(A)') 'fcst_initialize ERROR: date /= date_res' + write(0,'(A,6(I4))')' date = ', date + write(0,'(A,6(I4))')' date_res = ', date_res + call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + +999 continue +998 continue + + endif ! fexist + endif ! mype == 0 + + call diag_manager_init (TIME_INIT=date) + call diag_manager_set_time_end(Time_end) + + Time_step = set_time (dt_atmos,0) + if (mype == 0) write(*,*)'fcst_initialize, time_init=', date_init,'time=',date,'time_end=',date_end,'dt_atmos=',dt_atmos + + ! ####################################################################################### + ! Initialize component models. + ! atmos_model_init() calls the MPAS dycore initialization. + ! ####################################################################################### + call atmos_model_init(Atmos, Time_init, Time, Time_end, Time_step, fcst_mpi_comm, calendar) + + ! Timing info (debug mode) + if (mype == 0) write(*,*)'PASS(fcst_initialize): Time is ', mpi_wtime() - tbeg1 + + end subroutine fcst_initialize + + ! ########################################################################################### + ! Advertise the ESMF forecast grid component. + ! ########################################################################################### + subroutine fcst_advertise(fcst_comp, importState, exportState, clock, rc) + type(esmf_GridComp) :: fcst_comp + type(ESMF_State) :: importState, exportState + type(esmf_Clock) :: clock + integer,intent(out) :: rc + + ! Initialize ESMF error message. + rc = ESMF_SUCCESS + + end subroutine fcst_advertise + + ! ########################################################################################### + ! Realize the ESMF forecast grid component. + ! ########################################################################################### + subroutine fcst_realize(fcst_comp, importState, exportState, clock, rc) + type(esmf_GridComp) :: fcst_comp + type(ESMF_State) :: importState, exportState + type(esmf_Clock) :: clock + integer,intent(out) :: rc + + ! Initialize ESMF error message. + rc = ESMF_SUCCESS + + end subroutine fcst_realize + + ! ########################################################################################### + ! Run phase(1) for the ESMF forecast grid component. + ! ########################################################################################### + subroutine fcst_run_phase_1(fcst_comp, importState, exportState, clock, rc) + type(ESMF_GridComp) :: fcst_comp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer,intent(out) :: rc + + ! Locals + integer :: seconds + real(kind=8) :: mpi_wtime, tbeg1 + + ! 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 + + ! Call forecast integration subroutines... + call atmos_model_radiation_physics (Atmos) + call atmos_model_dynamics (Atmos) + call atmos_model_microphysics (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 + + ! ########################################################################################### + ! Finalize the ESMF forecast grid component. + ! ########################################################################################### + subroutine fcst_finalize(fcst_comp, importState, exportState, clock, rc) + type(esmf_GridComp) :: fcst_comp + type(ESMF_State) :: importState, exportState + type(esmf_Clock) :: clock + integer,intent(out) :: rc + + ! Locals + real(kind=8) :: mpi_wtime, tbeg1 + + ! Initialize ESMF error message. + rc = ESMF_SUCCESS + + ! Timing info (debug mode) + tbeg1 = mpi_wtime() + + call atmos_model_end (Atmos) + call diag_manager_end (Atmos%Time) + call fms_end + + ! Timing info (debug mode) + if (mype == 0) write(*,*)'PASS(fcst_finalize): total is ', mpi_wtime() - tbeg1 + + end subroutine fcst_finalize +end module module_fcst_grid_comp diff --git a/mpas/module_mpas_config.F90 b/mpas/module_mpas_config.F90 new file mode 100644 index 000000000..2ab507bab --- /dev/null +++ b/mpas/module_mpas_config.F90 @@ -0,0 +1,95 @@ +! ######################################################################################### +! +! MPAS configuration information +! +! ######################################################################################### +module module_mpas_config + use MPAS_typedefs, only: r8 => kind_dbl_prec, r4 => kind_sngl_prec + use GFS_typedefs, only: pi => con_pi + use mpi_f08 + use pio, only : iosystem_desc_t, file_desc_t, io_desc_t + use esmf + + implicit none + + !> Atmosphere time step in seconds + integer :: dt_atmos + + !> Number of MPAS dycore calls per ATMosphere time step. + integer :: n_atmos + + !> MPI communicator for the forecast grid component + type(MPI_Comm) :: fcst_mpi_comm + + !> Total number of mpi tasks for the forecast grid components + integer :: fcst_ntasks + + !> The first integration step + integer :: first_kdt + + !> ID number for the coupled grids + integer :: cpl_grid_id + + !> Flag to decide if model writes out coupled diagnostic fields + logical :: cplprint_flag = .false. + + !> Flag to decide if write grid components is used + logical :: quilting = .false. + + !> 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 + real,dimension(:),allocatable :: output_fh + + !> Calendar type + character(17) :: calendar=' ' + + !> MPAS Initial Condition file (via UFSATM NML) + character(len=256) :: ic_filename + + !> MPAS Lateral Boundary Condition file (via UFSATM NML) + character(len=256) :: lbc_filename + + !> PIO + type(iosystem_desc_t), pointer :: pio_subsystem + 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(:) + real(r8), target, allocatable :: zref_edge(:) + real(r8), target, allocatable :: pref(:) + real(r8), target, allocatable :: pref_edge(:) + + !> sphere_radius is a global attribute in the MPAS initial file. It is needed to + !> normalize the cell areas to a unit sphere. + real(r8) :: sphere_radius + + integer :: maxNCells ! maximum number of cells for any task (nCellsSolve <= maxNCells) + integer :: maxEdges ! maximum number of edges per cell + integer :: nVertLevels ! number of vertical layers (midpoints) + + integer, pointer :: & + 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 + + !> Global gridded data + integer :: nCellsGlobal ! global number of cells/columns + integer :: nEdgesGlobal ! global number of edges + integer :: nVerticesGlobal ! global number of vertices + + !> GridCell Longitue/Latitue/Area + 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 new file mode 100644 index 000000000..889caf6d7 --- /dev/null +++ b/mpas/ufs_mpas_subdriver.F90 @@ -0,0 +1,3060 @@ +!> ########################################################################################### +!> \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 +!> +!> Forward integration of the dycore is handled in ufs_mpas_run. The current forecast time, +!> forecast interval, and MPAS dycore time step are used to integrate the model forward in +!> time. Afterwards, atm_compute_output_diagnostics() is called to compute fields needed by +!> the Physics. +!> +!> Other public routines used the UFSATM driver +!> ufs_mpas_open_init: Open MPAS Initial Condition file, return PIO file handle. +!> +!> ########################################################################################### +module ufs_mpas_subdriver + use mpi_f08 + use mpas_derived_types, only : core_type, domain_type, mpas_Clock_type + use mpas_kind_types, only : StrKIND, rkind + use module_mpas_config, only : pio_subsystem, pio_stride, pio_numiotasks, pio_iodesc + use module_mpas_config, only : ic_filename, lbc_filename + use module_mpas_config, only : pio_iotype, fcst_mpi_comm, pioid + use module_mpas_config, only : 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 + 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_run + public :: ufs_mpas_open_init + public :: corelist, domain_ptr + public :: constituent_name + public :: is_water_species + public :: dyn_mpas_read_write_stream + + !> ######################################################################################### + !> + !> ######################################################################################### + type MPAS_control_type + + ! Namelist filename + character(len=64) :: fn_nml + + ! Full namelist for use with internal file reads + character(len=:), pointer, dimension(:) :: input_nml_file => null() + + ! MPI Bookkeeping + integer :: me !< current MPI-rank + integer :: master !< master MPI-rank + type(MPI_Comm) :: mpi_comm !< forecast tasks mpi communicator + + ! ESMF + integer :: fcst_ntasks !< total number of forecast tasks + + ! Log file identifier + integer :: nlunit !< fortran unit number for file opens + integer :: logunit !< fortran unit number for writing logfile + + ! UFS date(s) for model time. + integer :: bdat(8) !< model begin date in GFS format (same as idat) + integer :: cdat(8) !< model current date in GFS format (same as jdat) + + ! Spatial/Temporal parameters for physics/dynamics coupling. + real(rkind) :: dt_dycore !< dynamics time step in seconds + real(rkind) :: dt_phys !< physics time step in seconds + integer :: nblks !< Number of data (physics) blocks. + integer, pointer :: blksz(:) !< Block size for data blocking (default blksz(1)=[nCells]) + integer :: levs !< number of vertical levels + + ! + integer :: iau_offset !< iau running window length + logical :: restart !< flag whether this is a coldstart (.false.) or a warmstart/restart (.true.) + + ! Tracers + integer :: nConstituents !< Number of constituents (tracers). + integer :: nwat !< number of hydrometeors in dcyore (including water vapor) + character(len=32), pointer :: tracer_names(:) !< tracers names to dereference tracer id + integer, pointer :: tracer_types(:) !< tracers types: 0=generic, 1=chem,prog, 2=chem,diag + + end type MPAS_control_type + + !> ######################################################################################### + ! + !> ######################################################################################### + type :: var_info_type + private + character(64) :: name = '' + character(10) :: type = '' + integer :: rank = 0 + end type var_info_type + + !> ######################################################################################### + !> This list corresponds to the "invariant" stream in MPAS registry. + !> It consists of variables that are members of the "mesh" struct. + !> ######################################################################################### + type(var_info_type), parameter :: invariant_var_info_list(*) = [ & + var_info_type('angleEdge' , 'real' , 1), & + var_info_type('areaCell' , 'real' , 1), & + var_info_type('areaTriangle' , 'real' , 1), & + var_info_type('bdyMaskCell' , 'integer' , 1), & + var_info_type('bdyMaskEdge' , 'integer' , 1), & + var_info_type('bdyMaskVertex' , 'integer' , 1), & + var_info_type('cellTangentPlane' , 'real' , 3), & + var_info_type('cell_gradient_coef_x' , 'real' , 2), & + var_info_type('cell_gradient_coef_y' , 'real' , 2), & + var_info_type('cellsOnCell' , 'integer' , 2), & + var_info_type('cellsOnEdge' , 'integer' , 2), & + var_info_type('cellsOnVertex' , 'integer' , 2), & + var_info_type('cf1' , 'real' , 0), & + var_info_type('cf2' , 'real' , 0), & + var_info_type('cf3' , 'real' , 0), & + var_info_type('coeffs_reconstruct' , 'real' , 3), & + var_info_type('dcEdge' , 'real' , 1), & + var_info_type('defc_a' , 'real' , 2), & + var_info_type('defc_b' , 'real' , 2), & + var_info_type('deriv_two' , 'real' , 3), & + var_info_type('dss' , 'real' , 2), & + var_info_type('dvEdge' , 'real' , 1), & + var_info_type('dzu' , 'real' , 1), & + var_info_type('edgeNormalVectors' , 'real' , 2), & + var_info_type('edgesOnCell' , 'integer' , 2), & + var_info_type('edgesOnEdge' , 'integer' , 2), & + var_info_type('edgesOnVertex' , 'integer' , 2), & + var_info_type('fEdge' , 'real' , 1), & + var_info_type('fVertex' , 'real' , 1), & + var_info_type('fzm' , 'real' , 1), & + var_info_type('fzp' , 'real' , 1), & + var_info_type('indexToCellID' , 'integer' , 1), & + var_info_type('indexToEdgeID' , 'integer' , 1), & + var_info_type('indexToVertexID' , 'integer' , 1), & + var_info_type('kiteAreasOnVertex' , 'real' , 2), & + var_info_type('latCell' , 'real' , 1), & + var_info_type('latEdge' , 'real' , 1), & + var_info_type('latVertex' , 'real' , 1), & + var_info_type('localVerticalUnitVectors' , 'real' , 2), & + var_info_type('lonCell' , 'real' , 1), & + var_info_type('lonEdge' , 'real' , 1), & + var_info_type('lonVertex' , 'real' , 1), & + var_info_type('meshDensity' , 'real' , 1), & + var_info_type('nEdgesOnCell' , 'integer' , 1), & + var_info_type('nEdgesOnEdge' , 'integer' , 1), & + var_info_type('nominalMinDc' , 'real' , 0), & + var_info_type('qv_init' , 'real' , 1), & + var_info_type('rdzu' , 'real' , 1), & + var_info_type('rdzw' , 'real' , 1), & + var_info_type('t_init' , 'real' , 2), & + var_info_type('u_init' , 'real' , 1), & + var_info_type('v_init' , 'real' , 1), & + var_info_type('verticesOnCell' , 'integer' , 2), & + var_info_type('verticesOnEdge' , 'integer' , 2), & + var_info_type('weightsOnEdge' , 'real' , 2), & + var_info_type('xCell' , 'real' , 1), & + var_info_type('xEdge' , 'real' , 1), & + var_info_type('xVertex' , 'real' , 1), & + var_info_type('yCell' , 'real' , 1), & + var_info_type('yEdge' , 'real' , 1), & + var_info_type('yVertex' , 'real' , 1), & + var_info_type('zCell' , 'real' , 1), & + var_info_type('zEdge' , 'real' , 1), & + var_info_type('zVertex' , 'real' , 1), & + var_info_type('zb' , 'real' , 3), & + var_info_type('zb3' , 'real' , 3), & + var_info_type('zgrid' , 'real' , 2), & + var_info_type('zxu' , 'real' , 2), & + var_info_type('zz' , 'real' , 2) & + ] + + ! Whether a variable should be in input or restart can be determined by looking at + ! the `atm_init_coupled_diagnostics` subroutine in MPAS. + ! If a variable first appears on the LHS of an equation, it should be in restart. + ! If a variable first appears on the RHS of an equation, it should be in input. + ! The remaining ones of interest should be in output. + + !> ######################################################################################### + !> This list corresponds to the "input" stream in MPAS registry. + !> It consists of variables that are members of the "diag" and "state" struct. + !> Only variables that are specific to the "input" stream are included. + !> ######################################################################################### + type(var_info_type), parameter :: input_var_info_list(*) = [ & + var_info_type('Time' , 'real' , 0), & + var_info_type('initial_time' , 'character' , 0), & + var_info_type('rho' , 'real' , 2), & + var_info_type('rho_base' , 'real' , 2), & + var_info_type('scalars' , 'real' , 3), & + var_info_type('theta' , 'real' , 2), & + var_info_type('theta_base' , 'real' , 2), & + var_info_type('u' , 'real' , 2), & + var_info_type('w' , 'real' , 2), & + var_info_type('xtime' , 'character' , 0) & + ] + + !> ######################################################################################### + !> This list corresponds to the "restart" stream in MPAS registry. + !> It consists of variables that are members of the "diag" and "state" struct. + !> Only variables that are specific to the "restart" stream are included. + !> ######################################################################################### + type(var_info_type), parameter :: restart_var_info_list(*) = [ & + var_info_type('exner' , 'real' , 2), & + var_info_type('exner_base' , 'real' , 2), & + var_info_type('pressure_base' , 'real' , 2), & + var_info_type('pressure_p' , 'real' , 2), & + var_info_type('rho_p' , 'real' , 2), & + var_info_type('rho_zz' , 'real' , 2), & + var_info_type('rtheta_base' , 'real' , 2), & + var_info_type('rtheta_p' , 'real' , 2), & + var_info_type('ru' , 'real' , 2), & + var_info_type('ru_p' , 'real' , 2), & + var_info_type('rw' , 'real' , 2), & + var_info_type('rw_p' , 'real' , 2), & + var_info_type('theta_m' , 'real' , 2) & + ] + + !> ######################################################################################### + !> This list corresponds to the "output" stream in MPAS registry. + !> It consists of variables that are members of the "diag" struct. + !> Only variables that are specific to the "output" stream are included. + !> ######################################################################################### + type(var_info_type), parameter :: output_var_info_list(*) = [ & + var_info_type('divergence' , 'real' , 2), & + var_info_type('pressure' , 'real' , 2), & + var_info_type('relhum' , 'real' , 2), & + var_info_type('surface_pressure' , 'real' , 1), & + var_info_type('uReconstructMeridional' , 'real' , 2), & + var_info_type('uReconstructZonal' , 'real' , 2), & + var_info_type('vorticity' , 'real' , 2) & + ] + + !> ######################################################################################### + !> + !> ######################################################################################### + type(core_type), pointer :: corelist => null() + type(domain_type), pointer :: domain_ptr => null() + type(mpas_Clock_type), pointer :: clock => null() + + character(StrKIND), allocatable :: constituent_name(:) + integer, allocatable :: index_constituent_to_mpas_scalar(:) + integer, allocatable :: index_mpas_scalar_to_constituent(:) + logical, allocatable :: is_water_species(:) + +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. + !> + !> ######################################################################################### + subroutine ufs_mpas_init_phase1(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 + use mpas_pool_routines, only : mpas_pool_get_array, mpas_pool_get_config + use mpas_framework, only : mpas_framework_init_phase1, mpas_framework_init_phase2 + use mpas_domain_routines, only : mpas_allocate_domain, mpas_pool_get_dimension + 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_kind_types, only : StrKIND, RKIND + use mpas_log, only : mpas_log_write + use atm_core_interface, only : atm_setup_core, atm_setup_domain + use mpas_constants, only : mpas_constants_compute_derived, pi => pii + use mpas_attlist, only : mpas_add_att + ! FMS + use field_manager_mod, only : MODEL_ATMOS + use fms2_io_mod, only : file_exists + use mpp_mod, only : FATAL, mpp_error + ! PIO + use pio, only : pio_global, pio_get_att + ! Arguments + type(mpas_control_type), intent(inout) :: Cfg + integer, intent(in ) :: time_start(6), time_end(6), logUnits(2) + integer, intent(in ) :: total_time + character(17), intent(in ) :: calendar + ! Locals + character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_init_phase1' + integer :: i, ndate1, ndate2, tod, ierr, ik, kk + type (mpas_pool_type), pointer :: state, mesh, tend + type (field3dReal), pointer :: scalarsField + character (len=StrKIND), pointer :: initial_time, config_start_time + integer, pointer :: num_scalars + + ! Setup MPAS infrastructure + allocate(corelist, stat=ierr) + if ( ierr /= 0 ) call mpp_error(FATAL,subname//": failed to allocate corelist array") + nullify(corelist % next) + + allocate(corelist % domainlist, stat=ierr) + if ( ierr /= 0 ) call mpp_error(FATAL,subname//": failed to allocate corelist%domainlist%next") + nullify(corelist % domainlist % next) + + domain_ptr => corelist % domainlist + domain_ptr % core => corelist + + call mpas_allocate_domain(domain_ptr) + domain_ptr % domainID = 0 + + ! Initialize MPAS infrastructure + call mpas_framework_init_phase1(domain_ptr % dminfo, external_comm=fcst_mpi_comm) + + call atm_setup_core(corelist) + call atm_setup_domain(domain_ptr) + + ! Set up the log manager as early as possible so we can use it for any errors/messages + ! during subsequent init steps. We need: + ! 1) domain_ptr to be allocated, + ! 2) dmpar_init complete to access dminfo, + ! 3) *_setup_core to assign the setup_log function pointer + domain_ptr % core % git_version = 'unknown' + domain_ptr % core % build_target = 'N/A' + ierr = domain_ptr % core % setup_log(domain_ptr % logInfo, domain_ptr, unitNumbers=logUnits) + if ( ierr /= 0 ) then + 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 + call mpp_error(FATAL,subname//": Cannot find MPAS namelist file, input.nml") + end if + + ! Set forecast start time (config_start_time) + ndate1 = time_start(1)*10000 + time_start(2)*100 + time_start(3) + tod = time_start(4)*3600 + time_start(5)*60 + time_start(6) + call mpas_pool_add_config(domain_ptr % configs, 'config_start_time', date2yyyymmdd(ndate1)//'_'//sec2hms(tod)) + call mpas_log_write('config_start_time = '//date2yyyymmdd(ndate1)//'_'//sec2hms(tod)) + + ! Set forecast end time (config_stop_time) + ndate2 = time_end(1)*10000 + time_end(2)*100 + time_end(3) + tod = time_end(4)*3600 + time_end(5)*60 + time_end(6) + 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. + tod = max(ndate2 - ndate1 - 1,0) + call mpas_pool_add_config(domain_ptr % configs, 'config_run_duration', trim(int2str(tod))//'_'//sec2hms(total_time)) + call mpas_log_write('config_run_duration = '//trim(int2str(tod))//'_'//sec2hms(total_time)) + + ! Set other MPAS required configuration information. + call mpas_pool_add_config(domain_ptr % configs, 'config_restart_timestamp_name', 'restart_timestamp') + call mpas_pool_add_config(domain_ptr % configs, 'config_IAU_option', 'off') + call mpas_pool_add_config(domain_ptr % configs, 'config_do_DAcycling', .false.) + call mpas_pool_add_config(domain_ptr % configs, 'config_halo_exch_method', 'mpas_halo') + + ! Initialize MPAS infrastructure (phase 2) + call mpas_framework_init_phase2(domain_ptr, io_system=pio_subsystem, calendar = trim(calendar)) + + ! 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)) + end if + + ierr = domain_ptr % core % define_packages(domain_ptr % packages) + if (ierr /= 0) then + call mpp_error(FATAL,subname//": Package definition failed for "//trim(domain_ptr % core % coreName)) + end if + + ierr = domain_ptr % core % setup_packages(domain_ptr % configs, domain_ptr % streamInfo, & + domain_ptr % packages, domain_ptr % iocontext) + if (ierr /= 0) then + call mpp_error(FATAL,subname//": Package setup failed for "//trim(domain_ptr % core % coreName)) + end if + + ierr = domain_ptr % core % setup_decompositions(domain_ptr % decompositions) + if (ierr /= 0) then + call mpp_error(FATAL,subname//": Decomposition setup failed for "//trim(domain_ptr % core % coreName)) + end if + + ierr = domain_ptr % core % setup_clock(domain_ptr % clock, domain_ptr % configs) + if (ierr /= 0) then + call mpp_error(FATAL,subname//": Clock setup failed for "//trim(domain_ptr % core % coreName)) + end if + + ! Adding a config named 'cam_pcnst' with the number of constituents will indicate to + ! MPAS-A setup code that it is operating as a UFS dycore, and that it is necessary to + ! 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) + + ! Finalize the setup of blocks and fields + call mpas_bootstrap_framework_phase2(domain_ptr, pio_file_desc=pioid) + + ! Add num_scalars from "state" pool to "dimensions". + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + call mpas_pool_add_dimension(domain_ptr % blocklist % dimensions, 'num_scalars', num_scalars) + nullify(num_scalars) + 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) + + ! Read in static (invariant) data + call dyn_mpas_read_write_stream( 'r', 'invariant') + + ! 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 + + ! 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 + + ! Query global grid dimensions from MPAS + call ufs_mpas_get_global_dims(nCellsGlobal, nEdgesGlobal, nVerticesGlobal, maxEdges, nVertLevels, maxNCells) + + ! Setup constants + call mpas_constants_compute_derived() + + ! Set MPAS mesh lon/lat/area. + allocate(latCellGlobal(nCellsGlobal), lonCellGlobal(nCellsGlobal), areaCellGlobal(nCellsGlobal)) + call ufs_mpas_get_global_coords(latCellGlobal, lonCellGlobal, areaCellGlobal) + + end subroutine ufs_mpas_init_phase1 + + !> ######################################################################################## + !> Procedure to initialize UWM with MPAS dynamical core. + !> + !> ######################################################################################## + subroutine ufs_mpas_init_phase2(Cfg) + use mpas_kind_types, only : StrKIND, RKIND + use mpas_derived_types, only : mpas_pool_type, mpas_Time_Type, field0DReal, field2dreal + 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 + use mpas_pool_routines, only : mpas_pool_get_array, mpas_pool_get_field + use mpas_atm_dimensions, only : mpas_atm_set_dims + 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_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 + use mpas_attlist, only : mpas_modify_att + use mpas_string_utils, only : mpas_string_replace + use mpas_field_routines, only : mpas_allocate_scratch_field + ! Arguments + type(mpas_control_type), intent(inout) :: Cfg + type(mpas_pool_type), pointer :: tend_physics_pool + ! Locals + character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_init_phase2' + type (mpas_pool_type), pointer :: state, mesh + integer :: ierr + integer, pointer :: nVertLevels1, maxEdges1, maxEdges2, num_scalars + real (kind=RKIND), pointer :: dt + logical, pointer :: config_do_restart + type (mpas_Time_Type) :: startTime + character(len=StrKIND) :: startTimeStamp + character (len=StrKIND), pointer :: xtime + character (len=StrKIND), pointer :: initial_time1, initial_time2 + type(field0dreal), pointer :: field_0d_real + type(field2dreal), pointer :: field_2d_real + + ! + ! Setup threading + ! + call mpas_log_write('Setting up OpenMP threading') + call mpas_atm_threading_init(domain_ptr%blocklist, ierr) + if ( ierr /= 0 ) then + call mpp_error(FATAL,subname//": Threading setup failed for core "//trim(domain_ptr % core % coreName)) + end if + + ! + ! Set up inner dimensions used by arrays in optimized dynamics routines + ! + call mpas_log_write('Setting up dimensions') + call mpas_pool_get_subpool(domain_ptr % blocklist % structs, 'state', state) + call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels1) + 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 + + ! + ! Set "local" clock to point to the clock contained in the domain type + ! + clock => domain_ptr % clock + core_clock => domain_ptr % clock + + ! + ! Build halo exchange groups and set method for exchanging halos in a group + ! + call mpas_log_write('Building halo exchange groups.') + + nullify(exchange_halo_group) + call atm_build_halo_groups(domain_ptr, ierr) + + if (ierr /= 0) then + call mpp_error(FATAL,subname//": failed to build MPAS-A halo exchange groups.") + end if + if (.not. associated(exchange_halo_group)) then + call mpp_error(FATAL,subname//": failed to build MPAS-A halo exchange groups.") + end if + + ! 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) + + 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"') + 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 + + ! + ! Set startTimeStamp based on the start time of the simulation clock + ! + startTime = mpas_get_clock_time(clock, mpas_START_TIME, ierr) + if ( ierr /= 0 ) then + call mpp_error(FATAL,subname//': Failed to get clock_time "mpas_START_TIME"') + end if + call mpas_get_time(startTime, dateTimeString=startTimeStamp, ierr=ierr) + if ( ierr /= 0 ) then + call mpp_error(FATAL,subname//': Failed to get time mpas_START_TIME"') + 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) + + 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"') + 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 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"') + end if + + ! + ! Prepare the dynamics for integration + ! + 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 + + !> ######################################################################################### + !> Routine to call MPAS dynamical core + !> Loop over dynamical time-step(s) and increment MPAS state (timelevel 1->2) + !> + !> ######################################################################################### + 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_kind_types, only : StrKIND, RKIND, R8KIND + use mpas_constants, only : rvord + 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_log, only : mpas_log_write + 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(<) + ! 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 + 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 + 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) + + ! Eventually, dt should be domain specific + call mpas_pool_get_config( domain_ptr % blocklist % configs, 'config_dt', config_dt) + 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) + if (config_apply_lbcs) then + + endif + + ! During integration, time level 1 stores the model state at the beginning of the + ! time step, and time level 2 stores the state advanced config_dt in time by timestep(...) + timeNow = mpas_get_clock_time(clock, mpas_NOW, ierr) + if (ierr /= 0) then + call mpp_error(FATAL,subname//': Failed to get clock_time for "mpas_NOW"') + endif + + timeStop = timeNow + mpas_time_interval + itimestep = 0 + do while (itimestep < 1)!(timeNow < timeStop) !DJS2025: Only one dycore inte + 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)) + + ! 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)/)) + + ! 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) + 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 + ! + call atm_compute_output_diagnostics(state, 1, diag, mesh) + + end subroutine ufs_mpas_run + + + !> ######################################################################################### + !> Procedure to open MPAS IC file. + !> + !> ######################################################################################### + subroutine ufs_mpas_open_init() + ! PIO + use pio, only : pio_openfile, pio_nowrite + ! FMS + use fms2_io_mod, only : file_exists + use mpp_mod, only : FATAL, mpp_error + ! Arguments + ! Locals + integer :: ierr + character(len=*), parameter :: subname = 'ufs_mpas_subdriver::ufs_mpas_open_init' + + ! Open MPAS Initial Condition file. + if (file_exists(ic_filename)) then + ierr = pio_openfile(pio_subsystem, pioid, pio_iotype, ic_filename, pio_nowrite) + if (ierr /= 0) then + call mpp_error(FATAL,subname//": Failed opening MPAS IC File, "//trim(ic_filename)) + end if + else + call mpp_error(FATAL,subname//": Cannot find MPAS IC file: "//trim(ic_filename)) + end if + end subroutine ufs_mpas_open_init + + !> ######################################################################################### + !> Procedure to read MPAS namelist(s). + !> + !> The namelist for MPAS are described in MPAS-Model/src/core_atmosphere/Registry.xml, this + !> is also where the default values defined below originate. + !> + !> ######################################################################################### + subroutine read_mpas_namelist(nml_file, configPool, mpicomm, master, me) + use mpi_f08, only: MPI_Comm, MPI_CHARACTER, MPI_INTEGER, MPI_REAL8, MPI_LOGICAL + use mpi_f08, only: mpi_bcast, mpi_barrier + use mpas_derived_types, only: mpas_pool_type + use mpas_kind_types, only: StrKIND, RKIND + use mpas_pool_routines, only: mpas_pool_add_config + use mpas_log, only : mpas_log_write + use mpas_typedefs, only: r8 => kind_dbl_prec + use fms_mod, only: check_nml_error + use mpp_mod, only: input_nml_file + ! Inputs + type(MPI_Comm), intent(in ) :: mpicomm + integer, intent(in ) :: master, me + character(len=*), intent(in ) :: nml_file + type(mpas_pool_type), intent(inout) :: configPool + + ! Namelist nhyd_model + character (len=StrKIND) :: mpas_time_integration = 'SRK3' + integer :: mpas_time_integration_order = 2 + real(r8) :: mpas_dt = 720.0_r8 + logical :: mpas_split_dynamics_transport = .true. + integer :: mpas_number_of_sub_steps = 2 + integer :: mpas_dynamics_split_steps = 3 + real(r8) :: mpas_h_mom_eddy_visc2 = 0.0_r8 + real(r8) :: mpas_h_mom_eddy_visc4 = 0.0_r8 + real(r8) :: mpas_v_mom_eddy_visc2 = 0.0_r8 + real(r8) :: mpas_h_theta_eddy_visc2 = 0.0_r8 + 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_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 + integer :: mpas_u_vadv_order = 3 + integer :: mpas_w_vadv_order = 3 + integer :: mpas_theta_vadv_order = 3 + integer :: mpas_scalar_vadv_order = 3 + logical :: mpas_scalar_advection = .true. + logical :: mpas_positive_definite = .false. + logical :: mpas_monotonic = .true. + real(r8) :: mpas_coef_3rd_order = 0.25_r8 + real(r8) :: mpas_smagorinsky_coef = 0.125_r8 + logical :: mpas_mix_full = .true. + real(r8) :: mpas_epssm = 0.1_r8 + real(r8) :: mpas_smdiv = 0.1_r8 + real(r8) :: mpas_apvm_upwinding = 0.5_r8 + logical :: mpas_h_ScaleWithMesh = .true. + ! Namelist damping + 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. + real(r8) :: mpas_rayleigh_damp_u_timescale_days = 5.0_r8 + integer :: mpas_number_rayleigh_damp_u_levels = 3 + ! Namelist limited_area + logical :: mpas_apply_lbcs = .false. + ! Namelist PIO + integer :: mpas_pio_num_iotasks = 1 + integer :: mpas_pio_stride = 1 + ! Namelist assimilation + logical :: mpas_jedi_da = .false. + ! Namelist decomposition + character (len=StrKIND) :: mpas_block_decomp_file_prefix = 'x1.40962.graph.info.part.' + ! Namelist restart + logical :: mpas_do_restart = .false. + ! Namelist printout + logical :: mpas_print_global_minmax_vel = .true. + logical :: mpas_print_detailed_minmax_vel = .true. + logical :: mpas_print_global_minmax_sca = .true. + + namelist /mpas_nhyd_model/ mpas_time_integration, mpas_time_integration_order, mpas_dt, & + mpas_split_dynamics_transport, mpas_number_of_sub_steps, mpas_dynamics_split_steps, & + 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_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, & + mpas_h_ScaleWithMesh + ! + namelist /mpas_damping/ mpas_zd, mpas_xnutr, mpas_cam_coef, mpas_cam_damping_levels, & + mpas_rayleigh_damp_u, mpas_rayleigh_damp_u_timescale_days, & + mpas_number_rayleigh_damp_u_levels + ! + namelist /mpas_limited_area/ mpas_apply_lbcs + ! + namelist /mpas_io/ mpas_pio_num_iotasks, mpas_pio_stride + ! + namelist /mpas_assimilation/ mpas_jedi_da + ! + namelist /mpas_decomposition/ mpas_block_decomp_file_prefix + ! + namelist /mpas_restart/ mpas_do_restart + ! + namelist /mpas_printout/ mpas_print_global_minmax_vel, mpas_print_detailed_minmax_vel, & + mpas_print_global_minmax_sca + + ! These configuration parameters must be set in the MPAS configPool, but can't be changed + ! in UFS. *From CAM src/dynamics/mpas/dyn_comp.F90* + integer :: config_num_halos = 2 + integer :: config_number_of_blocks = 0 + logical :: config_explicit_proc_decomp = .false. + character(len=StrKIND) :: config_proc_decomp_file_prefix = 'graph.info.part' + real(RKIND) :: config_relax_zone_divdamp_coef = 6 + + ! Locals + integer :: ierr, io, mpierr + + ! Read in namelists... + if (me == master) then + call mpas_log_write('Reading MPAS-A dynamical core namelist') + ! nhyd_model + read(input_nml_file, nml=mpas_nhyd_model, iostat=io) + ierr = check_nml_error(io, 'mpas_nhyd_model') + ! damping + read(input_nml_file, nml=mpas_damping, iostat=io) + ierr = check_nml_error(io, 'mpas_damping') + ! limited_area + read(input_nml_file, nml=mpas_limited_area, iostat=io) + ierr = check_nml_error(io, 'mpas_limited_area') + ! PIO + read(input_nml_file, nml=mpas_io, iostat=io) + ierr = check_nml_error(io, 'mpas_io') + ! assimilation + read(input_nml_file, nml=mpas_assimilation, iostat=io) + ierr = check_nml_error(io, 'mpas_assimilation') + ! decomposition + read(input_nml_file, nml=mpas_decomposition, iostat=io) + ierr = check_nml_error(io, 'mpas_decomposition') + ! restart + read(input_nml_file, nml=mpas_restart, iostat=io) + ierr = check_nml_error(io, 'mpas_restart') + ! printout + read(input_nml_file, nml=mpas_printout, iostat=io) + ierr = check_nml_error(io, 'mpas_printout') + endif + + ! Other processors waiting... + call mpi_barrier(mpicomm, mpierr) + + ! + ! 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) + call mpi_bcast(mpas_split_dynamics_transport, 1, mpi_logical, master, mpicomm, mpierr) + call mpi_bcast(mpas_number_of_sub_steps, 1, mpi_integer, master, mpicomm, mpierr) + call mpi_bcast(mpas_dynamics_split_steps, 1, mpi_integer, master, mpicomm, mpierr) + call mpi_bcast(mpas_h_mom_eddy_visc2, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_h_mom_eddy_visc4, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_v_mom_eddy_visc2, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_h_theta_eddy_visc2, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_h_theta_eddy_visc4, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_v_theta_eddy_visc2, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_horiz_mixing, StrKIND, mpi_character, master, mpicomm, mpierr) + call mpi_bcast(mpas_len_disp, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_visc4_2dsmag, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_del4u_div_factor, 1, mpi_real8, master, mpicomm, mpierr) + 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_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) + call mpi_bcast(mpas_scalar_vadv_order, 1, mpi_integer, master, mpicomm, mpierr) + call mpi_bcast(mpas_scalar_advection, 1, mpi_logical, master, mpicomm, mpierr) + call mpi_bcast(mpas_positive_definite, 1, mpi_logical, master, mpicomm, mpierr) + call mpi_bcast(mpas_monotonic, 1, mpi_logical, master, mpicomm, mpierr) + call mpi_bcast(mpas_coef_3rd_order, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_smagorinsky_coef, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_mix_full, 1, mpi_logical, master, mpicomm, mpierr) + call mpi_bcast(mpas_epssm, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_smdiv, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_apvm_upwinding, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_h_ScaleWithMesh, 1, mpi_logical, master, mpicomm, mpierr) + ! + call mpi_bcast(mpas_zd, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_xnutr, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_cam_coef, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_cam_damping_levels, 1, mpi_integer, master, mpicomm, mpierr) + call mpi_bcast(mpas_rayleigh_damp_u, 1, mpi_logical, master, mpicomm, mpierr) + call mpi_bcast(mpas_rayleigh_damp_u_timescale_days, 1, mpi_real8, master, mpicomm, mpierr) + call mpi_bcast(mpas_number_rayleigh_damp_u_levels, 1, mpi_integer, master, mpicomm, mpierr) + ! + call mpi_bcast(mpas_apply_lbcs, 1, mpi_logical, master, mpicomm, mpierr) + ! + call mpi_bcast(mpas_pio_num_iotasks, 1, mpi_integer, master, mpicomm, mpierr) + call mpi_bcast(mpas_pio_stride, 1, mpi_integer, master, mpicomm, mpierr) + ! + call mpi_bcast(mpas_jedi_da, 1, mpi_logical, master, mpicomm, mpierr) + ! + call mpi_bcast(mpas_block_decomp_file_prefix, StrKIND, mpi_character, master, mpicomm, mpierr) + ! + call mpi_bcast(mpas_do_restart, 1, mpi_logical, master, mpicomm, mpierr) + ! + 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 + ! + call mpas_pool_add_config(configPool, 'config_time_integration', mpas_time_integration) + call mpas_pool_add_config(configPool, 'config_time_integration_order', mpas_time_integration_order) + call mpas_pool_add_config(configPool, 'config_dt', real(mpas_dt,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_split_dynamics_transport', mpas_split_dynamics_transport) + call mpas_pool_add_config(configPool, 'config_number_of_sub_steps', mpas_number_of_sub_steps) + call mpas_pool_add_config(configPool, 'config_dynamics_split_steps', mpas_dynamics_split_steps) + call mpas_pool_add_config(configPool, 'config_h_mom_eddy_visc2', real(mpas_h_mom_eddy_visc2,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_h_mom_eddy_visc4', real(mpas_h_mom_eddy_visc4,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_v_mom_eddy_visc2', real(mpas_v_mom_eddy_visc2,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_h_theta_eddy_visc2', real(mpas_h_theta_eddy_visc2,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_h_theta_eddy_visc4', real(mpas_h_theta_eddy_visc4,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_v_theta_eddy_visc2', real(mpas_v_theta_eddy_visc2,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_horiz_mixing', mpas_horiz_mixing) + call mpas_pool_add_config(configPool, 'config_len_disp', real(mpas_len_disp,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_visc4_2dsmag', real(mpas_visc4_2dsmag,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_del4u_div_factor', real(mpas_del4u_div_factor,kind=RKIND)) + 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_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) + call mpas_pool_add_config(configPool, 'config_scalar_vadv_order', mpas_scalar_vadv_order) + call mpas_pool_add_config(configPool, 'config_scalar_advection', mpas_scalar_advection) + call mpas_pool_add_config(configPool, 'config_positive_definite', mpas_positive_definite) + call mpas_pool_add_config(configPool, 'config_monotonic', mpas_monotonic) + call mpas_pool_add_config(configPool, 'config_coef_3rd_order', real(mpas_coef_3rd_order,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_smagorinsky_coef', real(mpas_smagorinsky_coef,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_mix_full', mpas_mix_full) + call mpas_pool_add_config(configPool, 'config_epssm', real(mpas_epssm,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_smdiv', real(mpas_smdiv,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_apvm_upwinding', real(mpas_apvm_upwinding,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_h_ScaleWithMesh', mpas_h_ScaleWithMesh) + ! + call mpas_pool_add_config(configPool, 'config_zd', real(mpas_zd,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_xnutr', real(mpas_xnutr,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_mpas_cam_coef', real(mpas_cam_coef,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_number_cam_damping_levels', mpas_cam_damping_levels) + call mpas_pool_add_config(configPool, 'config_rayleigh_damp_u', mpas_rayleigh_damp_u) + call mpas_pool_add_config(configPool, 'config_rayleigh_damp_u_timescale_days', real(mpas_rayleigh_damp_u_timescale_days,kind=RKIND)) + call mpas_pool_add_config(configPool, 'config_number_rayleigh_damp_u_levels', mpas_number_rayleigh_damp_u_levels) + ! + call mpas_pool_add_config(configPool, 'config_apply_lbcs', mpas_apply_lbcs) + ! + call mpas_pool_add_config(configPool, 'config_pio_num_iotasks', mpas_pio_num_iotasks) + call mpas_pool_add_config(configPool, 'config_pio_stride', mpas_pio_stride) + ! + call mpas_pool_add_config(configPool, 'config_jedi_da', mpas_jedi_da) + ! + call mpas_pool_add_config(configPool, 'config_block_decomp_file_prefix', mpas_block_decomp_file_prefix) + ! + call mpas_pool_add_config(configPool, 'config_do_restart', mpas_do_restart) + ! + call mpas_pool_add_config(configPool, 'config_print_global_minmax_vel', mpas_print_global_minmax_vel) + call mpas_pool_add_config(configPool, 'config_print_detailed_minmax_vel', mpas_print_detailed_minmax_vel) + call mpas_pool_add_config(configPool, 'config_print_global_minmax_sca', mpas_print_global_minmax_sca) + + ! Set some configuration parameters that cannot be changed by UFSATM. *From CAM src/dynamics/mpas/dyn_comp.F90* + call mpas_pool_add_config(configPool, 'config_num_halos', config_num_halos) + call mpas_pool_add_config(configPool, 'config_number_of_blocks', config_number_of_blocks) + call mpas_pool_add_config(configPool, 'config_explicit_proc_decomp', config_explicit_proc_decomp) + call mpas_pool_add_config(configPool, 'config_proc_decomp_file_prefix', config_proc_decomp_file_prefix) + call mpas_pool_add_config(configPool, 'config_relax_zone_divdamp_coef', config_relax_zone_divdamp_coef) + + ! Display namelist information (master processor only) + if (me == master) then + call mpas_log_write('-------------------------------- MPAS-A dycore namelist ---------------------------------') + call mpas_log_write('') + call mpas_log_write(' mpas_time_integration = '//trim(mpas_time_integration)) + call mpas_log_write(' mpas_time_integration_order = '//int2str(mpas_time_integration_order)) + call mpas_log_write(' mpas_dt = '//int2str(int(mpas_dt))) + call mpas_log_write(' mpas_split_dynamics_transport = '//log2str(mpas_split_dynamics_transport)) + call mpas_log_write(' mpas_number_of_sub_steps = '//int2str(mpas_number_of_sub_steps)) + call mpas_log_write(' mpas_dynamics_split_steps = '//int2str(mpas_dynamics_split_steps)) + call mpas_log_write(' mpas_h_mom_eddy_visc2 = '//int2str(int(mpas_h_mom_eddy_visc2))) + call mpas_log_write(' mpas_h_mom_eddy_visc4 = '//int2str(int(mpas_h_mom_eddy_visc4))) + call mpas_log_write(' mpas_v_mom_eddy_visc2 = '//int2str(int(mpas_v_mom_eddy_visc2))) + call mpas_log_write(' mpas_h_theta_eddy_visc2 = '//int2str(int(mpas_h_theta_eddy_visc2))) + call mpas_log_write(' mpas_h_theta_eddy_visc4 = '//int2str(int(mpas_h_theta_eddy_visc4))) + call mpas_log_write(' mpas_v_theta_eddy_visc2 = '//int2str(int(mpas_v_theta_eddy_visc2))) + call mpas_log_write(' mpas_horiz_mixing = '//trim(mpas_horiz_mixing)) + call mpas_log_write(' mpas_len_disp = '//int2str(int(mpas_len_disp))) + call mpas_log_write(' mpas_visc4_2dsmag = '//int2str(int(mpas_visc4_2dsmag))) + call mpas_log_write(' mpas_del4u_div_factor = '//int2str(int(mpas_del4u_div_factor))) + call mpas_log_write(' mpas_w_adv_order = '//int2str(mpas_w_adv_order)) + call mpas_log_write(' mpas_theta_adv_order = '//int2str(mpas_theta_adv_order)) + call mpas_log_write(' mpas_scalar_adv_order = '//int2str(mpas_scalar_adv_order)) + call mpas_log_write(' mpas_u_vadv_order = '//int2str(mpas_u_vadv_order)) + call mpas_log_write(' mpas_w_vadv_order = '//int2str(mpas_w_vadv_order)) + call mpas_log_write(' mpas_theta_vadv_order = '//int2str(mpas_theta_vadv_order)) + call mpas_log_write(' mpas_scalar_vadv_order = '//int2str(mpas_scalar_vadv_order)) + call mpas_log_write(' mpas_scalar_advection = '//log2str(mpas_scalar_advection)) + call mpas_log_write(' mpas_positive_definite = '//log2str(mpas_positive_definite)) + call mpas_log_write(' mpas_monotonic = '//log2str(mpas_monotonic)) + call mpas_log_write(' mpas_coef_3rd_order = '//int2str(int(mpas_coef_3rd_order))) + call mpas_log_write(' mpas_smagorinsky_coef = '//int2str(int(mpas_smagorinsky_coef))) + call mpas_log_write(' mpas_mix_full = '//log2str(mpas_mix_full)) + call mpas_log_write(' mpas_epssm = '//int2str(int(mpas_epssm))) + call mpas_log_write(' mpas_smdiv = '//int2str(int(mpas_smdiv))) + call mpas_log_write(' mpas_apvm_upwinding = '//int2str(int(mpas_apvm_upwinding))) + call mpas_log_write(' mpas_h_ScaleWithMesh = '//log2str(mpas_h_ScaleWithMesh)) + call mpas_log_write(' mpas_zd = '//int2str(int(mpas_zd))) + call mpas_log_write(' mpas_xnutr = '//int2str(int(mpas_xnutr))) + call mpas_log_write(' mpas_cam_coef = '//int2str(int(mpas_cam_coef))) + call mpas_log_write(' mpas_cam_damping_levels = '//int2str(mpas_cam_damping_levels)) + call mpas_log_write(' mpas_rayleigh_damp_u = '//log2str(mpas_rayleigh_damp_u)) + call mpas_log_write(' mpas_rayleigh_damp_u_timescale_days = '//int2str(int(mpas_rayleigh_damp_u_timescale_days))) + call mpas_log_write(' mpas_number_rayleigh_damp_u_levels = '//int2str(mpas_number_rayleigh_damp_u_levels)) + call mpas_log_write(' mpas_apply_lbcs = '//log2str(mpas_apply_lbcs)) + call mpas_log_write(' mpas_pio_num_iotasks = '//int2str(mpas_pio_num_iotasks)) + call mpas_log_write(' mpas_pio_stride = '//int2str(mpas_pio_stride)) + call mpas_log_write(' mpas_jedi_da = '//log2str(mpas_jedi_da)) + call mpas_log_write(' mpas_block_decomp_file_prefix = '//trim(mpas_block_decomp_file_prefix)) + call mpas_log_write(' mpas_do_restart = '//log2str(mpas_do_restart)) + call mpas_log_write(' mpas_print_global_minmax_vel = '//log2str(mpas_print_global_minmax_vel)) + call mpas_log_write(' mpas_print_detailed_minmax_vel = '//log2str(mpas_print_detailed_minmax_vel)) + call mpas_log_write(' mpas_print_global_minmax_sca = '//log2str(mpas_print_global_minmax_sca)) + 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/tests/test_fv3_cap.F90 b/tests/test_fv3_cap.F90 index 81e944b0a..50ed973af 100644 --- a/tests/test_fv3_cap.F90 +++ b/tests/test_fv3_cap.F90 @@ -1,5 +1,5 @@ program test_output_hours - use fv3atm_cap_mod, only: OutputHours_FrequencyInput, OutputHours_ArrayInput + use ufsatm_cap_mod, only: OutputHours_FrequencyInput, OutputHours_ArrayInput use module_fv3_config, only: dt_atmos, output_fh use module_fv3_io_def, only: lflname_fulltime diff --git a/fv3/fv3_cap.F90 b/ufsatm_cap.F90 similarity index 87% rename from fv3/fv3_cap.F90 rename to ufsatm_cap.F90 index 70cb52e05..0c9f0e6eb 100644 --- a/fv3/fv3_cap.F90 +++ b/ufsatm_cap.F90 @@ -1,6 +1,6 @@ -!--------------- FV3 ATM solo model ---------------- +!--------------- UFS ATM solo model ---------------- ! -!*** The FV3 atmosphere grid component nuopc cap +!*** The UFS ATMosphere grid component nuopc cap ! ! Author: Jun Wang@noaa.gov ! @@ -10,9 +10,10 @@ ! 24 Jul 2017: J. Wang initialization and time stepping changes for coupling ! 02 Nov 2017: J. Wang Use Gerhard's transferable RouteHandle ! 20 May 2025: D. Sarmiento Handle output hour array in seperate subroutines +! 06 Jun 2025: D. Swales Generalization for MPAS dynamical core ! -module fv3atm_cap_mod +module ufsatm_cap_mod use ESMF use NUOPC @@ -28,11 +29,20 @@ module fv3atm_cap_mod label_Finalize, & NUOPC_ModelGet ! +#ifdef FV3 use module_fv3_config, only: quilting, quilting_restart, output_fh, & dt_atmos, & calendar, cpl_grid_id, & cplprint_flag, first_kdt - +#endif +#ifdef MPAS + use module_mpas_config, only: output_fh, dt_atmos, calendar, & + fcst_mpi_comm, pio_ioformat, pio_iotype, & + pio_subsystem, pio_stride, & + pio_numiotasks, pio_iodesc, cpl_grid_id, & + cplprint_flag, first_kdt, quilting, & + quilting_restart +#endif use module_fv3_io_def, only: num_pes_fcst,write_groups, & num_files, filename_base, & wrttasks_per_group, n_group, & @@ -91,14 +101,14 @@ module fv3atm_cap_mod contains !----------------------------------------------------------------------- -!------------------- Solo fv3atm code starts here ---------------------- +!------------------- Solo ufsatm code starts here ---------------------- !----------------------------------------------------------------------- subroutine SetServices(gcomp, rc) type(ESMF_GridComp) :: gcomp integer, intent(out) :: rc - character(len=*),parameter :: subname='(fv3atm_cap:SetServices)' + character(len=*),parameter :: subname='(ufsatm_cap:SetServices)' rc = ESMF_SUCCESS @@ -119,13 +129,14 @@ subroutine SetServices(gcomp, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! checking the import fields is a bit more complex because of coldstart option +#ifdef FV3 call ESMF_MethodRemove(gcomp, label_CheckImport, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return call NUOPC_CompSpecialize(gcomp, specLabel=label_CheckImport, & - specRoutine=fv3_checkimport, rc=rc) + specRoutine=ufsatm_checkimport, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - +#endif ! setup Run/Advance phase: phase1 call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, & phaseLabelList=(/"phase1"/), userRoutine=routine_Run, rc=rc) @@ -134,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) @@ -144,7 +155,7 @@ subroutine SetServices(gcomp, rc) specPhaseLabel="phase2", specRoutine=ModelAdvance_phase2, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - ! specializations to set fv3 cap run clock (model clock) + ! specializations to set ufsatm cap run clock (model clock) call ESMF_MethodRemove(gcomp, label=label_SetRunClock, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -154,7 +165,7 @@ subroutine SetServices(gcomp, rc) ! specializations required to support 'inline' run sequences call NUOPC_CompSpecialize(gcomp, specLabel=label_CheckImport, & - specPhaseLabel="phase1", specRoutine=fv3_checkimport, rc=rc) + specPhaseLabel="phase1", specRoutine=ufsatm_checkimport, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return call NUOPC_CompSpecialize(gcomp, specLabel=label_TimestampExport, & @@ -164,7 +175,7 @@ subroutine SetServices(gcomp, rc) call NUOPC_CompSpecialize(gcomp, specLabel=label_CheckImport, & specPhaseLabel="phase2", specRoutine=NUOPC_NoOp, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - +#endif ! model finalize method(s) call NUOPC_CompSpecialize(gcomp, specLabel=label_Finalize, & specRoutine=ModelFinalize, rc=rc) @@ -175,7 +186,13 @@ end subroutine SetServices !----------------------------------------------------------------------------- subroutine InitializeAdvertise(gcomp, rc) - +#ifdef MPAS + use pio, only: pio_init, pio_setdebuglevel + use pio, only: PIO_REARR_BOX, PIO_REARR_SUBSET + use pio, only: PIO_64BIT_OFFSET, PIO_64BIT_DATA + use pio, only: PIO_IOTYPE_NETCDF, PIO_IOTYPE_PNETCDF + use pio, only: PIO_IOTYPE_NETCDF4C, PIO_IOTYPE_NETCDF4P +#endif type(ESMF_GridComp) :: gcomp integer, intent(out) :: rc @@ -214,7 +231,7 @@ subroutine InitializeAdvertise(gcomp, rc) type(ESMF_FieldBundle) :: mirrorFB type(ESMF_Field), allocatable :: fieldList(:) - character(len=*),parameter :: subname='(fv3_cap:InitializeAdvertise)' + character(len=*),parameter :: subname='(ufsatm_cap:InitializeAdvertise)' real(kind=8) :: MPI_Wtime, timeis, timerhs, time_rh_fb_start, time_rh_start integer :: wrttasks_per_group_from_parent, wrtLocalPet, num_threads @@ -226,7 +243,10 @@ subroutine InitializeAdvertise(gcomp, rc) type(ESMF_StaggerLoc) :: staggerloc character(len=20) :: cvalue character(ESMF_MAXSTR) :: output_grid - + ! PIO + integer :: pio_root + integer :: pio_rearranger + integer :: pio_debug_level logical :: needs_dst_mask logical :: top_parent_is_global integer :: ngrids @@ -240,9 +260,15 @@ subroutine InitializeAdvertise(gcomp, rc) call ESMF_GridCompGet(gcomp, name=gc_name, vm=vm,rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - +#ifdef FV3 call ESMF_VMGet(vm, petCount=petcount, localpet=mype, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return +#endif +#ifdef MPAS + call ESMF_VMGet(vm=vm, localPet=mype, mpiCommunicator=fcst_mpi_comm%mpi_val, & + petCount=petcount, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return +#endif ! num_threads is needed to compute actual wrttasks_per_group_from_parent call ESMF_InfoGetFromHost(gcomp, info=info, rc=rc) @@ -253,13 +279,13 @@ subroutine InitializeAdvertise(gcomp, rc) ! query for importState and exportState call NUOPC_ModelGet(gcomp, driverClock=clock, importState=importState, exportState=exportState, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - +#ifdef FV3 call ESMF_AttributeGet(gcomp, name="cpl_grid_id", value=value, defaultValue="1", & convention="NUOPC", purpose="Instance", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return cpl_grid_id = ESMF_UtilString2Int(value, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - +#endif call ESMF_AttributeGet(gcomp, name="ProfileMemory", value=value, defaultValue="false", & convention="NUOPC", purpose="Instance", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -287,6 +313,158 @@ subroutine InitializeAdvertise(gcomp, rc) write(msgString,'(A,i6)') trim(subname)//' dbug = ',dbug call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) +#ifdef MPAS + ! ####################################################################################### + ! + ! PIO + ! + ! ####################################################################################### + ! pio_netcdf_format + call NUOPC_CompAttributeGet(gcomp, name='pio_netcdf_format', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (isPresent .and. isSet) then + cvalue = ESMF_UtilStringUpperCase(cvalue) + if (trim(cvalue) .eq. 'CLASSIC') then + pio_ioformat = 0 + else if (trim(cvalue) .eq. '64BIT_OFFSET') then + pio_ioformat = PIO_64BIT_OFFSET + else if (trim(cvalue) .eq. '64BIT_DATA') then + pio_ioformat = PIO_64BIT_DATA + else + call ESMF_LogWrite(trim("need to provide valid option for pio_ioformat (CLASSIC|64BIT_OFFSET|64BIT_DATA)"), ESMF_LOGMSG_INFO) + return + end if + else + cvalue = '64BIT_OFFSET' + pio_ioformat = PIO_64BIT_OFFSET + end if + + ! pio_typename + call NUOPC_CompAttributeGet(gcomp, name='pio_typename', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (isPresent .and. isSet) then + cvalue = ESMF_UtilStringUpperCase(cvalue) + if (trim(cvalue) .eq. 'NETCDF') then + pio_iotype = PIO_IOTYPE_NETCDF + else if (trim(cvalue) .eq. 'PNETCDF') then + pio_iotype = PIO_IOTYPE_PNETCDF + else if (trim(cvalue) .eq. 'NETCDF4C') then + pio_iotype = PIO_IOTYPE_NETCDF4C + else if (trim(cvalue) .eq. 'NETCDF4P') then + pio_iotype = PIO_IOTYPE_NETCDF4P + else + call ESMF_LogWrite(trim("need to provide valid option for pio_typename (NETCDF|PNETCDF|NETCDF4C|NETCDF4P)"), ESMF_LOGMSG_INFO) + return + end if + else + cvalue = 'NETCDF' + pio_iotype = PIO_IOTYPE_NETCDF + end if + + ! pio_root + call NUOPC_CompAttributeGet(gcomp, name='pio_root', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (isPresent .and. isSet) then + read(cvalue,*) pio_root + if (pio_root < 0) then + pio_root = 1 + endif + pio_root = min(pio_root, petCount-1) + else + pio_root = 1 + end if + + ! pio_stride + call NUOPC_CompAttributeGet(gcomp, name='pio_stride', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (isPresent .and. isSet) then + read(cvalue,*) pio_stride + else + pio_stride = -99 + end if + + ! pio_numiotasks + call NUOPC_CompAttributeGet(gcomp, name='pio_numiotasks', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (isPresent .and. isSet) then + read(cvalue,*) pio_numiotasks + else + pio_numiotasks = -99 + end if + + ! check for parallel IO, it requires at least two io pes + if (petCount > 1 .and. pio_numiotasks == 1 .and. & + (pio_iotype .eq. PIO_IOTYPE_PNETCDF .or. pio_iotype .eq. PIO_IOTYPE_NETCDF4P)) then + pio_numiotasks = 2 + pio_stride = min(pio_stride, petCount/2) + endif + + if (pio_root + (pio_stride)*(pio_numiotasks-1) >= petCount .or. & + pio_stride <= 0 .or. pio_numiotasks <= 0 .or. pio_root < 0 .or. pio_root > petCount-1) then + if (petCount < 100) then + pio_stride = max(1, petCount/4) + else if(petCount < 1000) then + pio_stride = max(1, petCount/8) + else + pio_stride = max(1, petCount/16) + end if + if(pio_stride > 1) then + pio_numiotasks = petCount/pio_stride + pio_root = min(1, petCount-1) + else + pio_numiotasks = petCount + pio_root = 0 + end if + end if + + ! pio_rearranger + call NUOPC_CompAttributeGet(gcomp, name='pio_rearranger', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (isPresent .and. isSet) then + cvalue = ESMF_UtilStringUpperCase(cvalue) + if (trim(cvalue) .eq. 'BOX') then + pio_rearranger = PIO_REARR_BOX + else if (trim(cvalue) .eq. 'SUBSET') then + pio_rearranger = PIO_REARR_SUBSET + else + call ESMF_LogWrite(trim("need to provide valid option for pio_rearranger (BOX|SUBSET)"), ESMF_LOGMSG_INFO) + return + end if + else + cvalue = 'SUBSET' + pio_rearranger = PIO_REARR_SUBSET + 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) + + ! PIO debug related options + ! pio_debug_level + call NUOPC_CompAttributeGet(gcomp, name='pio_debug_level', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (isPresent .and. isSet) then + read(cvalue,*) pio_debug_level + if (pio_debug_level < 0 .or. pio_debug_level > 6) then + call ESMF_LogWrite(trim("MPAS_NUOPC_CAP: need to provide valid option for pio_debug_level (0-6)"), ESMF_LOGMSG_INFO) + return + end if + else + pio_debug_level = 0 + end if + + ! set PIO debug level + call pio_setdebuglevel(pio_debug_level) + +#endif + ! set cpl_scalars from config. Default to null values for standalone flds_scalar_name = '' flds_scalar_num = 0 @@ -427,7 +605,7 @@ subroutine InitializeAdvertise(gcomp, rc) ! set up fcst grid component ! !---------------------------------------------------------------------- -!*** create fv3 atm tasks and quilt servers +!*** create ufsatm tasks and quilt servers !----------------------------------------------------------------------- ! ! create fcst grid component @@ -442,10 +620,10 @@ subroutine InitializeAdvertise(gcomp, rc) do j=1, num_pes_fcst fcstPetList(j) = j - 1 enddo - fcstComp = ESMF_GridCompCreate(petList=fcstPetList, name='fv3_fcst', rc=rc) + fcstComp = ESMF_GridCompCreate(petList=fcstPetList, name='ufsatm_fcst', rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! - ! copy attributes from fv3cap component to fcstComp + ! copy attributes from ufscap component to fcstComp call ESMF_InfoGetFromHost(gcomp, info=parentInfo, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return call ESMF_InfoGetFromHost(fcstComp, info=childInfo, rc=rc) @@ -479,12 +657,13 @@ subroutine InitializeAdvertise(gcomp, rc) ! determine number elements in fcstState call ESMF_StateGet(fcstState, itemCount=FBCount, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if(mype == 0) print *,'fv3_cap: field bundles in fcstComp export state, FBCount= ',FBcount + if(mype == 0) print *,'ufsatm_cap: field bundles in fcstComp export state, FBCount= ',FBcount ! ! set start time for output output_startfh = 0. ! ! query the is_moving array from the fcstState (was set by fcstComp.Initialize() above) +#ifdef FV3 call ESMF_InfoGetFromHost(fcstState, info=info, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return call ESMF_InfoGetAlloc(info, key="is_moving", values=is_moving, rc=rc) @@ -502,7 +681,7 @@ subroutine InitializeAdvertise(gcomp, rc) write(msgString,'(A,8L4)') trim(subname)//" is_moving = ", is_moving call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - +#endif ! !----------------------------------------------------------------------- !*** create and initialize Write component(s). @@ -571,7 +750,7 @@ subroutine InitializeAdvertise(gcomp, rc) ! print *,'af wrtComp(i)=',i,'name=',trim(cwrtcomp),'rc=',rc if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -! copy attributes from fv3cap component to wrtComp +! copy attributes from ufsatm_cap component to wrtComp call ESMF_InfoGetFromHost(wrtComp(i), info=childInfo, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return call ESMF_InfoUpdate(lhs=childInfo, rhs=parentInfo, rc=rc) @@ -880,7 +1059,7 @@ subroutine InitializeAdvertise(gcomp, rc) inquire(FILE=trim(rh_filename), EXIST=rh_file_exist) if (rh_file_exist .and. use_saved_routehandles) then - if(mype==0) print *,' routehandle file ',trim(rh_filename), ' exists' + if(mype==0) print *,'in ufsatm_cap init, routehandle file ',trim(rh_filename), ' exists' write(msgString,*) "Calling into ESMF_RouteHandleCreate(from file)...", trim(rh_filename) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO, rc=rc) @@ -905,7 +1084,7 @@ subroutine InitializeAdvertise(gcomp, rc) routehandle=routehandle(j,1), & rc=rc) if (rc /= ESMF_SUCCESS) then - call ESMF_LogWrite('fv3_cap.F90:InitializeAdvertise error in ESMF_FieldBundleRedistStore', ESMF_LOGMSG_ERROR, rc=rc) + call ESMF_LogWrite('ufsatm_cap.F90:InitializeAdvertise error in ESMF_FieldBundleRedistStore', ESMF_LOGMSG_ERROR, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! call ESMF_Finalize(endflag=ESMF_END_ABORT) endif @@ -926,7 +1105,7 @@ subroutine InitializeAdvertise(gcomp, rc) unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, & srcTermProcessing=isrcTermProcessing, rc=rc) if (rc /= ESMF_SUCCESS) then - call ESMF_LogWrite('fv3_cap.F90:InitializeAdvertise error in ESMF_FieldBundleRegridStore', ESMF_LOGMSG_ERROR, rc=rc) + call ESMF_LogWrite('ufsatm_cap.F90:InitializeAdvertise error in ESMF_FieldBundleRegridStore', ESMF_LOGMSG_ERROR, rc=rc) call ESMF_Finalize(endflag=ESMF_END_ABORT) endif call ESMF_TraceRegionExit("ESMF_FieldBundleRegridStore()", rc=rc) @@ -945,7 +1124,7 @@ subroutine InitializeAdvertise(gcomp, rc) call ESMF_RouteHandleWrite(routehandle(j,1), fileName=trim(rh_filename), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return call ESMF_TraceRegionExit("ESMF_RouteHandleWrite()", rc=rc) - if(mype==0) print *,' saved routehandle file ',trim(rh_filename) + if(mype==0) print *,'in ufsatm_cap init, saved routehandle file ',trim(rh_filename) write(msgString,*) "... returned from ESMF_RouteHandleWrite." call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO, rc=rc) @@ -995,8 +1174,7 @@ subroutine InitializeAdvertise(gcomp, rc) ! end write_groups enddo ! i=1, write_groups - if(mype==0) print *,'in fv3cap init, time wrtcrt/regrdst',MPI_Wtime()-timerhs - + if(mype==0) print *,'in ufsatm_cap init, time wrtcrt/regrdst',MPI_Wtime()-timerhs deallocate(petList) deallocate(originPetList) deallocate(targetPetList) @@ -1008,7 +1186,7 @@ subroutine InitializeAdvertise(gcomp, rc) if(iau_offset > 0) then output_startfh = iau_offset endif - if(mype==0) print *,'in fv3 cap init, output_startfh=',output_startfh,' iau_offset=',iau_offset + if(mype==0) print *,'in ufsatm cap init, output_startfh=',output_startfh,' iau_offset=',iau_offset ! !----------------------------------------------------------------------- !*** SET THE FIRST WRITE GROUP AS THE FIRST ONE TO ACT. @@ -1020,6 +1198,7 @@ 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. @@ -1051,7 +1230,7 @@ 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) @@ -1073,7 +1252,7 @@ subroutine InitializeAdvertise(gcomp, rc) call ESMF_ConfigDestroy(cf, rc=rc) if (ESMF_LogFoundError(rcToCheck=urc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return - if(write_runtimelog .and. lprint) print *,'in fv3_cap, init time=',MPI_Wtime()-timeis,mype + if(write_runtimelog .and. lprint) print *,'in ufsatm_cap, init time=',MPI_Wtime()-timeis,mype !----------------------------------------------------------------------- ! end subroutine InitializeAdvertise @@ -1155,7 +1334,7 @@ subroutine InitializeRealize(gcomp, rc) integer, intent(out) :: rc ! local variables - character(len=*),parameter :: subname='(fv3atm_cap:InitializeRealize)' + character(len=*),parameter :: subname='(ufsatm_cap:InitializeRealize)' type(ESMF_Clock) :: clock type(ESMF_State) :: importState, exportState integer :: urc @@ -1181,7 +1360,7 @@ subroutine InitializeRealize(gcomp, rc) timere = 0. timep2re = 0. - if(write_runtimelog .and. lprint) print *,'in fv3_cap, initirealz time=',MPI_Wtime()-timeirs,mype + if(write_runtimelog .and. lprint) print *,'in ufsatm_cap, initirealz time=',MPI_Wtime()-timeirs,mype end subroutine InitializeRealize @@ -1197,20 +1376,20 @@ subroutine ModelAdvance(gcomp, rc) rc = ESMF_SUCCESS timers = MPI_Wtime() - if(write_runtimelog .and. timere>0. .and. lprint) print *,'in fv3_cap, time between fv3 run step=', timers-timere,mype + if(write_runtimelog .and. timere>0. .and. lprint) print *,'in ufsatm_cap, time between atmosphere run step=', timers-timere,mype - if (profile_memory) call ESMF_VMLogMemInfo("Entering FV3 ModelAdvance: ") + if (profile_memory) call ESMF_VMLogMemInfo("Entering UFSATM ModelAdvance: ") 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 - - if (profile_memory) call ESMF_VMLogMemInfo("Leaving FV3 ModelAdvance: ") +#endif + if (profile_memory) call ESMF_VMLogMemInfo("Leaving UFSATM ModelAdvance: ") timere = MPI_Wtime() - if(write_runtimelog .and. lprint) print *,'in fv3_cap, time in fv3 run step=', timere-timers, mype + if(write_runtimelog .and. lprint) print *,'in ufsatm_cap, time in atmosphere run step=', timere-timers, mype end subroutine ModelAdvance @@ -1224,7 +1403,7 @@ subroutine ModelAdvance_phase1(gcomp, rc) type(ESMF_Clock) :: clock integer :: urc logical :: fcstpe - character(len=*),parameter :: subname='(fv3_cap:ModelAdvance_phase1)' + character(len=*),parameter :: subname='(ufsatm_cap:ModelAdvance_phase1)' character(240) :: msgString real(kind=8) :: MPI_Wtime, timep1rs, timep1re @@ -1232,23 +1411,23 @@ subroutine ModelAdvance_phase1(gcomp, rc) rc = ESMF_SUCCESS timep1rs = MPI_Wtime() - if(write_runtimelog .and. timep2re>0. .and. lprint) print *,'in fv3_cap, time between fv3 run phase2 and phase1 ', timep1rs-timep2re,mype + if(write_runtimelog .and. timep2re>0. .and. lprint) print *,'in ufsatm_cap, time between ufsatm run phase2 and phase1 ', timep1rs-timep2re,mype - if(profile_memory) call ESMF_VMLogMemInfo("Entering FV3 ModelAdvance_phase1: ") + if(profile_memory) call ESMF_VMLogMemInfo("Entering UFSATM ModelAdvance_phase1: ") call ESMF_GridCompGet(gcomp, clock=clock, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return call ESMF_ClockPrint(clock, options="currTime", & - preString="entering FV3_ADVANCE phase1 with clock current: ", & + preString="entering UFSATM_ADVANCE phase1 with clock current: ", & unit=msgString) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) call ESMF_ClockPrint(clock, options="startTime", & - preString="entering FV3_ADVANCE phase1 with clock start: ", & + preString="entering UFSATM_ADVANCE phase1 with clock start: ", & unit=msgString) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) call ESMF_ClockPrint(clock, options="stopTime", & - preString="entering FV3_ADVANCE phase1 with clock stop: ", & + preString="entering UFSATM_ADVANCE phase1 with clock stop: ", & unit=msgString) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) @@ -1264,8 +1443,8 @@ subroutine ModelAdvance_phase1(gcomp, rc) endif timep1re = MPI_Wtime() - if(write_runtimelog .and. lprint) print *,'in fv3_cap,modeladvance phase1 time ', timep1re-timep1rs,mype - if (profile_memory) call ESMF_VMLogMemInfo("Leaving FV3 ModelAdvance_phase1: ") + if(write_runtimelog .and. lprint) print *,'in ufsatm_cap,modeladvance phase1 time ', timep1re-timep1rs,mype + if (profile_memory) call ESMF_VMLogMemInfo("Leaving UFSATM ModelAdvance_phase1: ") end subroutine ModelAdvance_phase1 @@ -1284,7 +1463,7 @@ subroutine ModelAdvance_phase2(gcomp, rc) integer :: na, j, urc integer :: nfseconds logical :: fcstpe - character(len=*),parameter :: subname='(fv3_cap:ModelAdvance_phase2)' + character(len=*),parameter :: subname='(ufsatm_cap:ModelAdvance_phase2)' character(240) :: msgString @@ -1300,7 +1479,7 @@ subroutine ModelAdvance_phase2(gcomp, rc) rc = ESMF_SUCCESS timep2rs = MPI_Wtime() - if(profile_memory) call ESMF_VMLogMemInfo("Entering FV3 ModelAdvance_phase2: ") + if(profile_memory) call ESMF_VMLogMemInfo("Entering UFSATM ModelAdvance_phase2: ") call ESMF_GridCompGet(gcomp, clock=clock, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -1402,15 +1581,15 @@ subroutine ModelAdvance_phase2(gcomp, rc) endif ! quilting call ESMF_ClockPrint(clock, options="currTime", & - preString="leaving FV3_ADVANCE phase2 with clock current: ", & + preString="leaving UFSATM_ADVANCE phase2 with clock current: ", & unit=msgString) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) call ESMF_ClockPrint(clock, options="startTime", & - preString="leaving FV3_ADVANCE phase2 with clock start: ", & + preString="leaving UFSATM_ADVANCE phase2 with clock start: ", & unit=msgString) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) call ESMF_ClockPrint(clock, options="stopTime", & - preString="leaving FV3_ADVANCE phase2 with clock stop: ", & + preString="leaving UFSATM_ADVANCE phase2 with clock stop: ", & unit=msgString) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) @@ -1425,8 +1604,8 @@ subroutine ModelAdvance_phase2(gcomp, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return timep2re = MPI_Wtime() - if(write_runtimelog .and. lprint) print *,'in fv3_cap,modeladvance phase2 time ', timep2re-timep2rs, mype - if(profile_memory) call ESMF_VMLogMemInfo("Leaving FV3 ModelAdvance_phase2: ") + if(write_runtimelog .and. lprint) print *,'in ufsatm_cap,modeladvance phase2 time ', timep2re-timep2rs, mype + if(profile_memory) call ESMF_VMLogMemInfo("Leaving UFSATM ModelAdvance_phase2: ") end subroutine ModelAdvance_phase2 @@ -1466,7 +1645,7 @@ end subroutine ModelSetRunClock !----------------------------------------------------------------------------- - subroutine fv3_checkimport(gcomp, rc) + subroutine ufsatm_checkimport(gcomp, rc) !*** Check the import state fields @@ -1475,7 +1654,7 @@ subroutine fv3_checkimport(gcomp, rc) integer, intent(out) :: rc ! local variables - character(len=*),parameter :: subname='(fv3atm_cap:fv3_checkimport)' + character(len=*),parameter :: subname='(ufsatmatm_cap:ufsatm_checkimport)' integer :: n, nf type(ESMF_Clock) :: clock type(ESMF_Time) :: currTime, invalidTime @@ -1499,7 +1678,7 @@ subroutine fv3_checkimport(gcomp, rc) date(1:6) = 0 call ESMF_TimeGet(time=currTime,yy=date(1),mm=date(2),dd=date(3),h=date(4), & m=date(5),s=date(6),rc=rc) -! if(mype==0) print *,'in fv3_checkimport, currtime=',date(1:6) +! if(mype==0) print *,'in ufsatm_checkimport, currtime=',date(1:6) ! set up invalid time (by convention) call ESMF_TimeSet(invalidTime, yy=99999999, mm=01, dd=01, & @@ -1515,7 +1694,7 @@ subroutine fv3_checkimport(gcomp, rc) importFieldsValid(:) = .true. if (associated(fieldList)) then -! if(mype==0) print *,'in fv3_checkimport, inside associated(fieldList)' +! if(mype==0) print *,'in ufsatm_checkimport, inside associated(fieldList)' do n = 1,size(fieldList) call ESMF_FieldGet(fieldList(n), name=fldname, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -1546,14 +1725,14 @@ subroutine fv3_checkimport(gcomp, rc) return end if end if - write(msgString,'(A,2i4,l3)') "fv3_checkimport "//trim(fldname),n,nf,importFieldsValid(nf) + write(msgString,'(A,2i4,l3)') "ufsatm_checkimport "//trim(fldname),n,nf,importFieldsValid(nf) call ESMF_LogWrite(msgString,ESMF_LOGMSG_INFO,rc=rc) enddo deallocate(fieldList) endif - end subroutine fv3_checkimport + end subroutine ufsatm_checkimport !----------------------------------------------------------------------------- @@ -1564,7 +1743,7 @@ subroutine TimestampExport_phase1(gcomp, rc) integer, intent(out) :: rc ! local variables - character(len=*),parameter :: subname='(fv3atm_cap:TimestampExport_phase1)' + character(len=*),parameter :: subname='(ufsatm_cap:TimestampExport_phase1)' type(ESMF_Clock) :: driverClock, modelClock type(ESMF_State) :: exportState @@ -1594,7 +1773,7 @@ subroutine ModelFinalize(gcomp, rc) integer, intent(out) :: rc ! local variables - character(len=*),parameter :: subname='(fv3atm_cap:ModelFinalize)' + character(len=*),parameter :: subname='(ufsatm_cap:ModelFinalize)' integer :: i, urc type(ESMF_VM) :: vm real(kind=8) :: MPI_Wtime, timeffs @@ -1636,10 +1815,10 @@ subroutine ModelFinalize(gcomp, rc) call ESMF_GridCompDestroy(fcstComp, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! - if(write_runtimelog .and. lprint) print *,'in fv3_cap, finalize time=',MPI_Wtime()-timeffs, mype + if(write_runtimelog .and. lprint) print *,'in ufsatm_cap, finalize time=',MPI_Wtime()-timeffs, mype end subroutine ModelFinalize ! !----------------------------------------------------------------------------- -end module fv3atm_cap_mod +end module ufsatm_cap_mod diff --git a/ufsatm_util.F90 b/ufsatm_util.F90 new file mode 100644 index 000000000..e532b1071 --- /dev/null +++ b/ufsatm_util.F90 @@ -0,0 +1,121 @@ +! ########################################################################################### +!> \file ufsatm_util.F90 +!> +!> This module contaion code that could be shared across dynamical core atmospheric drivers. +!> +! ########################################################################################### +module mod_ufsatm_util + implicit none + public :: get_atmos_tracer_types +contains + ! ######################################################################################### + ! + ! + ! Identify and return usage and type id of atmospheric tracers. + ! Ids are defined as: + ! 0 = generic tracer + ! 1 = chemistry - prognostic + ! 2 = chemistry - diagnostic + ! + ! Tracers are identified via the additional 'tracer_usage' keyword and + ! their optional 'type' qualifier. A tracer is assumed prognostic if + ! 'type' is not provided. See examples from the field_table file below: + ! + ! Prognostic tracer: + ! ------------------ + ! "TRACER", "atmos_mod", "so2" + ! "longname", "so2 mixing ratio" + ! "units", "ppm" + ! "tracer_usage", "chemistry" + ! "profile_type", "fixed", "surface_value=5.e-6" / + ! + ! Diagnostic tracer: + ! ------------------ + ! "TRACER", "atmos_mod", "pm25" + ! "longname", "PM2.5" + ! "units", "ug/m3" + ! "tracer_usage", "chemistry", "type=diagnostic" + ! "profile_type", "fixed", "surface_value=5.e-6" / + ! + ! For atmospheric chemistry, the order of both prognostic and diagnostic + ! tracers is validated against the model's internal assumptions. + ! + ! + ! ######################################################################################### + subroutine get_atmos_tracer_types(tracer_types) + + use field_manager_mod, only: parse + use tracer_manager_mod, only: query_method + use field_manager_mod, only: MODEL_ATMOS + use mpp_mod, only: mpp_error, FATAL + use tracer_manager_mod, only: get_number_tracers + + integer, intent(out) :: tracer_types(:) + + !--- local variables + logical :: found + integer :: n, num_tracers, num_types + integer :: id_max, id_min, id_num, ip_max, ip_min, ip_num + character(len=32) :: tracer_usage + character(len=128) :: control, tracer_type + + !--- begin + + !--- validate array size + call get_number_tracers(MODEL_ATMOS, num_tracers=num_tracers) + + if (size(tracer_types) < num_tracers) & + call mpp_error(FATAL, 'insufficient size of tracer type array') + + !--- initialize tracer indices + id_min = num_tracers + 1 + id_max = -id_min + ip_min = id_min + ip_max = id_max + id_num = 0 + ip_num = 0 + + do n = 1, num_tracers + tracer_types(n) = 0 + found = query_method('tracer_usage',MODEL_ATMOS,n,tracer_usage,control) + if (found) then + if (trim(tracer_usage) == 'chemistry') then + !--- set default to prognostic + tracer_type = 'prognostic' + num_types = parse(control, 'type', tracer_type) + select case (trim(tracer_type)) + case ('diagnostic') + tracer_types(n) = 2 + id_num = id_num + 1 + id_max = n + if (id_num == 1) id_min = n + case ('prognostic') + tracer_types(n) = 1 + ip_num = ip_num + 1 + ip_max = n + if (ip_num == 1) ip_min = n + end select + end if + end if + end do + + if (ip_num > 0) then + !--- check if prognostic tracers are contiguous + if (ip_num > ip_max - ip_min + 1) & + call mpp_error(FATAL, 'prognostic chemistry tracers must be contiguous') + end if + + if (id_num > 0) then + !--- check if diagnostic tracers are contiguous + if (id_num > id_max - id_min + 1) & + call mpp_error(FATAL, 'diagnostic chemistry tracers must be contiguous') + end if + + !--- prognostic tracers must precede diagnostic ones + if (ip_max > id_min) & + call mpp_error(FATAL, 'diagnostic chemistry tracers must follow prognostic ones') + + end subroutine get_atmos_tracer_types + ! + +end module mod_ufsatm_util