From 4652703a32a12054a71141d34da8623a6824f627 Mon Sep 17 00:00:00 2001 From: Yi-ChuanLO Date: Sun, 19 Jan 2025 14:41:20 +0900 Subject: [PATCH 001/214] fixed errors when compile fortran with gfortran with -fimplicit-none flag --- src/core_atmosphere/diagnostics/mpas_cloud_diagnostics.F | 6 +++--- .../physics/mpas_atmphys_lsm_noahmpinit.F | 2 +- .../physics/physics_wrf/module_cu_gf.mpas.F | 1 + .../physics/physics_wrf/module_sf_urban.F | 3 +++ src/framework/mpas_block_creator.F | 1 + src/framework/mpas_field_routines.F | 9 +++++++++ src/framework/mpas_framework.F | 2 ++ src/framework/mpas_timekeeping.F | 1 + 8 files changed, 21 insertions(+), 4 deletions(-) diff --git a/src/core_atmosphere/diagnostics/mpas_cloud_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_cloud_diagnostics.F index b4de3b3e75..b53a5109c7 100644 --- a/src/core_atmosphere/diagnostics/mpas_cloud_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_cloud_diagnostics.F @@ -15,11 +15,11 @@ module mpas_cloud_diagnostics type (MPAS_clock_type), pointer :: clock - public :: cloud_diagnostics_setup, & - cloud_diagnostics_compute, & - private + public :: cloud_diagnostics_setup, & + cloud_diagnostics_compute + contains diff --git a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F index da1cead2c0..35b2a1d157 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F +++ b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F @@ -253,7 +253,7 @@ subroutine noahmp_init(configs,mesh,diag_physics,diag_physics_noahmp,output_noah !local variables and pointers: logical,pointer:: do_restart logical,parameter:: fndsnowh = .true. - integer:: i,its,ite,ns,nsoil,nsnow,nzsnow + integer:: i,its,ite,n,ns,nsoil,nsnow,nzsnow !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write(' ') diff --git a/src/core_atmosphere/physics/physics_wrf/module_cu_gf.mpas.F b/src/core_atmosphere/physics/physics_wrf/module_cu_gf.mpas.F index 8e2d8309a5..67d893efc9 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_cu_gf.mpas.F +++ b/src/core_atmosphere/physics/physics_wrf/module_cu_gf.mpas.F @@ -3489,6 +3489,7 @@ SUBROUTINE neg_check(j,subt,subq,dt,q,outq,outt,outqc,pret,its,ite,kts,kte,itf,k ,intent (in ) :: & dt real :: thresh,qmem,qmemf,qmem2,qtest,qmem1 + integer :: i,k ! ! first do check on vertical heating rate ! diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F b/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F index 82d7ef5b02..c76d777093 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F @@ -2974,6 +2974,8 @@ SUBROUTINE bisection(TSP,PS,S,EPS,RX,SIG,RHO,CP,CH,UA,QA,TA,EL,BET,AKS,TSL,DZ,TS REAL, INTENT(IN) :: TSP,PS,S,EPS,RX,SIG,RHO,CP,CH,UA,QA,TA,EL,BET,AKS,TSL,DZ REAL, INTENT(OUT) :: TS REAL :: ES,QS0,R,H,ELE,G0,F1,F + REAL :: TS1, TS2 + INTEGER :: ITERATION TS1 = TSP - 5. TS2 = TSP + 5. @@ -3246,6 +3248,7 @@ SUBROUTINE TRANSP (ETT,ET,EC,SHDFAC,ETP1,CMC,CFACTR,CMCMAX,LAI,RSMIN,RSMAX,RGL,S REAL, INTENT(OUT) :: EC, ETT REAL :: RC, RCS, RCT, RCQ, RCSOIL, FF, WS, SLV, DESDT REAL :: SIGMA, PC, CMC2MS, SGX, DENOM, RTX, ETT1 + REAL :: EA, DELTA, RR INTEGER :: K REAL, DIMENSION(1:NROOT) :: PART, GX diff --git a/src/framework/mpas_block_creator.F b/src/framework/mpas_block_creator.F index 42070c04b8..3dc7e15606 100644 --- a/src/framework/mpas_block_creator.F +++ b/src/framework/mpas_block_creator.F @@ -984,6 +984,7 @@ subroutine mpas_block_creator_finalize_block_phase1(nHalos, blocklist, nCellsSol type (field1dInteger), pointer :: nCellsCursor, nEdgesCursor, nVerticesCursor type (field1dInteger), pointer :: indexToCellCursor, indexToEdgeCursor, indexToVertexCursor + integer :: nCells, nEdges, nVertices integer :: nCellsSolve_0Halo, nVerticesSolve_0Halo, nEdgesSolve_0Halo integer :: blockID, localBlockID, err_level, iErr diff --git a/src/framework/mpas_field_routines.F b/src/framework/mpas_field_routines.F index 0ae6e169e8..5d0cb4d371 100644 --- a/src/framework/mpas_field_routines.F +++ b/src/framework/mpas_field_routines.F @@ -144,6 +144,7 @@ subroutine mpas_allocate_scratch_field1d_integer(f, single_block_in, init_array_ logical :: single_block, init_array type (field1dInteger), pointer :: f_cursor integer :: threadNum + integer :: i if(f % isPersistent) then return @@ -232,6 +233,7 @@ subroutine mpas_allocate_scratch_field2d_integer(f, single_block_in, init_array_ logical :: single_block, init_array type (field2dInteger), pointer :: f_cursor integer :: threadNum + integer :: i,j if(f % isPersistent) then return @@ -324,6 +326,7 @@ subroutine mpas_allocate_scratch_field3d_integer(f, single_block_in, init_array_ logical :: single_block, init_array type (field3dInteger), pointer :: f_cursor integer :: threadNum + integer :: i,j,k if(f % isPersistent) then return @@ -416,6 +419,7 @@ subroutine mpas_allocate_scratch_field1d_real(f, single_block_in, init_array_in) logical :: single_block, init_array type (field1dReal), pointer :: f_cursor integer :: threadNum + integer :: i if(f % isPersistent) then return @@ -504,6 +508,7 @@ subroutine mpas_allocate_scratch_field2d_real(f, single_block_in, init_array_in) logical :: single_block, init_array type (field2dReal), pointer :: f_cursor integer :: threadNum + integer :: i,j if(f % isPersistent) then return @@ -594,6 +599,7 @@ subroutine mpas_allocate_scratch_field3d_real(f, single_block_in, init_array_in) logical :: single_block, init_array type (field3dReal), pointer :: f_cursor integer :: threadNum + integer :: i,j,k if(f % isPersistent) then return @@ -686,6 +692,7 @@ subroutine mpas_allocate_scratch_field4d_real(f, single_block_in, init_array_in) logical :: single_block, init_array type (field4dReal), pointer :: f_cursor integer :: threadNum + integer :: i,j,k,l if(f % isPersistent) then return @@ -782,6 +789,7 @@ subroutine mpas_allocate_scratch_field5d_real(f, single_block_in, init_array_in) logical :: single_block, init_array type (field5dReal), pointer :: f_cursor integer :: threadNum + integer :: i,j,k,l,m if(f % isPersistent) then return @@ -882,6 +890,7 @@ subroutine mpas_allocate_scratch_field1d_char(f, single_block_in, init_array_in) logical :: single_block, init_array type (field1dChar), pointer :: f_cursor integer :: threadNum + integer :: i if(f % isPersistent) then return diff --git a/src/framework/mpas_framework.F b/src/framework/mpas_framework.F index 7986383656..2d25bcc442 100644 --- a/src/framework/mpas_framework.F +++ b/src/framework/mpas_framework.F @@ -27,7 +27,9 @@ module mpas_framework use mpas_io_units use mpas_block_decomp +#ifdef MPAS_OPENACC private :: report_acc_devices +#endif contains diff --git a/src/framework/mpas_timekeeping.F b/src/framework/mpas_timekeeping.F index 93fdb86336..a6dc794f9c 100644 --- a/src/framework/mpas_timekeeping.F +++ b/src/framework/mpas_timekeeping.F @@ -150,6 +150,7 @@ end subroutine mpas_timekeeping_finalize !----------------------------------------------------------------------- subroutine mpas_timekeeping_set_year_width(yearWidthIn)!{{{ integer, intent(in) :: yearWidthIn + integer :: ierr yearWidth = yearWidthIn From 386cc4c275078f8e53209ef70df6d608745cd1d9 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 13 Jun 2025 13:35:50 -0600 Subject: [PATCH 002/214] Update version number to 8.3.1 --- README.md | 2 +- src/core_atmosphere/Registry.xml | 2 +- src/core_init_atmosphere/Registry.xml | 2 +- src/core_landice/Registry.xml | 2 +- src/core_ocean/Registry.xml | 2 +- src/core_seaice/Registry.xml | 2 +- src/core_sw/Registry.xml | 2 +- src/core_test/Registry.xml | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) diff --git a/README.md b/README.md index 5e4df2480f..a4f23e5523 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -MPAS-v8.3.0 +MPAS-v8.3.1 ==== The Model for Prediction Across Scales (MPAS) is a collaborative project for diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 2f6820d719..4281c40bba 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index ceec72efd8..cf4934a81b 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 9edf2853d0..1153d48c25 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 5b30da8525..29cf098fef 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -1,5 +1,5 @@ - + - + - + diff --git a/src/core_test/Registry.xml b/src/core_test/Registry.xml index 000ca901e3..4c3f48bc7a 100644 --- a/src/core_test/Registry.xml +++ b/src/core_test/Registry.xml @@ -1,5 +1,5 @@ - + From 5fd856a1732567a6c82d4b7e8d5d21a907b07433 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 13 Jun 2025 13:41:33 -0600 Subject: [PATCH 003/214] Fix bug in vertical interp of humidity for LBCs when levels are given top-to-bottom Note: The changes in this commit mirror those in commit f232665e, but this commit concerns to the code for producing LBCs rather than the code for producing ICs. The code in the init_atm_case_lbc routine for vertically interpolating relative humidity and specific humidity for LBCs assumed that first-guess levels would be given in bottom-to-top order when attempting to vertically extrapolate to model levels below the lowest first-guess level. The relevant code for relative humidity read as follows -- the code for specific humidity is similar. if (target_z < z_fg(1,iCell) .and. k < nVertLevels) relhum(k,iCell) = relhum(k+1,iCell) If first-guess levels are not given in bottom-to-top order, then z_fg(1,iCell) does not necessarily contain the height of the surface in the first-guess data, resulting in a copy of vertically interpolated relative humidity level k+1 to level k. One possible fix for this issue might be to compare target_z with sorted_arr(1,1). Since sorted_arr is always sorted in ascending order by its first index, the check to decide when to copy/extrapolate relative humidity would be independent of the order in which first-guess levels were provided. If the comparison were to be made against sorted_arr(1,1) rather than against z_fg(1,iCell), the effect would be to copy the lowest *interpolated* level downward to model levels below the first-guess ground. An alternative fix adopted in this commit is to simply delete the logic to explicitly copy/extrapolate downward, since both relative humidity and specific humidity are vertically interpolated with extrap=0, which specifies constant- value extrapolation. In this case, the lowest *first-guess* level -- rather than the lowest *interpolated* level -- is copied downward. Note: The issue being addressed by this commit is a dependence on the order in which levels are given in the input intermediate file, and not on the direction in which the first-guess model indexes its levels. --- src/core_init_atmosphere/mpas_init_atm_cases.F | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index cfd3f3d27b..3c5320c9f3 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -5459,7 +5459,6 @@ subroutine init_atm_case_lbc(timestamp, block, mesh, nCells, nEdges, nVertLevels target_z = 0.5 * (zgrid(k,iCell) + zgrid(k+1,iCell)) relhum(k,iCell) = vertical_interp(target_z, nfglevels_actual-1, & sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=0) - if (target_z < z_fg(1,iCell) .and. k < nVertLevels) relhum(k,iCell) = relhum(k+1,iCell) end do @@ -5477,7 +5476,6 @@ subroutine init_atm_case_lbc(timestamp, block, mesh, nCells, nEdges, nVertLevels target_z = 0.5 * (zgrid(k,iCell) + zgrid(k+1,iCell)) spechum(k,iCell) = vertical_interp(target_z, nfglevels_actual-1, & sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=0) - if (target_z < z_fg(1,iCell) .and. k < nVertLevels) spechum(k,iCell) = spechum(k+1,iCell) end do From ddc98648bfb2ab6c3fd98ca5e8d4b96f4c082922 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Mon, 16 Jun 2025 13:50:31 -0600 Subject: [PATCH 004/214] Update MMM-physics tag in Externals.cfg to fix .F90 re-compilation issue This commit updates the tag to 20250616-MPASv8.3 for the MMM-physics external in the src/core_atmosphere/Externals.cfg file to address an issue with .F90 files not being re-compiled to .o files if a .F90 file was modified. With the updated tag, compiling the atmosphere core, then making changes to any of the .F90 files in src/core_atmosphere/physics/physics_mmm/, then running 'make' again (without first cleaning) leads to the modified .F90 files correctly being re-compiled. --- src/core_atmosphere/Externals.cfg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/Externals.cfg b/src/core_atmosphere/Externals.cfg index 3fe143bea7..84dc47d1d8 100644 --- a/src/core_atmosphere/Externals.cfg +++ b/src/core_atmosphere/Externals.cfg @@ -2,7 +2,7 @@ local_path = ./physics_mmm protocol = git repo_url = https://github.com/NCAR/MMM-physics.git -tag = 20240626-MPASv8.2 +tag = 20250616-MPASv8.3 required = True [GSL_UGWP] From 0e2c6ea977f024b49e685ef4aa0f77e0eb34cad1 Mon Sep 17 00:00:00 2001 From: Matt Dawson Date: Thu, 10 Apr 2025 14:55:26 -0600 Subject: [PATCH 005/214] Add support for linking with the MUSICA-Fortran library This commit adds support for linking with the MUSICA-Fortran library. This capability is intended as a first step towards being able to use MUSICA chemistry components (MICM, TUV-x) in MPAS-Atmosphere. In order for MPAS to link with the MUSICA-Fortran library, the library must be detectable through 'pkg-config'. Specifying MUSICA=true on the MPAS 'make' command line will cause MPAS to link with the MUSICA library; for example: make gnu CORE=atmosphere MUSICA=true Note that, although the use of the MUSICA library will likely be within the context of the atmosphere core only, compiling any core with MUSICA=true will cause the MUSICA library to be linked with the MPAS model core executable. If the MUSICA-Fortran library has been linked successfully, the build summary will include the message MPAS was linked with the MUSICA-Fortran library version 0.10.1. (possibly with a different version number); additionally, when running the model, the log file will contain a message indicating MUSICA support as well as the MICM library version, e.g.: MUSICA support: yes - MICM version: 3.8.0 If the MUSICA-Fortran library has not been linked, the build summary will include the message MPAS was not linked with the MUSICA-Fortran library. and the log file for a core will contain the message MUSICA support: no . --- Makefile | 48 ++++++++++++++++++++++++++++++++++ src/framework/mpas_framework.F | 16 +++++++++++- 2 files changed, 63 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 1d31bb2843..e3bed8048f 100644 --- a/Makefile +++ b/Makefile @@ -872,6 +872,20 @@ $(if $(PRECISION),$(info NOTE: PRECISION=single is unnecessary, single is the de PRECISION_MESSAGE="MPAS was built with default single-precision reals." endif #PRECISION IF +# Optional MUSICA support for chemistry +ifeq "$(shell echo $(MUSICA) | tr '[:upper:]' '[:lower:]')" "true" +ifeq ($(shell pkg-config --exists musica-fortran && echo yes || echo no), no) +$(error "musica-fortran package is not installed. Please install it to proceed.") +endif + MUSICA_FCINCLUDES += $(shell pkg-config --cflags musica-fortran) + MUSICA_LIBS += $(shell pkg-config --libs musica-fortran) + MUSICA_FFLAGS = -DMPAS_USE_MUSICA + + FCINCLUDES += $(MUSICA_FCINCLUDES) + LIBS += $(MUSICA_LIBS) + override CPPFLAGS += $(MUSICA_FFLAGS) +endif + ifeq "$(USE_PAPI)" "true" CPPINCLUDES += -I$(PAPI)/include -D_PAPI FCINCLUDES += -I$(PAPI)/include @@ -1374,6 +1388,32 @@ mpi_f08_test: $(if $(findstring 1,$(MPAS_MPI_F08)), $(eval MPI_F08_MESSAGE = "Using the mpi_f08 module."), ) $(if $(findstring 1,$(MPAS_MPI_F08)), $(info mpi_f08 module detected.)) +musica_fortran_test: + @# + @# Create a Fortran test program that will link against the MUSICA library + @# + $(info Checking for a working MUSICA-Fortran library...) + $(eval MUSICA_FORTRAN_TEST := $(shell $\ + printf "program test_musica_fortran\n$\ + & use musica_util, only : string_t\n$\ + & use musica_micm, only : get_micm_version\n$\ + & type(string_t) :: version_string\n$\ + & version_string = get_micm_version()\n$\ + & print *, \"MUSICA support is available. MICM version: \", version_string%%value_\n$\ + end program test_musica_fortran\n" | sed 's/&/ /' > test_musica_fortran.f90; $\ + $\ + $(FC) $(MUSICA_FCINCLUDES) $(MUSICA_FFLAGS) test_musica_fortran.f90 -o test_musica_fortran.x $(MUSICA_LIBS) > /dev/null 2>&1; $\ + musica_fortran_status=$$?; $\ + rm -f test_musica_fortran.f90 test_musica_fortran.x; $\ + if [ $$musica_fortran_status -eq 0 ]; then $\ + printf "1"; $\ + else $\ + printf "0"; $\ + fi $\ + )) + $(if $(findstring 0,$(MUSICA_FORTRAN_TEST)), $(error Could not build a simple test program with MUSICA-Fortran)) + $(eval MUSICA_FORTRAN_VERSION := $(shell pkg-config --modversion musica-fortran)) + $(if $(findstring 1,$(MUSICA_FORTRAN_TEST)), $(info Built a simple test program with MUSICA-Fortran version $(MUSICA_FORTRAN_VERSION)), ) pnetcdf_test: @# @@ -1424,6 +1464,13 @@ IO_MESSAGE = "Using the SMIOL library." override CPPFLAGS += "-DMPAS_SMIOL_SUPPORT" endif +ifneq "$(MUSICA_FFLAGS)" "" +MAIN_DEPS += musica_fortran_test +MUSICA_MESSAGE = "MPAS was linked with the MUSICA-Fortran library version $(MUSICA_FORTRAN_VERSION)." +else +MUSICA_MESSAGE = "MPAS was not linked with the MUSICA-Fortran library." +endif + mpas_main: $(MAIN_DEPS) cd src; $(MAKE) FC="$(FC)" \ CC="$(CC)" \ @@ -1460,6 +1507,7 @@ mpas_main: $(MAIN_DEPS) @echo $(OPENMP_MESSAGE) @echo $(OPENMP_OFFLOAD_MESSAGE) @echo $(OPENACC_MESSAGE) + @echo $(MUSICA_MESSAGE) @echo $(SHAREDLIB_MESSAGE) ifeq "$(AUTOCLEAN)" "true" @echo $(AUTOCLEAN_MESSAGE) diff --git a/src/framework/mpas_framework.F b/src/framework/mpas_framework.F index 7986383656..0c48c68bac 100644 --- a/src/framework/mpas_framework.F +++ b/src/framework/mpas_framework.F @@ -26,6 +26,10 @@ module mpas_framework use mpas_io use mpas_io_units use mpas_block_decomp +#ifdef MPAS_USE_MUSICA + use musica_micm, only : get_micm_version + use musica_util, only : string_t +#endif private :: report_acc_devices @@ -207,7 +211,9 @@ subroutine mpas_framework_report_settings(domain) implicit none type (domain_type), pointer :: domain - +#ifdef MPAS_USE_MUSICA + type(string_t) :: micm_version +#endif call mpas_log_write('') call mpas_log_write('Output from ''git describe --dirty'': '//trim(domain % core % git_version)) @@ -248,6 +254,14 @@ subroutine mpas_framework_report_settings(domain) #endif #else 'SMIOL') +#endif + call mpas_log_write(' MUSICA support: ' // & +#ifdef MPAS_USE_MUSICA + 'yes') + micm_version = get_micm_version() + call mpas_log_write(' - MICM version: '//trim(micm_version % value_)) +#else + 'no') #endif call mpas_log_write('') From 7e0ef05fb97dc83a4fdd6e981c067914e2199ded Mon Sep 17 00:00:00 2001 From: Zhe Zhang Date: Thu, 3 Jul 2025 20:35:57 -0600 Subject: [PATCH 006/214] fix the q2 diagnostics in NoahMP --- .../physics_noahmp/drivers/mpas/EnergyVarOutTransferMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarOutTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarOutTransferMod.F90 index a3124b3a2e..a150bf9b6e 100644 --- a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarOutTransferMod.F90 +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarOutTransferMod.F90 @@ -136,7 +136,7 @@ subroutine EnergyVarOutTransfer(noahmp, NoahmpIO) NoahmpIO%CHB2XY (I) = noahmp%energy%state%ExchCoeffSh2mBare NoahmpIO%Q2MVXY (I) = noahmp%energy%state%SpecHumidity2mVeg /(1.0-noahmp%energy%state%SpecHumidity2mVeg) ! spec humidity to mixing ratio NoahmpIO%Q2MBXY (I) = noahmp%energy%state%SpecHumidity2mBare/(1.0-noahmp%energy%state%SpecHumidity2mBare) - NoahmpIO%Q2MXY (I) = noahmp%energy%state%SpecHumidity2m/(1.0-noahmp%energy%state%SpecHumidity2m) + NoahmpIO%Q2MXY (I) = NoahmpIO%Q2MBXY(I) * ( 1 - NoahmpIO%FVEGXY(I) ) + NoahmpIO%Q2MVXY(I) * NoahmpIO%FVEGXY(I) NoahmpIO%IRRSPLH (I) = NoahmpIO%IRRSPLH(I) + & (noahmp%energy%flux%HeatLatentIrriEvap * noahmp%config%domain%MainTimeStep) NoahmpIO%TSLB (I,1:NumSoilLayer) = noahmp%energy%state%TemperatureSoilSnow(1:NumSoilLayer) From 4e4f54f43f591efa33e164ad748348c338ac7b50 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 11 Jul 2025 11:54:48 -0600 Subject: [PATCH 007/214] Add computation of edgeNormalVectors for case 13 in the init_atmosphere core This commit adds a call to the mpas_initialize_vectors routine for init case 13 (CAM-MPAS 3-d grid) to compute the edgeNormalVectors, cellTangentPlane, and localVerticalUnitVectors fields, which may be useful for alternative initialization workflows for CAM-MPAS. --- src/core_init_atmosphere/mpas_init_atm_cases.F | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index e3e1ba56ea..379ff0f920 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -5823,6 +5823,7 @@ subroutine init_atm_case_cam_mpas(stream_manager, dminfo, block, mesh, & use mpas_dmpar, only : mpas_dmpar_exch_halo_field, mpas_dmpar_min_real, mpas_dmpar_max_real use mpas_stream_manager, only : MPAS_stream_mgr_stream_exists, MPAS_stream_mgr_read use mpas_derived_types, only : MPAS_STREAM_MGR_NOERR + use mpas_vector_operations, only : mpas_initialize_vectors implicit none @@ -5994,6 +5995,13 @@ subroutine init_atm_case_cam_mpas(stream_manager, dminfo, block, mesh, & call atm_initialize_deformation_weights(mesh, nCells, on_a_sphere, sphere_radius) + ! + ! Compute edgeNormalVectors, cellTangentPlane, and localVerticalUnitVectors + ! (NB: these are the same fields computed by the mpas_rbf_interp_initialize routine) + ! + call mpas_initialize_vectors(mesh) + + ! ! Read PHIS field from cam_topo stream ! From 82defae2f443ce4dabfc8f9f3e2189b2b629f537 Mon Sep 17 00:00:00 2001 From: Andy Stokely Date: Fri, 25 Jul 2025 19:40:18 -0600 Subject: [PATCH 008/214] Fix buffer overflow in c_attname due to missing null terminator The c_attname array in the streaminfo_query function (in mpas_stream_inquiry.F) was allocated to the same size as the attname variable. When attname had no padding, this caused a buffer overflow when appending a C null terminator (c_null_char) to c_attname. --- src/framework/mpas_stream_inquiry.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/mpas_stream_inquiry.F b/src/framework/mpas_stream_inquiry.F index 4a81ead1ad..dd7ffec2eb 100644 --- a/src/framework/mpas_stream_inquiry.F +++ b/src/framework/mpas_stream_inquiry.F @@ -249,7 +249,7 @@ end function query_streams_file call mpas_f_to_c_string(streamname, c_streamname) if (present(attname)) then - allocate(c_attname(len(attname))) + allocate(c_attname(len(attname)+1)) call mpas_f_to_c_string(attname, c_attname) c_attname_ptr = c_loc(c_attname) else From 26fc69c2bdb9dd781404ef8b590c0496e51cc700 Mon Sep 17 00:00:00 2001 From: Andy Stokely Date: Fri, 8 Aug 2025 11:03:22 -0600 Subject: [PATCH 009/214] Added unit test for error handling in MPAS_stream_mgr_remove_alarm. Tests fail when removing an input alarm from an output list or an output alarm from an input list due to the absence of proper error handling in MPAS_stream_mgr_remove_alarm in mpas_stream_manager.F. The test checks for an error when attempting to remove an alarm from the opposite list, but the error handling is missing, causing the test to fail. --- src/core_test/mpas_test_core.F | 5 +- src/core_test/mpas_test_core_streams.F | 169 ++++++++++++++++++++++++- 2 files changed, 170 insertions(+), 4 deletions(-) diff --git a/src/core_test/mpas_test_core.F b/src/core_test/mpas_test_core.F index b9824d7db5..dbaee54bbc 100644 --- a/src/core_test/mpas_test_core.F +++ b/src/core_test/mpas_test_core.F @@ -164,11 +164,12 @@ function test_core_run(domain) result(iErr)!{{{ end if !$omp end parallel + ! Run stream tests call test_core_streams_test(domain, threadErrs, iErr) if ( iErr == 0 ) then - call mpas_log_write('Stream I/O tests: SUCCESS') + call mpas_log_write('Stream tests: SUCCESS') else - call mpas_log_write('Stream I/O tests: FAILURE', MPAS_LOG_ERR) + call mpas_log_write('Stream tests: FAILURE', MPAS_LOG_ERR) end if ! Run string util tests diff --git a/src/core_test/mpas_test_core_streams.F b/src/core_test/mpas_test_core_streams.F index dc82ce3498..86d5547b49 100644 --- a/src/core_test/mpas_test_core_streams.F +++ b/src/core_test/mpas_test_core_streams.F @@ -19,7 +19,7 @@ module test_core_streams !*********************************************************************** ! - ! routine test_core_streams_test + ! routine test_read_write_real_streams ! !> \brief tests reading/writing single- and double-precision streams !> \author Michael Duda @@ -35,7 +35,7 @@ module test_core_streams !> that are created by this routine. ! !----------------------------------------------------------------------- - subroutine test_core_streams_test(domain, threadErrs, ierr) + subroutine test_read_write_real_streams(domain, threadErrs, ierr) use mpas_stream_manager @@ -391,6 +391,171 @@ subroutine test_core_streams_test(domain, threadErrs, ierr) return end if + end subroutine test_read_write_real_streams + + !*********************************************************************** + ! Subroutine test_remove_alarm + ! + !> \brief Tests the functionality of adding and removing alarms from + !> input and output streams in the stream manager. + !> + !> \details This subroutine creates a stream, adds an alarm to both + !> the stream and the clock, and verifies the correct handling + !> of alarms in different scenarios. It ensures that alarms + !> cannot be removed from the opposite list and can be removed + !> from the correct list. The stream type (input or output) + !> is passed as an argument to test both scenarios. + !> + !> \param domain The domain object that contains the stream manager + !> and clock. + !> \param streamType The type of the stream being tested (input or output). + !> \param ierr The error code that indicates the result of the test. + ! + !----------------------------------------------------------------------- + subroutine test_remove_alarm(domain, streamType, ierr) + use mpas_stream_manager + use mpas_timekeeping + + implicit none + + ! Arguments + type (domain_type), intent(inout) :: domain + integer, intent(in) :: streamType ! MPAS_STREAM_INPUT or MPAS_STREAM_OUTPUT + integer, intent(out) :: ierr + + ! Local variables + character(len = :), allocatable :: streamID + character(len = :), allocatable :: alarmID + character(len = :), allocatable :: fileName + integer :: oppositeType + type(MPAS_Time_type) :: alarmTime + integer :: err + + ierr = 0 + err = 0 + + ! Assign IDs and file name based on type + if (streamType == MPAS_STREAM_INPUT) then + streamID = 'test_input_alarm_stream' + alarmID = 'test_input_alarm' + fileName = 'test_input_alarm_stream.nc' + oppositeType = MPAS_STREAM_OUTPUT + else if (streamType == MPAS_STREAM_OUTPUT) then + streamID = 'test_output_alarm_stream' + alarmID = 'test_output_alarm' + fileName = 'test_output_alarm_stream.nc' + oppositeType = MPAS_STREAM_INPUT + else + call mpas_log_write('Invalid stream type passed to test_remove_alarm.', MPAS_LOG_ERR) + ierr = 1 + return + end if + + ! Create the stream + call MPAS_stream_mgr_create_stream(domain % streamManager, streamID, streamType, fileName, & + realPrecision = MPAS_IO_SINGLE_PRECISION, & + clobberMode = MPAS_STREAM_CLOBBER_TRUNCATE, & + ierr = err) + if (err /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Error creating stream.', MPAS_LOG_ERR) + ierr = ierr + abs(err) + end if + + ! Add alarm to the clock + call mpas_add_clock_alarm(domain % clock, alarmID, alarmTime, ierr = err) + if (err /= 0) then + call mpas_log_write('Error adding alarm to clock.', MPAS_LOG_ERR) + ierr = ierr + abs(err) + end if + + ! Add alarm to the stream + call MPAS_stream_mgr_add_alarm(domain % streamManager, streamID, alarmID, streamType, ierr = err) + if (err /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Error adding alarm to stream.', MPAS_LOG_ERR) + ierr = ierr + abs(err) + end if + + ! Try removing from opposite list — should fail + call MPAS_stream_mgr_remove_alarm(domain % streamManager, streamID, alarmID, oppositeType, ierr = err) + if (err /= MPAS_STREAM_MGR_ERROR) then + if (streamType == MPAS_STREAM_INPUT) then + call mpas_log_write('Expected error when removing input alarm from output alarm list.', MPAS_LOG_ERR) + else + call mpas_log_write('Expected error when removing output alarm from input alarm list.', MPAS_LOG_ERR) + end if + err = 1 + ierr = ierr + abs(err) + end if + + ! Remove from correct list — should succeed + call MPAS_stream_mgr_remove_alarm(domain % streamManager, streamID, alarmID, streamType, ierr = err) + if (err /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Error removing alarm from stream.', MPAS_LOG_ERR) + ierr = ierr + abs(err) + end if + + end subroutine test_remove_alarm + + !*********************************************************************** + ! Subroutine test_core_streams_test + ! + !> \brief Core test suite for stream I/O and alarm management in MPAS. + !> + !> \details This subroutine tests the functionality of reading/writing + !> real-valued streams and managing alarms in streams. It calls + !> individual tests for stream I/O operations and for adding/removing + !> alarms from input and output streams. The results of each test + !> are logged with a success or failure message. + !> + !> \param domain The domain object that contains the stream manager + !> and clock. + !> \param threadErrs An array to store any errors encountered during + !> the test. + !> \param ierr The error code that indicates the result of the test. + ! + !----------------------------------------------------------------------- + subroutine test_core_streams_test(domain, threadErrs, ierr) + + use mpas_log + + implicit none + + type (domain_type), intent(inout) :: domain + integer, dimension(:), intent(out) :: threadErrs + integer, intent(out) :: ierr + + integer :: test_status + + ierr = 0 + test_status = 0 + + call mpas_log_write('Testing reading/writing real-valued streams') + call test_read_write_real_streams(domain, threadErrs, test_status) + if (test_status == 0) then + call mpas_log_write('Stream I/O tests: SUCCESS') + else + call mpas_log_write('Stream I/O tests: FAILURE', MPAS_LOG_ERR) + ierr = ierr + abs(test_status) + end if + + call mpas_log_write('Testing removing an output alarm from a stream.') + call test_remove_alarm(domain, MPAS_STREAM_OUTPUT, test_status) + if (test_status == 0) then + call mpas_log_write('Removing output alarm test: SUCCESS') + else + call mpas_log_write('Removing output alarm test: FAILURE', MPAS_LOG_ERR) + ierr = ierr + abs(test_status) + end if + + call mpas_log_write('Testing removing an input alarm from a stream.') + call test_remove_alarm(domain, MPAS_STREAM_INPUT, test_status) + if (test_status == 0) then + call mpas_log_write('Removing input alarm test: SUCCESS') + else + call mpas_log_write('Removing input alarm test: FAILURE', MPAS_LOG_ERR) + ierr = ierr + abs(test_status) + end if + end subroutine test_core_streams_test end module test_core_streams From 002be2bb11b0404d49e1195051c9efdf2d26516f Mon Sep 17 00:00:00 2001 From: Andy Stokely Date: Fri, 8 Aug 2025 11:03:41 -0600 Subject: [PATCH 010/214] Handle errors from MPAS_stream_list_remove in MPAS_stream_mgr_remove_alarm Previously, some logic paths (e.g., passing the wrong direction to MPAS_stream_mgr_remove_alarm) would log an error without affecting the code's execution state. The fix can be verified by running the test core, where the previously failing stream tests now pass. --- src/framework/mpas_stream_manager.F | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/src/framework/mpas_stream_manager.F b/src/framework/mpas_stream_manager.F index d00fcaa800..7a3c7b079a 100644 --- a/src/framework/mpas_stream_manager.F +++ b/src/framework/mpas_stream_manager.F @@ -1383,8 +1383,18 @@ subroutine MPAS_stream_mgr_remove_alarm(manager, streamID, alarmID, direction, i nullify(alarmNode) if (direction == MPAS_STREAM_INPUT) then call MPAS_stream_list_remove(stream % alarmList_in, alarmID, alarmNode, ierr=ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems unlinking alarm from alarmList_in for stream: '//trim(streamID)) + return + end if else if (direction == MPAS_STREAM_OUTPUT) then call MPAS_stream_list_remove(stream % alarmList_out, alarmID, alarmNode, ierr=ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems unlinking alarm from alarmList_out for stream: '//trim(streamID)) + return + end if else if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR STREAM_ERROR_WRITE('Requested to remove alarm from invalid direction from stream '//trim(streamID)) @@ -1396,6 +1406,11 @@ subroutine MPAS_stream_mgr_remove_alarm(manager, streamID, alarmID, direction, i ! if (associated(alarmNode)) then call MPAS_stream_list_remove(alarmNode % xref % streamList, streamID, streamNode, ierr=ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while removing stream from alarms streamList.') + return + end if else if (direction == MPAS_STREAM_INPUT) then STREAM_ERROR_WRITE('Input alarm '//trim(alarmID)//' does not exist on stream '//trim(streamID)) @@ -1417,9 +1432,19 @@ subroutine MPAS_stream_mgr_remove_alarm(manager, streamID, alarmID, direction, i if (direction == MPAS_STREAM_INPUT) then STREAM_ERROR_WRITE('Input alarm '//trim(alarmID)//' has no associated streams and will be deleted.') call MPAS_stream_list_remove(manager % alarms_in, alarmID, alarmNode, ierr=ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while removing stream from list of input alarm') + return + end if else STREAM_ERROR_WRITE('Output alarm '//trim(alarmID)//' has no associated streams and will be deleted.') call MPAS_stream_list_remove(manager % alarms_out, alarmID, alarmNode, ierr=ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + if (present(ierr)) ierr = MPAS_STREAM_MGR_ERROR + STREAM_ERROR_WRITE('Problems while removing stream from list of output alarm') + return + end if end if end if end if From 91bb07bd4f4fd88e8a58e5f4afa56f5a82b72399 Mon Sep 17 00:00:00 2001 From: Andy Stokely Date: Fri, 8 Aug 2025 11:04:00 -0600 Subject: [PATCH 011/214] Remove error logging macros from mpas_stream_list.F Error logging is no longer necessary in mpas_stream_list.F, as error codes and logging are now handled in mpas_stream_manager.F. The related macros have been commented out. --- src/framework/mpas_stream_list.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/framework/mpas_stream_list.F b/src/framework/mpas_stream_list.F index 1ac079b6a0..b3bce7d956 100644 --- a/src/framework/mpas_stream_list.F +++ b/src/framework/mpas_stream_list.F @@ -2,8 +2,8 @@ module mpas_stream_list #define COMMA , #define LIST_DEBUG_WRITE(M) ! call mpas_log_write(M) -#define LIST_WARN_WRITE(M) call mpas_log_write( M , messageType=MPAS_LOG_WARN) -#define LIST_ERROR_WRITE(M) call mpas_log_write( M , messageType=MPAS_LOG_ERR) +#define LIST_WARN_WRITE(M) ! call mpas_log_write( M , messageType=MPAS_LOG_WARN) +#define LIST_ERROR_WRITE(M) ! call mpas_log_write( M , messageType=MPAS_LOG_ERR) use mpas_kind_types, only : StrKIND use mpas_log From 47aa6d9041ac879628652115218428e428315f8b Mon Sep 17 00:00:00 2001 From: Andy Stokely Date: Fri, 8 Aug 2025 13:56:53 -0600 Subject: [PATCH 012/214] Fix CMake linking for PnetCDF C library Update FindPnetCDF.cmake so PnetCDF::PnetCDF_C sets INTERFACE_LINK_LIBRARIES to pnetcdf instead of only setting INTERFACE_LINK_DIRECTORIES to the parallel-netcdf library directory, ensuring proper linkage in builds. --- cmake/Modules/FindPnetCDF.cmake | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/cmake/Modules/FindPnetCDF.cmake b/cmake/Modules/FindPnetCDF.cmake index 91a076ba57..34a8ab1c02 100644 --- a/cmake/Modules/FindPnetCDF.cmake +++ b/cmake/Modules/FindPnetCDF.cmake @@ -133,19 +133,20 @@ set(_new_components) if(PnetCDF_Fortran_FOUND AND NOT TARGET PnetCDF::PnetCDF_Fortran) add_library(PnetCDF::PnetCDF_Fortran INTERFACE IMPORTED) set_target_properties(PnetCDF::PnetCDF_Fortran PROPERTIES INTERFACE_INCLUDE_DIRECTORIES ${PnetCDF_INCLUDE_DIR} - INTERFACE_LINK_DIRECTORIES ${PnetCDF_LIB_DIR}) + INTERFACE_LINK_DIRECTORIES ${PnetCDF_LIB_DIR} + INTERFACE_LINK_LIBRARIES pnetcdf) if(PnetCDF_MODULE_DIR AND NOT PnetCDF_MODULE_DIR STREQUAL PnetCDF_INCLUDE_DIR ) set_property(TARGET PnetCDF::PnetCDF_Fortran APPEND PROPERTY INTERFACE_INCLUDE_DIRECTORIES ${PnetCDF_MODULE_DIR}) endif() set(_new_components 1) - target_link_libraries(PnetCDF::PnetCDF_Fortran INTERFACE -lpnetcdf) endif() # PnetCDF::PnetCDF_C imported interface target if(PnetCDF_C_FOUND AND NOT TARGET PnetCDF::PnetCDF_C) add_library(PnetCDF::PnetCDF_C INTERFACE IMPORTED) set_target_properties(PnetCDF::PnetCDF_C PROPERTIES INTERFACE_INCLUDE_DIRECTORIES ${PnetCDF_INCLUDE_DIR} - INTERFACE_LINK_DIRECTORIES ${PnetCDF_LIB_DIR}) + INTERFACE_LINK_DIRECTORIES ${PnetCDF_LIB_DIR} + INTERFACE_LINK_LIBRARIES pnetcdf) set(_new_components 1) endif() @@ -153,7 +154,8 @@ endif() if(PnetCDF_CXX_FOUND AND NOT TARGET PnetCDF::PnetCDF_CXX) add_library(PnetCDF::PnetCDF_CXX INTERFACE IMPORTED) set_target_properties(PnetCDF::PnetCDF_CXX PROPERTIES INTERFACE_INCLUDE_DIRECTORIES ${PnetCDF_INCLUDE_DIR} - INTERFACE_LINK_DIRECTORIES ${PnetCDF_LIB_DIR}) + INTERFACE_LINK_DIRECTORIES ${PnetCDF_LIB_DIR} + INTERFACE_LINK_LIBRARIES pnetcdf) set(_new_components 1) endif() From d3385a9e962a72d3f13bf9a53789143a4052e4f1 Mon Sep 17 00:00:00 2001 From: Andy Stokely Date: Fri, 15 Aug 2025 09:45:16 -0600 Subject: [PATCH 013/214] Add unit tests for mpas_stream_list module Unit tests were added for the mpas_stream_list module, covering stream list creation, insertion, querying, and removal. The tests fail when inserting duplicate streams adjacent to each other, either as the first or last stream in the list. The bug is in the MPAS_stream_list_insert subroutine in the mpas_stream_list module, which does not correctly handle duplicates in these cases. --- src/core_test/Makefile | 6 +- src/core_test/mpas_test_core.F | 11 + src/core_test/mpas_test_core_stream_list.F | 653 +++++++++++++++++++++ 3 files changed, 668 insertions(+), 2 deletions(-) create mode 100644 src/core_test/mpas_test_core_stream_list.F diff --git a/src/core_test/Makefile b/src/core_test/Makefile index 5518eceda0..2d7bb95f1e 100644 --- a/src/core_test/Makefile +++ b/src/core_test/Makefile @@ -11,7 +11,8 @@ OBJS = mpas_test_core.o \ mpas_test_core_string_utils.o \ mpas_test_core_dmpar.o \ mpas_test_core_stream_inquiry.o \ - mpas_test_openacc.o + mpas_test_openacc.o \ + mpas_test_core_stream_list.o all: core_test @@ -42,7 +43,8 @@ mpas_test_core.o: mpas_test_core_halo_exch.o mpas_test_core_streams.o \ mpas_test_core_field_tests.o mpas_test_core_timekeeping_tests.o \ mpas_test_core_sorting.o mpas_halo_testing.o \ mpas_test_core_string_utils.o mpas_test_core_dmpar.o \ - mpas_test_core_stream_inquiry.o mpas_test_openacc.o + mpas_test_core_stream_inquiry.o mpas_test_openacc.o \ + mpas_test_core_stream_list.o mpas_test_core_halo_exch.o: diff --git a/src/core_test/mpas_test_core.F b/src/core_test/mpas_test_core.F index dbaee54bbc..2116cbf92a 100644 --- a/src/core_test/mpas_test_core.F +++ b/src/core_test/mpas_test_core.F @@ -91,6 +91,7 @@ function test_core_run(domain) result(iErr)!{{{ use mpas_vector_operations use mpas_geometry_utils use test_core_streams, only : test_core_streams_test + use mpas_test_core_stream_list, only : mpas_test_stream_list use test_core_sorting, only : test_core_test_sorting use mpas_halo_testing, only : mpas_halo_tests use test_core_string_utils, only : mpas_test_string_utils @@ -171,6 +172,16 @@ function test_core_run(domain) result(iErr)!{{{ else call mpas_log_write('Stream tests: FAILURE', MPAS_LOG_ERR) end if + call mpas_log_write('') + + ! Run stream list tests + call mpas_test_stream_list(iErr) + if (iErr == 0) then + call mpas_log_write('Stream list tests: SUCCESS') + else + call mpas_log_write('Stream list tests: FAILURE', MPAS_LOG_ERR) + end if + call mpas_log_write('') ! Run string util tests call mpas_log_write('') diff --git a/src/core_test/mpas_test_core_stream_list.F b/src/core_test/mpas_test_core_stream_list.F new file mode 100644 index 0000000000..4511f052e1 --- /dev/null +++ b/src/core_test/mpas_test_core_stream_list.F @@ -0,0 +1,653 @@ +! Copyright (c) 2025 The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at https://mpas-dev.github.io/license.html . +! +module mpas_test_core_stream_list + + use mpas_derived_types + use mpas_log + use mpas_stream_list + + implicit none + private + + public :: mpas_test_stream_list + +contains + + !************************************************************************************** + ! Subroutine mpas_test_create_list + ! + !> \brief Test creating an empty stream list and verify initialization. + !> + !> \details This subroutine tests the creation of a new MPAS stream list, ensuring + !> that the list is properly initialized with zero items and no head stream. + !> The list is then destroyed to clean up any allocated memory. + !> + !> \param err The error code that indicates the result of the test. + ! + !-------------------------------------------------------------------------------------- + subroutine mpas_test_create_list(err) + integer, intent(out) :: err + type(MPAS_stream_list_type), pointer :: list + + err = 0 + + call MPAS_stream_list_create(list) + + if (.not. associated(list)) then + err = err + 1 + end if + + if (list%nItems /= 0) then + err = err + 1 + end if + + if (associated(list%head)) then + err = err + 1 + end if + + call MPAS_stream_list_destroy(list) + end subroutine mpas_test_create_list + + !************************************************************************************** + ! Subroutine mpas_test_insert_single + ! + !> \brief Test inserting a single stream into the list and verify correct insertion. + !> + !> \details This subroutine tests the insertion of a single stream into an MPAS + !> stream list. It verifies that the stream is correctly added to the + !> list, and checks that the list contains the expected stream with the + !> correct number of items. + !> + !> \param err The error code that indicates the result of the test. + ! + !-------------------------------------------------------------------------------------- + subroutine mpas_test_insert_single(err) + integer, intent(out) :: err + type(MPAS_stream_list_type), pointer :: list, stream + integer :: ierr + + err = 0 + + call MPAS_stream_list_create(list) + allocate(stream) + stream%name = 'stream1' + + call MPAS_stream_list_insert(list, stream, ierr) + + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + + if (.not. associated(list%head)) then + err = err + 1 + end if + + if (list%nItems /= 1) then + err = err + 1 + end if + + if (trim(list%head%name) /= 'stream1') then + err = err + 1 + end if + + call MPAS_stream_list_destroy(list) + end subroutine mpas_test_insert_single + + !************************************************************************************** + ! Subroutine mpas_test_query_exact_match + ! + !> \brief Test querying for an exact stream match and ensure correct stream is found. + !> + !> \details This subroutine tests querying a stream list for an exact match of a + !> stream's name. It ensures that the correct stream is found and that + !> the query operation behaves as expected. + !> + !> \param err The error code that indicates the result of the test. + ! + !-------------------------------------------------------------------------------------- + subroutine mpas_test_query_exact_match(err) + integer, intent(out) :: err + type(MPAS_stream_list_type), pointer :: list, stream, found + logical :: matched + + err = 0 + + call MPAS_stream_list_create(list) + allocate(stream) + stream%name = 'stream1' + call MPAS_stream_list_insert(list, stream) + found => null() + + matched = MPAS_stream_list_query(list, 'stream1', found) + + if (.not. matched) then + err = err + 1 + end if + + if (.not. associated(found)) then + err = err + 1 + else if (trim(found%name) /= 'stream1') then + err = err + 1 + end if + + call MPAS_stream_list_destroy(list) + end subroutine mpas_test_query_exact_match + + !************************************************************************************** + ! Subroutine mpas_test_remove_existing_streams + ! + !> \brief Test removing streams from the beginning, middle, and end of a list. + !> + !> \details This subroutine verifies that removing streams from different positions + !> in an MPAS stream list works as expected. It inserts three streams into + !> the list, then removes one from the middle, one from the end, and one + !> from the beginning, checking that the correct stream is removed in each + !> case and that the operation returns a success code. + !> + !> \param err The error code that indicates the result of the test. + !> + !-------------------------------------------------------------------------------------- + subroutine mpas_test_remove_existing_streams(err) + integer, intent(out) :: err + type(MPAS_stream_list_type), pointer :: list, s1, s2, s3, & + removed1, removed2, removed3 + integer :: ierr + + err = 0 + + allocate(s1) + s1%name = 'stream1' + allocate(s2) + s2%name = 'stream2' + allocate(s3) + s3%name = 'stream3' + + call MPAS_stream_list_create(list, ierr=ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + + call MPAS_stream_list_insert(list, s1, ierr=ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + + call MPAS_stream_list_insert(list, s2, ierr=ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + + call MPAS_stream_list_insert(list, s3, ierr=ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + + ! Remove from the middle + call MPAS_stream_list_remove(list, 'stream2', removed2, ierr=ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + if (.not. associated(removed2)) then + err = err + 1 + end if + if (trim(removed2%name) /= 'stream2') then + err = err + 1 + end if + + ! Remove from the end + call MPAS_stream_list_remove(list, 'stream3', removed3, ierr=ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + if (.not. associated(removed3)) then + err = err + 1 + end if + if (trim(removed3%name) /= 'stream3') then + err = err + 1 + end if + + ! Remove from the beginning + call MPAS_stream_list_remove(list, 'stream1', removed1, ierr=ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + if (.not. associated(removed1)) then + err = err + 1 + end if + if (trim(removed1%name) /= 'stream1') then + err = err + 1 + end if + + call MPAS_stream_list_destroy(list) + deallocate(removed1) + deallocate(removed2) + deallocate(removed3) + end subroutine mpas_test_remove_existing_streams + + !************************************************************************************** + ! Subroutine mpas_test_insert_non_adjacent_duplicate + ! + !> \brief Test inserting a non-adjacent duplicate of the first item added to the list. + !> + !> \details This subroutine verifies that inserting a duplicate of the first stream + !> added to an MPAS stream list results in the correct duplicate error + !> code when the duplicate is not inserted immediately after the original. + !> It does so by inserting two unique streams into the list, then attempting + !> to insert the first stream again. This confirms that duplicate detection + !> works for non-adjacent duplicates in insertion order. + !> + !> \param err The error code that indicates the result of the test. + !-------------------------------------------------------------------------------------- + subroutine mpas_test_insert_non_adjacent_duplicate(err) + integer, intent(out) :: err + type(MPAS_stream_list_type), pointer :: list + type(MPAS_stream_list_type), pointer :: s1, s2 + integer :: ierr + + err = 0 + call MPAS_stream_list_create(list) + + allocate(s1) + s1%name = 'stream1' + allocate(s2) + s2%name = 'stream2' + + call MPAS_stream_list_insert(list, s1, ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + + call MPAS_stream_list_insert(list, s2, ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + + call MPAS_stream_list_insert(list, s1, ierr) + if (ierr /= MPAS_STREAM_LIST_DUPLICATE) then + err = err + 1 + end if + if (MPAS_stream_list_length(list) /= 2) then + err = err + 1 + end if + ! Verify that inserting s1 again does not break the linkage bewtween s1 and s2 + if (.not. associated(s1%next)) then + err = err + 1 + end if + + call MPAS_stream_list_destroy(list) + end subroutine mpas_test_insert_non_adjacent_duplicate + + !************************************************************************************** + ! Subroutine mpas_test_remove_from_empty_list + ! + !> \brief Test attempting to remove a stream from an empty list, expect error. + !> + !> \details This subroutine tests the behavior of attempting to remove a stream + !> from an empty list. It ensures that the correct error + !> is returned when the stream is not found. + !> + !> \param err The error code that indicates the result of the test. + ! + !-------------------------------------------------------------------------------------- + subroutine mpas_test_remove_from_empty_list(err) + integer, intent(out) :: err + type(MPAS_stream_list_type), pointer :: list, removed + integer :: ierr + + err = 0 + + call MPAS_stream_list_create(list) + + call MPAS_stream_list_remove(list, 'stream1', removed, ierr) + if (ierr /= MPAS_STREAM_LIST_NOT_FOUND) then + err = err + 1 + end if + if (associated(removed)) then + err = err + 1 + end if + call MPAS_stream_list_destroy(list) + end subroutine mpas_test_remove_from_empty_list + + !************************************************************************************** + ! Subroutine mpas_test_remove_not_found + ! + !> \brief Attempt to remove a stream not in a non-empty list; expect NOT_FOUND. + !> + !> \details This subroutine populates the list with a couple of streams, then + !> attempts to remove a stream name that does not exist. It verifies that + !> MPAS_STREAM_LIST_NOT_FOUND is returned and that no node is returned. + !> + !> \param err The error code that indicates the result of the test. + !> + !-------------------------------------------------------------------------------------- + subroutine mpas_test_remove_not_found(err) + integer, intent(out) :: err + type(MPAS_stream_list_type), pointer :: list, removed + type(MPAS_stream_list_type), pointer :: s1, s2 + integer :: ierr + + err = 0 + + allocate(s1) + s1%name = 'stream1' + allocate(s2) + s2%name = 'stream2' + + call MPAS_stream_list_create(list) + + call MPAS_stream_list_insert(list, s1, ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + + call MPAS_stream_list_insert(list, s2, ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + + call MPAS_stream_list_remove(list, 'stream3', removed, ierr) + if (ierr /= MPAS_STREAM_LIST_NOT_FOUND) then + err = err + 1 + end if + if (associated(removed)) then + err = err + 1 + end if + + call MPAS_stream_list_destroy(list) + end subroutine mpas_test_remove_not_found + + !************************************************************************************** + ! Subroutine mpas_test_list_length + ! + !> \brief Test the length of the stream list after inserting multiple streams. + !> + !> \details This subroutine tests that the length of an MPAS stream list is correctly + !> updated after multiple streams are inserted. It verifies that the length + !> matches the expected value. + !> + !> \param err The error code that indicates the result of the test. + ! + !-------------------------------------------------------------------------------------- + subroutine mpas_test_list_length(err) + integer, intent(out) :: err + type(MPAS_stream_list_type), pointer :: list, s1, s2, s3 + + err = 0 + call MPAS_stream_list_create(list) + + allocate(s1) + s1%name = 'stream1' + allocate(s2) + s2%name = 'stream2' + allocate(s3) + s3%name = 'stream3' + + call MPAS_stream_list_insert(list, s1) + if (MPAS_stream_list_length(list) /= 1) then + err = err + 1 + end if + call MPAS_stream_list_insert(list, s2) + if (MPAS_stream_list_length(list) /= 2) then + err = err + 1 + end if + call MPAS_stream_list_insert(list, s3) + if (MPAS_stream_list_length(list) /= 3) then + err = err + 1 + end if + + call MPAS_stream_list_destroy(list) + end subroutine mpas_test_list_length + + !************************************************************************************** + ! Subroutine mpas_test_query_partial_match + ! + !> \brief Test querying for a partial stream name match, ensuring no match is found. + !> + !> \details This subroutine tests the querying of a stream list for a partial match + !> of a stream's name. It verifies that no match is found for a partial + !> name match. + !> + !> \param err The error code that indicates the result of the test. + ! + !-------------------------------------------------------------------------------------- + subroutine mpas_test_query_partial_match(err) + integer, intent(out) :: err + type(MPAS_stream_list_type), pointer :: list, stream, found + logical :: matched + integer :: ierr + + err = 0 + call MPAS_stream_list_create(list) + allocate(stream) + stream%name = 'stream1' + nullify(found) + + call MPAS_stream_list_insert(list, stream) + + matched = MPAS_stream_list_query(list, 'stream', found, ierr) + + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + if (matched .or. associated(found)) then + err = err + 1 + end if + + call MPAS_stream_list_destroy(list) + end subroutine mpas_test_query_partial_match + + !************************************************************************************** + ! Subroutine mpas_test_insert_duplicate_at_begin + ! + !> \brief Test inserting a duplicate stream at the beginning of the list. + !> + !> \details This subroutine tests the insertion of a duplicate stream at the + !> beginning of an MPAS stream list. It ensures that the correct error + !> is returned when attempting to insert a duplicate stream. + !> + !> \param err The error code that indicates the result of the test. + ! + !-------------------------------------------------------------------------------------- + subroutine mpas_test_insert_duplicate_at_begin(err) + integer, intent(out) :: err + type(MPAS_stream_list_type), pointer :: list + type(MPAS_stream_list_type), pointer :: s1 + integer :: ierr + + err = 0 + call MPAS_stream_list_create(list) + + allocate(s1) + s1%name = 'stream1' + + call MPAS_stream_list_insert(list, s1, ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + + call MPAS_stream_list_insert(list, s1, ierr) + if (ierr /= MPAS_STREAM_LIST_DUPLICATE) then + err = err + 1 + end if + if (MPAS_stream_list_length(list) /= 1) then + err = err + 1 + end if + + call MPAS_stream_list_destroy(list) + end subroutine mpas_test_insert_duplicate_at_begin + + !************************************************************************************** + ! Subroutine mpas_test_insert_duplicate_at_end + ! + !> \brief Test inserting a duplicate stream at the end of the list. + !> + !> \details This subroutine tests the insertion of a duplicate stream at the + !> end of an MPAS stream list. It ensures that the correct error + !> is returned when attempting to insert a duplicate stream. + !> + !> \param err The error code that indicates the result of the test. + ! + !-------------------------------------------------------------------------------------- + subroutine mpas_test_insert_duplicate_at_end(err) + integer, intent(out) :: err + type(MPAS_stream_list_type), pointer :: list + type(MPAS_stream_list_type), pointer :: s1, s2 + integer :: ierr + + err = 0 + call MPAS_stream_list_create(list) + + allocate(s1) + s1%name = 'stream1' + + allocate(s2) + s2%name = 'stream2' + + call MPAS_stream_list_insert(list, s1, ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + + call MPAS_stream_list_insert(list, s2, ierr) + if (ierr /= MPAS_STREAM_LIST_NOERR) then + err = err + 1 + end if + + call MPAS_stream_list_insert(list, s2, ierr) + if (ierr /= MPAS_STREAM_LIST_DUPLICATE) then + err = err + 1 + end if + if (MPAS_stream_list_length(list) /= 2) then + err = err + 1 + end if + + call MPAS_stream_list_destroy(list) + end subroutine mpas_test_insert_duplicate_at_end + + !************************************************************************************** + ! Subroutine mpas_test_stream_list + ! + !> \brief Core test suite for MPAS stream list routines. + !> + !> \details This subroutine runs all the test cases for the MPAS stream list + !> routines, including tests for stream creation, insertion, querying, + !> removal, and checking for duplicate entries. Each test case is executed + !> and its result is logged with a success or failure message. + !> + !> \param err The error code that indicates the result of the test. It accumulates + !> errors from all individual test cases. + ! + !-------------------------------------------------------------------------------------- + subroutine mpas_test_stream_list(err) + integer, intent(out) :: err + integer :: test_err + + err = 0 + + call mpas_log_write('Testing MPAS stream list routines:') + + ! Test stream list creation and verify initialization. + call mpas_test_create_list(test_err) + if (test_err == 0) then + call mpas_log_write(' mpas_test_create_list: SUCCESS') + else + err = err + test_err + call mpas_log_write(' mpas_test_create_list: FAILURE') + end if + + ! Test inserting a single stream into the list and verify correct insertion. + call mpas_test_insert_single(test_err) + if (test_err == 0) then + call mpas_log_write(' mpas_test_insert_single: SUCCESS') + else + err = err + test_err + call mpas_log_write(' mpas_test_insert_single: FAILURE') + end if + + ! Test querying for an exact stream match and ensure correct stream is found. + call mpas_test_query_exact_match(test_err) + if (test_err == 0) then + call mpas_log_write(' mpas_test_query_exact_match: SUCCESS') + else + err = err + test_err + call mpas_log_write(' mpas_test_query_exact_match: FAILURE') + end if + + ! Test removing streams at beginning, middle, and end of a list. + call mpas_test_remove_existing_streams(test_err) + if (test_err == 0) then + call mpas_log_write(' mpas_test_remove_existing_streams: SUCCESS') + else + err = err + test_err + call mpas_log_write(' mpas_test_remove_existing_streams: FAILURE') + end if + + ! Test inserting a non-adjacent duplicate of the first stream added. + call mpas_test_insert_non_adjacent_duplicate(test_err) + if (test_err == 0) then + call mpas_log_write(' mpas_test_insert_non_adjacent_duplicate: SUCCESS') + else + err = err + test_err + call mpas_log_write(' mpas_test_insert_non_adjacent_duplicate: FAILURE') + end if + + ! Test attempting to remove a non-existent stream from an empty list, expect error. + call mpas_test_remove_from_empty_list(test_err) + if (test_err == 0) then + call mpas_log_write(' mpas_test_remove_from_empty_list: SUCCESS') + else + err = err + test_err + call mpas_log_write(' mpas_test_remove_from_empty_list: FAILURE') + end if + + ! Test attempting to remove a stream not found in the list, expect error. + call mpas_test_remove_not_found(test_err) + if (test_err == 0) then + call mpas_log_write(' mpas_test_remove_not_found: SUCCESS') + else + err = err + test_err + call mpas_log_write(' mpas_test_remove_not_found: FAILURE') + end if + + ! Test the length of the stream list after inserting multiple streams. + call mpas_test_list_length(test_err) + if (test_err == 0) then + call mpas_log_write(' mpas_test_list_length: SUCCESS') + else + err = err + test_err + call mpas_log_write(' mpas_test_list_length: FAILURE') + end if + + ! Test querying for a partial stream name match, ensuring no match is found. + call mpas_test_query_partial_match(test_err) + if (test_err == 0) then + call mpas_log_write(' mpas_test_query_partial_match: SUCCESS') + else + err = err + test_err + call mpas_log_write(' mpas_test_query_partial_match: FAILURE') + end if + + ! Test inserting a duplicate stream at the beginning of the list. + call mpas_test_insert_duplicate_at_begin(test_err) + if (test_err == 0) then + call mpas_log_write(' mpas_test_insert_duplicate_at_begin: SUCCESS') + else + err = err + test_err + call mpas_log_write(' mpas_test_insert_duplicate_at_begin: FAILURE') + end if + + ! Test inserting a duplicate stream at the end of the list. + call mpas_test_insert_duplicate_at_end(test_err) + if (test_err == 0) then + call mpas_log_write(' mpas_test_insert_duplicate_at_end: SUCCESS') + else + err = err + test_err + call mpas_log_write(' mpas_test_insert_duplicate_at_end: FAILURE') + end if + end subroutine mpas_test_stream_list + +end module mpas_test_core_stream_list From b16dd8b0ff156cc0cfaf2298feb5558caf3c6479 Mon Sep 17 00:00:00 2001 From: Andy Stokely Date: Fri, 15 Aug 2025 09:50:29 -0600 Subject: [PATCH 014/214] Fix bug allowing adjacent duplicate streams in mpas_stream_list insert The original code allowed adjacent duplicate streams to be inserted into the list, which caused incorrect behavior when adding a duplicate stream next to an existing one. The bug was fixed by updating the insertion logic to properly reject adjacent duplicate streams. The new code checks for duplicates during insertion and prevents adding the stream if it is already in the list, even if adjacent. The mpas_test_insert_duplicate_at_begin and mpas_test_insert_duplicate_at_end tests in the mpas_stream_list test suite confirm that these changes fix the bug. --- src/framework/mpas_stream_list.F | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/framework/mpas_stream_list.F b/src/framework/mpas_stream_list.F index b3bce7d956..60a80cd5de 100644 --- a/src/framework/mpas_stream_list.F +++ b/src/framework/mpas_stream_list.F @@ -113,20 +113,22 @@ subroutine MPAS_stream_list_insert(list, stream, ierr) !{{{ if (present(ierr)) ierr = MPAS_STREAM_LIST_NOERR nullify(stream % next) - if (.not. associated(list % head)) then list % head => stream else node => list % head - do while (associated(node % next)) + do while (associated(node)) if (node % name == stream % name) then if (present(ierr)) ierr = MPAS_STREAM_LIST_DUPLICATE LIST_ERROR_WRITE('Found duplicate item '//trim(stream % name)//' in list.') return end if + if (.not. associated(node % next)) then + node % next => stream + exit + end if node => node % next end do - node % next => stream end if list % nItems = list % nItems + 1 From 3f9ead8a3d7cfc4dcdfdd6b314ad3febd40c31b6 Mon Sep 17 00:00:00 2001 From: Andy Stokely Date: Fri, 15 Aug 2025 09:50:58 -0600 Subject: [PATCH 015/214] Fix mpas_stream_list_insert bug unlinking head on duplicate insert Fix bug in mpas_stream_list_insert that could unlink the head node when a duplicate stream was inserted. Moved nullify(stream % next) calls into the relevant conditional blocks to ensure new streams are only linked after passing duplicate checks. Prevents inadvertent modification of the list when duplicate insertions occur. --- src/framework/mpas_stream_list.F | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/framework/mpas_stream_list.F b/src/framework/mpas_stream_list.F index 60a80cd5de..293fbb67ed 100644 --- a/src/framework/mpas_stream_list.F +++ b/src/framework/mpas_stream_list.F @@ -112,9 +112,9 @@ subroutine MPAS_stream_list_insert(list, stream, ierr) !{{{ if (present(ierr)) ierr = MPAS_STREAM_LIST_NOERR - nullify(stream % next) if (.not. associated(list % head)) then list % head => stream + nullify(stream % next) else node => list % head do while (associated(node)) @@ -125,6 +125,7 @@ subroutine MPAS_stream_list_insert(list, stream, ierr) !{{{ end if if (.not. associated(node % next)) then node % next => stream + nullify(stream % next) exit end if node => node % next From 9b9e5a5c805782432fe1c4f6fac6e015639dacdb Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 26 Aug 2025 13:05:16 -0600 Subject: [PATCH 016/214] Remove 'pointer' attribute from 'inlist' argument of mpas_dmpar_scatter_ints The 'pointer' attribute is unnecessary for the 'inlist' argument, and requiring the inlist argument to be a pointer precluded the use of mpas_dmpar_scatter_ints for arrays that are not pointers, e.g., allocatable arrays or array constructors. Additionally, since the inlist argument is used only as the first argument to MPI_Scatterv (i.e., as the 'sendbuf' argument of MPI_Scatterv), it can be declared as an intent(in) in the mpas_dmpar_scatter_ints routine. The changes in this commit have also been found to resolve runtime errors occurring with certain compiler and MPI library combinations, specifically, nvfortran and OpenMPI 5.x. --- src/framework/mpas_dmpar.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/mpas_dmpar.F b/src/framework/mpas_dmpar.F index 490687d095..e7504d97d6 100644 --- a/src/framework/mpas_dmpar.F +++ b/src/framework/mpas_dmpar.F @@ -1378,7 +1378,7 @@ subroutine mpas_dmpar_scatter_ints(dminfo, nprocs, noutlist, displs, counts, inl integer, intent(in) :: noutlist !< Input: Number integers to receive integer, dimension(nprocs), intent(in) :: displs !< Input: Displacement in sending array integer, dimension(nprocs), intent(in) :: counts !< Input: Number of integers to distribute - integer, dimension(:), pointer :: inlist !< Input: List of integers to send + integer, dimension(:), intent(in) :: inlist !< Input: List of integers to send integer, dimension(noutlist), intent(inout) :: outlist !< Output: List of received integers #ifdef _MPI From d635aed972f498545ce6723c7b9eb2adfa437baa Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 30 Sep 2025 14:54:23 -0600 Subject: [PATCH 017/214] Variable epssm(zeta) introduction: epssm is an offcentering coefficient for the vertically (column-wise) semi-implicit acoustic/gravity-wave integration. Presently the coefficent is a single constant. We now allow this coefficient to vary with model and interface levels as a function of height zeta between two values with a transition layer between the two. This commit, to the Registry only, adds namelist control variables for specifying the lower and upper values of epssm and the lower and upper heights of the transition region for these values. The commit also includes Registry-defined arrays storing the values (1 +- epssm(z))/2 at the levels and interfaces needed in the solution procedure. --- src/core_atmosphere/Registry.xml | 37 ++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 4281c40bba..fc599be2be 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -292,6 +292,27 @@ units="-" description="Number of layers in which to apply Rayleigh damping on horizontal velocity at top of model; damping linearly ramps to zero by layer number from the top" possible_values="Positive integer values"/> + + + + + + + + + @@ -495,6 +516,10 @@ + + + + #ifdef MPAS_CAM_DYCORE @@ -1484,6 +1509,18 @@ + + + + + + + + From 14ae8f8a37cfd72202e0502bd68c038868bf891e Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Wed, 1 Oct 2025 13:48:53 -0600 Subject: [PATCH 018/214] Variable epssm(zeta) introduction, step (2): Added code into mpas_atm_core.F to initialize the Registry-defined arrays storing the values (1 +- epssm(z))/2 at the levels and interfaces needed in the solution procedure. The initialization occurs at model integration start up. The vertically varying epssm is NOT active at this point; the simulation still uses the constant value from config_epssm. --- src/core_atmosphere/mpas_atm_core.F | 72 +++++++++++++++++++++++++++++ 1 file changed, 72 insertions(+) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index f7d04a1f0c..03cc02d8f6 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -1253,6 +1253,11 @@ subroutine atm_compute_damping_coefs(mesh, configs) real (kind=RKIND), dimension(:), pointer :: meshDensity real (kind=RKIND) :: dx_scale_power + real (kind=RKIND), dimension(:), pointer :: rdzw, etp, etm, ewp, ewm + real (kind=RKIND), pointer :: max_coeff, min_coeff, transition_lower_bound, transition_upper_bound + real (kind=RKIND) :: transition_width + real (kind=RKIND), allocatable, dimension(:) :: height_u_levels, epssm_coeff_u, height_w_levels, epssm_coeff_w + m1 = -1.0 pii = acos(m1) @@ -1279,6 +1284,73 @@ subroutine atm_compute_damping_coefs(mesh, configs) end do end do + call mpas_pool_get_array(mesh, 'rdzw', rdzw) + call mpas_pool_get_array(mesh, 'etp', etp) + call mpas_pool_get_array(mesh, 'etm', etm) + call mpas_pool_get_array(mesh, 'ewp', ewp) + call mpas_pool_get_array(mesh, 'ewm', ewm) + call mpas_pool_get_config(configs, 'config_epssm_minimum', min_coeff) + call mpas_pool_get_config(configs, 'config_epssm_maximum', max_coeff) + call mpas_pool_get_config(configs, 'config_epssm_transition_bottom_z', transition_lower_bound) + call mpas_pool_get_config(configs, 'config_epssm_transition_top_z', transition_upper_bound) + + allocate(height_u_levels(nVertLevels)) + allocate(epssm_coeff_u(nVertLevels)) + allocate(height_w_levels(nVertLevels+1)) + allocate(epssm_coeff_w(nVertLevels+1)) + + transition_width = transition_upper_bound - transition_lower_bound + +! initialization for heights of coordinate at u and w levels +! These are the heights of the computational coordinate zeta + + height_w_levels(:) = 0.0_RKIND + do k =1, nVertLevels + height_w_levels(k+1) = height_w_levels(k) + 1.0_RKIND/rdzw(k) + height_u_levels(k) = 0.5*(height_w_levels(k+1) + height_w_levels(k)) + enddo + +! Height dependent values of epssm; profiles stored in etp, etm, ewp, and ewm, + + call mpas_log_write(' setting epssm coefficients ') + call mpas_log_write(' minimum epssm: $r ',realArgs=(/min_coeff/)) + call mpas_log_write(' maximum epssm: $r ',realArgs=(/max_coeff/)) + call mpas_log_write(' transition lower bound (m): $r ',realArgs=(/transition_lower_bound/)) + call mpas_log_write(' transition upper bound (m): $r ',realArgs=(/transition_upper_bound/)) + call mpas_log_write(' ') + + do k = 1,nVertLevels + if(height_u_levels(k).le.transition_lower_bound) then + epssm_coeff_u(k) = min_coeff + else if(height_u_levels(k).ge.transition_upper_bound) then + epssm_coeff_u(k) = max_coeff + else + z = (height_u_levels(k)-transition_lower_bound)/transition_width + epssm_coeff_u(k) = min_coeff + sin(0.5_RKIND*pii*z)**2*(max_coeff-min_coeff) + end if + etp(k) = 0.5*(1.0 + epssm_coeff_u(k)) + etm(k) = 0.5*(1.0 - epssm_coeff_u(k)) + call mpas_log_write('k, etp, etm $i $r $r ',intArgs=(/k/),realArgs=(/etp(k),etm(k)/)) + end do + do k= 1,nVertlevels+1 + if(height_w_levels(k).le.transition_lower_bound) then + epssm_coeff_w(k) = min_coeff + else if(height_w_levels(k).ge.transition_upper_bound) then + epssm_coeff_w(k) = max_coeff + else + z = (height_w_levels(k)-transition_lower_bound)/transition_width + epssm_coeff_w(k) = min_coeff + sin(0.5_RKIND*pii*z)**2*(max_coeff-min_coeff) + end if + ewp(k) = 0.5*(1.0 + epssm_coeff_w(k)) + ewm(k) = 0.5*(1.0 - epssm_coeff_w(k)) + call mpas_log_write('k, ewp, ewm $i $r $r ',intArgs=(/k/),realArgs=(/ewp(k),ewm(k)/)) + end do + + deallocate(height_u_levels) + deallocate(epssm_coeff_u) + deallocate(height_w_levels) + deallocate(epssm_coeff_w) + end subroutine atm_compute_damping_coefs From b1202f78731e12c36779d0f58ca7eb249bb57ee9 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Tue, 19 Aug 2025 16:15:23 -0600 Subject: [PATCH 019/214] Refactoring duplicate definitions of halo_exchange_routine This commit introduces a new include file mpas_halo_interface under src/framework in order to remove the repeated definitions of the generic interface halo_exchange_routine and replace them with an include. --- .../dynamics/mpas_atm_time_integration.F | 17 ++--------------- src/core_atmosphere/mpas_atm_core.F | 17 ++--------------- src/core_atmosphere/mpas_atm_halos.F | 17 ++--------------- .../physics/mpas_atmphys_todynamics.F | 17 ++--------------- src/framework/mpas_halo_interface.inc | 15 +++++++++++++++ 5 files changed, 23 insertions(+), 60 deletions(-) create mode 100644 src/framework/mpas_halo_interface.inc diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 4fe2faefc4..3f3d64bb7f 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -37,21 +37,8 @@ module atm_time_integration use mpas_atm_iau - ! - ! Abstract interface for routine used to communicate halos of fields - ! in a named group - ! - abstract interface - subroutine halo_exchange_routine(domain, halo_group, ierr) - - use mpas_derived_types, only : domain_type - - type (domain_type), intent(inout) :: domain - character(len=*), intent(in) :: halo_group - integer, intent(out), optional :: ierr - - end subroutine halo_exchange_routine - end interface + ! Provides definition of halo_exchange_routine +#include "mpas_halo_interface.inc" integer :: timerid, secs, u_secs diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index f7d04a1f0c..aaebf865c7 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -13,21 +13,8 @@ module atm_core use mpas_log, only : mpas_log_write, mpas_log_info use mpas_io_units, only : mpas_new_unit, mpas_release_unit - ! - ! Abstract interface for routine used to communicate halos of fields - ! in a named group - ! - abstract interface - subroutine halo_exchange_routine(domain, halo_group, ierr) - - use mpas_derived_types, only : domain_type - - type (domain_type), intent(inout) :: domain - character(len=*), intent(in) :: halo_group - integer, intent(out), optional :: ierr - - end subroutine halo_exchange_routine - end interface + ! Provides definition of halo_exchange_routine +#include "mpas_halo_interface.inc" type (MPAS_Clock_type), pointer :: clock diff --git a/src/core_atmosphere/mpas_atm_halos.F b/src/core_atmosphere/mpas_atm_halos.F index df02ee30a2..983c529673 100644 --- a/src/core_atmosphere/mpas_atm_halos.F +++ b/src/core_atmosphere/mpas_atm_halos.F @@ -10,21 +10,8 @@ module mpas_atm_halos use mpas_pool_routines use mpas_log, only : mpas_log_write, mpas_log_info - ! - ! Abstract interface for routine used to communicate halos of fields - ! in a named group - ! - abstract interface - subroutine halo_exchange_routine(domain, halo_group, ierr) - - use mpas_derived_types, only : domain_type - - type (domain_type), intent(inout) :: domain - character(len=*), intent(in) :: halo_group - integer, intent(out), optional :: ierr - - end subroutine halo_exchange_routine - end interface + ! Provides definition of halo_exchange_routine +#include "mpas_halo_interface.inc" procedure (halo_exchange_routine), pointer :: exchange_halo_group diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index 284b072851..cebf566cc4 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -41,21 +41,8 @@ module mpas_atmphys_todynamics ! number concentrations due to PBL processes. ! Laura D. Fowler (laura@ucar.edu) / 2024-05-16. -! -! Abstract interface for routine used to communicate halos of fields -! in a named group -! - abstract interface - subroutine halo_exchange_routine(domain, halo_group, ierr) - - use mpas_derived_types, only : domain_type - - type (domain_type), intent(inout) :: domain - character(len=*), intent(in) :: halo_group - integer, intent(out), optional :: ierr - - end subroutine halo_exchange_routine - end interface + ! Provides definition of halo_exchange_routine +#include "mpas_halo_interface.inc" contains diff --git a/src/framework/mpas_halo_interface.inc b/src/framework/mpas_halo_interface.inc new file mode 100644 index 0000000000..8f0934fbb0 --- /dev/null +++ b/src/framework/mpas_halo_interface.inc @@ -0,0 +1,15 @@ + ! + ! Abstract interface for routine used to communicate halos of fields + ! in a named group + ! + abstract interface + subroutine halo_exchange_routine(domain, halo_group, ierr) + + use mpas_derived_types, only : domain_type + + type (domain_type), intent(inout) :: domain + character(len=*), intent(in) :: halo_group + integer, intent(out), optional :: ierr + + end subroutine halo_exchange_routine + end interface From 097f9fedf391eaec3cf429172b2dc152019a054b Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 14 Oct 2025 11:06:28 -0600 Subject: [PATCH 020/214] Variable epssm(zeta) introduction, step (3): modified code to set the coefficients for the vertically-implicit acoustic solution to use the variable epssm formulation, and modified the acoustic step solver to use the variable epssm coefficients. This commit changes the solution at roundoff level even if a constant epssm is configured because we have changed the order of the computations in some places and we have incorporated the acoustic timestep delta tau in a different manner than in the previous formulation. --- .../dynamics/mpas_atm_time_integration.F | 157 +++++++++++++----- 1 file changed, 120 insertions(+), 37 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 4fe2faefc4..353c3574cc 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -2177,10 +2177,16 @@ subroutine atm_compute_vert_imp_coefs(state, mesh, diag, configs, nVertLevels, d real (kind=RKIND), pointer :: epssm - integer, pointer :: nCells, moist_start, moist_end + ! variable epssm arrays + real (kind=RKIND), dimension(:), pointer :: etp, etm, ewp, ewm + integer, pointer :: nCells, moist_start, moist_end call mpas_pool_get_config(configs, 'config_epssm', epssm) + call mpas_pool_get_array(mesh, 'etp', etp) + call mpas_pool_get_array(mesh, 'etm', etm) + call mpas_pool_get_array(mesh, 'ewp', ewp) + call mpas_pool_get_array(mesh, 'ewm', ewm) call mpas_pool_get_array(mesh, 'rdzu', rdzu) call mpas_pool_get_array(mesh, 'rdzw', rdzw) @@ -2215,6 +2221,7 @@ subroutine atm_compute_vert_imp_coefs(state, mesh, diag, configs, nVertLevels, d call atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, epssm, & zz, cqw, p, t, rb, rtb, pb, rt, cofwr, cofwz, coftz, cofwt, & a_tri, alpha_tri, gamma_tri, cofrz, rdzw, fzm, fzp, rdzu, scalars, & + etp, etm, ewp, ewm, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -2225,6 +2232,7 @@ end subroutine atm_compute_vert_imp_coefs subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, epssm, & zz, cqw, p, t, rb, rtb, pb, rt, cofwr, cofwz, coftz, cofwt, & a_tri, alpha_tri, gamma_tri, cofrz, rdzw, fzm, fzp, rdzu, scalars, & + etp, etm, ewp, ewm, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -2260,6 +2268,8 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, real (kind=RKIND), dimension(nVertLevels) :: fzm real (kind=RKIND), dimension(nVertLevels) :: fzp real (kind=RKIND), dimension(nVertLevels) :: rdzu + real (kind=RKIND), dimension(nVertLevels ) :: etp,etm + real (kind=RKIND), dimension(nVertLevels+1) :: ewp,ewm real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: scalars integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd @@ -2280,7 +2290,7 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, MPAS_ACC_TIMER_STOP('atm_compute_vert_imp_coefs_work [ACC_data_xfer]') ! set coefficients - dtseps = .5*dts*(1.+epssm) + ! dtseps = .5*dts*(1.+epssm) ! not needed for epssm_z rcv = rgas/(cp-rgas) c2 = cp*rcv @@ -2288,7 +2298,8 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, !$acc loop gang worker ! MGD bad to have all threads setting this variable? do k=1,nVertLevels - cofrz(k) = dtseps*rdzw(k) + ! cofrz(k) = dtseps*rdzw(k) + cofrz(k) = rdzw(k) ! epssm_z_change end do !$acc end parallel @@ -2299,15 +2310,21 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, !DIR$ IVDEP !$acc loop vector do k=2,nVertLevels - cofwr(k,iCell) =.5*dtseps*gravity*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) + ! cofwr(k,iCell) =.5*dtseps*gravity*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) + cofwr(k,iCell) =.5*gravity*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) ! epssm_z_change end do coftz(1,iCell) = 0.0 !DIR$ IVDEP !$acc loop vector do k=2,nVertLevels - cofwz(k,iCell) = dtseps*c2*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) & + ! cofwz(k,iCell) = dtseps*c2*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) & + ! *rdzu(k)*cqw(k,iCell)*(fzm(k)*p (k,iCell)+fzp(k)*p (k-1,iCell)) + ! coftz(k,iCell) = dtseps* (fzm(k)*t (k,iCell)+fzp(k)*t (k-1,iCell)) + + ! ! epssm_z_change + cofwz(k,iCell) = c2*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) & *rdzu(k)*cqw(k,iCell)*(fzm(k)*p (k,iCell)+fzp(k)*p (k-1,iCell)) - coftz(k,iCell) = dtseps* (fzm(k)*t (k,iCell)+fzp(k)*t (k-1,iCell)) + coftz(k,iCell) = (fzm(k)*t (k,iCell)+fzp(k)*t (k-1,iCell)) end do coftz(nVertLevels+1,iCell) = 0.0 !DIR$ IVDEP @@ -2320,9 +2337,14 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, ! end do qtotal = qtot(k,iCell) - cofwt(k,iCell) = .5*dtseps*rcv*zz(k,iCell)*gravity*rb(k,iCell)/(1.+qtotal) & + ! cofwt(k,iCell) = .5*dtseps*rcv*zz(k,iCell)*gravity*rb(k,iCell)/(1.+qtotal) & + ! *p(k,iCell)/((rtb(k,iCell)+rt(k,iCell))*pb(k,iCell)) + + ! epssm_z_change + cofwt(k,iCell) = .5*rcv*zz(k,iCell)*gravity*rb(k,iCell)/(1.+qtotal) & *p(k,iCell)/((rtb(k,iCell)+rt(k,iCell))*pb(k,iCell)) -! cofwt(k,iCell) = 0. + ! cofwt(k,iCell) = .5*rcv*zz(k,iCell)*gravity/t(k,iCell) ! zero base state option + ! cofwt(k,iCell) = 0. end do a_tri(1,iCell) = 0. ! note, this value is never used @@ -2337,21 +2359,38 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, a_tri(k,iCell) = -cofwz(k ,iCell)* coftz(k-1,iCell)*rdzw(k-1)*zz(k-1,iCell) & +cofwr(k ,iCell)* cofrz(k-1 ) & -cofwt(k-1,iCell)* coftz(k-1,iCell)*rdzw(k-1) - b_tri(k) = 1. & - +cofwz(k ,iCell)*(coftz(k ,iCell)*rdzw(k )*zz(k ,iCell) & - +coftz(k ,iCell)*rdzw(k-1)*zz(k-1,iCell)) & - -coftz(k ,iCell)*(cofwt(k ,iCell)*rdzw(k ) & - -cofwt(k-1,iCell)*rdzw(k-1)) & - +cofwr(k, iCell)*(cofrz(k )-cofrz(k-1)) + a_tri(k,iCell) = a_tri(k,iCell)*etp(k-1)*ewp(k-1) ! epssm_z_change (addition) + + ! b_tri(k) = 1. & + ! +cofwz(k ,iCell)*(coftz(k ,iCell)*rdzw(k )*zz(k ,iCell) & + ! +coftz(k ,iCell)*rdzw(k-1)*zz(k-1,iCell)) & + ! -coftz(k ,iCell)*(cofwt(k ,iCell)*rdzw(k ) & + ! -cofwt(k-1,iCell)*rdzw(k-1)) & + ! +cofwr(k, iCell)*(cofrz(k )-cofrz(k-1)) + + ! epssm_z_change + b_tri(k) = +cofwz(k ,iCell)*coftz(k,iCell)* & + ( etp(k )*rdzw(k )*zz(k ,iCell) & + +etp(k-1)*rdzw(k-1)*zz(k-1,iCell)) & + -coftz(k ,iCell)*( etp(k )*cofwt(k ,iCell)*rdzw(k ) & + -etp(k-1)*cofwt(k-1,iCell)*rdzw(k-1)) & + +cofwr(k, iCell)*(etp(k)*cofrz(k )-etp(k-1)*cofrz(k-1)) + b_tri(k) = b_tri(k)*ewp(k) + c_tri(k) = -cofwz(k ,iCell)* coftz(k+1,iCell)*rdzw(k )*zz(k ,iCell) & -cofwr(k ,iCell)* cofrz(k ) & +cofwt(k ,iCell)* coftz(k+1,iCell)*rdzw(k ) + c_tri(k) = c_tri(k)*etp(k)*ewp(k+1) ! epssm_z_change (addition) end do + c_tri(nVertLevels) = 0.0 ! epssm_z_change (addition) !MGD VECTOR DEPENDENCE !$acc loop seq do k=2,nVertLevels - alpha_tri(k,iCell) = 1./(b_tri(k)-a_tri(k,iCell)*gamma_tri(k-1,iCell)) - gamma_tri(k,iCell) = c_tri(k)*alpha_tri(k,iCell) + ! alpha_tri(k,iCell) = 1./(b_tri(k)-a_tri(k,iCell)*gamma_tri(k-1,iCell)) + ! gamma_tri(k,iCell) = c_tri(k)*alpha_tri(k,iCell) + ! epssm_z_change + alpha_tri(k,iCell) = 1./(1.0+(dts**2)*(b_tri(k)-a_tri(k,iCell)*gamma_tri(k-1,iCell))) + gamma_tri(k,iCell) = (dts**2)*c_tri(k)*alpha_tri(k,iCell) end do end do ! loop over cells @@ -2561,6 +2600,8 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, real (kind=RKIND), pointer :: cf1, cf2, cf3 + real (kind=RKIND), dimension(:), pointer :: etp, etm, ewp, ewm + integer, pointer :: nEdges, nCellsSolve call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) @@ -2570,6 +2611,11 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, call mpas_pool_get_array(mesh, 'specZoneMaskEdge', specZoneMaskEdge) call mpas_pool_get_array(mesh, 'specZoneMaskCell', specZoneMaskCell) + call mpas_pool_get_array(mesh, 'etp', etp) + call mpas_pool_get_array(mesh, 'etm', etm) + call mpas_pool_get_array(mesh, 'ewp', ewp) + call mpas_pool_get_array(mesh, 'ewm', ewm) + call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) ! call mpas_pool_get_array(state, 'theta_m', theta_m, 2) call mpas_pool_get_array(state, 'theta_m', theta_m, 1) @@ -2637,6 +2683,7 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & dts, small_step, epssm, cf1, cf2, cf3, & + etp, etm, ewp, ewm, & specZoneMaskEdge, specZoneMaskCell & ) @@ -2650,6 +2697,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & dts, small_step, epssm, cf1, cf2, cf3, & + etp, etm, ewp, ewm, & specZoneMaskEdge, specZoneMaskCell & ) @@ -2703,6 +2751,10 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart real (kind=RKIND), dimension(nVertLevels) :: fzm real (kind=RKIND), dimension(nVertLevels) :: fzp real (kind=RKIND), dimension(nVertLevels) :: rdzw + real (kind=RKIND), dimension(nVertLevels ) :: etp + real (kind=RKIND), dimension(nVertLevels ) :: etm + real (kind=RKIND), dimension(nVertLevels+1) :: ewp + real (kind=RKIND), dimension(nVertLevels+1) :: ewm real (kind=RKIND), dimension(nEdges+1) :: dcEdge real (kind=RKIND), dimension(nEdges+1) :: invDcEdge real (kind=RKIND), dimension(nCells+1) :: invAreaCell @@ -2888,31 +2940,51 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP !$acc loop vector do k=1, nVertLevels - rs(k) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) + rs(k) & - - cofrz(k)*resm*(rw_p(k+1,iCell)-rw_p(k,iCell)) - ts(k) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) + ts(k) & - - resm*rdzw(k)*( coftz(k+1,iCell)*rw_p(k+1,iCell) & - -coftz(k,iCell)*rw_p(k,iCell)) + ! rs(k) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) + rs(k) & + ! - cofrz(k)*resm*(rw_p(k+1,iCell)-rw_p(k,iCell)) + ! ts(k) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) + ts(k) & + ! - resm*rdzw(k)*( coftz(k+1,iCell)*rw_p(k+1,iCell) & + ! -coftz(k,iCell)*rw_p(k,iCell)) + + ! epssm_z change + rs(k) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) + rs(k) & + - dts*cofrz(k)*(ewm(k+1)*rw_p(k+1,iCell)-ewm(k)*rw_p(k,iCell)) + ts(k) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) + ts(k) & + - dts*rdzw(k)*( ewm(k+1)*coftz(k+1,iCell)*rw_p(k+1,iCell) & + -ewm(k )*coftz(k,iCell)*rw_p(k,iCell)) end do !DIR$ IVDEP !$acc loop vector do k=2, nVertLevels - wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0-epssm)*rw_p(k,iCell) + ! wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0-epssm)*rw_p(k,iCell) + wwavg(k,iCell) = wwavg(k,iCell) + ewm(k)*rw_p(k,iCell) ! epssm_z change end do !DIR$ IVDEP !$acc loop vector do k=2, nVertLevels - rw_p(k,iCell) = rw_p(k,iCell) + dts*tend_rw(k,iCell) & - - cofwz(k,iCell)*((zz(k ,iCell)*ts(k) & - -zz(k-1,iCell)*ts(k-1)) & - +resm*(zz(k ,iCell)*rtheta_pp(k ,iCell) & - -zz(k-1,iCell)*rtheta_pp(k-1,iCell))) & - - cofwr(k,iCell)*((rs(k)+rs(k-1)) & - +resm*(rho_pp(k,iCell)+rho_pp(k-1,iCell))) & - + cofwt(k ,iCell)*(ts(k )+resm*rtheta_pp(k ,iCell)) & - + cofwt(k-1,iCell)*(ts(k-1)+resm*rtheta_pp(k-1,iCell)) + ! rw_p(k,iCell) = rw_p(k,iCell) + dts*tend_rw(k,iCell) & + ! - cofwz(k,iCell)*((zz(k ,iCell)*ts(k) & + ! -zz(k-1,iCell)*ts(k-1)) & + ! +resm*(zz(k ,iCell)*rtheta_pp(k ,iCell) & + ! -zz(k-1,iCell)*rtheta_pp(k-1,iCell))) & + ! - cofwr(k,iCell)*((rs(k)+rs(k-1)) & + ! +resm*(rho_pp(k,iCell)+rho_pp(k-1,iCell))) & + ! + cofwt(k ,iCell)*(ts(k )+resm*rtheta_pp(k ,iCell)) & + ! + cofwt(k-1,iCell)*(ts(k-1)+resm*rtheta_pp(k-1,iCell)) + + ! epssm_z change + rw_p(k,iCell) = rw_p(k,iCell) + dts*(tend_rw(k,iCell) & + - cofwz(k,iCell)*(( etp(k )*zz(k ,iCell)*ts(k) & + -etp(k-1)*zz(k-1,iCell)*ts(k-1)) & + + ( etm(k )*zz(k ,iCell)*rtheta_pp(k ,iCell) & + -etm(k-1)*zz(k-1,iCell)*rtheta_pp(k-1,iCell))) & + - cofwr(k,iCell)*((etp(k)*rs(k)+etp(k-1)*rs(k-1)) & + +( etm(k )*rho_pp(k ,iCell) & + +etm(k-1)*rho_pp(k-1,iCell))) & + + cofwt(k ,iCell)*(etp(k )*ts(k )+etm(k )*rtheta_pp(k ,iCell)) & + + cofwt(k-1,iCell)*(etp(k-1)*ts(k-1)+etm(k-1)*rtheta_pp(k-1,iCell))) end do ! tridiagonal solve sweeping up and then down the column @@ -2920,7 +2992,10 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !MGD VECTOR DEPENDENCE !$acc loop seq do k=2,nVertLevels - rw_p(k,iCell) = (rw_p(k,iCell)-a_tri(k,iCell)*rw_p(k-1,iCell))*alpha_tri(k,iCell) + ! rw_p(k,iCell) = (rw_p(k,iCell)-a_tri(k,iCell)*rw_p(k-1,iCell))*alpha_tri(k,iCell) + + ! epssm_z change + rw_p(k,iCell) = (rw_p(k,iCell)-(dts**2)*a_tri(k,iCell)*rw_p(k-1,iCell))*alpha_tri(k,iCell) end do !MGD VECTOR DEPENDENCE @@ -2945,7 +3020,8 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP !$acc loop vector do k=2,nVertLevels - wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) + ! wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) + wwAvg(k,iCell) = wwAvg(k,iCell) + ewp(k)*rw_p(k,iCell) ! epssm_z change end do ! update rho_pp and theta_pp given updated rw_p @@ -2953,9 +3029,15 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP !$acc loop vector do k=1,nVertLevels - rho_pp(k,iCell) = rs(k) - cofrz(k) *(rw_p(k+1,iCell)-rw_p(k ,iCell)) - rtheta_pp(k,iCell) = ts(k) - rdzw(k)*(coftz(k+1,iCell)*rw_p(k+1,iCell) & - -coftz(k ,iCell)*rw_p(k ,iCell)) + ! rho_pp(k,iCell) = rs(k) - cofrz(k) *(rw_p(k+1,iCell)-rw_p(k ,iCell)) + ! rtheta_pp(k,iCell) = ts(k) - rdzw(k)*(coftz(k+1,iCell)*rw_p(k+1,iCell) & + ! -coftz(k ,iCell)*rw_p(k ,iCell)) + ! + ! epssm_z change + rho_pp(k,iCell) = rs(k) - dts*cofrz(k) *( ewp(k+1)*rw_p(k+1,iCell) & + -ewp(k )*rw_p(k ,iCell)) + rtheta_pp(k,iCell) = ts(k) - dts*rdzw(k)*( ewp(k+1)*coftz(k+1,iCell)*rw_p(k+1,iCell) & + -ewp(k )*coftz(k ,iCell)*rw_p(k ,iCell)) end do else ! specifed zone in regional_MPAS @@ -2965,7 +3047,8 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart rho_pp(k,iCell) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) rtheta_pp(k,iCell) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) rw_p(k,iCell) = rw_p(k,iCell) + dts*tend_rw(k,iCell) - wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) + ! wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) + wwAvg(k,iCell) = wwAvg(k,iCell) + ewp(k)*rw_p(k,iCell) ! epssm_z change end do end if From 51d8389060519b1e97472d34239515b3ab549963 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 14 Oct 2025 11:31:53 -0600 Subject: [PATCH 021/214] Changed the default values of the variable_epssm configuration variables to the intended general configuration for real-data cases. --- src/core_atmosphere/Registry.xml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index fc599be2be..f5d74ef379 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -298,17 +298,17 @@ description="Value of epssm below transition zone" possible_values="Positive real values between 0 and 1"/> - - - From 42b5d79aabc81666971da086533a8066d5c1fe24 Mon Sep 17 00:00:00 2001 From: Jim Wittig Date: Wed, 22 Oct 2025 15:04:44 -0600 Subject: [PATCH 022/214] Add src/framework to list of include directories when building with CMake In PR 1359 a new file, src/framework/mpas_halo_interface.inc is included by several files in the src/core_atmosphere tree. Therefore compiling core_atmosphere now requires including src/framework. To accomplish that the CMakeLists.txt file for src/framework now exports its source directory as an interface include directory. This adds that directory to the compilation include path for any target which links against framework. --- src/framework/CMakeLists.txt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/framework/CMakeLists.txt b/src/framework/CMakeLists.txt index 8273e8e407..dbaccf7a13 100644 --- a/src/framework/CMakeLists.txt +++ b/src/framework/CMakeLists.txt @@ -69,6 +69,9 @@ if (MPAS_PROFILE) list(APPEND FRAMEWORK_LINK_LIBRARIES GPTL::GPTL) endif () target_link_libraries(framework PUBLIC ${FRAMEWORK_LINK_LIBRARIES}) +target_include_directories(framework INTERFACE + $ + $) install(TARGETS framework EXPORT ${PROJECT_NAME}Exports ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} From 80db0ac32afeea0ae1572284dffdea4eeab03303 Mon Sep 17 00:00:00 2001 From: Andy Stokely Date: Sat, 25 Oct 2025 17:25:13 -0600 Subject: [PATCH 023/214] Nullify pointer arguments in all pool accessor routines All pool accessor routines now nullify their pointer arguments at the start of each subroutine. This includes mpas_pool_get_config_* (real, int, char, and logical), mpas_pool_get_subpool, and mpas_pool_get_package. Nullifying these pointers ensures they are in a defined state before assignment, allowing callers to safely use associated() checks to determine whether a configuration key, subpool, or package exists in the pool. This change also makes the behavior of these accessor subroutines consistent with the existing behavior of mpas_pool_get_field_*, mpas_pool_get_array_*, and mpas_pool_get_dimension_*. No other logic or behavior was changed. --- src/framework/mpas_pool_routines.F | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/framework/mpas_pool_routines.F b/src/framework/mpas_pool_routines.F index aab1818c30..80339e3112 100644 --- a/src/framework/mpas_pool_routines.F +++ b/src/framework/mpas_pool_routines.F @@ -4770,6 +4770,8 @@ subroutine mpas_pool_get_config_real(inPool, key, value, record)!{{{ type (mpas_pool_data_type), pointer :: mem + nullify(value) + if ( present(record) ) then call mpas_pool_get_subpool(inPool, record, recordPool) mem => pool_get_member(recordPool, key, MPAS_POOL_CONFIG) @@ -4812,6 +4814,8 @@ subroutine mpas_pool_get_config_int(inPool, key, value, record)!{{{ type (mpas_pool_data_type), pointer :: mem + nullify(value) + if ( present(record) ) then call mpas_pool_get_subpool(inPool, record, recordPool) mem => pool_get_member(recordPool, key, MPAS_POOL_CONFIG) @@ -4854,6 +4858,8 @@ subroutine mpas_pool_get_config_char(inPool, key, value, record)!{{{ type (mpas_pool_data_type), pointer :: mem + nullify(value) + if ( present(record) ) then call mpas_pool_get_subpool(inPool, record, recordPool) mem => pool_get_member(recordPool, key, MPAS_POOL_CONFIG) @@ -4897,6 +4903,8 @@ subroutine mpas_pool_get_config_logical(inPool, key, value, record)!{{{ type (mpas_pool_data_type), pointer :: mem + nullify(value) + if ( present(record) ) then call mpas_pool_get_subpool(inPool, record, recordPool) mem => pool_get_member(recordPool, key, MPAS_POOL_CONFIG) @@ -5149,6 +5157,7 @@ subroutine mpas_pool_get_subpool(inPool, key, subPool)!{{{ type (mpas_pool_data_type), pointer :: mem + nullify(subPool) mem => pool_get_member(inPool, key, MPAS_POOL_SUBPOOL) @@ -5228,6 +5237,7 @@ subroutine mpas_pool_get_package(inPool, key, package)!{{{ type (mpas_pool_data_type), pointer :: mem + nullify(package) mem => pool_get_member(inPool, key, MPAS_POOL_PACKAGE) From 0b3d40a655dd90bec11d010d45215080fa35a084 Mon Sep 17 00:00:00 2001 From: dwfncar Date: Fri, 22 Aug 2025 14:35:18 -0600 Subject: [PATCH 024/214] Chemistry hooks integrated with MUSICA stubs and guarded build flags. The chemistry infrastructure now lives in a dedicated `core_atmosphere/chemistry` hierarchy, which includes a `musica` subdirectory and its Makefiles. Within this structure we added the MUSICA MICM-facing modules `mpas_atm_chemistry.F` and `musica/mpas_musica.F`, providing the stubs that expose the chemistry hooks needed by the atmospheric core. `mpas_atm_chemistry.F` now establishes the MICM configuration path, performs initialization at the end of `atm_core_init`, advances the chemistry tendencies through `chemistry_step` inside `atm_do_timestep`, and finalizes the subsystem during shutdown. These calls are wrapped in `#ifdef DO_CHEMISTRY` and coordinated with the new `#ifdef MPAS_USE_MUSICA` guards so that chemistry support is compiled and executed only when explicitly enabled. The interface routines also accept the MPAS pool, configuration, and dimension objects, including forwarding `nVertLevels` to `musica_init`. Inside `musica/mpas_musica.F`, the initialization sequence now queries the MICM version via `get_micm_version`, records both the version and the number of grid cells in the log, and honors the compile-time flag to keep MUSICA linkage optional. Matching updates to the atmospheric and chemistry Makefiles add the new sources, apply the `CHEMISTRY` flags to the compiler command line, and ensure the MUSICA library is only built and linked when `MPAS_USE_MUSICA` is defined. --- src/core_atmosphere/Makefile | 29 +++- src/core_atmosphere/chemistry/Makefile | 47 +++++ .../chemistry/mpas_atm_chemistry.F | 126 ++++++++++++++ src/core_atmosphere/chemistry/musica/Makefile | 31 ++++ .../chemistry/musica/mpas_musica.F | 161 ++++++++++++++++++ src/core_atmosphere/mpas_atm_core.F | 30 +++- 6 files changed, 414 insertions(+), 10 deletions(-) create mode 100644 src/core_atmosphere/chemistry/Makefile create mode 100644 src/core_atmosphere/chemistry/mpas_atm_chemistry.F create mode 100644 src/core_atmosphere/chemistry/musica/Makefile create mode 100644 src/core_atmosphere/chemistry/musica/mpas_musica.F diff --git a/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index 966027bc77..9c3a58686e 100644 --- a/src/core_atmosphere/Makefile +++ b/src/core_atmosphere/Makefile @@ -2,12 +2,13 @@ # # To build a dycore-only MPAS-Atmosphere model, comment-out or delete -# the definition of PHYSICS, below +# the definition of PHYSICS and CHEMISTRY, below # -# If MPAS_CAM_DYCORE is found in CPPFLAGS, PHYSICS will become undefined automatically +# If MPAS_CAM_DYCORE is found in CPPFLAGS, PHYSICS and CHEMISTRY will become undefined automatically # ifeq ($(findstring MPAS_CAM_DYCORE,$(CPPFLAGS)),) PHYSICS = -DDO_PHYSICS + CHEMISTRY = -DDO_CHEMISTRY endif ifdef PHYSICS @@ -15,16 +16,21 @@ ifdef PHYSICS PHYS_OBJS = libphys/*.o endif +ifdef CHEMISTRY + CHEMCORE = chemcore + CHEM_OBJS = libchem/*.o +endif + OBJS = mpas_atm_core.o \ mpas_atm_core_interface.o \ mpas_atm_dimensions.o \ mpas_atm_threading.o \ mpas_atm_halos.o -all: $(PHYSCORE) dycore diagcore atmcore utilities +all: $(PHYSCORE) $(CHEMCORE) dycore diagcore atmcore utilities core_reg: - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $(PHYSICS) Registry.xml > Registry_processed.xml + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $(PHYSICS) $(CHEMISTRY) Registry.xml > Registry_processed.xml core_input_gen: if [ ! -e default_inputs ]; then mkdir default_inputs; fi @@ -47,7 +53,11 @@ physcore: mpas_atm_dimensions.o ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_wrf/files/*DATA* .) ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_noahmp/parameters/*TBL .) -dycore: mpas_atm_dimensions.o $(PHYSCORE) +chemcore: + ( cd chemistry; $(MAKE) all CHEMISTRY="$(CHEMISTRY)" ) + ( mkdir libchem; cd libchem; ar -x ../chemistry/libchem.a ) + +dycore: mpas_atm_dimensions.o $(PHYSCORE) $(CHEMCORE) ( cd dynamics; $(MAKE) all PHYSICS="$(PHYSICS)" ) diagcore: $(PHYSCORE) dycore @@ -57,7 +67,7 @@ utilities: $(PHYSCORE) ( cd utils; $(MAKE) all PHYSICS="$(PHYSICS)" ) atmcore: $(PHYSCORE) dycore diagcore $(OBJS) - ar -ru libdycore.a $(OBJS) dynamics/*.o $(PHYS_OBJS) diagnostics/*.o + ar -ru libdycore.a $(OBJS) dynamics/*.o $(PHYS_OBJS) $(CHEM_OBJS) diagnostics/*.o mpas_atm_core_interface.o: mpas_atm_core.o @@ -67,6 +77,7 @@ mpas_atm_dimensions.o: clean: ( cd physics; $(MAKE) clean ) + ( cd chemistry; $(MAKE) clean ) ( cd dynamics; $(MAKE) clean ) ( cd diagnostics; $(MAKE) clean ) ( cd utils; $(MAKE) clean ) @@ -83,8 +94,8 @@ clean: .F.o: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" - $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) -I./inc $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I./physics/physics_mmm -I./physics/physics_noaa/UGWP -I../external/esmf_time_f90 + $(CPP) $(CPPFLAGS) $(PHYSICS) $(CHEMISTRY) $(CPPINCLUDES) -I./inc $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I./physics/physics_mmm -I./physics/physics_noaa/UGWP -I../external/esmf_time_f90 -I./chemistry else - $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./inc -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I./physics/physics_mmm -I./physics/physics_noaa/UGWP -I../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(PHYSICS) $(CHEMISTRY) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./inc -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I./physics/physics_mmm -I./physics/physics_noaa/UGWP -I../external/esmf_time_f90 -I./chemistry endif diff --git a/src/core_atmosphere/chemistry/Makefile b/src/core_atmosphere/chemistry/Makefile new file mode 100644 index 0000000000..5bd4480b7d --- /dev/null +++ b/src/core_atmosphere/chemistry/Makefile @@ -0,0 +1,47 @@ +.SUFFIXES: .F .o + +all: +ifeq ($(MUSICA),true) + echo "****** building MUSICA ******" + $(MAKE) core_mpas_musica core_chemistry +else + echo "****** not building MUSICA ******" + $(MAKE) core_chemistry +endif + +dummy: + echo "****** compiling chemistry ******" + +OBJS = \ + mpas_atm_chemistry.o + +ifeq ($(MUSICA),true) +core_mpas_musica: + echo "****** building CORE MPAS MUSICA ******" + (cd musica; $(MAKE) all) +endif + +core_chemistry: $(if $(filter true,$(MUSICA)),core_mpas_musica) + ($(MAKE) chem_interface) + ar -ru libchem.a $(OBJS) +ifeq ($(MUSICA),true) + ($(MAKE) -C ./musica mpas_musica_lib) +endif + +chem_interface: $(OBJS) + +clean: + $(RM) *.o *.mod *.f90 libchem.a + ( cd musica; $(MAKE) clean ) + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i + +.F.o: + $(RM) $@ $*.mod +ifeq "$(GEN_F90)" "true" + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./musica -I.. -I../../framework -I../../../external/esmf_time_f90 +else + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./musica -I.. -I../../framework -I../../../external/esmf_time_f90 +endif diff --git a/src/core_atmosphere/chemistry/mpas_atm_chemistry.F b/src/core_atmosphere/chemistry/mpas_atm_chemistry.F new file mode 100644 index 0000000000..39715cf37a --- /dev/null +++ b/src/core_atmosphere/chemistry/mpas_atm_chemistry.F @@ -0,0 +1,126 @@ +! Copyright (c) 2025 The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at https://mpas-dev.github.io/license.html . +! +!----------------------------------------------------------------------- +! mpas_atm_chemistry +! +!> \brief Manages interactions with chemistry packages +!> \author CheMPAS-A Developers +!> \date 20 August 2025 +!> \details +!> This module manages the interactions with chemistry packages, +!> including initialization, time-stepping, and finalization. +!> It provides a framework for integrating various chemistry models +!> into the CheMPAS-A system. +! +!------------------------------------------------------------------------- +module mpas_atm_chemistry + + implicit none + + private + + public :: chemistry_init, chemistry_step, chemistry_finalize + + contains + + !------------------------------------------------------------------------ + ! routine chemistry_init + ! + !> \brief Initializes the chemistry packages + !> \author CheMPAS-A Developers + !> \date 20 August 2025 + !> \details + !> This routine initializes the chemistry packages, setting up + !> necessary parameters and data structures for the simulation. + !------------------------------------------------------------------------ + subroutine chemistry_init(configs, dimensions) + +#ifdef MPAS_USE_MUSICA + use mpas_musica, only: musica_init +#endif + use mpas_log, only : mpas_log_write + use mpas_derived_types, only: mpas_pool_type + use mpas_kind_types, only: StrKIND + use mpas_pool_routines, only: mpas_pool_get_config, mpas_pool_get_dimension + + type (mpas_pool_type), intent(in) :: configs + type (mpas_pool_type), intent(in) :: dimensions + +#ifdef MPAS_USE_MUSICA + integer :: error_code + character(len=:), allocatable :: error_message + integer :: nVertLevels + integer, pointer :: nVertLevels_ptr + ! MUSICA will get the MICM JSON config from a namelist + ! hardcode filepath for now + character(len=StrKIND) :: filepath = 'chapman.json' +#endif + + call mpas_log_write('Initializing chemistry packages...') + +#ifdef MPAS_USE_MUSICA + call mpas_pool_get_dimension(dimensions, 'nVertLevels', nVertLevels_ptr) + nVertLevels = nVertLevels_ptr + + call musica_init(filepath, nVertLevels, error_code, error_message) + + ! TODO check error_code and generate MPAS error log message +#endif + + end subroutine chemistry_init + + + !------------------------------------------------------------------------ + ! routine chemistry_step + ! + !> \brief Steps the chemistry packages + !> \author CheMPAS-A Developers + !> \date 20 August 2025 + !> \details + !> This routine steps the chemistry packages, updating their state + !> based on the current simulation time and conditions. + !------------------------------------------------------------------------ + subroutine chemistry_step() + +#ifdef MPAS_USE_MUSICA + use mpas_musica, only: musica_step +#endif + use mpas_log, only : mpas_log_write + +#ifdef MPAS_USE_MUSICA + call mpas_log_write('Stepping chemistry packages...') + ! call musica_step() +#endif + + end subroutine chemistry_step + + + !------------------------------------------------------------------------ + ! routine chemistry_finalize + ! + !> \brief Finalizes the chemistry packages + !> \author CheMPAS-A Developers + !> \date 20 August 2025 + !> \details + !> This routine finalizes the chemistry packages, cleaning up + !> any resources and data structures used during the simulation. + !------------------------------------------------------------------------ + subroutine chemistry_finalize() + +#ifdef MPAS_USE_MUSICA + use mpas_musica, only: musica_finalize +#endif + use mpas_log, only : mpas_log_write + +#ifdef MPAS_USE_MUSICA + call mpas_log_write('Finalizing chemistry packages...') + call musica_finalize() +#endif + + end subroutine chemistry_finalize + +end module mpas_atm_chemistry diff --git a/src/core_atmosphere/chemistry/musica/Makefile b/src/core_atmosphere/chemistry/musica/Makefile new file mode 100644 index 0000000000..3a11055c77 --- /dev/null +++ b/src/core_atmosphere/chemistry/musica/Makefile @@ -0,0 +1,31 @@ +.SUFFIXES: .F .o + +.PHONY: mpas_musica mpas_musica_lib + +all: dummy mpas_musica + +dummy: + echo "****** compiling mpas_musica ******" + +OBJS = \ + mpas_musica.o + +mpas_musica: $(OBJS) + +mpas_musica_lib: + ar -ru ./../libchem.a $(OBJS) + +clean: + $(RM) *.f90 *.o *.mod + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i + +.F.o: +ifeq "$(GEN_F90)" "true" + $(CPP) $(CPPFLAGS) $(COREDEF) $(CPPINCLUDES) $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 +else + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 +endif + diff --git a/src/core_atmosphere/chemistry/musica/mpas_musica.F b/src/core_atmosphere/chemistry/musica/mpas_musica.F new file mode 100644 index 0000000000..649b2b3624 --- /dev/null +++ b/src/core_atmosphere/chemistry/musica/mpas_musica.F @@ -0,0 +1,161 @@ +! Copyright (c) 2025 The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at https://mpas-dev.github.io/license.html . +! +!----------------------------------------------------------------------- +! mpas_musica +! +!> \brief Manages interactions with the MUSICA chemistry package +!> \author CheMPAS-A Developers +!> \date 20 August 2025 +!> \details +!> This module manages the interactions with the MUSICA chemistry package, +!> including initialization, time-stepping, and finalization for +!> MICM (ODE solver) and TUV-x (photolysis rate constant calculator). +!-------------------------------------------------------------------------- +module mpas_musica + + use musica_micm, only: micm_t, get_micm_version + ! get_micm_version is here to avoid an ICE when within musica_init + use musica_state, only: state_t + + implicit none + + private + + public :: musica_init, musica_step, musica_finalize + + type(micm_t), pointer :: micm => null ( ) ! Pointer to the MICM ODE solver instance + type(state_t), pointer :: state => null ( ) ! Pointer to the state of the MICM solver + + contains + + !------------------------------------------------------------------------ + ! subroutine musica_init + ! + !> \brief Initializes the MUSICA chemistry package + !> \author CheMPAS-A Developers + !> \date 20 August 2025 + !> \details + !> This subroutine initializes the MUSICA chemistry package, + !> setting up necessary parameters and data structures for the simulation. + !> For now, we will load fixed configurations for MICM and TUV-x. + !> Later, we will gradually replace the fixed configuration elements + !> with runtime updates using the MUSICA API + !------------------------------------------------------------------------ + subroutine musica_init(filename_of_micm_configuration, & + number_of_grid_cells, & + error_code, error_message) + + use musica_micm, only : RosenbrockStandardOrder + use musica_util, only : error_t, string_t + + use mpas_log, only : mpas_log_write + + character(len=*), intent(in) :: filename_of_micm_configuration + integer, intent(in) :: number_of_grid_cells + integer, intent(out) :: error_code + character(len=:), allocatable, intent(out) :: error_message + + type(error_t) :: error + type(string_t) :: micm_version + + ! TEMPORARY: Hard-coded options for the MICM solver + integer :: solver_type = RosenbrockStandardOrder + + micm_version = get_micm_version() + + call mpas_log_write('Initializing MUSICA chemistry package...') + call mpas_log_write('MICM version: ' // micm_version%value_) + call mpas_log_write('MICM number of grid cells: $i', intArgs=[number_of_grid_cells]) + + micm => micm_t(trim(filename_of_micm_configuration), solver_type, error) + if (has_error_occurred(error, error_message, error_code)) return + + state => micm%get_state(number_of_grid_cells, error) + if (has_error_occurred(error, error_message, error_code)) return + + end subroutine musica_init + + !------------------------------------------------------------------------ + ! subroutine musica_step + ! + !> \brief Steps the MUSICA chemistry package + !> \author CheMPAS-A Developers + !> \date 20 August 2025 + !> \details + !> This subroutine steps the MUSICA chemistry package, updating its state + !> based on the current simulation time and conditions. + !> It first calls the TUV-x package to compute photolysis rates, + !> then calls the MICM package to solve the ODEs for chemical species + !> concentrations. + !------------------------------------------------------------------------ + subroutine musica_step() + + use mpas_log, only : mpas_log_write + + call mpas_log_write('Stepping MUSICA chemistry package...') + + ! Here we would typically call the TUV-x and MICM packages to perform + ! the necessary computations, but for now we will just log the step. + + end subroutine musica_step + + !------------------------------------------------------------------------ + ! subroutine musica_finalize + ! + !> \brief Finalizes the MUSICA chemistry package + !> \author CheMPAS-A Developers + !> \date 20 August 2025 + !> \details + !> This subroutine finalizes the MUSICA chemistry package, + !> cleaning up any resources and data structures used during the simulation. + !------------------------------------------------------------------------- + subroutine musica_finalize() + + use mpas_log, only : mpas_log_write + + call mpas_log_write('Finalizing MUSICA chemistry package...') + + ! Here we would typically clean up resources, but for now we do nothing. + + end subroutine musica_finalize + + !------------------------------------------------------------------------- + ! function has_error_occurred + ! + !> \author CheMPAS-A Developers + !> \date 20 August 2025 + ! \details + !> Evaluate a MUSICA error for failure and convert to error data + !> @param[in] error The error code to evaluate and convert. + !> @param[out] error_message The error message. + !> @param[out] error_code The error code. + !> @return True for an error, false for success. + !------------------------------------------------------------------------- + logical function has_error_occurred(error, error_message, error_code) + use musica_util, only: error_t + + type(error_t), intent(in) :: error + character(len=:), allocatable, intent(out) :: error_message + integer, intent(out) :: error_code + + character(len=30) :: error_code_str + + if ( error%is_success( ) ) then + error_code = 0 + error_message = '' + has_error_occurred = .false. + return + end if + error_code = error%code( ) + write(error_code_str, '(I30)') error%code( ) + error_message = '[MUSICA Error]: ' // error%category( ) // '[' // & + trim( adjustl( error_code_str ) ) // ']: ' // error%message( ) + has_error_occurred = .true. + + end function has_error_occurred + +end module mpas_musica diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index aaebf865c7..d3e8c8a846 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -35,6 +35,9 @@ function atm_core_init(domain, startTimeStamp) result(ierr) use mpas_attlist, only : mpas_modify_att use mpas_string_utils, only : mpas_string_replace use mpas_atm_halos, only: atm_build_halo_groups, exchange_halo_group +#ifdef DO_CHEMISTRY + use mpas_atm_chemistry, only: chemistry_init +#endif implicit none @@ -282,6 +285,13 @@ function atm_core_init(domain, startTimeStamp) result(ierr) ! call mpas_atm_dynamics_init(domain) + ! + ! Initialize the chemistry package + ! +#ifdef DO_CHEMISTRY + call chemistry_init(domain % blocklist % configs, domain % blocklist % dimensions) +#endif + end function atm_core_init @@ -972,9 +982,12 @@ subroutine atm_do_timestep(domain, dt, itimestep) use mpas_atmphys_driver use mpas_atmphys_manager use mpas_atmphys_update +#endif +#ifdef DO_CHEMISTRY + use mpas_atm_chemistry, only: chemistry_step #endif use mpas_atm_halos, only: exchange_halo_group - + implicit none type (domain_type), intent(inout) :: domain @@ -1006,6 +1019,10 @@ subroutine atm_do_timestep(domain, dt, itimestep) endif #endif +#ifdef DO_CHEMISTRY + call chemistry_step() +#endif + call atm_timestep(domain, dt, currTime, itimestep, exchange_halo_group) end subroutine atm_do_timestep @@ -1024,6 +1041,10 @@ function atm_core_finalize(domain) result(ierr) use mpas_atmphys_finalize #endif +#ifdef DO_CHEMISTRY + use mpas_atm_chemistry, only: chemistry_finalize +#endif + implicit none type (domain_type), intent(inout) :: domain @@ -1040,6 +1061,13 @@ function atm_core_finalize(domain) result(ierr) ! call mpas_atm_dynamics_finalize(domain) + ! + ! Finalize chemistry + ! +#ifdef DO_CHEMISTRY + call chemistry_finalize() +#endif + call mpas_atm_diag_cleanup() call mpas_destroy_clock(clock, ierr) From 9a432a332e31158fbfaa6ca64f169c646f8b0f13 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 7 Nov 2025 23:08:18 +0000 Subject: [PATCH 025/214] Explicitly declare ierr as an integer variable in the noahmp_init routine Towards the goal of having no implicitly declared variables in the atmosphere core, this commit adds a declaration for the 'ierr' variable in the noahmp_init routine in the mpas_atmphys_lsm_noahmpinit module. Because the name of the 'ierr' variable begins with the letter 'i', it was implicitly defined as an integer variable, and its use within the noahmp_init routine was consistent with that of an integer variable. --- src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F index 3d8a98be6b..493cfbc88e 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F +++ b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F @@ -258,7 +258,7 @@ subroutine noahmp_init(configs,mesh,clock,diag_physics,diag_physics_noahmp,outpu logical,pointer:: do_restart logical,parameter:: fndsnowh = .true. - integer:: i,its,ite,n,ns,nsoil,nsnow,nzsnow + integer:: i,its,ite,n,ns,nsoil,nsnow,nzsnow,ierr real(kind=RKIND),parameter:: hlice = 3.335E5 real(kind=RKIND):: bexp,fk,smcmax,psisat From 9743fb47de1c5a45556207e5aaaa5404c0e7a8f7 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Mon, 10 Nov 2025 14:08:17 -0700 Subject: [PATCH 026/214] Add -fimplicit-none to FFLAGS_OPT and FFLAGS_DEBUG in 'gnu' build target This commit adds the -fimplicit-none flag to both the FFLAGS_OPT and FFLAGS_DEBUG variables in the 'gnu' build target in the top-level Makefile. With the addition of this flag, compilation will now fail with the gfortran compiler if implicitly defined variables are present in Fortran source code. --- Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index c34823ab5a..ff75c6be6b 100644 --- a/Makefile +++ b/Makefile @@ -16,11 +16,11 @@ gnu: # BUILDTARGET GNU Fortran, C, and C++ compilers "CC_SERIAL = gcc" \ "CXX_SERIAL = g++" \ "FFLAGS_PROMOTION = -fdefault-real-8 -fdefault-double-8" \ - "FFLAGS_OPT = -std=f2008 -O3 -ffree-line-length-none -fconvert=big-endian -ffree-form" \ + "FFLAGS_OPT = -std=f2008 -fimplicit-none -O3 -ffree-line-length-none -fconvert=big-endian -ffree-form" \ "CFLAGS_OPT = -O3" \ "CXXFLAGS_OPT = -O3" \ "LDFLAGS_OPT = -O3" \ - "FFLAGS_DEBUG = -std=f2008 -g -ffree-line-length-none -fconvert=big-endian -ffree-form -fcheck=all -fbacktrace -ffpe-trap=invalid,zero,overflow" \ + "FFLAGS_DEBUG = -std=f2008 -fimplicit-none -g -ffree-line-length-none -fconvert=big-endian -ffree-form -fcheck=all -fbacktrace -ffpe-trap=invalid,zero,overflow" \ "CFLAGS_DEBUG = -g" \ "CXXFLAGS_DEBUG = -g" \ "LDFLAGS_DEBUG = -g" \ From c2f726cea3714bd53415eb8ce60d78255b4ca25b Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Thu, 13 Nov 2025 20:41:56 +0000 Subject: [PATCH 027/214] Fixed units designation of GW drag diagnostic variables dusfcg, dtaux2d, etc. --- src/core_atmosphere/Registry.xml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 4281c40bba..77ff8f431d 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -2948,10 +2948,10 @@ - - - - Date: Thu, 23 Oct 2025 13:34:22 -0600 Subject: [PATCH 028/214] Remove scaling of gravity-wave absorbing layer coefficient by local mesh size This commit removes the scaling of the gravity-wave absorbing layer coefficient by the local mesh size. Previously, the absorbing layer coefficient was scaled by dx/dx_fine. For large values of dx/dx_fine instabilities have been encountered associated with this scaling of the absorbing layer coefficient. Units have been added to the configuration variable config_xnutr (1/s) in the Registry - it is used in calculating the absorbing layer coefficient. Units have also been added to config_visc4_2dsmag (m/s) in the Registry - it is used in the calculation of the hyperviscosity. --- src/core_atmosphere/Registry.xml | 6 +++--- src/core_atmosphere/mpas_atm_core.F | 5 ----- 2 files changed, 3 insertions(+), 8 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 4281c40bba..9663a3cbf3 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -152,8 +152,8 @@ possible_values="Positive real values. A zero value implies that the length scale is prescribed by the nominalMinDc value in the input file."/> diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index f7d04a1f0c..e21cc040fe 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -1250,8 +1250,6 @@ subroutine atm_compute_damping_coefs(mesh, configs) real (kind=RKIND), pointer :: config_xnutr, config_zd real (kind=RKIND) :: z, zt, m1, pii real (kind=RKIND), dimension(:,:), pointer :: dss, zgrid - real (kind=RKIND), dimension(:), pointer :: meshDensity - real (kind=RKIND) :: dx_scale_power m1 = -1.0 pii = acos(m1) @@ -1259,14 +1257,12 @@ subroutine atm_compute_damping_coefs(mesh, configs) call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_array(mesh, 'meshDensity', meshDensity) call mpas_pool_get_array(mesh, 'dss', dss) call mpas_pool_get_array(mesh, 'zgrid', zgrid) call mpas_pool_get_config(configs, 'config_zd', config_zd) call mpas_pool_get_config(configs, 'config_xnutr', config_xnutr) - dx_scale_power = 1.0 dss(:,:) = 0.0 do iCell=1,nCells zt = zgrid(nVertLevels+1,iCell) @@ -1274,7 +1270,6 @@ subroutine atm_compute_damping_coefs(mesh, configs) z = 0.5*(zgrid(k,iCell) + zgrid(k+1,iCell)) if (z > config_zd) then dss(k,iCell) = config_xnutr*sin(0.5*pii*(z-config_zd)/(zt-config_zd))**2.0 - dss(k,iCell) = dss(k,iCell) / meshDensity(iCell)**(0.25*dx_scale_power) end if end do end do From 4a6857fb480b2dc11d1f05189540c48b7d2b7874 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Tue, 30 Dec 2025 10:36:10 -0700 Subject: [PATCH 029/214] Fix to esmf_time_f90 include path in the root chemistry Makefile This commit fixes the incorrect path for the esmf_time_f90 external modules in the root chemistry Makefile. This issue only came to known when building with the nvhpc compiler. --- src/core_atmosphere/chemistry/Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_atmosphere/chemistry/Makefile b/src/core_atmosphere/chemistry/Makefile index 5bd4480b7d..6293e231a8 100644 --- a/src/core_atmosphere/chemistry/Makefile +++ b/src/core_atmosphere/chemistry/Makefile @@ -41,7 +41,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./musica -I.. -I../../framework -I../../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./musica -I.. -I../../framework -I../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./musica -I.. -I../../framework -I../../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./musica -I.. -I../../framework -I../../external/esmf_time_f90 endif From aae3ac80457226b345b52bdb638881f9665eedfc Mon Sep 17 00:00:00 2001 From: Andy Stokely Date: Fri, 12 Dec 2025 14:18:07 -0700 Subject: [PATCH 030/214] Set default PnetCDF header alignment to 128 KiB Increase the default Parallel NetCDF header alignment to 128 KiB when creating new files with SMIOL. This increases the default header size, providing additional header memory padding and reducing the likelihood of header reallocations and associated performance degradation. The alignment hint can be overridden via the PNETCDF_HINTS environment variable. --- src/external/SMIOL/smiol.c | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/external/SMIOL/smiol.c b/src/external/SMIOL/smiol.c index 8a34ed23bb..3efe4b9b5f 100644 --- a/src/external/SMIOL/smiol.c +++ b/src/external/SMIOL/smiol.c @@ -12,6 +12,7 @@ #define PNETCDF_DEFINE_MODE 0 #define PNETCDF_DATA_MODE 1 #define MAX_REQS 256 +#define PNETCDF_HEADER_ALIGN_SIZE_STR "131072" #endif #define START_COUNT_READ 0 @@ -324,6 +325,7 @@ int SMIOL_open_file(struct SMIOL_context *context, const char *filename, /* * Convert fformat to a PNetCDF file creation mode */ + MPI_Info info = MPI_INFO_NULL; int filecmode; if (fformat == SMIOL_FORMAT_CDF2) { filecmode = NC_64BIT_OFFSET; @@ -336,11 +338,14 @@ int SMIOL_open_file(struct SMIOL_context *context, const char *filename, MPI_Comm_free(&io_group_comm); return SMIOL_INVALID_FORMAT; } - + MPI_Info_create(&info); + MPI_Info_set(info, "nc_header_align_size", + PNETCDF_HEADER_ALIGN_SIZE_STR); ierr = ncmpi_create(io_file_comm, filename, (filecmode | NC_CLOBBER), - MPI_INFO_NULL, + info, &((*file)->ncidp)); + MPI_Info_free(&info); } (*file)->state = PNETCDF_DEFINE_MODE; #endif From 934f6e43fc90971eda69854b25ec4fbb8e633337 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 20 Dec 2019 12:38:04 -0700 Subject: [PATCH 031/214] add new deformation coefficients to registries --- src/core_atmosphere/Registry.xml | 30 +++++++++++++++++++++++++++ src/core_init_atmosphere/Registry.xml | 25 ++++++++++++++++++++++ 2 files changed, 55 insertions(+) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 4281c40bba..2ae703653d 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -494,6 +494,11 @@ + + + + + #ifdef MPAS_CAM_DYCORE @@ -594,6 +599,17 @@ #endif + + + + + + + + + + + @@ -1561,6 +1577,20 @@ #endif + + + + + + + + + + + + + + @@ -573,6 +578,11 @@ + + + + + @@ -1114,6 +1124,21 @@ + + + + + + + + + + From da78a8cb3384e32fb488cbb25d30eba02d18f1d6 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 20 Dec 2019 15:18:27 -0700 Subject: [PATCH 032/214] initialize new deformation coefficients --- src/core_init_atmosphere/mpas_atm_advection.F | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index f4d44c984e..59edf3b843 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -758,6 +758,8 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b real (kind=RKIND), dimension(:,:), pointer :: cell_gradient_coef_x, cell_gradient_coef_y + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c2, deformation_coef_s2, deformation_coef_cs + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c, deformation_coef_s integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, cellsOnCell, verticesOnCell integer, dimension(:), pointer :: nEdgesOnCell real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell @@ -927,9 +929,19 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere defc_b(i,iCell) = dl*2.*sint_cost/area_cell cell_gradient_coef_x(i,iCell) = dl*cos(thetat(i))/area_cell cell_gradient_coef_y(i,iCell) = dl*sin(thetat(i))/area_cell + deformation_coef_c2(i,iCell) = dl*cost2/area_cell + deformation_coef_s2(i,iCell) = dl*sint2/area_cell + deformation_coef_cs(i,iCell) = dl*sint_cost/area_cell + deformation_coef_c(i,iCell) = dl*cos(thetat(i))/area_cell + deformation_coef_s(i,iCell) = dl*sin(thetat(i))/area_cell if (cellsOnEdge(1,EdgesOnCell(i,iCell)) /= iCell) then defc_a(i,iCell) = - defc_a(i,iCell) defc_b(i,iCell) = - defc_b(i,iCell) + deformation_coef_c2(i,iCell) = - deformation_coef_c2(i,iCell) + deformation_coef_s2(i,iCell) = - deformation_coef_s2(i,iCell) + deformation_coef_cs(i,iCell) = - deformation_coef_cs(i,iCell) + deformation_coef_c(i,iCell) = - deformation_coef_c(i,iCell) + deformation_coef_s(i,iCell) = - deformation_coef_s(i,iCell) end if end do From b7880ce698cc608d17609505e258b3afbf6032af Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 20 Dec 2019 16:32:22 -0700 Subject: [PATCH 033/214] add pointers for new coefficients --- src/core_init_atmosphere/mpas_atm_advection.F | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index 59edf3b843..7e04564fa0 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -787,6 +787,11 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere call mpas_pool_get_array(mesh, 'defc_b', defc_b) call mpas_pool_get_array(mesh, 'cell_gradient_coef_x', cell_gradient_coef_x) call mpas_pool_get_array(mesh, 'cell_gradient_coef_y', cell_gradient_coef_y) + call mpas_pool_get_array(mesh, 'deformation_coef_c2', deformation_coef_c2) + call mpas_pool_get_array(mesh, 'deformation_coef_s2', deformation_coef_s2) + call mpas_pool_get_array(mesh, 'deformation_coef_cs', deformation_coef_cs) + call mpas_pool_get_array(mesh, 'deformation_coef_c', deformation_coef_c) + call mpas_pool_get_array(mesh, 'deformation_coef_s', deformation_coef_s) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) From 235b61ce726b41daf4572d3da1d3a71463a6eeb1 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Mon, 23 Dec 2019 15:07:40 -0700 Subject: [PATCH 034/214] add initialization of new arrays to zero --- src/core_init_atmosphere/mpas_atm_advection.F | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index 7e04564fa0..7a954cd630 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -806,6 +806,11 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere defc_a(:,:) = 0. defc_b(:,:) = 0. + deformation_coef_c2(:,:) = 0. + deformation_coef_s2(:,:) = 0. + deformation_coef_cs(:,:) = 0. + deformation_coef_c(:,:) = 0. + deformation_coef_s(:,:) = 0. cell_gradient_coef_x(:,:) = 0. cell_gradient_coef_y(:,:) = 0. From cf17fae8fcd6986ffcc45babcbd8be70339f9b0b Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Mon, 23 Dec 2019 15:29:57 -0700 Subject: [PATCH 035/214] pass new arrays to dyn_tend_work - compiles --- .../dynamics/mpas_atm_time_integration.F | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 4fe2faefc4..4aa46b4879 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4810,6 +4810,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:,:), pointer :: ur_cell, vr_cell real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c2, deformation_coef_s2, deformation_coef_cs + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c, deformation_coef_s real(kind=RKIND), dimension(:,:), pointer :: tend_w_pgf, tend_w_buoy @@ -4905,6 +4907,11 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) call mpas_pool_get_array(mesh, 'defc_a', defc_a) call mpas_pool_get_array(mesh, 'defc_b', defc_b) + call mpas_pool_get_array(mesh, 'deformation_coef_c2', deformation_coef_c2) + call mpas_pool_get_array(mesh, 'deformation_coef_s2', deformation_coef_s2) + call mpas_pool_get_array(mesh, 'deformation_coef_cs', deformation_coef_cs) + call mpas_pool_get_array(mesh, 'deformation_coef_c', deformation_coef_c) + call mpas_pool_get_array(mesh, 'deformation_coef_s', deformation_coef_s) call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) call mpas_pool_get_array(mesh, 'u_init', u_init) @@ -4966,6 +4973,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & + deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & @@ -4990,6 +4998,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & + deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & @@ -5098,6 +5107,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(maxEdges,nCells+1) :: defc_a real (kind=RKIND), dimension(maxEdges,nCells+1) :: defc_b + real (kind=RKIND), dimension(maxEdges,nCells+1) :: deformation_coef_c2, deformation_coef_s2, deformation_coef_cs + real (kind=RKIND), dimension(maxEdges,nCells+1) :: deformation_coef_c, deformation_coef_s real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_pgf real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_buoy From bf910d67d2934316b6339a69f3b54b1549f0cbaf Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 13:52:43 -0700 Subject: [PATCH 036/214] add deformation formulation to 2d Smagorinsky kdiff --- .../dynamics/mpas_atm_time_integration.F | 24 ++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 4aa46b4879..b1e0241cc3 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5147,6 +5147,10 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension( nVertLevels+1 ) :: d_diag, d_off_diag, flux_arr real (kind=RKIND), dimension( nVertLevels + 1 ) :: wduz, wdwz, wdtz, dpzx real (kind=RKIND), dimension( nVertLevels ) :: ru_edge_w, q, u_mix + + real (kind=RKIND), dimension( nVertLevels+1 ) :: d_11, d_22, d_12 + real (kind=RKIND), dimension( nVertLevels+1 ) :: dudx, dudy, dvdx, dvdy + real (kind=RKIND) :: theta_turb_flux, w_turb_flux, r real (kind=RKIND) :: scalar_weight real (kind=RKIND) :: inv_r_earth @@ -5246,6 +5250,11 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm d_off_diag(k) = 0.0_RKIND end do + dudx(1:nVertLevels) = 0.0 + dudy(1:nVertLevels) = 0.0 + dvdx(1:nVertLevels) = 0.0 + dvdy(1:nVertLevels) = 0.0 + !$acc loop seq do iEdge=1,nEdgesOnCell(iCell) !$acc loop vector @@ -5254,6 +5263,14 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm - defc_b(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) d_off_diag(k) = d_off_diag(k) + defc_b(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + defc_a(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + - deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + - deformation_coef_s2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + + deformation_coef_c2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + + deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) end do end do !DIR$ IVDEP @@ -5261,7 +5278,12 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm do k=1, nVertLevels ! here is the Smagorinsky formulation, ! followed by imposition of an upper bound on the eddy viscosity - kdiff(k,iCell) = min((c_s * config_len_disp)**2 * sqrt(d_diag(k)**2 + d_off_diag(k)**2),(0.01*config_len_disp**2) * invDt) + ! kdiff(k,iCell) = min((c_s * config_len_disp)**2 * sqrt(d_diag(k)**2 + d_off_diag(k)**2),(0.01*config_len_disp**2) * invDt) + ! deformation formulation + d_11(k) = 2*dudx(k) + d_22(k) = 2*dvdy(k) + d_12(k) = dudy(k) + dvdx(k) + kdiff(k,iCell) = min((c_s * config_len_disp)**2 * sqrt(0.25*(d_11(k)-d_22(k))**2 + d_12(k)**2),(0.01*config_len_disp**2) * invDt) end do end do !$acc end parallel From 31a507c27690953c26ff409dfa7bcff605b0beba Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Fri, 27 Dec 2019 12:47:26 -0700 Subject: [PATCH 037/214] bug fixes for computing the deformation coefficients for the 2D Smagorinsky scheme on Cartesian planes. This also fixes periodicity on those planes for the coefficients. --- src/core_init_atmosphere/mpas_atm_advection.F | 66 ++++++++++++++++--- 1 file changed, 58 insertions(+), 8 deletions(-) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index 7a954cd630..585f5443ef 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -11,6 +11,7 @@ module atm_advection use mpas_derived_types use mpas_pool_routines use mpas_constants + use mpas_vector_operations use mpas_abort, only : mpas_dmpar_global_abort use mpas_log, only : mpas_log_write @@ -764,6 +765,7 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere integer, dimension(:), pointer :: nEdgesOnCell real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge real (kind=RKIND), dimension(nCells) :: theta_abs @@ -774,14 +776,22 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere integer :: iCell real (kind=RKIND) :: pii real (kind=RKIND), dimension(25) :: xp, yp + real (kind=RKIND) :: xe, ye + real (kind=RKIND) :: length_scale integer, dimension(25) :: cell_list - integer :: iv + integer :: iv, ie logical :: do_the_cell real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, dx, dy + logical, pointer :: is_periodic + real(kind=RKIND), pointer :: x_period, y_period + + call mpas_pool_get_config(mesh, 'is_periodic', is_periodic) + call mpas_pool_get_config(mesh, 'x_period', x_period) + call mpas_pool_get_config(mesh, 'y_period', y_period) call mpas_pool_get_array(mesh, 'defc_a', defc_a) call mpas_pool_get_array(mesh, 'defc_b', defc_b) @@ -803,6 +813,9 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere call mpas_pool_get_array(mesh, 'xVertex', xVertex) call mpas_pool_get_array(mesh, 'yVertex', yVertex) call mpas_pool_get_array(mesh, 'zVertex', zVertex) + call mpas_pool_get_array(mesh, 'xEdge', xEdge) + call mpas_pool_get_array(mesh, 'yEdge', yEdge) + call mpas_pool_get_array(mesh, 'zEdge', zEdge) defc_a(:,:) = 0. defc_b(:,:) = 0. @@ -900,21 +913,58 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere else ! On an x-y plane - theta_abs(iCell) = 0.0 + do i=1,n-1 + iv = verticesOnCell(i,iCell) + xp(i) = mpas_fix_periodicity(xVertex(iv),xCell(iCell),x_period) - xCell(iCell) + yp(i) = mpas_fix_periodicity(yVertex(iv),yCell(iCell),y_period) - yCell(iCell) + end do - xp(1) = xCell(iCell) - yp(1) = yCell(iCell) + ! if(iCell.lt.11) then + ! call mpas_log_write(' setting defc coefs, cell $i', intArgs=(/iCell/)) + ! do i=1,n-1 + ! iv = verticesOnCell(i,iCell) + ! call mpas_log_write(' xp,yp,xvc,yvc, $r $r $r $r', realArgs=(/xp(i),yp(i),xVertex(iv)-xCell(iCell),yVertex(iv)-yCell(iCell)/)) + ! end do + ! end if - do i=2,n - iv = verticesOnCell(i-1,iCell) - xp(i) = xVertex(iv) - yp(i) = yVertex(iv) + do i=1,n-1 + ie = edgesOnCell(i,iCell) + xe = mpas_fix_periodicity(xEdge(ie),xCell(iCell),x_period) - xCell(iCell) + ye = mpas_fix_periodicity(yEdge(ie),yCell(iCell),y_period) - yCell(iCell) + thetat(i) = atan2(ye,xe) end do + ! if(iCell .lt. 11) then + ! call mpas_log_write(' edge angles, plane calc, cell $i', intArgs=(/iCell/)) + ! do i=1,n-1 + ! call mpas_log_write(' edge angle $r', realArgs=(/thetat(i)*180./3.1415926/)) + ! end do + ! end if + + theta_abs(iCell) = thetat(1) + end if ! (1) compute cell area on the tangent plane used in the integrals ! (2) compute angle of cell edge normal vector. here we are repurposing thetat + thetat(1) = theta_abs(iCell) + + do i=2,n-1 + ip1 = i+1 + if (ip1 == n) ip1 = 1 + thetat(i) = plane_angle( 0.0_RKIND, 0.0_RKIND, 0.0_RKIND, & + xp(i)-xp(i-1), yp(i)-yp(i-1), 0.0_RKIND, & + xp(ip1)-xp(i), yp(ip1)-yp(i), 0.0_RKIND, & + 0.0_RKIND, 0.0_RKIND, 1.0_RKIND) + thetat(i) = thetat(i) + thetat(i-1) + end do + + if(iCell .lt. 11) then + call mpas_log_write(' edge angles, generic calc, cell $i', intArgs=(/iCell/)) + do i=1,n-1 + call mpas_log_write(' edge angle $r', realArgs=(/thetat(i)*180./3.1415926/)) + end do + end if area_cell = 0. do i=1,n-1 From a4c08d4a85fb719bbc03af26491ec4183a5c5fde Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 30 Dec 2019 12:26:47 -0700 Subject: [PATCH 038/214] Fixed error in w_x, w_y deformation coefficients. Added unit test for deformation coefficients on Cartesian-plane meshes. --- src/core_init_atmosphere/mpas_atm_advection.F | 243 +++++++++++++++++- 1 file changed, 234 insertions(+), 9 deletions(-) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index 585f5443ef..3b487f3797 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -765,7 +765,8 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere integer, dimension(:), pointer :: nEdgesOnCell real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex - real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge + real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge, angleEdge + real (kind=RKIND), dimension(:), pointer :: areaCell real (kind=RKIND), dimension(nCells) :: theta_abs @@ -784,7 +785,11 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere integer :: iv, ie logical :: do_the_cell +<<<<<<< HEAD real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, dx, dy +======= + real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost +>>>>>>> 94ba9031b (Fixed error in w_x, w_y deformation coefficients.) logical, pointer :: is_periodic real(kind=RKIND), pointer :: x_period, y_period @@ -816,6 +821,8 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere call mpas_pool_get_array(mesh, 'xEdge', xEdge) call mpas_pool_get_array(mesh, 'yEdge', yEdge) call mpas_pool_get_array(mesh, 'zEdge', zEdge) + call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) defc_a(:,:) = 0. defc_b(:,:) = 0. @@ -959,12 +966,12 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere thetat(i) = thetat(i) + thetat(i-1) end do - if(iCell .lt. 11) then - call mpas_log_write(' edge angles, generic calc, cell $i', intArgs=(/iCell/)) - do i=1,n-1 - call mpas_log_write(' edge angle $r', realArgs=(/thetat(i)*180./3.1415926/)) - end do - end if + ! if(iCell .lt. 11) then + ! call mpas_log_write(' edge angles, generic calc, cell $i', intArgs=(/iCell/)) + ! do i=1,n-1 + ! call mpas_log_write(' edge angle $r', realArgs=(/thetat(i)*180./3.1415926/)) + ! end do + ! end if area_cell = 0. do i=1,n-1 @@ -1000,14 +1007,232 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere deformation_coef_c2(i,iCell) = - deformation_coef_c2(i,iCell) deformation_coef_s2(i,iCell) = - deformation_coef_s2(i,iCell) deformation_coef_cs(i,iCell) = - deformation_coef_cs(i,iCell) - deformation_coef_c(i,iCell) = - deformation_coef_c(i,iCell) - deformation_coef_s(i,iCell) = - deformation_coef_s(i,iCell) +! deformation_coef_c(i,iCell) = - deformation_coef_c(i,iCell) +! deformation_coef_s(i,iCell) = - deformation_coef_s(i,iCell) end if end do end do + call atm_init_test_coefs( deformation_coef_c2, deformation_coef_s2, & + deformation_coef_cs, deformation_coef_c, & + deformation_coef_s, & + is_periodic, on_a_sphere, & + x_period, y_period, & + xEdge, yEdge, zEdge, & + xCell, yCell, zCell, nCells, & + angleEdge, nEdgesOnCell, edgesOnCell ) + + end subroutine atm_initialize_deformation_weights end module atm_advection +!----------------------- + + subroutine atm_init_test_coefs( deformation_coef_c2, deformation_coef_s2, & + deformation_coef_cs, deformation_coef_c, & + deformation_coef_s, & + is_periodic, on_a_sphere, & + x_period, y_period, & + xEdge, yEdge, zEdge, & + xCell, yCell, zCell, nCells, & + angleEdge, nEdgesOnCell, edgesOnCell ) + + implicit none + + logical :: is_periodic, on_a_sphere + integer :: nCells + integer, dimension(:) :: nEdgesOnCell + real (kind=RKIND) :: x_period, y_period + real (kind=RKIND), dimension(:,:) :: deformation_coef_c2, deformation_coef_s2 + real (kind=RKIND), dimension(:,:) :: deformation_coef_cs + real (kind=RKIND), dimension(:,:) :: deformation_coef_c, deformation_coef_s + integer, dimension(:,:) :: edgesOnCell + real (kind=RKIND), dimension(:) :: angleEdge, xEdge, yEdge, zEdge + real (kind=RKIND), dimension(:) :: xCell, yCell, zCell + + ! local variables + + integer :: iCell, iEdge, ie + real (kind=RKIND) :: cos_edge, sin_edge, ux, uy, vx, vy, wx, wy + real (kind=RKIND) :: xc, yc, xe, ye + real (kind=RKIND) :: angle_e, ue, ve, we, e_int + real (kind=RKIND) :: dudx, dudy, dvdx, dvdy, dwdx, dwdy + real (kind=RKIND) :: dudx_c, dudy_c, dvdx_c, dvdy_c, dwdx_c, dwdy_c + + real (kind=RKIND) :: dudx_err_max, dudy_err_max, dvdx_err_max, dvdy_err_max, dwdx_err_max, dwdy_err_max + real (kind=RKIND) :: dudx_err_tot, dudy_err_tot, dvdx_err_tot, dvdy_err_tot, dwdx_err_tot, dwdy_err_tot + real (kind=RKIND) :: dudx_max, dudy_max, dvdx_max, dvdy_max, dwdx_max, dwdy_max + + real (kind=RKIND) :: ang + real (kind=RKIND), parameter :: x_vel= 1.0, y_vel=1.0, w_vel=1.0 + real (kind=RKIND) :: u_edge, v_edge, w_edge, x, y, angle, xl, yl + real (kind=RKIND) :: dudx_cell, dudy_cell, dvdx_cell, dvdy_cell, dwdx_cell, dwdy_cell + + ! Test tunction definitions + ! + ! here are the velocity field functions and their derivatives. + ! First a simple test: U = x_vel*(-x+y), V = y_vel * (-x+y), W = w_vel*(-x+y) + + u_edge(x,y,ang,xl,yl) = (x_vel*(x+y)) * cos(ang) + (y_vel * (x+y) * sin(ang)) + v_edge(x,y,ang,xl,yl) = -(x_vel*(x+y)) * sin(ang) + (y_vel * (x+y) * cos(ang)) + w_edge(x,y,xl,yl) = w_vel * (x+y) + + dudx_cell(x,y,xl,yl) = x_vel + dudy_cell(x,y,xl,yl) = x_vel + dvdx_cell(x,y,xl,yl) = y_vel + dvdy_cell(x,y,xl,yl) = y_vel + dwdx_cell(x,y,xl,yl) = w_vel + dwdy_cell(x,y,xl,yl) = w_vel + + ! ----------------- + + if ( (.not. on_a_sphere) .and. (is_periodic) ) then ! test is for doubly-periodic Cartesian plane only + + dudx_err_max = 0. + dudy_err_max = 0. + dvdx_err_max = 0. + dvdy_err_max = 0. + dwdx_err_max = 0. + dwdy_err_max = 0. + + dudx_err_tot = 0. + dudy_err_tot = 0. + dvdx_err_tot = 0. + dvdy_err_tot = 0. + dwdx_err_tot = 0. + dwdy_err_tot = 0. + + dudx_max = 0. + dudy_max = 0. + dvdx_max = 0. + dvdy_max = 0. + dwdx_max = 0. + dwdy_max = 0. + + do iCell = 1, nCells + + dudx = 0. + dudy = 0. + dvdx = 0. + dvdy = 0. + dwdx = 0. + dwdy = 0. + + xc = xCell(iCell) + yc = yCell(iCell) + + dudx_c = dudx_cell(xc,yc,x_period,y_period) + dudy_c = dudy_cell(xc,yc,x_period,y_period) + dvdx_c = dvdx_cell(xc,yc,x_period,y_period) + dvdy_c = dvdy_cell(xc,yc,x_period,y_period) + dwdx_c = dwdx_cell(xc,yc,x_period,y_period) + dwdy_c = dwdy_cell(xc,yc,x_period,y_period) + + do iEdge = 1, nEdgesOnCell(iCell) + + ie = edgesOnCell(iEdge,iCell) + angle_e = angleEdge(ie) + xe = xEdge(ie) + ye = yEdge(ie) + + xe = mpas_fix_periodicity(xe,xc,x_period) + ye = mpas_fix_periodicity(ye,yc,y_period) + + ue = u_edge(xe,ye,angle_e,x_period,y_period) + ve = v_edge(xe,ye,angle_e,x_period,y_period) + we = w_edge(xe,ye,x_period,y_period) + + dudx = dudx + deformation_coef_c2(iEdge,iCell)*ue & + - deformation_coef_cs(iEdge,iCell)*ve + dudy = dudy + deformation_coef_cs(iEdge,iCell)*ue & + - deformation_coef_s2(iEdge,iCell)*ve + dvdx = dvdx + deformation_coef_cs(iEdge,iCell)*ue & + + deformation_coef_c2(iEdge,iCell)*ve + dvdy = dvdy + deformation_coef_s2(iEdge,iCell)*ue & + + deformation_coef_cs(iEdge,iCell)*ve + + dwdx = dwdx + deformation_coef_c(iEdge,iCell)*we + dwdy = dwdy + deformation_coef_s(iEdge,iCell)*we + + end do + + ! call mpas_log_write(' u_x, u_y, $r, $r ', realArgs=(/dudx, dudy/)) + ! call mpas_log_write(' v_x, v_y, $r, $r ', realArgs=(/dvdx, dvdy/)) + ! call mpas_log_write(' w_x, w_y, $r, $r ', realArgs=(/dwdx, dwdy/)) + + ! check result for cell + + e_int = abs(dudx_c - dudx) + dudx_err_tot = dudx_err_tot + e_int + dudx_err_max = max(dudx_err_max, e_int) + + e_int = abs(dudy_c - dudy) + dudy_err_tot = dudy_err_tot + e_int + dudy_err_max = max(dudy_err_max, e_int) + + e_int = abs(dvdx_c - dvdx) + dvdx_err_tot = dvdx_err_tot + e_int + dvdx_err_max = max(dvdx_err_max, e_int) + + e_int = abs(dvdy_c - dvdy) + dvdy_err_tot = dvdy_err_tot + e_int + dvdy_err_max = max(dvdy_err_max, e_int) + + e_int = abs(dwdx_c - dwdx) + dwdx_err_tot = dwdx_err_tot + e_int + dwdx_err_max = max(dwdx_err_max, e_int) + + e_int = abs(dwdy_c - dwdy) + dwdy_err_tot = dwdy_err_tot + e_int + dwdy_err_max = max(dwdy_err_max, e_int) + + dudx_max = max(dudx_max, abs(dudx_c)) + dudy_max = max(dudy_max, abs(dudy_c)) + dvdx_max = max(dvdx_max, abs(dvdx_c)) + dvdy_max = max(dvdy_max, abs(dvdy_c)) + dwdx_max = max(dwdx_max, abs(dwdx_c)) + dwdy_max = max(dwdy_max, abs(dwdy_c)) + + end do + + ! scale errors + + dudx_err_max = dudx_err_max/dudx_max + dudy_err_max = dudy_err_max/dudy_max + dvdx_err_max = dvdx_err_max/dvdx_max + dvdy_err_max = dvdy_err_max/dvdy_max + dwdx_err_max = dwdx_err_max/dwdx_max + dwdy_err_max = dwdy_err_max/dwdy_max + + dudx_err_tot = dudx_err_tot/dudx_max/real(nCells) + dudy_err_tot = dudy_err_tot/dudy_max/real(nCells) + dvdx_err_tot = dvdx_err_tot/dvdx_max/real(nCells) + dvdy_err_tot = dvdy_err_tot/dvdy_max/real(nCells) + dwdx_err_tot = dwdx_err_tot/dwdx_max/real(nCells) + dwdy_err_tot = dwdy_err_tot/dwdy_max/real(nCells) + + ! output + + call mpas_log_write(' ') + call mpas_log_write(' deformation coefficients check ') + call mpas_log_write(' dudx check, max abs(dudx), max and avg error $r, $r, $r', & + realArgs=(/dudx_max, dudx_err_max, dudx_err_tot/)) + call mpas_log_write(' dudy check, max abs(dudy), max and avg error $r, $r, $r', & + realArgs=(/dudy_max, dudy_err_max, dudy_err_tot/)) + call mpas_log_write(' dvdx check, max abs(dvdx), max and avg error $r, $r, $r', & + realArgs=(/dvdx_max, dvdx_err_max, dvdx_err_tot/)) + call mpas_log_write(' dvdy check, max abs(dvdy), max and avg error $r, $r, $r', & + realArgs=(/dvdy_max, dvdy_err_max, dvdy_err_tot/)) + call mpas_log_write(' dwdx check, max abs(dwdx), max and avg error $r, $r, $r', & + realArgs=(/dwdx_max, dwdx_err_max, dwdx_err_tot/)) + call mpas_log_write(' dwdy check, max abs(dwdy), max and avg error $r, $r, $r', & + realArgs=(/dwdy_max, dwdy_err_max, dwdy_err_tot/)) + call mpas_log_write(' ') + + end if + + end subroutine atm_init_test_coefs + +end module atm_advection From 4fbeab4ff8213c6b545ff6c34d31a4c63b8b2e7e Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 31 Dec 2019 10:50:15 -0700 Subject: [PATCH 039/214] New module file for the dissipation routines. The algorithm for the 2D Smagorinsky eddy viscosity coefficients are implemented in this module. Others to follow. --- .../dynamics/mpas_atm_dissipation_models.F | 74 +++++++++++++++++++ 1 file changed, 74 insertions(+) create mode 100644 src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F new file mode 100644 index 0000000000..c64fd90fa3 --- /dev/null +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -0,0 +1,74 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! + +module mpas_atm_dissipation_models + + use mpas_kind_types, only : RKIND + + contains + + subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & + nCells, nEdges, nVertLevels, maxEdges ) + implicit none + + integer, intent(in) :: cellStart, cellEnd, nCells, nEdges, nVertLevels, maxEdges + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: v + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_c2 + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_s2 + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_cs + real (kind=RKIND), intent(in) :: c_s, config_len_disp, invDt, config_visc4_2dsmag + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: kdiff + real (kind=RKIND), intent(out) :: h_mom_eddy_visc4, h_theta_eddy_visc4 + + ! local variables + + integer :: iCell, iEdge, k + real (kind=RKIND), dimension(nVertLevels) :: d_11, d_22, d_12, dudx, dudy, dvdx, dvdy + + do iCell = cellStart,cellEnd + dudx(1:nVertLevels) = 0.0 + dudy(1:nVertLevels) = 0.0 + dvdx(1:nVertLevels) = 0.0 + dvdy(1:nVertLevels) = 0.0 + do iEdge=1,nEdgesOnCell(iCell) + do k=1,nVertLevels + dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + - deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + - deformation_coef_s2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + + deformation_coef_c2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + + deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + end do + end do +!DIR$ IVDEP + do k=1, nVertLevels + ! here is the Smagorinsky formulation, + ! followed by imposition of an upper bound on the eddy viscosity + d_11(k) = 2*dudx(k) + d_22(k) = 2*dvdy(k) + d_12(k) = dudy(k) + dvdx(k) + kdiff(k,iCell) = (c_s * config_len_disp)**2 * sqrt(0.25*(d_11(k)-d_22(k))**2 + d_12(k)**2) + kdiff(k,iCell) = min(kdiff(k,iCell),(0.01*config_len_disp**2) * invDt) + end do + end do + + h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 + h_theta_eddy_visc4 = h_mom_eddy_visc4 + + end subroutine smagorinsky_2d + +end module mpas_atm_dissipation_models From bf5e369d941fae9323c95cbc3ab0a403d3937a1b Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 13:55:05 -0700 Subject: [PATCH 040/214] (1) Changes to the Makefile to compile new dissipation module. (2) Changes in atm_compute_dyn_tend to call dissipation module subroutine to compute 2D Smagorinsky eddy viscosity. --- src/core_atmosphere/dynamics/Makefile | 5 +- .../dynamics/mpas_atm_time_integration.F | 58 +++---------------- 2 files changed, 10 insertions(+), 53 deletions(-) diff --git a/src/core_atmosphere/dynamics/Makefile b/src/core_atmosphere/dynamics/Makefile index 6892633c68..1bf21fff9d 100644 --- a/src/core_atmosphere/dynamics/Makefile +++ b/src/core_atmosphere/dynamics/Makefile @@ -1,11 +1,12 @@ .SUFFIXES: .F .o OBJS = mpas_atm_time_integration.o \ - mpas_atm_boundaries.o + mpas_atm_boundaries.o \ + mpas_atm_dissipation_models.o all: $(OBJS) -mpas_atm_time_integration.o: mpas_atm_boundaries.o mpas_atm_iau.o +mpas_atm_time_integration.o: mpas_atm_boundaries.o mpas_atm_iau.o mpas_atm_dissipation_models.o mpas_atm_boundaries.o: diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index b1e0241cc3..c2aa4cf94f 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -36,6 +36,7 @@ module atm_time_integration use mpas_atm_boundaries, only : nSpecZone, nRelaxZone, nBdyZone, mpas_atm_get_bdy_state, mpas_atm_get_bdy_tend ! regional_MPAS addition use mpas_atm_iau + use mpas_atm_dissipation_models ! ! Abstract interface for routine used to communicate halos of fields @@ -5236,60 +5237,15 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc end parallel ! Smagorinsky eddy viscosity, based on horizontal deformation (in this case on model coordinate surfaces). - ! The integration coefficients were precomputed and stored in defc_a and defc_b + ! The integration coefficients were precomputed and stored in deformation_coef_* if(config_horiz_mixing == "2d_smagorinsky") then - !$acc parallel default(present) - !$acc loop gang worker private(d_diag, d_off_diag) - do iCell = cellStart,cellEnd - - !$acc loop vector - do k = 1, nVertLevels - d_diag(k) = 0.0_RKIND - d_off_diag(k) = 0.0_RKIND - end do - - dudx(1:nVertLevels) = 0.0 - dudy(1:nVertLevels) = 0.0 - dvdx(1:nVertLevels) = 0.0 - dvdy(1:nVertLevels) = 0.0 - - !$acc loop seq - do iEdge=1,nEdgesOnCell(iCell) - !$acc loop vector - do k=1,nVertLevels - d_diag(k) = d_diag(k) + defc_a(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - - defc_b(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - d_off_diag(k) = d_off_diag(k) + defc_b(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - + defc_a(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - - deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - - deformation_coef_s2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - + deformation_coef_c2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - + deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - end do - end do -!DIR$ IVDEP - !$acc loop vector - do k=1, nVertLevels - ! here is the Smagorinsky formulation, - ! followed by imposition of an upper bound on the eddy viscosity - ! kdiff(k,iCell) = min((c_s * config_len_disp)**2 * sqrt(d_diag(k)**2 + d_off_diag(k)**2),(0.01*config_len_disp**2) * invDt) - ! deformation formulation - d_11(k) = 2*dudx(k) - d_22(k) = 2*dvdy(k) - d_12(k) = dudy(k) + dvdx(k) - kdiff(k,iCell) = min((c_s * config_len_disp)**2 * sqrt(0.25*(d_11(k)-d_22(k))**2 + d_12(k)**2),(0.01*config_len_disp**2) * invDt) - end do - end do - !$acc end parallel - - h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 - h_theta_eddy_visc4 = h_mom_eddy_visc4 + call smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & + nCells, nEdges, nVertLevels, maxEdges ) else if(config_horiz_mixing == "2d_fixed") then From 597f74f0bddf7ddd17386fb29d1b3a917f7ed1e8 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 31 Dec 2019 11:11:04 -0700 Subject: [PATCH 041/214] Modifications to use mpas_atm_dimensions in the dissipation module so that compile time specification of Nvertlevels and maxEdges is enabled. --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 7 +++++-- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 2 +- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index c64fd90fa3..7b8457d927 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -16,10 +16,13 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & - nCells, nEdges, nVertLevels, maxEdges ) + nCells, nEdges ) + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + implicit none - integer, intent(in) :: cellStart, cellEnd, nCells, nEdges, nVertLevels, maxEdges + integer, intent(in) :: cellStart, cellEnd, nCells, nEdges real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: v real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_c2 diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index c2aa4cf94f..0ec79e0800 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5245,7 +5245,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & - nCells, nEdges, nVertLevels, maxEdges ) + nCells, nEdges ) else if(config_horiz_mixing == "2d_fixed") then From b454527bc22d6425241273219ab11c000d15bb65 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 14:00:37 -0700 Subject: [PATCH 042/214] Adding configuration string for the les models in the Registry. Made string available in atm_compute_dyn_tend and set up logic to allow for different dissipation options that now include the les models. --- src/core_atmosphere/Registry.xml | 5 ++ .../dynamics/mpas_atm_time_integration.F | 51 ++++++++++++------- 2 files changed, 37 insertions(+), 19 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 2ae703653d..94e6b43f22 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -146,6 +146,11 @@ description="Formulation of horizontal mixing" possible_values="`2d_fixed' or `2d_smagorinsky'"/> + + Date: Thu, 4 Dec 2025 14:06:43 -0700 Subject: [PATCH 043/214] Moved the dissipation term computations for u, theta and w from subroutine atm_compute_dyn_tend to subroutines in mpas_atm_dissipation.F. The results are no longer bit-for-bit with the modified code because we have re-arranged the order to the processes in the vertical momentum equation to accommodate doing the horizontal and vertical dissipation for w together. --- .../dynamics/mpas_atm_dissipation_models.F | 502 ++++++++++++++++++ .../dynamics/mpas_atm_time_integration.F | 447 ++-------------- 2 files changed, 533 insertions(+), 416 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 7b8457d927..af983af979 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -74,4 +74,506 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, end subroutine smagorinsky_2d +!--------------------------------------- + + subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & + cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & + nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & + invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & + angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & + config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & + config_del4u_div_factor, zgrid, kdiff, & + delsq_u, delsq_vorticity, delsq_divergence, & + u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + + implicit none + + integer, intent(in) :: edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: vertexStart, vertexEnd, vertexDegree + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: nCells, nEdges, nVertices + logical, intent(in) :: config_mix_full + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + integer, dimension(2,nEdges+1), intent(in) :: verticesOnEdge + integer, dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(vertexDegree,nVertices+1), intent(in) :: edgesOnVertex + + real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 + real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 + real (kind=RKIND), intent(in) :: config_del4u_div_factor + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(vertexDegree,nVertices+1), intent(in) :: edgesOnVertex_sign + real (kind=RKIND), dimension(nVertices+1), intent(in) :: invAreaTriangle + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: angleEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid + + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: divergence + real (kind=RKIND), dimension(nVertLevels,nVertices+1), intent(in) :: vorticity + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff + + + ! scratch space from calling routine + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: delsq_u + real (kind=RKIND), dimension(nVertLevels,nVertices+1) :: delsq_vorticity + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_divergence + + real (kind=RKIND), dimension(nVertLevels), intent(in) :: u_init, v_init + + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(out) :: tend_u_euler + + ! local variables + + integer :: iEdge, cell1, cell2, vertex1, vertex2, iVertex, iCell, i, k + real (kind=RKIND) :: r_dc, r_dv, u_diffusion, kdiffu, r, edge_sign, u_mix_scale + real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp + real (kind=RKIND), dimension(nVertLevels) :: u_mix + +!$OMP BARRIER + + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). + ! First, storage to hold the result from the first del^2 computation. + + delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 + + do iEdge=edgeStart,edgeEnd + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + vertex1 = verticesOnEdge(1,iEdge) + vertex2 = verticesOnEdge(2,iEdge) + r_dc = invDcEdge(iEdge) + r_dv = min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) + +!DIR$ IVDEP + do k=1,nVertLevels + + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant + u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & + -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv + + delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion + + kdiffu = 0.5*(kdiff(k,cell1)+kdiff(k,cell2)) + + ! include 2nd-orer diffusion here + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & + + rho_edge(k,iEdge)* kdiffu * u_diffusion * meshScalingDel2(iEdge) + + end do + end do + + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + +!$OMP BARRIER + + do iVertex=vertexStart,vertexEnd + delsq_vorticity(1:nVertLevels,iVertex) = 0.0 + do i=1,vertexDegree + iEdge = edgesOnVertex(i,iVertex) + edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) + do k=1,nVertLevels + delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) + end do + end do + end do + + do iCell=cellStart,cellEnd + delsq_divergence(1:nVertLevels,iCell) = 0.0 + r = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) + do k=1,nVertLevels + delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) + end do + end do + end do + +!$OMP BARRIER + + do iEdge=edgeSolveStart,edgeSolveEnd + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + vertex1 = verticesOnEdge(1,iEdge) + vertex2 = verticesOnEdge(2,iEdge) + + u_mix_scale = meshScalingDel4(iEdge)*h_mom_eddy_visc4 + r_dc = u_mix_scale * config_del4u_div_factor * invDcEdge(iEdge) + r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) + +!DIR$ IVDEP + do k=1,nVertLevels + + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant + ! + ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor + ! relative to the rotational part. The stability constraint on the divergence component is much less + ! stringent than the rotational part, and this flexibility may be useful. + ! + u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & + -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion + + end do + end do + + end if ! 4th order mixing is active + + ! + ! vertical mixing for u - 2nd order filter in physical (z) space + ! + if ( v_mom_eddy_visc2 > 0.0 ) then + + if (config_mix_full) then ! mix full state + + do iEdge=edgeSolveStart,edgeSolveEnd + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=2,nVertLevels-1 + + z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) + z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) + z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) + z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & + (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) & + -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + else ! idealized cases where we mix on the perturbation from the initial 1-D state + + do iEdge=edgeSolveStart,edgeSolveEnd + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & + - v_init(k) * sin( angleEdge(iEdge) ) + end do + + do k=2,nVertLevels-1 + + z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) + z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) + z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) + z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & + (u_mix(k+1)-u_mix(k ))/(zp-z0) & + -(u_mix(k )-u_mix(k-1))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + end if ! mix perturbation state + + end if ! vertical mixing of horizontal momentum + + end subroutine u_dissipation + +!------------------------ + + subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, kdiff, rho_zz, & + tend_w_euler ) + + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + + implicit none + + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, intent(in) :: nCells, nEdges + + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 + real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: tend_w_euler + + ! storage passed in from calling routine + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_w + + ! local variables + + integer :: cell1, cell2, iEdge, iCell, i, k + real (kind=RKIND) :: r_areaCell, edge_sign, w_turb_flux + +! !OMP BARRIER why is this openmp barrier here??? + + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). + ! + ! First, storage to hold the result from the first del^2 computation. + ! we copied code from the theta mixing, hence the theta* names. + + + delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + tend_w_euler(1:nVertLevels+1,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + + edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + +!DIR$ IVDEP + do k=2,nVertLevels + + w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) + delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux + w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & + (kdiff(k,cell1)+kdiff(k,cell2)+kdiff(k-1,cell1)+kdiff(k-1,cell2)) + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux + end do + end do + end do + +!$OMP BARRIER + + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) + + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) + end do + + end do + end do + + end if ! 4th order mixing is active + + if ( v_mom_eddy_visc2 > 0.0 ) then ! vertical mixing + + do iCell=cellSolveStart,cellSolveEnd +!DIR$ IVDEP + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & + (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & + -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k) + end do + end do + + end if + + end subroutine w_dissipation + +!----------------------------------------------------- + + subroutine theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, kdiff, rho_zz, & + tend_theta_euler ) + + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + implicit none + + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, intent(in) :: nCells, nEdges + + logical, intent(in) :: config_mix_full + + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + real (kind=RKIND), intent(in) :: h_theta_eddy_visc4 + real (kind=RKIND), intent(in) :: v_theta_eddy_visc2 + real (kind=RKIND), intent(in) :: prandtl_inv + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + real (kind=RKIND), dimension(nVertLevels+1, nCells+1), intent(in) :: zgrid + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: t_init + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler + + ! storage passed in from calling routine + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_theta + + ! local variables + integer :: cell1, cell2, iEdge, iCell, i, k + real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale + real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp + + delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + tend_theta_euler(1:nVertLevels,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + pr_scale = prandtl_inv * meshScalingDel2(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) +!DIR$ IVDEP + do k=1,nVertLevels + +! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below + + theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) + delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux + theta_turb_flux = theta_turb_flux*0.5*(kdiff(k,cell1)+kdiff(k,cell2)) * pr_scale + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux + + end do + end do + end do + +!$OMP BARRIER + + if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active + + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + + iEdge = edgesOnCell(i,iCell) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) + end do + end do + end do + + end if ! 4th order mixing is active + + if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m + + if (config_mix_full) then + + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & + -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + else ! idealized cases where we mix on the perturbation from the initial 1-D state + + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & + -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + end if + + end if + + end subroutine theta_dissipation + end module mpas_atm_dissipation_models diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 97f3d85e25..1ae2abb219 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5461,203 +5461,16 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$OMP BARRIER - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). - ! First, storage to hold the result from the first del^2 computation. - - !$acc parallel default(present) - !$acc loop gang worker - do iEdge = edgeStart, edgeEnd - !$acc loop vector - do k = 1, nVertLevels - delsq_u(k,iEdge) = 0.0_RKIND - end do - end do - !$acc end parallel - - !$acc parallel default(present) - !$acc loop gang worker - do iEdge=edgeStart,edgeEnd - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - vertex1 = verticesOnEdge(1,iEdge) - vertex2 = verticesOnEdge(2,iEdge) - r_dc = invDcEdge(iEdge) - r_dv = min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) - -!DIR$ IVDEP - !$acc loop vector - do k=1,nVertLevels - - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant - u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & - -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv - - delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion - - kdiffu = 0.5*(kdiff(k,cell1)+kdiff(k,cell2)) - - ! include 2nd-orer diffusion here - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & - + rho_edge(k,iEdge)* kdiffu * u_diffusion * meshScalingDel2(iEdge) - - end do - end do - !$acc end parallel - - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active - -!$OMP BARRIER - - !$acc parallel default(present) - !$acc loop gang worker - do iVertex=vertexStart,vertexEnd - - !$acc loop vector - do k=1,nVertLevels - delsq_vorticity(k,iVertex) = 0.0_RKIND - end do - - !$acc loop seq - do i=1,vertexDegree - iEdge = edgesOnVertex(i,iVertex) - edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) - - !$acc loop vector - do k=1,nVertLevels - delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) - end do - end do - end do - - !$acc loop gang worker - do iCell=cellStart,cellEnd - - !$acc loop vector - do k=1,nVertLevels - delsq_divergence(k,iCell) = 0.0_RKIND - end do - - r = invAreaCell(iCell) - - !$acc loop seq - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) - - !$acc loop vector - do k=1,nVertLevels - delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) - end do - end do - end do - !$acc end parallel - -!$OMP BARRIER - - !$acc parallel default(present) - !$acc loop gang worker - do iEdge=edgeSolveStart,edgeSolveEnd - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - vertex1 = verticesOnEdge(1,iEdge) - vertex2 = verticesOnEdge(2,iEdge) - - u_mix_scale = meshScalingDel4(iEdge)*h_mom_eddy_visc4 - r_dc = u_mix_scale * config_del4u_div_factor * invDcEdge(iEdge) - r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) - -!DIR$ IVDEP - !$acc loop vector - do k=1,nVertLevels - - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant - ! - ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor - ! relative to the rotational part. The stability constraint on the divergence component is much less - ! stringent than the rotational part, and this flexibility may be useful. - ! - u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & - -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion - - end do - end do - !$acc end parallel - - end if ! 4th order mixing is active - - ! - ! vertical mixing for u - 2nd order filter in physical (z) space - ! - if ( v_mom_eddy_visc2 > 0.0 ) then - - if (config_mix_full) then ! mix full state - - !$acc parallel default(present) - !$acc loop gang worker - do iEdge=edgeSolveStart,edgeSolveEnd - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - !$acc loop vector - do k=2,nVertLevels-1 - - z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) - z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) - z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) - z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & - (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) & - -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - !$acc end parallel - - else ! idealized cases where we mix on the perturbation from the initial 1-D state - - !$acc parallel default(present) - !$acc loop gang worker private(u_mix) - do iEdge=edgeSolveStart,edgeSolveEnd - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - !$acc loop vector - do k=1,nVertLevels - u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & - - v_init(k) * sin( angleEdge(iEdge) ) - end do - - !$acc loop vector - do k=2,nVertLevels-1 - - z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) - z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) - z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) - z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & - (u_mix(k+1)-u_mix(k ))/(zp-z0) & - -(u_mix(k )-u_mix(k-1))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - !$acc end parallel - - end if ! mix perturbation state - - end if ! vertical mixing of horizontal momentum + call u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & + cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & + nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & + invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & + angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & + config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & + config_del4u_div_factor, zgrid, kdiff, & + delsq_u, delsq_vorticity, delsq_divergence, & + u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) end if ! (rk_step 1 test for computing mixing terms) @@ -5785,80 +5598,16 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then -! !OMP BARRIER why is this openmp barrier here??? - - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). - ! - ! First, storage to hold the result from the first del^2 computation. - ! we copied code from the theta mixing, hence the theta* names. - - !$acc parallel default(present) - !$acc loop gang worker - do iCell=cellStart,cellEnd - - !$acc loop vector - do k=1,nVertLevels - delsq_w(k,iCell) = 0.0_RKIND - end do - - !$acc loop vector - do k=1,nVertLevels+1 - tend_w_euler(k,iCell) = 0.0_RKIND - end do - - r_areaCell = invAreaCell(iCell) - - !$acc loop seq - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - - edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - -!DIR$ IVDEP - !$acc loop vector - do k=2,nVertLevels - - w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) - delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux - w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & - (kdiff(k,cell1)+kdiff(k,cell2)+kdiff(k-1,cell1)+kdiff(k-1,cell2)) - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux - end do - end do - end do - !$acc end parallel - -!$OMP BARRIER - - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active - - !$acc parallel default(present) - !$acc loop gang worker - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - - r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) - - !$acc loop seq - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) - - !$acc loop vector - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) - end do - - end do - end do - !$acc end parallel - - end if ! 4th order mixing is active + call w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, kdiff, rho_zz, & + tend_w_euler ) end if ! horizontal mixing for w computed in first rk_step @@ -5913,27 +5662,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end do !$acc end parallel - if (rk_step == 1) then - - if ( v_mom_eddy_visc2 > 0.0 ) then - - !$acc parallel default(present) - !$acc loop gang worker - do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP - !$acc loop vector - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & - (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & - -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k) - end do - end do - !$acc end parallel - - end if - - end if ! mixing term computed first rk_step - ! add in mixing terms for w !$acc parallel default(present) @@ -6024,69 +5752,17 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then - !$acc parallel default(present) - !$acc loop gang worker - do iCell=cellStart,cellEnd - - !$acc loop vector - do k=1,nVertLevels - delsq_theta(k,iCell) = 0.0_RKIND - tend_theta_euler(k,iCell) = 0.0_RKIND - end do - - r_areaCell = invAreaCell(iCell) - - !$acc loop seq - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - pr_scale = prandtl_inv * meshScalingDel2(iEdge) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) -!DIR$ IVDEP - !$acc loop vector - do k=1,nVertLevels - -! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below - - theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) - delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux - theta_turb_flux = theta_turb_flux*0.5*(kdiff(k,cell1)+kdiff(k,cell2)) * pr_scale - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux - - end do - end do - end do - !$acc end parallel - -!$OMP BARRIER - - if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active - - !$acc parallel default(present) - !$acc loop gang worker - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - - r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) - - !$acc loop seq - do i=1,nEdgesOnCell(iCell) - - iEdge = edgesOnCell(i,iCell) - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - !$acc loop vector - do k=1,nVertLevels - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) - end do - end do - end do - !$acc end parallel - - end if ! 4th order mixing is active + call theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, kdiff, rho_zz, & + tend_theta_euler ) end if ! theta mixing calculated first rk_step @@ -6127,73 +5803,12 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end do !$acc end parallel - ! - ! vertical mixing for theta - 2nd order - ! - - if (rk_step == 1) then - - if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m - - if (config_mix_full) then - - !$acc parallel default(present) - !$acc loop gang worker - do iCell = cellSolveStart,cellSolveEnd - - !$acc loop vector - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & - -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - !$acc end parallel - - else ! idealized cases where we mix on the perturbation from the initial 1-D state - - !$acc parallel default(present) - !$acc loop gang worker - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & - -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - !$acc end parallel - - end if - - end if - - end if ! compute vertical theta mixing on first rk_step - !$acc parallel default(present) !$acc loop gang worker do iCell = cellSolveStart,cellSolveEnd !DIR$ IVDEP !$acc loop vector do k=1,nVertLevels -! tend_theta(k,iCell) = tend_theta(k,iCell) + tend_theta_euler(k,iCell) tend_theta(k,iCell) = tend_theta(k,iCell) + tend_theta_euler(k,iCell) + tend_rtheta_physics(k,iCell) end do end do From 93d2ac51f461aad9d61e46ee0628496675b97ed7 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 6 Jan 2020 13:16:23 -0700 Subject: [PATCH 044/214] Added initialization for convective boundary layer LES case. This is config_init_case = 10 --- .../mpas_init_atm_cases.F | 577 +++++++++++++++++- 1 file changed, 576 insertions(+), 1 deletion(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 673ebfc525..82b2517e76 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -393,13 +393,30 @@ subroutine init_atm_setup_case(domain, stream_manager) call init_atm_case_cam_mpas(stream_manager, domain % dminfo, block_ptr, & mesh, block_ptr % dimensions, block_ptr % configs, nVertLevels) + else if (config_init_case == 10) then + + call mpas_log_write(' les test case ') + block_ptr => domain % blocklist + do while (associated(block_ptr)) + + call mpas_pool_get_dimension(block_ptr % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) + + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block_ptr % structs, 'state', state) + call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) + + call mpas_log_write(' calling test case setup ') + call init_atm_case_les(domain % dminfo, mesh, nCells, nVertLevels, state, diag, config_init_case, block_ptr % configs) + call decouple_variables(mesh, nCells, nVertLevels, state, diag) + call mpas_log_write(' returned from test case setup ') block_ptr => block_ptr % next end do else call mpas_log_write(' ***********************************************************', messageType=MPAS_LOG_ERR) - call mpas_log_write(' Only test cases 1 through 9 and 13 are currently supported.', messageType=MPAS_LOG_ERR) + call mpas_log_write(' Only test cases 1 through 10 and 13 are currently supported.', messageType=MPAS_LOG_ERR) call mpas_log_write(' ***********************************************************', messageType=MPAS_LOG_CRIT) end if @@ -6184,6 +6201,564 @@ subroutine init_atm_case_lbc(timestamp, block, mesh, nCells, nEdges, nVertLevels end subroutine init_atm_case_lbc +!--------------------- + + subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, test_case, configs) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Large Eddy Simulation (les) test case setup + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + implicit none + + type (dm_info), intent(in) :: dminfo + type (mpas_pool_type), intent(inout) :: mesh + integer, intent(in) :: nCells + integer, intent(in) :: nVertLevels + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout):: configs + + integer, intent(in) :: test_case + + real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp + real (kind=RKIND), dimension(:,:), pointer :: zgrid, zxu, zz, hx, cqw + real (kind=RKIND), dimension(:,:), pointer :: ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, dss, t, rt, u, ru + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 + + !This is temporary variable here. It just need when calculate tangential velocity v. + integer :: eoe, j + integer, dimension(:), pointer :: nEdgesOnEdge + integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge + real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge + + integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, cell1, cell2 + integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve + integer, pointer :: index_qv + + real (kind=RKIND), dimension(nVertLevels + 1 ) :: znu, znw, znwc, znwv + real (kind=RKIND), dimension(nVertLevels + 1 ) :: znuc, znuv + + real (kind=RKIND), dimension(nVertLevels + 1 ) :: zc, zw, ah + real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm + + real (kind=RKIND), dimension(nVertLevels, nCells) :: relhum, thi, tbi, cqwb + + real (kind=RKIND) :: r, xnutr + real (kind=RKIND) :: ztemp, zd, zt, dz, str + + real (kind=RKIND), dimension(nVertLevels ) :: qvb + real (kind=RKIND), dimension(nVertLevels ) :: t_init_1d + + real (kind=RKIND) :: d1, d2, d3, cof1, cof2 + real (kind=RKIND), pointer :: cf1, cf2, cf3 + real (kind=RKIND) :: ztr, thetar, ttr, thetas, um, us, zts, pitop, pibtop, ptopb, ptop, rcp, rcv, p0 + real (kind=RKIND) :: radx, radz, zcent, xmid, delt, xloc, rad, yloc, ymid, a_scale + real (kind=RKIND) :: pres, temp, es, qvs + + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell, areaTriangle + real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + logical, pointer :: on_a_sphere + real (kind=RKIND), pointer :: sphere_radius + real (kind=RKIND), pointer :: config_ztop + + real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta + real (kind=RKIND), dimension(:), pointer :: u_init, qv_init, angleEdge, fEdge, fVertex + real (kind=RKIND) :: u_vel, v_vel, randx + + call mpas_pool_get_array(mesh, 'xCell', xCell) + call mpas_pool_get_array(mesh, 'yCell', yCell) + call mpas_pool_get_array(mesh, 'zCell', zCell) + call mpas_pool_get_array(mesh, 'xEdge', xEdge) + call mpas_pool_get_array(mesh, 'yEdge', yEdge) + call mpas_pool_get_array(mesh, 'zEdge', zEdge) + call mpas_pool_get_array(mesh, 'xVertex', xVertex) + call mpas_pool_get_array(mesh, 'yVertex', yVertex) + call mpas_pool_get_array(mesh, 'zVertex', zVertex) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + + call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) + call mpas_pool_get_config(configs, 'config_ztop', config_ztop) + + ! + ! Scale all distances + ! + + a_scale = 1.0 + + xCell(:) = xCell(:) * a_scale + yCell(:) = yCell(:) * a_scale + zCell(:) = zCell(:) * a_scale + xVertex(:) = xVertex(:) * a_scale + yVertex(:) = yVertex(:) * a_scale + zVertex(:) = zVertex(:) * a_scale + xEdge(:) = xEdge(:) * a_scale + yEdge(:) = yEdge(:) * a_scale + zEdge(:) = zEdge(:) * a_scale + dvEdge(:) = dvEdge(:) * a_scale + dcEdge(:) = dcEdge(:) * a_scale + areaCell(:) = areaCell(:) * a_scale**2.0 + areaTriangle(:) = areaTriangle(:) * a_scale**2.0 + kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 + + call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(mesh, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'maxEdges', maxEdges) + nz1 = nVertLevels + nz = nz1 + 1 + + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'zb', zb) + call mpas_pool_get_array(mesh, 'zb3', zb3) + call mpas_pool_get_array(mesh, 'rdzw', rdzw) + call mpas_pool_get_array(mesh, 'dzu', dzu) + call mpas_pool_get_array(mesh, 'rdzu', rdzu) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + call mpas_pool_get_array(mesh, 'zxu', zxu) + call mpas_pool_get_array(mesh, 'zz', zz) + call mpas_pool_get_array(mesh, 'hx', hx) + call mpas_pool_get_array(mesh, 'dss', dss) + call mpas_pool_get_array(mesh, 't_init', t_init) + call mpas_pool_get_array(mesh, 'u_init', u_init) + call mpas_pool_get_array(mesh, 'qv_init', qv_init) + call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) + call mpas_pool_get_array(mesh, 'fEdge', fEdge) + call mpas_pool_get_array(mesh, 'fVertex', fVertex) + + call mpas_pool_get_array(mesh, 'cf1', cf1) + call mpas_pool_get_array(mesh, 'cf2', cf2) + call mpas_pool_get_array(mesh, 'cf3', cf3) + + call mpas_pool_get_array(diag, 'pressure_base', ppb) + call mpas_pool_get_array(diag, 'exner_base', pb) + call mpas_pool_get_array(diag, 'rho_base', rb) + call mpas_pool_get_array(diag, 'theta_base', tb) + call mpas_pool_get_array(diag, 'rtheta_base', rtb) + call mpas_pool_get_array(diag, 'exner', p) + call mpas_pool_get_array(diag, 'cqw', cqw) + + call mpas_pool_get_array(diag, 'pressure_p', pp) + call mpas_pool_get_array(diag, 'rho_p', rr) + call mpas_pool_get_array(diag, 'rtheta_p', rt) + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(diag, 'rw', rw) + call mpas_pool_get_array(diag, 'v', v) + call mpas_pool_get_array(diag, 'rho', rho) + call mpas_pool_get_array(diag, 'theta', theta) + + call mpas_pool_get_array(state, 'rho_zz', rho_zz) + call mpas_pool_get_array(state, 'theta_m', t) + call mpas_pool_get_array(state, 'u', u) + call mpas_pool_get_array(state, 'w', w) + call mpas_pool_get_array(state, 'scalars', scalars) + + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + + scalars(:,:,:) = 0. + + call atm_initialize_advection_rk(mesh, nCells, nEdges, maxEdges, on_a_sphere, sphere_radius ) + call atm_initialize_deformation_weights(mesh, nCells, on_a_sphere, sphere_radius) + + xnutr = 0. + zd = 12000. + + p0 = 1.e+05 + rcp = rgas/cp + rcv = rgas/(cp-rgas) + + call mpas_log_write(' point 1 in test case setup ') + +! We may pass in an hx(:,:) that has been precomputed elsewhere. +! For now it is independent of k + + do iCell=1,nCells + do k=1,nz + hx(k,iCell) = 0. ! les on a flat Cartesian plane + end do + end do + +! write(0,*) ' dz = ',dz + call mpas_log_write(' hx computation complete ') + + ! metrics for hybrid coordinate and vertical stretching + + str = 1.0 ! no stretching in les case: constant dz + ! zt = 20000. + zt = config_ztop + dz = zt/float(nz1) + + + do k=1,nz + + ! zw(k) = zt*(real(k-1)*dz/zt)**str + zw(k) = float(k-1)*dz + zc(k) = zw(k) +! +! ah(k) governs the transition between terrain-following +! and pureheight coordinates +! ah(k) = 0 is a terrain-following coordinate +! ah(k) = 1 is a height coordinate + +! ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6 + ah(k) = 1. +! call mpas_log_write(' k, zc, zw, ah = $i $r $r $r', intArgs=(/k/), realArgs=(/zc(k),zw(k),ah(k)/)) + end do + do k=1,nz1 + dzw (k) = zw(k+1)-zw(k) + rdzw(k) = 1./dzw(k) + zu(k ) = .5*(zw(k)+zw(k+1)) + end do + do k=2,nz1 + dzu (k) = .5*(dzw(k)+dzw(k-1)) + rdzu(k) = 1./dzu(k) + fzp (k) = .5* dzw(k )/dzu(k) + fzm (k) = .5* dzw(k-1)/dzu(k) + rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1))) + rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1))) + end do + +!********** how are we storing cf1, cf2 and cf3? + + COF1 = (2.*DZU(2)+DZU(3))/(DZU(2)+DZU(3))*DZW(1)/DZU(2) + COF2 = DZU(2) /(DZU(2)+DZU(3))*DZW(1)/DZU(3) + CF1 = FZP(2) + COF1 + CF2 = FZM(2) - COF1 - COF2 + CF3 = COF2 + + do iCell=1,nCells + do k=1,nz + zgrid(k,iCell) = ah(k)*(zc(k)*(1.-hx(k,iCell)/zt)+hx(k,iCell)) & + + (1.-ah(k)) * zc(k) + end do + do k=1,nz1 + zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell)) + end do + end do + + do i=1, nEdges + iCell1 = cellsOnEdge(1,i) + iCell2 = cellsOnEdge(2,i) + do k=1,nz1 + zxu (k,i) = 0.5 * (zgrid(k,iCell2)-zgrid(k,iCell1) + zgrid(k+1,iCell2)-zgrid(k+1,iCell1)) / dcEdge(i) + end do + end do + do i=1, nCells + do k=1,nz1 + ztemp = .5*(zgrid(k+1,i)+zgrid(k,i)) + dss(k,i) = 0. + ztemp = zgrid(k,i) + if(ztemp.gt.zd+.1) then + dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2 + end if + end do + end do + +! +! initialization +! + do i=1,nCells + do k=1,nz1 + + ztemp = .5*(zgrid(k,i)+zgrid(k+1,i)) + + ! if(ztemp .gt. ztr) then + ! t (k,i) = thetar*exp(9.8*(ztemp-ztr)/(1003.*ttr)) + ! relhum(k,i) = 0.25 + ! else + ! t (k,i) = 300.+43.*(ztemp/ztr)**1.25 + ! relhum(k,i) = (1.-0.75*(ztemp/ztr)**1.25) + ! if(t(k,i).lt.thetas) t(k,i) = thetas + ! end if + + t(k,i) = atm_get_sounding('theta',ztemp) + scalars(index_qv,k,i) = atm_get_sounding('qv',ztemp) + + tb(k,i) = t(k,i) + thi(k,i) = t(k,i) + tbi(k,i) = t(k,i) + cqw(k,i) = 1. + cqwb(k,i) = 1. + end do + end do + +! set the velocity field - we are on a plane here. + + do i=1, nEdges + cell1 = cellsOnEdge(1,i) + cell2 = cellsOnEdge(2,i) + if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then + do k=1,nz1 + ztemp = .25*( zgrid(k,cell1 )+zgrid(k+1,cell1 ) & + +zgrid(k,cell2)+zgrid(k+1,cell2)) + u_vel = atm_get_sounding('u',ztemp) + v_vel = atm_get_sounding('v',ztemp) + u(k,i) = cos(angleEdge(i))*u_vel - sin(angleEdge(i))*v_vel + if(i == 1 ) u_init(k) = u(k,i) + end do + end if + end do + + call mpas_dmpar_bcast_reals(dminfo, nz1, u_init) + +! +! for reference sounding +! + do itr=1,30 + + pitop = 1.-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1)) + pibtop = 1.-.5*dzw(1)*gravity*(1.+qvb(1))/(cp*tb(1,1)*zz(1,1)) + do k=2,nz1 + pitop = pitop-dzu(k)*gravity/(cp*cqw(k,1)*.5*(t(k,1)+t(k-1,1)) & + *.5*(zz(k,1)+zz(k-1,1))) + pibtop = pibtop-dzu(k)*gravity/(cp*cqwb(k,1)*.5*(tb(k,1)+tb(k-1,1)) & + *.5*(zz(k,1)+zz(k-1,1))) + + !call mpas_log_write('$i $r $r $r $r', intArgs=(/k/), realArgs=(/pitop,tb(k,1),dzu(k),tb(k,1)/)) + end do + pitop = pitop-.5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1)) + pibtop = pibtop-.5*dzw(nz1)*gravity*(1.+qvb(nz1))/(cp*tb(nz1,1)*zz(nz1,1)) + + call mpas_dmpar_bcast_real(dminfo, pitop) + call mpas_dmpar_bcast_real(dminfo, pibtop) + + ptopb = p0*pibtop**(1./rcp) + call mpas_log_write('ptopb = $r', realArgs=(/0.01_RKIND*ptopb/)) + + do i=1, nCells + pb(nz1,i) = pibtop+.5*dzw(nz1)*gravity*(1.+qvb(nz1))/(cp*tb(nz1,i)*zz(nz1,i)) + p (nz1,i) = pitop+.5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,i))/(cp*t (nz1,i)*zz(nz1,i)) + do k=nz1-1,1,-1 + pb(k,i) = pb(k+1,i) + dzu(k+1)*gravity/(cp*cqwb(k+1,i)*.5*(tb(k,i)+tb(k+1,i)) & + *.5*(zz(k,i)+zz(k+1,i))) + p (k,i) = p (k+1,i) + dzu(k+1)*gravity/(cp*cqw(k+1,i)*.5*(t (k,i)+t (k+1,i)) & + *.5*(zz(k,i)+zz(k+1,i))) + end do + do k=1,nz1 + rb (k,i) = pb(k,i)**(1./rcv)/((rgas/p0)*tb(k,i)*zz(k,i)) + rtb(k,i) = rb(k,i)*tb(k,i) + rr (k,i) = p (k,i)**(1./rcv)/((rgas/p0)*t (k,i)*zz(k,i))-rb(k,i) + ppb(k,i) = p0*(zz(k,i)*rgas*rtb(k,i)/p0)**(cp/cv) + end do + end do + + ! + ! update water vapor mixing ratio from humidity profile + ! + ! do i= 1,nCells + ! do k=1,nz1 + ! temp = p(k,i)*thi(k,i) + ! pres = p0*p(k,i)**(1./rcp) + ! qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres + ! scalars(index_qv,k,i) = min(0.014_RKIND,relhum(k,i)*qvs) + ! end do + ! end do + + do k=1,nz1 +!********************************************************************* +! QVB = QV INCLUDES MOISTURE IN REFERENCE STATE +! qvb(k) = scalars(index_qv,k,1) +! QVB = 0 PRODUCES DRY REFERENCE STATE + qvb(k) = 0. +!********************************************************************* + end do + + do i= 1,nCells + do k=1,nz1 + t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) + tb(k,i) = tbi(k,i)*(1.+1.61*qvb(k)) + end do + do k=2,nz1 + cqw (k,i) = 1./(1.+.5*(scalars(index_qv,k,i)+scalars(index_qv,k-1,i))) + cqwb(k,i) = 1./(1.+.5*(qvb(k)+qvb(k-1))) + end do + end do + + end do !end of iteration loop + + call mpas_log_write(' base state sounding ') + call mpas_log_write(' k, pb, rb, tb, rtb, t, rr, p, qvb') + do k=1,nVertLevels + call mpas_log_write('$i $r $r $r $r $r $r $r $r', intArgs=(/k/), realArgs=(/pb(k,1),rb(k,1),tb(k,1),rtb(k,1),t(k,1),rr(k,1),p(k,1),qvb(k)/)) + end do + +! +! potential temperature perturbation +! + + do i=1,nCells + do k = 1,4 ! same as in WRF + call random_number(randx) + thi(k,i) = thi(k,i) + 0.1*(randx-0.5) + t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) + end do + end do + + do itr=1,30 + + pitop = 1.-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1)) + do k=2,nz1 + pitop = pitop-dzu(k)*gravity/(cp*cqw(k,1)*.5*(t (k,1)+t (k-1,1)) & + *.5*(zz(k,1)+zz(k-1,1))) + end do + pitop = pitop - .5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1)) + ptop = p0*pitop**(1./rcp) + call mpas_log_write('ptop = $r $r', realArgs=(/0.01_RKIND*ptop, 0.01_RKIND*ptopb/)) + + call mpas_dmpar_bcast_real(dminfo, ptop) + + do i = 1, nCells + + pp(nz1,i) = ptop-ptopb+.5*dzw(nz1)*gravity* & + (rr(nz1,i)+(rr(nz1,i)+rb(nz1,i))*scalars(index_qv,nz1,i)) + do k=nz1-1,1,-1 +! pp(k,i) = pp(k+1,i)+.5*dzu(k+1)*gravity* & +! (rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i) & +! +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i)) + pp(k,i) = pp(k+1,i)+dzu(k+1)*gravity*( & + fzm(k+1)*(rb(k+1,i)*(scalars(index_qv,k+1,i)-qvb(k+1)) & + +rr(k+1,i)*(1.+scalars(index_qv,k+1,i))) & + +fzp(k+1)*(rb(k ,i)*(scalars(index_qv,k ,i)-qvb(k)) & + +rr(k ,i)*(1.+scalars(index_qv,k ,i)))) + end do + if (itr==1.and.i==1) then + do k=1,nz1 + call mpas_log_write('pp-check $r', realArgs=(/pp(k,i)/)) + end do + end if + do k=1,nz1 + rt(k,i) = (pp(k,i)/(rgas*zz(k,i)) & + -rtb(k,i)*(p(k,i)-pb(k,i)))/p(k,i) + p (k,i) = (zz(k,i)*(rgas/p0)*(rtb(k,i)+rt(k,i)))**rcv + rr(k,i) = (rt(k,i)-rb(k,i)*(t(k,i)-tb(k,i)))/t(k,i) + end do + + end do ! loop over cells + + end do ! iteration loop +!---------------------------------------------------------------------- +! + do k=1,nz1 + qv_init(k) = scalars(index_qv,k,1) + end do + + t_init_1d(:) = t(:,1) + call mpas_dmpar_bcast_reals(dminfo, nz1, t_init_1d) + call mpas_dmpar_bcast_reals(dminfo, nz1, qv_init) + + do i=1,nCells + do k=1,nz1 + t_init(k,i) = t_init_1d(k) + rho_zz(k,i) = rb(k,i)+rr(k,i) + end do + end do + + do i=1,nEdges + cell1 = cellsOnEdge(1,i) + cell2 = cellsOnEdge(2,i) + if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then + do k=1,nz1 + ru (k,i) = 0.5*(rho_zz(k,cell1)+rho_zz(k,cell2))*u(k,i) + end do + end if + end do + + + ! + ! we are assuming w and rw are zero for this initialization + ! i.e., no terrain + ! + rw = 0.0 + w = 0.0 + + zb = 0.0 + zb3 = 0.0 + + ! + ! Generate rotated Coriolis field - same settings as in WRF + ! + do iEdge=1,nEdges + fEdge(iEdge) = 1.e-04 + end do + + do iVtx=1,nVertices + fVertex(iVtx) = 1.e-04 + end do + + ! + ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells) + ! + v(:,:) = 0.0 + do iEdge = 1, nEdges + do i=1,nEdgesOnEdge(iEdge) + eoe = edgesOnEdge(i,iEdge) + if (eoe > 0) then + do k = 1, nVertLevels + v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe) + end do + end if + end do + end do + + ! call mpas_log_write(' k,u_init, t_init, qv_init ') + ! do k=1,nVertLevels + ! call mpas_log_write('$i $r $r $r', intArgs=(/k/), realArgs=(/u_init(k),t_init(k,1),qv_init(k)/)) + ! end do + + ! Compute rho and theta from rho_zz and theta_m + do iCell=1,nCells + do k=1,nVertLevels + rho(k,iCell) = rho_zz(k,iCell) * zz(k,iCell) + theta(k,iCell) = t(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell)) + end do + end do + + end subroutine init_atm_case_les + + + real (kind=RKIND) function atm_get_sounding( variable, height ) + + implicit none + real (kind=RKIND), intent(in) :: height + character(len=*), intent(in) :: variable + + atm_get_sounding = -999. + + if(variable == 'u') then + atm_get_sounding = 0. + else if (variable == 'v') then + atm_get_sounding = 0. + else if (variable == 'qv') then + atm_get_sounding = 0. + else if (variable == 'theta') then + + if(height .le. 1000.) then + atm_get_sounding = 300. + else if(height .le. 1150.) then + atm_get_sounding = 300. + (height-1000.)*8./150. + else + atm_get_sounding = 308. + (height-1150.)*3./1000. + end if + + end if + + end function atm_get_sounding + +!----------- !----------------------------------------------------------------------- ! routine init_atm_case_cam_mpas From c5eb44e4615ababeaace7e7407b741d474346f67 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 7 Jan 2020 16:13:08 -0700 Subject: [PATCH 045/214] add calcalate_n2 routine (no functional code yet) --- .../dynamics/mpas_atm_dissipation_models.F | 15 +++++++++++++ .../dynamics/mpas_atm_time_integration.F | 21 +++++++++++++------ 2 files changed, 30 insertions(+), 6 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index af983af979..9431a6295f 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -9,6 +9,7 @@ module mpas_atm_dissipation_models use mpas_kind_types, only : RKIND + use mpas_atmphys_constants contains @@ -74,6 +75,20 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, end subroutine smagorinsky_2d +!--------------------------------------- + + subroutine calculate_n2(bn2, theta, scalars, num_scalars, index_qv, cellStart, cellEnd, nCells) + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + + integer, intent(in) :: cellStart, cellEnd, nCells + integer, intent(in) :: index_qv + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: bn2 + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta + real (kind=RKIND), dimension(:,:,:) :: scalars + + end subroutine calculate_n2 + !--------------------------------------- subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 1ae2abb219..d083f25233 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4777,7 +4777,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:), pointer :: fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, & meshScalingDel2, meshScalingDel4 real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & - divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & + divergence, vorticity, ke, pv_edge, theta_m, theta, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save @@ -4832,6 +4832,10 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, logical, pointer :: config_rayleigh_damp_u real (kind=RKIND), pointer :: config_rayleigh_damp_u_timescale_days integer, pointer :: config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels + integer, pointer :: config_number_rayleigh_damp_u_levels + integer, pointer :: index_qv + + logical :: inactive_rthdynten call mpas_pool_get_config(mesh, 'sphere_radius', r_earth) @@ -4860,6 +4864,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(state, 'w', w, 2) call mpas_pool_get_array(state, 'theta_m', theta_m, 2) call mpas_pool_get_array(state, 'theta_m', theta_m_save, 1) + call mpas_pool_get_array(state, 'theta', theta, 2) call mpas_pool_get_array(state, 'scalars', scalars, 2) call mpas_pool_get_array(diag, 'uReconstructZonal', ur_cell) @@ -4954,6 +4959,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) call mpas_pool_get_dimension(state, 'moist_start', moist_start) call mpas_pool_get_dimension(state, 'moist_end', moist_end) + call mpas_pool_get_dimension(state, 'index_qv', index_qv) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) @@ -4966,10 +4972,10 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(mesh, 'cf3', cf3) call atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels, & - nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, moist_start, moist_end, & + nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, index_qv, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & - divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & + divergence, vorticity, ke, pv_edge, theta_m, theta, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & @@ -4992,10 +4998,10 @@ end subroutine atm_compute_dyn_tend subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dummy, & - nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, moist_start, moist_end, & + nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & - divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & + divergence, vorticity, ke, pv_edge, theta_m, theta, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & @@ -5025,7 +5031,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! Dummy arguments ! integer :: nCells, nEdges, nVertices, nVertLevels_dummy, nCellsSolve, nEdgesSolve, vertexDegree, & - maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, moist_start, moist_end + maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, moist_start, moist_end real (kind=RKIND), dimension(nEdges+1) :: fEdge real (kind=RKIND), dimension(nEdges+1) :: dvEdge @@ -5049,6 +5055,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: ke real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: pv_edge real (kind=RKIND), dimension(nVertLevels,nCells+1) :: theta_m + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: theta real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_rho real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rt_diabatic_tend @@ -5065,6 +5072,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: cqu real (kind=RKIND), dimension(nVertLevels,nCells+1) :: h_divergence real (kind=RKIND), dimension(nVertLevels,nCells+1) :: kdiff + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: bn2 real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign real (kind=RKIND), dimension(vertexDegree,nVertices+1) :: edgesOnVertex_sign real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw_save @@ -5274,6 +5282,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if (config_les_model == "3d_smagorinsky") then ! call to 3D smagorinsky here... + call calculate_n2(bn2, theta, scalars, num_scalars, index_qv, cellStart, cellEnd, nCells) end if From b18f3e2e29f9a753d2f5cc3abc18d83ac2c0493b Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 8 Jan 2020 14:00:15 -0700 Subject: [PATCH 046/214] add to arg list of calculate_n2 --- .../dynamics/mpas_atm_dissipation_models.F | 17 +++++++++++++---- .../dynamics/mpas_atm_time_integration.F | 3 ++- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 9431a6295f..8d82678441 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -77,16 +77,25 @@ end subroutine smagorinsky_2d !--------------------------------------- - subroutine calculate_n2(bn2, theta, scalars, num_scalars, index_qv, cellStart, cellEnd, nCells) + subroutine calculate_n2( bn2, theta, exner, pressure_b, pp, zgrid, scalars, index_qv, & + cellStart, cellEnd, nCells) - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + use mpas_atm_dimensions ! pull nVertLevels and num_scalars from here integer, intent(in) :: cellStart, cellEnd, nCells integer, intent(in) :: index_qv real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: bn2 - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta - real (kind=RKIND), dimension(:,:,:) :: scalars + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta, exner, pressure_b, pp + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars + do iCell = cellStart,cellEnd +!DIR$ IVDEP + do k=1, nVertLevels + ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 + bn2(k,iCell) = 0. + end do + end do end subroutine calculate_n2 !--------------------------------------- diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index d083f25233..0f62fc2aa1 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5282,7 +5282,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if (config_les_model == "3d_smagorinsky") then ! call to 3D smagorinsky here... - call calculate_n2(bn2, theta, scalars, num_scalars, index_qv, cellStart, cellEnd, nCells) + call calculate_n2( bn2, theta, exner, pressure_b, pp, zgrid, scalars, index_qv, & + cellStart, cellEnd, nCells) end if From a6336368bde6fb76e1be44babe129346a5c1c39c Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 16 Jan 2020 10:54:29 -0700 Subject: [PATCH 047/214] add dry N^2 --- .../dynamics/mpas_atm_dissipation_models.F | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 8d82678441..43b89248b6 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -88,13 +88,19 @@ subroutine calculate_n2( bn2, theta, exner, pressure_b, pp, zgrid, scalars, inde real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta, exner, pressure_b, pp real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars +! local + real (kind=RKIND) :: dz + do iCell = cellStart,cellEnd !DIR$ IVDEP - do k=1, nVertLevels + do k=2, nVertLevels-1 ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 - bn2(k,iCell) = 0. + dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) + bn2(k,iCell) = gravity * (theta(k+1,iCell) - theta(k-1,iCell) ) / theta(k,iCell) / dz end do + bn2(1,iCell) = bn2(2,iCell) + bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) end do end subroutine calculate_n2 From d42a459d967d230e4a999a1c3a29c31e1dec5cf4 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 17 Jan 2020 11:31:38 -0700 Subject: [PATCH 048/214] fix theta to be in diag pool --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 0f62fc2aa1..f8c0ee7d4b 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4864,9 +4864,9 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(state, 'w', w, 2) call mpas_pool_get_array(state, 'theta_m', theta_m, 2) call mpas_pool_get_array(state, 'theta_m', theta_m_save, 1) - call mpas_pool_get_array(state, 'theta', theta, 2) call mpas_pool_get_array(state, 'scalars', scalars, 2) + call mpas_pool_get_array(diag, 'theta', theta) call mpas_pool_get_array(diag, 'uReconstructZonal', ur_cell) call mpas_pool_get_array(diag, 'uReconstructMeridional', vr_cell) call mpas_pool_get_array(diag, 'rho_edge', rho_edge) From f0fc10df7424091c79d53ba52bf454bf1a83fbf0 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 17 Jan 2020 15:52:59 -0700 Subject: [PATCH 049/214] fix to use theta_m and qv instead of non-updated theta --- .../dynamics/mpas_atm_dissipation_models.F | 11 +++++++---- .../dynamics/mpas_atm_time_integration.F | 10 ++++------ 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 43b89248b6..df7df75521 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -77,7 +77,7 @@ end subroutine smagorinsky_2d !--------------------------------------- - subroutine calculate_n2( bn2, theta, exner, pressure_b, pp, zgrid, scalars, index_qv, & + subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, & cellStart, cellEnd, nCells) use mpas_atm_dimensions ! pull nVertLevels and num_scalars from here @@ -85,19 +85,22 @@ subroutine calculate_n2( bn2, theta, exner, pressure_b, pp, zgrid, scalars, inde integer, intent(in) :: cellStart, cellEnd, nCells integer, intent(in) :: index_qv real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: bn2 - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta, exner, pressure_b, pp + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m, exner, pressure_b, pp real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local - real (kind=RKIND) :: dz + real (kind=RKIND) :: dz, theta do iCell = cellStart,cellEnd !DIR$ IVDEP do k=2, nVertLevels-1 ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 + theta = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) + thetap = theta_m(k+1,iCell) / (1._RKIND + rvord * scalars(index_qv,k+1,iCell)) + thetam = theta_m(k-1,iCell) / (1._RKIND + rvord * scalars(index_qv,k-1,iCell)) dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) - bn2(k,iCell) = gravity * (theta(k+1,iCell) - theta(k-1,iCell) ) / theta(k,iCell) / dz + bn2(k,iCell) = gravity * (thetap - thetam ) / theta / dz end do bn2(1,iCell) = bn2(2,iCell) bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index f8c0ee7d4b..00f935e311 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4777,7 +4777,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:), pointer :: fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, & meshScalingDel2, meshScalingDel4 real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & - divergence, vorticity, ke, pv_edge, theta_m, theta, rw, tend_rho, & + divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save @@ -4866,7 +4866,6 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(state, 'theta_m', theta_m_save, 1) call mpas_pool_get_array(state, 'scalars', scalars, 2) - call mpas_pool_get_array(diag, 'theta', theta) call mpas_pool_get_array(diag, 'uReconstructZonal', ur_cell) call mpas_pool_get_array(diag, 'uReconstructMeridional', vr_cell) call mpas_pool_get_array(diag, 'rho_edge', rho_edge) @@ -4975,7 +4974,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, index_qv, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & - divergence, vorticity, ke, pv_edge, theta_m, theta, rw, tend_rho, & + divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & @@ -5001,7 +5000,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & - divergence, vorticity, ke, pv_edge, theta_m, theta, rw, tend_rho, & + divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & @@ -5055,7 +5054,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: ke real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: pv_edge real (kind=RKIND), dimension(nVertLevels,nCells+1) :: theta_m - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: theta real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_rho real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rt_diabatic_tend @@ -5282,7 +5280,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if (config_les_model == "3d_smagorinsky") then ! call to 3D smagorinsky here... - call calculate_n2( bn2, theta, exner, pressure_b, pp, zgrid, scalars, index_qv, & + call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, & cellStart, cellEnd, nCells) end if From 116368b7943c13ad4f3debf55dde5ec7c7329b3d Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 17 Jan 2020 16:15:04 -0700 Subject: [PATCH 050/214] use local 1d theta array for efficiency --- .../dynamics/mpas_atm_dissipation_models.F | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index df7df75521..987611a584 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -89,22 +89,24 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local - real (kind=RKIND) :: dz, theta + real (kind=RKIND) :: dz + real (kind=RKIND), dimension(nVertLevels) :: theta do iCell = cellStart,cellEnd !DIR$ IVDEP + do k=1, nVertLevels + theta(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) + end do do k=2, nVertLevels-1 ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 - theta = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) - thetap = theta_m(k+1,iCell) / (1._RKIND + rvord * scalars(index_qv,k+1,iCell)) - thetam = theta_m(k-1,iCell) / (1._RKIND + rvord * scalars(index_qv,k-1,iCell)) dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) - bn2(k,iCell) = gravity * (thetap - thetam ) / theta / dz + bn2(k,iCell) = gravity * (theta(k+1) - theta(k-1) ) / theta(k) / dz end do bn2(1,iCell) = bn2(2,iCell) bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) end do + end subroutine calculate_n2 !--------------------------------------- From b673e28325a2f024dc7207d6a74fd05aecf4df97 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 24 Jan 2020 11:16:18 -0700 Subject: [PATCH 051/214] add qtot drag term to thetav in dry case --- .../dynamics/mpas_atm_dissipation_models.F | 12 +++++++----- .../dynamics/mpas_atm_time_integration.F | 2 +- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 987611a584..db0492e262 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -77,7 +77,7 @@ end subroutine smagorinsky_2d !--------------------------------------- - subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, & + subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, qtot, & cellStart, cellEnd, nCells) use mpas_atm_dimensions ! pull nVertLevels and num_scalars from here @@ -85,23 +85,25 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in integer, intent(in) :: cellStart, cellEnd, nCells integer, intent(in) :: index_qv real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: bn2 - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m, exner, pressure_b, pp + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m, exner, pressure_b, pp, qtot real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local real (kind=RKIND) :: dz - real (kind=RKIND), dimension(nVertLevels) :: theta + real (kind=RKIND), dimension(nVertLevels) :: thetav do iCell = cellStart,cellEnd !DIR$ IVDEP do k=1, nVertLevels - theta(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) +! qtot is qv plus all species - thetav includes moist loading (rvord-1 gives 0.61 * qv) + thetav(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) & + * (1._RKIND + rvord * scalars(index_qv,k,iCell) - qtot(k, iCell)) end do do k=2, nVertLevels-1 ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) - bn2(k,iCell) = gravity * (theta(k+1) - theta(k-1) ) / theta(k) / dz + bn2(k,iCell) = gravity * (thetav(k+1) - thetav(k-1) ) / thetav(k) / dz end do bn2(1,iCell) = bn2(2,iCell) bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 00f935e311..2c6a1f4a57 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5280,7 +5280,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if (config_les_model == "3d_smagorinsky") then ! call to 3D smagorinsky here... - call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, & + call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, qtot, & cellStart, cellEnd, nCells) end if From a9d7bfa108cf1468350658671ac16d5f5220dd9f Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Mon, 27 Jan 2020 15:07:00 -0700 Subject: [PATCH 052/214] add cloudy conditions N2 calculation following WRF and Durran and Klemp (1982) --- .../dynamics/mpas_atm_dissipation_models.F | 40 ++++++++++++++----- .../dynamics/mpas_atm_time_integration.F | 11 ++--- 2 files changed, 37 insertions(+), 14 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index db0492e262..6605e0bad4 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -77,36 +77,58 @@ end subroutine smagorinsky_2d !--------------------------------------- - subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, qtot, & + subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) use mpas_atm_dimensions ! pull nVertLevels and num_scalars from here integer, intent(in) :: cellStart, cellEnd, nCells - integer, intent(in) :: index_qv + integer, intent(in) :: index_qv, index_qc real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: bn2 real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m, exner, pressure_b, pp, qtot real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local - real (kind=RKIND) :: dz - real (kind=RKIND), dimension(nVertLevels) :: thetav - + real (kind=RKIND) :: dz, esw, qc_cr + real (kind=RKIND), dimension(nVertLevels) :: theta, thetav, qvsw, temp, coefa + qc_cr = 0.00001 ! in kg/kg + do iCell = cellStart,cellEnd !DIR$ IVDEP do k=1, nVertLevels ! qtot is qv plus all species - thetav includes moist loading (rvord-1 gives 0.61 * qv) - thetav(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) & - * (1._RKIND + rvord * scalars(index_qv,k,iCell) - qtot(k, iCell)) + theta(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) + thetav(k) = theta(k) * (1._RKIND + rvord * scalars(index_qv,k,iCell) - qtot(k, iCell)) + + temp(k) = exner(k,iCell) * theta(k) + + p = pressure_b(k,iCell) + pp(k,iCell) + esw = 1000. * svp1 * exp(svp2 * (temp(k) - svpt0) / (temp(k) - svp3)) + if (p < esw) esw = p * 0.99 ! fix for pressure < esw + qvsw(k) = ep_2 * esw / (p - esw) + + coefa(k) = ( 1.0 + xlv * qvsw(k)/ R_d / temp(k) ) / & + ( 1.0 + xlv * xlv *qvsw(k) / Cp / R_v / temp(k) / temp(k) ) + end do + do k=2, nVertLevels-1 - ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) - bn2(k,iCell) = gravity * (thetav(k+1) - thetav(k-1) ) / thetav(k) / dz + + if ( scalars(index_qc,k,iCell) < qc_cr ) then + ! Dry Brunt-Vaisala frequency + bn2(k,iCell) = gravity * (thetav(k+1) - thetav(k-1) ) / thetav(k) / dz + else + ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 + bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & + + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) / dz ) & + - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) + endif end do bn2(1,iCell) = bn2(2,iCell) bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) + end do end subroutine calculate_n2 diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 2c6a1f4a57..fc875548f5 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4833,7 +4833,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), pointer :: config_rayleigh_damp_u_timescale_days integer, pointer :: config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels integer, pointer :: config_number_rayleigh_damp_u_levels - integer, pointer :: index_qv + integer, pointer :: index_qv, index_qc logical :: inactive_rthdynten @@ -4959,6 +4959,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_dimension(state, 'moist_start', moist_start) call mpas_pool_get_dimension(state, 'moist_end', moist_end) call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_dimension(state, 'index_qc', index_qc) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) @@ -4971,7 +4972,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(mesh, 'cf3', cf3) call atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels, & - nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, index_qv, moist_start, moist_end, & + nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, index_qv, index_qc, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & @@ -4997,7 +4998,7 @@ end subroutine atm_compute_dyn_tend subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dummy, & - nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, moist_start, moist_end, & + nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, index_qc, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & @@ -5030,7 +5031,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! Dummy arguments ! integer :: nCells, nEdges, nVertices, nVertLevels_dummy, nCellsSolve, nEdgesSolve, vertexDegree, & - maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, moist_start, moist_end + maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, index_qc, moist_start, moist_end real (kind=RKIND), dimension(nEdges+1) :: fEdge real (kind=RKIND), dimension(nEdges+1) :: dvEdge @@ -5280,7 +5281,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if (config_les_model == "3d_smagorinsky") then ! call to 3D smagorinsky here... - call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, qtot, & + call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) end if From f12589da0f1c779fcf61f34c05a5e3d3db16ed3a Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 30 Jan 2020 09:43:20 -0700 Subject: [PATCH 053/214] remove thetav use --- .../dynamics/mpas_atm_dissipation_models.F | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 6605e0bad4..c53904413d 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -90,16 +90,15 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local real (kind=RKIND) :: dz, esw, qc_cr - real (kind=RKIND), dimension(nVertLevels) :: theta, thetav, qvsw, temp, coefa + real (kind=RKIND), dimension(nVertLevels) :: theta, qvsw, temp, coefa qc_cr = 0.00001 ! in kg/kg do iCell = cellStart,cellEnd !DIR$ IVDEP do k=1, nVertLevels -! qtot is qv plus all species - thetav includes moist loading (rvord-1 gives 0.61 * qv) + theta(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) - thetav(k) = theta(k) * (1._RKIND + rvord * scalars(index_qv,k,iCell) - qtot(k, iCell)) temp(k) = exner(k,iCell) * theta(k) @@ -118,7 +117,9 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in if ( scalars(index_qc,k,iCell) < qc_cr ) then ! Dry Brunt-Vaisala frequency - bn2(k,iCell) = gravity * (thetav(k+1) - thetav(k-1) ) / thetav(k) / dz + bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & + + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) / dz & + - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) else ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & From 7abd792ab4aa31c702637e94cd40feba4cba876d Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 14:09:06 -0700 Subject: [PATCH 054/214] add bn2 to output and commented out test call --- src/core_atmosphere/Registry.xml | 6 ++++++ .../dynamics/mpas_atm_time_integration.F | 12 +++++++++--- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 94e6b43f22..23788430c1 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1959,6 +1959,12 @@ + + + + diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index fc875548f5..5b5edebf62 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4779,7 +4779,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save + h_divergence, kdiff, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save real (kind=RKIND), dimension(:,:), pointer :: theta_m_save @@ -4874,6 +4874,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(diag, 'rho_p_save', rr_save) call mpas_pool_get_array(diag, 'v', v) call mpas_pool_get_array(diag, 'kdiff', kdiff) + call mpas_pool_get_array(diag, 'bn2', bn2) call mpas_pool_get_array(diag, 'ru', ru) call mpas_pool_get_array(diag, 'ru_save', ru_save) call mpas_pool_get_array(diag, 'rw', rw) @@ -4977,7 +4978,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + h_divergence, kdiff, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & @@ -5003,7 +5004,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + h_divergence, kdiff, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & @@ -5263,6 +5264,11 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if(config_horiz_mixing == "2d_fixed") then +! testing +! call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & +! cellStart, cellEnd, nCells) +! testing + !$acc parallel default(present) !$acc loop gang worker do iCell = cellStart, cellEnd From a6faf86febfc6dbde29dcce876e2ea8c328db3c8 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Fri, 6 Mar 2020 08:46:26 -0700 Subject: [PATCH 055/214] added a 3D vertical eddy viscosity to the Registry for use in LES appliations. added a new 3D Smagorinsky eddy viscosity computation and vertical mixing for the dynamics variables. All code compiles but not tested. --- src/core_atmosphere/Registry.xml | 3 + .../dynamics/mpas_atm_dissipation_models.F | 932 ++++++++++++++++-- 2 files changed, 838 insertions(+), 97 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 23788430c1..ad6a27b4f3 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1959,6 +1959,9 @@ + + diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index c53904413d..37a9d3aabf 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -10,6 +10,7 @@ module mpas_atm_dissipation_models use mpas_kind_types, only : RKIND use mpas_atmphys_constants + use mpas_constants contains @@ -75,6 +76,131 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, end subroutine smagorinsky_2d +!--------------------------------------- + + subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, & + w, c_s, bv_freq2, zgrid, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + deformation_coef_c, deformation_coef_s, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & + nCells, nEdges, nVertLevels, maxEdges ) + + implicit none + + integer, intent(in) :: cellStart, cellEnd, nCells, nEdges, nVertLevels, maxEdges + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: v + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: uCell + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: vCell + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: bv_freq2 + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_c2 + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_s2 + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_cs + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_c + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_s + real (kind=RKIND), intent(in) :: c_s, config_len_disp, invDt, config_visc4_2dsmag + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: eddy_visc_horz, eddy_visc_vert + real (kind=RKIND), intent(in) :: h_mom_eddy_visc4, h_theta_eddy_visc4 + + ! local variables + + integer :: iCell, iEdge, k, ie, cell1, cell2 + real (kind=RKIND), dimension(nVertLevels) :: d_11, d_22, d_33, d_12, d_13, d_23 + real (kind=RKIND), dimension(nVertLevels) :: dudx, dudy, dvdx, dvdy + real (kind=RKIND), dimension(nVertLevels+1) :: dwdx, dwdy + real (kind=RKIND), dimension(nVertLevels) :: dudz, dvdz, dwdz + real (kind=RKIND) :: rdz, def2, pr_inv, wk + + pr_inv = 1./prandtl + + do iCell = cellStart,cellEnd + + dudx(1:nVertLevels) = 0.0 + dudy(1:nVertLevels) = 0.0 + dvdx(1:nVertLevels) = 0.0 + dvdy(1:nVertLevels) = 0.0 + dwdx(1:nVertLevels+1) = 0.0 + dwdy(1:nVertLevels+1) = 0.0 + + dudz(1:nVertLevels) = 0.0 + dvdz(1:nVertLevels) = 0.0 + dwdz(1:nVertLevels) = 0.0 + + do iEdge=1,nEdgesOnCell(iCell) + + ie = EdgesOnCell(iEdge,iCell) + cell1 = edgesOnCell(1,ie) + cell2 = edgesOnCell(2,ie) + + do k=1,nVertLevels + dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,ie) & + - deformation_coef_cs(iEdge,iCell)*v(k,ie) + dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,ie) & + - deformation_coef_s2(iEdge,iCell)*v(k,ie) + dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,ie) & + + deformation_coef_c2(iEdge,iCell)*v(k,ie) + dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,ie) & + + deformation_coef_cs(iEdge,iCell)*v(k,ie) + end do + + do k=1,nVertLevels+1 + wk = 0.5*(w(k,cell1)+w(k,cell2)) + dwdx(k) = dwdx(k) + deformation_coef_c(iEdge,iCell)*wk + dwdy(k) = dwdy(k) + deformation_coef_s(iEdge,iCell)*wk + end do + + end do + + do k=1,nVertLevels + rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) + dwdz(k) = (w(k+1,iCell)-w(k,iCell))*rdz + end do + + do k=2,nVertLevels-1 + rdz = 2./(zgrid(k+2,iCell)+zgrid(k+1,iCell)-zgrid(k,iCell)-zgrid(k-1,iCell)) + dudz(k) = (u(k+1,iCell)-u(k-1,iCell))*rdz + dvdz(k) = (v(k+1,iCell)-v(k-1,iCell))*rdz + end do + + k = 1 + rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) + dudz(k) = (u(k+1,iCell)-u(k,iCell))*rdz + dvdz(k) = (v(k+1,iCell)-v(k,iCell))*rdz + + k = nVertLevels-1 + rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) + dudz(k+1) = (u(k+1,iCell)-u(k,iCell))*rdz + dvdz(k+1) = (v(k+1,iCell)-v(k,iCell))*rdz + + do k=1, nVertLevels + ! here is the 3D Smagorinsky formulation, + ! followed by imposition of an upper bound on the eddy viscosity + d_11(k) = 2*dudx(k) + d_22(k) = 2*dvdy(k) + d_33(k) = 2*dwdz(k) + d_12(k) = dudy(k) + dvdx(k) + d_13(k) = dwdx(k) + dudz(k) + d_23(k) = dwdy(k) + dvdz(k) + + def2 = 0.5*(d_11(k)**2 + d_22(k)**2 + d_33(k)**2) + d_12(k)**2 + d_13(k)**2 + d_23(k)**2 + + eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * max(0.,def2 - pr_inv*bv_freq2(k,iCell)) + eddy_visc_horz(k,iCell) = min(eddy_visc_horz(k,iCell),(0.01*config_len_disp**2) * invDt) + eddy_visc_vert(k,iCell) = eddy_visc_horz(k,iCell) + + end do + + end do ! loop over all owned cells (columns) + + end subroutine smagorinsky_3d + !--------------------------------------- subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & @@ -361,165 +487,587 @@ end subroutine u_dissipation !------------------------ - subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - rdzw, rdzu, & - v_mom_eddy_visc2, h_mom_eddy_visc4, & - delsq_w, & - w, rho_edge, kdiff, rho_zz, & - tend_w_euler ) - + subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & + cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & + nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & + invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & + angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & + config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & + config_del4u_div_factor, zgrid, & + eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & + fzm, fzp, config_les_model, & + delsq_u, delsq_vorticity, delsq_divergence, & + u, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here implicit none + integer, intent(in) :: edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: vertexStart, vertexEnd, vertexDegree integer, intent(in) :: cellStart, cellEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd - integer, intent(in) :: nCells, nEdges + integer, intent(in) :: nCells, nEdges, nVertices + logical, intent(in) :: config_mix_full - integer, dimension(nCells+1), intent(in) :: nEdgesOnCell - integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + character (len=StrKIND) :: config_les_model integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + integer, dimension(2,nEdges+1), intent(in) :: verticesOnEdge + integer, dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(vertexDegree,nVertices+1), intent(in) :: edgesOnVertex real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 + real (kind=RKIND), intent(in) :: config_del4u_div_factor real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(vertexDegree,nVertices+1), intent(in) :: edgesOnVertex_sign + real (kind=RKIND), dimension(nVertices+1), intent(in) :: invAreaTriangle real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell - real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: angleEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid - real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: divergence + real (kind=RKIND), dimension(nVertLevels,nVertices+1), intent(in) :: vorticity real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_horz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw + real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzm + real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzp - real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: tend_w_euler - ! storage passed in from calling routine - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_w + ! scratch space from calling routine + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: delsq_u + real (kind=RKIND), dimension(nVertLevels,nVertices+1) :: delsq_vorticity + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_divergence - ! local variables + real (kind=RKIND), dimension(nVertLevels), intent(in) :: u_init, v_init - integer :: cell1, cell2, iEdge, iCell, i, k - real (kind=RKIND) :: r_areaCell, edge_sign, w_turb_flux + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(out) :: tend_u_euler -! !OMP BARRIER why is this openmp barrier here??? + ! local variables - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). - ! - ! First, storage to hold the result from the first del^2 computation. - ! we copied code from the theta mixing, hence the theta* names. + integer :: iEdge, cell1, cell2, vertex1, vertex2, iVertex, iCell, i, k + real (kind=RKIND) :: r_dc, r_dv, u_diffusion, kdiffu, r, edge_sign, u_mix_scale + real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp + real (kind=RKIND), dimension(nVertLevels) :: u_mix + real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux + real (kind=RKIND) :: rho_k_cell1, rho_k_cell2, rho_k_at_w + real (kind=RKIND) :: zz_cell1, zz_cell2, zz_at_w - delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 +!$OMP BARRIER - do iCell=cellStart,cellEnd - tend_w_euler(1:nVertLevels+1,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). + ! First, storage to hold the result from the first del^2 computation. - edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + do iEdge=edgeStart,edgeEnd + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + vertex1 = verticesOnEdge(1,iEdge) + vertex2 = verticesOnEdge(2,iEdge) + r_dc = invDcEdge(iEdge) + r_dv = min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) !DIR$ IVDEP - do k=2,nVertLevels + do k=1,nVertLevels + + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant + u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & + -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv + + delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion + + kdiffu = 0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) + + ! include 2nd-orer diffusion here + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & + + rho_edge(k,iEdge)* kdiffu * u_diffusion * meshScalingDel2(iEdge) - w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) - delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux - w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & - (kdiff(k,cell1)+kdiff(k,cell2)+kdiff(k-1,cell1)+kdiff(k-1,cell2)) - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux - end do end do end do + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + !$OMP BARRIER - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + do iVertex=vertexStart,vertexEnd + delsq_vorticity(1:nVertLevels,iVertex) = 0.0 + do i=1,vertexDegree + iEdge = edgesOnVertex(i,iVertex) + edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) + do k=1,nVertLevels + delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) + end do + end do + end do - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) + do iCell=cellStart,cellEnd + delsq_divergence(1:nVertLevels,iCell) = 0.0 + r = invAreaCell(iCell) do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) - - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) + edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) + do k=1,nVertLevels + delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) end do - end do end do - end if ! 4th order mixing is active +!$OMP BARRIER - if ( v_mom_eddy_visc2 > 0.0 ) then ! vertical mixing + do iEdge=edgeSolveStart,edgeSolveEnd + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + vertex1 = verticesOnEdge(1,iEdge) + vertex2 = verticesOnEdge(2,iEdge) + + u_mix_scale = meshScalingDel4(iEdge)*h_mom_eddy_visc4 + r_dc = u_mix_scale * config_del4u_div_factor * invDcEdge(iEdge) + r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) - do iCell=cellSolveStart,cellSolveEnd !DIR$ IVDEP - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & - (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & - -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k) + do k=1,nVertLevels + + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant + ! + ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor + ! relative to the rotational part. The stability constraint on the divergence component is much less + ! stringent than the rotational part, and this flexibility may be useful. + ! + u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & + -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion + + end do end do - end do - end if + end if ! 4th order mixing is active - end subroutine w_dissipation + ! + ! vertical mixing for u - 2nd order filter in physical (z) space + ! + if ( v_mom_eddy_visc2 > 0.0 ) then -!----------------------------------------------------- + if (config_mix_full) then ! mix full state - subroutine theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - delsq_theta, & - theta_m, rho_edge, kdiff, rho_zz, & - tend_theta_euler ) + do iEdge=edgeSolveStart,edgeSolveEnd + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here - implicit none + do k=2,nVertLevels-1 - integer, intent(in) :: cellStart, cellEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd - integer, intent(in) :: nCells, nEdges + z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) + z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) + z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) + z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) - logical, intent(in) :: config_mix_full + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) - integer, dimension(nCells+1), intent(in) :: nEdgesOnCell - integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & + (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) & + -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do - integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + else ! idealized cases where we mix on the perturbation from the initial 1-D state - real (kind=RKIND), intent(in) :: h_theta_eddy_visc4 - real (kind=RKIND), intent(in) :: v_theta_eddy_visc2 - real (kind=RKIND), intent(in) :: prandtl_inv + do iEdge=edgeSolveStart,edgeSolveEnd - real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign - real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell - real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & + - v_init(k) * sin( angleEdge(iEdge) ) + end do + + do k=2,nVertLevels-1 + + z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) + z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) + z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) + z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & + (u_mix(k+1)-u_mix(k ))/(zp-z0) & + -(u_mix(k )-u_mix(k-1))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + end if ! mix perturbation state + + end if ! vertical mixing of horizontal momentum for fixe viscosity + + if ( config_les_model == "3d_smagorinsky") then + + do iEdge=edgeSolveStart,edgeSolveEnd + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain + turb_vflux(1) = 0. ! lower bc flux handled where ??? + + do k=2,nVertLevels + rho_k_cell1 = fzm(k)*rho_zz(k ,cell1)*zz(k ,cell1)*eddy_visc_vert(k ,cell1) & + +fzp(k)*rho_zz(k-1,cell1)*zz(k-1,cell1)*eddy_visc_vert(k-1,cell1) + rho_k_cell2 = fzm(k)*rho_zz(k ,cell2)*zz(k ,cell2)*eddy_visc_vert(k ,cell2) & + +fzp(k)*rho_zz(k-1,cell2)*zz(k-1,cell2)*eddy_visc_vert(k-1,cell2) + rho_k_at_w = 0.5*(rho_k_cell1+rho_k_cell2) + + zz_cell1 = fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) + zz_cell2 = fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) + zz_at_w = 0.5*(zz_cell1+zz_cell2) + turb_vflux(k) = rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) + end do + + do k=1,nVertLevels + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + end do + + end do + + end if + + + end subroutine u_dissipation_3d + +!------------------------ + + subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, kdiff, rho_zz, & + tend_w_euler ) + + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + + implicit none + + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, intent(in) :: nCells, nEdges + + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 + real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: tend_w_euler + + ! storage passed in from calling routine + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_w + + ! local variables + + integer :: cell1, cell2, iEdge, iCell, i, k + real (kind=RKIND) :: r_areaCell, edge_sign, w_turb_flux + +! !OMP BARRIER why is this openmp barrier here??? + + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). + ! + ! First, storage to hold the result from the first del^2 computation. + ! we copied code from the theta mixing, hence the theta* names. + + + delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + tend_w_euler(1:nVertLevels+1,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + + edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + +!DIR$ IVDEP + do k=2,nVertLevels + + w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) + delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux + w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & + (kdiff(k,cell1)+kdiff(k,cell2)+kdiff(k-1,cell1)+kdiff(k-1,cell2)) + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux + end do + end do + end do + +!$OMP BARRIER + + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) + + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) + end do + + end do + end do + + end if ! 4th order mixing is active + + if ( v_mom_eddy_visc2 > 0.0 ) then ! vertical mixing + + do iCell=cellSolveStart,cellSolveEnd +!DIR$ IVDEP + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & + (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & + -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k) + end do + end do + + end if + + end subroutine w_dissipation + +!------------------------ + + subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + config_les_model, & + tend_w_euler ) + + + ! 3D w dissipation using the 3D smagorinsky eddy viscosities. + ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + + implicit none + + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, intent(in) :: nCells, nEdges + + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + character (len=StrKIND) :: config_les_model + + real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 + real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_horz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: tend_w_euler + + ! storage passed in from calling routine + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_w + real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux + + ! local variables + + integer :: cell1, cell2, iEdge, iCell, i, k + real (kind=RKIND) :: r_areaCell, edge_sign, w_turb_flux + +! !OMP BARRIER why is this openmp barrier here??? + + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). + ! + ! First, storage to hold the result from the first del^2 computation. + ! we copied code from the theta mixing, hence the theta* names. + + + delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + tend_w_euler(1:nVertLevels+1,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + + edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + +!DIR$ IVDEP + do k=2,nVertLevels + + w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) + delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux + w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & + ( eddy_visc_horz(k ,cell1)+eddy_visc_horz(k ,cell2) & + +eddy_visc_horz(k-1,cell1)+eddy_visc_horz(k-1,cell2) ) + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux + end do + end do + end do + +!$OMP BARRIER + + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) + + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) + end do + + end do + end do + + end if ! 4th order mixing is active + + if ( v_mom_eddy_visc2 > 0.0 ) then ! vertical mixing + + do iCell=cellSolveStart,cellSolveEnd +!DIR$ IVDEP + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & + (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & + -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k) + end do + end do + + end if + + if ( config_les_model == "3d_smagorinsky") then + + do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column + ! compute turbulent fluxes + do k=1,nVertLevels + turb_vflux(k) = rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*zz(k,iCell) & + *rdzu(k)*(w(k+1,iCell)-w(k,iCell)) + end do + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & + + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + end do + end do + + end if + + end subroutine w_dissipation_3d + +!----------------------------------------------------- + + subroutine theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, kdiff, rho_zz, & + tend_theta_euler ) + + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + implicit none + + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, intent(in) :: nCells, nEdges + + logical, intent(in) :: config_mix_full + + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + real (kind=RKIND), intent(in) :: h_theta_eddy_visc4 + real (kind=RKIND), intent(in) :: v_theta_eddy_visc2 + real (kind=RKIND), intent(in) :: prandtl_inv + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw @@ -636,4 +1184,194 @@ subroutine theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end subroutine theta_dissipation +!----------------------------------------------------- + + subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, fzm, fzp, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + config_les_model, & + tend_theta_euler ) + + + ! 3D theta_m dissipation using the 3D smagorinsky eddy viscosities. + ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + implicit none + + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, intent(in) :: nCells, nEdges + + logical, intent(in) :: config_mix_full + + character (len=StrKIND) :: config_les_model + + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + real (kind=RKIND), intent(in) :: h_theta_eddy_visc4 + real (kind=RKIND), intent(in) :: v_theta_eddy_visc2 + real (kind=RKIND), intent(in) :: prandtl_inv + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzm + real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzp + real (kind=RKIND), dimension(nVertLevels+1, nCells+1), intent(in) :: zgrid + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: t_init + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_horz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler + + ! storage passed in from calling routine + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_theta + + ! local variables + integer :: cell1, cell2, iEdge, iCell, i, k + real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale + real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp + real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux + real (kind=RKIND) :: rho_k_at_w, zz_at_w + + delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + tend_theta_euler(1:nVertLevels,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + pr_scale = prandtl_inv * meshScalingDel2(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) +!DIR$ IVDEP + do k=1,nVertLevels + +! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. +! This is in conservative form. + + theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) + delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux + theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_vert(k,cell2)) * pr_scale + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux + + end do + end do + end do + +!$OMP BARRIER + + if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active + + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + + iEdge = edgesOnCell(i,iCell) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) + end do + end do + end do + + end if ! 4th order mixing is active + + ! idealized case vertical mixing + + if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m + + if (config_mix_full) then + + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & + -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + else ! idealized cases where we mix on the perturbation from the initial 1-D state + + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & + -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + end if + + end if + + if ( config_les_model == "3d_smagorinsky") then + + do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column + ! compute turbulent fluxes + turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain + turb_vflux(1) = 0. ! lower bc flux handled where ??? + do k=2,nVertLevels + rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) + turb_vflux(k) = rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) + end do + + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & + + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + end do + end do + + end if + + end subroutine theta_dissipation_3d + end module mpas_atm_dissipation_models From 88aa0b2246fba3155c45154583d0db5265a42b60 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 9 Mar 2020 15:12:55 -0600 Subject: [PATCH 056/214] Added a horizontal eddy_viscosity array to go along with the vertical eddy viscosity array. For use in the LES models. --- src/core_atmosphere/Registry.xml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index ad6a27b4f3..7d56a042c5 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1960,7 +1960,10 @@ description="Smagorinsky horizontal eddy viscosity"/> + description="vertical eddy viscosity for les models"/> + + From 05f206c6e516ae2237001a044af9350a39872a9f Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 9 Mar 2020 15:14:22 -0600 Subject: [PATCH 057/214] Bug fixes in the new LES mixing routines. --- .../dynamics/mpas_atm_dissipation_models.F | 47 ++++++++++++------- 1 file changed, 30 insertions(+), 17 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 37a9d3aabf..e42d3551f9 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -119,6 +119,8 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, real (kind=RKIND) :: rdz, def2, pr_inv, wk pr_inv = 1./prandtl + ! testing + pr_inv = 0. do iCell = cellStart,cellEnd @@ -136,8 +138,8 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, do iEdge=1,nEdgesOnCell(iCell) ie = EdgesOnCell(iEdge,iCell) - cell1 = edgesOnCell(1,ie) - cell2 = edgesOnCell(2,ie) + cell1 = cellsOnEdge(1,ie) + cell2 = cellsOnEdge(2,ie) do k=1,nVertLevels dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,ie) & @@ -152,8 +154,8 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, do k=1,nVertLevels+1 wk = 0.5*(w(k,cell1)+w(k,cell2)) - dwdx(k) = dwdx(k) + deformation_coef_c(iEdge,iCell)*wk - dwdy(k) = dwdy(k) + deformation_coef_s(iEdge,iCell)*wk + dwdx(k) = dwdx(k) + deformation_coef_c(iEdge,iCell)*wk + dwdy(k) = dwdy(k) + deformation_coef_s(iEdge,iCell)*wk end do end do @@ -165,33 +167,33 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, do k=2,nVertLevels-1 rdz = 2./(zgrid(k+2,iCell)+zgrid(k+1,iCell)-zgrid(k,iCell)-zgrid(k-1,iCell)) - dudz(k) = (u(k+1,iCell)-u(k-1,iCell))*rdz - dvdz(k) = (v(k+1,iCell)-v(k-1,iCell))*rdz + dudz(k) = (uCell(k+1,iCell)-uCell(k-1,iCell))*rdz + dvdz(k) = (vCell(k+1,iCell)-vCell(k-1,iCell))*rdz end do k = 1 rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) - dudz(k) = (u(k+1,iCell)-u(k,iCell))*rdz - dvdz(k) = (v(k+1,iCell)-v(k,iCell))*rdz + dudz(k) = (uCell(k+1,iCell)-uCell(k,iCell))*rdz + dvdz(k) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz k = nVertLevels-1 rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) - dudz(k+1) = (u(k+1,iCell)-u(k,iCell))*rdz - dvdz(k+1) = (v(k+1,iCell)-v(k,iCell))*rdz + dudz(k+1) = (uCell(k+1,iCell)-uCell(k,iCell))*rdz + dvdz(k+1) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz do k=1, nVertLevels ! here is the 3D Smagorinsky formulation, ! followed by imposition of an upper bound on the eddy viscosity - d_11(k) = 2*dudx(k) - d_22(k) = 2*dvdy(k) - d_33(k) = 2*dwdz(k) + d_11(k) = 2.*dudx(k) + d_22(k) = 2.*dvdy(k) + d_33(k) = 2.*dwdz(k) d_12(k) = dudy(k) + dvdx(k) d_13(k) = dwdx(k) + dudz(k) d_23(k) = dwdy(k) + dvdz(k) def2 = 0.5*(d_11(k)**2 + d_22(k)**2 + d_33(k)**2) + d_12(k)**2 + d_13(k)**2 + d_23(k)**2 - eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * max(0.,def2 - pr_inv*bv_freq2(k,iCell)) + eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) eddy_visc_horz(k,iCell) = min(eddy_visc_horz(k,iCell),(0.01*config_len_disp**2) * invDt) eddy_visc_vert(k,iCell) = eddy_visc_horz(k,iCell) @@ -745,6 +747,11 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v turb_vflux(k) = rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) end do + ! test conditions for supercell case + turb_vflux(1) = turb_vflux(2) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + ! end test conditions + do k=1,nVertLevels tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do @@ -1276,7 +1283,7 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux - theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_vert(k,cell2)) * pr_scale + theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux end do @@ -1351,7 +1358,8 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn end if - if ( config_les_model == "3d_smagorinsky") then + ! test section + ! if ( config_les_model == "3d_smagorinsky") then do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes @@ -1364,13 +1372,18 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn turb_vflux(k) = rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) end do + ! test boundary conditions for supercell case + turb_vflux(1) = turb_vflux(2) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + do k=1,nVertLevels tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do end do - end if + ! end if + ! end test section end subroutine theta_dissipation_3d From 92fbf81b8e16a0b28502e4e227c9159b76267344 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 14:15:30 -0700 Subject: [PATCH 058/214] added test calls to the new 3D LES schemes. This is currently hardwired to always call these LES routines, in this case for the sueprcell test case. Code compiles and runs for the supercell test case. --- .../dynamics/mpas_atm_time_integration.F | 126 ++++++++++++++---- 1 file changed, 103 insertions(+), 23 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 5b5edebf62..9406ac6d2b 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4781,6 +4781,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & h_divergence, kdiff, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save + real (kind=RKIND), dimension(:,:), pointer :: eddy_visc_horz, eddy_visc_vert + real (kind=RKIND), dimension(:,:), pointer :: theta_m_save real (kind=RKIND), dimension(:,:), pointer :: exner @@ -4874,6 +4876,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(diag, 'rho_p_save', rr_save) call mpas_pool_get_array(diag, 'v', v) call mpas_pool_get_array(diag, 'kdiff', kdiff) + call mpas_pool_get_array(diag, 'eddy_visc_horz', eddy_visc_horz) + call mpas_pool_get_array(diag, 'eddy_visc_vert', eddy_visc_vert) call mpas_pool_get_array(diag, 'bn2', bn2) call mpas_pool_get_array(diag, 'ru', ru) call mpas_pool_get_array(diag, 'ru_save', ru_save) @@ -4978,7 +4982,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, & + edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & @@ -5004,7 +5009,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, & + edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & @@ -5072,6 +5078,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: cqu real (kind=RKIND), dimension(nVertLevels,nCells+1) :: h_divergence real (kind=RKIND), dimension(nVertLevels,nCells+1) :: kdiff + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_horz + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1) :: bn2 real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign real (kind=RKIND), dimension(vertexDegree,nVertices+1) :: edgesOnVertex_sign @@ -5136,6 +5144,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: config_visc4_2dsmag real (kind=RKIND) :: config_len_disp real (kind=RKIND) :: config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2 + logical, parameter :: test_dissipation_3d=.true. integer, intent(in) :: rk_step real (kind=RKIND), intent(in) :: dt @@ -5262,6 +5271,19 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & nCells, nEdges ) +! testing - 3D smagorinsky computation + call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & + cellStart, cellEnd, nCells) + + call smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, ur_cell, vr_cell, & + w, c_s, bn2, zgrid, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + deformation_coef_c, deformation_coef_s, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & + nCells, nEdges, nVertLevels, maxEdges ) +! testing + else if(config_horiz_mixing == "2d_fixed") then ! testing @@ -5476,6 +5498,23 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$OMP BARRIER + if(test_dissipation_3d) then + + call u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & + cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & + nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & + invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & + angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & + config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & + config_del4u_div_factor, zgrid, & + eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & + fzm, fzp, config_les_model, & + delsq_u, delsq_vorticity, delsq_divergence, & + u, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) + + else + call u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & @@ -5487,6 +5526,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm delsq_u, delsq_vorticity, delsq_divergence, & u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) + end if + end if ! (rk_step 1 test for computing mixing terms) !$OMP BARRIER @@ -5613,16 +5654,35 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then - call w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - rdzw, rdzu, & - v_mom_eddy_visc2, h_mom_eddy_visc4, & - delsq_w, & - w, rho_edge, kdiff, rho_zz, & - tend_w_euler ) + if(test_dissipation_3d) then + + call w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + config_les_model, & + tend_w_euler ) + + else + + call w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, kdiff, rho_zz, & + tend_w_euler ) + + end if end if ! horizontal mixing for w computed in first rk_step @@ -5767,17 +5827,37 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then - call theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - delsq_theta, & - theta_m, rho_edge, kdiff, rho_zz, & - tend_theta_euler ) + if(test_dissipation_3d) then + + call theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, fzm, fzp, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + config_les_model, & + tend_theta_euler ) + + else + + call theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, kdiff, rho_zz, & + tend_theta_euler ) + + end if end if ! theta mixing calculated first rk_step From 1eaffdfc68ffcbe06fdfb84757b9a07f7d605ed8 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 9 Mar 2020 15:56:00 -0600 Subject: [PATCH 059/214] Bug fixes for the supercell test case using the 3D Smagorinsky LES model. Fixes are for both configuration and algorithm errors. --- .../dynamics/mpas_atm_dissipation_models.F | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index e42d3551f9..bc1db0d6e7 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -166,7 +166,7 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, end do do k=2,nVertLevels-1 - rdz = 2./(zgrid(k+2,iCell)+zgrid(k+1,iCell)-zgrid(k,iCell)-zgrid(k-1,iCell)) + rdz = 1./(zgrid(k+2,iCell)+zgrid(k+1,iCell)-zgrid(k,iCell)-zgrid(k-1,iCell)) dudz(k) = (uCell(k+1,iCell)-uCell(k-1,iCell))*rdz dvdz(k) = (vCell(k+1,iCell)-vCell(k-1,iCell))*rdz end do @@ -725,7 +725,8 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end if ! vertical mixing of horizontal momentum for fixe viscosity - if ( config_les_model == "3d_smagorinsky") then + ! test section - always execute this code + ! if ( config_les_model == "3d_smagorinsky") then do iEdge=edgeSolveStart,edgeSolveEnd @@ -758,7 +759,8 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end do - end if + ! end if + ! end test section end subroutine u_dissipation_3d @@ -1020,7 +1022,8 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end if - if ( config_les_model == "3d_smagorinsky") then + ! test section - always execute this code + ! if ( config_les_model == "3d_smagorinsky") then do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes @@ -1034,7 +1037,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end do end do - end if + ! end if end subroutine w_dissipation_3d @@ -1358,7 +1361,7 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn end if - ! test section + ! test section - always execute this code ! if ( config_les_model == "3d_smagorinsky") then do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column From eb4b3ef1887469a26a2d778622dab02fd15ecea7 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 9 Mar 2020 16:38:52 -0600 Subject: [PATCH 060/214] switched signs of the vertical turbulent fluxes and vertical flux divergence in the 3D mixing routines to conform to convention. no change in results. --- .../dynamics/mpas_atm_dissipation_models.F | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index bc1db0d6e7..c9c3f3325f 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -745,7 +745,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v zz_cell1 = fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) zz_cell2 = fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) zz_at_w = 0.5*(zz_cell1+zz_cell2) - turb_vflux(k) = rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) + turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) end do ! test conditions for supercell case @@ -754,7 +754,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v ! end test conditions do k=1,nVertLevels - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do end do @@ -1028,12 +1028,12 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes do k=1,nVertLevels - turb_vflux(k) = rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*zz(k,iCell) & - *rdzu(k)*(w(k+1,iCell)-w(k,iCell)) + turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*zz(k,iCell) & + *rdzu(k)*(w(k+1,iCell)-w(k,iCell)) end do do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & - + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do end do @@ -1372,7 +1372,7 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) - turb_vflux(k) = rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) + turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) end do ! test boundary conditions for supercell case @@ -1381,7 +1381,7 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn do k=1,nVertLevels tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & - + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do end do From dbd83ea5686cfdaa081aebb05e30e9c30f212952 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 14:20:31 -0700 Subject: [PATCH 061/214] Added new lower boundary conditions for LES simulations: (1) constant heat flux (2) simple surface drag cleaned up the driving layer in subroutine atm_compute_dyn_tend. convective boundary layer test results look OK. --- .../dynamics/mpas_atm_dissipation_models.F | 98 +++++++++--- .../dynamics/mpas_atm_time_integration.F | 141 ++++++++---------- 2 files changed, 139 insertions(+), 100 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index c9c3f3325f..dad19bd059 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -11,6 +11,12 @@ module mpas_atm_dissipation_models use mpas_kind_types, only : RKIND use mpas_atmphys_constants use mpas_constants + use mpas_log + + logical, parameter :: debug_dissipation = .true. + logical, parameter :: les_test = .true. + real (kind=RKIND), parameter :: tke_heat_flux = 0.24 + real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 contains @@ -42,6 +48,9 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, integer :: iCell, iEdge, k real (kind=RKIND), dimension(nVertLevels) :: d_11, d_22, d_12, dudx, dudy, dvdx, dvdy + if(debug_dissipation) call mpas_log_write(' begin smagorinsky_2d ') + + do iCell = cellStart,cellEnd dudx(1:nVertLevels) = 0.0 dudy(1:nVertLevels) = 0.0 @@ -74,6 +83,8 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 h_theta_eddy_visc4 = h_mom_eddy_visc4 + if(debug_dissipation) call mpas_log_write(' exiting smagorinsky_2d ') + end subroutine smagorinsky_2d !--------------------------------------- @@ -107,7 +118,7 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: eddy_visc_horz, eddy_visc_vert - real (kind=RKIND), intent(in) :: h_mom_eddy_visc4, h_theta_eddy_visc4 + real (kind=RKIND), intent(out) :: h_mom_eddy_visc4, h_theta_eddy_visc4 ! local variables @@ -118,9 +129,9 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, real (kind=RKIND), dimension(nVertLevels) :: dudz, dvdz, dwdz real (kind=RKIND) :: rdz, def2, pr_inv, wk + if(debug_dissipation) call mpas_log_write(' begin smagorinsky_3d ') + pr_inv = 1./prandtl - ! testing - pr_inv = 0. do iCell = cellStart,cellEnd @@ -201,6 +212,13 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, end do ! loop over all owned cells (columns) + ! set up coefficients for 4th-order horizontal background filter + + h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 + h_theta_eddy_visc4 = h_mom_eddy_visc4 + + if(debug_dissipation) call mpas_log_write(' exiting smagorinsky_3d ') + end subroutine smagorinsky_3d !--------------------------------------- @@ -217,11 +235,12 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local - real (kind=RKIND) :: dz, esw, qc_cr + real (kind=RKIND) :: dz, esw + real (kind=RKIND), parameter :: qc_cr = 0.00001 ! in kg/kg real (kind=RKIND), dimension(nVertLevels) :: theta, qvsw, temp, coefa - qc_cr = 0.00001 ! in kg/kg - + if(debug_dissipation) call mpas_log_write(' begin BV frequency calculations ') + do iCell = cellStart,cellEnd !DIR$ IVDEP do k=1, nVertLevels @@ -260,6 +279,8 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in end do + if(debug_dissipation) call mpas_log_write(' exiting BV frequency calculations ') + end subroutine calculate_n2 !--------------------------------------- @@ -500,7 +521,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & fzm, fzp, config_les_model, & delsq_u, delsq_vorticity, delsq_divergence, & - u, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) + u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here @@ -538,6 +559,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: v real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: divergence real (kind=RKIND), dimension(nVertLevels,nVertices+1), intent(in) :: vorticity real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge @@ -571,6 +593,15 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND) :: rho_k_cell1, rho_k_cell2, rho_k_at_w real (kind=RKIND) :: zz_cell1, zz_cell2, zz_at_w + real (kind=RKIND) :: velocity_magnitude + + if(debug_dissipation) then + call mpas_log_write(' begin u_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) + call mpas_log_write(' 4th order divergence factor is $r ', realArgs=(/config_del4u_div_factor/)) + end if + !$OMP BARRIER ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). @@ -725,8 +756,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end if ! vertical mixing of horizontal momentum for fixe viscosity - ! test section - always execute this code - ! if ( config_les_model == "3d_smagorinsky") then + if ( config_les_model == "3d_smagorinsky") then do iEdge=edgeSolveStart,edgeSolveEnd @@ -748,10 +778,17 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) end do + if( les_test ) then + velocity_magnitude = sqrt(u(1,iEdge)**2 + v(1,iEdge)**2) + turb_vflux(1) = -rho_edge(1,iEdge)*tke_drag_coefficient*u(1,iEdge)*velocity_magnitude + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + ! end test conditions + else ! test conditions for supercell case turb_vflux(1) = turb_vflux(2) turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) ! end test conditions + end if do k=1,nVertLevels tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) @@ -759,9 +796,9 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end do - ! end if - ! end test section + end if + if(debug_dissipation) call mpas_log_write(' exiting u_dissipation_3d ') end subroutine u_dissipation_3d @@ -960,6 +997,11 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, ! First, storage to hold the result from the first del^2 computation. ! we copied code from the theta mixing, hence the theta* names. + if(debug_dissipation) then + call mpas_log_write(' begin w_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) + end if delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 @@ -1022,8 +1064,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end if - ! test section - always execute this code - ! if ( config_les_model == "3d_smagorinsky") then + if ( config_les_model == "3d_smagorinsky") then do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes @@ -1037,7 +1078,9 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end do end do - ! end if + end if + + if(debug_dissipation) call mpas_log_write(' exiting w_dissipation_3d ') end subroutine w_dissipation_3d @@ -1267,6 +1310,12 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux real (kind=RKIND) :: rho_k_at_w, zz_at_w + if(debug_dissipation) then + call mpas_log_write(' begin theta_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_theta_eddy_visc4/)) + end if + delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 do iCell=cellStart,cellEnd @@ -1361,8 +1410,7 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn end if - ! test section - always execute this code - ! if ( config_les_model == "3d_smagorinsky") then + if ( config_les_model == "3d_smagorinsky") then do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes @@ -1375,9 +1423,16 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) end do - ! test boundary conditions for supercell case - turb_vflux(1) = turb_vflux(2) - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + ! test boundary conditions for supercell and les test cases + + if( les_test ) then + turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + else + turb_vflux(1) = turb_vflux(2) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + end if + do k=1,nVertLevels tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & @@ -1385,8 +1440,9 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn end do end do - ! end if - ! end test section + end if + + if(debug_dissipation) call mpas_log_write(' exiting theta_dissipation_3d ') end subroutine theta_dissipation_3d diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 9406ac6d2b..a04c9cc97a 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5265,13 +5265,22 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if(config_horiz_mixing == "2d_smagorinsky") then - call smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, & + call smagorinsky_2d( eddy_visc_horz, u, v, c_s, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & nCells, nEdges ) -! testing - 3D smagorinsky computation + else if(config_horiz_mixing == "2d_fixed") then + + eddy_visc_horz(1:nVertLevels,cellStart:cellEnd) = config_h_theta_eddy_visc2 + h_mom_eddy_visc4 = config_h_mom_eddy_visc4 + h_theta_eddy_visc4 = config_h_theta_eddy_visc4 + + end if + + else if (config_les_model == "3d_smagorinsky") then + call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) @@ -5282,35 +5291,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & nCells, nEdges, nVertLevels, maxEdges ) -! testing - - else if(config_horiz_mixing == "2d_fixed") then - -! testing -! call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & -! cellStart, cellEnd, nCells) -! testing - - !$acc parallel default(present) - !$acc loop gang worker - do iCell = cellStart, cellEnd - !$acc loop vector - do k = 1, nVertLevels - kdiff(k,iCell) = config_h_theta_eddy_visc2 - end do - end do - !$acc end parallel - - h_mom_eddy_visc4 = config_h_mom_eddy_visc4 - h_theta_eddy_visc4 = config_h_theta_eddy_visc4 - - end if - - else if (config_les_model == "3d_smagorinsky") then - - ! call to 3D smagorinsky here... - call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & - cellStart, cellEnd, nCells) end if @@ -5329,6 +5309,9 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm visc2cam = visc2cam*(1.0-real(nVertLevels-k)/real(config_number_cam_damping_levels)) kdiff(k ,iCell) = max(kdiff(k ,iCell),visc2cam) end do + eddy_visc_horz(nVertLevels-2,iCell) = max(eddy_visc_horz(nVertLevels-2,iCell), 2.0833*config_len_disp*config_mpas_cam_coef) + eddy_visc_horz(nVertLevels-1,iCell) = max(eddy_visc_horz(nVertLevels-1,iCell),2.0*2.0833*config_len_disp*config_mpas_cam_coef) + eddy_visc_horz(nVertLevels ,iCell) = max(eddy_visc_horz(nVertLevels ,iCell),4.0*2.0833*config_len_disp*config_mpas_cam_coef) end do !$acc end parallel @@ -5498,7 +5481,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$OMP BARRIER - if(test_dissipation_3d) then +! if(test_dissipation_3d) then call u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & @@ -5511,22 +5494,22 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & fzm, fzp, config_les_model, & delsq_u, delsq_vorticity, delsq_divergence, & - u, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) + u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) - else - - call u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & - cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & - cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & - nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & - invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & - angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & - config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & - config_del4u_div_factor, zgrid, kdiff, & - delsq_u, delsq_vorticity, delsq_divergence, & - u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) - - end if +! else ! this is the original MPAS dissipation code +! +! call u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & +! cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & +! cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & +! nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & +! invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & +! angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & +! config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & +! config_del4u_div_factor, zgrid, kdiff, & +! delsq_u, delsq_vorticity, delsq_divergence, & +! u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) +! +! end if end if ! (rk_step 1 test for computing mixing terms) @@ -5654,7 +5637,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then - if(test_dissipation_3d) then +! if(test_dissipation_3d) then call w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & nCells, nEdges, & @@ -5669,22 +5652,22 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm config_les_model, & tend_w_euler ) - else - - call w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - rdzw, rdzu, & - v_mom_eddy_visc2, h_mom_eddy_visc4, & - delsq_w, & - w, rho_edge, kdiff, rho_zz, & - tend_w_euler ) - - end if +! else +! +! call w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & +! nCells, nEdges, & +! nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & +! invAreaCell, invDcEdge, dvEdge, & +! meshScalingDel2, meshScalingDel4, & +! rdzw, rdzu, & +! v_mom_eddy_visc2, h_mom_eddy_visc4, & +! delsq_w, & +! w, rho_edge, kdiff, rho_zz, & +! tend_w_euler ) +! +! end if - end if ! horizontal mixing for w computed in first rk_step + end if ! mixing for w computed in first rk_step ! Note for OpenMP parallelization: We could avoid allocating the delsq_w scratch ! array, and just use the delsq_theta array as was previously done; however, @@ -5827,7 +5810,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then - if(test_dissipation_3d) then +! if(test_dissipation_3d) then call theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & nCells, nEdges, & @@ -5843,21 +5826,21 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm config_les_model, & tend_theta_euler ) - else - - call theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - delsq_theta, & - theta_m, rho_edge, kdiff, rho_zz, & - tend_theta_euler ) - - end if +! else ! this is the original MPAS dissipation code +! +! call theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & +! nCells, nEdges, & +! nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & +! invAreaCell, invDcEdge, dvEdge, & +! meshScalingDel2, meshScalingDel4, & +! config_mix_full, t_init, zgrid, & +! rdzw, rdzu, & +! v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & +! delsq_theta, & +! theta_m, rho_edge, kdiff, rho_zz, & +! tend_theta_euler ) +! +! end if end if ! theta mixing calculated first rk_step From 59f1348c754f6c41383776b0a03be457193f1076 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 16 Mar 2020 15:52:47 -0600 Subject: [PATCH 062/214] Added a scalar variable named tke. This is the turbulent kinetic energy used in the prognostic 1.5 order TKE (LES) scheme. Initialized the values to 0.1 (i.e. a small number) becuase there must be a seed to grow tke. --- src/core_init_atmosphere/Registry.xml | 2 ++ src/core_init_atmosphere/mpas_init_atm_cases.F | 10 ++++++++++ 2 files changed, 12 insertions(+) diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index d24568c866..b4f4622246 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -1196,6 +1196,8 @@ + diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 82b2517e76..0160139fb8 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -6235,6 +6235,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, cell1, cell2 integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve integer, pointer :: index_qv + integer, pointer :: index_tke real (kind=RKIND), dimension(nVertLevels + 1 ) :: znu, znw, znwc, znwv real (kind=RKIND), dimension(nVertLevels + 1 ) :: znuc, znuv @@ -6368,6 +6369,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes call mpas_pool_get_array(state, 'scalars', scalars) call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_dimension(state, 'index_tke', index_tke) scalars(:,:,:) = 0. @@ -6607,6 +6609,14 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) end do end do +! +! initial seed for tke +! + do i=1,nCells + do k = 1,nz1 + scalars(index_tke,k,i) = 0.1 + end do + end do do itr=1,30 From 31f21ff571126a8ea48eb19845ff1991c53f2e9c Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 17 Mar 2020 11:09:52 -0600 Subject: [PATCH 063/214] Added passive test of prognostic tke. Does not yet pass debug step. --- src/core_atmosphere/Registry.xml | 10 ++ .../dynamics/mpas_atm_dissipation_models.F | 111 ++++++++++++++++-- .../dynamics/mpas_atm_time_integration.F | 21 +++- 3 files changed, 124 insertions(+), 18 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 7d56a042c5..f78ca1b2fb 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1696,6 +1696,12 @@ + packages="mp_thompson_in"/> + + + + + packages="mp_thompson_in"/> + + #endif diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index dad19bd059..ea5181a8f7 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -89,22 +89,26 @@ end subroutine smagorinsky_2d !--------------------------------------- - subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, & + subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, & w, c_s, bv_freq2, zgrid, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & deformation_coef_c, deformation_coef_s, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & - nCells, nEdges, nVertLevels, maxEdges ) + nCells, nEdges, nVertLevels, maxEdges, num_scalars ) implicit none - integer, intent(in) :: cellStart, cellEnd, nCells, nEdges, nVertLevels, maxEdges + integer, intent(in) :: cellStart, cellEnd, nCells, nEdges, nVertLevels, maxEdges, index_tke, num_scalars real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: v real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: uCell real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: vCell real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: bv_freq2 + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: tend_scalars real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_c2 @@ -112,6 +116,7 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_cs real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_c real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_s + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 real (kind=RKIND), intent(in) :: c_s, config_len_disp, invDt, config_visc4_2dsmag integer, dimension(nCells+1), intent(in) :: nEdgesOnCell integer, dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell @@ -128,6 +133,11 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, real (kind=RKIND), dimension(nVertLevels+1) :: dwdx, dwdy real (kind=RKIND), dimension(nVertLevels) :: dudz, dvdz, dwdz real (kind=RKIND) :: rdz, def2, pr_inv, wk + real (kind=RKIND) :: shear_production, buoyancy, dissipation, delta_z, delta_s, bv, tke_length, diss_length + real (kind=RKIND) :: l_horizontal, l_vertical, c_k, c_dissipation + real (kind=RKIND) :: prandtl_horizontal_inv, prandtl_vertical_inv + + logical, parameter :: test_tke=.true. if(debug_dissipation) call mpas_log_write(' begin smagorinsky_3d ') @@ -210,6 +220,63 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, end do +!*************************************************** + + if (test_tke) then + + do k=1,nVertLevels + + shear_production = eddy_visc_horz(k,iCell)*(d_11(k)**2 + d_22(k)**2 + d_12(k)**2) & + +eddy_visc_vert(k,iCell)*(d_33(k)**2 + d_13(k)**2 + d_13(k)**2) + + buoyancy = -eddy_visc_vert(k,iCell)*bv_freq2(k,iCell) + + ! dissipation + + delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) + delta_s = ((config_len_disp**2)*delta_z)**(1./3.) + bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon ) + tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv + + diss_length = min(delta_s,tke_length) + if(bv_freq2(k,iCell) <= 0) diss_length = delta_s + + c_k = 0.25 + c_dissipation = 1.9*c_k + max( 0.0, 0.93 - 1.9*c_k )*diss_length/delta_s + + dissipation = -c_dissipation*(scalars(index_tke,k,iCell)**(1.5))/diss_length + + ! computing eddy viscosities ********* + + ! non-isotropic mixing + + l_horizontal = config_len_disp + l_vertical = min(delta_z,tke_length) + if(bv_freq2(k,iCell) <= 0) diss_length = delta_z + + ! isotropic mixing + + l_horizontal = min(delta_s,tke_length) + if(bv_freq2(k,iCell) <= 0) diss_length = delta_s + l_vertical = l_horizontal + + prandtl_horizontal_inv = 3. + prandtl_vertical_inv = 1.0+(2.0*l_vertical/delta_z) ! going to need to store this off somewhere + + ! eddy viscocities set here if we are running the 1.5 order prognostic tke scheme + ! eddy_visc_horz(k,iCell) = c_k*l_horizontal*sqrt(scalars(index_tke,k,iCell)) + ! eddy_visc_vert(k,iCell) = c_k*l_vertical*sqrt(scalars(index_tke,k,iCell)) + + ! RHS term for the subgrid ke. + + tend_scalars(index_tke,k,iCell) = rho_zz(k,iCell)*( shear_production + buoyancy + dissipation ) + + end do + + end if ! end of test_tke + +!*************************************************** + end do ! loop over all owned cells (columns) ! set up coefficients for 4th-order horizontal background filter @@ -235,9 +302,10 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local - real (kind=RKIND) :: dz, esw + real (kind=RKIND) :: dz, rdz, esw real (kind=RKIND), parameter :: qc_cr = 0.00001 ! in kg/kg real (kind=RKIND), dimension(nVertLevels) :: theta, qvsw, temp, coefa + logical :: dry_bv_frequency if(debug_dissipation) call mpas_log_write(' begin BV frequency calculations ') @@ -261,18 +329,37 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in do k=2, nVertLevels-1 dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) - - if ( scalars(index_qc,k,iCell) < qc_cr ) then + rdz = 1.0/dz + + ! if ( scalars(index_qc,k,iCell) < qc_cr ) then + ! ! Dry Brunt-Vaisala frequency + ! bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & + ! + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) / dz & + ! - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) + ! else + ! ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 + ! bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & + ! + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) / dz ) & + ! - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) + ! endif + + dry_bv_frequency = .true. + if(index_qc .gt. 0) then ! if moist simulation, qc exists + if ( scalars(index_qc,k,iCell) .ge. qc_cr ) dry_bv_frequency = .false. + end if + + if (dry_bv_frequency) then ! Dry Brunt-Vaisala frequency - bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & - + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) / dz & - - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) + bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) * rdz & + + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) * rdz & + - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) * rdz ) else ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 - bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & - + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) / dz ) & - - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) + bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) * rdz & + + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) * rdz ) & + - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) * rdz ) endif + end do bn2(1,iCell) = bn2(2,iCell) bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index a04c9cc97a..a3dd869be5 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4791,7 +4791,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:,:), pointer :: rthdynten - real (kind=RKIND), dimension(:,:,:), pointer :: scalars + real (kind=RKIND), dimension(:,:,:), pointer :: scalars, tend_scalars real (kind=RKIND), dimension(:,:), pointer :: tend_u_euler, tend_w_euler, tend_theta_euler @@ -4835,7 +4835,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), pointer :: config_rayleigh_damp_u_timescale_days integer, pointer :: config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels integer, pointer :: config_number_rayleigh_damp_u_levels - integer, pointer :: index_qv, index_qc + integer, pointer :: index_qv, index_qc, index_tke logical :: inactive_rthdynten @@ -4947,6 +4947,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(tend, 'w_euler', tend_w_euler) call mpas_pool_get_array(tend, 'w_pgf', tend_w_pgf) call mpas_pool_get_array(tend, 'w_buoy', tend_w_buoy) + call mpas_pool_get_array(tend, 'scalars_tend', tend_scalars) + call mpas_pool_get_array(diag, 'cqw', cqw) call mpas_pool_get_array(diag, 'cqu', cqu) @@ -4965,6 +4967,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_dimension(state, 'moist_end', moist_end) call mpas_pool_get_dimension(state, 'index_qv', index_qv) call mpas_pool_get_dimension(state, 'index_qc', index_qc) + call mpas_pool_get_dimension(state, 'index_tke', index_tke) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) @@ -4978,11 +4981,12 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels, & nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, index_qv, index_qc, moist_start, moist_end, & + tend_scalars, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, & + h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, index_tke, & edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & @@ -5005,11 +5009,12 @@ end subroutine atm_compute_dyn_tend subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dummy, & nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, index_qc, moist_start, moist_end, & + tend_scalars, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, & + h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, index_tke, & edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & @@ -5038,7 +5043,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! Dummy arguments ! integer :: nCells, nEdges, nVertices, nVertLevels_dummy, nCellsSolve, nEdgesSolve, vertexDegree, & - maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, index_qc, moist_start, moist_end + maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, index_qc, moist_start, moist_end, index_tke real (kind=RKIND), dimension(nEdges+1) :: fEdge real (kind=RKIND), dimension(nEdges+1) :: dvEdge @@ -5090,6 +5095,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: exner real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rr_save real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: scalars + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: tend_scalars real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: tend_u_euler real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_euler real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_theta_euler @@ -5281,6 +5287,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if (config_les_model == "3d_smagorinsky") then + ! call mpas_log_write(' BV call, index qv, qc, tke $i $i $i ', intArgs=(/index_qv, index_qc, index_tke/)) + call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) @@ -5289,8 +5297,9 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & deformation_coef_c, deformation_coef_s, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & - nCells, nEdges, nVertLevels, maxEdges ) + nCells, nEdges, nVertLevels, maxEdges, num_scalars ) end if From 7e1581b745dbbb19e617c44188417318add61a97 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 17 Mar 2020 19:59:43 -0600 Subject: [PATCH 064/214] 1.5 order prognostic tke mods. The prognostic tke does not feed back on the solution in this formulation. further testing ahead. --- .../dynamics/mpas_atm_dissipation_models.F | 46 +++++++++++-------- 1 file changed, 27 insertions(+), 19 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index ea5181a8f7..0d76397baf 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -136,8 +136,10 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, real (kind=RKIND) :: shear_production, buoyancy, dissipation, delta_z, delta_s, bv, tke_length, diss_length real (kind=RKIND) :: l_horizontal, l_vertical, c_k, c_dissipation real (kind=RKIND) :: prandtl_horizontal_inv, prandtl_vertical_inv + real (kind=RKIND) :: eddy_visc_h, eddy_visc_v logical, parameter :: test_tke=.true. + real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 if(debug_dissipation) call mpas_log_write(' begin smagorinsky_3d ') @@ -226,28 +228,13 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, do k=1,nVertLevels - shear_production = eddy_visc_horz(k,iCell)*(d_11(k)**2 + d_22(k)**2 + d_12(k)**2) & - +eddy_visc_vert(k,iCell)*(d_33(k)**2 + d_13(k)**2 + d_13(k)**2) - - buoyancy = -eddy_visc_vert(k,iCell)*bv_freq2(k,iCell) - - ! dissipation - delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) delta_s = ((config_len_disp**2)*delta_z)**(1./3.) - bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon ) + bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon_bv ) tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv - diss_length = min(delta_s,tke_length) if(bv_freq2(k,iCell) <= 0) diss_length = delta_s - c_k = 0.25 - c_dissipation = 1.9*c_k + max( 0.0, 0.93 - 1.9*c_k )*diss_length/delta_s - - dissipation = -c_dissipation*(scalars(index_tke,k,iCell)**(1.5))/diss_length - - ! computing eddy viscosities ********* - ! non-isotropic mixing l_horizontal = config_len_disp @@ -256,9 +243,30 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, ! isotropic mixing - l_horizontal = min(delta_s,tke_length) - if(bv_freq2(k,iCell) <= 0) diss_length = delta_s - l_vertical = l_horizontal + ! l_horizontal = min(delta_s,tke_length) + ! if(bv_freq2(k,iCell) <= 0) diss_length = delta_s + ! l_vertical = l_horizontal + + ! eddy viscocities set here if we are running the 1.5 order prognostic tke scheme + eddy_visc_h = c_k*l_horizontal*sqrt(scalars(index_tke,k,iCell)) + eddy_visc_v = c_k*l_vertical*sqrt(scalars(index_tke,k,iCell)) + + ! terms for the prognostic tke integration + + shear_production = eddy_visc_h*(d_11(k)**2 + d_22(k)**2 + d_12(k)**2) & + +eddy_visc_v*(d_33(k)**2 + d_13(k)**2 + d_13(k)**2) + + buoyancy = -eddy_visc_v*bv_freq2(k,iCell) + + ! dissipation + + c_k = 0.25 + c_dissipation = 1.9*c_k + max( 0.0, 0.93 - 1.9*c_k )*diss_length/delta_s + if( (k.eq. 1) .or. (k.eq.nVertLevels) ) c_dissipation = 3.9 + + dissipation = -c_dissipation*(scalars(index_tke,k,iCell)**(1.5))/diss_length + + ! computing eddy viscosities ********* prandtl_horizontal_inv = 3. prandtl_vertical_inv = 1.0+(2.0*l_vertical/delta_z) ! going to need to store this off somewhere From 84ad242fffcee936e513556eb762d90ee7c7c43c Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Wed, 18 Mar 2020 16:50:43 -0600 Subject: [PATCH 065/214] Added mixing routines for scalars within the LES models, both diagnostic and prognostic versions. The progostic tke option is still running in a no-feedback mode. --- .../dynamics/mpas_atm_dissipation_models.F | 320 ++++++++++++++++++ .../dynamics/mpas_atm_time_integration.F | 44 ++- 2 files changed, 351 insertions(+), 13 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 0d76397baf..510b213184 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1541,4 +1541,324 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn end subroutine theta_dissipation_3d +!----------------------------------------------------- + + subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, fzm, fzp, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + bv_freq2, config_len_disp, scalars, tend_scalars, & + index_tke, index_qv, num_scalars_dummy, mix_scalars, & + config_les_model, & + tend_theta_euler ) + + + ! 3D theta_m dissipation using the 3D smagorinsky eddy viscosities. + ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + implicit none + + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, intent(in) :: nCells, nEdges + integer, intent(in) :: num_scalars_dummy + integer, intent(in) :: index_tke, index_qv + + logical, intent(in) :: config_mix_full, mix_scalars + + character (len=StrKIND) :: config_les_model + + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + real (kind=RKIND), intent(in) :: h_theta_eddy_visc4 + real (kind=RKIND), intent(in) :: v_theta_eddy_visc2 + real (kind=RKIND), intent(in) :: prandtl_inv + real (kind=RKIND), intent(in) :: config_len_disp + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzm + real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzp + real (kind=RKIND), dimension(nVertLevels+1, nCells+1), intent(in) :: zgrid + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: t_init + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: bv_freq2 + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout) :: tend_scalars + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_horz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler + + ! storage passed in from calling routine + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_theta + + ! local variables + integer :: cell1, cell2, iEdge, iCell, i, k, iScalar + real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale + real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp + real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux + real (kind=RKIND), dimension(num_scalars,nVertLevels+1) :: turb_vflux_scalars + real (kind=RKIND) :: rho_k_at_w, zz_at_w + + logical, parameter :: vmix_scalars = .true. + logical, parameter :: hmix_scalars = .true. + logical, parameter :: hmix4_scalars = .false. + + if(debug_dissipation) then + call mpas_log_write(' begin scalar_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_theta_eddy_visc4/)) + end if + + delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + tend_theta_euler(1:nVertLevels,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + pr_scale = prandtl_inv * meshScalingDel2(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) +!DIR$ IVDEP + do k=1,nVertLevels + +! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. +! This is in conservative form. + + theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) + delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux + theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux + + end do + end do + end do + +!$OMP BARRIER + + if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active + + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + + iEdge = edgesOnCell(i,iCell) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) + end do + end do + end do + + end if ! 4th order mixing is active + + if(mix_scalars .and. hmix_scalars) then ! dissipation for scalars, including 4th-order filter. Likely needs optimization + + do iScalar=1,num_scalars + + delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + ! tend_theta_euler(1:nVertLevels,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + pr_scale = prandtl_inv * meshScalingDel2(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) +!DIR$ IVDEP + do k=1,nVertLevels + +! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. +! This is in conservative form. + + theta_turb_flux = edge_sign*(scalars(iScalar,k,cell2) - scalars(iScalar,k,cell1))*rho_edge(k,iEdge) + delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux + theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale + tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) + theta_turb_flux + + end do + end do + end do + +!$OMP BARRIER + + if ((h_theta_eddy_visc4 > 0.0).and. hmix4_scalars) then ! 4th order mixing is active + + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + + iEdge = edgesOnCell(i,iCell) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) + end do + end do + end do + + end if ! 4th order mixing is active + + end do ! loop over scalars for horizontal mixing + + end if ! horizontal scalar mixing + + + ! idealized case vertical mixing. No scalar mixing here. + + if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m + + if (config_mix_full) then + + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & + -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + else ! idealized cases where we mix on the perturbation from the initial 1-D state + + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & + -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + end if + + end if + + if ( config_les_model /= "none") then + + do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column + ! compute turbulent fluxes + turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain + turb_vflux(1) = 0. ! lower bc flux handled where ??? + do k=2,nVertLevels + rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) + turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) + end do + + ! test boundary conditions for supercell and les test cases + + if( les_test ) then + turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + else + turb_vflux(1) = turb_vflux(2) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + end if + + + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & + - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + end do + + end do + + if (mix_scalars .and. vmix_scalars) then + + do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column + ! compute turbulent fluxes + turb_vflux_scalars(:,nVertlevels+1) = 0. ! no turbulent flux out of the domain + turb_vflux_scalars(:,1) = 0. ! lower bc flux handled where ??? + do k=2,nVertLevels + rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) + do iScalar=1,num_scalars + turb_vflux_scalars(iScalar,k) = - rho_k_at_w*zz_at_w*rdzu(k)* & + (scalars(iScalar,k,iCell)-scalars(iScalar,k-1,iCell)) + end do + end do + + ! test boundary conditions for supercell and les test cases + + ! need lower bc for qv here... + + ! if( les_test ) then + ! turb_vflux_scalars(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY + ! turb_vflux_scalars(nVertLevels+1) = turb_vflux_scalars(nVertLevels) + ! else + ! turb_vflux_scalars(1) = turb_vflux_scalars(2) + ! turb_vflux_scalars(nVertLevels+1) = turb_vflux_scalars(nVertLevels) + ! end if + + + do k=1,nVertLevels + do iScalar=1,num_scalars + tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) & + - rdzw(k)*(turb_vflux_scalars(iScalar,k+1)-turb_vflux_scalars(iScalar,k)) + end do + end do + + end do + + end if ! mix scalars + + end if + + if(debug_dissipation) call mpas_log_write(' exiting scalar_dissipation_3d ') + + end subroutine scalar_dissipation_3d_les + end module mpas_atm_dissipation_models diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index a3dd869be5..f79485b5be 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5151,6 +5151,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: config_len_disp real (kind=RKIND) :: config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2 logical, parameter :: test_dissipation_3d=.true. + logical, parameter :: mix_scalars = .true. integer, intent(in) :: rk_step real (kind=RKIND), intent(in) :: dt @@ -5821,19 +5822,36 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! if(test_dissipation_3d) then - call theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, fzm, fzp, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - delsq_theta, & - theta_m, rho_edge, rho_zz, zz, & - eddy_visc_horz, eddy_visc_vert, & - config_les_model, & - tend_theta_euler ) + !call theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + ! nCells, nEdges, & + ! nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + ! invAreaCell, invDcEdge, dvEdge, & + ! meshScalingDel2, meshScalingDel4, & + ! config_mix_full, t_init, zgrid, & + ! rdzw, rdzu, fzm, fzp, & + ! v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + ! delsq_theta, & + ! theta_m, rho_edge, rho_zz, zz, & + ! eddy_visc_horz, eddy_visc_vert, & + ! config_les_model, & + ! tend_theta_euler ) + + call scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, fzm, fzp, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + bn2, config_len_disp, scalars, tend_scalars, & + index_tke, index_qv, num_scalars, mix_scalars, & + config_les_model, & + tend_theta_euler ) + ! else ! this is the original MPAS dissipation code ! From bf39525c523e673133b26abea9c0d19a728ae0fc Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Fri, 20 Mar 2020 10:59:32 -0600 Subject: [PATCH 066/214] Clean up and changes to run the prognostic tke les model. initial tests of the prognostic scheme with a convective boundary layer appear to be OK. More testing to follow. --- .../dynamics/mpas_atm_dissipation_models.F | 153 +++++++++--------- .../dynamics/mpas_atm_time_integration.F | 21 ++- 2 files changed, 90 insertions(+), 84 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 510b213184..9b1d122866 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -12,6 +12,7 @@ module mpas_atm_dissipation_models use mpas_atmphys_constants use mpas_constants use mpas_log + use mpas_derived_types, only : MPAS_LOG_CRIT logical, parameter :: debug_dissipation = .true. logical, parameter :: les_test = .true. @@ -89,17 +90,20 @@ end subroutine smagorinsky_2d !--------------------------------------- - subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, & - w, c_s, bv_freq2, zgrid, config_len_disp, & - deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & - deformation_coef_c, deformation_coef_s, & - invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & - scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & - cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & - nCells, nEdges, nVertLevels, maxEdges, num_scalars ) + subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, & + u, v, uCell, vCell, & + w, c_s, bv_freq2, zgrid, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + deformation_coef_c, deformation_coef_s, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & + nCells, nEdges, nVertLevels, maxEdges, num_scalars ) implicit none + character (len=StrKIND), intent(in) :: config_les_model + integer, intent(in) :: cellStart, cellEnd, nCells, nEdges, nVertLevels, maxEdges, index_tke, num_scalars real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: v @@ -107,7 +111,7 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: vCell real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: bv_freq2 real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz - real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout) :: scalars real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: tend_scalars real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid @@ -141,10 +145,16 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, logical, parameter :: test_tke=.true. real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 - if(debug_dissipation) call mpas_log_write(' begin smagorinsky_3d ') + if(debug_dissipation) call mpas_log_write(' begin les_models ') + if(debug_dissipation) call mpas_log_write(' les scheme is '//trim(config_les_model)) pr_inv = 1./prandtl + ! set up coefficients for 4th-order horizontal background filter + + h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 + h_theta_eddy_visc4 = h_mom_eddy_visc4 + do iCell = cellStart,cellEnd dudx(1:nVertLevels) = 0.0 @@ -205,26 +215,28 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, dvdz(k+1) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz do k=1, nVertLevels - ! here is the 3D Smagorinsky formulation, - ! followed by imposition of an upper bound on the eddy viscosity d_11(k) = 2.*dudx(k) d_22(k) = 2.*dvdy(k) d_33(k) = 2.*dwdz(k) d_12(k) = dudy(k) + dvdx(k) d_13(k) = dwdx(k) + dudz(k) d_23(k) = dwdy(k) + dvdz(k) + end do - def2 = 0.5*(d_11(k)**2 + d_22(k)**2 + d_33(k)**2) + d_12(k)**2 + d_13(k)**2 + d_23(k)**2 - - eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) - eddy_visc_horz(k,iCell) = min(eddy_visc_horz(k,iCell),(0.01*config_len_disp**2) * invDt) - eddy_visc_vert(k,iCell) = eddy_visc_horz(k,iCell) + if (config_les_model == "3d_smagorinsky") then - end do + do k=1, nVertLevels + def2 = 0.5*(d_11(k)**2 + d_22(k)**2 + d_33(k)**2) + d_12(k)**2 + d_13(k)**2 + d_23(k)**2 + eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) + eddy_visc_horz(k,iCell) = min(eddy_visc_horz(k,iCell),(0.01*config_len_disp**2) * invDt) + eddy_visc_vert(k,iCell) = eddy_visc_horz(k,iCell) + end do -!*************************************************** + else if (config_les_model == "prognostic_1.5_order") then - if (test_tke) then + do k=1,nVertLevels ! bound the tke here, currently hardwired + scalars(index_tke,k,iCell) = max(0.,min(100.,scalars(index_tke,k,iCell))) + end do do k=1,nVertLevels @@ -232,7 +244,7 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, delta_s = ((config_len_disp**2)*delta_z)**(1./3.) bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon_bv ) tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv - diss_length = min(delta_s,tke_length) + diss_length = min(delta_s,max(tke_length,0.01*delta_s)) if(bv_freq2(k,iCell) <= 0) diss_length = delta_s ! non-isotropic mixing @@ -251,6 +263,10 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, eddy_visc_h = c_k*l_horizontal*sqrt(scalars(index_tke,k,iCell)) eddy_visc_v = c_k*l_vertical*sqrt(scalars(index_tke,k,iCell)) + ! testing + !eddy_visc_horz(k,iCell) = eddy_visc_h + !eddy_visc_vert(k,iCell) = eddy_visc_v + ! terms for the prognostic tke integration shear_production = eddy_visc_h*(d_11(k)**2 + d_22(k)**2 + d_12(k)**2) & @@ -271,37 +287,30 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, prandtl_horizontal_inv = 3. prandtl_vertical_inv = 1.0+(2.0*l_vertical/delta_z) ! going to need to store this off somewhere - ! eddy viscocities set here if we are running the 1.5 order prognostic tke scheme - ! eddy_visc_horz(k,iCell) = c_k*l_horizontal*sqrt(scalars(index_tke,k,iCell)) - ! eddy_visc_vert(k,iCell) = c_k*l_vertical*sqrt(scalars(index_tke,k,iCell)) - ! RHS term for the subgrid ke. tend_scalars(index_tke,k,iCell) = rho_zz(k,iCell)*( shear_production + buoyancy + dissipation ) end do - end if ! end of test_tke + else -!*************************************************** + call mpas_log_write(' in les_models, no les scheme for '//trim(config_les_model), messageType=MPAS_LOG_CRIT) + + end if ! end of config_les_model test end do ! loop over all owned cells (columns) - ! set up coefficients for 4th-order horizontal background filter - - h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 - h_theta_eddy_visc4 = h_mom_eddy_visc4 - - if(debug_dissipation) call mpas_log_write(' exiting smagorinsky_3d ') + if(debug_dissipation) call mpas_log_write(' les_models ') - end subroutine smagorinsky_3d + end subroutine les_models -!--------------------------------------- +!--------------------------------------- subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) - use mpas_atm_dimensions ! pull nVertLevels and num_scalars from here + use mpas_atm_dimensions ! pull nVertLevels and num_scalars from here integer, intent(in) :: cellStart, cellEnd, nCells integer, intent(in) :: index_qv, index_qc @@ -378,7 +387,7 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in end subroutine calculate_n2 -!--------------------------------------- +!--------------------------------------- subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & @@ -391,7 +400,7 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert delsq_u, delsq_vorticity, delsq_divergence, & u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here implicit none @@ -440,17 +449,17 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(out) :: tend_u_euler - ! local variables + ! local variables integer :: iEdge, cell1, cell2, vertex1, vertex2, iVertex, iCell, i, k real (kind=RKIND) :: r_dc, r_dv, u_diffusion, kdiffu, r, edge_sign, u_mix_scale real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp real (kind=RKIND), dimension(nVertLevels) :: u_mix -!$OMP BARRIER +!$OMP BARRIER - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). - ! First, storage to hold the result from the first del^2 computation. + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). + ! First, storage to hold the result from the first del^2 computation. delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 @@ -462,11 +471,11 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert r_dc = invDcEdge(iEdge) r_dv = min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) -!DIR$ IVDEP +!DIR$ IVDEP do k=1,nVertLevels - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv @@ -474,17 +483,17 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert kdiffu = 0.5*(kdiff(k,cell1)+kdiff(k,cell2)) - ! include 2nd-orer diffusion here + ! include 2nd-orer diffusion here + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & + rho_edge(k,iEdge)* kdiffu * u_diffusion * meshScalingDel2(iEdge) end do end do - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active - -!$OMP BARRIER + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active +!$OMP BARRIER do iVertex=vertexStart,vertexEnd delsq_vorticity(1:nVertLevels,iVertex) = 0.0 do i=1,vertexDegree @@ -508,8 +517,7 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert end do end do -!$OMP BARRIER - +!$OMP BARRIER do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -520,16 +528,16 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert r_dc = u_mix_scale * config_del4u_div_factor * invDcEdge(iEdge) r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) -!DIR$ IVDEP +!DIR$ IVDEP do k=1,nVertLevels - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant - ! - ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor - ! relative to the rotational part. The stability constraint on the divergence component is much less - ! stringent than the rotational part, and this flexibility may be useful. - ! + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant + ! + ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor + ! relative to the rotational part. The stability constraint on the divergence component is much less + ! stringent than the rotational part, and this flexibility may be useful. + ! u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion @@ -537,14 +545,13 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert end do end do - end if ! 4th order mixing is active - - ! - ! vertical mixing for u - 2nd order filter in physical (z) space - ! + end if ! 4th order mixing is active + ! + ! vertical mixing for u - 2nd order filter in physical (z) space + ! if ( v_mom_eddy_visc2 > 0.0 ) then - if (config_mix_full) then ! mix full state + if (config_mix_full) then ! mix full state do iEdge=edgeSolveStart,edgeSolveEnd @@ -568,9 +575,9 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert end do end do - else ! idealized cases where we mix on the perturbation from the initial 1-D state + else ! idealized cases where we mix on the perturbation from the initial 1-D state - do iEdge=edgeSolveStart,edgeSolveEnd + do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -597,9 +604,9 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert end do end do - end if ! mix perturbation state + end if ! mix perturbation state - end if ! vertical mixing of horizontal momentum + end if ! vertical mixing of horizontal momentum end subroutine u_dissipation @@ -849,9 +856,9 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end if ! mix perturbation state - end if ! vertical mixing of horizontal momentum for fixe viscosity + end if ! vertical mixing of horizontal momentum for les formulation - if ( config_les_model == "3d_smagorinsky") then + if ( config_les_model /= "none") then do iEdge=edgeSolveStart,edgeSolveEnd @@ -1159,7 +1166,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end if - if ( config_les_model == "3d_smagorinsky") then + if ( config_les_model /= "none") then do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes @@ -1505,7 +1512,7 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn end if - if ( config_les_model == "3d_smagorinsky") then + if ( config_les_model /= "none") then do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index f79485b5be..961ceaefa3 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5286,21 +5286,22 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end if - else if (config_les_model == "3d_smagorinsky") then + else if (config_les_model /= "none") then ! call mpas_log_write(' BV call, index qv, qc, tke $i $i $i ', intArgs=(/index_qv, index_qc, index_tke/)) call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) - call smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, ur_cell, vr_cell, & - w, c_s, bn2, zgrid, config_len_disp, & - deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & - deformation_coef_c, deformation_coef_s, & - invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & - scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & - cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & - nCells, nEdges, nVertLevels, maxEdges, num_scalars ) + call les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, & + u, v, ur_cell, vr_cell, & + w, c_s, bn2, zgrid, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + deformation_coef_c, deformation_coef_s, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & + nCells, nEdges, nVertLevels, maxEdges, num_scalars ) end if @@ -5330,8 +5331,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end if ! tendency for density. - ! accumulate total water here for later use in w tendency calculation. - ! accumulate horizontal mass-flux !$acc parallel default(present) From 203fdef7c346af77fdcc0702e91e7bdcb10dddc1 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 24 Mar 2020 09:25:43 -0600 Subject: [PATCH 067/214] bug fixes and the addition of the Prandtl number formulation to the scalar mixing routines for the prognostic tke scheme. more testing to follow. --- .../dynamics/mpas_atm_dissipation_models.F | 61 +++++++++++++------ 1 file changed, 44 insertions(+), 17 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 9b1d122866..d99eb221d1 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -14,10 +14,13 @@ module mpas_atm_dissipation_models use mpas_log use mpas_derived_types, only : MPAS_LOG_CRIT - logical, parameter :: debug_dissipation = .true. + logical, parameter :: debug_dissipation = .false. logical, parameter :: les_test = .true. real (kind=RKIND), parameter :: tke_heat_flux = 0.24 real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 + real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 + real (kind=RKIND), parameter :: c_k = 0.25 + contains @@ -138,12 +141,12 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, real (kind=RKIND), dimension(nVertLevels) :: dudz, dvdz, dwdz real (kind=RKIND) :: rdz, def2, pr_inv, wk real (kind=RKIND) :: shear_production, buoyancy, dissipation, delta_z, delta_s, bv, tke_length, diss_length - real (kind=RKIND) :: l_horizontal, l_vertical, c_k, c_dissipation + real (kind=RKIND) :: l_horizontal, l_vertical, c_dissipation real (kind=RKIND) :: prandtl_horizontal_inv, prandtl_vertical_inv real (kind=RKIND) :: eddy_visc_h, eddy_visc_v logical, parameter :: test_tke=.true. - real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 + ! real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 if(debug_dissipation) call mpas_log_write(' begin les_models ') if(debug_dissipation) call mpas_log_write(' les scheme is '//trim(config_les_model)) @@ -243,7 +246,9 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) delta_s = ((config_len_disp**2)*delta_z)**(1./3.) bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon_bv ) - tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv + tke_length = delta_s + if(bv_freq2(k,iCell) .gt. 1.e-06) & + tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv diss_length = min(delta_s,max(tke_length,0.01*delta_s)) if(bv_freq2(k,iCell) <= 0) diss_length = delta_s @@ -264,8 +269,8 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, eddy_visc_v = c_k*l_vertical*sqrt(scalars(index_tke,k,iCell)) ! testing - !eddy_visc_horz(k,iCell) = eddy_visc_h - !eddy_visc_vert(k,iCell) = eddy_visc_v + eddy_visc_horz(k,iCell) = eddy_visc_h + eddy_visc_vert(k,iCell) = eddy_visc_v ! terms for the prognostic tke integration @@ -276,9 +281,8 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, ! dissipation - c_k = 0.25 c_dissipation = 1.9*c_k + max( 0.0, 0.93 - 1.9*c_k )*diss_length/delta_s - if( (k.eq. 1) .or. (k.eq.nVertLevels) ) c_dissipation = 3.9 + ! if( (k.eq. 1) .or. (k.eq.nVertLevels) ) c_dissipation = 3.9 dissipation = -c_dissipation*(scalars(index_tke,k,iCell)**(1.5))/diss_length @@ -1626,9 +1630,10 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo integer :: cell1, cell2, iEdge, iCell, i, k, iScalar real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp - real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux + real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux, prandtl_inverse real (kind=RKIND), dimension(num_scalars,nVertLevels+1) :: turb_vflux_scalars real (kind=RKIND) :: rho_k_at_w, zz_at_w + real (kind=RKIND) :: delta_z, delta_s, tke_length, bv_frequency2 logical, parameter :: vmix_scalars = .true. logical, parameter :: hmix_scalars = .true. @@ -1795,13 +1800,38 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes + + turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain turb_vflux(1) = 0. ! lower bc flux handled where ??? + + if ( config_les_model == "3d_smagorinsky") then + do k=2,nVertLevels + prandtl_inverse(k) = prandtl_inv + end do + else ! prognostic_1.5_order + do k=2,nVertLevels + delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) + delta_s = ((config_len_disp**2)*delta_z)**(1./3.) + bv_frequency2 = 0.5*(bv_freq2(k,iCell)+bv_freq2(k-1,iCell)) + tke_length = delta_s + if(bv_frequency2 .gt. 1.e-06) & + tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/sqrt(bv_frequency2) + prandtl_inverse(k) = 1. + 2.*tke_length/delta_z + end do + end if + do k=2,nVertLevels + + ! delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) + ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) + ! bv_frequency2 = 0.5*(bv_freq2(k)+bv_freq(k-1)) + ! bv = max( sqrt(abs(bv_frequency2)), epsilon_bv ) + rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) - turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) + turb_vflux(k) = - prandtl_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) end do ! test boundary conditions for supercell and les test cases @@ -1820,11 +1850,8 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do - end do - - if (mix_scalars .and. vmix_scalars) then + if (mix_scalars .and. vmix_scalars) then - do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes turb_vflux_scalars(:,nVertlevels+1) = 0. ! no turbulent flux out of the domain turb_vflux_scalars(:,1) = 0. ! lower bc flux handled where ??? @@ -1833,7 +1860,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) do iScalar=1,num_scalars - turb_vflux_scalars(iScalar,k) = - rho_k_at_w*zz_at_w*rdzu(k)* & + turb_vflux_scalars(iScalar,k) = - prandtl_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)* & (scalars(iScalar,k,iCell)-scalars(iScalar,k-1,iCell)) end do end do @@ -1858,9 +1885,9 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do - end do - end if ! mix scalars + + end do ! loop over cells (columns) end if From 1f442aecea508b0d492f34dc0651fa1272df0039 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Thu, 2 Apr 2020 11:38:42 -0600 Subject: [PATCH 068/214] changed Prandtl number to 1/3 for LES simulations in the MPAS_constants module. --- src/framework/mpas_constants.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/mpas_constants.F b/src/framework/mpas_constants.F index 2c8168510a..5822f9c0e6 100644 --- a/src/framework/mpas_constants.F +++ b/src/framework/mpas_constants.F @@ -53,7 +53,7 @@ module mpas_constants real (kind=RKIND), parameter :: cvpm = -cv / cp ! #endif real (kind=RKIND), parameter :: p0 = 1.0e5_RKIND !< Constant: 100000 Pa - real (kind=RKIND), parameter :: prandtl = 1.0_RKIND !< Constant: Prandtl number + real (kind=RKIND), parameter :: prandtl = 1.0_RKIND/3.0_RKIND !< Constant: Prandtl number contains From 57a88294e26633558ae83e0c40c41439d54e06d2 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Thu, 2 Apr 2020 11:40:56 -0600 Subject: [PATCH 069/214] implemented a perturbation coriolis term option for the LES cases. --- .../dynamics/mpas_atm_dissipation_models.F | 38 ++++++++++--------- .../dynamics/mpas_atm_time_integration.F | 15 ++++++++ 2 files changed, 35 insertions(+), 18 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index d99eb221d1..e0f802eae7 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -16,10 +16,12 @@ module mpas_atm_dissipation_models logical, parameter :: debug_dissipation = .false. logical, parameter :: les_test = .true. - real (kind=RKIND), parameter :: tke_heat_flux = 0.24 - real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 + !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour + real (kind=RKIND), parameter :: tke_heat_flux = 0.0 + !! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 ! ocean roughness length + real (kind=RKIND), parameter :: tke_drag_coefficient = 0.00935 real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 - real (kind=RKIND), parameter :: c_k = 0.25 + real (kind=RKIND), parameter :: c_k = 0.1 contains @@ -588,7 +590,7 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert do k=1,nVertLevels u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & - - v_init(k) * sin( angleEdge(iEdge) ) + + v_init(k) * sin( angleEdge(iEdge) ) end do do k=2,nVertLevels-1 @@ -838,7 +840,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v do k=1,nVertLevels u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & - - v_init(k) * sin( angleEdge(iEdge) ) + + v_init(k) * sin( angleEdge(iEdge) ) end do do k=2,nVertLevels-1 @@ -1568,6 +1570,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo bv_freq2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars_dummy, mix_scalars, & config_les_model, & + uReconstructZonal, uReconstructMeridional, & tend_theta_euler ) @@ -1609,6 +1612,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzp real (kind=RKIND), dimension(nVertLevels+1, nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: uReconstructZonal, uReconstructMeridional real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: t_init @@ -1638,6 +1642,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo logical, parameter :: vmix_scalars = .true. logical, parameter :: hmix_scalars = .true. logical, parameter :: hmix4_scalars = .false. + real (kind=RKIND) :: moisture_flux, heat_flux, theta_m_flux, c_h, c_q if(debug_dissipation) then call mpas_log_write(' begin scalar_dissipation_3d ') @@ -1837,7 +1842,15 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! test boundary conditions for supercell and les test cases if( les_test ) then - turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY + moisture_flux = 0. + heat_flux = tke_heat_flux + + ! bulk formulation will go here. + + theta_m_flux = heat_flux*(1.0+(rv/rgas)*scalars(index_qv,1,iCell)) & + +(rv/rgas)*theta_m(1,iCell)*moisture_flux/rho_zz(k,iCell) + ! turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY + turb_vflux(1) = theta_m_flux*rho_zz(1,iCell) turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) else turb_vflux(1) = turb_vflux(2) @@ -1865,18 +1878,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do - ! test boundary conditions for supercell and les test cases - - ! need lower bc for qv here... - - ! if( les_test ) then - ! turb_vflux_scalars(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY - ! turb_vflux_scalars(nVertLevels+1) = turb_vflux_scalars(nVertLevels) - ! else - ! turb_vflux_scalars(1) = turb_vflux_scalars(2) - ! turb_vflux_scalars(nVertLevels+1) = turb_vflux_scalars(nVertLevels) - ! end if - + if( les_test ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv do k=1,nVertLevels do iScalar=1,num_scalars diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 961ceaefa3..5d65db2752 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5198,6 +5198,10 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: flux3, flux4 real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 + logical, parameter :: perturbation_coriolis = .true. + real (kind=RKIND), parameter :: coriolis_value = 1.e-04 + real (kind=RKIND) :: reference_u + flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ua*( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 @@ -5458,6 +5462,16 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end do end do + if (perturbation_coriolis) then ! this is correct only for constant f + do j = 1,nEdgesOnEdge(iEdge) + eoe = edgesOnEdge(j,iEdge) + do k=1,nVertLevels + reference_u = u_init(k) * cos(angleEdge(eoe)) - v_init(k) * sin(angleEdge(eoe)) + q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * coriolis_value + end do + end do + end if + !DIR$ IVDEP !$acc loop vector do k=1,nVertLevels @@ -5849,6 +5863,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm bn2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars, mix_scalars, & config_les_model, & + ur_cell, vr_cell, & tend_theta_euler ) From 7ddd21d10bc15436a7975e2d8ecba8920d6c4d7c Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Thu, 2 Apr 2020 11:42:04 -0600 Subject: [PATCH 070/214] introduced the sheared PBL test case for the LES implementation, including setting both u_init and v_init properly for the perturbation coriolis terms. --- .../mpas_init_atm_cases.F | 58 ++++++++++++++++--- 1 file changed, 50 insertions(+), 8 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 0160139fb8..2371016310 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -6267,7 +6267,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes real (kind=RKIND), pointer :: config_ztop real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta - real (kind=RKIND), dimension(:), pointer :: u_init, qv_init, angleEdge, fEdge, fVertex + real (kind=RKIND), dimension(:), pointer :: u_init, v_init, qv_init, angleEdge, fEdge, fVertex real (kind=RKIND) :: u_vel, v_vel, randx call mpas_pool_get_array(mesh, 'xCell', xCell) @@ -6336,6 +6336,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes call mpas_pool_get_array(mesh, 'dss', dss) call mpas_pool_get_array(mesh, 't_init', t_init) call mpas_pool_get_array(mesh, 'u_init', u_init) + call mpas_pool_get_array(mesh, 'v_init', v_init) call mpas_pool_get_array(mesh, 'qv_init', qv_init) call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) call mpas_pool_get_array(mesh, 'fEdge', fEdge) @@ -6510,7 +6511,10 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes u_vel = atm_get_sounding('u',ztemp) v_vel = atm_get_sounding('v',ztemp) u(k,i) = cos(angleEdge(i))*u_vel - sin(angleEdge(i))*v_vel - if(i == 1 ) u_init(k) = u(k,i) + if(i == 1 ) then + u_init(k) = u_vel + v_init(k) = v_vel + end if end do end if end do @@ -6749,25 +6753,63 @@ real (kind=RKIND) function atm_get_sounding( variable, height ) atm_get_sounding = -999. if(variable == 'u') then - atm_get_sounding = 0. + atm_get_sounding = 15.0 else if (variable == 'v') then atm_get_sounding = 0. else if (variable == 'qv') then - atm_get_sounding = 0. + + atm_get_sounding = 0. ! dry sounding + ! atm_get_sounding = 0.010 + ! if(height .gt. 500.) atm_get_sounding = 0.004 + else if (variable == 'theta') then - if(height .le. 1000.) then + if(height .le. 500.) then atm_get_sounding = 300. - else if(height .le. 1150.) then - atm_get_sounding = 300. + (height-1000.)*8./150. + else if(height .le. 600.) then + atm_get_sounding = 300. + (height-500.)*3./100. else - atm_get_sounding = 308. + (height-1150.)*3./1000. + atm_get_sounding = 303. + (height-600.)*3./1000. end if + ! atm_get_sounding = atm_get_sounding - 10.0 ! for water case end if end function atm_get_sounding + real (kind=RKIND) function atm_get_sounding_1( variable, height ) + + implicit none + real (kind=RKIND), intent(in) :: height + character(len=*), intent(in) :: variable + + atm_get_sounding_1 = -999. + + if(variable == 'u') then + atm_get_sounding_1 = 10.0 + else if (variable == 'v') then + atm_get_sounding_1 = 0. + else if (variable == 'qv') then + + ! atm_get_sounding_1 = 0. ! dry sounding_1 + atm_get_sounding_1 = 0.010 + if(height .gt. 1000.) atm_get_sounding_1 = 0.004 + + else if (variable == 'theta') then + + if(height .le. 1000.) then + atm_get_sounding_1 = 300. + else if(height .le. 1150.) then + atm_get_sounding_1 = 300. + (height-1000.)*8./150. + else + atm_get_sounding_1 = 308. + (height-1150.)*3./1000. + end if + atm_get_sounding_1 = atm_get_sounding_1 - 10.0 ! for water case + + end if + + end function atm_get_sounding_1 + !----------- !----------------------------------------------------------------------- From 6212e0e5a61b821a2437f970095c660f55c73888 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Thu, 23 Apr 2020 13:59:49 -0600 Subject: [PATCH 071/214] Implemented SAS case sounding in LES initialization. --- .../mpas_init_atm_cases.F | 92 ++++++++++++++----- 1 file changed, 67 insertions(+), 25 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 2371016310..e9dc369a29 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -6248,7 +6248,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes real (kind=RKIND) :: r, xnutr real (kind=RKIND) :: ztemp, zd, zt, dz, str - real (kind=RKIND), dimension(nVertLevels ) :: qvb + real (kind=RKIND), dimension(nVertLevels ) :: qvb, qvp, zg real (kind=RKIND), dimension(nVertLevels ) :: t_init_1d real (kind=RKIND) :: d1, d2, d3, cof1, cof2 @@ -6580,6 +6580,8 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes ! qvb(k) = scalars(index_qv,k,1) ! QVB = 0 PRODUCES DRY REFERENCE STATE qvb(k) = 0. + qvp(k) = scalars(index_qv,k,1)*1000. + zg(k) = .5*(zgrid(k,1)+zgrid(k+1,1)) !********************************************************************* end do @@ -6596,10 +6598,10 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes end do !end of iteration loop - call mpas_log_write(' base state sounding ') - call mpas_log_write(' k, pb, rb, tb, rtb, t, rr, p, qvb') + call mpas_log_write(' sounding ') + call mpas_log_write(' k, zg, rb, tb, rtb, t, rr, p, qvp') do k=1,nVertLevels - call mpas_log_write('$i $r $r $r $r $r $r $r $r', intArgs=(/k/), realArgs=(/pb(k,1),rb(k,1),tb(k,1),rtb(k,1),t(k,1),rr(k,1),p(k,1),qvb(k)/)) + call mpas_log_write('$i $r $r $r $r $r $r $r $r', intArgs=(/k/), realArgs=(/zg(k),rb(k,1),tb(k,1),rtb(k,1),t(k,1),rr(k,1),p(k,1),qvp(k)/)) end do ! @@ -6751,32 +6753,39 @@ real (kind=RKIND) function atm_get_sounding( variable, height ) character(len=*), intent(in) :: variable atm_get_sounding = -999. +! SAS case sounding if(variable == 'u') then - atm_get_sounding = 15.0 + atm_get_sounding = 0.0 + else if (variable == 'v') then atm_get_sounding = 0. - else if (variable == 'qv') then - - atm_get_sounding = 0. ! dry sounding - ! atm_get_sounding = 0.010 - ! if(height .gt. 500.) atm_get_sounding = 0.004 else if (variable == 'theta') then - if(height .le. 500.) then - atm_get_sounding = 300. - else if(height .le. 600.) then - atm_get_sounding = 300. + (height-500.)*3./100. + if(height .le. 352.5) then + atm_get_sounding = 296.6 + else if(height .le. 442.5) then + atm_get_sounding = 296.6 + (height-352.5)*1.5/90. + else + atm_get_sounding = 298.1 + (height-442.5)*0.003 + end if + + else if (variable == 'qv') then + + if(height .le. 352.5) then + atm_get_sounding = 11.8/1000. + else if(height .le. 442.5) then + atm_get_sounding = 11.8/1000. - (height-352.5)*4.0/90./1000. else - atm_get_sounding = 303. + (height-600.)*3./1000. + atm_get_sounding = max(7.8/1000. - (height-442.5)*0.004/1000.,0.0) end if - ! atm_get_sounding = atm_get_sounding - 10.0 ! for water case end if end function atm_get_sounding + real (kind=RKIND) function atm_get_sounding_1( variable, height ) implicit none @@ -6786,30 +6795,63 @@ real (kind=RKIND) function atm_get_sounding_1( variable, height ) atm_get_sounding_1 = -999. if(variable == 'u') then - atm_get_sounding_1 = 10.0 + atm_get_sounding_1 = 15.0 else if (variable == 'v') then atm_get_sounding_1 = 0. else if (variable == 'qv') then - ! atm_get_sounding_1 = 0. ! dry sounding_1 - atm_get_sounding_1 = 0.010 - if(height .gt. 1000.) atm_get_sounding_1 = 0.004 + atm_get_sounding_1 = 0. ! dry sounding + ! atm_get_sounding_1 = 0.010 + ! if(height .gt. 500.) atm_get_sounding_1 = 0.004 else if (variable == 'theta') then - if(height .le. 1000.) then + if(height .le. 500.) then atm_get_sounding_1 = 300. - else if(height .le. 1150.) then - atm_get_sounding_1 = 300. + (height-1000.)*8./150. + else if(height .le. 600.) then + atm_get_sounding_1 = 300. + (height-500.)*3./100. else - atm_get_sounding_1 = 308. + (height-1150.)*3./1000. + atm_get_sounding_1 = 303. + (height-600.)*3./1000. end if - atm_get_sounding_1 = atm_get_sounding_1 - 10.0 ! for water case + ! atm_get_sounding_1 = atm_get_sounding_1 - 10.0 ! for water case end if end function atm_get_sounding_1 + real (kind=RKIND) function atm_get_sounding_2( variable, height ) + + implicit none + real (kind=RKIND), intent(in) :: height + character(len=*), intent(in) :: variable + + atm_get_sounding_2 = -999. + + if(variable == 'u') then + atm_get_sounding_2 = 10.0 + else if (variable == 'v') then + atm_get_sounding_2 = 0. + else if (variable == 'qv') then + + ! atm_get_sounding_2 = 0. ! dry sounding_2 + atm_get_sounding_2 = 0.010 + if(height .gt. 1000.) atm_get_sounding_2 = 0.004 + + else if (variable == 'theta') then + + if(height .le. 1000.) then + atm_get_sounding_2 = 300. + else if(height .le. 1150.) then + atm_get_sounding_2 = 300. + (height-1000.)*8./150. + else + atm_get_sounding_2 = 308. + (height-1150.)*3./1000. + end if + atm_get_sounding_2 = atm_get_sounding_2 - 10.0 ! for water case + + end if + + end function atm_get_sounding_2 + !----------- !----------------------------------------------------------------------- From 35910083c352652dff17021bbe45533d607376f5 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 14:22:38 -0700 Subject: [PATCH 072/214] Added the SAS LES time-varying lower boundary moisture and heat fluxes. --- .../dynamics/mpas_atm_dissipation_models.F | 53 +++++++++++++++++-- .../dynamics/mpas_atm_time_integration.F | 15 +++++- 2 files changed, 63 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index e0f802eae7..7fdf0e4794 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -15,7 +15,7 @@ module mpas_atm_dissipation_models use mpas_derived_types, only : MPAS_LOG_CRIT logical, parameter :: debug_dissipation = .false. - logical, parameter :: les_test = .true. + logical, parameter :: les_test = .false., les_sas_test = .true. !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour real (kind=RKIND), parameter :: tke_heat_flux = 0.0 !! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 ! ocean roughness length @@ -1535,6 +1535,8 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn if( les_test ) then turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY + ! SAS case lower flux for theta_m - code goes here + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) else turb_vflux(1) = turb_vflux(2) @@ -1569,7 +1571,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo eddy_visc_horz, eddy_visc_vert, & bv_freq2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars_dummy, mix_scalars, & - config_les_model, & + config_les_model, time_of_day_seconds, & uReconstructZonal, uReconstructMeridional, & tend_theta_euler ) @@ -1586,6 +1588,8 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo integer, intent(in) :: num_scalars_dummy integer, intent(in) :: index_tke, index_qv + real (kind=RKIND), intent(in) :: time_of_day_seconds + logical, intent(in) :: config_mix_full, mix_scalars character (len=StrKIND) :: config_les_model @@ -1643,6 +1647,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo logical, parameter :: hmix_scalars = .true. logical, parameter :: hmix4_scalars = .false. real (kind=RKIND) :: moisture_flux, heat_flux, theta_m_flux, c_h, c_q + real (kind=RKIND) :: qv_cell, theta_m_cell, theta_cell if(debug_dissipation) then call mpas_log_write(' begin scalar_dissipation_3d ') @@ -1842,6 +1847,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! test boundary conditions for supercell and les test cases if( les_test ) then + moisture_flux = 0. heat_flux = tke_heat_flux @@ -1852,9 +1858,27 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY turb_vflux(1) = theta_m_flux*rho_zz(1,iCell) turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + + else if (les_sas_test) then + + ! if(iCell == 1) call mpas_log_write(' les_sas_test for theta and qv surface fluxes ') + qv_cell = scalars(index_qv,1,iCell) + theta_m_cell = theta_m(1,iCell) + theta_cell = theta_m_cell/(1.0+(rv/rgas)*qv_cell) + + call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) + if(iCell == 1) call mpas_log_write(' SAS t and qv fluxes, $r, $r ', realArgs=(/heat_flux, moisture_flux/)) + + theta_m_flux = heat_flux*(1.0+(rv/rgas)*qv_cell)+(rv/rgas)*theta_cell*moisture_flux + turb_vflux(1) = theta_m_flux*rho_zz(1,iCell) + moisture_flux = moisture_flux*rho_zz(1,iCell) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + else + turb_vflux(1) = turb_vflux(2) turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + end if @@ -1878,7 +1902,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do - if( les_test ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv + if( les_test .or. les_sas_test ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv do k=1,nVertLevels do iScalar=1,num_scalars @@ -1897,4 +1921,27 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end subroutine scalar_dissipation_3d_les +!----------- + + subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) + + implicit none + + real (kind=RKIND), intent(in) :: time_of_day_seconds + real (kind=RKIND), intent(out) :: heat_flux, moisture_flux + + real (kind=RKIND), parameter:: t_start_t_flux = 3600.*6.0 + real (kind=RKIND), parameter:: t_end_t_flux = 3600.*19.50 + real (kind=RKIND), parameter:: t_start_q_flux = 3600.*7.0 + real (kind=RKIND), parameter:: t_end_q_flux = 3600.*19.50 + real (kind=RKIND) :: rel_time_t_flux, rel_time_q_flux + + rel_time_t_flux = max(0.,(time_of_day_seconds - t_start_t_flux)/(t_end_t_flux - t_start_t_flux)) + rel_time_q_flux = max(0.,(time_of_day_seconds - t_start_q_flux)/(t_end_q_flux - t_start_q_flux)) + + heat_flux = max(0., 0.1*sin(pii*rel_time_t_flux)) + moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux)) + + end subroutine flux_les_sas + end module mpas_atm_dissipation_models diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 5d65db2752..f8fee790ff 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -24,7 +24,8 @@ module atm_time_integration use mpas_vector_reconstruction ! Added only clause to keep xlf90 from getting confused from the overloaded abs intrinsic in mpas_timekeeping use mpas_derived_types, only : MPAS_Time_type, MPAS_TimeInterval_type, MPAS_NOW - use mpas_timekeeping, only: mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+) + use mpas_timekeeping, only: MPAS_Time_type, MPAS_TimeInterval_type, mpas_get_clock_time, & + mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+), add_t_ti use mpas_timer #ifdef DO_PHYSICS @@ -5202,6 +5203,11 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), parameter :: coriolis_value = 1.e-04 real (kind=RKIND) :: reference_u + type (MPAS_Time_Type) :: currTime + integer :: H, M, S, S_n, S_d + integer :: ierr + real(kind=RKIND) :: time_of_day_seconds + flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ua*( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 @@ -5297,6 +5303,11 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) + currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) + call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) + time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*dt + ! call mpas_log_write(' les integration, timestep midpoint time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) + call les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, & u, v, ur_cell, vr_cell, & w, c_s, bn2, zgrid, config_len_disp, & @@ -5862,7 +5873,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eddy_visc_horz, eddy_visc_vert, & bn2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars, mix_scalars, & - config_les_model, & + config_les_model, time_of_day_seconds, & ur_cell, vr_cell, & tend_theta_euler ) From f77c123d939aa723e4fd266489cf6b7275cd680a Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 4 May 2020 12:25:35 -0600 Subject: [PATCH 073/214] changed the initialization for the random potential temperature preturbation, the Coriolis parameter and the horizontal wind field (u) to match the SAS cases configuration --- .../mpas_init_atm_cases.F | 43 +++++++++++++------ 1 file changed, 30 insertions(+), 13 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index e9dc369a29..12de5af3e9 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -6608,20 +6608,35 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes ! potential temperature perturbation ! - do i=1,nCells - do k = 1,4 ! same as in WRF - call random_number(randx) - thi(k,i) = thi(k,i) + 0.1*(randx-0.5) - t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) - end do +! do i=1,nCells +! do k = 1,nz1 ! same as in WRF +! call random_number(randx) +! thi(k,i) = thi(k,i) + 0.1*(randx-0.5) +! t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) +! end do +! end do + + do k = 1,nz1 ! same as in WRF + if(zg(k) .le. 397.0) then ! the SAS initial PBL height + do i=1,nCells + call random_number(randx) + thi(k,i) = thi(k,i) + 1.0*(randx-0.5) + t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) + end do + end if end do ! ! initial seed for tke ! - do i=1,nCells - do k = 1,nz1 - scalars(index_tke,k,i) = 0.1 - end do + scalars(index_tke,:,:) = 0. + + do k = 1,nz1 + if( zg(k) .le. 255.) then + do i=1,nCells + !! scalars(index_tke,k,i) = 0.1 + scalars(index_tke,k,i) = 0.4*((1.-(zg(k)/255.))**3) + end do + end if end do do itr=1,30 @@ -6708,11 +6723,13 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes ! Generate rotated Coriolis field - same settings as in WRF ! do iEdge=1,nEdges - fEdge(iEdge) = 1.e-04 + ! fEdge(iEdge) = 1.e-04 + fEdge(iEdge) = 7.2921e-05 end do do iVtx=1,nVertices - fVertex(iVtx) = 1.e-04 + ! fVertex(iVtx) = 1.e-04 + fVertex(iVtx) = 7.2921e-05 end do ! @@ -6756,7 +6773,7 @@ real (kind=RKIND) function atm_get_sounding( variable, height ) ! SAS case sounding if(variable == 'u') then - atm_get_sounding = 0.0 + atm_get_sounding = 2.0 ! SAS value else if (variable == 'v') then atm_get_sounding = 0. From b6f044a8a45816d55dbd9a1fd7ff9c6ae9828bf2 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 4 May 2020 12:27:55 -0600 Subject: [PATCH 074/214] Added a 3D diagnostic variable: the inverse Prandtl number used in the scalar mixing formulation in the prognostic LES scheme. This allows for computing it only once and also allows it to be output for use in off-line diagnostic calculation of the sub-grid fluxes. --- src/core_atmosphere/Registry.xml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index f78ca1b2fb..9d1d5ac8a7 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1971,6 +1971,9 @@ + + From 2a9afcaac60b4626ce2bcc7fccf745198d1a9dde Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 4 May 2020 12:31:42 -0600 Subject: [PATCH 075/214] Threaded the 3D inverse Prandtl number through to the routines that need it in the prognostic LES models, and set its values appropriately. Also switched the hardwired formulation to isotropic mixing. --- .../dynamics/mpas_atm_dissipation_models.F | 48 +++++++++++-------- .../dynamics/mpas_atm_time_integration.F | 12 +++-- 2 files changed, 38 insertions(+), 22 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 7fdf0e4794..891cc6152a 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -99,7 +99,7 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, & w, c_s, bv_freq2, zgrid, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & - deformation_coef_c, deformation_coef_s, & + deformation_coef_c, deformation_coef_s, prandtl_3d_inv, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & @@ -115,6 +115,7 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: uCell real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: vCell real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: bv_freq2 + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: prandtl_3d_inv real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout) :: scalars real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: tend_scalars @@ -249,22 +250,24 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, delta_s = ((config_len_disp**2)*delta_z)**(1./3.) bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon_bv ) tke_length = delta_s + ! isentropic mixing formulation if(bv_freq2(k,iCell) .gt. 1.e-06) & tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv + tke_length = min(tke_length, delta_z) diss_length = min(delta_s,max(tke_length,0.01*delta_s)) if(bv_freq2(k,iCell) <= 0) diss_length = delta_s ! non-isotropic mixing - l_horizontal = config_len_disp - l_vertical = min(delta_z,tke_length) - if(bv_freq2(k,iCell) <= 0) diss_length = delta_z + ! l_horizontal = config_len_disp + ! l_vertical = min(delta_z,tke_length) + ! if(bv_freq2(k,iCell) <= 0) diss_length = delta_z ! isotropic mixing - ! l_horizontal = min(delta_s,tke_length) - ! if(bv_freq2(k,iCell) <= 0) diss_length = delta_s - ! l_vertical = l_horizontal + l_horizontal = min(delta_s,tke_length) + if(bv_freq2(k,iCell) <= 0) diss_length = delta_s + l_vertical = l_horizontal ! eddy viscocities set here if we are running the 1.5 order prognostic tke scheme eddy_visc_h = c_k*l_horizontal*sqrt(scalars(index_tke,k,iCell)) @@ -291,7 +294,8 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, ! computing eddy viscosities ********* prandtl_horizontal_inv = 3. - prandtl_vertical_inv = 1.0+(2.0*l_vertical/delta_z) ! going to need to store this off somewhere + prandtl_3d_inv(k,iCell) = 1.0+(2.0*l_vertical/delta_z) + ! RHS term for the subgrid ke. @@ -1566,6 +1570,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo config_mix_full, t_init, zgrid, & rdzw, rdzu, fzm, fzp, & v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + prandtl_3d_inv, & delsq_theta, & theta_m, rho_edge, rho_zz, zz, & eddy_visc_horz, eddy_visc_vert, & @@ -1621,6 +1626,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: t_init real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: bv_freq2 + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: prandtl_3d_inv real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout) :: tend_scalars real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m @@ -1819,16 +1825,20 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo do k=2,nVertLevels prandtl_inverse(k) = prandtl_inv end do - else ! prognostic_1.5_order - do k=2,nVertLevels - delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) - delta_s = ((config_len_disp**2)*delta_z)**(1./3.) - bv_frequency2 = 0.5*(bv_freq2(k,iCell)+bv_freq2(k-1,iCell)) - tke_length = delta_s - if(bv_frequency2 .gt. 1.e-06) & - tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/sqrt(bv_frequency2) - prandtl_inverse(k) = 1. + 2.*tke_length/delta_z - end do + else ! prognostic_1.5_order, isentropic mixing length + ! do k=2,nVertLevels + ! delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) + ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) + ! bv_frequency2 = 0.5*(bv_freq2(k,iCell)+bv_freq2(k-1,iCell)) + ! tke_length = delta_s + ! if(bv_frequency2 .gt. 1.e-06) & + ! tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/sqrt(bv_frequency2) + ! tke_length = min(delta_z,tke_length) + ! prandtl_inverse(k) = 1. + 2.*tke_length/delta_z + ! end do + + prandtl_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) + end if do k=2,nVertLevels @@ -1940,7 +1950,7 @@ subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) rel_time_q_flux = max(0.,(time_of_day_seconds - t_start_q_flux)/(t_end_q_flux - t_start_q_flux)) heat_flux = max(0., 0.1*sin(pii*rel_time_t_flux)) - moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux)) + moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux))/1000. end subroutine flux_les_sas diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index f8fee790ff..58ee52ffbd 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4816,6 +4816,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c2, deformation_coef_s2, deformation_coef_cs real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c, deformation_coef_s + real (kind=RKIND), dimension(:,:), pointer :: prandtl_3d_inv + real(kind=RKIND), dimension(:,:), pointer :: tend_w_pgf, tend_w_buoy @@ -4892,6 +4894,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(diag, 'pressure_base', pressure_b) call mpas_pool_get_array(diag, 'h_divergence', h_divergence) call mpas_pool_get_array(diag, 'exner', exner) + call mpas_pool_get_array(diag, 'prandtl_3d_inv', prandtl_3d_inv) + call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) @@ -4995,7 +4999,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_les_model, & - config_del4u_div_factor, & + prandtl_3d_inv, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & config_mpas_cam_coef, & @@ -5023,7 +5027,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_les_model, & - config_del4u_div_factor, & + prandtl_3d_inv, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & config_mpas_cam_coef, & @@ -5087,6 +5091,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_horz real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1) :: bn2 + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: prandtl_3d_inv real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign real (kind=RKIND), dimension(vertexDegree,nVertices+1) :: edgesOnVertex_sign real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw_save @@ -5312,7 +5317,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm u, v, ur_cell, vr_cell, & w, c_s, bn2, zgrid, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & - deformation_coef_c, deformation_coef_s, & + deformation_coef_c, deformation_coef_s, prandtl_3d_inv, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & @@ -5868,6 +5873,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm config_mix_full, t_init, zgrid, & rdzw, rdzu, fzm, fzp, & v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + prandtl_3d_inv, & delsq_theta, & theta_m, rho_edge, rho_zz, zz, & eddy_visc_horz, eddy_visc_vert, & From 7bef48fb31cdd8c178be5a328fd87cf2e3e6315e Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 13 May 2020 16:00:22 -0600 Subject: [PATCH 076/214] ustm passed to u_dissipation_3d, diag_physics pool accessed --- .../dynamics/mpas_atm_dissipation_models.F | 3 +- .../dynamics/mpas_atm_time_integration.F | 39 ++++++++++++------- 2 files changed, 28 insertions(+), 14 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 891cc6152a..b44e1ebbab 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -633,7 +633,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & fzm, fzp, config_les_model, & delsq_u, delsq_vorticity, delsq_divergence, & - u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) + u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, tend_u_euler ) use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here @@ -691,6 +691,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_divergence real (kind=RKIND), dimension(nVertLevels), intent(in) :: u_init, v_init + real (kind=RKIND), dimension(nCells+1), intent(in) :: ustm real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(out) :: tend_u_euler diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 58ee52ffbd..c32c7a5801 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1149,6 +1149,14 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) end if call mpas_timer_start('atm_compute_dyn_tend') + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'tend', tend) + call mpas_pool_get_subpool(block % structs, 'diag_physics', diag_physics) + call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) allocate(delsq_theta(nVertLevels,nCells+1)) allocate(delsq_w(nVertLevels,nCells+1)) @@ -1172,15 +1180,16 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !$acc end parallel !$OMP PARALLEL DO - do thread=1,nThreads - call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, block % configs, nVertLevels, rk_step, dt, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do + do thread=1,nThreads + call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, diag_physics, & + block % configs, nVertLevels, rk_step, dt, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + end do !$OMP END PARALLEL DO deallocate(delsq_theta) @@ -4736,7 +4745,7 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge end subroutine atm_advance_scalars_mono_work - subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, nVertLevels, rk_step, dt, & + subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_physics, configs, nVertLevels, rk_step, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -4762,6 +4771,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, type (mpas_pool_type), intent(in) :: state type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: diag_physics type (mpas_pool_type), intent(in) :: configs integer, intent(in) :: nVertLevels ! for allocating stack variables integer, intent(in) :: rk_step @@ -4899,6 +4909,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) + call mpas_pool_get_array(diag_physics,'ustm'  ,ustm  ) + call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) @@ -5005,7 +5017,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & - rthdynten, & + tend_rtheta_adv, rthdynten, ustm, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -5033,7 +5045,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & - rthdynten, & + tend_rtheta_adv, rthdynten, ustm, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -5091,6 +5103,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_horz real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1) :: bn2 + real (kind=RKIND), dimension(nCells+1) :: ustm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: prandtl_3d_inv real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign real (kind=RKIND), dimension(vertexDegree,nVertices+1) :: edgesOnVertex_sign @@ -5533,7 +5546,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & fzm, fzp, config_les_model, & delsq_u, delsq_vorticity, delsq_divergence, & - u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) + u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, tend_u_euler ) ! else ! this is the original MPAS dissipation code ! From f2ae5beb59154911fa6f98348b82ea7156878fa5 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 15 May 2020 14:08:27 -0600 Subject: [PATCH 077/214] ustm add pointer remove blanks in pool statement --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index c32c7a5801..96e74f7202 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4817,6 +4817,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys real (kind=RKIND), dimension(:), pointer :: rdzu, rdzw, fzm, fzp, qv_init real (kind=RKIND), dimension(:,:), pointer :: t_init + real (kind=RKIND), dimension(:), pointer:: ustm real (kind=RKIND), pointer :: cf1, cf2, cf3 @@ -4909,7 +4910,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) - call mpas_pool_get_array(diag_physics,'ustm'  ,ustm  ) + call mpas_pool_get_array(diag_physics,'ustm',ustm) call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) From 1ab69a02c4c0a1773e636c8090abe78f52c935fb Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 3 Jun 2020 15:09:15 -0600 Subject: [PATCH 078/214] add les_model check to bypass pbl calls --- src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F index 72a411aeba..43837ee27c 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F @@ -775,6 +775,7 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics bl_mynn_tkeadvect character(len=StrKIND),pointer:: pbl_scheme + character(len=StrKIND),pointer:: config_les_model integer,pointer:: bl_mynn_cloudpdf, & bl_mynn_mixlength, & @@ -813,6 +814,7 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics call mpas_pool_get_config(configs,'config_do_DAcycling',config_do_DAcycling) call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) call mpas_pool_get_config(configs,'config_pbl_scheme' ,pbl_scheme ) + call mpas_pool_get_config(configs, 'config_les_model', config_les_model) !copy MPAS arrays to local arrays: call pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,ite) @@ -820,6 +822,7 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics initflag = 1 if(config_do_restart .or. itimestep > 1) initflag = 0 + if(config_les_model == "none") then pbl_select: select case (trim(pbl_scheme)) case("bl_ysu") @@ -964,6 +967,8 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics case default end select pbl_select + + endif ! les skip pbl !copy local arrays to MPAS grid: call pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) From b6f5cba0ddda660c118f99e333304262535880e0 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 17 Jun 2020 15:56:42 -0600 Subject: [PATCH 079/214] add time_of_day_seconds calculation (compiles) --- .../physics/mpas_atmphys_driver_sfclayer.F | 42 +++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index afde4fa523..3435ecbe60 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -8,7 +8,11 @@ !================================================================================================================= module mpas_atmphys_driver_sfclayer use mpas_kind_types + use mpas_derived_types use mpas_pool_routines +! use mpas_timekeeping, only: MPAS_Time_type, MPAS_TimeInterval_type, mpas_get_clock_time, & +! mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+), add_t_ti + use mpas_timekeeping, only: MPAS_Time_type, mpas_get_clock_time, mpas_get_time use mpas_timer, only : mpas_timer_start, mpas_timer_stop use mpas_atmphys_constants @@ -32,6 +36,7 @@ module mpas_atmphys_driver_sfclayer integer,parameter,private:: iz0tlnd = 0 !=0,(Carlson-Boland). integer,parameter,private:: scm_force_flux = 0 !SCM surface forcing by surface fluxes. !0=no 1=yes (WRF single column model option only). + type (MPAS_Clock_type), pointer, private :: clock !MPAS driver for parameterization of the surface layer. !Laura D. Fowler (send comments to laura@ucar.edu). @@ -854,6 +859,7 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite logical,pointer:: config_do_restart,config_frac_seaice character(len=StrKIND),pointer:: sfclayer_scheme real(kind=RKIND),dimension(:),pointer:: areaCell + real(kind=RKIND),pointer:: config_dt !local variables: integer:: initflag @@ -863,6 +869,11 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite character(len=StrKIND):: errmsg integer:: errflg + type (MPAS_Time_Type) :: currTime + integer :: H, M, S, S_n, S_d + integer :: ierr + real(kind=RKIND) :: time_of_day_seconds + !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_sfclayer:') @@ -874,6 +885,7 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) + call mpas_pool_get_config(configs,'config_dt',config_dt) call mpas_pool_get_array(mesh,'areaCell',areaCell) @@ -889,6 +901,12 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite case("sf_monin_obukhov") call mpas_timer_start('sf_monin_obukhov') + + currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) + call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) + time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*config_dt + call mpas_log_write(' sfclay, time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) + call sfclay( & p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & u3d = u_p , v3d = v_p , qv3d = qv_p , & @@ -1087,6 +1105,30 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite end subroutine driver_sfclayer + subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) + + implicit none + + real (kind=RKIND), intent(in) :: time_of_day_seconds + real (kind=RKIND), intent(out) :: heat_flux, moisture_flux + + real (kind=RKIND), parameter:: t_start_t_flux = 3600.*6.0 + real (kind=RKIND), parameter:: t_end_t_flux = 3600.*19.50 + real (kind=RKIND), parameter:: t_start_q_flux = 3600.*7.0 + real (kind=RKIND), parameter:: t_end_q_flux = 3600.*19.50 + real (kind=RKIND) :: rel_time_t_flux, rel_time_q_flux + + rel_time_t_flux = max(0.,(time_of_day_seconds - t_start_t_flux)/(t_end_t_flux - t_start_t_flux)) + rel_time_q_flux = max(0.,(time_of_day_seconds - t_start_q_flux)/(t_end_q_flux - t_start_q_flux)) + + heat_flux = max(0., 0.1*sin(pii*rel_time_t_flux)) + moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux))/1000. + + end subroutine flux_les_sas + + + + !================================================================================================================= end module mpas_atmphys_driver_sfclayer !================================================================================================================= From d6d42f0de61cdef68009bdc4827f5ef4f346996c Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 23 Jun 2020 14:55:07 -0600 Subject: [PATCH 080/214] add flux_les_sas call in driver_sfclayer routine --- src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index 3435ecbe60..bc0007eb7a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -873,6 +873,7 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite integer :: H, M, S, S_n, S_d integer :: ierr real(kind=RKIND) :: time_of_day_seconds + real(kind=RKIND) :: heat_flux, moisture_flux !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') @@ -906,6 +907,7 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*config_dt call mpas_log_write(' sfclay, time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) + call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) call sfclay( & p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & From a7a1dc58ee7988b367cf21a7e1aefe805e438446 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 23 Jun 2020 15:18:51 -0600 Subject: [PATCH 081/214] add fluxes to sfclay arguments and pass in --- src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F | 6 ++++++ src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F | 5 ++++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index bc0007eb7a..bc379217b9 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -874,6 +874,7 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite integer :: ierr real(kind=RKIND) :: time_of_day_seconds real(kind=RKIND) :: heat_flux, moisture_flux + logical :: specified_flux !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') @@ -908,6 +909,7 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*config_dt call mpas_log_write(' sfclay, time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) + specified_flux = .true. call sfclay( & p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & @@ -932,6 +934,8 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite ustm = ustm_p , ck = ck_p , cka = cka_p , & cd = cd_p , cda = cda_p , isftcflx = isftcflx , & iz0tlnd = iz0tlnd , scm_force_flux = scm_force_flux , & + heat_flux = heat_flux , moisture_flux = moisture_flux , & + specified_flux = specified_flux , & ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & @@ -961,6 +965,8 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite ustm = ustm_sea , ck = ck_sea , cka = cka_sea , & cd = cd_sea , cda = cda_sea , isftcflx = isftcflx , & iz0tlnd = iz0tlnd , scm_force_flux = scm_force_flux , & + heat_flux = heat_flux , moisture_flux = moisture_flux , & + specified_flux = specified_flux , & ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F index 2b3ba578f0..d9709a5547 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -25,7 +25,8 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & ustm,ck,cka,cd,cda, & - isftcflx,iz0tlnd,scm_force_flux) + isftcflx,iz0tlnd,scm_force_flux, & + heat_flux, moisture_flux, specified_flux ) !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- @@ -184,6 +185,8 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX + REAL, INTENT(IN ) :: heat_flux, moisture_flux + LOGICAL, INTENT(IN ) :: specified_flux REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT ) :: QSFC From e6d26f2bf42aebc84f98d14de2f94aa1cd4848f8 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 30 Jul 2020 10:44:57 -0600 Subject: [PATCH 082/214] pass heat flux args to sfclay1d --- src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F index d9709a5547..bd614cb359 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -246,6 +246,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT, & P1000mb, & + heat_flux, moisture_flux, specified_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -271,6 +272,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & P1000mb, & + heat_flux, moisture_flux, specified_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -292,6 +294,8 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT REAL, INTENT(IN ) :: P1000mb + REAL, INTENT(IN ) :: heat_flux, moisture_flux + LOGICAL, INTENT(IN ) :: specified_flux ! REAL, DIMENSION( ims:ime ) , & INTENT(IN ) :: MAVAIL, & From 460c8b5dc2113e9bfd72696c0d653e03ff11603c Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 30 Jul 2020 11:11:56 -0600 Subject: [PATCH 083/214] copy specified fluxes to hfx and qfx before sfclay1d --- .../physics/physics_wrf/module_sf_sfclay.F | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F index bd614cb359..948f6e52ce 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -230,6 +230,13 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & T1D(i) =T3D(i,1,j) ENDDO + IF(specified_flux)THEN + DO i=its,ite + HFX(i,j)=heat_flux + QFX(i,j)=moisture_flux + ENDDO + ENDIF + ! Sending array starting locations of optional variables may cause ! troubles, so we explicitly change the call. @@ -246,7 +253,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT, & P1000mb, & - heat_flux, moisture_flux, specified_flux, & + specified_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -272,7 +279,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & P1000mb, & - heat_flux, moisture_flux, specified_flux, & + specified_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -294,7 +301,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT REAL, INTENT(IN ) :: P1000mb - REAL, INTENT(IN ) :: heat_flux, moisture_flux LOGICAL, INTENT(IN ) :: specified_flux ! REAL, DIMENSION( ims:ime ) , & From fb5e94f36e79b1ae266cde5afc14df7e76e17b27 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 30 Jul 2020 15:51:56 -0600 Subject: [PATCH 084/214] add MOL and BR calculations to sfclay1d --- .../physics/physics_wrf/module_sf_sfclay.F | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F index 948f6e52ce..7d726e40ae 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -398,6 +398,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & REAL :: FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,GZ0OZQ,GZ0OZT REAL :: ZW, ZN1, ZN2 REAL :: Z0T, CZC + REAL :: USTI !------------------------------------------------------------------- KL=kte @@ -544,6 +545,15 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & 260 CONTINUE + IF(specified_flux)THEN +! Need to recalculate MOL and BR when HFX is given and TSK is not used + DO I=ITS,ITE +! MOL is THETA* + USTI = MAX(UST(I),0.01) + MOL(I) = HFX(I)/(RHOX(I)*CP*USTI) + BR(I) = KARMAN*GOVRTH(I)*ZA(I)*MOL(I)/(USTI*USTI)/GZ1OZ0(I) + ENDDO + ENDIF ! !-----DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATED STABILITY CLASS: ! From 88df14a5bf98a19db023dfb58954379ed3874659 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 12 Aug 2020 14:48:22 -0600 Subject: [PATCH 085/214] add ustm drag in u_dissipation_3d les_sas_test --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index b44e1ebbab..90b843168b 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -705,6 +705,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux real (kind=RKIND) :: rho_k_cell1, rho_k_cell2, rho_k_at_w real (kind=RKIND) :: zz_cell1, zz_cell2, zz_at_w + real (kind=RKIND) :: ust_edge real (kind=RKIND) :: velocity_magnitude @@ -895,6 +896,11 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v velocity_magnitude = sqrt(u(1,iEdge)**2 + v(1,iEdge)**2) turb_vflux(1) = -rho_edge(1,iEdge)*tke_drag_coefficient*u(1,iEdge)*velocity_magnitude turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + else if (les_sas_test) then + ust_edge = 0.5*(ustm(cell1) + ustm(cell2)) + velocity_magnitude = max(sqrt(u(1,iEdge)**2 + v(1,iEdge)**2),0.1) + turb_vflux(1) = -rho_edge(1,iEdge)*ust_edge*ust_edge*(u(1,iEdge)/velocity_magnitude) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) ! end test conditions else ! test conditions for supercell case From 5c9feb4e8a7fa6a7a5e5f53b2ca5d876ca8e96fa Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 13 Aug 2020 10:07:27 -0600 Subject: [PATCH 086/214] skip hfx and qfx calcs in sfclay for specified_flux --- src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F index 7d726e40ae..77a115231d 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -844,6 +844,8 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & 330 CONTINUE ! 335 CONTINUE + + IF(specified_flux) GOTO 410 !-----COMPUTE THE SURFACE SENSIBLE AND LATENT HEAT FLUXES: IF ( PRESENT(SCM_FORCE_FLUX) ) THEN From d0d418d2bcdc914015df02031bfa0b6e83f42e36 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 13 Aug 2020 16:02:52 -0600 Subject: [PATCH 087/214] pass hfx and qfx to dissipation and use for les_sas --- .../dynamics/mpas_atm_dissipation_models.F | 6 +++++- .../dynamics/mpas_atm_time_integration.F | 11 +++++++---- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 90b843168b..b19fd9551c 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1585,6 +1585,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo index_tke, index_qv, num_scalars_dummy, mix_scalars, & config_les_model, time_of_day_seconds, & uReconstructZonal, uReconstructMeridional, & + hfx, qfx, & tend_theta_euler ) @@ -1641,6 +1642,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + real (kind=RKIND), dimension(nCells+1), intent(in) :: hfx, qfx real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler @@ -1883,7 +1885,9 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo theta_m_cell = theta_m(1,iCell) theta_cell = theta_m_cell/(1.0+(rv/rgas)*qv_cell) - call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) +! call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) + heat_flux = hfx(iCell)/rho_zz(1,iCell)/cp + moisture_flux = qfx(iCell) if(iCell == 1) call mpas_log_write(' SAS t and qv fluxes, $r, $r ', realArgs=(/heat_flux, moisture_flux/)) theta_m_flux = heat_flux*(1.0+(rv/rgas)*qv_cell)+(rv/rgas)*theta_cell*moisture_flux diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 96e74f7202..2c78768b84 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4817,7 +4817,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys real (kind=RKIND), dimension(:), pointer :: rdzu, rdzw, fzm, fzp, qv_init real (kind=RKIND), dimension(:,:), pointer :: t_init - real (kind=RKIND), dimension(:), pointer:: ustm + real (kind=RKIND), dimension(:), pointer:: ustm, hfx, qfx real (kind=RKIND), pointer :: cf1, cf2, cf3 @@ -4911,6 +4911,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) call mpas_pool_get_array(diag_physics,'ustm',ustm) + call mpas_pool_get_array(diag_physics,'hfx',hfx) + call mpas_pool_get_array(diag_physics,'qfx',qfx) call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) @@ -5018,7 +5020,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & - tend_rtheta_adv, rthdynten, ustm, & + tend_rtheta_adv, rthdynten, ustm, hfx, qfx, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -5046,7 +5048,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & - tend_rtheta_adv, rthdynten, ustm, & + tend_rtheta_adv, rthdynten, ustm, hfx, qfx, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -5104,7 +5106,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_horz real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1) :: bn2 - real (kind=RKIND), dimension(nCells+1) :: ustm + real (kind=RKIND), dimension(nCells+1) :: ustm, hfx, qfx real (kind=RKIND), dimension(nVertLevels,nCells+1) :: prandtl_3d_inv real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign real (kind=RKIND), dimension(vertexDegree,nVertices+1) :: edgesOnVertex_sign @@ -5895,6 +5897,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm index_tke, index_qv, num_scalars, mix_scalars, & config_les_model, time_of_day_seconds, & ur_cell, vr_cell, & + hfx, qfx, & tend_theta_euler ) From 3121ce5a425b484da045cd97b25bf23268f644d7 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 18 Aug 2020 11:44:13 -0600 Subject: [PATCH 088/214] comment out duplicate flux_les_sas in dissipiation module --- .../dynamics/mpas_atm_dissipation_models.F | 28 +++++++++---------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index b19fd9551c..501efd8df9 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1944,25 +1944,25 @@ end subroutine scalar_dissipation_3d_les !----------- - subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) +! subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) - implicit none +! implicit none - real (kind=RKIND), intent(in) :: time_of_day_seconds - real (kind=RKIND), intent(out) :: heat_flux, moisture_flux +! real (kind=RKIND), intent(in) :: time_of_day_seconds +! real (kind=RKIND), intent(out) :: heat_flux, moisture_flux - real (kind=RKIND), parameter:: t_start_t_flux = 3600.*6.0 - real (kind=RKIND), parameter:: t_end_t_flux = 3600.*19.50 - real (kind=RKIND), parameter:: t_start_q_flux = 3600.*7.0 - real (kind=RKIND), parameter:: t_end_q_flux = 3600.*19.50 - real (kind=RKIND) :: rel_time_t_flux, rel_time_q_flux +! real (kind=RKIND), parameter:: t_start_t_flux = 3600.*6.0 +! real (kind=RKIND), parameter:: t_end_t_flux = 3600.*19.50 +! real (kind=RKIND), parameter:: t_start_q_flux = 3600.*7.0 +! real (kind=RKIND), parameter:: t_end_q_flux = 3600.*19.50 +! real (kind=RKIND) :: rel_time_t_flux, rel_time_q_flux - rel_time_t_flux = max(0.,(time_of_day_seconds - t_start_t_flux)/(t_end_t_flux - t_start_t_flux)) - rel_time_q_flux = max(0.,(time_of_day_seconds - t_start_q_flux)/(t_end_q_flux - t_start_q_flux)) +! rel_time_t_flux = max(0.,(time_of_day_seconds - t_start_t_flux)/(t_end_t_flux - t_start_t_flux)) +! rel_time_q_flux = max(0.,(time_of_day_seconds - t_start_q_flux)/(t_end_q_flux - t_start_q_flux)) - heat_flux = max(0., 0.1*sin(pii*rel_time_t_flux)) - moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux))/1000. +! heat_flux = max(0., 0.1*sin(pii*rel_time_t_flux)) +! moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux))/1000. - end subroutine flux_les_sas +! end subroutine flux_les_sas end module mpas_atm_dissipation_models From af3233d053950096aeb8d3fa4d5df40582722c58 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 18 Aug 2020 11:51:02 -0600 Subject: [PATCH 089/214] Set dummy TSK and UST=USTM (no VCONV) --- .../physics/physics_wrf/module_sf_sfclay.F | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F index 77a115231d..9739b08786 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -410,10 +410,16 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & !----CONVERT GROUND TEMPERATURE TO POTENTIAL TEMPERATURE: ! DO 5 I=its,ite - TGDSA(I)=TSK(I) + IF(.not.specified_flux)THEN + TGDSA(I)=TSK(I) ! PSFC cb -! THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP - THGB(I)=TSK(I)*(P1000mb/PSFCPA(I))**ROVCP +! THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP + THGB(I)=TSK(I)*(P1000mb/PSFCPA(I))**ROVCP + ELSE +! with specified_flux TSK value is not input and given value will not affect USTM + TGDSA(I)=300. + THGB(I)=300.*(P1000mb/PSFCPA(I))**ROVCP + ENDIF 5 CONTINUE ! !-----DECOUPLE FLUX-FORM VARIABLES TO GIVE U,V,T,THETA,THETA-VIR., @@ -819,6 +825,8 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & WSPDI(I)=SQRT(UX(I)*UX(I)+VX(I)*VX(I)) IF ( PRESENT(USTM) ) THEN USTM(I)=0.5*USTM(I)+0.5*KARMAN*WSPDI(I)/PSIX +! For specified_flux VCONV effect not added to UST that will be used for ZOL + IF(specified_flux)UST(I)=USTM(I) ENDIF U10(I)=UX(I)*PSIX10/PSIX V10(I)=VX(I)*PSIX10/PSIX From 16637caa1cf3f3a2369f84980976b88a6ff3b1dd Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 18 Aug 2020 14:38:11 -0600 Subject: [PATCH 090/214] sign correction for MOL --- src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F index 9739b08786..36e53d11f0 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -556,7 +556,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & DO I=ITS,ITE ! MOL is THETA* USTI = MAX(UST(I),0.01) - MOL(I) = HFX(I)/(RHOX(I)*CP*USTI) + MOL(I) = - HFX(I)/(RHOX(I)*CP*USTI) BR(I) = KARMAN*GOVRTH(I)*ZA(I)*MOL(I)/(USTI*USTI)/GZ1OZ0(I) ENDDO ENDIF From 210df8e127ebe3363fb8a5aa7627ea1abb00d0c2 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 19 Aug 2020 10:59:52 -0600 Subject: [PATCH 091/214] pass clock atm_do_timestep to physics_driver to driver_sfclayer --- src/core_atmosphere/mpas_atm_core.F | 2 +- src/core_atmosphere/physics/mpas_atmphys_driver.F | 7 ++++--- src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F | 4 +++- 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index f7d04a1f0c..ce9875cc89 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -1015,7 +1015,7 @@ subroutine atm_do_timestep(domain, dt, itimestep) !proceed with physics if moist_physics is set to true: if(moist_physics) then call physics_timetracker(domain,dt,clock,itimestep,xtime_s) - call physics_driver(domain,itimestep,xtime_s) + call physics_driver(domain,clock,itimestep,xtime_s) endif #endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index 8e31672657..5d9d5d092c 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -108,12 +108,13 @@ module mpas_atmphys_driver !================================================================================================================= - subroutine physics_driver(domain,itimestep,xtime_s) + subroutine physics_driver(domain,clock,itimestep,xtime_s) !================================================================================================================= !input arguments: integer,intent(in):: itimestep real(kind=RKIND),intent(in):: xtime_s + type(MPAS_Clock_type),intent(in):: clock !inout arguments: type(domain_type),intent(inout):: domain @@ -269,8 +270,8 @@ subroutine physics_driver(domain,itimestep,xtime_s) call allocate_sfclayer(block%configs) !$OMP PARALLEL DO do thread=1,nThreads - call driver_sfclayer(itimestep,block%configs,mesh,diag_physics,sfc_input, & - cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + call driver_sfclayer(clock,itimestep,block%configs,mesh,diag_physics,sfc_input, & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO call deallocate_sfclayer(block%configs) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index bc379217b9..791d933405 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -841,10 +841,12 @@ subroutine init_sfclayer(configs) end subroutine init_sfclayer !================================================================================================================= - subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) + subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,its,ite) !================================================================================================================= !input and inout arguments: + type(MPAS_Clock_type),intent(in):: clock + type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: sfc_input From eba2aeec2a673c0a64a19e5de1f2f43f8b758589 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 19 Aug 2020 15:29:14 -0600 Subject: [PATCH 092/214] put k loop around prandtl_inverse calc in dissipation --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 501efd8df9..71c694c9a4 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1846,7 +1846,9 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! prandtl_inverse(k) = 1. + 2.*tke_length/delta_z ! end do - prandtl_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) + do k=2,nVertLevels + prandtl_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) + end do end if From 9895ad556b19bccbc56353f7e3580338a04ca012 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Fri, 25 Sep 2020 14:31:17 -0600 Subject: [PATCH 093/214] bug fixes - fixed an uninitialized value in the w turbulent flux at the model top, and fixed a problem with the variable prandtl_inv in the scalar 3d mixing routine. --- .../dynamics/mpas_atm_dissipation_models.F | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 71c694c9a4..7d170c8bd3 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1191,6 +1191,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*zz(k,iCell) & *rdzu(k)*(w(k+1,iCell)-w(k,iCell)) end do + turb_vflux(nVertLevels+1) = 0. do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) @@ -1653,7 +1654,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo integer :: cell1, cell2, iEdge, iCell, i, k, iScalar real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp - real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux, prandtl_inverse + real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux, prandtl_1d_inverse real (kind=RKIND), dimension(num_scalars,nVertLevels+1) :: turb_vflux_scalars real (kind=RKIND) :: rho_k_at_w, zz_at_w real (kind=RKIND) :: delta_z, delta_s, tke_length, bv_frequency2 @@ -1832,7 +1833,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo if ( config_les_model == "3d_smagorinsky") then do k=2,nVertLevels - prandtl_inverse(k) = prandtl_inv + prandtl_1d_inverse(k) = prandtl_inv end do else ! prognostic_1.5_order, isentropic mixing length ! do k=2,nVertLevels @@ -1847,7 +1848,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! end do do k=2,nVertLevels - prandtl_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) + prandtl_1d_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) end do end if @@ -1862,7 +1863,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) - turb_vflux(k) = - prandtl_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) + turb_vflux(k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) end do ! test boundary conditions for supercell and les test cases @@ -1920,7 +1921,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) do iScalar=1,num_scalars - turb_vflux_scalars(iScalar,k) = - prandtl_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)* & + turb_vflux_scalars(iScalar,k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)* & (scalars(iScalar,k,iCell)-scalars(iScalar,k-1,iCell)) end do end do From 82a1a8cc2780d5d9b4c9d143250d89d87ef98e12 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 27 Oct 2020 11:36:32 -0600 Subject: [PATCH 094/214] hfx = heat_flux*rho*cp (factor added) --- src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F index 36e53d11f0..73852e6220 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -211,6 +211,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & REAL, DIMENSION( its:ite ) :: DX2D INTEGER :: I,J + REAL :: RHO DO J=jts,jte @@ -232,7 +233,8 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & IF(specified_flux)THEN DO i=its,ite - HFX(i,j)=heat_flux + RHO = P1D(i)/R/(T1D(i)*(1.+EP1*QV1D(i))) + HFX(i,j)=heat_flux*RHO*CP QFX(i,j)=moisture_flux ENDDO ENDIF From a7828afda7380955fd30179fb6cc1ff2ce95ed7b Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 10 Nov 2020 14:05:56 -0700 Subject: [PATCH 095/214] add print for ust_edge --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 7d170c8bd3..3430571a2f 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -898,6 +898,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) else if (les_sas_test) then ust_edge = 0.5*(ustm(cell1) + ustm(cell2)) + if(iEdge == 1) call mpas_log_write(' SAS ust_edge, $r ', realArgs=(/ust_edge/)) velocity_magnitude = max(sqrt(u(1,iEdge)**2 + v(1,iEdge)**2),0.1) turb_vflux(1) = -rho_edge(1,iEdge)*ust_edge*ust_edge*(u(1,iEdge)/velocity_magnitude) turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) From 5e34d468f13bbe6e9a90334ba0c94fe70b83b145 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 10 Nov 2020 16:00:01 -0700 Subject: [PATCH 096/214] initialize landmask, lu_index(ivgtyp), xland = 1 --- .../mpas_init_atm_cases.F | 35 ++++++++++++++----- 1 file changed, 26 insertions(+), 9 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 12de5af3e9..785f7a4b68 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -403,11 +403,12 @@ subroutine init_atm_setup_case(domain, stream_manager) call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block_ptr % structs, 'fg', fg) call mpas_pool_get_subpool(block_ptr % structs, 'state', state) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) call mpas_log_write(' calling test case setup ') - call init_atm_case_les(domain % dminfo, mesh, nCells, nVertLevels, state, diag, config_init_case, block_ptr % configs) + call init_atm_case_les(domain % dminfo, mesh, fg, nCells, nVertLevels, state, diag, config_init_case, block_ptr % configs) call decouple_variables(mesh, nCells, nVertLevels, state, diag) call mpas_log_write(' returned from test case setup ') block_ptr => block_ptr % next @@ -6203,7 +6204,7 @@ end subroutine init_atm_case_lbc !--------------------- - subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, test_case, configs) + subroutine init_atm_case_les(dminfo, mesh, fg, nCells, nVertLevels, state, diag, test_case, configs) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Large Eddy Simulation (les) test case setup !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -6212,6 +6213,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes type (dm_info), intent(in) :: dminfo type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(inout) :: fg integer, intent(in) :: nCells integer, intent(in) :: nVertLevels type (mpas_pool_type), intent(inout) :: state @@ -6226,6 +6228,9 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes real (kind=RKIND), dimension(:,:,:), pointer :: scalars real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 + real (kind=RKIND), dimension(:), pointer :: xland + integer, dimension(:), pointer :: landmask, lu_index + !This is temporary variable here. It just need when calculate tangential velocity v. integer :: eoe, j integer, dimension(:), pointer :: nEdgesOnEdge @@ -6372,6 +6377,10 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes call mpas_pool_get_dimension(state, 'index_qv', index_qv) call mpas_pool_get_dimension(state, 'index_tke', index_tke) + call mpas_pool_get_array(fg, 'xland', xland) + call mpas_pool_get_array(mesh, 'landmask', landmask) + call mpas_pool_get_array(mesh, 'lu_index', lu_index) + scalars(:,:,:) = 0. call atm_initialize_advection_rk(mesh, nCells, nEdges, maxEdges, on_a_sphere, sphere_radius ) @@ -6543,7 +6552,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes call mpas_dmpar_bcast_real(dminfo, pibtop) ptopb = p0*pibtop**(1./rcp) - call mpas_log_write('ptopb = $r', realArgs=(/0.01_RKIND*ptopb/)) +! call mpas_log_write('ptopb = $r', realArgs=(/0.01_RKIND*ptopb/)) do i=1, nCells pb(nz1,i) = pibtop+.5*dzw(nz1)*gravity*(1.+qvb(nz1))/(cp*tb(nz1,i)*zz(nz1,i)) @@ -6648,7 +6657,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes end do pitop = pitop - .5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1)) ptop = p0*pitop**(1./rcp) - call mpas_log_write('ptop = $r $r', realArgs=(/0.01_RKIND*ptop, 0.01_RKIND*ptopb/)) +! call mpas_log_write('ptop = $r $r', realArgs=(/0.01_RKIND*ptop, 0.01_RKIND*ptopb/)) call mpas_dmpar_bcast_real(dminfo, ptop) @@ -6666,11 +6675,11 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes +fzp(k+1)*(rb(k ,i)*(scalars(index_qv,k ,i)-qvb(k)) & +rr(k ,i)*(1.+scalars(index_qv,k ,i)))) end do - if (itr==1.and.i==1) then - do k=1,nz1 - call mpas_log_write('pp-check $r', realArgs=(/pp(k,i)/)) - end do - end if +! if (itr==1.and.i==1) then +! do k=1,nz1 +! call mpas_log_write('pp-check $r', realArgs=(/pp(k,i)/)) +! end do +! end if do k=1,nz1 rt(k,i) = (pp(k,i)/(rgas*zz(k,i)) & -rtb(k,i)*(p(k,i)-pb(k,i)))/p(k,i) @@ -6760,6 +6769,14 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes end do end do + do iCell = 1, nCells + !land category + landmask(iCell) = 1 + lu_index(iCell) = 1 + xland(iCell) = 1.0 + if (iCell == 1) call mpas_log_write(' landmask, lu_index, xland $i $i $r', intArgs=(/landmask(iCell),lu_index(iCell)/), realArgs=(/xland(iCell)/)) + end do + end subroutine init_atm_case_les From 451424455359c0f24903f800d614bd9446960a36 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 2 Nov 2021 15:33:00 -0600 Subject: [PATCH 097/214] change hardwired value of f - need to generize to use fEdge --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 2c78768b84..f69f0847c8 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5221,7 +5221,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 logical, parameter :: perturbation_coriolis = .true. - real (kind=RKIND), parameter :: coriolis_value = 1.e-04 + real (kind=RKIND), parameter :: coriolis_value = 7.2921e-05 real (kind=RKIND) :: reference_u type (MPAS_Time_Type) :: currTime From cdb3a2e1b2cc37f074ae1e42e4178c13ef8f6abe Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 3 Nov 2021 12:59:51 -0600 Subject: [PATCH 098/214] fix rdzw/rdzu for w dissipation, use fEdge instead of coriolis_value --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 4 ++-- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 3 +-- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 3430571a2f..63d558dfb8 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1190,12 +1190,12 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, ! compute turbulent fluxes do k=1,nVertLevels turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*zz(k,iCell) & - *rdzu(k)*(w(k+1,iCell)-w(k,iCell)) + *rdzw(k)*(w(k+1,iCell)-w(k,iCell)) end do turb_vflux(nVertLevels+1) = 0. do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & - - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + - rdzu(k)*(turb_vflux(k)-turb_vflux(k-1)) end do end do diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index f69f0847c8..064b8d4db3 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5221,7 +5221,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 logical, parameter :: perturbation_coriolis = .true. - real (kind=RKIND), parameter :: coriolis_value = 7.2921e-05 real (kind=RKIND) :: reference_u type (MPAS_Time_Type) :: currTime @@ -5499,7 +5498,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eoe = edgesOnEdge(j,iEdge) do k=1,nVertLevels reference_u = u_init(k) * cos(angleEdge(eoe)) - v_init(k) * sin(angleEdge(eoe)) - q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * coriolis_value + q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * fEdge(iEdge) end do end do end if From dcaa6205a88d97d4a0a984c82f43dedf4c287c5f Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 3 Nov 2021 15:07:25 -0600 Subject: [PATCH 099/214] revert to hardwired f until fEdge can be used --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 064b8d4db3..948b50b7d7 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5498,7 +5498,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eoe = edgesOnEdge(j,iEdge) do k=1,nVertLevels reference_u = u_init(k) * cos(angleEdge(eoe)) - v_init(k) * sin(angleEdge(eoe)) - q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * fEdge(iEdge) + q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * 0.729210E-04 end do end do end if From 19e94ab31d43ed255be9c2e3b0704a43277e9879 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 30 Nov 2021 14:08:23 -0700 Subject: [PATCH 100/214] convert moisture_flux w'q' to surface flux qfx --- src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F index 73852e6220..f7399e4b40 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -235,7 +235,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & DO i=its,ite RHO = P1D(i)/R/(T1D(i)*(1.+EP1*QV1D(i))) HFX(i,j)=heat_flux*RHO*CP - QFX(i,j)=moisture_flux + QFX(i,j)=moisture_flux*RHO ENDDO ENDIF From 2bea0489d118f0efef4acc55c9024c0e5ad7c5c9 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 8 Dec 2021 11:58:20 -0700 Subject: [PATCH 101/214] moisture_flux in dynamics should be w'q' = qfx/rho --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 63d558dfb8..99d899462e 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1891,7 +1891,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) heat_flux = hfx(iCell)/rho_zz(1,iCell)/cp - moisture_flux = qfx(iCell) + moisture_flux = qfx(iCell)/rho_zz(1,iCell) if(iCell == 1) call mpas_log_write(' SAS t and qv fluxes, $r, $r ', realArgs=(/heat_flux, moisture_flux/)) theta_m_flux = heat_flux*(1.0+(rv/rgas)*qv_cell)+(rv/rgas)*theta_cell*moisture_flux From 99e890589fce090dd5f454fd45b1cd818e01baa0 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 24 Mar 2022 11:34:03 -0600 Subject: [PATCH 102/214] add commented fEdge line while still using hardwired f --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 948b50b7d7..73d9731e52 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5498,6 +5498,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eoe = edgesOnEdge(j,iEdge) do k=1,nVertLevels reference_u = u_init(k) * cos(angleEdge(eoe)) - v_init(k) * sin(angleEdge(eoe)) +! q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * fEdge(iEdge) q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * 0.729210E-04 end do end do From 684cc611e820186d6fa0bf304f29f16991140b16 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 22 Jun 2022 15:53:09 -0600 Subject: [PATCH 103/214] initial prep to use les_test option --- .../dynamics/mpas_atm_dissipation_models.F | 10 +++++++--- .../dynamics/mpas_atm_time_integration.F | 4 ++-- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 99d899462e..39ab3c9ad4 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -15,7 +15,7 @@ module mpas_atm_dissipation_models use mpas_derived_types, only : MPAS_LOG_CRIT logical, parameter :: debug_dissipation = .false. - logical, parameter :: les_test = .false., les_sas_test = .true. + logical, parameter :: les_test = .true., les_sas_test = .false. !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour real (kind=RKIND), parameter :: tke_heat_flux = 0.0 !! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 ! ocean roughness length @@ -1874,10 +1874,14 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo moisture_flux = 0. heat_flux = tke_heat_flux + qv_cell = scalars(index_qv,1,iCell) + theta_m_cell = theta_m(1,iCell) + theta_cell = theta_m_cell/(1.0+(rv/rgas)*qv_cell) ! bulk formulation will go here. - theta_m_flux = heat_flux*(1.0+(rv/rgas)*scalars(index_qv,1,iCell)) & - +(rv/rgas)*theta_m(1,iCell)*moisture_flux/rho_zz(k,iCell) +! theta_m_flux = heat_flux*(1.0+(rv/rgas)*scalars(index_qv,1,iCell)) & +! +(rv/rgas)*theta_m(1,iCell)*moisture_flux/rho_zz(k,iCell) + theta_m_flux = heat_flux*(1.0+(rv/rgas)*qv_cell)+(rv/rgas)*theta_cell*moisture_flux ! turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY turb_vflux(1) = theta_m_flux*rho_zz(1,iCell) turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 73d9731e52..48dce63ab7 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5498,8 +5498,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eoe = edgesOnEdge(j,iEdge) do k=1,nVertLevels reference_u = u_init(k) * cos(angleEdge(eoe)) - v_init(k) * sin(angleEdge(eoe)) -! q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * fEdge(iEdge) - q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * 0.729210E-04 + q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * fEdge(iEdge) +! q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * 0.729210E-04 end do end do end if From 2410a5143d9a13a9666c5ed88d05e1517988a598 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 30 Oct 2024 09:57:52 -0600 Subject: [PATCH 104/214] fix for compile --- src/core_init_atmosphere/mpas_atm_advection.F | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index 3b487f3797..891224a5e3 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -785,11 +785,7 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere integer :: iv, ie logical :: do_the_cell -<<<<<<< HEAD real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, dx, dy -======= - real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost ->>>>>>> 94ba9031b (Fixed error in w_x, w_y deformation coefficients.) logical, pointer :: is_periodic real(kind=RKIND), pointer :: x_period, y_period From f0ee5ebaa6efebbcf985a81c39e143025f1eb7d0 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 30 Oct 2024 13:21:19 -0600 Subject: [PATCH 105/214] fixes to compile init_atmosphere --- src/core_init_atmosphere/mpas_atm_advection.F | 1 - .../mpas_init_atm_cases.F | 39 ++++++++++--------- 2 files changed, 21 insertions(+), 19 deletions(-) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index 891224a5e3..bff8843fbc 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -1023,7 +1023,6 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere end subroutine atm_initialize_deformation_weights - end module atm_advection !----------------------- subroutine atm_init_test_coefs( deformation_coef_c2, deformation_coef_s2, & diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 785f7a4b68..cdfb9324f3 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -367,6 +367,27 @@ subroutine init_atm_setup_case(domain, stream_manager) ! call mpas_stream_mgr_reset_alarms(stream_manager, streamID='lbc', direction=MPAS_STREAM_OUTPUT, ierr=ierr) + else if (config_init_case == 10) then + + call mpas_log_write(' les test case ') + block_ptr => domain % blocklist + do while (associated(block_ptr)) + + call mpas_pool_get_dimension(block_ptr % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) + + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block_ptr % structs, 'fg', fg) + call mpas_pool_get_subpool(block_ptr % structs, 'state', state) + call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) + + call mpas_log_write(' calling test case setup ') + call init_atm_case_les(domain % dminfo, mesh, fg, nCells, nVertLevels, state, diag, config_init_case, block_ptr % configs) + call decouple_variables(mesh, nCells, nVertLevels, state, diag) + call mpas_log_write(' returned from test case setup ') + block_ptr => block_ptr % next + end do + else if (config_init_case == 13 ) then call mpas_log_write(' CAM-MPAS grid ') @@ -393,24 +414,6 @@ subroutine init_atm_setup_case(domain, stream_manager) call init_atm_case_cam_mpas(stream_manager, domain % dminfo, block_ptr, & mesh, block_ptr % dimensions, block_ptr % configs, nVertLevels) - else if (config_init_case == 10) then - - call mpas_log_write(' les test case ') - block_ptr => domain % blocklist - do while (associated(block_ptr)) - - call mpas_pool_get_dimension(block_ptr % dimensions, 'nCells', nCells) - call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) - - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block_ptr % structs, 'fg', fg) - call mpas_pool_get_subpool(block_ptr % structs, 'state', state) - call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) - - call mpas_log_write(' calling test case setup ') - call init_atm_case_les(domain % dminfo, mesh, fg, nCells, nVertLevels, state, diag, config_init_case, block_ptr % configs) - call decouple_variables(mesh, nCells, nVertLevels, state, diag) - call mpas_log_write(' returned from test case setup ') block_ptr => block_ptr % next end do From af5807a6d4266d0e399e8980abdf349bc672c141 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 1 Nov 2024 10:19:39 -0600 Subject: [PATCH 106/214] to compile atmosphere --- src/core_atmosphere/Registry.xml | 4 ---- .../dynamics/mpas_atm_time_integration.F | 16 +++------------- 2 files changed, 3 insertions(+), 17 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 9d1d5ac8a7..2f159f3958 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1696,13 +1696,10 @@ - packages="mp_thompson_in"/> - - @@ -2080,7 +2077,6 @@ - packages="mp_thompson_in"/> diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 48dce63ab7..b687fdc0a3 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -16,14 +16,13 @@ module atm_time_integration - use mpas_derived_types use mpas_pool_routines use mpas_kind_types use mpas_constants use mpas_dmpar use mpas_vector_reconstruction ! Added only clause to keep xlf90 from getting confused from the overloaded abs intrinsic in mpas_timekeeping - use mpas_derived_types, only : MPAS_Time_type, MPAS_TimeInterval_type, MPAS_NOW + use mpas_derived_types, only : MPAS_NOW use mpas_timekeeping, only: MPAS_Time_type, MPAS_TimeInterval_type, mpas_get_clock_time, & mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+), add_t_ti use mpas_timer @@ -1149,14 +1148,6 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) end if call mpas_timer_start('atm_compute_dyn_tend') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_subpool(block % structs, 'diag_physics', diag_physics) - call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) allocate(delsq_theta(nVertLevels,nCells+1)) allocate(delsq_w(nVertLevels,nCells+1)) @@ -4848,7 +4839,6 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys logical, pointer :: config_rayleigh_damp_u real (kind=RKIND), pointer :: config_rayleigh_damp_u_timescale_days integer, pointer :: config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels - integer, pointer :: config_number_rayleigh_damp_u_levels integer, pointer :: index_qv, index_qc, index_tke logical :: inactive_rthdynten @@ -5020,7 +5010,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & - tend_rtheta_adv, rthdynten, ustm, hfx, qfx, & + rthdynten, ustm, hfx, qfx, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -5048,7 +5038,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & - tend_rtheta_adv, rthdynten, ustm, hfx, qfx, & + rthdynten, ustm, hfx, qfx, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) From a28454222ffd25e4a60d2d542917c2ce58c5a240 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 2 Jan 2025 14:20:53 -0700 Subject: [PATCH 107/214] fix small error in tke shear production and add surface heat flux --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 39ab3c9ad4..7933a777bc 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -17,9 +17,9 @@ module mpas_atm_dissipation_models logical, parameter :: debug_dissipation = .false. logical, parameter :: les_test = .true., les_sas_test = .false. !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour - real (kind=RKIND), parameter :: tke_heat_flux = 0.0 + real (kind=RKIND), parameter :: tke_heat_flux = 0.03 !! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 ! ocean roughness length - real (kind=RKIND), parameter :: tke_drag_coefficient = 0.00935 + real (kind=RKIND), parameter :: tke_drag_coefficient = 0.006 real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 real (kind=RKIND), parameter :: c_k = 0.1 @@ -280,7 +280,7 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, ! terms for the prognostic tke integration shear_production = eddy_visc_h*(d_11(k)**2 + d_22(k)**2 + d_12(k)**2) & - +eddy_visc_v*(d_33(k)**2 + d_13(k)**2 + d_13(k)**2) + +eddy_visc_v*(d_33(k)**2 + d_13(k)**2 + d_23(k)**2) buoyancy = -eddy_visc_v*bv_freq2(k,iCell) From c3f694c42250a4a9a4e116f139488c4968a7b65d Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 19 Mar 2025 11:53:12 -0600 Subject: [PATCH 108/214] remove specialized physics code to leave dynonly les --- src/core_atmosphere/mpas_atm_core.F | 2 +- .../physics/mpas_atmphys_driver.F | 7 ++- .../physics/mpas_atmphys_driver_pbl.F | 5 -- .../physics/mpas_atmphys_driver_sfclayer.F | 54 +------------------ .../physics/physics_wrf/module_sf_sfclay.F | 43 ++------------- 5 files changed, 9 insertions(+), 102 deletions(-) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index ce9875cc89..f7d04a1f0c 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -1015,7 +1015,7 @@ subroutine atm_do_timestep(domain, dt, itimestep) !proceed with physics if moist_physics is set to true: if(moist_physics) then call physics_timetracker(domain,dt,clock,itimestep,xtime_s) - call physics_driver(domain,clock,itimestep,xtime_s) + call physics_driver(domain,itimestep,xtime_s) endif #endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index 5d9d5d092c..8e31672657 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -108,13 +108,12 @@ module mpas_atmphys_driver !================================================================================================================= - subroutine physics_driver(domain,clock,itimestep,xtime_s) + subroutine physics_driver(domain,itimestep,xtime_s) !================================================================================================================= !input arguments: integer,intent(in):: itimestep real(kind=RKIND),intent(in):: xtime_s - type(MPAS_Clock_type),intent(in):: clock !inout arguments: type(domain_type),intent(inout):: domain @@ -270,8 +269,8 @@ subroutine physics_driver(domain,clock,itimestep,xtime_s) call allocate_sfclayer(block%configs) !$OMP PARALLEL DO do thread=1,nThreads - call driver_sfclayer(clock,itimestep,block%configs,mesh,diag_physics,sfc_input, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + call driver_sfclayer(itimestep,block%configs,mesh,diag_physics,sfc_input, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO call deallocate_sfclayer(block%configs) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F index 43837ee27c..72a411aeba 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F @@ -775,7 +775,6 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics bl_mynn_tkeadvect character(len=StrKIND),pointer:: pbl_scheme - character(len=StrKIND),pointer:: config_les_model integer,pointer:: bl_mynn_cloudpdf, & bl_mynn_mixlength, & @@ -814,7 +813,6 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics call mpas_pool_get_config(configs,'config_do_DAcycling',config_do_DAcycling) call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) call mpas_pool_get_config(configs,'config_pbl_scheme' ,pbl_scheme ) - call mpas_pool_get_config(configs, 'config_les_model', config_les_model) !copy MPAS arrays to local arrays: call pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,ite) @@ -822,7 +820,6 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics initflag = 1 if(config_do_restart .or. itimestep > 1) initflag = 0 - if(config_les_model == "none") then pbl_select: select case (trim(pbl_scheme)) case("bl_ysu") @@ -967,8 +964,6 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics case default end select pbl_select - - endif ! les skip pbl !copy local arrays to MPAS grid: call pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index 791d933405..afde4fa523 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -8,11 +8,7 @@ !================================================================================================================= module mpas_atmphys_driver_sfclayer use mpas_kind_types - use mpas_derived_types use mpas_pool_routines -! use mpas_timekeeping, only: MPAS_Time_type, MPAS_TimeInterval_type, mpas_get_clock_time, & -! mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+), add_t_ti - use mpas_timekeeping, only: MPAS_Time_type, mpas_get_clock_time, mpas_get_time use mpas_timer, only : mpas_timer_start, mpas_timer_stop use mpas_atmphys_constants @@ -36,7 +32,6 @@ module mpas_atmphys_driver_sfclayer integer,parameter,private:: iz0tlnd = 0 !=0,(Carlson-Boland). integer,parameter,private:: scm_force_flux = 0 !SCM surface forcing by surface fluxes. !0=no 1=yes (WRF single column model option only). - type (MPAS_Clock_type), pointer, private :: clock !MPAS driver for parameterization of the surface layer. !Laura D. Fowler (send comments to laura@ucar.edu). @@ -841,12 +836,10 @@ subroutine init_sfclayer(configs) end subroutine init_sfclayer !================================================================================================================= - subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,its,ite) + subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) !================================================================================================================= !input and inout arguments: - type(MPAS_Clock_type),intent(in):: clock - type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: sfc_input @@ -861,7 +854,6 @@ subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,i logical,pointer:: config_do_restart,config_frac_seaice character(len=StrKIND),pointer:: sfclayer_scheme real(kind=RKIND),dimension(:),pointer:: areaCell - real(kind=RKIND),pointer:: config_dt !local variables: integer:: initflag @@ -871,13 +863,6 @@ subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,i character(len=StrKIND):: errmsg integer:: errflg - type (MPAS_Time_Type) :: currTime - integer :: H, M, S, S_n, S_d - integer :: ierr - real(kind=RKIND) :: time_of_day_seconds - real(kind=RKIND) :: heat_flux, moisture_flux - logical :: specified_flux - !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_sfclayer:') @@ -889,7 +874,6 @@ subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,i call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) - call mpas_pool_get_config(configs,'config_dt',config_dt) call mpas_pool_get_array(mesh,'areaCell',areaCell) @@ -905,14 +889,6 @@ subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,i case("sf_monin_obukhov") call mpas_timer_start('sf_monin_obukhov') - - currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) - call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) - time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*config_dt - call mpas_log_write(' sfclay, time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) - call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) - specified_flux = .true. - call sfclay( & p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & u3d = u_p , v3d = v_p , qv3d = qv_p , & @@ -936,8 +912,6 @@ subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,i ustm = ustm_p , ck = ck_p , cka = cka_p , & cd = cd_p , cda = cda_p , isftcflx = isftcflx , & iz0tlnd = iz0tlnd , scm_force_flux = scm_force_flux , & - heat_flux = heat_flux , moisture_flux = moisture_flux , & - specified_flux = specified_flux , & ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & @@ -967,8 +941,6 @@ subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,i ustm = ustm_sea , ck = ck_sea , cka = cka_sea , & cd = cd_sea , cda = cda_sea , isftcflx = isftcflx , & iz0tlnd = iz0tlnd , scm_force_flux = scm_force_flux , & - heat_flux = heat_flux , moisture_flux = moisture_flux , & - specified_flux = specified_flux , & ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & @@ -1115,30 +1087,6 @@ subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,i end subroutine driver_sfclayer - subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) - - implicit none - - real (kind=RKIND), intent(in) :: time_of_day_seconds - real (kind=RKIND), intent(out) :: heat_flux, moisture_flux - - real (kind=RKIND), parameter:: t_start_t_flux = 3600.*6.0 - real (kind=RKIND), parameter:: t_end_t_flux = 3600.*19.50 - real (kind=RKIND), parameter:: t_start_q_flux = 3600.*7.0 - real (kind=RKIND), parameter:: t_end_q_flux = 3600.*19.50 - real (kind=RKIND) :: rel_time_t_flux, rel_time_q_flux - - rel_time_t_flux = max(0.,(time_of_day_seconds - t_start_t_flux)/(t_end_t_flux - t_start_t_flux)) - rel_time_q_flux = max(0.,(time_of_day_seconds - t_start_q_flux)/(t_end_q_flux - t_start_q_flux)) - - heat_flux = max(0., 0.1*sin(pii*rel_time_t_flux)) - moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux))/1000. - - end subroutine flux_les_sas - - - - !================================================================================================================= end module mpas_atmphys_driver_sfclayer !================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F index f7399e4b40..2b3ba578f0 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -25,8 +25,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & ustm,ck,cka,cd,cda, & - isftcflx,iz0tlnd,scm_force_flux, & - heat_flux, moisture_flux, specified_flux ) + isftcflx,iz0tlnd,scm_force_flux) !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- @@ -185,8 +184,6 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX - REAL, INTENT(IN ) :: heat_flux, moisture_flux - LOGICAL, INTENT(IN ) :: specified_flux REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT ) :: QSFC @@ -211,7 +208,6 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & REAL, DIMENSION( its:ite ) :: DX2D INTEGER :: I,J - REAL :: RHO DO J=jts,jte @@ -231,14 +227,6 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & T1D(i) =T3D(i,1,j) ENDDO - IF(specified_flux)THEN - DO i=its,ite - RHO = P1D(i)/R/(T1D(i)*(1.+EP1*QV1D(i))) - HFX(i,j)=heat_flux*RHO*CP - QFX(i,j)=moisture_flux*RHO - ENDDO - ENDIF - ! Sending array starting locations of optional variables may cause ! troubles, so we explicitly change the call. @@ -255,7 +243,6 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT, & P1000mb, & - specified_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -281,7 +268,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & P1000mb, & - specified_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -303,7 +289,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT REAL, INTENT(IN ) :: P1000mb - LOGICAL, INTENT(IN ) :: specified_flux ! REAL, DIMENSION( ims:ime ) , & INTENT(IN ) :: MAVAIL, & @@ -400,7 +385,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & REAL :: FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,GZ0OZQ,GZ0OZT REAL :: ZW, ZN1, ZN2 REAL :: Z0T, CZC - REAL :: USTI !------------------------------------------------------------------- KL=kte @@ -412,16 +396,10 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & !----CONVERT GROUND TEMPERATURE TO POTENTIAL TEMPERATURE: ! DO 5 I=its,ite - IF(.not.specified_flux)THEN - TGDSA(I)=TSK(I) + TGDSA(I)=TSK(I) ! PSFC cb -! THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP - THGB(I)=TSK(I)*(P1000mb/PSFCPA(I))**ROVCP - ELSE -! with specified_flux TSK value is not input and given value will not affect USTM - TGDSA(I)=300. - THGB(I)=300.*(P1000mb/PSFCPA(I))**ROVCP - ENDIF +! THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP + THGB(I)=TSK(I)*(P1000mb/PSFCPA(I))**ROVCP 5 CONTINUE ! !-----DECOUPLE FLUX-FORM VARIABLES TO GIVE U,V,T,THETA,THETA-VIR., @@ -553,15 +531,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & 260 CONTINUE - IF(specified_flux)THEN -! Need to recalculate MOL and BR when HFX is given and TSK is not used - DO I=ITS,ITE -! MOL is THETA* - USTI = MAX(UST(I),0.01) - MOL(I) = - HFX(I)/(RHOX(I)*CP*USTI) - BR(I) = KARMAN*GOVRTH(I)*ZA(I)*MOL(I)/(USTI*USTI)/GZ1OZ0(I) - ENDDO - ENDIF ! !-----DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATED STABILITY CLASS: ! @@ -827,8 +796,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & WSPDI(I)=SQRT(UX(I)*UX(I)+VX(I)*VX(I)) IF ( PRESENT(USTM) ) THEN USTM(I)=0.5*USTM(I)+0.5*KARMAN*WSPDI(I)/PSIX -! For specified_flux VCONV effect not added to UST that will be used for ZOL - IF(specified_flux)UST(I)=USTM(I) ENDIF U10(I)=UX(I)*PSIX10/PSIX V10(I)=VX(I)*PSIX10/PSIX @@ -854,8 +821,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & 330 CONTINUE ! 335 CONTINUE - - IF(specified_flux) GOTO 410 !-----COMPUTE THE SURFACE SENSIBLE AND LATENT HEAT FLUXES: IF ( PRESENT(SCM_FORCE_FLUX) ) THEN From d916283e4b28d6ba6ed9a3892775e5d767e488e6 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 21 May 2025 10:14:59 -0600 Subject: [PATCH 109/214] mods to scale les-supercell case and remove surface fluxes from les_test option --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 6 ++++-- src/core_init_atmosphere/mpas_init_atm_cases.F | 7 +++++-- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 7933a777bc..c07df5669a 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -17,9 +17,11 @@ module mpas_atm_dissipation_models logical, parameter :: debug_dissipation = .false. logical, parameter :: les_test = .true., les_sas_test = .false. !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour - real (kind=RKIND), parameter :: tke_heat_flux = 0.03 + ! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 + real (kind=RKIND), parameter :: tke_heat_flux = 0.0 !! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 ! ocean roughness length - real (kind=RKIND), parameter :: tke_drag_coefficient = 0.006 + ! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.006 + real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0 real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 real (kind=RKIND), parameter :: c_k = 0.1 diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index cdfb9324f3..f1b747eb78 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -1459,6 +1459,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d real (kind=RKIND), pointer :: nominalMinDc logical, pointer :: on_a_sphere real (kind=RKIND), pointer :: sphere_radius + real (kind=RKIND), pointer :: config_ztop real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta real (kind=RKIND), dimension(:), pointer :: u_init, qv_init, angleEdge, fEdge, fVertex @@ -1484,12 +1485,13 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) call mpas_pool_get_config(configs, 'config_interface_projection', config_interface_projection) + call mpas_pool_get_config(configs, 'config_ztop', config_ztop) ! ! Scale all distances ! - a_scale = 1.0 + a_scale = 11.25 xCell(:) = xCell(:) * a_scale yCell(:) = yCell(:) * a_scale @@ -1593,7 +1595,8 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d ! metrics for hybrid coordinate and vertical stretching str = 1.0 - zt = 20000. +! zt = 20000. + zt = config_ztop dz = zt/float(nz1) ! write(0,*) ' dz = ',dz From 97e73ed9fd85567f807bc55b85961b17bff584b1 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 23 May 2025 15:15:45 -0600 Subject: [PATCH 110/214] add seed tke = 0.1 at all points --- src/core_init_atmosphere/mpas_init_atm_cases.F | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index f1b747eb78..0f2d92d42c 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -1433,6 +1433,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, nz1, itr, cell1, cell2 integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve integer, pointer :: index_qv + integer, pointer :: index_tke real (kind=RKIND), dimension(nVertLevels + 1 ) :: zc, zw, ah real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm @@ -1568,6 +1569,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d call mpas_pool_get_array(state, 'scalars', scalars) call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_dimension(state, 'index_tke', index_tke) scalars(:,:,:) = 0. @@ -1883,6 +1885,18 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) end do end do +! +! initial seed for tke +! +! call mpas_log_write('index_qv $i ', intArgs=(/index_qv/)) +! call mpas_log_write('index_tke $i ', intArgs=(/index_tke/)) + scalars(index_tke,:,:) = 0. + + do k = 1,nz1 + do i=1,nCells + scalars(index_tke,k,i) = 0.1 + end do + end do do itr=1,30 From ac2f96cf9fe415dc50e748c0e8e26f7debfa9929 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 12 Aug 2025 09:27:31 -0600 Subject: [PATCH 111/214] fix scaling for x_period and y_period for cases --- src/core_init_atmosphere/mpas_init_atm_cases.F | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 0f2d92d42c..48cff2c52e 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -1429,7 +1429,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d integer, dimension(:), pointer :: nEdgesOnEdge integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge - + real (kind=RKIND), pointer :: x_period, y_period integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, nz1, itr, cell1, cell2 integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve integer, pointer :: index_qv @@ -1482,7 +1482,9 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) - + + call mpas_pool_get_config(mesh, 'x_period', x_period) + call mpas_pool_get_config(mesh, 'y_period', y_period) call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) call mpas_pool_get_config(configs, 'config_interface_projection', config_interface_projection) @@ -1509,6 +1511,8 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d areaTriangle(:) = areaTriangle(:) * a_scale**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 nominalMinDc = nominalMinDc * a_scale + x_period = x_period * a_scale + y_period = y_period * a_scale call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) @@ -2051,6 +2055,7 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag integer, dimension(:), pointer :: nEdgesOnEdge, nEdgesOnCell integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge, cellsOnCell real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge + real (kind=RKIND), pointer :: x_period, y_period integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, itr, cell1, cell2, nz1 integer, pointer :: nEdges, maxEdges, nCellsSolve, nVertices @@ -2109,6 +2114,8 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) + call mpas_pool_get_config(mesh, 'x_period', x_period) + call mpas_pool_get_config(mesh, 'y_period', y_period) call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) @@ -2150,6 +2157,8 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag areaTriangle(:) = areaTriangle(:) * a_scale**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 nominalMinDc = nominalMinDc * a_scale + x_period = x_period * a_scale + y_period = y_period * a_scale call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) @@ -6256,6 +6265,7 @@ subroutine init_atm_case_les(dminfo, mesh, fg, nCells, nVertLevels, state, diag, integer, dimension(:), pointer :: nEdgesOnEdge integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge + real (kind=RKIND), pointer :: x_period, y_period integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, cell1, cell2 integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve @@ -6310,6 +6320,8 @@ subroutine init_atm_case_les(dminfo, mesh, fg, nCells, nVertLevels, state, diag, call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_config(mesh, 'x_period', x_period) + call mpas_pool_get_config(mesh, 'y_period', y_period) call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) call mpas_pool_get_config(configs, 'config_ztop', config_ztop) @@ -6334,6 +6346,8 @@ subroutine init_atm_case_les(dminfo, mesh, fg, nCells, nVertLevels, state, diag, areaCell(:) = areaCell(:) * a_scale**2.0 areaTriangle(:) = areaTriangle(:) * a_scale**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 + x_period = x_period * a_scale + y_period = y_period * a_scale call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) From 250db000bd9be8d1c022b6e42fc0e0c59a8da28f Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 27 Aug 2025 10:57:45 -0600 Subject: [PATCH 112/214] revert supercell a_scale to 1.0 --- src/core_init_atmosphere/mpas_init_atm_cases.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 48cff2c52e..9f936dcf93 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -1494,7 +1494,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d ! Scale all distances ! - a_scale = 11.25 + a_scale = 1.0 xCell(:) = xCell(:) * a_scale yCell(:) = yCell(:) * a_scale From e446ec8f17d242275070c74645aca1d7cc2a5a66 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Mon, 29 Sep 2025 14:55:36 -0600 Subject: [PATCH 113/214] add config_les_surface to registry and routines (not used yet) --- src/core_atmosphere/Registry.xml | 7 ++++++- .../dynamics/mpas_atm_dissipation_models.F | 16 ++++++++++++---- .../dynamics/mpas_atm_time_integration.F | 15 +++++++++------ 3 files changed, 27 insertions(+), 11 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 2f159f3958..5c0950aa10 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -149,7 +149,12 @@ + possible_values="`none', `3d_smagorinsky', 'prognostic_1.5_order'"/> + + Date: Wed, 8 Oct 2025 10:47:54 -0600 Subject: [PATCH 114/214] clean up and reduce duplication --- src/core_atmosphere/Registry.xml | 2 +- .../dynamics/mpas_atm_dissipation_models.F | 39 +++++++------------ 2 files changed, 14 insertions(+), 27 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 5c0950aa10..86cf2e749a 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -154,7 +154,7 @@ + possible_values="`free', 'specified', `varying'"/> Date: Wed, 8 Oct 2025 15:07:24 -0600 Subject: [PATCH 115/214] remove redundant dissipation routines --- .../dynamics/mpas_atm_dissipation_models.F | 801 +----------------- 1 file changed, 45 insertions(+), 756 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 8515f6b7a7..d2b6245e13 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -403,229 +403,6 @@ end subroutine calculate_n2 !--------------------------------------- - subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & - cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & - cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & - nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & - invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & - angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & - config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & - config_del4u_div_factor, zgrid, kdiff, & - delsq_u, delsq_vorticity, delsq_divergence, & - u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) - - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here - - implicit none - - integer, intent(in) :: edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd - integer, intent(in) :: vertexStart, vertexEnd, vertexDegree - integer, intent(in) :: cellStart, cellEnd - integer, intent(in) :: nCells, nEdges, nVertices - logical, intent(in) :: config_mix_full - - integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge - integer, dimension(2,nEdges+1), intent(in) :: verticesOnEdge - integer, dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell - integer, dimension(nCells+1), intent(in) :: nEdgesOnCell - integer, dimension(vertexDegree,nVertices+1), intent(in) :: edgesOnVertex - - real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 - real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 - real (kind=RKIND), intent(in) :: config_del4u_div_factor - - real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign - real (kind=RKIND), dimension(vertexDegree,nVertices+1), intent(in) :: edgesOnVertex_sign - real (kind=RKIND), dimension(nVertices+1), intent(in) :: invAreaTriangle - real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell - real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDvEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: angleEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: dcEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 - real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid - - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: divergence - real (kind=RKIND), dimension(nVertLevels,nVertices+1), intent(in) :: vorticity - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff - - - ! scratch space from calling routine - real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: delsq_u - real (kind=RKIND), dimension(nVertLevels,nVertices+1) :: delsq_vorticity - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_divergence - - real (kind=RKIND), dimension(nVertLevels), intent(in) :: u_init, v_init - - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(out) :: tend_u_euler - - ! local variables - - integer :: iEdge, cell1, cell2, vertex1, vertex2, iVertex, iCell, i, k - real (kind=RKIND) :: r_dc, r_dv, u_diffusion, kdiffu, r, edge_sign, u_mix_scale - real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp - real (kind=RKIND), dimension(nVertLevels) :: u_mix - -!$OMP BARRIER - - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). - ! First, storage to hold the result from the first del^2 computation. - - delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 - - do iEdge=edgeStart,edgeEnd - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - vertex1 = verticesOnEdge(1,iEdge) - vertex2 = verticesOnEdge(2,iEdge) - r_dc = invDcEdge(iEdge) - r_dv = min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) - -!DIR$ IVDEP - do k=1,nVertLevels - - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant - u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & - -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv - - delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion - - kdiffu = 0.5*(kdiff(k,cell1)+kdiff(k,cell2)) - - ! include 2nd-orer diffusion here - - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & - + rho_edge(k,iEdge)* kdiffu * u_diffusion * meshScalingDel2(iEdge) - - end do - end do - - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active - -!$OMP BARRIER - do iVertex=vertexStart,vertexEnd - delsq_vorticity(1:nVertLevels,iVertex) = 0.0 - do i=1,vertexDegree - iEdge = edgesOnVertex(i,iVertex) - edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) - do k=1,nVertLevels - delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) - end do - end do - end do - - do iCell=cellStart,cellEnd - delsq_divergence(1:nVertLevels,iCell) = 0.0 - r = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) - do k=1,nVertLevels - delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) - end do - end do - end do - -!$OMP BARRIER - do iEdge=edgeSolveStart,edgeSolveEnd - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - vertex1 = verticesOnEdge(1,iEdge) - vertex2 = verticesOnEdge(2,iEdge) - - u_mix_scale = meshScalingDel4(iEdge)*h_mom_eddy_visc4 - r_dc = u_mix_scale * config_del4u_div_factor * invDcEdge(iEdge) - r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) - -!DIR$ IVDEP - do k=1,nVertLevels - - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant - ! - ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor - ! relative to the rotational part. The stability constraint on the divergence component is much less - ! stringent than the rotational part, and this flexibility may be useful. - ! - u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & - -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion - - end do - end do - - end if ! 4th order mixing is active - ! - ! vertical mixing for u - 2nd order filter in physical (z) space - ! - if ( v_mom_eddy_visc2 > 0.0 ) then - - if (config_mix_full) then ! mix full state - - do iEdge=edgeSolveStart,edgeSolveEnd - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - do k=2,nVertLevels-1 - - z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) - z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) - z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) - z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & - (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) & - -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - - else ! idealized cases where we mix on the perturbation from the initial 1-D state - - do iEdge=edgeSolveStart,edgeSolveEnd - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - do k=1,nVertLevels - u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & - + v_init(k) * sin( angleEdge(iEdge) ) - end do - - do k=2,nVertLevels-1 - - z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) - z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) - z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) - z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & - (u_mix(k+1)-u_mix(k ))/(zp-z0) & - -(u_mix(k )-u_mix(k-1))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - - end if ! mix perturbation state - - end if ! vertical mixing of horizontal momentum - - end subroutine u_dissipation - -!------------------------ - subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & @@ -929,17 +706,22 @@ end subroutine u_dissipation_3d !------------------------ - subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - rdzw, rdzu, & - v_mom_eddy_visc2, h_mom_eddy_visc4, & - delsq_w, & - w, rho_edge, kdiff, rho_zz, & - tend_w_euler ) + subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + config_les_model, config_les_surface, & + tend_w_euler ) + + ! 3D w dissipation using the 3D smagorinsky eddy viscosities. + ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here @@ -954,6 +736,9 @@ subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + character (len=StrKIND) :: config_les_model + character (len=StrKIND) :: config_les_surface + real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 @@ -967,14 +752,17 @@ subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_horz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: tend_w_euler ! storage passed in from calling routine real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_w + real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux ! local variables @@ -988,6 +776,12 @@ subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, ! First, storage to hold the result from the first del^2 computation. ! we copied code from the theta mixing, hence the theta* names. + if(debug_dissipation) then + call mpas_log_write(' begin w_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' les surface is '//trim(config_les_surface)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) + end if delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 @@ -1008,7 +802,8 @@ subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & - (kdiff(k,cell1)+kdiff(k,cell2)+kdiff(k-1,cell1)+kdiff(k-1,cell2)) + ( eddy_visc_horz(k ,cell1)+eddy_visc_horz(k ,cell2) & + +eddy_visc_horz(k-1,cell1)+eddy_visc_horz(k-1,cell2) ) tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux end do end do @@ -1049,533 +844,27 @@ subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end if - end subroutine w_dissipation - -!------------------------ - - subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - rdzw, rdzu, & - v_mom_eddy_visc2, h_mom_eddy_visc4, & - delsq_w, & - w, rho_edge, rho_zz, zz, & - eddy_visc_horz, eddy_visc_vert, & - config_les_model, config_les_surface, & - tend_w_euler ) - - - ! 3D w dissipation using the 3D smagorinsky eddy viscosities. - ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter + if ( config_les_model /= "none") then - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column + ! compute turbulent fluxes + do k=1,nVertLevels + turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*zz(k,iCell) & + *rdzw(k)*(w(k+1,iCell)-w(k,iCell)) + end do + turb_vflux(nVertLevels+1) = 0. + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & + - rdzu(k)*(turb_vflux(k)-turb_vflux(k-1)) + end do + end do - implicit none + end if - integer, intent(in) :: cellStart, cellEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd - integer, intent(in) :: nCells, nEdges - - integer, dimension(nCells+1), intent(in) :: nEdgesOnCell - integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell - - integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge - - character (len=StrKIND) :: config_les_model - character (len=StrKIND) :: config_les_surface - - real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 - real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 - - real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign - real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell - real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu - - real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_horz - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge - - real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: tend_w_euler - - ! storage passed in from calling routine - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_w - real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux - - ! local variables - - integer :: cell1, cell2, iEdge, iCell, i, k - real (kind=RKIND) :: r_areaCell, edge_sign, w_turb_flux - -! !OMP BARRIER why is this openmp barrier here??? - - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). - ! - ! First, storage to hold the result from the first del^2 computation. - ! we copied code from the theta mixing, hence the theta* names. - - if(debug_dissipation) then - call mpas_log_write(' begin w_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' les surface is '//trim(config_les_surface)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) - end if - - delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 - - do iCell=cellStart,cellEnd - tend_w_euler(1:nVertLevels+1,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - - edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - -!DIR$ IVDEP - do k=2,nVertLevels - - w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) - delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux - w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & - ( eddy_visc_horz(k ,cell1)+eddy_visc_horz(k ,cell2) & - +eddy_visc_horz(k-1,cell1)+eddy_visc_horz(k-1,cell2) ) - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux - end do - end do - end do - -!$OMP BARRIER - - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active - - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) - - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) - end do - - end do - end do - - end if ! 4th order mixing is active - - if ( v_mom_eddy_visc2 > 0.0 ) then ! vertical mixing - - do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & - (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & - -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k) - end do - end do - - end if - - if ( config_les_model /= "none") then - - do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column - ! compute turbulent fluxes - do k=1,nVertLevels - turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*zz(k,iCell) & - *rdzw(k)*(w(k+1,iCell)-w(k,iCell)) - end do - turb_vflux(nVertLevels+1) = 0. - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & - - rdzu(k)*(turb_vflux(k)-turb_vflux(k-1)) - end do - end do - - end if - - if(debug_dissipation) call mpas_log_write(' exiting w_dissipation_3d ') + if(debug_dissipation) call mpas_log_write(' exiting w_dissipation_3d ') end subroutine w_dissipation_3d -!----------------------------------------------------- - - subroutine theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - delsq_theta, & - theta_m, rho_edge, kdiff, rho_zz, & - tend_theta_euler ) - - - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here - implicit none - - integer, intent(in) :: cellStart, cellEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd - integer, intent(in) :: nCells, nEdges - - logical, intent(in) :: config_mix_full - - integer, dimension(nCells+1), intent(in) :: nEdgesOnCell - integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell - - integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge - - real (kind=RKIND), intent(in) :: h_theta_eddy_visc4 - real (kind=RKIND), intent(in) :: v_theta_eddy_visc2 - real (kind=RKIND), intent(in) :: prandtl_inv - - real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign - real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell - real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu - real (kind=RKIND), dimension(nVertLevels+1, nCells+1), intent(in) :: zgrid - - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: t_init - - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge - - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler - - ! storage passed in from calling routine - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_theta - - ! local variables - integer :: cell1, cell2, iEdge, iCell, i, k - real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale - real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp - - delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 - - do iCell=cellStart,cellEnd - tend_theta_euler(1:nVertLevels,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - pr_scale = prandtl_inv * meshScalingDel2(iEdge) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) -!DIR$ IVDEP - do k=1,nVertLevels - -! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below - - theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) - delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux - theta_turb_flux = theta_turb_flux*0.5*(kdiff(k,cell1)+kdiff(k,cell2)) * pr_scale - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux - - end do - end do - end do - -!$OMP BARRIER - - if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active - - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - - iEdge = edgesOnCell(i,iCell) - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - do k=1,nVertLevels - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) - end do - end do - end do - - end if ! 4th order mixing is active - - if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m - - if (config_mix_full) then - - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & - -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - - else ! idealized cases where we mix on the perturbation from the initial 1-D state - - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & - -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - - end if - - end if - - end subroutine theta_dissipation - -!----------------------------------------------------- - - subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, fzm, fzp, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - delsq_theta, & - theta_m, rho_edge, rho_zz, zz, & - eddy_visc_horz, eddy_visc_vert, & - config_les_model, & - tend_theta_euler ) - - - ! 3D theta_m dissipation using the 3D smagorinsky eddy viscosities. - ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter - - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here - implicit none - - integer, intent(in) :: cellStart, cellEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd - integer, intent(in) :: nCells, nEdges - - logical, intent(in) :: config_mix_full - - character (len=StrKIND) :: config_les_model - - integer, dimension(nCells+1), intent(in) :: nEdgesOnCell - integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell - - integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge - - real (kind=RKIND), intent(in) :: h_theta_eddy_visc4 - real (kind=RKIND), intent(in) :: v_theta_eddy_visc2 - real (kind=RKIND), intent(in) :: prandtl_inv - - real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign - real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell - real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu - real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzm - real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzp - real (kind=RKIND), dimension(nVertLevels+1, nCells+1), intent(in) :: zgrid - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz - - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: t_init - - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_horz - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge - - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler - - ! storage passed in from calling routine - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_theta - - ! local variables - integer :: cell1, cell2, iEdge, iCell, i, k - real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale - real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp - real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux - real (kind=RKIND) :: rho_k_at_w, zz_at_w - - if(debug_dissipation) then - call mpas_log_write(' begin theta_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_theta_eddy_visc4/)) - end if - - delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 - - do iCell=cellStart,cellEnd - tend_theta_euler(1:nVertLevels,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - pr_scale = prandtl_inv * meshScalingDel2(iEdge) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) -!DIR$ IVDEP - do k=1,nVertLevels - -! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. -! This is in conservative form. - - theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) - delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux - theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux - - end do - end do - end do - -!$OMP BARRIER - - if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active - - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - - iEdge = edgesOnCell(i,iCell) - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - do k=1,nVertLevels - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) - end do - end do - end do - - end if ! 4th order mixing is active - - ! idealized case vertical mixing - - if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m - - if (config_mix_full) then - - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & - -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - - else ! idealized cases where we mix on the perturbation from the initial 1-D state - - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & - -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - - end if - - end if - - if ( config_les_model /= "none") then - - do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column - ! compute turbulent fluxes - turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain - turb_vflux(1) = 0. ! lower bc flux handled where ??? - do k=2,nVertLevels - rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & - +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) - zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) - turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) - end do - - ! test boundary conditions for supercell and les test cases - - if( les_test ) then - turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY - ! SAS case lower flux for theta_m - code goes here - - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) - else - turb_vflux(1) = turb_vflux(2) - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) - end if - - - do k=1,nVertLevels - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & - - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) - end do - end do - - end if - - if(debug_dissipation) call mpas_log_write(' exiting theta_dissipation_3d ') - - end subroutine theta_dissipation_3d - !----------------------------------------------------- subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & From 49372ce4707e6fde3b27fac13b89cf9b8645e418 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 9 Oct 2025 13:01:58 -0600 Subject: [PATCH 116/214] Merge with Bill Skamarock updated LES modules --- src/core_atmosphere/Registry.xml | 5 ++ .../dynamics/mpas_atm_dissipation_models.F | 83 +++++++++++-------- .../dynamics/mpas_atm_time_integration.F | 29 +++---- 3 files changed, 69 insertions(+), 48 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 86cf2e749a..7cfd643b5e 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -166,6 +166,11 @@ description="Scaling coefficient of $\delta x^3$ to obtain $\nabla^4$ diffusion coefficient" possible_values="Non-negative real values"/> + + 0.0).and. hmix4_scalars) then ! 4th order mixing is active + if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) @@ -1147,7 +1162,8 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! end do do k=2,nVertLevels - prandtl_1d_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) + ! prandtl_1d_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) + prandtl_1d_inverse(k) = fzm(k)*prandtl_3d_inv(k,iCell)+fzp(k)*prandtl_3d_inv(k-1,iCell) end do end if @@ -1158,9 +1174,8 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) ! bv_frequency2 = 0.5*(bv_freq2(k)+bv_freq(k-1)) ! bv = max( sqrt(abs(bv_frequency2)), epsilon_bv ) - - rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & - +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) turb_vflux(k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) end do @@ -1202,14 +1217,14 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do - if (mix_scalars .and. vmix_scalars) then + if (mix_scalars ) then ! compute turbulent fluxes turb_vflux_scalars(:,nVertlevels+1) = 0. ! no turbulent flux out of the domain turb_vflux_scalars(:,1) = 0. ! lower bc flux handled where ??? do k=2,nVertLevels - rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & - +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) do iScalar=1,num_scalars turb_vflux_scalars(iScalar,k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)* & diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index dde697a3e1..05dd4feb36 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1173,7 +1173,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !$OMP PARALLEL DO do thread=1,nThreads call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, diag_physics, & - block % configs, nVertLevels, rk_step, dt, & + block % configs, nVertLevels, rk_step, dynamics_substep, dt, & cellThreadStart(thread), cellThreadEnd(thread), & vertexThreadStart(thread), vertexThreadEnd(thread), & edgeThreadStart(thread), edgeThreadEnd(thread), & @@ -4736,7 +4736,7 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge end subroutine atm_advance_scalars_mono_work - subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_physics, configs, nVertLevels, rk_step, dt, & + subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_physics, configs, nVertLevels, rk_step, dynamics_substep, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -4765,7 +4765,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys type (mpas_pool_type), intent(in) :: diag_physics type (mpas_pool_type), intent(in) :: configs integer, intent(in) :: nVertLevels ! for allocating stack variables - integer, intent(in) :: rk_step + integer, intent(in) :: rk_step, dynamics_substep real (kind=RKIND), intent(in) :: dt integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd @@ -4825,6 +4825,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys real (kind=RKIND), pointer :: coef_3rd_order, c_s logical, pointer :: config_mix_full + logical, pointer :: config_mix_scalars character (len=StrKIND), pointer :: config_horiz_mixing character (len=StrKIND), pointer :: config_les_model character (len=StrKIND), pointer :: config_les_surface @@ -4848,6 +4849,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys call mpas_pool_get_config(mesh, 'sphere_radius', r_earth) call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) call mpas_pool_get_config(configs, 'config_mix_full', config_mix_full) + call mpas_pool_get_config(configs, 'config_mix_scalars', config_mix_scalars) call mpas_pool_get_config(configs, 'config_horiz_mixing', config_horiz_mixing) call mpas_pool_get_config(configs, 'config_les_model', config_les_model) call mpas_pool_get_config(configs, 'config_les_surface', config_les_surface) @@ -5005,10 +5007,10 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & - tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_les_model, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_mix_scalars, config_horiz_mixing, config_les_model, & config_les_surface, prandtl_3d_inv, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & - config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & + config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dynamics_substep, dt, & config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & @@ -5033,10 +5035,10 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & - tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_les_model, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_mix_scalars, config_horiz_mixing, config_les_model, & config_les_surface, prandtl_3d_inv, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & - config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & + config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dynamics_substep, dt, & config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & @@ -5155,7 +5157,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_buoy real (kind=RKIND) :: coef_3rd_order, c_s - logical :: config_mix_full + logical :: config_mix_full, config_mix_scalars character (len=StrKIND) :: config_horiz_mixing character (len=StrKIND) :: config_les_model character (len=StrKIND) :: config_les_surface @@ -5166,9 +5168,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: config_len_disp real (kind=RKIND) :: config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2 logical, parameter :: test_dissipation_3d=.true. - logical, parameter :: mix_scalars = .true. - integer, intent(in) :: rk_step + integer, intent(in) :: rk_step, dynamics_substep real (kind=RKIND), intent(in) :: dt real (kind=RKIND) :: config_mpas_cam_coef @@ -5321,7 +5322,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*dt ! call mpas_log_write(' les integration, timestep midpoint time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) - call les_models( config_les_model, config_les_surface, eddy_visc_horz, eddy_visc_vert, & + call les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & u, v, ur_cell, vr_cell, & w, c_s, bn2, zgrid, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & @@ -5695,7 +5696,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm rdzw, rdzu, & v_mom_eddy_visc2, h_mom_eddy_visc4, & delsq_w, & - w, rho_edge, rho_zz, zz, & + w, rho_edge, rho_zz, divergence, zz, & eddy_visc_horz, eddy_visc_vert, & config_les_model, config_les_surface, & tend_w_euler ) @@ -5887,11 +5888,11 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm theta_m, rho_edge, rho_zz, zz, & eddy_visc_horz, eddy_visc_vert, & bn2, config_len_disp, scalars, tend_scalars, & - index_tke, index_qv, num_scalars, mix_scalars, & + index_tke, index_qv, num_scalars, config_mix_scalars, & config_les_model, config_les_surface, time_of_day_seconds,& ur_cell, vr_cell, & hfx, qfx, & - tend_theta_euler ) + tend_theta_euler, dynamics_substep ) ! else ! this is the original MPAS dissipation code From 6345dc1640d1cd79c1d68ae035769e883d15daab Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 21 Oct 2025 13:24:09 -0600 Subject: [PATCH 117/214] add surface flux namelist options --- src/core_atmosphere/Registry.xml | 17 ++++++++++++++++- .../dynamics/mpas_atm_dissipation_models.F | 15 ++++++++++----- .../dynamics/mpas_atm_time_integration.F | 13 +++++++++++++ 3 files changed, 39 insertions(+), 6 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 7cfd643b5e..2264cf1fd5 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -154,7 +154,22 @@ + possible_values="'specified', `varying'"/> + + + + + + Date: Thu, 4 Dec 2025 15:32:48 -0700 Subject: [PATCH 118/214] Add explicit declarations of iCell, k, and p in the calculate_n2 routine By ensuring that all variables are explicitly declared in the calculate_n2 routine, the code can be built with compiler flags (e.g., -fimplicit-none) that forbid implicitly declared variables. --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 50c0619962..7753e692c5 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -340,7 +340,8 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local - real (kind=RKIND) :: dz, rdz, esw + integer :: iCell, k + real (kind=RKIND) :: dz, rdz, esw, p real (kind=RKIND), parameter :: qc_cr = 0.00001 ! in kg/kg real (kind=RKIND), dimension(nVertLevels) :: theta, qvsw, temp, coefa logical :: dry_bv_frequency From a6eec0e0794771092ef43480c2a478fd75d3f90e Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 17:01:35 -0700 Subject: [PATCH 119/214] Avoid passing null pointers for ustm, hfx, and qfx to atm_compute_dyn_tend_work The dummy arguments for ustm, hfx, and qfx in the atm_compute_dyn_tend_work routine are not pointers, and so passing unassociated pointers for the actual arguments is invalid and will trigger a runtime error when debugging options are enabled with the GNU compilers. The workaround adopted in this commit is to allocate the ustm, hfx, and qfx array pointers with a trivial size if these fields are not available (due to packages associated with PBL schemes), and to deallocate them after the call to atm_compute_dyn_tend_work. The dummy arguments for ustm, hfx, and qfx in atm_compute_dyn_tend_work (as well as in u_dissipation_3d and scalar_dissipation_3d_les) are now assumed-shape arrays, as the actual arguments may not have (nCells+1) elements. --- .../dynamics/mpas_atm_dissipation_models.F | 4 ++-- .../dynamics/mpas_atm_time_integration.F | 23 ++++++++++++++++++- 2 files changed, 24 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 7753e692c5..1b35cedd3a 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -484,7 +484,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_divergence real (kind=RKIND), dimension(nVertLevels), intent(in) :: u_init, v_init - real (kind=RKIND), dimension(nCells+1), intent(in) :: ustm + real (kind=RKIND), dimension(:), intent(in) :: ustm real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(out) :: tend_u_euler @@ -964,7 +964,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge - real (kind=RKIND), dimension(nCells+1), intent(in) :: hfx, qfx + real (kind=RKIND), dimension(:), intent(in) :: hfx, qfx real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index e5b9c98733..f54804cc93 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4847,6 +4847,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys integer, pointer :: index_qv, index_qc, index_tke logical :: inactive_rthdynten + logical :: nopbl call mpas_pool_get_config(mesh, 'sphere_radius', r_earth) @@ -4910,10 +4911,24 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) + nullify(ustm) call mpas_pool_get_array(diag_physics,'ustm',ustm) + nullify(hfx) call mpas_pool_get_array(diag_physics,'hfx',hfx) + nullify(qfx) call mpas_pool_get_array(diag_physics,'qfx',qfx) + nopbl = .false. + if (.not. associated(ustm) & + .or. .not. associated(hfx) & + .or. .not. associated(qfx)) then + + allocate(ustm(1)) + allocate(hfx(1)) + allocate(qfx(1)) + nopbl = .true. + end if + call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) @@ -5025,6 +5040,12 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + if (nopbl) then + deallocate(ustm) + deallocate(hfx) + deallocate(qfx) + end if + end subroutine atm_compute_dyn_tend @@ -5108,7 +5129,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_horz real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1) :: bn2 - real (kind=RKIND), dimension(nCells+1) :: ustm, hfx, qfx + real (kind=RKIND), dimension(:) :: ustm, hfx, qfx real (kind=RKIND), dimension(nVertLevels,nCells+1) :: prandtl_3d_inv real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign real (kind=RKIND), dimension(vertexDegree,nVertices+1) :: edgesOnVertex_sign From f18ccf098265a2586553fb78e207e1612f9a9ab2 Mon Sep 17 00:00:00 2001 From: Jim Wittig Date: Fri, 6 Feb 2026 16:58:42 -0700 Subject: [PATCH 120/214] Change the intel fortran preprocessing order. This fixes a problem when using a macro in the invocation of another macro. This change is only for using the intel build tools. It applies to both gnu make builds and cmake builds. --- Makefile | 4 ++-- cmake/Functions/MPAS_Functions.cmake | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index ff75c6be6b..5a7cf5060a 100644 --- a/Makefile +++ b/Makefile @@ -663,11 +663,11 @@ intel: # BUILDTARGET Intel oneAPI Fortran, C, and C++ compiler suite "CC_SERIAL = icx" \ "CXX_SERIAL = icpx" \ "FFLAGS_PROMOTION = -real-size 64" \ - "FFLAGS_OPT = -O3 -convert big_endian -free -align array64byte" \ + "FFLAGS_OPT = -O3 -convert big_endian -free -align array64byte -Qoption,fpp,-macro_expand=vc" \ "CFLAGS_OPT = -O3" \ "CXXFLAGS_OPT = -O3" \ "LDFLAGS_OPT = -O3" \ - "FFLAGS_DEBUG = -g -convert big_endian -free -check bounds,pointers,arg_temp_created,format,shape,contiguous -fpe0 -traceback" \ + "FFLAGS_DEBUG = -g -convert big_endian -free -check bounds,pointers,arg_temp_created,format,shape,contiguous -fpe0 -traceback -Qoption,fpp,-macro_expand=vc" \ "CFLAGS_DEBUG = -g -traceback" \ "CXXFLAGS_DEBUG = -g -traceback" \ "LDFLAGS_DEBUG = -g -traceback" \ diff --git a/cmake/Functions/MPAS_Functions.cmake b/cmake/Functions/MPAS_Functions.cmake index fe76556225..15d9f63fc1 100644 --- a/cmake/Functions/MPAS_Functions.cmake +++ b/cmake/Functions/MPAS_Functions.cmake @@ -121,6 +121,7 @@ function(mpas_fortran_target target) list(APPEND MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PUBLIC $<$:-align array64byte> $<$:-convert big_endian> + $<$:-Qoption,fpp,-macro_expand=vc> ) if(MPAS_DOUBLE_PRECISION) list(APPEND MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PRIVATE From 66e724a8f6267f5713bfd951f0410fabf246a9c4 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 20 Oct 2025 11:22:50 -0600 Subject: [PATCH 121/214] Introduce init_atmosphere namelist options to control hybrid vertical coordinate This commit provides access to the hybrid vertical coordinate and the transition height of the coordinate through namelist variables for the init_atmosphere core. Additionally, the smoothing coefficient formula for the hybrid coordinate now uses the transition height instead of the model top height. These changes affect only the real-data construction of the vertical mesh. The changes include two new namelist configurations variables in the init_atmosphere Registry file: a logical for activating the hybrid vertical coordinate and the transition height for the coordinate (where it transitions from terrain-following to constant height). These variables are config_hybrid_coordinate (logical) and config_hybrid_top_z (real, meters). The variables had been hardwired in the code up until now (true and 30 km). Also included are a few changes to provide further information concerning diagnostic output appearing in the init_atmosphere log files. --- src/core_init_atmosphere/Registry.xml | 10 +++++ .../mpas_init_atm_cases.F | 38 +++++++++++++------ 2 files changed, 36 insertions(+), 12 deletions(-) diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index cf4934a81b..c11eab6cb4 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -225,6 +225,16 @@ description="Model top height" possible_values="Positive real values"/> + + + + Date: Fri, 17 Oct 2025 13:30:56 -0600 Subject: [PATCH 122/214] Implement option to turn off microphysics tendencies above a specified height This commit provides the capability of turning off use of the microphysics tendency above a user-specified height. This change alleviates some instabilities encountered in deep-domain MPAS simulations (model tops above the stratopause). The changes include: (1) addition of a namelist variable specifying the height above which the microphysics tendencies are to be ignored, and an integer variable that is set when the integration starts specifying the level based on that height. (2) additions to src/core_atmosphere/physics/mpas_atmphys_init.F to set the level based on the namelist-specified height. (3) changes in src/core_atmosphere/physics/mpas_atmphys_interface.F that disable the microphysics tendency updates above the specified level. --- src/core_atmosphere/Registry.xml | 8 +++ .../physics/mpas_atmphys_init.F | 21 +++++++- .../physics/mpas_atmphys_interface.F | 54 +++++++++++++++++-- 3 files changed, 77 insertions(+), 6 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 4281c40bba..b0bd5e9e31 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1599,6 +1599,9 @@ + + @@ -2215,6 +2218,11 @@ description="number of microphysics time-steps per physics time-steps" possible_values="Positive integers"/> + + Date: Mon, 9 Feb 2026 18:15:50 -0700 Subject: [PATCH 123/214] Move 'mp_top_level' from mesh pool to tend_physics pool in the atmosphere core This commit moves the 'mp_top_level' variable from the 'mesh' pool to the 'tend_physics' pool in the atmosphere core. The mp_top_level variable holds the level above which microphysics tendencies are to be ignored, and it is therefore naturally associated with physics tendencies. --- src/core_atmosphere/Registry.xml | 6 +++--- src/core_atmosphere/mpas_atm_core.F | 4 +++- src/core_atmosphere/physics/mpas_atmphys_init.F | 5 +++-- src/core_atmosphere/physics/mpas_atmphys_interface.F | 3 ++- 4 files changed, 11 insertions(+), 7 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index b0bd5e9e31..de255ecac5 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1599,9 +1599,6 @@ - - @@ -3427,6 +3424,9 @@ + + diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index f7d04a1f0c..67b6f53c37 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -390,6 +390,7 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) type (mpas_pool_type), pointer :: state type (mpas_pool_type), pointer :: diag type (mpas_pool_type), pointer :: tend + type (mpas_pool_type), pointer :: tend_physics type (mpas_pool_type), pointer :: sfc_input type (mpas_pool_type), pointer :: diag_physics type (mpas_pool_type), pointer :: diag_physics_noahmp @@ -566,6 +567,7 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) if (moist_physics) then !initialization of some input variables in registry: call mpas_pool_get_subpool(block % structs, 'tend', tend) + call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) call mpas_pool_get_subpool(block % structs, 'diag_physics', diag_physics) call mpas_pool_get_subpool(block % structs, 'diag_physics_noahmp', diag_physics_noahmp) call mpas_pool_get_subpool(block % structs, 'ngw_input', ngw_input) @@ -576,7 +578,7 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) call physics_run_init(block % configs, mesh, state, clock, stream_manager) !initialization of all physics: - call physics_init(dminfo, stream_manager, clock, block % configs, mesh, diag, tend, state, 1, & + call physics_init(dminfo, stream_manager, clock, block % configs, mesh, diag, tend, tend_physics, state, 1, & diag_physics, diag_physics_noahmp, ngw_input, atm_input, sfc_input, output_noahmp) endif #endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index c9d9e21542..5183f5a974 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -80,7 +80,7 @@ module mpas_atmphys_init !================================================================================================================= - subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,state,time_lev,diag_physics, & + subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,tend_physics,state,time_lev,diag_physics, & diag_physics_noahmp,ngw_input,atm_input,sfc_input,output_noahmp) !================================================================================================================= @@ -99,6 +99,7 @@ subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,state type(mpas_pool_type),intent(inout):: state type(mpas_pool_type),intent(inout):: diag type(mpas_pool_type),intent(inout):: tend + type(mpas_pool_type),intent(inout):: tend_physics type(mpas_pool_type),intent(inout):: diag_physics type(mpas_pool_type),intent(inout):: diag_physics_noahmp type(mpas_pool_type),intent(inout):: ngw_input @@ -242,7 +243,7 @@ subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,state call mpas_pool_get_dimension(mesh,'nVertLevels',nVertLevels ) call mpas_pool_get_array(mesh,'rdzw' ,rdzw ) call mpas_pool_get_array(mesh,'dzu' ,dzu ) - call mpas_pool_get_array(mesh,'mp_top_level',mp_top_level) + call mpas_pool_get_array(tend_physics,'mp_top_level',mp_top_level) currTime = mpas_get_clock_time(clock,MPAS_NOW,ierr) call mpas_get_time(curr_time=currTime,DoY=julday,ierr=ierr) diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index 6c9e1c0bb2..67d744bd78 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -824,7 +824,8 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te call mpas_pool_get_array(mesh,'zz' ,zz ) call mpas_pool_get_array(mesh,'zgrid',zgrid) - call mpas_pool_get_array(mesh,'mp_top_level',mp_top_level) + + call mpas_pool_get_array(tend_physics,'mp_top_level',mp_top_level) call mpas_pool_get_array(diag,'exner' ,exner ) call mpas_pool_get_array(diag,'exner_base' ,exner_b ) From c34e74db753860e989ecd05d68a2773792763b9a Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 11 Feb 2026 10:45:23 -0700 Subject: [PATCH 124/214] Remove etp, etm, ewp, and ewm from the 'invariant' stream in the atmosphere core The etp, etm, ewp, and ewm variables are computed during model start-up by the atm_compute_damping_coefs routine, and so they do not need to be read from the invariant stream. --- src/core_atmosphere/Registry.xml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index f5d74ef379..2330c8ae35 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -516,10 +516,6 @@ - - - - #ifdef MPAS_CAM_DYCORE From 0d434b5b9a19b99ffcea62669dfc7af27344e86b Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 11 Feb 2026 11:02:43 -0700 Subject: [PATCH 125/214] Remove old epssm variables and commented-out code from mpas_atm_time_integration With the introduction of level-dependent off-centering parameters (etp, etm, ewp, ewm) for the vertically implicit acoustic integration, the config_epssm variable is no longer used. This commit removes the config_epssm / epssm variable, as well as commented-out code that made use of epssm, from the atm_time_integration module. --- .../dynamics/mpas_atm_time_integration.F | 90 +++---------------- 1 file changed, 14 insertions(+), 76 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 353c3574cc..783d9317d2 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -2175,14 +2175,11 @@ subroutine atm_compute_vert_imp_coefs(state, mesh, diag, configs, nVertLevels, d real (kind=RKIND), dimension(:), pointer :: cofrz, rdzw, fzm, fzp, rdzu real (kind=RKIND), dimension(:,:,:), pointer :: scalars - real (kind=RKIND), pointer :: epssm - ! variable epssm arrays real (kind=RKIND), dimension(:), pointer :: etp, etm, ewp, ewm integer, pointer :: nCells, moist_start, moist_end - call mpas_pool_get_config(configs, 'config_epssm', epssm) call mpas_pool_get_array(mesh, 'etp', etp) call mpas_pool_get_array(mesh, 'etm', etm) call mpas_pool_get_array(mesh, 'ewp', ewp) @@ -2218,7 +2215,7 @@ subroutine atm_compute_vert_imp_coefs(state, mesh, diag, configs, nVertLevels, d call mpas_pool_get_dimension(state, 'moist_end', moist_end) - call atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, epssm, & + call atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, & zz, cqw, p, t, rb, rtb, pb, rt, cofwr, cofwz, coftz, cofwt, & a_tri, alpha_tri, gamma_tri, cofrz, rdzw, fzm, fzp, rdzu, scalars, & etp, etm, ewp, ewm, & @@ -2229,7 +2226,7 @@ subroutine atm_compute_vert_imp_coefs(state, mesh, diag, configs, nVertLevels, d end subroutine atm_compute_vert_imp_coefs - subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, epssm, & + subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, & zz, cqw, p, t, rb, rtb, pb, rt, cofwr, cofwz, coftz, cofwt, & a_tri, alpha_tri, gamma_tri, cofrz, rdzw, fzm, fzp, rdzu, scalars, & etp, etm, ewp, ewm, & @@ -2246,7 +2243,6 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, ! integer, intent(in) :: nCells, moist_start, moist_end real (kind=RKIND), intent(in) :: dts - real (kind=RKIND), intent(in) :: epssm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: zz real (kind=RKIND), dimension(nVertLevels,nCells+1) :: cqw @@ -2290,7 +2286,6 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, MPAS_ACC_TIMER_STOP('atm_compute_vert_imp_coefs_work [ACC_data_xfer]') ! set coefficients - ! dtseps = .5*dts*(1.+epssm) ! not needed for epssm_z rcv = rgas/(cp-rgas) c2 = cp*rcv @@ -2298,8 +2293,7 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, !$acc loop gang worker ! MGD bad to have all threads setting this variable? do k=1,nVertLevels - ! cofrz(k) = dtseps*rdzw(k) - cofrz(k) = rdzw(k) ! epssm_z_change + cofrz(k) = rdzw(k) end do !$acc end parallel @@ -2310,18 +2304,12 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, !DIR$ IVDEP !$acc loop vector do k=2,nVertLevels - ! cofwr(k,iCell) =.5*dtseps*gravity*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) - cofwr(k,iCell) =.5*gravity*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) ! epssm_z_change + cofwr(k,iCell) =.5*gravity*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) end do coftz(1,iCell) = 0.0 !DIR$ IVDEP !$acc loop vector do k=2,nVertLevels - ! cofwz(k,iCell) = dtseps*c2*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) & - ! *rdzu(k)*cqw(k,iCell)*(fzm(k)*p (k,iCell)+fzp(k)*p (k-1,iCell)) - ! coftz(k,iCell) = dtseps* (fzm(k)*t (k,iCell)+fzp(k)*t (k-1,iCell)) - - ! ! epssm_z_change cofwz(k,iCell) = c2*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) & *rdzu(k)*cqw(k,iCell)*(fzm(k)*p (k,iCell)+fzp(k)*p (k-1,iCell)) coftz(k,iCell) = (fzm(k)*t (k,iCell)+fzp(k)*t (k-1,iCell)) @@ -2337,10 +2325,6 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, ! end do qtotal = qtot(k,iCell) - ! cofwt(k,iCell) = .5*dtseps*rcv*zz(k,iCell)*gravity*rb(k,iCell)/(1.+qtotal) & - ! *p(k,iCell)/((rtb(k,iCell)+rt(k,iCell))*pb(k,iCell)) - - ! epssm_z_change cofwt(k,iCell) = .5*rcv*zz(k,iCell)*gravity*rb(k,iCell)/(1.+qtotal) & *p(k,iCell)/((rtb(k,iCell)+rt(k,iCell))*pb(k,iCell)) ! cofwt(k,iCell) = .5*rcv*zz(k,iCell)*gravity/t(k,iCell) ! zero base state option @@ -2359,16 +2343,8 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, a_tri(k,iCell) = -cofwz(k ,iCell)* coftz(k-1,iCell)*rdzw(k-1)*zz(k-1,iCell) & +cofwr(k ,iCell)* cofrz(k-1 ) & -cofwt(k-1,iCell)* coftz(k-1,iCell)*rdzw(k-1) - a_tri(k,iCell) = a_tri(k,iCell)*etp(k-1)*ewp(k-1) ! epssm_z_change (addition) + a_tri(k,iCell) = a_tri(k,iCell)*etp(k-1)*ewp(k-1) - ! b_tri(k) = 1. & - ! +cofwz(k ,iCell)*(coftz(k ,iCell)*rdzw(k )*zz(k ,iCell) & - ! +coftz(k ,iCell)*rdzw(k-1)*zz(k-1,iCell)) & - ! -coftz(k ,iCell)*(cofwt(k ,iCell)*rdzw(k ) & - ! -cofwt(k-1,iCell)*rdzw(k-1)) & - ! +cofwr(k, iCell)*(cofrz(k )-cofrz(k-1)) - - ! epssm_z_change b_tri(k) = +cofwz(k ,iCell)*coftz(k,iCell)* & ( etp(k )*rdzw(k )*zz(k ,iCell) & +etp(k-1)*rdzw(k-1)*zz(k-1,iCell)) & @@ -2380,15 +2356,12 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, c_tri(k) = -cofwz(k ,iCell)* coftz(k+1,iCell)*rdzw(k )*zz(k ,iCell) & -cofwr(k ,iCell)* cofrz(k ) & +cofwt(k ,iCell)* coftz(k+1,iCell)*rdzw(k ) - c_tri(k) = c_tri(k)*etp(k)*ewp(k+1) ! epssm_z_change (addition) + c_tri(k) = c_tri(k)*etp(k)*ewp(k+1) end do - c_tri(nVertLevels) = 0.0 ! epssm_z_change (addition) + c_tri(nVertLevels) = 0.0 !MGD VECTOR DEPENDENCE !$acc loop seq do k=2,nVertLevels - ! alpha_tri(k,iCell) = 1./(b_tri(k)-a_tri(k,iCell)*gamma_tri(k-1,iCell)) - ! gamma_tri(k,iCell) = c_tri(k)*alpha_tri(k,iCell) - ! epssm_z_change alpha_tri(k,iCell) = 1./(1.0+(dts**2)*(b_tri(k)-a_tri(k,iCell)*gamma_tri(k-1,iCell))) gamma_tri(k,iCell) = (dts**2)*c_tri(k)*alpha_tri(k,iCell) end do @@ -2596,8 +2569,6 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign - real (kind=RKIND), pointer :: epssm - real (kind=RKIND), pointer :: cf1, cf2, cf3 real (kind=RKIND), dimension(:), pointer :: etp, etm, ewp, ewm @@ -2673,16 +2644,13 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, call mpas_pool_get_array(diag, 'rw', rw) call mpas_pool_get_array(diag, 'rw_save', rw_save) - ! epssm is the offcentering coefficient for the vertically implicit integration. - call mpas_pool_get_config(configs, 'config_epssm', epssm) - call atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & rho_zz, theta_m, ru_p, rw_p, rtheta_pp, rtheta_pp_old, zz, exner, cqu, ruAvg, wwAvg, & rho_pp, cofwt, coftz, zxu, a_tri, alpha_tri, gamma_tri, dss, tend_ru, tend_rho, tend_rt, & tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & - dts, small_step, epssm, cf1, cf2, cf3, & + dts, small_step, cf1, cf2, cf3, & etp, etm, ewp, ewm, & specZoneMaskEdge, specZoneMaskCell & ) @@ -2696,7 +2664,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart rho_pp, cofwt, coftz, zxu, a_tri, alpha_tri, gamma_tri, dss, tend_ru, tend_rho, tend_rt, & tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & - dts, small_step, epssm, cf1, cf2, cf3, & + dts, small_step, cf1, cf2, cf3, & etp, etm, ewp, ewm, & specZoneMaskEdge, specZoneMaskCell & ) @@ -2771,7 +2739,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart integer, intent(in) :: small_step - real (kind=RKIND), intent(in) :: dts, epssm,cf1, cf2, cf3 + real (kind=RKIND), intent(in) :: dts, cf1, cf2, cf3 real (kind=RKIND), dimension(nVertLevels) :: ts, rs @@ -2780,12 +2748,11 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart ! integer :: cell1, cell2, iEdge, iCell, i, k real (kind=RKIND) :: c2, rcv, rtheta_pp_tmp - real (kind=RKIND) :: pgrad, flux, resm, rdts + real (kind=RKIND) :: pgrad, flux, rdts rcv = rgas / (cp - rgas) c2 = cp * rcv - resm = (1.0 - epssm) / (1.0 + epssm) rdts = 1./dts MPAS_ACC_TIMER_START('atm_advance_acoustic_step [ACC_data_xfer]') @@ -2940,13 +2907,6 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP !$acc loop vector do k=1, nVertLevels - ! rs(k) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) + rs(k) & - ! - cofrz(k)*resm*(rw_p(k+1,iCell)-rw_p(k,iCell)) - ! ts(k) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) + ts(k) & - ! - resm*rdzw(k)*( coftz(k+1,iCell)*rw_p(k+1,iCell) & - ! -coftz(k,iCell)*rw_p(k,iCell)) - - ! epssm_z change rs(k) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) + rs(k) & - dts*cofrz(k)*(ewm(k+1)*rw_p(k+1,iCell)-ewm(k)*rw_p(k,iCell)) ts(k) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) + ts(k) & @@ -2957,24 +2917,12 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP !$acc loop vector do k=2, nVertLevels - ! wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0-epssm)*rw_p(k,iCell) - wwavg(k,iCell) = wwavg(k,iCell) + ewm(k)*rw_p(k,iCell) ! epssm_z change + wwavg(k,iCell) = wwavg(k,iCell) + ewm(k)*rw_p(k,iCell) end do !DIR$ IVDEP !$acc loop vector do k=2, nVertLevels - ! rw_p(k,iCell) = rw_p(k,iCell) + dts*tend_rw(k,iCell) & - ! - cofwz(k,iCell)*((zz(k ,iCell)*ts(k) & - ! -zz(k-1,iCell)*ts(k-1)) & - ! +resm*(zz(k ,iCell)*rtheta_pp(k ,iCell) & - ! -zz(k-1,iCell)*rtheta_pp(k-1,iCell))) & - ! - cofwr(k,iCell)*((rs(k)+rs(k-1)) & - ! +resm*(rho_pp(k,iCell)+rho_pp(k-1,iCell))) & - ! + cofwt(k ,iCell)*(ts(k )+resm*rtheta_pp(k ,iCell)) & - ! + cofwt(k-1,iCell)*(ts(k-1)+resm*rtheta_pp(k-1,iCell)) - - ! epssm_z change rw_p(k,iCell) = rw_p(k,iCell) + dts*(tend_rw(k,iCell) & - cofwz(k,iCell)*(( etp(k )*zz(k ,iCell)*ts(k) & -etp(k-1)*zz(k-1,iCell)*ts(k-1)) & @@ -2992,9 +2940,6 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !MGD VECTOR DEPENDENCE !$acc loop seq do k=2,nVertLevels - ! rw_p(k,iCell) = (rw_p(k,iCell)-a_tri(k,iCell)*rw_p(k-1,iCell))*alpha_tri(k,iCell) - - ! epssm_z change rw_p(k,iCell) = (rw_p(k,iCell)-(dts**2)*a_tri(k,iCell)*rw_p(k-1,iCell))*alpha_tri(k,iCell) end do @@ -3020,8 +2965,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP !$acc loop vector do k=2,nVertLevels - ! wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) - wwAvg(k,iCell) = wwAvg(k,iCell) + ewp(k)*rw_p(k,iCell) ! epssm_z change + wwAvg(k,iCell) = wwAvg(k,iCell) + ewp(k)*rw_p(k,iCell) end do ! update rho_pp and theta_pp given updated rw_p @@ -3029,11 +2973,6 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP !$acc loop vector do k=1,nVertLevels - ! rho_pp(k,iCell) = rs(k) - cofrz(k) *(rw_p(k+1,iCell)-rw_p(k ,iCell)) - ! rtheta_pp(k,iCell) = ts(k) - rdzw(k)*(coftz(k+1,iCell)*rw_p(k+1,iCell) & - ! -coftz(k ,iCell)*rw_p(k ,iCell)) - ! - ! epssm_z change rho_pp(k,iCell) = rs(k) - dts*cofrz(k) *( ewp(k+1)*rw_p(k+1,iCell) & -ewp(k )*rw_p(k ,iCell)) rtheta_pp(k,iCell) = ts(k) - dts*rdzw(k)*( ewp(k+1)*coftz(k+1,iCell)*rw_p(k+1,iCell) & @@ -3047,8 +2986,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart rho_pp(k,iCell) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) rtheta_pp(k,iCell) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) rw_p(k,iCell) = rw_p(k,iCell) + dts*tend_rw(k,iCell) - ! wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) - wwAvg(k,iCell) = wwAvg(k,iCell) + ewp(k)*rw_p(k,iCell) ! epssm_z change + wwAvg(k,iCell) = wwAvg(k,iCell) + ewp(k)*rw_p(k,iCell) end do end if From a18b64f4373243e3c82e6ecbf665e002f6f2a81c Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 11 Feb 2026 18:00:44 -0700 Subject: [PATCH 126/214] Report use of config_epssm in the &nhyd_model namlist group with log warnings The config_epssm namelist option is no longer used to specify the off-centering parameter for the vertically implicit acoustic integration, and with this commit, the config_epssm option now takes on a default value of 0.0 in the Registry.xml file and is not written to the default namelist.atmosphere file that is generated when the atmosphere core is compiled. The mpas_atm_dynamics_checks routine now contains additional logic to detect whether the config_epssm option was specified with a value other than 0.0, and if so, it prints the following warning messages to the log file: WARNING: The specification of the off-centering parameter for the vertically implicit WARNING: acoustic integration using config_epssm in the &nhyd_model namelist group is WARNING: no longer supported. WARNING: Please use the namelist options WARNING: config_epssm_minimum WARNING: config_epssm_maximum WARNING: config_epssm_transition_bottom_z WARNING: config_epssm_transition_top_z WARNING: in the &damping namelist group to specify level-dependent off-centering parameters. --- src/core_atmosphere/Registry.xml | 2 +- .../dynamics/mpas_atm_time_integration.F | 32 +++++++++++++++++++ 2 files changed, 33 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 2330c8ae35..603e879e35 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -226,7 +226,7 @@ description="Mix full $\theta$ and $u$ fields, or mix perturbation from intitial state" possible_values=".true. or .false."/> - diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 783d9317d2..263f5b937c 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -156,6 +156,7 @@ subroutine mpas_atm_dynamics_checks(dminfo, blockList, streamManager, ierr) integer, intent(out) :: ierr logical, pointer :: config_positive_definite + real (kind=RKIND), pointer :: config_epssm call mpas_log_write('') @@ -177,6 +178,37 @@ subroutine mpas_atm_dynamics_checks(dminfo, blockList, streamManager, ierr) messageType=MPAS_LOG_WARN) call mpas_log_write('&nhyd_model namelist group.', & messageType=MPAS_LOG_WARN) + call mpas_log_write('') + end if + + ! + ! Check whether old config_epssm namelist option has been specified + ! + nullify(config_epssm) + call mpas_pool_get_config(blocklist % configs, 'config_epssm', config_epssm) + + if (associated(config_epssm)) then + if (config_epssm /= 0.0_RKIND) then + call mpas_log_write('The specification of the off-centering parameter for the vertically implicit', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('acoustic integration using config_epssm in the &nhyd_model namelist group is', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('no longer supported.', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('Please use the namelist options', & + messageType=MPAS_LOG_WARN) + call mpas_log_write(' config_epssm_minimum', & + messageType=MPAS_LOG_WARN) + call mpas_log_write(' config_epssm_maximum', & + messageType=MPAS_LOG_WARN) + call mpas_log_write(' config_epssm_transition_bottom_z', & + messageType=MPAS_LOG_WARN) + call mpas_log_write(' config_epssm_transition_top_z', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('in the &damping namelist group to specify level-dependent off-centering parameters.', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('') + end if end if call mpas_log_write(' ----- done checking dynamics settings -----') From 6f9441c7ad0631ee9e424b912431648e31edced4 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 12 Feb 2026 13:51:58 -0700 Subject: [PATCH 127/214] Deactivate epssm log writes in atm_compute_damping_coefs using MPAS_DEBUG macro This commit deactivates several mpas_log_write calls related to the setup of the level-dependent epssm arrays in the atm_compute_damping_coefs routine using MPAS_DEBUG preprocessing directives. For optimized builds, these mpas_log_write calls will be omitted, while debug builds will include these calls. --- src/core_atmosphere/mpas_atm_core.F | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index 03cc02d8f6..cd7fe97345 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -1312,12 +1312,14 @@ subroutine atm_compute_damping_coefs(mesh, configs) ! Height dependent values of epssm; profiles stored in etp, etm, ewp, and ewm, +#ifdef MPAS_DEBUG call mpas_log_write(' setting epssm coefficients ') call mpas_log_write(' minimum epssm: $r ',realArgs=(/min_coeff/)) call mpas_log_write(' maximum epssm: $r ',realArgs=(/max_coeff/)) call mpas_log_write(' transition lower bound (m): $r ',realArgs=(/transition_lower_bound/)) call mpas_log_write(' transition upper bound (m): $r ',realArgs=(/transition_upper_bound/)) call mpas_log_write(' ') +#endif do k = 1,nVertLevels if(height_u_levels(k).le.transition_lower_bound) then @@ -1330,7 +1332,9 @@ subroutine atm_compute_damping_coefs(mesh, configs) end if etp(k) = 0.5*(1.0 + epssm_coeff_u(k)) etm(k) = 0.5*(1.0 - epssm_coeff_u(k)) +#ifdef MPAS_DEBUG call mpas_log_write('k, etp, etm $i $r $r ',intArgs=(/k/),realArgs=(/etp(k),etm(k)/)) +#endif end do do k= 1,nVertlevels+1 if(height_w_levels(k).le.transition_lower_bound) then @@ -1343,7 +1347,9 @@ subroutine atm_compute_damping_coefs(mesh, configs) end if ewp(k) = 0.5*(1.0 + epssm_coeff_w(k)) ewm(k) = 0.5*(1.0 - epssm_coeff_w(k)) +#ifdef MPAS_DEBUG call mpas_log_write('k, ewp, ewm $i $r $r ',intArgs=(/k/),realArgs=(/ewp(k),ewm(k)/)) +#endif end do deallocate(height_u_levels) From dfc451eb70dc48e7feee666b2f2bc3cc92a1180d Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 12 Feb 2026 13:55:21 -0700 Subject: [PATCH 128/214] Copy epssm arrays etp, etm, ewp, and ewm to the device when using OpenACC This commit adds code in the mpas_atm_dynamics_init routine to copy the etp, etm, ewp, and ewm arrays to the device when MPAS-Atmosphere is compiled with OpenACC support. This commit also adds code in the mpas_atm_dynamics_finalize routine to delete these arrays from device memory. --- .../dynamics/mpas_atm_time_integration.F | 32 +++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 263f5b937c..a016e39c96 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -292,6 +292,10 @@ subroutine mpas_atm_dynamics_init(domain) real (kind=RKIND), dimension(:,:), pointer :: zgrid real (kind=RKIND), dimension(:,:), pointer :: zxu real (kind=RKIND), dimension(:,:), pointer :: dss + real (kind=RKIND), dimension(:), pointer :: etp + real (kind=RKIND), dimension(:), pointer :: etm + real (kind=RKIND), dimension(:), pointer :: ewp + real (kind=RKIND), dimension(:), pointer :: ewm real (kind=RKIND), dimension(:), pointer :: specZoneMaskCell real (kind=RKIND), dimension(:), pointer :: meshScalingRegionalCell real (kind=RKIND), dimension(:), pointer :: meshScalingRegionalEdge @@ -453,6 +457,18 @@ subroutine mpas_atm_dynamics_init(domain) call mpas_pool_get_array(mesh, 'dss', dss) !$acc enter data copyin(dss) + call mpas_pool_get_array(mesh, 'etp', etp) + !$acc enter data copyin(etp) + + call mpas_pool_get_array(mesh, 'etm', etm) + !$acc enter data copyin(etm) + + call mpas_pool_get_array(mesh, 'ewp', ewp) + !$acc enter data copyin(ewp) + + call mpas_pool_get_array(mesh, 'ewm', ewm) + !$acc enter data copyin(ewm) + call mpas_pool_get_array(mesh, 'specZoneMaskCell', specZoneMaskCell) !$acc enter data copyin(specZoneMaskCell) @@ -566,6 +582,10 @@ subroutine mpas_atm_dynamics_finalize(domain) real (kind=RKIND), dimension(:,:), pointer :: zgrid real (kind=RKIND), dimension(:,:), pointer :: zxu real (kind=RKIND), dimension(:,:), pointer :: dss + real (kind=RKIND), dimension(:), pointer :: etp + real (kind=RKIND), dimension(:), pointer :: etm + real (kind=RKIND), dimension(:), pointer :: ewp + real (kind=RKIND), dimension(:), pointer :: ewm real (kind=RKIND), dimension(:), pointer :: specZoneMaskCell real (kind=RKIND), dimension(:), pointer :: meshScalingRegionalCell real (kind=RKIND), dimension(:), pointer :: meshScalingRegionalEdge @@ -728,6 +748,18 @@ subroutine mpas_atm_dynamics_finalize(domain) call mpas_pool_get_array(mesh, 'dss', dss) !$acc exit data delete(dss) + call mpas_pool_get_array(mesh, 'etp', etp) + !$acc exit data delete(etp) + + call mpas_pool_get_array(mesh, 'etm', etm) + !$acc exit data delete(etm) + + call mpas_pool_get_array(mesh, 'ewp', ewp) + !$acc exit data delete(ewp) + + call mpas_pool_get_array(mesh, 'ewm', ewm) + !$acc exit data delete(ewm) + call mpas_pool_get_array(mesh, 'specZoneMaskCell', specZoneMaskCell) !$acc exit data delete(specZoneMaskCell) From ff8081ae5e9393e6e09a60e15ec630f33cfacca7 Mon Sep 17 00:00:00 2001 From: Jim Wittig Date: Mon, 5 Jan 2026 13:50:04 -0700 Subject: [PATCH 129/214] Ensure the buffer provided to MPAS_io_get_var_generic is large enough. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A fixed size array is provided as an input buffer when reading 0d-char character variables. Call MPAS_io_inq_var prior to the read to get the size of the variable’s value, and only proceed with the read if the variable’s value will fit in the provided array. Return an error code if the variable’s value is larger than the provided input buffer. --- src/framework/mpas_io.F | 62 +++++++++++++++++++++++++++------ src/framework/mpas_io_types.inc | 3 +- 2 files changed, 53 insertions(+), 12 deletions(-) diff --git a/src/framework/mpas_io.F b/src/framework/mpas_io.F index 09514a3667..20318e56ad 100644 --- a/src/framework/mpas_io.F +++ b/src/framework/mpas_io.F @@ -7,6 +7,9 @@ ! module mpas_io +#define IO_DEBUG_WRITE(M, ARGS) !call mpas_log_write(M, ARGS) +#define IO_ERROR_WRITE(M, ARGS) call mpas_log_write( M, ARGS, messageType=MPAS_LOG_ERR) + use mpas_derived_types use mpas_attlist use mpas_dmpar @@ -1847,6 +1850,13 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr character (len=:), pointer :: charVal_p character (len=:), dimension(:), pointer :: charArray1d_p + ! local variables returned from MPAS_io_inq_var + integer :: fieldtype + integer :: ndims + integer, dimension(:), pointer :: dimsizes + character (len=StrKIND), dimension(:), pointer :: dimnames + character (len=StrKIND) :: message + #ifdef MPAS_SMIOL_SUPPORT type (SMIOLf_decomp), pointer :: null_decomp @@ -1984,22 +1994,41 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr ! call mpas_log_write(' value is char') charVal_p => charVal + + ! get the dimension of the char variable to ensure the provided output buffer is large enough + call MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsizes, local_ierr) + do i = 1, ndims + message = ' MPAS_io_get_var_generic len(charVal):$i var "'//trim(fieldname)// & + '" type is $i dim is $i '// trim(dimnames(i))//' size is $i' + IO_DEBUG_WRITE(message, intArgs=(/len(charVal), fieldtype, i, dimsizes(i)/)) + end do + ! because charVal is provided, assume dimension 1 is the string length + if (dimsizes(1) > len(charVal)) then + local_ierr = MPAS_IO_ERR_INSUFFICIENT_BUF + message = 'Length of string variable "'//trim(fieldname)//'" in file "'//trim(handle % filename)//'"' + IO_ERROR_WRITE(message, intArgs=[0]) + message = ' exceeds buffer size: len('//trim(fieldname)//')=$i, len(buffer)=$i' + IO_ERROR_WRITE(message, intArgs=(/dimsizes(1), len(charVal)/)) + else #ifdef MPAS_SMIOL_SUPPORT - local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, charVal_p) + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, charVal_p) #endif #ifdef MPAS_PIO_SUPPORT - if (field_cursor % fieldhandle % has_unlimited_dim) then - count2(1) = field_cursor % fieldhandle % dims(1) % dimsize - pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, tempchar) - charVal(1:count2(1)) = tempchar(1)(1:count2(1)) - else - start1(1) = 1 - count1(1) = field_cursor % fieldhandle % dims(1) % dimsize - pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, tempchar) - charVal(1:count1(1)) = tempchar(1)(1:count1(1)) - end if + if (field_cursor % fieldhandle % has_unlimited_dim) then + count2(1) = field_cursor % fieldhandle % dims(1) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, tempchar) + charVal(1:count2(1)) = tempchar(1)(1:count2(1)) + else + start1(1) = 1 + count1(1) = field_cursor % fieldhandle % dims(1) % dimsize + pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, tempchar) + charVal(1:count1(1)) = tempchar(1)(1:count1(1)) + end if #endif + end if + deallocate(dimsizes) + deallocate(dimnames) else if (present(charArray1d)) then ! call mpas_log_write(' value is char1') #ifdef MPAS_PIO_SUPPORT @@ -2765,6 +2794,13 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr end if ! call mpas_log_write('Checking for error') + if (local_ierr == MPAS_IO_ERR_INSUFFICIENT_BUF) then + call MPAS_io_err_mesg(handle % ioContext, local_ierr, .false.) + io_global_err = local_ierr + if (present(ierr)) ierr = local_ierr + return + endif + #ifdef MPAS_PIO_SUPPORT if (pio_ierr /= PIO_noerr) then io_global_err = pio_ierr @@ -6498,6 +6534,10 @@ subroutine MPAS_io_err_mesg(ioContext, ierr, fatal) call mpas_log_write('MPAS IO Error: Would clobber existing file', MPAS_LOG_ERR) case (MPAS_IO_ERR_NOEXIST_READ) call mpas_log_write('MPAS IO Error: Attempting to read a file which does not exist.', MPAS_LOG_ERR) + case (MPAS_IO_ERR_MISSING_DIM) + call mpas_log_write('MPAS IO Error: Attempting to read a dimension which does not exist.', MPAS_LOG_ERR) + case (MPAS_IO_ERR_INSUFFICIENT_BUF) + call mpas_log_write('MPAS IO Error: Attempting to read a variable into a buffer of insufficient size.', MPAS_LOG_ERR) case default call mpas_log_write('MPAS IO Error: Unrecognized error code...', MPAS_LOG_ERR) end select diff --git a/src/framework/mpas_io_types.inc b/src/framework/mpas_io_types.inc index 522e6e1ad5..dc7551857a 100644 --- a/src/framework/mpas_io_types.inc +++ b/src/framework/mpas_io_types.inc @@ -65,7 +65,8 @@ MPAS_IO_ERR_UNIMPLEMENTED = -18, & MPAS_IO_ERR_WOULD_CLOBBER = -19, & MPAS_IO_ERR_NOEXIST_READ = -20, & - MPAS_IO_ERR_MISSING_DIM = -21 + MPAS_IO_ERR_MISSING_DIM = -21, & + MPAS_IO_ERR_INSUFFICIENT_BUF = -22 type MPAS_IO_Handle_type logical :: initialized = .false. From 9def5557c930c67bc05c8be218bb92931c8e2fe0 Mon Sep 17 00:00:00 2001 From: Jim Wittig Date: Mon, 5 Jan 2026 14:01:02 -0700 Subject: [PATCH 130/214] Add a test to verify reading character variables won't overrun buffers. Character variables are read into fixed size arrays when reading netcdf files. A test is added which tries to read character variables into a buffer which isn't large enough to hold the data. The test verifies the read fails with a suitable error code. --- src/core_test/Makefile | 5 +- src/core_test/mpas_test_core.F | 13 ++ src/core_test/mpas_test_core_io.F | 200 ++++++++++++++++++++++++++++++ 3 files changed, 216 insertions(+), 2 deletions(-) create mode 100644 src/core_test/mpas_test_core_io.F diff --git a/src/core_test/Makefile b/src/core_test/Makefile index 2d7bb95f1e..e11e5dbb50 100644 --- a/src/core_test/Makefile +++ b/src/core_test/Makefile @@ -12,7 +12,8 @@ OBJS = mpas_test_core.o \ mpas_test_core_dmpar.o \ mpas_test_core_stream_inquiry.o \ mpas_test_openacc.o \ - mpas_test_core_stream_list.o + mpas_test_core_stream_list.o \ + mpas_test_core_io.o all: core_test @@ -44,7 +45,7 @@ mpas_test_core.o: mpas_test_core_halo_exch.o mpas_test_core_streams.o \ mpas_test_core_sorting.o mpas_halo_testing.o \ mpas_test_core_string_utils.o mpas_test_core_dmpar.o \ mpas_test_core_stream_inquiry.o mpas_test_openacc.o \ - mpas_test_core_stream_list.o + mpas_test_core_stream_list.o mpas_test_core_io.o mpas_test_core_halo_exch.o: diff --git a/src/core_test/mpas_test_core.F b/src/core_test/mpas_test_core.F index 2116cbf92a..f0bbc1dda9 100644 --- a/src/core_test/mpas_test_core.F +++ b/src/core_test/mpas_test_core.F @@ -97,6 +97,7 @@ function test_core_run(domain) result(iErr)!{{{ use test_core_string_utils, only : mpas_test_string_utils use mpas_test_core_dmpar, only : mpas_test_dmpar use mpas_test_core_stream_inquiry, only : mpas_test_stream_inquiry + use test_core_io, only : test_core_io_test use mpas_test_core_openacc, only : mpas_test_openacc implicit none @@ -224,6 +225,18 @@ function test_core_run(domain) result(iErr)!{{{ call mpas_stream_mgr_write(domain % streamManager, forceWriteNow=.true.) + ! + ! Run io tests + ! + call mpas_log_write('') + call test_core_io_test(domain, iErr) + if (iErr == 0) then + call mpas_log_write('All tests PASSED') + else + call mpas_log_write('$i tests FAILED', intArgs=[iErr]) + end if + call mpas_log_write('') + ! ! Run mpas_test_openacc ! diff --git a/src/core_test/mpas_test_core_io.F b/src/core_test/mpas_test_core_io.F new file mode 100644 index 0000000000..b448d06d78 --- /dev/null +++ b/src/core_test/mpas_test_core_io.F @@ -0,0 +1,200 @@ +! Copyright (c) 2025 The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at https://mpas-dev.github.io/license.html . +! +module test_core_io + +#define ERROR_WRITE(M) call mpas_log_write( M , messageType=MPAS_LOG_ERR) +#define ERROR_WRITE_ARGS(M, ARGS) call mpas_log_write( M , ARGS, messageType=MPAS_LOG_ERR) + use mpas_log + use mpas_io + + implicit none + private + public :: test_core_io_test + + contains + + !*********************************************************************** + ! + ! routine close_file_with_message + ! + !> \brief closes the provided file handle and writes an error message. + !----------------------------------------------------------------------- + subroutine close_file_with_message(fileHandle, message, args) + type(MPAS_IO_Handle_type), intent(inout) :: fileHandle + character (len=*), intent(in), optional :: message + integer, dimension(:), intent(in), optional :: args + + integer :: local_ierr + + ! log an error message + if (present(message)) then + ERROR_WRITE_ARGS(message, intArgs=args) + end if + + ! close the provided file + call MPAS_io_close(fileHandle, local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ERROR_WRITE_ARGS('MPAS_io_close failed with error code:$i', intArgs=(/local_ierr/)) + return + endif + + end subroutine close_file_with_message + + !*********************************************************************** + ! + ! routine test_read_string_buffer_check + ! + !> \brief verifies attempts to read strings into buffers which are too small + !> to hold the value fails safely. + !> \details + !> Run these tests with valgrind to ensure there are no buffer overflows when + !> attempting to read strings into undersized buffers. + !----------------------------------------------------------------------- + subroutine test_read_string_buffer_check(domain, ierr) + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: ierr + + integer :: local_ierr, i + type(MPAS_IO_Handle_type) :: fileHandle + character (len=StrKIND), dimension(1), parameter :: dimNamesString = ['StrLen'] + character (len=StrKIND), dimension(2), parameter :: dimNamesStringTime = & + [character(len=StrKIND) :: 'StrLen', 'Time'] + character (len=32), parameter :: varName1 = 'stringVar' + character (len=32), parameter :: varName2 = 'stringTimeVar' + character (len=*), parameter :: varValue1 = 'This is a string' + character (len=32), dimension(2), parameter :: varNames = [varName1, varName2] + integer, parameter :: bufferSize=128 + integer, parameter :: smallBufferSize=bufferSize/2 + character (len=bufferSize) :: buffer + character (len=smallBufferSize) :: smallBuffer + character (len=*), parameter :: filename = 'char_data.nc' + + ierr = 0 + + ! open a file to write char variables to + fileHandle = MPAS_io_open(filename, MPAS_IO_WRITE, MPAS_IO_NETCDF, domain % ioContext, & + clobber_file=.true., truncate_file=.true., ierr=local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ierr = 1 + ERROR_WRITE('Error opening file ' // trim(filename)) + return + end if + + ! define dimensions and char variables + call MPAS_io_def_dim(fileHandle, dimNamesStringTime(1), bufferSize, local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ierr = 1 + call close_file_with_message(fileHandle, 'Error defining '//trim(dimNamesStringTime(1))//', error=$i', (/local_ierr/)) + return + end if + call MPAS_io_def_dim(fileHandle, dimNamesStringTime(2), MPAS_IO_UNLIMITED_DIM, local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ierr = 1 + call close_file_with_message(fileHandle, 'Error defining '//trim(dimNamesStringTime(2))//', error=$i', (/local_ierr/)) + return + end if + call MPAS_io_def_var(fileHandle, varNames(1), MPAS_IO_CHAR, dimNamesString, ierr=local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ierr = 1 + call close_file_with_message(fileHandle, 'Error defining var "'//trim(varNames(1))//'" error=$i', (/local_ierr/)) + return + end if + call MPAS_io_def_var(fileHandle, varNames(2), MPAS_IO_CHAR, dimNamesStringTime, ierr=local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ierr = 1 + call close_file_with_message(fileHandle, 'Error defining var "'//trim(varNames(2))//'" error=$i', (/local_ierr/)) + return + end if + + ! write the string values + do i=1,size(varNames) + call MPAS_io_put_var_char0d(fileHandle, varNames(i), varValue1, local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ierr = 1 + call close_file_with_message(fileHandle, 'Error writing "'//trim(varNames(i))// & + '", error=$i', (/local_ierr/)) + return + end if + + ! verify the strings are read into buffers which are large enough for the string values + call MPAS_io_get_var_char0d(fileHandle, varNames(i), buffer, local_ierr) + if (local_ierr /= MPAS_IO_NOERR) then + ierr = 1 + call close_file_with_message(fileHandle, 'Error reading "'//trim(varNames(i))// & + '", error=$i', (/local_ierr/)) + return + end if + end do + + ! verify attempts to read strings into buffers which are too small generates an error + call mpas_log_write(' ') + call mpas_log_write('Expect to see the following error:') + call MPAS_io_err_mesg(domain % ioContext, MPAS_IO_ERR_INSUFFICIENT_BUF, .false.) + call mpas_log_write(' ') + do i=1,size(varNames) + ! this should return an error + call MPAS_io_get_var_char0d(fileHandle, varNames(i), smallBuffer, local_ierr) + call mpas_log_write(' ') + + if (local_ierr /= MPAS_IO_ERR_INSUFFICIENT_BUF) then + ierr = 1 + if (local_ierr == MPAS_IO_NOERR) then + call close_file_with_message(fileHandle, 'Expected MPAS_IO_ERR_INSUFFICIENT_BUF ($i)'& + //' but recieved no error reading "'//trim(varName1), (/local_ierr/)) + else + call close_file_with_message(fileHandle, 'Expected MPAS_IO_ERR_INSUFFICIENT_BUF ($i)'& + //' but recieved error $i reading "'//trim(varName1)//'"', & + (/MPAS_IO_ERR_INSUFFICIENT_BUF, local_ierr/)) + end if + return + end if + end do + call close_file_with_message(fileHandle) + + end subroutine test_read_string_buffer_check + + + !*********************************************************************** + ! Subroutine test_core_io_test + ! + !> \brief Core test suite for I/O + !> + !> \details This subroutine tests mpas_io features. + !> It calls individual tests for I/O operations. + !> See the subroutine body for details. + !> The results of each test are logged with a success or failure message. + !> + !> \param domain The domain object that contains the I/O context + !> \param ierr The error code that indicates the result of the test. + ! + !----------------------------------------------------------------------- + subroutine test_core_io_test(domain, ierr) + + use mpas_log + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: ierr + + integer :: test_status + + ierr = 0 + test_status = 0 + + call mpas_log_write('Testing char-0 buffer reads') + call test_read_string_buffer_check(domain, test_status) + if (test_status == 0) then + call mpas_log_write('char-0 buffer tests: SUCCESS') + else + call mpas_log_write('char-0 buffer tests: FAILURE', MPAS_LOG_ERR) + ierr = ierr + abs(test_status) + end if + + + end subroutine test_core_io_test + +end module test_core_io From e530428a43841b3e1963cfc08544b86768285ddf Mon Sep 17 00:00:00 2001 From: Jim Wittig Date: Tue, 17 Feb 2026 10:28:51 -0700 Subject: [PATCH 131/214] Allow optional arguments to logging macros in mpas_io.F IO_DEBUG_WRITE and IO_ERROR_WRITE take one argument, which is passed to mpas_log_write(). To pass parameters to mpas_log_write invoke the macros providing COMMA between arguments, e.g. IO_DEBUG_WRITE('message' COMMA intArgs=[42]) --- src/framework/mpas_io.F | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/framework/mpas_io.F b/src/framework/mpas_io.F index 20318e56ad..5b3b5642bb 100644 --- a/src/framework/mpas_io.F +++ b/src/framework/mpas_io.F @@ -7,8 +7,9 @@ ! module mpas_io -#define IO_DEBUG_WRITE(M, ARGS) !call mpas_log_write(M, ARGS) -#define IO_ERROR_WRITE(M, ARGS) call mpas_log_write( M, ARGS, messageType=MPAS_LOG_ERR) +#define COMMA , +#define IO_DEBUG_WRITE(M) ! call mpas_log_write(M) +#define IO_ERROR_WRITE(M) call mpas_log_write( M, messageType=MPAS_LOG_ERR) use mpas_derived_types use mpas_attlist @@ -2000,15 +2001,15 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr do i = 1, ndims message = ' MPAS_io_get_var_generic len(charVal):$i var "'//trim(fieldname)// & '" type is $i dim is $i '// trim(dimnames(i))//' size is $i' - IO_DEBUG_WRITE(message, intArgs=(/len(charVal), fieldtype, i, dimsizes(i)/)) + IO_DEBUG_WRITE(message COMMA intArgs=(/len(charVal), fieldtype, i, dimsizes(i)/)) end do ! because charVal is provided, assume dimension 1 is the string length if (dimsizes(1) > len(charVal)) then local_ierr = MPAS_IO_ERR_INSUFFICIENT_BUF message = 'Length of string variable "'//trim(fieldname)//'" in file "'//trim(handle % filename)//'"' - IO_ERROR_WRITE(message, intArgs=[0]) + IO_ERROR_WRITE(message) message = ' exceeds buffer size: len('//trim(fieldname)//')=$i, len(buffer)=$i' - IO_ERROR_WRITE(message, intArgs=(/dimsizes(1), len(charVal)/)) + IO_ERROR_WRITE(message COMMA intArgs=(/dimsizes(1), len(charVal)/)) else #ifdef MPAS_SMIOL_SUPPORT local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, charVal_p) From f69133ab70aaebdb4a3613868939f5d1207b0913 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Thu, 19 Feb 2026 13:44:15 -0700 Subject: [PATCH 132/214] Adding support for linking with the SCOTCH graph partitioning library This commit adds support for linking MPAS with the SCOTCH graph partitioning library. This capability is intended as a first step towards MPAS cores being able to generate graph partitions during runtime, by invoking the distributed graph partitioning algorithms provided by PT-SCOTCH. In order for MPAS to be able to link with the SCOTCH library, the SCOTCH environment variable must be set to point to the SCOTCH installation path prior to build MPAS. export SCOTCH=/path/to/scotch/installation make gnu CORE=atmosphere If the SCOTCH env variable has been set, but it does not point to the correct SCOTCH installation directory, then the Scotch C test in the Makefile would fail, yielding the following message: Could not build a simple C program with Scotch. If MPAS has been successfully linked with the SCOTCH library, the build summary will include the message: MPAS has been linked with the Scotch graph partitioning library. Furthermore, the log file at model runtime will also include the following message near the top: SCOTCH support: yes Conversely, if MPAS has not been linked with SCOTCH, then appropriate messages are displayed in the aforementioned locations. --- Makefile | 48 ++++++++++++++++++++++++++++++++++ src/framework/mpas_framework.F | 6 +++++ 2 files changed, 54 insertions(+) diff --git a/Makefile b/Makefile index c34823ab5a..caab21804f 100644 --- a/Makefile +++ b/Makefile @@ -759,6 +759,15 @@ endif LIBS += $(NCLIB) endif +ifneq "$(SCOTCH)" "" + SCOTCH_INCLUDES += -I$(SCOTCH)/include + SCOTCH_LIBS += -L$(SCOTCH)/lib64 -lptscotch -lscotch -lptscotcherr -lm + SCOTCH_FLAGS = -DMPAS_SCOTCH + + CPPINCLUDES += $(SCOTCH_INCLUDES) + LIBS += $(SCOTCH_LIBS) + override CPPFLAGS += $(SCOTCH_FLAGS) +endif ifneq "$(PNETCDF)" "" ifneq ($(wildcard $(PNETCDF)/lib/libpnetcdf.*), ) @@ -1415,6 +1424,37 @@ musica_fortran_test: $(eval MUSICA_FORTRAN_VERSION := $(shell pkg-config --modversion musica-fortran)) $(if $(findstring 1,$(MUSICA_FORTRAN_TEST)), $(info Built a simple test program with MUSICA-Fortran version $(MUSICA_FORTRAN_VERSION)), ) +scotch_c_test: + @# + @# Create a C test program and try to build against the PT-SCOTCH library + @# + $(info Checking for a working Scotch library...) + $(eval SCOTCH_C_TEST := $(shell $\ + printf "#include \n\ + &#include \"mpi.h\"\n\ + &#include \"ptscotch.h\"\n\ + &int main(){\n\ + & int err;\n\ + & SCOTCH_Dgraph *dgraph;\n\ + & err = SCOTCH_dgraphInit(dgraph, MPI_COMM_WORLD);\n\ + & SCOTCH_dgraphExit(dgraph);\n\ + & return err;\n\ + &}\n" | sed 's/&/ /' > ptscotch_c_test.c; $\ + $\ + $(CC) $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) ptscotch_c_test.c -o ptscotch_c_test.x $(SCOTCH_LIBS) > ptscotch_c_test.log 2>&1; $\ + scotch_c_status=$$?; $\ + if [ $$scotch_c_status -eq 0 ]; then $\ + printf "1"; $\ + rm -f ptscotch_c_test.c ptscotch_c_test.x ptscotch_c_test.log; $\ + else $\ + printf "0"; $\ + fi $\ + )) + $(if $(findstring 0,$(SCOTCH_C_TEST)), $(error Could not build a simple C program with Scotch. $\ + Test program ptscotch_c_test.c and output ptscotch_c_test.log have been left $\ + in the top-level MPAS directory for further debugging )) + $(if $(findstring 1,$(SCOTCH_C_TEST)), $(info Built a simple C program with Scotch )) + pnetcdf_test: @# @# Create test C programs that look for PNetCDF header file and some symbols in it @@ -1471,6 +1511,13 @@ else MUSICA_MESSAGE = "MPAS was not linked with the MUSICA-Fortran library." endif +ifneq "$(SCOTCH)" "" +MAIN_DEPS += scotch_c_test +SCOTCH_MESSAGE = "MPAS has been linked with the Scotch graph partitioning library." +else +SCOTCH_MESSAGE = "MPAS was NOT linked with the Scotch graph partitioning library." +endif + mpas_main: $(MAIN_DEPS) cd src; $(MAKE) FC="$(FC)" \ CC="$(CC)" \ @@ -1508,6 +1555,7 @@ mpas_main: $(MAIN_DEPS) @echo $(OPENMP_OFFLOAD_MESSAGE) @echo $(OPENACC_MESSAGE) @echo $(MUSICA_MESSAGE) + @echo $(SCOTCH_MESSAGE) @echo $(SHAREDLIB_MESSAGE) ifeq "$(AUTOCLEAN)" "true" @echo $(AUTOCLEAN_MESSAGE) diff --git a/src/framework/mpas_framework.F b/src/framework/mpas_framework.F index 0c48c68bac..7cba507484 100644 --- a/src/framework/mpas_framework.F +++ b/src/framework/mpas_framework.F @@ -262,6 +262,12 @@ subroutine mpas_framework_report_settings(domain) call mpas_log_write(' - MICM version: '//trim(micm_version % value_)) #else 'no') +#endif + call mpas_log_write(' SCOTCH support: ' // & +#ifdef MPAS_SCOTCH + 'yes') +#else + 'no') #endif call mpas_log_write('') From faaf2e4295a6d0beaadc16d70c3d98aa310a3c50 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Thu, 19 Feb 2026 15:59:12 -0700 Subject: [PATCH 133/214] Adding source files that enable Fortran-C interfaces from MPAS to SCOTCH This commit adds a C and Fortran source file to the src/framework directory, and builds on the previous commit to provide a set of routines which enable various MPAS cores to invoke the SCOTCH library to do the following tasks: - Initialize, build and check a distributed SCOTCH graph - Partition and redistribute the distributed graphs - Query distributed graphs - Initialize SCOTCH graph mapping strategies Together these routines enable the MPAS framework to generate online graph partitioning. This commit also includes modifications to the src/framework Makefile to build and C and Fortran interfaces. To avoid unnecessary references to the SCOTCH fortran library, this commit introduces two derived types, scotchm_dgraph and scotchm_strat in the Fortran mpas_ptscotch_interface. These two derived types hold C pointers to memory locations of type SCOTCH_Dgraph and SCOTCH_Strat respectively, which are allocated in the C-interface. --- src/framework/Makefile | 4 + src/framework/mpas_ptscotch_interface.F | 453 ++++++++++++++++++++++++ src/framework/ptscotch_interface.c | 280 +++++++++++++++ 3 files changed, 737 insertions(+) create mode 100644 src/framework/mpas_ptscotch_interface.F create mode 100644 src/framework/ptscotch_interface.c diff --git a/src/framework/Makefile b/src/framework/Makefile index 2d8e7dc92b..ebf6dabbb7 100644 --- a/src/framework/Makefile +++ b/src/framework/Makefile @@ -36,6 +36,8 @@ OBJS = mpas_kind_types.o \ mpas_log.o \ mpas_halo.o \ mpas_string_utils.o \ + mpas_ptscotch_interface.o \ + ptscotch_interface.o \ mpas_stream_inquiry.o \ stream_inquiry.o @@ -112,6 +114,8 @@ xml_stream_parser.o: xml_stream_parser.c mpas_halo.o: mpas_derived_types.o mpas_pool_routines.o mpas_log.o +mpas_ptscotch_interface.o : mpas_derived_types.o mpas_log.o + mpas_stream_inquiry.o : mpas_derived_types.o mpas_log.o mpas_c_interfacing.o clean: diff --git a/src/framework/mpas_ptscotch_interface.F b/src/framework/mpas_ptscotch_interface.F new file mode 100644 index 0000000000..6980e2b33b --- /dev/null +++ b/src/framework/mpas_ptscotch_interface.F @@ -0,0 +1,453 @@ +! Copyright (c) 2025 The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at https://mpas-dev.github.io/license.html . +! +#ifdef MPAS_SCOTCH +module mpas_ptscotch_interface + use iso_c_binding, only : c_ptr + public :: scotch_dgraphinit, scotch_dgraphbuild + + ! Dummy type declaration for SCOTCH distributed graph + ! Member ptr is a pointer to the SCOTCH_Dgraph C structure + type :: scotchm_dgraph + type(c_ptr) :: ptr + end type scotchm_dgraph + + ! Dummy type declaration for SCOTCH strategy + ! Member ptr is a pointer to the SCOTCH_Strat C structure + type :: scotchm_strat + type(c_ptr) :: ptr + end type scotchm_strat + +contains + + !----------------------------------------------------------------------- + ! subroutine scotch_checkintsize + ! + !> \brief Check that SCOTCH integer size matches MPAS integer size + !> \author Abishek Gopal + !> \date 21 Jan 2026 + !> \details + !> Compares the size of SCOTCH_Num type with the MPAS integer size. + !> Logs an error message if there is a mismatch. + !----------------------------------------------------------------------- + subroutine scotch_checkintsize() + use iso_c_binding, only : c_int, c_size_t, c_sizeof + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_CRIT + + implicit none + + integer(c_int) :: dummy_int + + interface + function scotchm_get_intsize() bind(C, name='scotchm_get_intsize') result(intsize) + use iso_c_binding, only : c_size_t + integer(c_size_t) :: intsize + end function scotchm_get_intsize + end interface + + if (scotchm_get_intsize() /= c_sizeof(dummy_int)) then + call mpas_log_write("Error: Scotch SCOTCH_Num size does not match MPAS integer size \n" & + // "Please build Scotch with 32-bit integers", MPAS_LOG_CRIT) + end if + + end subroutine scotch_checkintsize + + !----------------------------------------------------------------------- + ! subroutine scotch_dgraphinit + ! + !> \brief Initialize a SCOTCH distributed graph object + !> \author Abishek Gopal + !> \date 8 Dec 2025 + !> \details + !> Initializes a SCOTCH_Dgraph structure using a Fortran MPI communicator. + !> This subroutine wraps the C function scotchm_dgraphinit. + !> \arguments + !> dgraph - scotchm_dgraph structure to be initialized + !> comm - Fortran MPI communicator integer + ! + !----------------------------------------------------------------------- + subroutine scotch_dgraphinit(dgraph, comm) + use iso_c_binding, only : c_ptr + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_CRIT + + implicit none + ! Arguments + type(scotchm_dgraph), intent(inout) :: dgraph + integer, intent(in) :: comm + + ! Return value + integer :: ierr + + interface + function scotchm_dgraphinit(dgraph_ptr, localcomm) bind(C, name='scotchm_dgraphinit') result(err) + use iso_c_binding, only : c_ptr, c_int + type(c_ptr) :: dgraph_ptr + integer(c_int), value :: localcomm + integer(c_int) :: err + end function scotchm_dgraphinit + end interface + + ierr = scotchm_dgraphinit(dgraph % ptr, comm) + + if (ierr /= 0) then + call mpas_log_write('Error initalizing distributed Scotch graph', MPAS_LOG_CRIT) + end if + + end subroutine scotch_dgraphinit + + !----------------------------------------------------------------------- + ! subroutine scotch_dgraphbuild + ! + !> \brief Build a SCOTCH distributed graph from local vertex/edge arrays + !> \author Abishek Gopal + !> \date 8 Dec 2025 + !> \details + !> Constructs a SCOTCH_Dgraph from local vertex and edge connectivity data. + !> This subroutine wraps the C function scotchm_dgraphbuild + !> \arguments + !> dgraph - scotchm_dgraph structure to be built + !> nVertices - Number of local vertices + !> vertloctab - Array of size (nVertices+1) + !> giving the start index of edges for each local vertex + !> nLocEdgesGraph - Total number of local edges in the graph + !> edgelocsiz - Size of the adjncy array + !> adjncy - Array of size nLocEdgesGraph containing the + !> adjacency list for local vertices + ! + !----------------------------------------------------------------------- + subroutine scotch_dgraphbuild(dgraph, nVertices, vertloctab, nLocEdgesGraph, edgelocsiz, adjncy) + use iso_c_binding, only : c_ptr, c_int + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_CRIT + + implicit none + + type(scotchm_dgraph) :: dgraph + integer(c_int), intent(in) :: nVertices + integer(c_int), intent(in) :: vertloctab(nVertices+1) + integer(c_int), intent(in) :: nLocEdgesGraph + integer(c_int), intent(in) :: edgelocsiz + integer(c_int), intent(in) :: adjncy(nLocEdgesGraph) + + ! Return value + integer :: ierr + + interface + function scotchm_dgraphbuild(dgraph_ptr, nVertices, vertloctab, & + nLocEdgesGraph, edgelocsiz, adjncy) bind(C, name='scotchm_dgraphbuild') result(err) + use iso_c_binding, only : c_ptr, c_int + type(c_ptr), value :: dgraph_ptr + integer(c_int), value :: nVertices + integer(c_int) :: vertloctab(nVertices+1) + integer(c_int), value :: nLocEdgesGraph + integer(c_int), value :: edgelocsiz + integer(c_int) :: adjncy(nLocEdgesGraph) + integer(c_int) :: err + end function scotchm_dgraphbuild + end interface + + ierr = 0 + + ierr = scotchm_dgraphbuild(dgraph % ptr, nVertices, vertloctab, & + nLocEdgesGraph, edgelocsiz, adjncy) + + if (ierr /= 0) then + call mpas_log_write('Error building distributed Scotch graph', MPAS_LOG_CRIT) + else + call mpas_log_write('Successfully built distributed Scotch graph') + end if + + end subroutine scotch_dgraphbuild + + !----------------------------------------------------------------------- + ! subroutine scotch_dgraphcheck + ! + !> \brief Perform consistency check on a SCOTCH distributed graph + !> \author Abishek Gopal + !> \date 8 Dec 2025 + !> \details + !> Validates the internal structure of a SCOTCH_Dgraph for consistency. + !> This subroutine wraps the C function scotchm_dgraphcheck. + !> \arguments + !> dgraph - scotchm_dgraph structure to be checked + ! + !----------------------------------------------------------------------- + subroutine scotch_dgraphcheck(dgraph) + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_CRIT + use iso_c_binding, only : c_ptr + + implicit none + + type(scotchm_dgraph) :: dgraph + + ! Return value + integer :: ierr + + interface + function scotchm_dgraphcheck(dgraph_ptr) bind(C, name='scotchm_dgraphcheck') result(err) + use iso_c_binding, only : c_int, c_ptr + type(c_ptr), value :: dgraph_ptr + integer(c_int) :: err + end function scotchm_dgraphcheck + end interface + + ierr = scotchm_dgraphcheck(dgraph % ptr) + + if (ierr /= 0) then + call mpas_log_write('Error during distributed Scotch graph check', MPAS_LOG_CRIT) + end if + + end subroutine scotch_dgraphcheck + + !----------------------------------------------------------------------- + ! subroutine scotch_dgraphexit + ! + !> \brief Finalize/cleanup a SCOTCH distributed graph object + !> \author Abishek Gopal + !> \date 8 Dec 2025 + !> \details + !> Deallocates internal structures associated with a SCOTCH_Dgraph. + !> This subroutine wraps the C function scotchm_dgraphexit. + !> \arguments + !> dgraph - scotchm_dgraph structure to be finalized + ! + !----------------------------------------------------------------------- + subroutine scotch_dgraphexit(dgraph) + use mpas_log, only : mpas_log_write + use iso_c_binding, only : c_ptr + + implicit none + + type(scotchm_dgraph) :: dgraph + + interface + subroutine scotchm_dgraphexit(dgraph_ptr) bind(C, name='scotchm_dgraphexit') + use iso_c_binding, only : c_int, c_ptr + type(c_ptr), value :: dgraph_ptr + end subroutine scotchm_dgraphexit + end interface + + call scotchm_dgraphexit(dgraph % ptr) + + end subroutine scotch_dgraphexit + + !----------------------------------------------------------------------- + ! subroutine scotch_stratinit + ! + !> \brief Initialize a SCOTCH strategy object + !> \author Abishek Gopal + !> \date 8 Dec 2025 + !> \details + !> Initializes a SCOTCH_Strat structure and builds a default strategy + !> for distributed graph mapping. This subroutine wraps the C function + !> scotchm_stratinit. + !> \arguments + !> stradat - scotchm_strat structure to be initialized + ! + !----------------------------------------------------------------------- + subroutine scotch_stratinit(stradat) + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_CRIT + use iso_c_binding, only : c_ptr + + implicit none + + type(scotchm_strat), intent(inout) :: stradat + + integer :: ierr + + interface + function scotchm_stratinit(strat_ptr) bind(C, name='scotchm_stratinit') result(err) + use iso_c_binding, only : c_int, c_ptr + type(c_ptr) :: strat_ptr + integer(c_int) :: err + end function scotchm_stratinit + end interface + + ierr = scotchm_stratinit(stradat % ptr) + + if (ierr /= 0) then + call mpas_log_write('Error during Scotch strategy initialization', MPAS_LOG_CRIT) + end if + + end subroutine scotch_stratinit + + !----------------------------------------------------------------------- + ! subroutine scotch_stratexit + ! + !> \brief Finalize/cleanup a SCOTCH strategy object + !> \author Abishek Gopal + !> \date 8 Dec 2025 + !> \details + !> Deallocates internal structures associated with a SCOTCH_Strat. + !> This subroutine wraps the C function scotchm_stratexit. + !> \arguments + !> stradat - scotchm_strat structure to be finalized + ! + !----------------------------------------------------------------------- + subroutine scotch_stratexit(stradat) + use mpas_log, only : mpas_log_write + use iso_c_binding, only : c_ptr + + implicit none + + type(scotchm_strat), intent(in) :: stradat + + interface + subroutine scotchm_stratexit(strat_ptr) bind(C, name='scotchm_stratexit') + use iso_c_binding, only : c_ptr + type(c_ptr), value :: strat_ptr + end subroutine scotchm_stratexit + end interface + + call scotchm_stratexit(stradat % ptr) + + end subroutine scotch_stratexit + + !----------------------------------------------------------------------- + ! subroutine scotch_dgraphpart + ! + !> \brief Partition a SCOTCH distributed graph + !> \author Abishek Gopal + !> \date 8 Dec 2025 + !> \details + !> Partitions the distributed graph into num_part parts using the + !> provided SCOTCH strategy object. This subroutine wraps the C function + !> scotchm_dgraphpart. + !> \arguments + !> dgraph - scotchm_dgraph structure to be partitioned + !> num_part - Number of partitions + !> stradat - scotchm_strat structure containing partitioning strategy + !> parttab - Output array of size equal to number of local vertices, + ! + !----------------------------------------------------------------------- + subroutine scotch_dgraphpart(dgraph, num_part, stradat, parttab) + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_CRIT + use iso_c_binding, only : c_ptr, c_int + + implicit none + + type(scotchm_dgraph), intent(in) :: dgraph + integer(c_int), intent(in) :: num_part + type(scotchm_strat), intent(in) :: stradat + integer(c_int), intent(out) :: parttab(*) + + ! Return value + integer :: ierr + + interface + function scotchm_dgraphpart(dgraph_ptr, num_part_loc, strat_ptr, parttab_loc ) bind(C, name='scotchm_dgraphpart') result(err) + use iso_c_binding, only : c_int, c_ptr + type(c_ptr), value :: dgraph_ptr + integer(c_int), value :: num_part_loc + type(c_ptr), value :: strat_ptr + integer(c_int) :: parttab_loc(*) + integer(c_int) :: err + end function scotchm_dgraphpart + end interface + + ierr = scotchm_dgraphpart(dgraph % ptr, num_part, stradat % ptr, parttab) + + if (ierr /= 0) then + call mpas_log_write('Error during Scotch graph partition', MPAS_LOG_CRIT) + else + call mpas_log_write('Successfully partitioned distributed Scotch graph') + end if + + end subroutine scotch_dgraphpart + + !----------------------------------------------------------------------- + ! subroutine scotch_dgraphredist + ! + !> \brief Redistribute a SCOTCH distributed graph according to partitions + !> \author Abishek Gopal + !> \date 8 Dec 2025 + !> \details + !> Redistributes the distributed graph structure based on a partition + !> table. This subroutine wraps the C function scotchm_dgraphredist. + !> \arguments + !> dgraph - scotchm_dgraph structure to be redistributed + !> parttab - Input array of size equal to number of local vertices, + !> containing partition assignments + !> dgraph_out - scotchm_dgraph structure to hold redistributed graph + !> num_local_vertices - Number of local vertices in the redistributed graph + ! + !----------------------------------------------------------------------- + subroutine scotch_dgraphredist(dgraph, parttab, dgraph_out, num_local_vertices) + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_CRIT + use iso_c_binding, only : c_ptr, c_int + + implicit none + + type(scotchm_dgraph) :: dgraph + integer(c_int), intent(in) :: parttab(*) + type(scotchm_dgraph) :: dgraph_out + integer(c_int) :: num_local_vertices + + ! Return value + integer :: ierr + + interface + function scotchm_dgraphredist(dgraph_ptr, parttab_loc, dgraph_out_ptr, vertlocnbr ) bind(C, name='scotchm_dgraphredist') result(err) + use iso_c_binding, only : c_int, c_ptr + type(c_ptr), value :: dgraph_ptr + integer(c_int) :: parttab_loc(*) + type(c_ptr), value :: dgraph_out_ptr + integer(c_int) :: vertlocnbr + integer(c_int) :: err + end function scotchm_dgraphredist + end interface + + ierr = scotchm_dgraphredist(dgraph % ptr, parttab, dgraph_out % ptr, num_local_vertices) + + if (ierr /= 0) then + call mpas_log_write('Error during Scotch graph redistribution', MPAS_LOG_CRIT) + end if + + end subroutine scotch_dgraphredist + + !----------------------------------------------------------------------- + ! subroutine scotch_dgraphdata + ! + !> \brief Extract vertex labels from a SCOTCH distributed graph + !> \author Abishek Gopal + !> \date 8 Dec 2025 + !> \details + !> Extracts vertex labels or stored IDs for local vertices into the + !> output array. This subroutine wraps the C function scotchm_dgraphdata. + !> \arguments + !> dgraph - scotchm_dgraph structure to extract from + !> local_cell_list - Output array to hold vertex labels for local vertices + ! + !----------------------------------------------------------------------- + subroutine scotch_dgraphdata(dgraph, local_cell_list) + use mpas_log, only : mpas_log_write + use iso_c_binding, only : c_ptr, c_int + + implicit none + + type(scotchm_dgraph) :: dgraph + integer(c_int), intent(out) :: local_cell_list(*) + + interface + subroutine scotchm_dgraphdata(dgraph_ptr, cell_list) bind(C, name='scotchm_dgraphdata') + use iso_c_binding, only : c_int, c_ptr + type(c_ptr), value :: dgraph_ptr + integer(c_int) :: cell_list(*) + end subroutine scotchm_dgraphdata + end interface + + call scotchm_dgraphdata(dgraph % ptr, local_cell_list) + + end subroutine scotch_dgraphdata + +end module mpas_ptscotch_interface +#endif diff --git a/src/framework/ptscotch_interface.c b/src/framework/ptscotch_interface.c new file mode 100644 index 0000000000..c503a8c42b --- /dev/null +++ b/src/framework/ptscotch_interface.c @@ -0,0 +1,280 @@ +/* + * Copyright (c) 2025, The University Corporation for Atmospheric Research (UCAR). + * + * Unless noted otherwise source code is licensed under the BSD license. + * Additional copyright and license information can be found in the LICENSE file + * distributed with this code, or at http://mpas-dev.github.com/license.html + */ +#ifdef MPAS_SCOTCH +#include +#include +#include "mpi.h" +#include "ptscotch.h" + + +/********************************************************************************* + * + * scotchm_get_intsize + * + * Get the size of SCOTCH_Num in bytes. + * + * Returns: + * size of SCOTCH_Num in bytes. + * + ********************************************************************************/ +size_t scotchm_get_intsize() +{ + return sizeof(SCOTCH_Num); + +} + + +/******************************************************************************** + * + * scotchm_dgraphinit + * + * Initialize a SCOTCH distributed graph object using a Fortran MPI communicator. + * + * Parameters: + * dgraph_ptr - pointer to a `SCOTCH_Dgraph` structure + * localcomm - Fortran MPI communicator handle (`MPI_Fint`) passed as `int` + * + * Returns: + * integer error code returned by `SCOTCH_dgraphInit` (0 on success). + * + ********************************************************************************/ +int scotchm_dgraphinit(SCOTCH_Dgraph **dgraph_ptr, int localcomm) +{ + MPI_Comm comm; + + comm = MPI_Comm_f2c((MPI_Fint)localcomm); + + *dgraph_ptr = (SCOTCH_Dgraph *) malloc(sizeof (SCOTCH_Dgraph)); + + return SCOTCH_dgraphInit(*dgraph_ptr, comm); + +} + + +/******************************************************************************** + * + * scotchm_dgraphbuild + * + * Build a SCOTCH distributed graph from local vertex/edge arrays. + * + * Parameters: + * ptr - pointer to a `SCOTCH_Dgraph` structure + * nVertices - number of local vertices + * vertloctab_1 - pointer to Fortran-style vertex index array (based) + * nLocEdgesGraph - number of local edges in the distributed graph + * edgelocsiz_1 - size of the local edge array + * adjncy - adjacency list array (edge destinations) + * + * Returns: + * integer error code returned by `SCOTCH_dgraphBuild` (0 on success). + * + ********************************************************************************/ +int scotchm_dgraphbuild(SCOTCH_Dgraph *dgraph_ptr, SCOTCH_Num nVertices, + SCOTCH_Num *vertloctab_1, SCOTCH_Num nLocEdgesGraph, + SCOTCH_Num edgelocsiz_1, SCOTCH_Num *adjncy) +{ + SCOTCH_Num baseval = 1; /* Fortran-style 1-based indexing */ + SCOTCH_Num vertlocnbr = nVertices; + SCOTCH_Num *veloloctab = NULL; /* vertex weights not used */ + SCOTCH_Num *vlblloctab = NULL; /* vertex labels not used */ + SCOTCH_Num edgelocnbr = nLocEdgesGraph; + SCOTCH_Num edgelocsiz = edgelocsiz_1; + SCOTCH_Num *edgegsttab = NULL; /* Optional array holding the local and ghost indices */ + SCOTCH_Num *edloloctab = NULL; /* Optional array of integer loads for each local edge */ + + SCOTCH_Num *vertloctab = (SCOTCH_Num *)vertloctab_1; + SCOTCH_Num *vendloctab = vertloctab_1 + 1; + SCOTCH_Num *edgeloctab = (SCOTCH_Num *)adjncy; + + return SCOTCH_dgraphBuild(dgraph_ptr, baseval, vertlocnbr, vertlocnbr, + vertloctab, vendloctab, veloloctab, vlblloctab, + edgelocnbr, edgelocsiz, edgeloctab, edgegsttab, + edloloctab); + +} + + +/******************************************************************************** + * + * scotchm_dgraphcheck + * + * Perform an internal consistency check of a SCOTCH distributed graph. + * + * Parameters: + * ptr - pointer to a `SCOTCH_Dgraph` structure + * + * Returns: + * integer error code returned by `SCOTCH_dgraphCheck` (0 on success). + * + ********************************************************************************/ +int scotchm_dgraphcheck(SCOTCH_Dgraph *dgraph_ptr) +{ + return SCOTCH_dgraphCheck(dgraph_ptr); + +} + + +/******************************************************************************** + * + * scotchm_dgraphpart + * + * Partition the distributed graph into `num_part` parts using the provided + * SCOTCH strategy object. + * + * Parameters: + * ptr - pointer to a `SCOTCH_Dgraph` structure + * num_part - number of partitions + * ptr_strat - pointer to a `SCOTCH_Strat` structure + * parttab - output array receiving part numbers for local vertices + * + * Returns: + * integer error code returned by `SCOTCH_dgraphPart` (0 on success). + * + ********************************************************************************/ +int scotchm_dgraphpart(SCOTCH_Dgraph *dgraph_ptr, SCOTCH_Num num_part, SCOTCH_Strat *strat_ptr, SCOTCH_Num *parttab) +{ + return SCOTCH_dgraphPart(dgraph_ptr, num_part, strat_ptr, parttab); + +} + + +/******************************************************************************** + * + * scotchm_dgraphredist + * + * Redistribute a distributed SCOTCH graph given the partition table. + * + * Parameters: + * ptr - pointer to input `SCOTCH_Dgraph` structure + * partloctab - partition table for local vertices + * ptr_out - pointer to output `SCOTCH_Dgraph` structure + * vertlocnbr - pointer to return the number of local vertices in output + * + * Returns: + * integer error code returned by `SCOTCH_dgraphRedist` (0 on success). + * + ********************************************************************************/ +int scotchm_dgraphredist(SCOTCH_Dgraph *dgraph_in, SCOTCH_Num *partloctab, SCOTCH_Dgraph *dgraph_out, SCOTCH_Num *vertlocnbr) +{ + SCOTCH_Num *permgsttab = NULL; /* Redistribution permutation array */ + SCOTCH_Num vertlocdlt = 0; /* Extra size of local vertex array */ + SCOTCH_Num edgelocdlt = 0; /* Extra size of local edge array */ + int err; + + err = SCOTCH_dgraphRedist(dgraph_in, partloctab, permgsttab, vertlocdlt, edgelocdlt, dgraph_out); + + // Call SCOTCH_dgraphSize to obtain the number of local vertices in the redistributed graph + SCOTCH_dgraphSize(dgraph_out, NULL, vertlocnbr, NULL, NULL); + + return err; + +} + + +/******************************************************************************** + * + * scotchm_dgraphdata + * + * Extract vertex labels (or stored IDs) for local vertices into `cell_list`. + * + * Parameters: + * ptr - pointer to a `SCOTCH_Dgraph` structure + * cell_list - output array to receive vertex labels for local vertices + * + * Returns: + * nothing + * + ********************************************************************************/ +void scotchm_dgraphdata(SCOTCH_Dgraph *dgraph_ptr, SCOTCH_Num *cell_list) +{ + + SCOTCH_Num vertlocnbr; + SCOTCH_Num *vlblloctab; /* vertex labels */ + + SCOTCH_dgraphData(dgraph_ptr, NULL, NULL, &vertlocnbr, NULL, NULL, + NULL, NULL, NULL, &vlblloctab, NULL, NULL, NULL, + NULL, NULL, NULL, NULL); + + // Copy vertex labels to output array + for (SCOTCH_Num i = 0; i < vertlocnbr; i++) { + cell_list[i] = vlblloctab[i]; + } + +} + + +/******************************************************************************** + * + * scotchm_dgraphexit + * + * Finalize/cleanup a `SCOTCH_Dgraph` object. + * + * Parameters: + * ptr - pointer to a `SCOTCH_Dgraph` structure + * + * Returns: + * nothing (wraps `SCOTCH_dgraphExit`). + * + ********************************************************************************/ +void scotchm_dgraphexit(SCOTCH_Dgraph *dgraph_ptr) +{ + SCOTCH_dgraphExit(dgraph_ptr); + free(dgraph_ptr); + +} + + +/******************************************************************************** + * + * scotchm_stratinit + * + * Initialize a SCOTCH strategy object and build a default strategy for + * distributed graph mapping. + * + * Parameters: + * strat_ptr - pointer to a `SCOTCH_Strat` structure + * + * Returns: + * integer (0 on success). + * + ********************************************************************************/ +int scotchm_stratinit(SCOTCH_Strat **strat_ptr) +{ + + *strat_ptr = (SCOTCH_Strat *) malloc (sizeof (SCOTCH_Strat)); + + SCOTCH_stratInit(*strat_ptr); + + // This was required to avoid crashes when scaling up to large core counts + SCOTCH_stratDgraphMapBuild(*strat_ptr, SCOTCH_STRATSCALABILITY, 1, 0, 0.05); + + return 0; + +} + + +/* ******************************************************************************** + * + * scotchm_stratexit + * + * Finalize/cleanup a `SCOTCH_Strat` strategy object. + * + * Parameters: + * strat_ptr - pointer to a `SCOTCH_Strat` structure + * + * Returns: + * nothing + * + ********************************************************************************/ +void scotchm_stratexit(SCOTCH_Strat *strat_ptr) +{ + SCOTCH_stratExit(strat_ptr); + free(strat_ptr); + +} +#endif From ac7ec8aa325730a12e87b5eb5143295a99008bd1 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Thu, 19 Feb 2026 16:28:33 -0700 Subject: [PATCH 134/214] Adding online graph partitioning routine to mpas_block_decomp.F This commit introduces a subroutine mpas_block_decomp_scotch in src/framework/mpas_block_decomp.F, which calls the routines introduced in the previous commit to invoke Scotch libraries. - The routine initializes and builds PT-SCOTCH distributed graphs from the adjacency data available in the partial_global_graph on each MPI task. - After checking the distributed graph for consistency, the SCOTCH graph mapping strategy is initialized, followed by the graph partitioning. Following a successful redistribution, the graph must be redistributed so that each MPI task is aware of all the vertices that it owns. - Finally, the routine writes out the generated graph partitioning data to disk so that it may be reused for the next model run. --- src/framework/Makefile | 2 +- src/framework/mpas_block_decomp.F | 216 ++++++++++++++++++++++++++++++ 2 files changed, 217 insertions(+), 1 deletion(-) diff --git a/src/framework/Makefile b/src/framework/Makefile index ebf6dabbb7..ce38c8e221 100644 --- a/src/framework/Makefile +++ b/src/framework/Makefile @@ -87,7 +87,7 @@ mpas_timekeeping.o: mpas_string_utils.o mpas_kind_types.o mpas_derived_types.o m mpas_timer.o: mpas_kind_types.o mpas_dmpar.o mpas_threading.o mpas_log.o -mpas_block_decomp.o: mpas_derived_types.o mpas_hash.o mpas_io_units.o mpas_dmpar.o +mpas_block_decomp.o: mpas_derived_types.o mpas_hash.o mpas_io_units.o mpas_dmpar.o mpas_ptscotch_interface.o mpas_block_creator.o: mpas_dmpar.o mpas_hash.o mpas_sort.o mpas_io_units.o mpas_block_decomp.o mpas_stream_manager.o mpas_decomp.o mpas_abort.o $(DEPS) diff --git a/src/framework/mpas_block_decomp.F b/src/framework/mpas_block_decomp.F index 4f3d197d5d..29513cfbaa 100644 --- a/src/framework/mpas_block_decomp.F +++ b/src/framework/mpas_block_decomp.F @@ -25,6 +25,9 @@ module mpas_block_decomp use mpas_derived_types use mpas_io_units use mpas_log +#ifdef MPAS_SCOTCH + use mpas_ptscotch_interface +#endif type graph integer :: nVerticesTotal @@ -287,6 +290,219 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l end subroutine mpas_block_decomp_cells_for_proc!}}} +!*********************************************************************** +! +! routine mpas_block_decomp_scotch +! +!> \brief Use PT-Scotch to generate the graph partitioning +!> \author Abishek Gopal +!> \date 12/05/25 +!> \details +!> This routine invokes the PT-Scotch library to first construct a distributed graph from the +!> partial global graph information read by each processor, then partitions the graph into the +!> specified number of blocks, and after redistributing the graph, it finally gathers all the +!> local block ids (for each MPI rank) to the IO_NODE to write out to a partition file with the +!> specified prefix. +! +!----------------------------------------------------------------------- +#ifdef MPAS_SCOTCH + subroutine mpas_block_decomp_scotch(dminfo, partial_global_graph_info, blockFilePrefix, blockFilename)!{{{ + +#ifdef MPAS_USE_MPI_F08 + use mpi_f08, only : MPI_Comm, MPI_INTEGER, MPI_Comm_dup, MPI_Comm_free, MPI_Gather, MPI_Gatherv +#else + use mpi +#endif + + implicit none + + type (dm_info), intent(inout) :: dminfo !< Input: domain information + type (graph), intent(in) :: partial_global_graph_info !< Input: Global graph information + character (len=*), intent(in) :: blockFilePrefix !< Input: File prefix for block decomposition + character (len=*), intent(out) :: blockFilename !< Output: Block decomposition file name + + integer, dimension(:), pointer :: global_start + ! integer, dimension(:), allocatable :: local_cell_list ! May be needed later to avoid reading partition file from disk + integer, dimension(:), allocatable :: local_block_list + + integer, dimension(:), allocatable ::global_block_id_arr, local_block_id_arr + integer :: i, ounit, ostatus, j, k + integer :: err, ierr + integer, dimension(:), pointer :: local_nvertices + integer :: num_local_vertices !< Number of local vertices for this processor + + integer :: nLocEdgesGraph = 0, nLocVerticesGraph = 0, edgelocsiz = 0, npart = 1 + character (len=StrKIND) :: partitionFilePrefix + integer, dimension(:), allocatable :: edgeloctab, vertloctab + type(scotchm_strat) :: stradat + type(scotchm_dgraph) :: scotchdgraph + type(scotchm_dgraph) :: scotchdgraph_redist + integer :: mpi_ierr +#ifdef MPAS_USE_MPI_F08 + type (MPI_Comm) :: localcomm +#else + integer :: localcomm +#endif + + ! Check that Scotch has not been built with 64-bit integers + ! Exit otherwise + call scotch_checkintsize() + + allocate(local_nvertices(dminfo % nprocs)) + allocate(global_start(dminfo % nprocs)) + allocate(global_block_id_arr(partial_global_graph_info % nVerticesTotal)) + allocate(local_block_id_arr(partial_global_graph_info % nVertices)) + + ! Count the number of edges (including to ghost cells) in the portion of graph + ! owned by the current rank. Each edge is counted twice, once for each vertex, + ! with the exception of edges to ghost vertices, which are counted only once. + do i=1,partial_global_graph_info % nVertices + do j=1,partial_global_graph_info % nAdjacent(i) + if (partial_global_graph_info % adjacencyList(j,i) == 0) cycle + nLocEdgesGraph = nLocEdgesGraph + 1 + ! call mpas_log_write('i=$i j=$i adj= $i', intArgs=(/i,j,partial_global_graph_info % adjacencyList(j,i)/) ) + end do + end do + + ! Holds the adjacency array for every local vertex + allocate(edgeloctab(nLocEdgesGraph)) + ! Array of start indices in edgeloctab for each local vertex + allocate(vertloctab(partial_global_graph_info % nVertices + 1)) + + ! Fill up edgeloctab and vertloctab + k = 1 + do i=1,partial_global_graph_info % nVertices + vertloctab(i) = k + do j=1,partial_global_graph_info % nAdjacent(i) + if (partial_global_graph_info % adjacencyList(j,i) == 0) cycle + edgeloctab(k) = partial_global_graph_info % adjacencyList(j,i) + k = k + 1 + end do + end do + vertloctab(partial_global_graph_info % nVertices+1) = nLocEdgesGraph + 1 + + ! Duplicate the communicator to be used by Scotch + call MPI_Comm_dup(dminfo % comm, localcomm, mpi_ierr) + if (mpi_ierr /= 0) then + call mpas_log_write('Cannot duplicate communicator', MPAS_LOG_CRIT) + endif + ! Initialize the Scotch graph data structure, and an extra one to hold the re-distributed graph +#ifdef MPAS_USE_MPI_F08 + call scotch_dgraphinit(scotchdgraph, localcomm% mpi_val) + call scotch_dgraphinit(scotchdgraph_redist, localcomm% mpi_val) +#else + call scotch_dgraphinit(scotchdgraph, localcomm) + call scotch_dgraphinit(scotchdgraph_redist, localcomm) +#endif + + ! From Scotch documentation: edgelocsiz is lower-bounded by the minimum size + ! of the edge array required to encompass all used adjacency values; it is + ! therefore at least equal to the maximum of the vendloctab entries, over all + ! local vertices, minus baseval; it can be set to edgelocnbr if the edge array is compact. + edgelocsiz = maxval(vertloctab) - 1 + + nLocVerticesGraph = partial_global_graph_info % nVertices + + ! Build the distributed Scotch graph and save it in scotchdgraph + ! Note: Optional arguments veloloctab, vlblloctab, edgegsttab, and edloloctab are not needed here. + call scotch_dgraphbuild (scotchdgraph, & + nLocVerticesGraph, & ! num of local vertices on the calling process + vertloctab, & ! Array of start indices in edgeloctab for each local vertex + nLocEdgesGraph, & ! Number of local edges, including to ghost vertices + edgelocsiz, & ! Defined previously + edgeloctab) ! Holds the adjacency array for every local vertex + + ! Only needed during development/debugging. + call scotch_dgraphcheck (scotchdgraph) + + ! Initialize the strategy data structure + call scotch_stratinit (stradat) + + ! Partition the distributed graph and save the result in local_block_id_arr + npart = dminfo % nProcs + call scotch_dgraphpart (scotchdgraph, npart, stradat, local_block_id_arr) + + ! After the paritioning above, each processor would not necessarily have information about all of the + ! vertices it owns. To obtain this information, Scotch provides a convenience function to redistribute the graph + ! to all processors, so that each processor has information about all of the vertices it owns. + call scotch_dgraphredist(scotchdgraph, & ! Input: original distributed graph + local_block_id_arr, & ! Input: the partition array + scotchdgraph_redist, & ! Output: re-distributed graph + num_local_vertices) ! Output: number of local vertices + + ! DO NOT REMOVE: This call is required if we want to read the local cell list directly after partitioning, + ! instead of reading it from the output partition file. + ! Extract the local cell list from the re-distributed graph. + ! allocate(local_cell_list(num_local_vertices)) + ! call scotch_dgraphdata(scotchdgraph_redist, local_cell_list) + ! do i=1,num_local_vertices + ! call mpas_log_write('local_cell_list($i): $i',MPAS_LOG_ERR, intArgs=(/i,local_cell_list(i)/)) + ! end do + + allocate(local_block_list(num_local_vertices)) + + local_block_list(:)=dminfo % my_proc_id + + ! Using the local_nvertices array to hold the original number of vertices in + ! the partial graph readb by each processor. Might need to use a different array + ! to clear up potential confusion. + local_nvertices(dminfo % my_proc_id + 1) = partial_global_graph_info % nVertices + + ! call mpas_log_write('local_nvertices($i): $i', MPAS_LOG_ERR, intArgs=(/i,num_local_vertices/)) + + ! Gather all the partial_global_graph_info % nVertices to IO_NODE. + ! num_local_vertices is the number of vertices that this processor owns, determined by the + ! Scotch paritioning. Whereas artial_global_graph_info % nVertices is the number of vertices + ! resident in the partial graph read by this processor. The latter is the correct size of the + ! local_block_id_arr. + call MPI_Gather( partial_global_graph_info % nVertices, 1, MPI_INTEGER, local_nvertices, & + 1, MPI_INTEGER, 0, localcomm, ierr) + + ! Compute the displacements for gathering all the local_block_id_arr to global_block_id_arr + global_start(1) = 0 + do i=2,dminfo % nprocs + global_start(i) = global_start(i-1) + local_nvertices(i-1) + end do + + ! Gather all the local block ids to global_block_id_arr so IO_NODE can write out the partitioning data + call MPI_Gatherv( local_block_id_arr, partial_global_graph_info % nVertices, MPI_INTEGER, global_block_id_arr, & + local_nvertices, global_start, MPI_INTEGER, 0, localcomm, ierr) + ! Write out the paritioning data to a file from IO_NODE + if (dminfo % my_proc_id == IO_NODE) then + partitionFilePrefix=trim(blockFilePrefix) + if (trim(partitionFilePrefix) == '') then + write(partitionFilePrefix,'(i0,a)') partial_global_graph_info%nVerticesTotal,'.graph.info.part.' + end if + write(blockFilename,'(a,i0)') trim(partitionFilePrefix), dminfo % nProcs + + call mpas_log_write('Writing out Scotch Graph partitioning data to '//trim(blockFilename)) + call mpas_new_unit(ounit) + open(unit=ounit, file=trim(blockFilename), form='formatted', status='new', action="write", iostat=ostatus) + do i=1,partial_global_graph_info % nVerticesTotal + write(unit=ounit, fmt='(i0)', iostat=err) global_block_id_arr(i) + end do + close(unit=ounit) + call mpas_release_unit(ounit) + end if + + ! Clean up + call scotch_dgraphexit (scotchdgraph) + call scotch_dgraphexit (scotchdgraph_redist) + call scotch_stratexit (stradat) + + deallocate(edgeloctab) + deallocate(vertloctab) + deallocate(local_block_list) + deallocate(local_nvertices) + deallocate(global_start) + deallocate(global_block_id_arr) + deallocate(local_block_id_arr) + + call MPI_Comm_free(localcomm, mpi_ierr) + + end subroutine mpas_block_decomp_scotch +#endif + !*********************************************************************** ! ! routine mpas_block_decomp_partitioned_edge_list From 3d09d7718d1ee1580edb9cc1845e1cb922c69a3f Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Thu, 19 Feb 2026 17:10:00 -0700 Subject: [PATCH 135/214] Enabling online graph partitioning via SCOTCH when partition file not found This commit modifies the existing logic in mpas_block_decomp_cells_for_proc routine inside src/framework/mpas_block_decomp.F to call the mpas_block_decomp_scotch routine, when all of the following are satisfied: - The MPAS core has been built with SCOTCH support - The routine is unable to find a relevant graph partition file on disk As described in the previous commit, the call to mpas_block_decomp_scotch begins the process of online graph partitioning, resulting in the generated partition file being written out to disk. Subsequently, the routine mpas_block_decomp_cells_for_proc attempts to read this newly-generated partition file, and if successful, proceeds with the rest of initialization. --- src/framework/mpas_block_decomp.F | 117 +++++++++++++++++++----------- 1 file changed, 75 insertions(+), 42 deletions(-) diff --git a/src/framework/mpas_block_decomp.F b/src/framework/mpas_block_decomp.F index 29513cfbaa..9065c99744 100644 --- a/src/framework/mpas_block_decomp.F +++ b/src/framework/mpas_block_decomp.F @@ -80,6 +80,7 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l character (len=StrKIND) :: filename logical :: no_blocks + logical :: useScotch no_blocks = .false. @@ -98,53 +99,85 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l allocate(local_nvertices(dminfo % nprocs)) allocate(global_start(dminfo % nprocs)) allocate(global_list(partial_global_graph_info % nVerticesTotal)) + + if (dminfo % my_proc_id == IO_NODE) then + + if (dminfo % total_blocks < 10) then + write(filename,'(a,i1)') trim(blockFilePrefix), dminfo % total_blocks + else if (dminfo % total_blocks < 100) then + write(filename,'(a,i2)') trim(blockFilePrefix), dminfo % total_blocks + else if (dminfo % total_blocks < 1000) then + write(filename,'(a,i3)') trim(blockFilePrefix), dminfo % total_blocks + else if (dminfo % total_blocks < 10000) then + write(filename,'(a,i4)') trim(blockFilePrefix), dminfo % total_blocks + else if (dminfo % total_blocks < 100000) then + write(filename,'(a,i5)') trim(blockFilePrefix), dminfo % total_blocks + else if (dminfo % total_blocks < 1000000) then + write(filename,'(a,i6)') trim(blockFilePrefix), dminfo % total_blocks + else if (dminfo % total_blocks < 10000000) then + write(filename,'(a,i7)') trim(blockFilePrefix), dminfo % total_blocks + else if (dminfo % total_blocks < 100000000) then + write(filename,'(a,i8)') trim(blockFilePrefix), dminfo % total_blocks + end if - if (dminfo % my_proc_id == IO_NODE) then + call mpas_new_unit(iunit) + open(unit=iunit, file=trim(filename), form='formatted', status='old', iostat=istatus) + + if (istatus /= 0) then +#ifdef MPAS_SCOTCH + useScotch = .true. +#else + call mpas_log_write('Could not open block decomposition file for $i blocks.', MPAS_LOG_ERR, intArgs=(/dminfo % total_blocks/) ) + call mpas_log_write('Filename: '//trim(filename), MPAS_LOG_CRIT) +#endif + else + useScotch = .false. + end if + end if - if (dminfo % total_blocks < 10) then - write(filename,'(a,i1)') trim(blockFilePrefix), dminfo % total_blocks - else if (dminfo % total_blocks < 100) then - write(filename,'(a,i2)') trim(blockFilePrefix), dminfo % total_blocks - else if (dminfo % total_blocks < 1000) then - write(filename,'(a,i3)') trim(blockFilePrefix), dminfo % total_blocks - else if (dminfo % total_blocks < 10000) then - write(filename,'(a,i4)') trim(blockFilePrefix), dminfo % total_blocks - else if (dminfo % total_blocks < 100000) then - write(filename,'(a,i5)') trim(blockFilePrefix), dminfo % total_blocks - else if (dminfo % total_blocks < 1000000) then - write(filename,'(a,i6)') trim(blockFilePrefix), dminfo % total_blocks - else if (dminfo % total_blocks < 10000000) then - write(filename,'(a,i7)') trim(blockFilePrefix), dminfo % total_blocks - else if (dminfo % total_blocks < 100000000) then - write(filename,'(a,i8)') trim(blockFilePrefix), dminfo % total_blocks - end if - - call mpas_new_unit(iunit) - open(unit=iunit, file=trim(filename), form='formatted', status='old', iostat=istatus) - - if (istatus /= 0) then - call mpas_log_write('Could not open block decomposition file for $i blocks.', MPAS_LOG_ERR, intArgs=(/dminfo % total_blocks/) ) - call mpas_log_write('Filename: '//trim(filename), MPAS_LOG_CRIT) - end if - - local_nvertices(:) = 0 - do i=1,partial_global_graph_info % nVerticesTotal - read(unit=iunit, fmt=*, iostat=err) global_block_id +#ifdef MPAS_SCOTCH + call mpas_dmpar_bcast_logical(dminfo, useScotch) - if ( err .ne. 0 ) then - call mpas_log_write('Decomoposition file: ' // trim(filename) // ' contains less than $i cells', & - MPAS_LOG_CRIT, intArgs=(/partial_global_graph_info % nVerticesTotal/) ) - end if - call mpas_get_owning_proc(dminfo, global_block_id, owning_proc) - local_nvertices(owning_proc+1) = local_nvertices(owning_proc+1) + 1 - end do + if (useScotch) then ! Using PT-Scotch across all MPI ranks - read(unit=iunit, fmt=*, iostat=err) + ! Pre-emptively blocking this untested code path. + if (numBlocks /= 0) then + call mpas_log_write('Scotch partitioning not available when config_number_of_blocks != 0 ', MPAS_LOG_CRIT) + end if + + call mpas_log_write('No existing block decomposition file found, invoking Scotch.') + call mpas_block_decomp_scotch(dminfo, partial_global_graph_info, blockFilePrefix, filename) + + if (dminfo % my_proc_id == IO_NODE) then + open(unit=iunit, file=trim(filename), form='formatted', status='old', iostat=istatus) + if (istatus /= 0) then + call mpas_log_write('Could not open block decomposition file for $i blocks.', MPAS_LOG_ERR, intArgs=(/dminfo % total_blocks/) ) + call mpas_log_write('Filename: '//trim(filename), MPAS_LOG_CRIT) + end if + end if + end if +#endif + + if (dminfo % my_proc_id == IO_NODE) then + + local_nvertices(:) = 0 + do i=1,partial_global_graph_info % nVerticesTotal + read(unit=iunit, fmt=*, iostat=err) global_block_id - if ( err == 0 ) then - call mpas_log_write('Decomposition file: ' // trim(filename) // ' contains more than $i cells', & - MPAS_LOG_CRIT, intArgs=(/partial_global_graph_info % nVerticesTotal/) ) - end if + if ( err .ne. 0 ) then + call mpas_log_write('Decomoposition file: ' // trim(filename) // ' contains less than $i cells', & + MPAS_LOG_CRIT, intArgs=(/partial_global_graph_info % nVerticesTotal/) ) + end if + call mpas_get_owning_proc(dminfo, global_block_id, owning_proc) + local_nvertices(owning_proc+1) = local_nvertices(owning_proc+1) + 1 + end do + + read(unit=iunit, fmt=*, iostat=err) + + if ( err == 0 ) then + call mpas_log_write('Decomposition file: ' // trim(filename) // ' contains more than $i cells', & + MPAS_LOG_CRIT, intArgs=(/partial_global_graph_info % nVerticesTotal/) ) + end if global_start(1) = 1 do i=2,dminfo % nprocs From 8c8f81e717aae7d538f70a5b3ff4dd0f9f989920 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Thu, 19 Feb 2026 17:34:57 -0700 Subject: [PATCH 136/214] Adding new timers to mpas_block_decomp.F This commit introduces new timers to the mpas_block_decomp_cells_for_proc and the mpas_block_decomp_scotch routines in src/framework/mpas_block_decomp.F. These timers may be useful in tracking the time spent in online graph partitioning or in reading the graph partition files from disk and in collective MPI calls. --- src/framework/Makefile | 2 +- src/framework/mpas_block_decomp.F | 14 ++++++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/src/framework/Makefile b/src/framework/Makefile index ce38c8e221..0e5f792b5e 100644 --- a/src/framework/Makefile +++ b/src/framework/Makefile @@ -87,7 +87,7 @@ mpas_timekeeping.o: mpas_string_utils.o mpas_kind_types.o mpas_derived_types.o m mpas_timer.o: mpas_kind_types.o mpas_dmpar.o mpas_threading.o mpas_log.o -mpas_block_decomp.o: mpas_derived_types.o mpas_hash.o mpas_io_units.o mpas_dmpar.o mpas_ptscotch_interface.o +mpas_block_decomp.o: mpas_derived_types.o mpas_hash.o mpas_io_units.o mpas_dmpar.o mpas_timer.o mpas_ptscotch_interface.o mpas_block_creator.o: mpas_dmpar.o mpas_hash.o mpas_sort.o mpas_io_units.o mpas_block_decomp.o mpas_stream_manager.o mpas_decomp.o mpas_abort.o $(DEPS) diff --git a/src/framework/mpas_block_decomp.F b/src/framework/mpas_block_decomp.F index 9065c99744..dc3d9e4e13 100644 --- a/src/framework/mpas_block_decomp.F +++ b/src/framework/mpas_block_decomp.F @@ -54,6 +54,8 @@ module mpas_block_decomp subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, local_cell_list, block_id, block_start, & block_count, numBlocks, explicitProcDecomp, blockFilePrefix, procFilePrefix)!{{{ + use mpas_timer, only : mpas_timer_start, mpas_timer_stop + implicit none type (dm_info), intent(inout) :: dminfo !< Input: domain information @@ -84,6 +86,8 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l no_blocks = .false. + call mpas_timer_start('mpas_block_decomp_cells_for_proc') + if (numBlocks == 0) then dminfo % total_blocks = dminfo % nProcs else @@ -321,6 +325,8 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l end if end if + call mpas_timer_stop('mpas_block_decomp_cells_for_proc') + end subroutine mpas_block_decomp_cells_for_proc!}}} !*********************************************************************** @@ -341,6 +347,7 @@ end subroutine mpas_block_decomp_cells_for_proc!}}} #ifdef MPAS_SCOTCH subroutine mpas_block_decomp_scotch(dminfo, partial_global_graph_info, blockFilePrefix, blockFilename)!{{{ + use mpas_timer, only : mpas_timer_start, mpas_timer_stop #ifdef MPAS_USE_MPI_F08 use mpi_f08, only : MPI_Comm, MPI_INTEGER, MPI_Comm_dup, MPI_Comm_free, MPI_Gather, MPI_Gatherv #else @@ -386,6 +393,8 @@ subroutine mpas_block_decomp_scotch(dminfo, partial_global_graph_info, blockFile allocate(global_block_id_arr(partial_global_graph_info % nVerticesTotal)) allocate(local_block_id_arr(partial_global_graph_info % nVertices)) + call mpas_timer_start('scotch_total') + ! Count the number of edges (including to ghost cells) in the portion of graph ! owned by the current rank. Each edge is counted twice, once for each vertex, ! with the exception of edges to ghost vertices, which are counted only once. @@ -451,10 +460,13 @@ subroutine mpas_block_decomp_scotch(dminfo, partial_global_graph_info, blockFile ! Initialize the strategy data structure call scotch_stratinit (stradat) + call mpas_timer_start('scotch_graph_partitioning') ! Partition the distributed graph and save the result in local_block_id_arr npart = dminfo % nProcs call scotch_dgraphpart (scotchdgraph, npart, stradat, local_block_id_arr) + call mpas_timer_stop('scotch_graph_partitioning') + ! After the paritioning above, each processor would not necessarily have information about all of the ! vertices it owns. To obtain this information, Scotch provides a convenience function to redistribute the graph ! to all processors, so that each processor has information about all of the vertices it owns. @@ -533,6 +545,8 @@ subroutine mpas_block_decomp_scotch(dminfo, partial_global_graph_info, blockFile call MPI_Comm_free(localcomm, mpi_ierr) + call mpas_timer_stop('scotch_total') + end subroutine mpas_block_decomp_scotch #endif From 44e0d396c63585382436c6381c1aaa64b4e79aa2 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 19:15:30 -0700 Subject: [PATCH 137/214] Remove unused variables from new LES code This commit removes unused variables from the new LES code -- both the test case initialization routine (init_atm_case_les) as well as the new mpas_atm_dissipation_models.F file. --- .../dynamics/mpas_atm_dissipation_models.F | 5 ++--- src/core_init_atmosphere/mpas_init_atm_cases.F | 18 +++++++----------- 2 files changed, 9 insertions(+), 14 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 1b35cedd3a..5328f0e4a0 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -150,7 +150,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e real (kind=RKIND) :: rdz, def2, pr_inv, wk real (kind=RKIND) :: shear_production, buoyancy, dissipation, delta_z, delta_s, bv, tke_length, diss_length real (kind=RKIND) :: l_horizontal, l_vertical, c_dissipation - real (kind=RKIND) :: prandtl_horizontal_inv, prandtl_vertical_inv + real (kind=RKIND) :: prandtl_horizontal_inv real (kind=RKIND) :: eddy_visc_h, eddy_visc_v logical, parameter :: test_tke=.true. @@ -978,9 +978,8 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux, prandtl_1d_inverse real (kind=RKIND), dimension(num_scalars,nVertLevels+1) :: turb_vflux_scalars real (kind=RKIND) :: rho_k_at_w, zz_at_w - real (kind=RKIND) :: delta_z, delta_s, tke_length, bv_frequency2 - real (kind=RKIND) :: moisture_flux, heat_flux, theta_m_flux, c_h, c_q + real (kind=RKIND) :: moisture_flux, heat_flux, theta_m_flux real (kind=RKIND) :: qv_cell, theta_m_cell, theta_cell if(debug_dissipation) then diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 9f936dcf93..9c372cb163 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -6261,36 +6261,32 @@ subroutine init_atm_case_les(dminfo, mesh, fg, nCells, nVertLevels, state, diag, integer, dimension(:), pointer :: landmask, lu_index !This is temporary variable here. It just need when calculate tangential velocity v. - integer :: eoe, j + integer :: eoe integer, dimension(:), pointer :: nEdgesOnEdge integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge real (kind=RKIND), pointer :: x_period, y_period - integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, cell1, cell2 + integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, nz1, itr, cell1, cell2 integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve integer, pointer :: index_qv integer, pointer :: index_tke - real (kind=RKIND), dimension(nVertLevels + 1 ) :: znu, znw, znwc, znwv - real (kind=RKIND), dimension(nVertLevels + 1 ) :: znuc, znuv - real (kind=RKIND), dimension(nVertLevels + 1 ) :: zc, zw, ah real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm - real (kind=RKIND), dimension(nVertLevels, nCells) :: relhum, thi, tbi, cqwb + real (kind=RKIND), dimension(nVertLevels, nCells) :: thi, tbi, cqwb - real (kind=RKIND) :: r, xnutr + real (kind=RKIND) :: xnutr real (kind=RKIND) :: ztemp, zd, zt, dz, str real (kind=RKIND), dimension(nVertLevels ) :: qvb, qvp, zg real (kind=RKIND), dimension(nVertLevels ) :: t_init_1d - real (kind=RKIND) :: d1, d2, d3, cof1, cof2 + real (kind=RKIND) :: cof1, cof2 real (kind=RKIND), pointer :: cf1, cf2, cf3 - real (kind=RKIND) :: ztr, thetar, ttr, thetas, um, us, zts, pitop, pibtop, ptopb, ptop, rcp, rcv, p0 - real (kind=RKIND) :: radx, radz, zcent, xmid, delt, xloc, rad, yloc, ymid, a_scale - real (kind=RKIND) :: pres, temp, es, qvs + real (kind=RKIND) :: pitop, pibtop, ptopb, ptop, rcp, rcv, p0 + real (kind=RKIND) :: a_scale real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge From 197296f61ee44f816c99e5ce554094b7b4b97374 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 5 Dec 2025 12:13:38 -0700 Subject: [PATCH 138/214] Clean up trailing whitespace and indentation in mpas_atm_dissipation_models.F --- .../dynamics/mpas_atm_dissipation_models.F | 1452 +++++++++-------- 1 file changed, 730 insertions(+), 722 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 5328f0e4a0..70cf9c24b3 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -8,37 +8,38 @@ module mpas_atm_dissipation_models - use mpas_kind_types, only : RKIND - use mpas_atmphys_constants - use mpas_constants - use mpas_log - use mpas_derived_types, only : MPAS_LOG_CRIT - - logical, parameter :: debug_dissipation = .false. - logical, parameter :: les_test = .true., les_sas_test = .false. - !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour - ! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 - ! real (kind=RKIND), parameter :: tke_heat_flux = 0.0 - !! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 ! ocean roughness length - ! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.006 - ! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0 - real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 - ! real (kind=RKIND), parameter :: c_k = 0.1 - real (kind=RKIND), parameter :: c_k = 0.25 - - - contains - - subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, & - deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & - invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & - cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & - nCells, nEdges ) + use mpas_kind_types, only : RKIND + use mpas_atmphys_constants + use mpas_constants + use mpas_log + use mpas_derived_types, only : MPAS_LOG_CRIT + + logical, parameter :: debug_dissipation = .false. + logical, parameter :: les_test = .true., les_sas_test = .false. + !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour + ! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 + ! real (kind=RKIND), parameter :: tke_heat_flux = 0.0 + !! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 ! ocean roughness length + ! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.006 + ! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0 + real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 + ! real (kind=RKIND), parameter :: c_k = 0.1 + real (kind=RKIND), parameter :: c_k = 0.25 + + +contains + + + subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & + nCells, nEdges ) use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here implicit none - + integer, intent(in) :: cellStart, cellEnd, nCells, nEdges real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: v @@ -57,59 +58,60 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, integer :: iCell, iEdge, k real (kind=RKIND), dimension(nVertLevels) :: d_11, d_22, d_12, dudx, dudy, dvdx, dvdy - if(debug_dissipation) call mpas_log_write(' begin smagorinsky_2d ') + if(debug_dissipation) call mpas_log_write(' begin smagorinsky_2d ') - do iCell = cellStart,cellEnd - dudx(1:nVertLevels) = 0.0 - dudy(1:nVertLevels) = 0.0 - dvdx(1:nVertLevels) = 0.0 - dvdy(1:nVertLevels) = 0.0 - do iEdge=1,nEdgesOnCell(iCell) - do k=1,nVertLevels - dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - - deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - - deformation_coef_s2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - + deformation_coef_c2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - + deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - end do - end do -!DIR$ IVDEP - do k=1, nVertLevels - ! here is the Smagorinsky formulation, - ! followed by imposition of an upper bound on the eddy viscosity - d_11(k) = 2*dudx(k) - d_22(k) = 2*dvdy(k) - d_12(k) = dudy(k) + dvdx(k) - kdiff(k,iCell) = (c_s * config_len_disp)**2 * sqrt(0.25*(d_11(k)-d_22(k))**2 + d_12(k)**2) - kdiff(k,iCell) = min(kdiff(k,iCell),(0.01*config_len_disp**2) * invDt) - end do + do iCell = cellStart,cellEnd + dudx(1:nVertLevels) = 0.0 + dudy(1:nVertLevels) = 0.0 + dvdx(1:nVertLevels) = 0.0 + dvdy(1:nVertLevels) = 0.0 + do iEdge=1,nEdgesOnCell(iCell) + do k=1,nVertLevels + dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + - deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + - deformation_coef_s2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + + deformation_coef_c2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + + deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) end do + end do + +!DIR$ IVDEP + do k=1, nVertLevels + ! here is the Smagorinsky formulation, + ! followed by imposition of an upper bound on the eddy viscosity + d_11(k) = 2*dudx(k) + d_22(k) = 2*dvdy(k) + d_12(k) = dudy(k) + dvdx(k) + kdiff(k,iCell) = (c_s * config_len_disp)**2 * sqrt(0.25*(d_11(k)-d_22(k))**2 + d_12(k)**2) + kdiff(k,iCell) = min(kdiff(k,iCell),(0.01*config_len_disp**2) * invDt) + end do + end do - h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 - h_theta_eddy_visc4 = h_mom_eddy_visc4 + h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 + h_theta_eddy_visc4 = h_mom_eddy_visc4 - if(debug_dissipation) call mpas_log_write(' exiting smagorinsky_2d ') + if(debug_dissipation) call mpas_log_write(' exiting smagorinsky_2d ') - end subroutine smagorinsky_2d + end subroutine smagorinsky_2d !--------------------------------------- - subroutine les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & - u, v, uCell, vCell, & - w, c_s, bv_freq2, zgrid, config_len_disp, & - deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & - deformation_coef_c, deformation_coef_s, prandtl_3d_inv, & - invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & - scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & - cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & - nCells, nEdges, nVertLevels, maxEdges, num_scalars ) + subroutine les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & + u, v, uCell, vCell, & + w, c_s, bv_freq2, zgrid, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + deformation_coef_c, deformation_coef_s, prandtl_3d_inv, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & + nCells, nEdges, nVertLevels, maxEdges, num_scalars ) implicit none - + character (len=StrKIND), intent(in) :: config_les_model character (len=StrKIND), intent(in) :: config_les_surface @@ -143,7 +145,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e ! local variables integer :: iCell, iEdge, k, ie, cell1, cell2 - real (kind=RKIND), dimension(nVertLevels) :: d_11, d_22, d_33, d_12, d_13, d_23 + real (kind=RKIND), dimension(nVertLevels) :: d_11, d_22, d_33, d_12, d_13, d_23 real (kind=RKIND), dimension(nVertLevels) :: dudx, dudy, dvdx, dvdy real (kind=RKIND), dimension(nVertLevels+1) :: dwdx, dwdy real (kind=RKIND), dimension(nVertLevels) :: dudz, dvdz, dwdz @@ -169,167 +171,167 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e do iCell = cellStart,cellEnd - dudx(1:nVertLevels) = 0.0 - dudy(1:nVertLevels) = 0.0 - dvdx(1:nVertLevels) = 0.0 - dvdy(1:nVertLevels) = 0.0 - dwdx(1:nVertLevels+1) = 0.0 - dwdy(1:nVertLevels+1) = 0.0 - - dudz(1:nVertLevels) = 0.0 - dvdz(1:nVertLevels) = 0.0 - dwdz(1:nVertLevels) = 0.0 - - do iEdge=1,nEdgesOnCell(iCell) - - ie = EdgesOnCell(iEdge,iCell) - cell1 = cellsOnEdge(1,ie) - cell2 = cellsOnEdge(2,ie) - - do k=1,nVertLevels - dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,ie) & - - deformation_coef_cs(iEdge,iCell)*v(k,ie) - dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,ie) & - - deformation_coef_s2(iEdge,iCell)*v(k,ie) - dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,ie) & - + deformation_coef_c2(iEdge,iCell)*v(k,ie) - dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,ie) & - + deformation_coef_cs(iEdge,iCell)*v(k,ie) - end do - - do k=1,nVertLevels+1 - wk = 0.5*(w(k,cell1)+w(k,cell2)) - dwdx(k) = dwdx(k) + deformation_coef_c(iEdge,iCell)*wk - dwdy(k) = dwdy(k) + deformation_coef_s(iEdge,iCell)*wk - end do - - end do - - do k=1,nVertLevels - rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) - dwdz(k) = (w(k+1,iCell)-w(k,iCell))*rdz - end do - - do k=2,nVertLevels-1 - rdz = 1./(zgrid(k+2,iCell)+zgrid(k+1,iCell)-zgrid(k,iCell)-zgrid(k-1,iCell)) - dudz(k) = (uCell(k+1,iCell)-uCell(k-1,iCell))*rdz - dvdz(k) = (vCell(k+1,iCell)-vCell(k-1,iCell))*rdz - end do - - k = 1 - rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) - dudz(k) = (uCell(k+1,iCell)-uCell(k,iCell))*rdz - dvdz(k) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz - - k = nVertLevels-1 - rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) - dudz(k+1) = (uCell(k+1,iCell)-uCell(k,iCell))*rdz - dvdz(k+1) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz - - do k=1, nVertLevels - d_11(k) = 2.*dudx(k) - d_22(k) = 2.*dvdy(k) - d_33(k) = 2.*dwdz(k) - d_12(k) = dudy(k) + dvdx(k) - d_13(k) = dwdx(k) + dudz(k) - d_23(k) = dwdy(k) + dvdz(k) - end do - - if (config_les_model == "3d_smagorinsky") then - - do k=1, nVertLevels - def2 = 0.5*(d_11(k)**2 + d_22(k)**2 + d_33(k)**2) + d_12(k)**2 + d_13(k)**2 + d_23(k)**2 - eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) - eddy_visc_horz(k,iCell) = min(eddy_visc_horz(k,iCell),(0.01*config_len_disp**2) * invDt) - delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) - eddy_visc_vert(k,iCell) = (c_s * delta_z)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) - ! eddy_visc_vert(k,iCell) = eddy_visc_horz(k,iCell) - end do - - else if (config_les_model == "prognostic_1.5_order") then - - do k=1,nVertLevels ! bound the tke here, currently hardwired - ! scalars(index_tke,k,iCell) = max(0.,min(100.,scalars(index_tke,k,iCell))) - scalars(index_tke,k,iCell) = max(0.,scalars(index_tke,k,iCell)) - end do - - do k=1,nVertLevels - - delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) - delta_s = ((config_len_disp**2)*delta_z)**(1./3.) - bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon_bv ) - tke_length = delta_s - ! isentropic mixing formulation - if(bv_freq2(k,iCell) .gt. 1.e-06) & - tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv - tke_length = min(tke_length, delta_z) - diss_length = min(delta_s,max(tke_length,0.01*delta_s)) - if(bv_freq2(k,iCell) <= 0) diss_length = delta_s - - ! non-isotropic mixing - - l_horizontal = config_len_disp - l_vertical = min(delta_z,tke_length) - if(bv_freq2(k,iCell) <= 0) diss_length = delta_z - - ! isotropic mixing + dudx(1:nVertLevels) = 0.0 + dudy(1:nVertLevels) = 0.0 + dvdx(1:nVertLevels) = 0.0 + dvdy(1:nVertLevels) = 0.0 + dwdx(1:nVertLevels+1) = 0.0 + dwdy(1:nVertLevels+1) = 0.0 + + dudz(1:nVertLevels) = 0.0 + dvdz(1:nVertLevels) = 0.0 + dwdz(1:nVertLevels) = 0.0 + + do iEdge=1,nEdgesOnCell(iCell) + + ie = EdgesOnCell(iEdge,iCell) + cell1 = cellsOnEdge(1,ie) + cell2 = cellsOnEdge(2,ie) + + do k=1,nVertLevels + dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,ie) & + - deformation_coef_cs(iEdge,iCell)*v(k,ie) + dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,ie) & + - deformation_coef_s2(iEdge,iCell)*v(k,ie) + dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,ie) & + + deformation_coef_c2(iEdge,iCell)*v(k,ie) + dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,ie) & + + deformation_coef_cs(iEdge,iCell)*v(k,ie) + end do + + do k=1,nVertLevels+1 + wk = 0.5*(w(k,cell1)+w(k,cell2)) + dwdx(k) = dwdx(k) + deformation_coef_c(iEdge,iCell)*wk + dwdy(k) = dwdy(k) + deformation_coef_s(iEdge,iCell)*wk + end do + + end do + + do k=1,nVertLevels + rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) + dwdz(k) = (w(k+1,iCell)-w(k,iCell))*rdz + end do + + do k=2,nVertLevels-1 + rdz = 1./(zgrid(k+2,iCell)+zgrid(k+1,iCell)-zgrid(k,iCell)-zgrid(k-1,iCell)) + dudz(k) = (uCell(k+1,iCell)-uCell(k-1,iCell))*rdz + dvdz(k) = (vCell(k+1,iCell)-vCell(k-1,iCell))*rdz + end do + + k = 1 + rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) + dudz(k) = (uCell(k+1,iCell)-uCell(k,iCell))*rdz + dvdz(k) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz + + k = nVertLevels-1 + rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) + dudz(k+1) = (uCell(k+1,iCell)-uCell(k,iCell))*rdz + dvdz(k+1) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz + + do k=1, nVertLevels + d_11(k) = 2.*dudx(k) + d_22(k) = 2.*dvdy(k) + d_33(k) = 2.*dwdz(k) + d_12(k) = dudy(k) + dvdx(k) + d_13(k) = dwdx(k) + dudz(k) + d_23(k) = dwdy(k) + dvdz(k) + end do + + if (config_les_model == "3d_smagorinsky") then + + do k=1, nVertLevels + def2 = 0.5*(d_11(k)**2 + d_22(k)**2 + d_33(k)**2) + d_12(k)**2 + d_13(k)**2 + d_23(k)**2 + eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) + eddy_visc_horz(k,iCell) = min(eddy_visc_horz(k,iCell),(0.01*config_len_disp**2) * invDt) + delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) + eddy_visc_vert(k,iCell) = (c_s * delta_z)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) + ! eddy_visc_vert(k,iCell) = eddy_visc_horz(k,iCell) + end do + + else if (config_les_model == "prognostic_1.5_order") then + + do k=1,nVertLevels ! bound the tke here, currently hardwired + ! scalars(index_tke,k,iCell) = max(0.,min(100.,scalars(index_tke,k,iCell))) + scalars(index_tke,k,iCell) = max(0.,scalars(index_tke,k,iCell)) + end do + + do k=1,nVertLevels + + delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) + delta_s = ((config_len_disp**2)*delta_z)**(1./3.) + bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon_bv ) + tke_length = delta_s + ! isentropic mixing formulation + if(bv_freq2(k,iCell) .gt. 1.e-06) & + tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv + tke_length = min(tke_length, delta_z) + diss_length = min(delta_s,max(tke_length,0.01*delta_s)) + if(bv_freq2(k,iCell) <= 0) diss_length = delta_s + + ! non-isotropic mixing + + l_horizontal = config_len_disp + l_vertical = min(delta_z,tke_length) + if(bv_freq2(k,iCell) <= 0) diss_length = delta_z + + ! isotropic mixing - ! l_horizontal = min(delta_s,tke_length) - ! if(bv_freq2(k,iCell) <= 0) diss_length = delta_s - ! l_vertical = l_horizontal + ! l_horizontal = min(delta_s,tke_length) + ! if(bv_freq2(k,iCell) <= 0) diss_length = delta_s + ! l_vertical = l_horizontal - ! eddy viscocities set here if we are running the 1.5 order prognostic tke scheme - eddy_visc_h = c_k*l_horizontal*sqrt(scalars(index_tke,k,iCell)) - eddy_visc_h = min(eddy_visc_h,(0.01*config_len_disp**2) * invDt) - eddy_visc_v = c_k*l_vertical*sqrt(scalars(index_tke,k,iCell)) - eddy_visc_v = min(eddy_visc_v,(0.01*delta_z**2) * invDt) + ! eddy viscocities set here if we are running the 1.5 order prognostic tke scheme + eddy_visc_h = c_k*l_horizontal*sqrt(scalars(index_tke,k,iCell)) + eddy_visc_h = min(eddy_visc_h,(0.01*config_len_disp**2) * invDt) + eddy_visc_v = c_k*l_vertical*sqrt(scalars(index_tke,k,iCell)) + eddy_visc_v = min(eddy_visc_v,(0.01*delta_z**2) * invDt) - eddy_visc_horz(k,iCell) = eddy_visc_h - eddy_visc_vert(k,iCell) = eddy_visc_v + eddy_visc_horz(k,iCell) = eddy_visc_h + eddy_visc_vert(k,iCell) = eddy_visc_v - ! terms for the prognostic tke integration + ! terms for the prognostic tke integration - shear_production = eddy_visc_h*(d_11(k)**2 + d_22(k)**2 + d_12(k)**2) & - +eddy_visc_v*(d_33(k)**2 + d_13(k)**2 + d_23(k)**2) + shear_production = eddy_visc_h*(d_11(k)**2 + d_22(k)**2 + d_12(k)**2) & + +eddy_visc_v*(d_33(k)**2 + d_13(k)**2 + d_23(k)**2) - buoyancy = -eddy_visc_v*bv_freq2(k,iCell) + buoyancy = -eddy_visc_v*bv_freq2(k,iCell) - ! dissipation + ! dissipation - c_dissipation = 1.9*c_k + max( 0.0, 0.93 - 1.9*c_k )*diss_length/delta_s - ! if( (k.eq. 1) .or. (k.eq.nVertLevels) ) c_dissipation = 3.9 + c_dissipation = 1.9*c_k + max( 0.0, 0.93 - 1.9*c_k )*diss_length/delta_s + ! if( (k.eq. 1) .or. (k.eq.nVertLevels) ) c_dissipation = 3.9 - dissipation = -c_dissipation*(scalars(index_tke,k,iCell)**(1.5))/diss_length + dissipation = -c_dissipation*(scalars(index_tke,k,iCell)**(1.5))/diss_length - ! computing eddy viscosities ********* + ! computing eddy viscosities ********* - prandtl_horizontal_inv = 3. - prandtl_3d_inv(k,iCell) = 1.0+(2.0*l_vertical/delta_z) - + prandtl_horizontal_inv = 3. + prandtl_3d_inv(k,iCell) = 1.0+(2.0*l_vertical/delta_z) - ! RHS term for the subgrid ke. - if(dynamics_substep == 1) & - tend_scalars(index_tke,k,iCell) = rho_zz(k,iCell)*( shear_production + buoyancy + dissipation ) + ! RHS term for the subgrid ke. - end do + if(dynamics_substep == 1) & + tend_scalars(index_tke,k,iCell) = rho_zz(k,iCell)*( shear_production + buoyancy + dissipation ) - else + end do + + else - call mpas_log_write(' in les_models, no les scheme for '//trim(config_les_model), messageType=MPAS_LOG_CRIT) - - end if ! end of config_les_model test + call mpas_log_write(' in les_models, no les scheme for '//trim(config_les_model), messageType=MPAS_LOG_CRIT) + + end if ! end of config_les_model test end do ! loop over all owned cells (columns) if(debug_dissipation) call mpas_log_write(' les_models ') - end subroutine les_models + end subroutine les_models !--------------------------------------- - subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & - cellStart, cellEnd, nCells) + subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & + cellStart, cellEnd, nCells) use mpas_atm_dimensions ! pull nVertLevels and num_scalars from here @@ -346,87 +348,88 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(nVertLevels) :: theta, qvsw, temp, coefa logical :: dry_bv_frequency - if(debug_dissipation) call mpas_log_write(' begin BV frequency calculations ') + if(debug_dissipation) call mpas_log_write(' begin BV frequency calculations ') - do iCell = cellStart,cellEnd + do iCell = cellStart,cellEnd !DIR$ IVDEP - do k=1, nVertLevels + do k=1, nVertLevels - theta(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) + theta(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) - temp(k) = exner(k,iCell) * theta(k) + temp(k) = exner(k,iCell) * theta(k) - p = pressure_b(k,iCell) + pp(k,iCell) - esw = 1000. * svp1 * exp(svp2 * (temp(k) - svpt0) / (temp(k) - svp3)) - if (p < esw) esw = p * 0.99 ! fix for pressure < esw - qvsw(k) = ep_2 * esw / (p - esw) + p = pressure_b(k,iCell) + pp(k,iCell) + esw = 1000. * svp1 * exp(svp2 * (temp(k) - svpt0) / (temp(k) - svp3)) + if (p < esw) esw = p * 0.99 ! fix for pressure < esw + qvsw(k) = ep_2 * esw / (p - esw) - coefa(k) = ( 1.0 + xlv * qvsw(k)/ R_d / temp(k) ) / & - ( 1.0 + xlv * xlv *qvsw(k) / Cp / R_v / temp(k) / temp(k) ) + coefa(k) = ( 1.0 + xlv * qvsw(k)/ R_d / temp(k) ) / & + ( 1.0 + xlv * xlv *qvsw(k) / Cp / R_v / temp(k) / temp(k) ) - end do + end do - do k=2, nVertLevels-1 - dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) - rdz = 1.0/dz - - ! if ( scalars(index_qc,k,iCell) < qc_cr ) then - ! ! Dry Brunt-Vaisala frequency - ! bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & - ! + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) / dz & - ! - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) - ! else - ! ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 - ! bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & - ! + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) / dz ) & - ! - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) - ! endif - - dry_bv_frequency = .true. - if(index_qc .gt. 0) then ! if moist simulation, qc exists - if ( scalars(index_qc,k,iCell) .ge. qc_cr ) dry_bv_frequency = .false. - end if - - if (dry_bv_frequency) then - ! Dry Brunt-Vaisala frequency - bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) * rdz & - + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) * rdz & - - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) * rdz ) - else - ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 - bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) * rdz & - + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) * rdz ) & - - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) * rdz ) - endif + do k=2, nVertLevels-1 + dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) + rdz = 1.0/dz + + ! if ( scalars(index_qc,k,iCell) < qc_cr ) then + ! ! Dry Brunt-Vaisala frequency + ! bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & + ! + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) / dz & + ! - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) + ! else + ! ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 + ! bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & + ! + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) / dz ) & + ! - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) + ! endif + + dry_bv_frequency = .true. + if(index_qc .gt. 0) then ! if moist simulation, qc exists + if ( scalars(index_qc,k,iCell) .ge. qc_cr ) dry_bv_frequency = .false. + end if - end do - bn2(1,iCell) = bn2(2,iCell) - bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) + if (dry_bv_frequency) then + ! Dry Brunt-Vaisala frequency + bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) * rdz & + + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) * rdz & + - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) * rdz ) + else + ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 + bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) * rdz & + + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) * rdz ) & + - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) * rdz ) + endif - end do + end do + + bn2(1,iCell) = bn2(2,iCell) + bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) + + end do - if(debug_dissipation) call mpas_log_write(' exiting BV frequency calculations ') + if(debug_dissipation) call mpas_log_write(' exiting BV frequency calculations ') - end subroutine calculate_n2 + end subroutine calculate_n2 !--------------------------------------- - subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & - cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & - cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & - nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & - invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & - angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & - config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & - config_del4u_div_factor, zgrid, & - eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & - fzm, fzp, config_les_model, config_les_surface, & - config_surface_drag_coefficient, & - delsq_u, delsq_vorticity, delsq_divergence, & - u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, & - tend_u_euler ) - - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & + cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & + nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & + invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & + angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & + config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & + config_del4u_div_factor, zgrid, & + eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & + fzm, fzp, config_les_model, config_les_surface, & + config_surface_drag_coefficient, & + delsq_u, delsq_vorticity, delsq_divergence, & + u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, & + tend_u_euler ) + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here implicit none @@ -488,7 +491,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(out) :: tend_u_euler - ! local variables + ! local variables integer :: iEdge, cell1, cell2, vertex1, vertex2, iVertex, iCell, i, k real (kind=RKIND) :: r_dc, r_dv, u_diffusion, u_diffusion_les, kdiffu, r, edge_sign, u_mix_scale @@ -503,244 +506,244 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND) :: velocity_magnitude real (kind=RKIND) :: tau_12_factor - if(debug_dissipation) then - call mpas_log_write(' begin u_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' les surface is '//trim(config_les_surface)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) - call mpas_log_write(' 4th order divergence factor is $r ', realArgs=(/config_del4u_div_factor/)) - end if + if(debug_dissipation) then + call mpas_log_write(' begin u_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' les surface is '//trim(config_les_surface)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) + call mpas_log_write(' 4th order divergence factor is $r ', realArgs=(/config_del4u_div_factor/)) + end if -!$OMP BARRIER +!$OMP BARRIER - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). - ! First, storage to hold the result from the first del^2 computation. + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). + ! First, storage to hold the result from the first del^2 computation. - delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 - tau_12_factor = 0.0 - if(config_les_model /= 'none') tau_12_factor = 1.0 + delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 + tau_12_factor = 0.0 + if(config_les_model /= 'none') tau_12_factor = 1.0 - do iEdge=edgeStart,edgeEnd - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - vertex1 = verticesOnEdge(1,iEdge) - vertex2 = verticesOnEdge(2,iEdge) - r_dc = invDcEdge(iEdge) - r_dv = min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) + do iEdge=edgeStart,edgeEnd + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + vertex1 = verticesOnEdge(1,iEdge) + vertex2 = verticesOnEdge(2,iEdge) + r_dc = invDcEdge(iEdge) + r_dv = min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) -!DIR$ IVDEP - do k=1,nVertLevels +!DIR$ IVDEP + do k=1,nVertLevels - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant - u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & - -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv - ! for LES models we need 2 times the gradient of divergence, in contrast to what is - ! saved and used to calculate the 4th-order horizontal filter - u_diffusion_les = u_diffusion + tau_12_factor * ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant + u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & + -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv + ! for LES models we need 2 times the gradient of divergence, in contrast to what is + ! saved and used to calculate the 4th-order horizontal filter + u_diffusion_les = u_diffusion + tau_12_factor * ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc - delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion + delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion - kdiffu = 0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) + kdiffu = 0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) - ! include 2nd-order diffusion here - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & - + rho_edge(k,iEdge)* kdiffu * u_diffusion_les * meshScalingDel2(iEdge) + ! include 2nd-order diffusion here + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & + + rho_edge(k,iEdge)* kdiffu * u_diffusion_les * meshScalingDel2(iEdge) - end do end do + end do - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active -!$OMP BARRIER +!$OMP BARRIER - do iVertex=vertexStart,vertexEnd - delsq_vorticity(1:nVertLevels,iVertex) = 0.0 - do i=1,vertexDegree - iEdge = edgesOnVertex(i,iVertex) - edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) - do k=1,nVertLevels - delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) - end do + do iVertex=vertexStart,vertexEnd + delsq_vorticity(1:nVertLevels,iVertex) = 0.0 + do i=1,vertexDegree + iEdge = edgesOnVertex(i,iVertex) + edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) + do k=1,nVertLevels + delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) end do end do + end do - do iCell=cellStart,cellEnd - delsq_divergence(1:nVertLevels,iCell) = 0.0 - r = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) - do k=1,nVertLevels - delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) - end do + do iCell=cellStart,cellEnd + delsq_divergence(1:nVertLevels,iCell) = 0.0 + r = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) + do k=1,nVertLevels + delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) end do end do + end do -!$OMP BARRIER +!$OMP BARRIER - do iEdge=edgeSolveStart,edgeSolveEnd - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - vertex1 = verticesOnEdge(1,iEdge) - vertex2 = verticesOnEdge(2,iEdge) + do iEdge=edgeSolveStart,edgeSolveEnd + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + vertex1 = verticesOnEdge(1,iEdge) + vertex2 = verticesOnEdge(2,iEdge) - u_mix_scale = meshScalingDel4(iEdge)*h_mom_eddy_visc4 - r_dc = u_mix_scale * config_del4u_div_factor * invDcEdge(iEdge) - r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) + u_mix_scale = meshScalingDel4(iEdge)*h_mom_eddy_visc4 + r_dc = u_mix_scale * config_del4u_div_factor * invDcEdge(iEdge) + r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) -!DIR$ IVDEP - do k=1,nVertLevels +!DIR$ IVDEP + do k=1,nVertLevels - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant - ! - ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor - ! relative to the rotational part. The stability constraint on the divergence component is much less - ! stringent than the rotational part, and this flexibility may be useful. - ! - u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & - -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant + ! + ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor + ! relative to the rotational part. The stability constraint on the divergence component is much less + ! stringent than the rotational part, and this flexibility may be useful. + ! + u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & + -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion - end do end do + end do - end if ! 4th order mixing is active + end if ! 4th order mixing is active - ! - ! vertical mixing for u - 2nd order filter in physical (z) space - ! - if ( v_mom_eddy_visc2 > 0.0 ) then + ! + ! vertical mixing for u - 2nd order filter in physical (z) space + ! + if ( v_mom_eddy_visc2 > 0.0 ) then - if (config_mix_full) then ! mix full state + if (config_mix_full) then ! mix full state - do iEdge=edgeSolveStart,edgeSolveEnd + do iEdge=edgeSolveStart,edgeSolveEnd - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) - do k=2,nVertLevels-1 + do k=2,nVertLevels-1 - z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) - z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) - z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) - z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) + z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) + z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) + z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) + z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & - (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) & - -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm)) - end do + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & + (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) & + -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm)) end do + end do - else ! idealized cases where we mix on the perturbation from the initial 1-D state + else ! idealized cases where we mix on the perturbation from the initial 1-D state - do iEdge=edgeSolveStart,edgeSolveEnd + do iEdge=edgeSolveStart,edgeSolveEnd - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) - do k=1,nVertLevels - u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & - + v_init(k) * sin( angleEdge(iEdge) ) - end do + do k=1,nVertLevels + u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & + + v_init(k) * sin( angleEdge(iEdge) ) + end do - do k=2,nVertLevels-1 + do k=2,nVertLevels-1 - z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) - z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) - z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) - z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) + z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) + z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) + z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) + z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & - (u_mix(k+1)-u_mix(k ))/(zp-z0) & - -(u_mix(k )-u_mix(k-1))/(z0-zm) )/(0.5*(zp-zm)) - end do + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & + (u_mix(k+1)-u_mix(k ))/(zp-z0) & + -(u_mix(k )-u_mix(k-1))/(z0-zm) )/(0.5*(zp-zm)) end do + end do - end if ! mix perturbation state + end if ! mix perturbation state - end if ! vertical mixing of horizontal momentum for les formulation + end if ! vertical mixing of horizontal momentum for les formulation - if ( config_les_model /= "none") then + if ( config_les_model /= "none") then - do iEdge=edgeSolveStart,edgeSolveEnd + do iEdge=edgeSolveStart,edgeSolveEnd - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain - turb_vflux(1) = 0. ! lower bc flux handled where ??? - - do k=2,nVertLevels - rho_k_cell1 = fzm(k)*rho_zz(k ,cell1)*zz(k ,cell1)*eddy_visc_vert(k ,cell1) & - +fzp(k)*rho_zz(k-1,cell1)*zz(k-1,cell1)*eddy_visc_vert(k-1,cell1) - rho_k_cell2 = fzm(k)*rho_zz(k ,cell2)*zz(k ,cell2)*eddy_visc_vert(k ,cell2) & - +fzp(k)*rho_zz(k-1,cell2)*zz(k-1,cell2)*eddy_visc_vert(k-1,cell2) - rho_k_at_w = 0.5*(rho_k_cell1+rho_k_cell2) - - zz_cell1 = fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) - zz_cell2 = fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) - zz_at_w = 0.5*(zz_cell1+zz_cell2) - turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) - end do + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain + turb_vflux(1) = 0. ! lower bc flux handled where ??? - if( config_les_surface == "specified" ) then - velocity_magnitude = sqrt(u(1,iEdge)**2 + v(1,iEdge)**2) - turb_vflux(1) = -rho_edge(1,iEdge)*config_surface_drag_coefficient*u(1,iEdge)*velocity_magnitude - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) - else if ( config_les_surface == "varying" ) then - ust_edge = 0.5*(ustm(cell1) + ustm(cell2)) - velocity_magnitude = max(sqrt(u(1,iEdge)**2 + v(1,iEdge)**2),0.1) - turb_vflux(1) = -rho_edge(1,iEdge)*ust_edge*ust_edge*(u(1,iEdge)/velocity_magnitude) - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) - ! end test conditions - else - ! test conditions for supercell case - turb_vflux(1) = turb_vflux(2) - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) - ! end test conditions - end if + do k=2,nVertLevels + rho_k_cell1 = fzm(k)*rho_zz(k ,cell1)*zz(k ,cell1)*eddy_visc_vert(k ,cell1) & + +fzp(k)*rho_zz(k-1,cell1)*zz(k-1,cell1)*eddy_visc_vert(k-1,cell1) + rho_k_cell2 = fzm(k)*rho_zz(k ,cell2)*zz(k ,cell2)*eddy_visc_vert(k ,cell2) & + +fzp(k)*rho_zz(k-1,cell2)*zz(k-1,cell2)*eddy_visc_vert(k-1,cell2) + rho_k_at_w = 0.5*(rho_k_cell1+rho_k_cell2) + + zz_cell1 = fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) + zz_cell2 = fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) + zz_at_w = 0.5*(zz_cell1+zz_cell2) + turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) + end do - do k=1,nVertLevels - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) - end do + if( config_les_surface == "specified" ) then + velocity_magnitude = sqrt(u(1,iEdge)**2 + v(1,iEdge)**2) + turb_vflux(1) = -rho_edge(1,iEdge)*config_surface_drag_coefficient*u(1,iEdge)*velocity_magnitude + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + else if ( config_les_surface == "varying" ) then + ust_edge = 0.5*(ustm(cell1) + ustm(cell2)) + velocity_magnitude = max(sqrt(u(1,iEdge)**2 + v(1,iEdge)**2),0.1) + turb_vflux(1) = -rho_edge(1,iEdge)*ust_edge*ust_edge*(u(1,iEdge)/velocity_magnitude) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + ! end test conditions + else + ! test conditions for supercell case + turb_vflux(1) = turb_vflux(2) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + ! end test conditions + end if - end do + do k=1,nVertLevels + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + end do + + end do - end if + end if - if(debug_dissipation) call mpas_log_write(' exiting u_dissipation_3d ') + if(debug_dissipation) call mpas_log_write(' exiting u_dissipation_3d ') - end subroutine u_dissipation_3d + end subroutine u_dissipation_3d !------------------------ - subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - rdzw, rdzu, & - v_mom_eddy_visc2, h_mom_eddy_visc4, & - delsq_w, & - w, rho_edge, rho_zz, divergence, zz, & - eddy_visc_horz, eddy_visc_vert, & - config_les_model, config_les_surface, & - tend_w_euler ) - - - ! 3D w dissipation using the 3D smagorinsky eddy viscosities. + subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, rho_zz, divergence, zz, & + eddy_visc_horz, eddy_visc_vert, & + config_les_model, config_les_surface, & + tend_w_euler ) + + + ! 3D w dissipation using the 3D smagorinsky eddy viscosities. ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here implicit none @@ -778,81 +781,81 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: tend_w_euler - ! storage passed in from calling routine + ! storage passed in from calling routine real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_w real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux - ! local variables + ! local variables integer :: cell1, cell2, iEdge, iCell, i, k real (kind=RKIND) :: r_areaCell, edge_sign, w_turb_flux -! !OMP BARRIER why is this openmp barrier here??? +! !OMP BARRIER why is this openmp barrier here??? - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). - ! - ! First, storage to hold the result from the first del^2 computation. - ! we copied code from the theta mixing, hence the theta* names. + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). + ! + ! First, storage to hold the result from the first del^2 computation. + ! we copied code from the theta mixing, hence the theta* names. - if(debug_dissipation) then - call mpas_log_write(' begin w_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' les surface is '//trim(config_les_surface)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) - end if + if(debug_dissipation) then + call mpas_log_write(' begin w_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' les surface is '//trim(config_les_surface)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) + end if - delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 + delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 - do iCell=cellStart,cellEnd - tend_w_euler(1:nVertLevels+1,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) + do iCell=cellStart,cellEnd + tend_w_euler(1:nVertLevels+1,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) - edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) -!DIR$ IVDEP - do k=2,nVertLevels +!DIR$ IVDEP + do k=2,nVertLevels - w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) - delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux - w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & - ( eddy_visc_horz(k ,cell1)+eddy_visc_horz(k ,cell2) & - +eddy_visc_horz(k-1,cell1)+eddy_visc_horz(k-1,cell2) ) - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux - end do + w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) + delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux + w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & + ( eddy_visc_horz(k ,cell1)+eddy_visc_horz(k ,cell2) & + +eddy_visc_horz(k-1,cell1)+eddy_visc_horz(k-1,cell2) ) + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux end do end do + end do -!$OMP BARRIER +!$OMP BARRIER - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) - end do + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) end do + end do + end do - end if ! 4th order mixing is active + end if ! 4th order mixing is active if ( v_mom_eddy_visc2 > 0.0 ) then ! vertical mixing do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP +!DIR$ IVDEP do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & @@ -862,55 +865,58 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end if - if ( config_les_model /= "none") then + if ( config_les_model /= "none") then + + do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column + ! compute turbulent fluxes + do k=1,nVertLevels + turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*( & + 2.0*zz(k,iCell)*rdzw(k)*(w(k+1,iCell)-w(k,iCell)) & + + divergence(k,iCell) ) + end do + + turb_vflux(nVertLevels+1) = 0.0 - do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column - ! compute turbulent fluxes - do k=1,nVertLevels - turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*( & - 2.0*zz(k,iCell)*rdzw(k)*(w(k+1,iCell)-w(k,iCell)) & - + divergence(k,iCell) ) - end do - turb_vflux(nVertLevels+1) = 0.0 - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & - - rdzu(k)*(turb_vflux(k)-turb_vflux(k-1)) - end do - end do + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & + - rdzu(k)*(turb_vflux(k)-turb_vflux(k-1)) + end do + end do - end if + end if - if(debug_dissipation) call mpas_log_write(' exiting w_dissipation_3d ') + if(debug_dissipation) call mpas_log_write(' exiting w_dissipation_3d ') - end subroutine w_dissipation_3d + end subroutine w_dissipation_3d !----------------------------------------------------- - subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, fzm, fzp, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - prandtl_3d_inv, & - delsq_theta, & - theta_m, rho_edge, rho_zz, zz, & - eddy_visc_horz, eddy_visc_vert, & - bv_freq2, config_len_disp, scalars, tend_scalars, & - index_tke, index_qv, num_scalars_dummy, mix_scalars, & - config_les_model, config_les_surface, time_of_day_seconds,& - config_surface_heat_flux, config_surface_moisture_flux, & - uReconstructZonal, uReconstructMeridional, & - hfx, qfx, & - tend_theta_euler, dynamics_substep ) - - - ! 3D theta_m dissipation using the 3D smagorinsky eddy viscosities. + subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, fzm, fzp, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + prandtl_3d_inv, & + delsq_theta, & + theta_m, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + bv_freq2, config_len_disp, scalars, tend_scalars, & + index_tke, index_qv, num_scalars_dummy, mix_scalars, & + config_les_model, config_les_surface, time_of_day_seconds,& + config_surface_heat_flux, config_surface_moisture_flux, & + uReconstructZonal, uReconstructMeridional, & + hfx, qfx, & + tend_theta_euler, dynamics_substep ) + + + ! 3D theta_m dissipation using the 3D smagorinsky eddy viscosities. ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + implicit none integer, intent(in) :: cellStart, cellEnd @@ -968,10 +974,10 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler - ! storage passed in from calling routine + ! storage passed in from calling routine real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_theta - ! local variables + ! local variables integer :: cell1, cell2, iEdge, iCell, i, k, iScalar real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp @@ -982,252 +988,254 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND) :: moisture_flux, heat_flux, theta_m_flux real (kind=RKIND) :: qv_cell, theta_m_cell, theta_cell - if(debug_dissipation) then - call mpas_log_write(' begin scalar_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' les surface is '//trim(config_les_surface)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_theta_eddy_visc4/)) - end if - if( mix_scalars .and. (dynamics_substep == 1)) call mpas_log_write(' scalar mixing on ') + if(debug_dissipation) then + call mpas_log_write(' begin scalar_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' les surface is '//trim(config_les_surface)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_theta_eddy_visc4/)) + end if - delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + if( mix_scalars .and. (dynamics_substep == 1)) call mpas_log_write(' scalar mixing on ') + + delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + tend_theta_euler(1:nVertLevels,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + pr_scale = prandtl_inv * meshScalingDel2(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) - do iCell=cellStart,cellEnd - tend_theta_euler(1:nVertLevels,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - pr_scale = prandtl_inv * meshScalingDel2(iEdge) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) !DIR$ IVDEP - do k=1,nVertLevels + do k=1,nVertLevels ! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. ! This is in conservative form. - theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) - delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux - theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux + theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) + delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux + theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux - end do end do - end do + end do + end do !$OMP BARRIER - - if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) + if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active - iEdge = edgesOnCell(i,iCell) - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + iEdge = edgesOnCell(i,iCell) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) - do k=1,nVertLevels - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) - end do + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) end do end do + end do + + end if ! 4th order mixing is active - end if ! 4th order mixing is active + if(mix_scalars .and. (dynamics_substep == 1)) then ! dissipation for scalars, including 4th-order filter. Likely needs optimization - if(mix_scalars .and. (dynamics_substep == 1)) then ! dissipation for scalars, including 4th-order filter. Likely needs optimization - do iScalar=1,num_scalars - - delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 - do iCell=cellStart,cellEnd - ! tend_theta_euler(1:nVertLevels,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - pr_scale = prandtl_inv * meshScalingDel2(iEdge) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + ! tend_theta_euler(1:nVertLevels,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + pr_scale = prandtl_inv * meshScalingDel2(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + !DIR$ IVDEP - do k=1,nVertLevels + do k=1,nVertLevels ! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. ! This is in conservative form. - theta_turb_flux = edge_sign*(scalars(iScalar,k,cell2) - scalars(iScalar,k,cell1))*rho_edge(k,iEdge) - delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux - theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale - tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) + theta_turb_flux + theta_turb_flux = edge_sign*(scalars(iScalar,k,cell2) - scalars(iScalar,k,cell1))*rho_edge(k,iEdge) + delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux + theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale + tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) + theta_turb_flux + end do end do end do - end do !$OMP BARRIER - - if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) + if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active - iEdge = edgesOnCell(i,iCell) - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + iEdge = edgesOnCell(i,iCell) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) - do k=1,nVertLevels - tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) + end do end do end do - end do - end if ! 4th order mixing is active - - end do ! loop over scalars for horizontal mixing + end if ! 4th order mixing is active + + end do ! loop over scalars for horizontal mixing end if ! horizontal scalar mixing - ! idealized case vertical mixing. No scalar mixing here. + ! idealized case vertical mixing. No scalar mixing here. - if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m + if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m - if (config_mix_full) then + if (config_mix_full) then - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & - -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) - end do + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & + -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) end do + end do else ! idealized cases where we mix on the perturbation from the initial 1-D state - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & - -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) - end do + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & + -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) end do - - end if + end do end if - if ( config_les_model /= "none") then + end if - do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column - ! compute turbulent fluxes + if ( config_les_model /= "none") then + do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column + ! compute turbulent fluxes - turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain - turb_vflux(1) = 0. ! lower bc flux handled where ??? + turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain + turb_vflux(1) = 0. ! lower bc flux handled where ??? - if ( config_les_model == "3d_smagorinsky") then - do k=2,nVertLevels - prandtl_1d_inverse(k) = prandtl_inv - end do - else ! prognostic_1.5_order, isentropic mixing length - ! do k=2,nVertLevels - ! delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) - ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) - ! bv_frequency2 = 0.5*(bv_freq2(k,iCell)+bv_freq2(k-1,iCell)) - ! tke_length = delta_s - ! if(bv_frequency2 .gt. 1.e-06) & - ! tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/sqrt(bv_frequency2) - ! tke_length = min(delta_z,tke_length) - ! prandtl_inverse(k) = 1. + 2.*tke_length/delta_z - ! end do - - do k=2,nVertLevels - ! prandtl_1d_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) - prandtl_1d_inverse(k) = fzm(k)*prandtl_3d_inv(k,iCell)+fzp(k)*prandtl_3d_inv(k-1,iCell) - end do + if ( config_les_model == "3d_smagorinsky") then + do k=2,nVertLevels + prandtl_1d_inverse(k) = prandtl_inv + end do + else ! prognostic_1.5_order, isentropic mixing length + ! do k=2,nVertLevels + ! delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) + ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) + ! bv_frequency2 = 0.5*(bv_freq2(k,iCell)+bv_freq2(k-1,iCell)) + ! tke_length = delta_s + ! if(bv_frequency2 .gt. 1.e-06) & + ! tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/sqrt(bv_frequency2) + ! tke_length = min(delta_z,tke_length) + ! prandtl_inverse(k) = 1. + 2.*tke_length/delta_z + ! end do + + do k=2,nVertLevels + ! prandtl_1d_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) + prandtl_1d_inverse(k) = fzm(k)*prandtl_3d_inv(k,iCell)+fzp(k)*prandtl_3d_inv(k-1,iCell) + end do + + end if - end if + do k=2,nVertLevels - do k=2,nVertLevels + ! delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) + ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) + ! bv_frequency2 = 0.5*(bv_freq2(k)+bv_freq(k-1)) + ! bv = max( sqrt(abs(bv_frequency2)), epsilon_bv ) + rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) + turb_vflux(k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) + end do - ! delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) - ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) - ! bv_frequency2 = 0.5*(bv_freq2(k)+bv_freq(k-1)) - ! bv = max( sqrt(abs(bv_frequency2)), epsilon_bv ) - rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & - +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) - zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) - turb_vflux(k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) - end do + ! test boundary conditions for supercell and les test cases - ! test boundary conditions for supercell and les test cases + if( config_les_surface == "specified" .or. config_les_surface == "varying" ) then - if( config_les_surface == "specified" .or. config_les_surface == "varying" ) then + if( config_les_surface == "specified" ) then + moisture_flux = config_surface_moisture_flux + heat_flux = config_surface_heat_flux - if( config_les_surface == "specified" ) then - moisture_flux = config_surface_moisture_flux - heat_flux = config_surface_heat_flux -! place holder routine for time-varying specified +! place holder routine for time-varying specified ! call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) - else if ( config_les_surface == "varying" ) then - heat_flux = hfx(iCell)/rho_zz(1,iCell)/cp - moisture_flux = qfx(iCell)/rho_zz(1,iCell) - endif - - qv_cell = scalars(index_qv,1,iCell) - theta_m_cell = theta_m(1,iCell) - theta_cell = theta_m_cell/(1.0+(rv/rgas)*qv_cell) + else if ( config_les_surface == "varying" ) then + heat_flux = hfx(iCell)/rho_zz(1,iCell)/cp + moisture_flux = qfx(iCell)/rho_zz(1,iCell) + endif - theta_m_flux = heat_flux*(1.0+(rv/rgas)*qv_cell)+(rv/rgas)*theta_cell*moisture_flux - turb_vflux(1) = theta_m_flux*rho_zz(1,iCell) - moisture_flux = moisture_flux*rho_zz(1,iCell) - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + qv_cell = scalars(index_qv,1,iCell) + theta_m_cell = theta_m(1,iCell) + theta_cell = theta_m_cell/(1.0+(rv/rgas)*qv_cell) - else + theta_m_flux = heat_flux*(1.0+(rv/rgas)*qv_cell)+(rv/rgas)*theta_cell*moisture_flux + turb_vflux(1) = theta_m_flux*rho_zz(1,iCell) + moisture_flux = moisture_flux*rho_zz(1,iCell) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) - turb_vflux(1) = turb_vflux(2) - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + else - end if + turb_vflux(1) = turb_vflux(2) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + end if - do k=1,nVertLevels - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & - - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) - end do + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & + - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + end do - if (mix_scalars ) then + if (mix_scalars ) then - ! compute turbulent fluxes - turb_vflux_scalars(:,nVertlevels+1) = 0. ! no turbulent flux out of the domain - turb_vflux_scalars(:,1) = 0. ! lower bc flux handled where ??? - do k=2,nVertLevels + ! compute turbulent fluxes + turb_vflux_scalars(:,nVertlevels+1) = 0. ! no turbulent flux out of the domain + turb_vflux_scalars(:,1) = 0. ! lower bc flux handled where ??? + do k=2,nVertLevels rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) @@ -1235,30 +1243,30 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo turb_vflux_scalars(iScalar,k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)* & (scalars(iScalar,k,iCell)-scalars(iScalar,k-1,iCell)) end do - end do + end do - if( config_les_surface == "specified" .or. config_les_surface == "varying" ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv + if( config_les_surface == "specified" .or. config_les_surface == "varying" ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv - do k=1,nVertLevels + do k=1,nVertLevels do iScalar=1,num_scalars - tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) & - - rdzw(k)*(turb_vflux_scalars(iScalar,k+1)-turb_vflux_scalars(iScalar,k)) + tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) & + - rdzw(k)*(turb_vflux_scalars(iScalar,k+1)-turb_vflux_scalars(iScalar,k)) end do - end do + end do - end if ! mix scalars + end if ! mix scalars - end do ! loop over cells (columns) - - end if + end do ! loop over cells (columns) + + end if - if(debug_dissipation) call mpas_log_write(' exiting scalar_dissipation_3d ') + if(debug_dissipation) call mpas_log_write(' exiting scalar_dissipation_3d ') - end subroutine scalar_dissipation_3d_les + end subroutine scalar_dissipation_3d_les !----------- -! subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) +! subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) ! implicit none @@ -1277,6 +1285,6 @@ end subroutine scalar_dissipation_3d_les ! heat_flux = max(0., 0.1*sin(pii*rel_time_t_flux)) ! moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux))/1000. -! end subroutine flux_les_sas +! end subroutine flux_les_sas end module mpas_atm_dissipation_models From 3df68570f7200156f21fde45eed032f75a4f0d47 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 5 Dec 2025 14:42:21 -0700 Subject: [PATCH 139/214] Use a macro for debugging print statements in mpas_atm_dissipation_models.F With a macro, when debugging prints are not enabled the compiler will see no executable code. --- .../dynamics/mpas_atm_dissipation_models.F | 61 +++++++++---------- 1 file changed, 30 insertions(+), 31 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 70cf9c24b3..4fd7000acd 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -6,6 +6,9 @@ ! distributed with this code, or at http://mpas-dev.github.com/license.html ! +#define COMMA , +#define DEBUG_WRITE(M) ! call mpas_log_write(M) + module mpas_atm_dissipation_models use mpas_kind_types, only : RKIND @@ -14,7 +17,6 @@ module mpas_atm_dissipation_models use mpas_log use mpas_derived_types, only : MPAS_LOG_CRIT - logical, parameter :: debug_dissipation = .false. logical, parameter :: les_test = .true., les_sas_test = .false. !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour ! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 @@ -58,8 +60,8 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, integer :: iCell, iEdge, k real (kind=RKIND), dimension(nVertLevels) :: d_11, d_22, d_12, dudx, dudy, dvdx, dvdy - if(debug_dissipation) call mpas_log_write(' begin smagorinsky_2d ') + DEBUG_WRITE(' begin smagorinsky_2d ') do iCell = cellStart,cellEnd dudx(1:nVertLevels) = 0.0 @@ -94,7 +96,7 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 h_theta_eddy_visc4 = h_mom_eddy_visc4 - if(debug_dissipation) call mpas_log_write(' exiting smagorinsky_2d ') + DEBUG_WRITE(' exiting smagorinsky_2d ') end subroutine smagorinsky_2d @@ -158,9 +160,10 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e logical, parameter :: test_tke=.true. ! real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 - if(debug_dissipation) call mpas_log_write(' begin les_models ') - if(debug_dissipation) call mpas_log_write(' les scheme is '//trim(config_les_model)) - if(debug_dissipation) call mpas_log_write(' les surface scheme is '//trim(config_les_surface)) + + DEBUG_WRITE(' begin les_models ') + DEBUG_WRITE(' les scheme is '//trim(config_les_model)) + DEBUG_WRITE(' les surface scheme is '//trim(config_les_surface)) pr_inv = 1./prandtl @@ -324,7 +327,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e end do ! loop over all owned cells (columns) - if(debug_dissipation) call mpas_log_write(' les_models ') + DEBUG_WRITE(' les_models ') end subroutine les_models @@ -348,7 +351,7 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(nVertLevels) :: theta, qvsw, temp, coefa logical :: dry_bv_frequency - if(debug_dissipation) call mpas_log_write(' begin BV frequency calculations ') + DEBUG_WRITE(' begin BV frequency calculations ') do iCell = cellStart,cellEnd !DIR$ IVDEP @@ -408,7 +411,7 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in end do - if(debug_dissipation) call mpas_log_write(' exiting BV frequency calculations ') + DEBUG_WRITE(' exiting BV frequency calculations ') end subroutine calculate_n2 @@ -506,13 +509,11 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND) :: velocity_magnitude real (kind=RKIND) :: tau_12_factor - if(debug_dissipation) then - call mpas_log_write(' begin u_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' les surface is '//trim(config_les_surface)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) - call mpas_log_write(' 4th order divergence factor is $r ', realArgs=(/config_del4u_div_factor/)) - end if + DEBUG_WRITE(' begin u_dissipation_3d ') + DEBUG_WRITE(' les model is '//trim(config_les_model)) + DEBUG_WRITE(' les surface is '//trim(config_les_surface)) + DEBUG_WRITE(' 4th order hyperviscosity is $r ' COMMA realArgs=(/h_mom_eddy_visc4/)) + DEBUG_WRITE(' 4th order divergence factor is $r ' COMMA realArgs=(/config_del4u_div_factor/)) !$OMP BARRIER @@ -720,7 +721,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end if - if(debug_dissipation) call mpas_log_write(' exiting u_dissipation_3d ') + DEBUG_WRITE(' exiting u_dissipation_3d ') end subroutine u_dissipation_3d @@ -797,12 +798,11 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, ! First, storage to hold the result from the first del^2 computation. ! we copied code from the theta mixing, hence the theta* names. - if(debug_dissipation) then - call mpas_log_write(' begin w_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' les surface is '//trim(config_les_surface)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) - end if + + DEBUG_WRITE(' begin w_dissipation_3d ') + DEBUG_WRITE(' les model is '//trim(config_les_model)) + DEBUG_WRITE(' les surface is '//trim(config_les_surface)) + DEBUG_WRITE(' 4th order hyperviscosity is $r ' COMMA realArgs=(/h_mom_eddy_visc4/)) delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 @@ -885,7 +885,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end if - if(debug_dissipation) call mpas_log_write(' exiting w_dissipation_3d ') + DEBUG_WRITE(' exiting w_dissipation_3d ') end subroutine w_dissipation_3d @@ -988,12 +988,11 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND) :: moisture_flux, heat_flux, theta_m_flux real (kind=RKIND) :: qv_cell, theta_m_cell, theta_cell - if(debug_dissipation) then - call mpas_log_write(' begin scalar_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' les surface is '//trim(config_les_surface)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_theta_eddy_visc4/)) - end if + + DEBUG_WRITE(' begin scalar_dissipation_3d ') + DEBUG_WRITE(' les model is '//trim(config_les_model)) + DEBUG_WRITE(' les surface is '//trim(config_les_surface)) + DEBUG_WRITE(' 4th order hyperviscosity is $r ' COMMA realArgs=(/h_theta_eddy_visc4/)) if( mix_scalars .and. (dynamics_substep == 1)) call mpas_log_write(' scalar mixing on ') @@ -1260,7 +1259,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end if - if(debug_dissipation) call mpas_log_write(' exiting scalar_dissipation_3d ') + DEBUG_WRITE(' exiting scalar_dissipation_3d ') end subroutine scalar_dissipation_3d_les From e0932725c82168a608fffb61223ef0be06427fb6 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 20 Jan 2026 17:15:05 -0700 Subject: [PATCH 140/214] Add 'lbc_tke' to the 'lbc_scalars' var_array in atmosphere core Registry.xml --- src/core_atmosphere/Registry.xml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 2264cf1fd5..68b0952e9b 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1722,9 +1722,6 @@ description="Rain number concentration" packages="mp_thompson_in;mp_thompson_aers_in"/> - - @@ -1736,6 +1733,9 @@ + + #endif @@ -2104,7 +2104,7 @@ packages="mp_thompson_aers_in"/> + description="Tendency of tke multiplied by dry air density divided by d(zeta)/dz"/> #endif @@ -2183,6 +2183,10 @@ + + From d60a7653e9a18196fa8021e8ac192a09e00d4933 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 25 Feb 2026 14:26:21 -0700 Subject: [PATCH 141/214] Initial pass at porting mpas_atm_dissipation_models to GPUs with OpenACC Results with the NVHPC 25.9 compilers are bit-identical between CPU and GPU runs when compiling with the additional flags -Mnofma -gpu=math_uniform . --- .../dynamics/mpas_atm_dissipation_models.F | 314 ++++++++++++++++-- .../dynamics/mpas_atm_time_integration.F | 97 +++++- 2 files changed, 369 insertions(+), 42 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 4fd7000acd..cadd1cfdff 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -63,12 +63,25 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, DEBUG_WRITE(' begin smagorinsky_2d ') + !$acc enter data create(dudx, dudy, dvdx, dvdy) + !$acc enter data create(d_11, d_22, d_12) + + !$acc parallel default(present) + + !$acc loop gang worker private(dudx, dudy, dvdx, dvdy, d_11, d_22, d_12) do iCell = cellStart,cellEnd - dudx(1:nVertLevels) = 0.0 - dudy(1:nVertLevels) = 0.0 - dvdx(1:nVertLevels) = 0.0 - dvdy(1:nVertLevels) = 0.0 + + !$acc loop vector + do k = 1, nVertLevels + dudx(k) = 0.0_RKIND + dudy(k) = 0.0_RKIND + dvdx(k) = 0.0_RKIND + dvdy(k) = 0.0_RKIND + end do + + !$acc loop seq do iEdge=1,nEdgesOnCell(iCell) + !$acc loop vector do k=1,nVertLevels dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) @@ -82,6 +95,7 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, end do !DIR$ IVDEP + !$acc loop vector do k=1, nVertLevels ! here is the Smagorinsky formulation, ! followed by imposition of an upper bound on the eddy viscosity @@ -93,6 +107,11 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, end do end do + !$acc end parallel + + !$acc exit data delete(dudx, dudy, dvdx, dvdy) + !$acc exit data delete(d_11, d_22, d_12) + h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 h_theta_eddy_visc4 = h_mom_eddy_visc4 @@ -165,6 +184,9 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e DEBUG_WRITE(' les scheme is '//trim(config_les_model)) DEBUG_WRITE(' les surface scheme is '//trim(config_les_surface)) + !$acc enter data create(dudx, dudy, dvdx, dvdy, dwdx, dwdy, dudz, dvdz, dwdz) + !$acc enter data create(d_11, d_22, d_33, d_12, d_13, d_23) + pr_inv = 1./prandtl ! set up coefficients for 4th-order horizontal background filter @@ -172,25 +194,37 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 h_theta_eddy_visc4 = h_mom_eddy_visc4 + !$acc parallel default(present) + + !$acc loop gang worker private(dudx, dudy, dvdx, dvdy, dwdx, dwdy, dudz, dvdz, dwdz, d_11, d_22, d_33, d_12, d_13, d_23) do iCell = cellStart,cellEnd - dudx(1:nVertLevels) = 0.0 - dudy(1:nVertLevels) = 0.0 - dvdx(1:nVertLevels) = 0.0 - dvdy(1:nVertLevels) = 0.0 - dwdx(1:nVertLevels+1) = 0.0 - dwdy(1:nVertLevels+1) = 0.0 + !$acc loop vector + do k = 1, nVertLevels + dudx(k) = 0.0_RKIND + dudy(k) = 0.0_RKIND + dvdx(k) = 0.0_RKIND + dvdy(k) = 0.0_RKIND - dudz(1:nVertLevels) = 0.0 - dvdz(1:nVertLevels) = 0.0 - dwdz(1:nVertLevels) = 0.0 + dudz(k) = 0.0_RKIND + dvdz(k) = 0.0_RKIND + dwdz(k) = 0.0_RKIND + end do + + !$acc loop vector + do k = 1, nVertLevels+1 + dwdx(k) = 0.0_RKIND + dwdy(k) = 0.0_RKIND + end do + !$acc loop seq do iEdge=1,nEdgesOnCell(iCell) ie = EdgesOnCell(iEdge,iCell) cell1 = cellsOnEdge(1,ie) cell2 = cellsOnEdge(2,ie) + !$acc loop vector do k=1,nVertLevels dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,ie) & - deformation_coef_cs(iEdge,iCell)*v(k,ie) @@ -202,6 +236,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e + deformation_coef_cs(iEdge,iCell)*v(k,ie) end do + !$acc loop vector do k=1,nVertLevels+1 wk = 0.5*(w(k,cell1)+w(k,cell2)) dwdx(k) = dwdx(k) + deformation_coef_c(iEdge,iCell)*wk @@ -210,11 +245,13 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e end do + !$acc loop vector do k=1,nVertLevels rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) dwdz(k) = (w(k+1,iCell)-w(k,iCell))*rdz end do + !$acc loop vector do k=2,nVertLevels-1 rdz = 1./(zgrid(k+2,iCell)+zgrid(k+1,iCell)-zgrid(k,iCell)-zgrid(k-1,iCell)) dudz(k) = (uCell(k+1,iCell)-uCell(k-1,iCell))*rdz @@ -231,6 +268,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e dudz(k+1) = (uCell(k+1,iCell)-uCell(k,iCell))*rdz dvdz(k+1) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz + !$acc loop vector do k=1, nVertLevels d_11(k) = 2.*dudx(k) d_22(k) = 2.*dvdy(k) @@ -242,6 +280,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e if (config_les_model == "3d_smagorinsky") then + !$acc loop vector do k=1, nVertLevels def2 = 0.5*(d_11(k)**2 + d_22(k)**2 + d_33(k)**2) + d_12(k)**2 + d_13(k)**2 + d_23(k)**2 eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) @@ -253,11 +292,13 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e else if (config_les_model == "prognostic_1.5_order") then + !$acc loop vector do k=1,nVertLevels ! bound the tke here, currently hardwired ! scalars(index_tke,k,iCell) = max(0.,min(100.,scalars(index_tke,k,iCell))) scalars(index_tke,k,iCell) = max(0.,scalars(index_tke,k,iCell)) end do + !$acc loop vector do k=1,nVertLevels delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) @@ -321,12 +362,17 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e else - call mpas_log_write(' in les_models, no les scheme for '//trim(config_les_model), messageType=MPAS_LOG_CRIT) +!MGD call mpas_log_write(' in les_models, no les scheme for '//trim(config_les_model), messageType=MPAS_LOG_CRIT) end if ! end of config_les_model test end do ! loop over all owned cells (columns) + !$acc end parallel + + !$acc exit data delete(dudx, dudy, dvdx, dvdy, dwdx, dwdy, dudz, dvdz, dwdz) + !$acc exit data delete(d_11, d_22, d_33, d_12, d_13, d_23) + DEBUG_WRITE(' les_models ') end subroutine les_models @@ -351,10 +397,18 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(nVertLevels) :: theta, qvsw, temp, coefa logical :: dry_bv_frequency + DEBUG_WRITE(' begin BV frequency calculations ') + !$acc enter data create(theta, temp, qvsw, coefa) + + !$acc parallel default(present) + + !$acc loop gang worker private(theta, temp, qvsw, coefa) do iCell = cellStart,cellEnd + !DIR$ IVDEP + !$acc loop vector do k=1, nVertLevels theta(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) @@ -371,6 +425,7 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in end do + !$acc loop vector do k=2, nVertLevels-1 dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) rdz = 1.0/dz @@ -411,6 +466,10 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in end do + !$acc end parallel + + !$acc exit data delete(theta, temp, qvsw, coefa) + DEBUG_WRITE(' exiting BV frequency calculations ') end subroutine calculate_n2 @@ -520,10 +579,15 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). ! First, storage to hold the result from the first del^2 computation. - delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 + !$acc enter data create(u_mix) + !$acc enter data create(turb_vflux) + + !$acc parallel default(present) + tau_12_factor = 0.0 if(config_les_model /= 'none') tau_12_factor = 1.0 + !$acc loop gang worker do iEdge=edgeStart,edgeEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -532,7 +596,13 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v r_dc = invDcEdge(iEdge) r_dv = min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) + !$acc loop vector + do k = 1, nVertLevels + delsq_u(k,iEdge) = 0.0_RKIND + end do + !DIR$ IVDEP + !$acc loop vector do k=1,nVertLevels ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity @@ -554,35 +624,61 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end do end do + !$acc end parallel + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active !$OMP BARRIER + !$acc parallel default(present) + + !$acc loop gang worker do iVertex=vertexStart,vertexEnd - delsq_vorticity(1:nVertLevels,iVertex) = 0.0 + !$acc loop vector + do k = 1, nVertLevels + delsq_vorticity(k,iVertex) = 0.0_RKIND + end do + + !$acc loop seq do i=1,vertexDegree iEdge = edgesOnVertex(i,iVertex) edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) + + !$acc loop vector do k=1,nVertLevels delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) end do end do end do + !$acc loop gang worker do iCell=cellStart,cellEnd - delsq_divergence(1:nVertLevels,iCell) = 0.0 + !$acc loop vector + do k = 1, nVertLevels + delsq_divergence(k,iCell) = 0.0_RKIND + end do + r = invAreaCell(iCell) + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) + + !$acc loop vector do k=1,nVertLevels delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) end do end do end do + !$acc end parallel + !$OMP BARRIER + !$acc parallel default(present) + + !$acc loop gang worker do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -594,6 +690,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) !DIR$ IVDEP + !$acc loop vector do k=1,nVertLevels ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity @@ -610,6 +707,8 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end do end do + !$acc end parallel + end if ! 4th order mixing is active ! @@ -619,11 +718,15 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v if (config_mix_full) then ! mix full state + !$acc parallel default(present) + + !$acc loop gang worker do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) + !$acc loop vector do k=2,nVertLevels-1 z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) @@ -641,18 +744,25 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end do end do + !$acc end parallel + else ! idealized cases where we mix on the perturbation from the initial 1-D state + !$acc parallel default(present) + + !$acc loop gang worker private(u_mix) do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) + !$acc loop vector do k=1,nVertLevels u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & + v_init(k) * sin( angleEdge(iEdge) ) end do + !$acc loop vector do k=2,nVertLevels-1 z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) @@ -670,19 +780,25 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end do end do + !$acc end parallel + end if ! mix perturbation state end if ! vertical mixing of horizontal momentum for les formulation if ( config_les_model /= "none") then + !$acc parallel default(present) + + !$acc loop gang worker private(turb_vflux) do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) - turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain - turb_vflux(1) = 0. ! lower bc flux handled where ??? + turb_vflux(nVertlevels+1) = 0.0_RKIND ! no turbulent flux out of the domain + turb_vflux(1) = 0.0_RKIND ! lower bc flux handled where ??? + !$acc loop vector do k=2,nVertLevels rho_k_cell1 = fzm(k)*rho_zz(k ,cell1)*zz(k ,cell1)*eddy_visc_vert(k ,cell1) & +fzp(k)*rho_zz(k-1,cell1)*zz(k-1,cell1)*eddy_visc_vert(k-1,cell1) @@ -713,14 +829,20 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v ! end test conditions end if + !$acc loop vector do k=1,nVertLevels tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do end do + !$acc end parallel + end if + !$acc exit data delete(turb_vflux) + !$acc exit data delete(u_mix) + DEBUG_WRITE(' exiting u_dissipation_3d ') end subroutine u_dissipation_3d @@ -804,11 +926,26 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, DEBUG_WRITE(' les surface is '//trim(config_les_surface)) DEBUG_WRITE(' 4th order hyperviscosity is $r ' COMMA realArgs=(/h_mom_eddy_visc4/)) - delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 + !$acc enter data create(turb_vflux) + !$acc parallel default(present) + + !$acc loop gang worker do iCell=cellStart,cellEnd - tend_w_euler(1:nVertLevels+1,iCell) = 0.0 + + !$acc loop vector + do k = 1, nVertLevels + delsq_w(k,iCell) = 0.0_RKIND + end do + + !$acc loop vector + do k = 1, nVertLevels+1 + tend_w_euler(k,iCell) = 0.0_RKIND + end do + r_areaCell = invAreaCell(iCell) + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) @@ -818,6 +955,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, cell2 = cellsOnEdge(2,iEdge) !DIR$ IVDEP + !$acc loop vector do k=2,nVertLevels w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) @@ -830,12 +968,20 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end do end do + !$acc end parallel + !$OMP BARRIER if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + !$acc parallel default(present) + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) cell1 = cellsOnEdge(1,iEdge) @@ -843,6 +989,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) + !$acc loop vector do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) end do @@ -850,12 +997,18 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end do end do + !$acc end parallel + end if ! 4th order mixing is active if ( v_mom_eddy_visc2 > 0.0 ) then ! vertical mixing + !$acc parallel default(present) + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd !DIR$ IVDEP + !$acc loop vector do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & @@ -863,12 +1016,19 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end do end do + !$acc end parallel + end if if ( config_les_model /= "none") then + !$acc parallel default(present) + + !$acc loop gang worker private(turb_vflux) do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes + + !$acc loop vector do k=1,nVertLevels turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*( & 2.0*zz(k,iCell)*rdzw(k)*(w(k+1,iCell)-w(k,iCell)) & @@ -877,14 +1037,19 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, turb_vflux(nVertLevels+1) = 0.0 + !$acc loop vector do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & - rdzu(k)*(turb_vflux(k)-turb_vflux(k-1)) end do end do + !$acc end parallel + end if + !$acc exit data delete(turb_vflux) + DEBUG_WRITE(' exiting w_dissipation_3d ') end subroutine w_dissipation_3d @@ -983,7 +1148,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux, prandtl_1d_inverse real (kind=RKIND), dimension(num_scalars,nVertLevels+1) :: turb_vflux_scalars - real (kind=RKIND) :: rho_k_at_w, zz_at_w + real (kind=RKIND), dimension(nVertLevels) :: rho_k_at_w, zz_at_w real (kind=RKIND) :: moisture_flux, heat_flux, theta_m_flux real (kind=RKIND) :: qv_cell, theta_m_cell, theta_cell @@ -996,11 +1161,23 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo if( mix_scalars .and. (dynamics_substep == 1)) call mpas_log_write(' scalar mixing on ') - delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + !$acc enter data create(turb_vflux_scalars) + !$acc enter data create(turb_vflux, prandtl_1d_inverse) + !$acc parallel default(present) + + !$acc loop gang worker do iCell=cellStart,cellEnd - tend_theta_euler(1:nVertLevels,iCell) = 0.0 + + !$acc loop vector + do k = 1, nVertLevels + delsq_theta(k,iCell) = 0.0_RKIND + tend_theta_euler(k,iCell) = 0.0_RKIND + end do + r_areaCell = invAreaCell(iCell) + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) @@ -1009,6 +1186,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo cell2 = cellsOnEdge(2,iEdge) !DIR$ IVDEP + !$acc loop vector do k=1,nVertLevels ! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. @@ -1023,12 +1201,19 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do + !$acc end parallel + !$OMP BARRIER if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active + !$acc parallel default(present) + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) @@ -1037,23 +1222,34 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) + !$acc loop vector do k=1,nVertLevels tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) end do end do end do + !$acc end parallel + end if ! 4th order mixing is active if(mix_scalars .and. (dynamics_substep == 1)) then ! dissipation for scalars, including 4th-order filter. Likely needs optimization do iScalar=1,num_scalars - delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + !$acc parallel default(present) + !$acc loop gang worker do iCell=cellStart,cellEnd + !$acc loop vector + do k = 1, nVertLevels + delsq_theta(k,iCell) = 0.0_RKIND + end do + ! tend_theta_euler(1:nVertLevels,iCell) = 0.0 r_areaCell = invAreaCell(iCell) + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) @@ -1062,6 +1258,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo cell2 = cellsOnEdge(2,iEdge) !DIR$ IVDEP + !$acc loop vector do k=1,nVertLevels ! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. @@ -1076,12 +1273,20 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do + !$acc end parallel + !$OMP BARRIER if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active + !$acc parallel default(present) + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) @@ -1090,12 +1295,15 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) + !$acc loop vector do k=1,nVertLevels tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) end do end do end do + !$acc end parallel + end if ! 4th order mixing is active end do ! loop over scalars for horizontal mixing @@ -1109,7 +1317,12 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo if (config_mix_full) then + !$acc parallel default(present) + + !$acc loop gang worker do iCell = cellSolveStart,cellSolveEnd + + !$acc loop vector do k=2,nVertLevels-1 z1 = zgrid(k-1,iCell) z2 = zgrid(k ,iCell) @@ -1126,9 +1339,16 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do + !$acc end parallel + else ! idealized cases where we mix on the perturbation from the initial 1-D state + !$acc parallel default(present) + + !$acc loop gang worker do iCell = cellSolveStart,cellSolveEnd + + !$acc loop vector do k=2,nVertLevels-1 z1 = zgrid(k-1,iCell) z2 = zgrid(k ,iCell) @@ -1145,12 +1365,17 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do + !$acc end parallel + end if end if if ( config_les_model /= "none") then + !$acc parallel default(present) + + !$acc loop gang worker private(turb_vflux, turb_vflux_scalars, prandtl_1d_inverse, rho_k_at_w, zz_at_w) do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes @@ -1158,6 +1383,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo turb_vflux(1) = 0. ! lower bc flux handled where ??? if ( config_les_model == "3d_smagorinsky") then + !$acc loop vector do k=2,nVertLevels prandtl_1d_inverse(k) = prandtl_inv end do @@ -1173,6 +1399,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! prandtl_inverse(k) = 1. + 2.*tke_length/delta_z ! end do + !$acc loop vector do k=2,nVertLevels ! prandtl_1d_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) prandtl_1d_inverse(k) = fzm(k)*prandtl_3d_inv(k,iCell)+fzp(k)*prandtl_3d_inv(k-1,iCell) @@ -1180,16 +1407,17 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end if + !$acc loop vector do k=2,nVertLevels ! delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) ! bv_frequency2 = 0.5*(bv_freq2(k)+bv_freq(k-1)) ! bv = max( sqrt(abs(bv_frequency2)), epsilon_bv ) - rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & - +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) - zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) - turb_vflux(k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) + rho_k_at_w(k) = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + zz_at_w(k) = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) + turb_vflux(k) = - prandtl_1d_inverse(k)*rho_k_at_w(k)*zz_at_w(k)*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) end do ! test boundary conditions for supercell and les test cases @@ -1224,6 +1452,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end if + !$acc loop vector do k=1,nVertLevels tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) @@ -1232,20 +1461,30 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo if (mix_scalars ) then ! compute turbulent fluxes - turb_vflux_scalars(:,nVertlevels+1) = 0. ! no turbulent flux out of the domain - turb_vflux_scalars(:,1) = 0. ! lower bc flux handled where ??? + !$acc loop vector + do iScalar=1,num_scalars + turb_vflux_scalars(iScalar,nVertlevels+1) = 0.0_RKIND ! no turbulent flux out of the domain + turb_vflux_scalars(iScalar,1) = 0.0_RKIND ! lower bc flux handled where ??? + end do + + !$acc loop vector + do k=2,nVertLevels + rho_k_at_w(k) = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + + fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + zz_at_w(k) = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) + end do + + !$acc loop vector collapse(2) do k=2,nVertLevels - rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & - +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) - zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) do iScalar=1,num_scalars - turb_vflux_scalars(iScalar,k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)* & + turb_vflux_scalars(iScalar,k) = - prandtl_1d_inverse(k)*rho_k_at_w(k)*zz_at_w(k)*rdzu(k)* & (scalars(iScalar,k,iCell)-scalars(iScalar,k-1,iCell)) end do end do if( config_les_surface == "specified" .or. config_les_surface == "varying" ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv + !$acc loop vector collapse(2) do k=1,nVertLevels do iScalar=1,num_scalars tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) & @@ -1257,8 +1496,13 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do ! loop over cells (columns) + !$acc end parallel + end if + !$acc exit data delete(turb_vflux_scalars) + !$acc exit data delete(turb_vflux, prandtl_1d_inverse) + DEBUG_WRITE(' exiting scalar_dissipation_3d ') end subroutine scalar_dissipation_3d_les diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index f54804cc93..3d79ef059c 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -273,6 +273,11 @@ subroutine mpas_atm_dynamics_init(domain) real (kind=RKIND), dimension(:), pointer :: angleEdge real (kind=RKIND), dimension(:), pointer :: meshScalingDel2 real (kind=RKIND), dimension(:), pointer :: meshScalingDel4 + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c2 + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_s2 + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_cs + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_s #endif #ifdef MPAS_CAM_DYCORE @@ -457,6 +462,21 @@ subroutine mpas_atm_dynamics_init(domain) call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) !$acc enter data copyin(meshScalingDel4) + + call mpas_pool_get_array(mesh, 'deformation_coef_c2', deformation_coef_c2) + !$acc enter data copyin(deformation_coef_c2) + + call mpas_pool_get_array(mesh, 'deformation_coef_s2', deformation_coef_s2) + !$acc enter data copyin(deformation_coef_s2) + + call mpas_pool_get_array(mesh, 'deformation_coef_cs', deformation_coef_cs) + !$acc enter data copyin(deformation_coef_cs) + + call mpas_pool_get_array(mesh, 'deformation_coef_c', deformation_coef_c) + !$acc enter data copyin(deformation_coef_c) + + call mpas_pool_get_array(mesh, 'deformation_coef_s', deformation_coef_s) + !$acc enter data copyin(deformation_coef_s) #endif end subroutine mpas_atm_dynamics_init @@ -547,6 +567,11 @@ subroutine mpas_atm_dynamics_finalize(domain) real (kind=RKIND), dimension(:), pointer :: angleEdge real (kind=RKIND), dimension(:), pointer :: meshScalingDel2 real (kind=RKIND), dimension(:), pointer :: meshScalingDel4 + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c2 + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_s2 + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_cs + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_s #endif @@ -732,6 +757,21 @@ subroutine mpas_atm_dynamics_finalize(domain) call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) !$acc exit data delete(meshScalingDel4) + + call mpas_pool_get_array(mesh, 'deformation_coef_c2', deformation_coef_c2) + !$acc exit data delete(deformation_coef_c2) + + call mpas_pool_get_array(mesh, 'deformation_coef_s2', deformation_coef_s2) + !$acc exit data delete(deformation_coef_s2) + + call mpas_pool_get_array(mesh, 'deformation_coef_cs', deformation_coef_cs) + !$acc exit data delete(deformation_coef_cs) + + call mpas_pool_get_array(mesh, 'deformation_coef_c', deformation_coef_c) + !$acc exit data delete(deformation_coef_c) + + call mpas_pool_get_array(mesh, 'deformation_coef_s', deformation_coef_s) + !$acc exit data delete(deformation_coef_s) #endif end subroutine mpas_atm_dynamics_finalize @@ -5226,8 +5266,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension( nVertLevels + 1 ) :: wduz, wdwz, wdtz, dpzx real (kind=RKIND), dimension( nVertLevels ) :: ru_edge_w, q, u_mix - real (kind=RKIND), dimension( nVertLevels+1 ) :: d_11, d_22, d_12 - real (kind=RKIND), dimension( nVertLevels+1 ) :: dudx, dudy, dvdx, dvdy +! real (kind=RKIND), dimension( nVertLevels+1 ) :: d_11, d_22, d_12 +! real (kind=RKIND), dimension( nVertLevels+1 ) :: dudx, dudy, dvdx, dvdy real (kind=RKIND) :: theta_turb_flux, w_turb_flux, r real (kind=RKIND) :: scalar_weight @@ -5263,6 +5303,13 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm MPAS_ACC_TIMER_START('atm_compute_dyn_tend_work [ACC_data_xfer]') + if (perturbation_coriolis) then + !$acc enter data copyin(u_init, v_init) + end if + if (trim(config_les_model) /= 'none') then + !$acc enter data copyin(exner, pressure_b, bn2) + end if + !$acc enter data copyin(ustm, hfx, qfx) if (rk_step == 1) then !$acc enter data create(tend_w_euler) !$acc enter data create(tend_u_euler) @@ -5274,7 +5321,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc enter data copyin(rb, rr_save) !$acc enter data copyin(divergence, vorticity) !$acc enter data copyin(v) - !$acc enter data copyin(u_init, v_init) else !$acc enter data copyin(tend_w_euler) !$acc enter data copyin(tend_u_euler) @@ -5297,9 +5343,18 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc enter data copyin(rw_save, rt_diabatic_tend) !$acc enter data create(rthdynten) !$acc enter data copyin(t_init) + if (trim(config_les_model) /= 'none') then + !$acc enter data copyin(ur_cell, vr_cell) + else #ifdef CURVATURE - !$acc enter data copyin(ur_cell, vr_cell) + !$acc enter data copyin(ur_cell, vr_cell) #endif + end if + !$acc enter data create(eddy_visc_horz) + !$acc enter data create(eddy_visc_vert) + !$acc enter data create(prandtl_3d_inv) + !$acc enter data copyin(scalars) + !$acc enter data copyin(tend_scalars) MPAS_ACC_TIMER_STOP('atm_compute_dyn_tend_work [ACC_data_xfer]') prandtl_inv = 1.0_RKIND / prandtl @@ -5336,7 +5391,16 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if(config_horiz_mixing == "2d_fixed") then - eddy_visc_horz(1:nVertLevels,cellStart:cellEnd) = config_h_theta_eddy_visc2 + !$acc parallel default(present) + !$acc loop gang worker + do iCell = cellStart, cellEnd + !$acc loop vector + do k = 1, nVertLevels + eddy_visc_horz(k,iCell) = config_h_theta_eddy_visc2 + end do + end do + !$acc end parallel + h_mom_eddy_visc4 = config_h_mom_eddy_visc4 h_theta_eddy_visc4 = config_h_theta_eddy_visc4 @@ -5520,8 +5584,11 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end do if (perturbation_coriolis) then ! this is correct only for constant f + !$acc loop seq do j = 1,nEdgesOnEdge(iEdge) eoe = edgesOnEdge(j,iEdge) + + !$acc loop vector do k=1,nVertLevels reference_u = u_init(k) * cos(angleEdge(eoe)) - v_init(k) * sin(angleEdge(eoe)) q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * fEdge(iEdge) @@ -5996,6 +6063,14 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc end parallel MPAS_ACC_TIMER_START('atm_compute_dyn_tend_work [ACC_data_xfer]') + if (perturbation_coriolis) then + !$acc exit data delete(u_init, v_init) + end if + if (trim(config_les_model) /= 'none') then + !$acc exit data delete(exner, pressure_b) + !$acc exit data copyout(bn2) + end if + !$acc exit data delete(ustm, hfx, qfx) if (rk_step == 1) then !$acc exit data copyout(tend_w_euler) !$acc exit data copyout(tend_u_euler) @@ -6007,7 +6082,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc exit data delete(rb, rr_save) !$acc exit data delete(divergence, vorticity) !$acc exit data delete(v) - !$acc exit data delete(u_init, v_init) else !$acc exit data delete(tend_w_euler) !$acc exit data delete(tend_u_euler) @@ -6030,9 +6104,18 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc exit data delete(rw_save, rt_diabatic_tend) !$acc exit data copyout(rthdynten) !$acc exit data delete(t_init) + if (trim(config_les_model) /= 'none') then + !$acc exit data delete(ur_cell, vr_cell) + else #ifdef CURVATURE - !$acc exit data delete(ur_cell, vr_cell) + !$acc exit data delete(ur_cell, vr_cell) #endif + end if + !$acc exit data delete(eddy_visc_horz) + !$acc exit data delete(eddy_visc_vert) + !$acc exit data delete(prandtl_3d_inv) + !$acc exit data delete(scalars) + !$acc exit data copyout(tend_scalars) MPAS_ACC_TIMER_STOP('atm_compute_dyn_tend_work [ACC_data_xfer]') end subroutine atm_compute_dyn_tend_work From d79df9cf2a8948394ab7c3dc1babe83cfe55dd3e Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 28 Jan 2026 17:49:51 -0700 Subject: [PATCH 142/214] Update copyright statement at the top of mpas_atm_dissipation_models.F --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index cadd1cfdff..1a5e642377 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1,5 +1,4 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). +! Copyright (c) 2026, The University Corporation for Atmospheric Research (UCAR). ! ! Unless noted otherwise source code is licensed under the BSD license. ! Additional copyright and license information can be found in the LICENSE file From f600615eaabac8a55302001236c0290f0af12f3a Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 28 Jan 2026 17:55:01 -0700 Subject: [PATCH 143/214] Fix LaTeX quotes in possible_values for config_les_model and config_les_surface This commit modifies the possible_values attribute for the config_les_model and config_les_surface namelist options in the atmosphere core's Registry.xml file to use LaTeX ` and ' quotes. --- src/core_atmosphere/Registry.xml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 68b0952e9b..a697eaf2e5 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -149,12 +149,12 @@ + possible_values="`none', `3d_smagorinsky', `prognostic_1.5_order'"/> + possible_values="`specified', `varying'"/> Date: Tue, 3 Feb 2026 20:19:37 +0000 Subject: [PATCH 144/214] Fix indentation of deformation_coef_* variables in atmosphere core Registry.xml The deformation_coef_* variables now use tabs for indentation rather than spaces to match other variables in the default stream definitions. --- src/core_atmosphere/Registry.xml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index a697eaf2e5..5ac9420576 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -524,11 +524,11 @@ - - - - - + + + + + #ifdef MPAS_CAM_DYCORE @@ -632,11 +632,11 @@ - - - - - + + + + + From d866412e572551ab242aac67053d4c4b697d8b62 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 3 Feb 2026 20:28:35 +0000 Subject: [PATCH 145/214] Clean up indentation in atm_init_test_coefs routine in mpas_atm_advection.F This commit cleans up whitespace and indentation in the atm_init_test_coefs routine, and it also performs minor cleanup elsewhere in the mpas_atm_advection.F file. --- src/core_init_atmosphere/mpas_atm_advection.F | 277 +++++++++--------- 1 file changed, 138 insertions(+), 139 deletions(-) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index bff8843fbc..4852b17117 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -778,7 +778,6 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere real (kind=RKIND) :: pii real (kind=RKIND), dimension(25) :: xp, yp real (kind=RKIND) :: xe, ye - real (kind=RKIND) :: length_scale integer, dimension(25) :: cell_list @@ -790,6 +789,7 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere logical, pointer :: is_periodic real(kind=RKIND), pointer :: x_period, y_period + call mpas_pool_get_config(mesh, 'is_periodic', is_periodic) call mpas_pool_get_config(mesh, 'x_period', x_period) call mpas_pool_get_config(mesh, 'y_period', y_period) @@ -1023,16 +1023,15 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere end subroutine atm_initialize_deformation_weights -!----------------------- - subroutine atm_init_test_coefs( deformation_coef_c2, deformation_coef_s2, & - deformation_coef_cs, deformation_coef_c, & - deformation_coef_s, & - is_periodic, on_a_sphere, & - x_period, y_period, & - xEdge, yEdge, zEdge, & - xCell, yCell, zCell, nCells, & - angleEdge, nEdgesOnCell, edgesOnCell ) + subroutine atm_init_test_coefs( deformation_coef_c2, deformation_coef_s2, & + deformation_coef_cs, deformation_coef_c, & + deformation_coef_s, & + is_periodic, on_a_sphere, & + x_period, y_period, & + xEdge, yEdge, zEdge, & + xCell, yCell, zCell, nCells, & + angleEdge, nEdgesOnCell, edgesOnCell ) implicit none @@ -1085,149 +1084,149 @@ subroutine atm_init_test_coefs( deformation_coef_c2, deformation_coef_s2, & if ( (.not. on_a_sphere) .and. (is_periodic) ) then ! test is for doubly-periodic Cartesian plane only - dudx_err_max = 0. - dudy_err_max = 0. - dvdx_err_max = 0. - dvdy_err_max = 0. - dwdx_err_max = 0. - dwdy_err_max = 0. - - dudx_err_tot = 0. - dudy_err_tot = 0. - dvdx_err_tot = 0. - dvdy_err_tot = 0. - dwdx_err_tot = 0. - dwdy_err_tot = 0. - - dudx_max = 0. - dudy_max = 0. - dvdx_max = 0. - dvdy_max = 0. - dwdx_max = 0. - dwdy_max = 0. - - do iCell = 1, nCells - - dudx = 0. - dudy = 0. - dvdx = 0. - dvdy = 0. - dwdx = 0. - dwdy = 0. - - xc = xCell(iCell) - yc = yCell(iCell) - - dudx_c = dudx_cell(xc,yc,x_period,y_period) - dudy_c = dudy_cell(xc,yc,x_period,y_period) - dvdx_c = dvdx_cell(xc,yc,x_period,y_period) - dvdy_c = dvdy_cell(xc,yc,x_period,y_period) - dwdx_c = dwdx_cell(xc,yc,x_period,y_period) - dwdy_c = dwdy_cell(xc,yc,x_period,y_period) - - do iEdge = 1, nEdgesOnCell(iCell) + dudx_err_max = 0. + dudy_err_max = 0. + dvdx_err_max = 0. + dvdy_err_max = 0. + dwdx_err_max = 0. + dwdy_err_max = 0. + + dudx_err_tot = 0. + dudy_err_tot = 0. + dvdx_err_tot = 0. + dvdy_err_tot = 0. + dwdx_err_tot = 0. + dwdy_err_tot = 0. + + dudx_max = 0. + dudy_max = 0. + dvdx_max = 0. + dvdy_max = 0. + dwdx_max = 0. + dwdy_max = 0. + + do iCell = 1, nCells + + dudx = 0. + dudy = 0. + dvdx = 0. + dvdy = 0. + dwdx = 0. + dwdy = 0. + + xc = xCell(iCell) + yc = yCell(iCell) + + dudx_c = dudx_cell(xc,yc,x_period,y_period) + dudy_c = dudy_cell(xc,yc,x_period,y_period) + dvdx_c = dvdx_cell(xc,yc,x_period,y_period) + dvdy_c = dvdy_cell(xc,yc,x_period,y_period) + dwdx_c = dwdx_cell(xc,yc,x_period,y_period) + dwdy_c = dwdy_cell(xc,yc,x_period,y_period) + + do iEdge = 1, nEdgesOnCell(iCell) + + ie = edgesOnCell(iEdge,iCell) + angle_e = angleEdge(ie) + xe = xEdge(ie) + ye = yEdge(ie) + + xe = mpas_fix_periodicity(xe,xc,x_period) + ye = mpas_fix_periodicity(ye,yc,y_period) + + ue = u_edge(xe,ye,angle_e,x_period,y_period) + ve = v_edge(xe,ye,angle_e,x_period,y_period) + we = w_edge(xe,ye,x_period,y_period) + + dudx = dudx + deformation_coef_c2(iEdge,iCell)*ue & + - deformation_coef_cs(iEdge,iCell)*ve + dudy = dudy + deformation_coef_cs(iEdge,iCell)*ue & + - deformation_coef_s2(iEdge,iCell)*ve + dvdx = dvdx + deformation_coef_cs(iEdge,iCell)*ue & + + deformation_coef_c2(iEdge,iCell)*ve + dvdy = dvdy + deformation_coef_s2(iEdge,iCell)*ue & + + deformation_coef_cs(iEdge,iCell)*ve + + dwdx = dwdx + deformation_coef_c(iEdge,iCell)*we + dwdy = dwdy + deformation_coef_s(iEdge,iCell)*we - ie = edgesOnCell(iEdge,iCell) - angle_e = angleEdge(ie) - xe = xEdge(ie) - ye = yEdge(ie) - - xe = mpas_fix_periodicity(xe,xc,x_period) - ye = mpas_fix_periodicity(ye,yc,y_period) - - ue = u_edge(xe,ye,angle_e,x_period,y_period) - ve = v_edge(xe,ye,angle_e,x_period,y_period) - we = w_edge(xe,ye,x_period,y_period) - - dudx = dudx + deformation_coef_c2(iEdge,iCell)*ue & - - deformation_coef_cs(iEdge,iCell)*ve - dudy = dudy + deformation_coef_cs(iEdge,iCell)*ue & - - deformation_coef_s2(iEdge,iCell)*ve - dvdx = dvdx + deformation_coef_cs(iEdge,iCell)*ue & - + deformation_coef_c2(iEdge,iCell)*ve - dvdy = dvdy + deformation_coef_s2(iEdge,iCell)*ue & - + deformation_coef_cs(iEdge,iCell)*ve - - dwdx = dwdx + deformation_coef_c(iEdge,iCell)*we - dwdy = dwdy + deformation_coef_s(iEdge,iCell)*we - - end do + end do - ! call mpas_log_write(' u_x, u_y, $r, $r ', realArgs=(/dudx, dudy/)) - ! call mpas_log_write(' v_x, v_y, $r, $r ', realArgs=(/dvdx, dvdy/)) - ! call mpas_log_write(' w_x, w_y, $r, $r ', realArgs=(/dwdx, dwdy/)) + ! call mpas_log_write(' u_x, u_y, $r, $r ', realArgs=(/dudx, dudy/)) + ! call mpas_log_write(' v_x, v_y, $r, $r ', realArgs=(/dvdx, dvdy/)) + ! call mpas_log_write(' w_x, w_y, $r, $r ', realArgs=(/dwdx, dwdy/)) - ! check result for cell + ! check result for cell - e_int = abs(dudx_c - dudx) - dudx_err_tot = dudx_err_tot + e_int - dudx_err_max = max(dudx_err_max, e_int) + e_int = abs(dudx_c - dudx) + dudx_err_tot = dudx_err_tot + e_int + dudx_err_max = max(dudx_err_max, e_int) - e_int = abs(dudy_c - dudy) - dudy_err_tot = dudy_err_tot + e_int - dudy_err_max = max(dudy_err_max, e_int) + e_int = abs(dudy_c - dudy) + dudy_err_tot = dudy_err_tot + e_int + dudy_err_max = max(dudy_err_max, e_int) - e_int = abs(dvdx_c - dvdx) - dvdx_err_tot = dvdx_err_tot + e_int - dvdx_err_max = max(dvdx_err_max, e_int) + e_int = abs(dvdx_c - dvdx) + dvdx_err_tot = dvdx_err_tot + e_int + dvdx_err_max = max(dvdx_err_max, e_int) - e_int = abs(dvdy_c - dvdy) - dvdy_err_tot = dvdy_err_tot + e_int - dvdy_err_max = max(dvdy_err_max, e_int) + e_int = abs(dvdy_c - dvdy) + dvdy_err_tot = dvdy_err_tot + e_int + dvdy_err_max = max(dvdy_err_max, e_int) - e_int = abs(dwdx_c - dwdx) - dwdx_err_tot = dwdx_err_tot + e_int - dwdx_err_max = max(dwdx_err_max, e_int) + e_int = abs(dwdx_c - dwdx) + dwdx_err_tot = dwdx_err_tot + e_int + dwdx_err_max = max(dwdx_err_max, e_int) - e_int = abs(dwdy_c - dwdy) - dwdy_err_tot = dwdy_err_tot + e_int - dwdy_err_max = max(dwdy_err_max, e_int) + e_int = abs(dwdy_c - dwdy) + dwdy_err_tot = dwdy_err_tot + e_int + dwdy_err_max = max(dwdy_err_max, e_int) - dudx_max = max(dudx_max, abs(dudx_c)) - dudy_max = max(dudy_max, abs(dudy_c)) - dvdx_max = max(dvdx_max, abs(dvdx_c)) - dvdy_max = max(dvdy_max, abs(dvdy_c)) - dwdx_max = max(dwdx_max, abs(dwdx_c)) - dwdy_max = max(dwdy_max, abs(dwdy_c)) + dudx_max = max(dudx_max, abs(dudx_c)) + dudy_max = max(dudy_max, abs(dudy_c)) + dvdx_max = max(dvdx_max, abs(dvdx_c)) + dvdy_max = max(dvdy_max, abs(dvdy_c)) + dwdx_max = max(dwdx_max, abs(dwdx_c)) + dwdy_max = max(dwdy_max, abs(dwdy_c)) - end do + end do - ! scale errors - - dudx_err_max = dudx_err_max/dudx_max - dudy_err_max = dudy_err_max/dudy_max - dvdx_err_max = dvdx_err_max/dvdx_max - dvdy_err_max = dvdy_err_max/dvdy_max - dwdx_err_max = dwdx_err_max/dwdx_max - dwdy_err_max = dwdy_err_max/dwdy_max - - dudx_err_tot = dudx_err_tot/dudx_max/real(nCells) - dudy_err_tot = dudy_err_tot/dudy_max/real(nCells) - dvdx_err_tot = dvdx_err_tot/dvdx_max/real(nCells) - dvdy_err_tot = dvdy_err_tot/dvdy_max/real(nCells) - dwdx_err_tot = dwdx_err_tot/dwdx_max/real(nCells) - dwdy_err_tot = dwdy_err_tot/dwdy_max/real(nCells) - - ! output - - call mpas_log_write(' ') - call mpas_log_write(' deformation coefficients check ') - call mpas_log_write(' dudx check, max abs(dudx), max and avg error $r, $r, $r', & - realArgs=(/dudx_max, dudx_err_max, dudx_err_tot/)) - call mpas_log_write(' dudy check, max abs(dudy), max and avg error $r, $r, $r', & - realArgs=(/dudy_max, dudy_err_max, dudy_err_tot/)) - call mpas_log_write(' dvdx check, max abs(dvdx), max and avg error $r, $r, $r', & - realArgs=(/dvdx_max, dvdx_err_max, dvdx_err_tot/)) - call mpas_log_write(' dvdy check, max abs(dvdy), max and avg error $r, $r, $r', & - realArgs=(/dvdy_max, dvdy_err_max, dvdy_err_tot/)) - call mpas_log_write(' dwdx check, max abs(dwdx), max and avg error $r, $r, $r', & - realArgs=(/dwdx_max, dwdx_err_max, dwdx_err_tot/)) - call mpas_log_write(' dwdy check, max abs(dwdy), max and avg error $r, $r, $r', & - realArgs=(/dwdy_max, dwdy_err_max, dwdy_err_tot/)) - call mpas_log_write(' ') + ! scale errors + + dudx_err_max = dudx_err_max/dudx_max + dudy_err_max = dudy_err_max/dudy_max + dvdx_err_max = dvdx_err_max/dvdx_max + dvdy_err_max = dvdy_err_max/dvdy_max + dwdx_err_max = dwdx_err_max/dwdx_max + dwdy_err_max = dwdy_err_max/dwdy_max + + dudx_err_tot = dudx_err_tot/dudx_max/real(nCells) + dudy_err_tot = dudy_err_tot/dudy_max/real(nCells) + dvdx_err_tot = dvdx_err_tot/dvdx_max/real(nCells) + dvdy_err_tot = dvdy_err_tot/dvdy_max/real(nCells) + dwdx_err_tot = dwdx_err_tot/dwdx_max/real(nCells) + dwdy_err_tot = dwdy_err_tot/dwdy_max/real(nCells) + + ! output + + call mpas_log_write(' ') + call mpas_log_write(' deformation coefficients check ') + call mpas_log_write(' dudx check, max abs(dudx), max and avg error $r, $r, $r', & + realArgs=(/dudx_max, dudx_err_max, dudx_err_tot/)) + call mpas_log_write(' dudy check, max abs(dudy), max and avg error $r, $r, $r', & + realArgs=(/dudy_max, dudy_err_max, dudy_err_tot/)) + call mpas_log_write(' dvdx check, max abs(dvdx), max and avg error $r, $r, $r', & + realArgs=(/dvdx_max, dvdx_err_max, dvdx_err_tot/)) + call mpas_log_write(' dvdy check, max abs(dvdy), max and avg error $r, $r, $r', & + realArgs=(/dvdy_max, dvdy_err_max, dvdy_err_tot/)) + call mpas_log_write(' dwdx check, max abs(dwdx), max and avg error $r, $r, $r', & + realArgs=(/dwdx_max, dwdx_err_max, dwdx_err_tot/)) + call mpas_log_write(' dwdy check, max abs(dwdy), max and avg error $r, $r, $r', & + realArgs=(/dwdy_max, dwdy_err_max, dwdy_err_tot/)) + call mpas_log_write(' ') end if - end subroutine atm_init_test_coefs + end subroutine atm_init_test_coefs end module atm_advection From 84986ea87d6eec3c2120513b2bfec804e475973f Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 3 Feb 2026 20:51:03 +0000 Subject: [PATCH 146/214] Tidy up module use statements in mpas_atm_time_integration.F --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 3d79ef059c..de8c7b6c9c 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -22,9 +22,8 @@ module atm_time_integration use mpas_dmpar use mpas_vector_reconstruction ! Added only clause to keep xlf90 from getting confused from the overloaded abs intrinsic in mpas_timekeeping - use mpas_derived_types, only : MPAS_NOW - use mpas_timekeeping, only: MPAS_Time_type, MPAS_TimeInterval_type, mpas_get_clock_time, & - mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+), add_t_ti + use mpas_derived_types, only : MPAS_Time_type, MPAS_TimeInterval_type, MPAS_NOW + use mpas_timekeeping, only: mpas_get_clock_time, mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+) use mpas_timer #ifdef DO_PHYSICS From be8887d8decd7b95fc5a880eaf4b7102aac065f4 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 3 Feb 2026 20:53:16 +0000 Subject: [PATCH 147/214] Fix indentation of call to atm_compute_dyn_tend in atm_srk3 --- .../dynamics/mpas_atm_time_integration.F | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index de8c7b6c9c..1c543c5716 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1210,16 +1210,16 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !$acc end parallel !$OMP PARALLEL DO - do thread=1,nThreads - call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, diag_physics, & - block % configs, nVertLevels, rk_step, dynamics_substep, dt, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do + do thread=1,nThreads + call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, diag_physics, & + block % configs, nVertLevels, rk_step, dynamics_substep, dt, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + end do !$OMP END PARALLEL DO deallocate(delsq_theta) From 42455024275d3ca80afa1f13340b04b2c1b5f8af Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 4 Feb 2026 00:28:38 +0000 Subject: [PATCH 148/214] Fix indentation of calls to calculate_n2 and les_models in atm_compute_dyn_tend_work --- .../dynamics/mpas_atm_time_integration.F | 32 +++++++++---------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 1c543c5716..a0ceae6422 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5407,25 +5407,25 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if (config_les_model /= "none") then - ! call mpas_log_write(' BV call, index qv, qc, tke $i $i $i ', intArgs=(/index_qv, index_qc, index_tke/)) + ! call mpas_log_write(' BV call, index qv, qc, tke $i $i $i ', intArgs=(/index_qv, index_qc, index_tke/)) - call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & - cellStart, cellEnd, nCells) + call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & + cellStart, cellEnd, nCells) - currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) - call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) - time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*dt - ! call mpas_log_write(' les integration, timestep midpoint time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) + currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) + call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) + time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*dt + ! call mpas_log_write(' les integration, timestep midpoint time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) - call les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & - u, v, ur_cell, vr_cell, & - w, c_s, bn2, zgrid, config_len_disp, & - deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & - deformation_coef_c, deformation_coef_s, prandtl_3d_inv, & - invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & - scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & - cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & - nCells, nEdges, nVertLevels, maxEdges, num_scalars ) + call les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & + u, v, ur_cell, vr_cell, & + w, c_s, bn2, zgrid, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + deformation_coef_c, deformation_coef_s, prandtl_3d_inv, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & + nCells, nEdges, nVertLevels, maxEdges, num_scalars ) end if From 01c4a5ebe2b419803e1e95d3ea01d4dcb0d4684c Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 4 Feb 2026 00:34:57 +0000 Subject: [PATCH 149/214] Remove commented-out calls to non-existent dissipation routines This commit removes commented-out calls to the u_dissipation, w_dissipation, theta_dissipation, and theta_dissipation_3d routines in the atm_compute_dyn_tend_work routine; the implementations of these routines no longer exist, and they had only been used for testing during the migration to new dissipation routines for u, w, and scalars. This commit also removes the local variable test_dissipation_3d, which was used to control whether the aforementioned routines were called. --- .../dynamics/mpas_atm_time_integration.F | 157 +++++------------- 1 file changed, 45 insertions(+), 112 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index a0ceae6422..c063760f36 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5238,7 +5238,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: config_visc4_2dsmag real (kind=RKIND) :: config_len_disp real (kind=RKIND) :: config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2 - logical, parameter :: test_dissipation_3d=.true. integer, intent(in) :: rk_step, dynamics_substep real (kind=RKIND), intent(in) :: dt @@ -5628,36 +5627,20 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$OMP BARRIER -! if(test_dissipation_3d) then - - call u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & - cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & - cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & - nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & - invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & - angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & - config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & - config_del4u_div_factor, zgrid, & - eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & - fzm, fzp, config_les_model, config_les_surface, & - config_surface_drag_coefficient, & - delsq_u, delsq_vorticity, delsq_divergence, & - u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, tend_u_euler ) - -! else ! this is the original MPAS dissipation code -! -! call u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & -! cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & -! cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & -! nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & -! invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & -! angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & -! config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & -! config_del4u_div_factor, zgrid, kdiff, & -! delsq_u, delsq_vorticity, delsq_divergence, & -! u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) -! -! end if + call u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & + cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & + nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & + invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & + angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & + config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & + config_del4u_div_factor, zgrid, & + eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & + fzm, fzp, config_les_model, config_les_surface, & + config_surface_drag_coefficient, & + delsq_u, delsq_vorticity, delsq_divergence, & + u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, tend_u_euler ) + end if ! (rk_step 1 test for computing mixing terms) @@ -5785,35 +5768,18 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then -! if(test_dissipation_3d) then - - call w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - rdzw, rdzu, & - v_mom_eddy_visc2, h_mom_eddy_visc4, & - delsq_w, & - w, rho_edge, rho_zz, divergence, zz, & - eddy_visc_horz, eddy_visc_vert, & - config_les_model, config_les_surface, & - tend_w_euler ) - -! else -! -! call w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & -! nCells, nEdges, & -! nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & -! invAreaCell, invDcEdge, dvEdge, & -! meshScalingDel2, meshScalingDel4, & -! rdzw, rdzu, & -! v_mom_eddy_visc2, h_mom_eddy_visc4, & -! delsq_w, & -! w, rho_edge, kdiff, rho_zz, & -! tend_w_euler ) -! -! end if + call w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, rho_zz, divergence, zz, & + eddy_visc_horz, eddy_visc_vert, & + config_les_model, config_les_surface, & + tend_w_euler ) end if ! mixing for w computed in first rk_step @@ -5958,58 +5924,25 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then -! if(test_dissipation_3d) then - - !call theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - ! nCells, nEdges, & - ! nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - ! invAreaCell, invDcEdge, dvEdge, & - ! meshScalingDel2, meshScalingDel4, & - ! config_mix_full, t_init, zgrid, & - ! rdzw, rdzu, fzm, fzp, & - ! v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - ! delsq_theta, & - ! theta_m, rho_edge, rho_zz, zz, & - ! eddy_visc_horz, eddy_visc_vert, & - ! config_les_model, & - ! tend_theta_euler ) - - call scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, fzm, fzp, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - prandtl_3d_inv, & - delsq_theta, & - theta_m, rho_edge, rho_zz, zz, & - eddy_visc_horz, eddy_visc_vert, & - bn2, config_len_disp, scalars, tend_scalars, & - index_tke, index_qv, num_scalars, config_mix_scalars, & - config_les_model, config_les_surface, time_of_day_seconds,& - config_surface_heat_flux, config_surface_moisture_flux, & - ur_cell, vr_cell, & - hfx, qfx, & - tend_theta_euler, dynamics_substep ) - - -! else ! this is the original MPAS dissipation code -! -! call theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & -! nCells, nEdges, & -! nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & -! invAreaCell, invDcEdge, dvEdge, & -! meshScalingDel2, meshScalingDel4, & -! config_mix_full, t_init, zgrid, & -! rdzw, rdzu, & -! v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & -! delsq_theta, & -! theta_m, rho_edge, kdiff, rho_zz, & -! tend_theta_euler ) -! -! end if + call scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, fzm, fzp, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + prandtl_3d_inv, & + delsq_theta, & + theta_m, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + bn2, config_len_disp, scalars, tend_scalars, & + index_tke, index_qv, num_scalars, config_mix_scalars, & + config_les_model, config_les_surface, time_of_day_seconds,& + config_surface_heat_flux, config_surface_moisture_flux, & + ur_cell, vr_cell, & + hfx, qfx, & + tend_theta_euler, dynamics_substep ) end if ! theta mixing calculated first rk_step From fb5c14ad2969a0cab78e463a733f0d842f635771 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 4 Feb 2026 00:39:23 +0000 Subject: [PATCH 150/214] Set the Prandtl number back to 1.0 in mpas_constants The value of the Prandtl number had been changed to 1/3 during development of the initial LES capability for MPAS-Atmosphere. --- src/framework/mpas_constants.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/mpas_constants.F b/src/framework/mpas_constants.F index 5822f9c0e6..2c8168510a 100644 --- a/src/framework/mpas_constants.F +++ b/src/framework/mpas_constants.F @@ -53,7 +53,7 @@ module mpas_constants real (kind=RKIND), parameter :: cvpm = -cv / cp ! #endif real (kind=RKIND), parameter :: p0 = 1.0e5_RKIND !< Constant: 100000 Pa - real (kind=RKIND), parameter :: prandtl = 1.0_RKIND/3.0_RKIND !< Constant: Prandtl number + real (kind=RKIND), parameter :: prandtl = 1.0_RKIND !< Constant: Prandtl number contains From 128b96d067584164553a843554ebcaca1b68627c Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 4 Feb 2026 01:01:57 +0000 Subject: [PATCH 151/214] Remove unnecessary variables from the atmosphere core's restart stream This commit removes the following variables from the definition of the restart stream in the atmosphere core: deriv_two defc_a defc_b deformation_coef_c2 deformation_coef_s2 deformation_coef_cs deformation_coef_c deformation_coef_s coeffs_reconstruct east north These variables are either already indirectly included in the restart stream through the invariant stream or they are not needed in restart files. --- src/core_atmosphere/Registry.xml | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 5ac9420576..fa243580ca 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -629,17 +629,6 @@ #endif - - - - - - - - - - - From ce6c254b27481cc1cbc290b34a96e1d6a449ee84 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 4 Feb 2026 01:34:38 +0000 Subject: [PATCH 152/214] Move computation of time_of_day_seconds into flux_les_sas routine The logic to compute time_of_day_seconds was previously in the atm_compute_dyn_tend_work routine, though the time_of_day_seconds variable was only used in the commented-out routine flux_les_sas in the mpas_atm_dissipation_models module. In an attempt to keep the atm_compute_dyn_tend_work routine cleaner, this commit pushes the computation of time_of_day_seconds down to the flux_les_sas routine where it is actually used. In order to do this, the simulation clock and timestep, dt, are now passed as arguments to scalar_dissipation_3d_les and thereafter into flux_les_sas. --- .../dynamics/mpas_atm_dissipation_models.F | 25 ++++++++++++++----- .../dynamics/mpas_atm_time_integration.F | 14 ++--------- 2 files changed, 21 insertions(+), 18 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 1a5e642377..60814f8a20 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -14,7 +14,8 @@ module mpas_atm_dissipation_models use mpas_atmphys_constants use mpas_constants use mpas_log - use mpas_derived_types, only : MPAS_LOG_CRIT + use mpas_timekeeping, only : mpas_get_clock_time, mpas_get_time + use mpas_derived_types, only : MPAS_Clock_type, MPAS_Time_type, MPAS_NOW, MPAS_LOG_CRIT logical, parameter :: les_test = .true., les_sas_test = .false. !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour @@ -1069,7 +1070,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo eddy_visc_horz, eddy_visc_vert, & bv_freq2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars_dummy, mix_scalars, & - config_les_model, config_les_surface, time_of_day_seconds,& + config_les_model, config_les_surface, clock, dt, & config_surface_heat_flux, config_surface_moisture_flux, & uReconstructZonal, uReconstructMeridional, & hfx, qfx, & @@ -1090,7 +1091,6 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo integer, intent(in) :: index_tke, index_qv integer, intent(in) :: dynamics_substep - real (kind=RKIND), intent(in) :: time_of_day_seconds real (kind=RKIND), intent(in) :: config_surface_heat_flux real (kind=RKIND), intent(in) :: config_surface_moisture_flux @@ -1099,6 +1099,9 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo character (len=StrKIND) :: config_les_model character (len=StrKIND) :: config_les_surface + type (MPAS_Clock_type), intent(in) :: clock + real (kind=RKIND), intent(in) :: dt + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell @@ -1428,7 +1431,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo heat_flux = config_surface_heat_flux ! place holder routine for time-varying specified -! call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) +! call flux_les_sas( heat_flux, moisture_flux, clock, dt ) else if ( config_les_surface == "varying" ) then heat_flux = hfx(iCell)/rho_zz(1,iCell)/cp @@ -1508,18 +1511,28 @@ end subroutine scalar_dissipation_3d_les !----------- -! subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) +! subroutine flux_les_sas(heat_flux, moisture_flux, clock, dt) ! implicit none -! real (kind=RKIND), intent(in) :: time_of_day_seconds ! real (kind=RKIND), intent(out) :: heat_flux, moisture_flux +! type (MPAS_Clock_type), intent(in) :: clock +! real (kind=RKIND), intent(in) :: dt ! real (kind=RKIND), parameter:: t_start_t_flux = 3600.*6.0 ! real (kind=RKIND), parameter:: t_end_t_flux = 3600.*19.50 ! real (kind=RKIND), parameter:: t_start_q_flux = 3600.*7.0 ! real (kind=RKIND), parameter:: t_end_q_flux = 3600.*19.50 ! real (kind=RKIND) :: rel_time_t_flux, rel_time_q_flux +! real (kind=RKIND) :: time_of_day_seconds +! type (MPAS_Time_type) :: currTime +! integer :: H, M, S, S_n, S_d +! integer :: ierr + +! currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) +! call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) +! time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*dt +! call mpas_log_write(' les integration, timestep midpoint time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) ! rel_time_t_flux = max(0.,(time_of_day_seconds - t_start_t_flux)/(t_end_t_flux - t_start_t_flux)) ! rel_time_q_flux = max(0.,(time_of_day_seconds - t_start_q_flux)/(t_end_q_flux - t_start_q_flux)) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index c063760f36..25179e987c 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -23,7 +23,7 @@ module atm_time_integration use mpas_vector_reconstruction ! Added only clause to keep xlf90 from getting confused from the overloaded abs intrinsic in mpas_timekeeping use mpas_derived_types, only : MPAS_Time_type, MPAS_TimeInterval_type, MPAS_NOW - use mpas_timekeeping, only: mpas_get_clock_time, mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+) + use mpas_timekeeping, only: mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+) use mpas_timer #ifdef DO_PHYSICS @@ -5287,11 +5287,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm logical, parameter :: perturbation_coriolis = .true. real (kind=RKIND) :: reference_u - type (MPAS_Time_Type) :: currTime - integer :: H, M, S, S_n, S_d - integer :: ierr - real(kind=RKIND) :: time_of_day_seconds - flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ua*( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 @@ -5410,11 +5405,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) - - currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) - call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) - time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*dt - ! call mpas_log_write(' les integration, timestep midpoint time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) call les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & u, v, ur_cell, vr_cell, & @@ -5938,7 +5928,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eddy_visc_horz, eddy_visc_vert, & bn2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars, config_mix_scalars, & - config_les_model, config_les_surface, time_of_day_seconds,& + config_les_model, config_les_surface, clock, dt, & config_surface_heat_flux, config_surface_moisture_flux, & ur_cell, vr_cell, & hfx, qfx, & From b2a744955964ddacc1c3f66c174ed6422014dc97 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 4 Feb 2026 16:48:49 -0700 Subject: [PATCH 153/214] Fix implementation of "CAM-MPAS" 2nd-order horizontal filter The implementation of the "CAM-MPAS" 2nd-order horizontal filter contained code to place a lower-bound on the 'kdiff' variable, which is no longer used, and it also included out-dated code to apply the filter over only the top three layers in the model. This commit updates the filter code (active when config_mpas_cam_coef > 0.0) so that it correctly enforces a lower-bound on 'eddy_visc_horz' over a variable number of layers below the model top. As part of the changes in this commit, the variable 'kdiff' can be removed entirely from the atmosphere core, as it has been supplanted by the 'eddy_visc_horz' variable. --- src/core_atmosphere/Registry.xml | 3 --- .../dynamics/mpas_atm_time_integration.F | 15 ++++----------- 2 files changed, 4 insertions(+), 14 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index fa243580ca..a0a94ad03c 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1973,9 +1973,6 @@ - - diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 25179e987c..4307dca8f0 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4820,7 +4820,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save + h_divergence, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save real (kind=RKIND), dimension(:,:), pointer :: eddy_visc_horz, eddy_visc_vert @@ -4929,7 +4929,6 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys call mpas_pool_get_array(diag, 'rho_p', rr) call mpas_pool_get_array(diag, 'rho_p_save', rr_save) call mpas_pool_get_array(diag, 'v', v) - call mpas_pool_get_array(diag, 'kdiff', kdiff) call mpas_pool_get_array(diag, 'eddy_visc_horz', eddy_visc_horz) call mpas_pool_get_array(diag, 'eddy_visc_vert', eddy_visc_vert) call mpas_pool_get_array(diag, 'bn2', bn2) @@ -5060,7 +5059,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, index_tke, & + h_divergence, bn2, eddy_visc_horz, eddy_visc_vert, index_tke, & edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & @@ -5095,7 +5094,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, index_tke, & + h_divergence, bn2, eddy_visc_horz, eddy_visc_vert, index_tke, & edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & @@ -5164,7 +5163,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: zxu real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: cqu real (kind=RKIND), dimension(nVertLevels,nCells+1) :: h_divergence - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: kdiff real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_horz real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1) :: bn2 @@ -5309,7 +5307,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc enter data create(tend_theta_euler) !$acc enter data create(tend_rho) - !$acc enter data create(kdiff) !$acc enter data copyin(tend_rho_physics) !$acc enter data copyin(rb, rr_save) !$acc enter data copyin(divergence, vorticity) @@ -5431,11 +5428,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm do k = nVertLevels-config_number_cam_damping_levels + 1, nVertLevels visc2cam = 4.0*2.0833*config_len_disp*config_mpas_cam_coef visc2cam = visc2cam*(1.0-real(nVertLevels-k)/real(config_number_cam_damping_levels)) - kdiff(k ,iCell) = max(kdiff(k ,iCell),visc2cam) + eddy_visc_horz(k,iCell) = max(eddy_visc_horz(k,iCell),visc2cam) end do - eddy_visc_horz(nVertLevels-2,iCell) = max(eddy_visc_horz(nVertLevels-2,iCell), 2.0833*config_len_disp*config_mpas_cam_coef) - eddy_visc_horz(nVertLevels-1,iCell) = max(eddy_visc_horz(nVertLevels-1,iCell),2.0*2.0833*config_len_disp*config_mpas_cam_coef) - eddy_visc_horz(nVertLevels ,iCell) = max(eddy_visc_horz(nVertLevels ,iCell),4.0*2.0833*config_len_disp*config_mpas_cam_coef) end do !$acc end parallel @@ -5999,7 +5993,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc exit data copyout(tend_theta_euler) !$acc exit data copyout(tend_rho) - !$acc exit data delete(kdiff) !$acc exit data delete(tend_rho_physics) !$acc exit data delete(rb, rr_save) !$acc exit data delete(divergence, vorticity) From dc9c0d799783459552e39881026e3966119dd202 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 25 Feb 2026 14:27:40 -0700 Subject: [PATCH 154/214] Use integer comparisons for config_les_model and config_les_surface Rather than comparing strings, this commit introduces changes to allow for integer comparisons when checking the LES model option and LES surface option. The mpas_atm_dissipation_models module now contains two new functions, les_model_from_string and les_surface_from_string, that translate character strings from the namelist options config_les_model and config_les_surface, respectively, into integer parameters. These two new functions are used in the atm_compute_dyn_tend routine to obtain integer values representing the runtime selection of LES model option and LES surface option, and these integers are employed thereafter. --- .../dynamics/mpas_atm_dissipation_models.F | 149 +++++++++++++----- .../dynamics/mpas_atm_time_integration.F | 39 +++-- 2 files changed, 136 insertions(+), 52 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 60814f8a20..450ed045c1 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -28,10 +28,95 @@ module mpas_atm_dissipation_models ! real (kind=RKIND), parameter :: c_k = 0.1 real (kind=RKIND), parameter :: c_k = 0.25 + integer, parameter :: LES_INVALID_OPT = -1 + + integer, parameter :: LES_MODEL_NONE = 0, & + LES_MODEL_3D_SMAGORINSKY = 1, & + LES_MODEL_PROGNOSTIC_15_ORDER = 2 + + integer, parameter :: LES_SURFACE_NONE = 0, & + LES_SURFACE_SPECIFIED = 1, & + LES_SURFACE_VARYING = 2 contains + !----------------------------------------------------------------------- + ! routine les_model_from_string + ! + !> \brief Converts an LES model option from a string to an integer parameter + !> \author Michael Duda + !> \date 13 February 2026 + !> \details + !> Given a string that contains the name of a valid LES model option, this + !> routine returns an integer parameter corresponding to that option. + !> + !> If the given string is not recognized as a valid LES model option, the + !> integer parameter LES_INVALID_OPT is returned. + ! + !----------------------------------------------------------------------- + pure function les_model_from_string(les_model_str) result(les_model_opt) + + implicit none + + ! Arguments + character(len=*), intent(in) :: les_model_str + + ! Return value + integer :: les_model_opt + + + if (trim(les_model_str) == 'none') then + les_model_opt = LES_MODEL_NONE + else if (trim(les_model_str) == '3d_smagorinsky') then + les_model_opt = LES_MODEL_3D_SMAGORINSKY + else if (trim(les_model_str) == 'prognostic_1.5_order') then + les_model_opt = LES_MODEL_PROGNOSTIC_15_ORDER + else + les_model_opt = LES_INVALID_OPT + end if + + end function les_model_from_string + + + !----------------------------------------------------------------------- + ! routine les_surface_from_string + ! + !> \brief Converts an LES surface option from a string to an integer parameter + !> \author Michael Duda + !> \date 13 February 2026 + !> \details + !> Given a string that contains the name of a valid LES surface option, this + !> routine returns an integer parameter corresponding to that option. + !> + !> If the given string is not recognized as a valid LES surface option, the + !> integer parameter LES_INVALID_OPT is returned. + ! + !----------------------------------------------------------------------- + pure function les_surface_from_string(les_surface_str) result(les_surface_opt) + + implicit none + + ! Arguments + character(len=*), intent(in) :: les_surface_str + + ! Return value + integer :: les_surface_opt + + + if (trim(les_surface_str) == 'none') then + les_surface_opt = LES_SURFACE_NONE + else if (trim(les_surface_str) == 'specified') then + les_surface_opt = LES_SURFACE_SPECIFIED + else if (trim(les_surface_str) == 'varying') then + les_surface_opt = LES_SURFACE_VARYING + else + les_surface_opt = LES_INVALID_OPT + end if + + end function les_surface_from_string + + subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & @@ -121,7 +206,7 @@ end subroutine smagorinsky_2d !--------------------------------------- - subroutine les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & + subroutine les_models( les_model_opt, les_surface_opt, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & u, v, uCell, vCell, & w, c_s, bv_freq2, zgrid, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & @@ -133,8 +218,8 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e implicit none - character (len=StrKIND), intent(in) :: config_les_model - character (len=StrKIND), intent(in) :: config_les_surface + integer, intent(in) :: les_model_opt + integer, intent(in) :: les_surface_opt integer, intent(in) :: cellStart, cellEnd, nCells, nEdges, nVertLevels, maxEdges, index_tke, num_scalars integer, intent(in) :: dynamics_substep @@ -180,10 +265,6 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e ! real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 - DEBUG_WRITE(' begin les_models ') - DEBUG_WRITE(' les scheme is '//trim(config_les_model)) - DEBUG_WRITE(' les surface scheme is '//trim(config_les_surface)) - !$acc enter data create(dudx, dudy, dvdx, dvdy, dwdx, dwdy, dudz, dvdz, dwdz) !$acc enter data create(d_11, d_22, d_33, d_12, d_13, d_23) @@ -278,7 +359,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e d_23(k) = dwdy(k) + dvdz(k) end do - if (config_les_model == "3d_smagorinsky") then + if (les_model_opt == LES_MODEL_3D_SMAGORINSKY) then !$acc loop vector do k=1, nVertLevels @@ -290,7 +371,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e ! eddy_visc_vert(k,iCell) = eddy_visc_horz(k,iCell) end do - else if (config_les_model == "prognostic_1.5_order") then + else if (les_model_opt == LES_MODEL_PROGNOSTIC_15_ORDER) then !$acc loop vector do k=1,nVertLevels ! bound the tke here, currently hardwired @@ -364,7 +445,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e !MGD call mpas_log_write(' in les_models, no les scheme for '//trim(config_les_model), messageType=MPAS_LOG_CRIT) - end if ! end of config_les_model test + end if ! end of les_model_opt test end do ! loop over all owned cells (columns) @@ -485,7 +566,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & config_del4u_div_factor, zgrid, & eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & - fzm, fzp, config_les_model, config_les_surface, & + fzm, fzp, les_model_opt, les_surface_opt, & config_surface_drag_coefficient, & delsq_u, delsq_vorticity, delsq_divergence, & u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, & @@ -501,8 +582,8 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v integer, intent(in) :: nCells, nEdges, nVertices logical, intent(in) :: config_mix_full - character (len=StrKIND) :: config_les_model - character (len=StrKIND) :: config_les_surface + integer, intent(in) :: les_model_opt + integer, intent(in) :: les_surface_opt integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge integer, dimension(2,nEdges+1), intent(in) :: verticesOnEdge @@ -568,9 +649,8 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND) :: velocity_magnitude real (kind=RKIND) :: tau_12_factor + DEBUG_WRITE(' begin u_dissipation_3d ') - DEBUG_WRITE(' les model is '//trim(config_les_model)) - DEBUG_WRITE(' les surface is '//trim(config_les_surface)) DEBUG_WRITE(' 4th order hyperviscosity is $r ' COMMA realArgs=(/h_mom_eddy_visc4/)) DEBUG_WRITE(' 4th order divergence factor is $r ' COMMA realArgs=(/config_del4u_div_factor/)) @@ -585,7 +665,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v !$acc parallel default(present) tau_12_factor = 0.0 - if(config_les_model /= 'none') tau_12_factor = 1.0 + if(les_model_opt /= LES_MODEL_NONE) tau_12_factor = 1.0 !$acc loop gang worker do iEdge=edgeStart,edgeEnd @@ -786,7 +866,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end if ! vertical mixing of horizontal momentum for les formulation - if ( config_les_model /= "none") then + if ( les_model_opt /= LES_MODEL_NONE ) then !$acc parallel default(present) @@ -812,11 +892,11 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) end do - if( config_les_surface == "specified" ) then + if( les_surface_opt == LES_SURFACE_SPECIFIED ) then velocity_magnitude = sqrt(u(1,iEdge)**2 + v(1,iEdge)**2) turb_vflux(1) = -rho_edge(1,iEdge)*config_surface_drag_coefficient*u(1,iEdge)*velocity_magnitude turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) - else if ( config_les_surface == "varying" ) then + else if ( les_surface_opt == LES_SURFACE_VARYING ) then ust_edge = 0.5*(ustm(cell1) + ustm(cell2)) velocity_magnitude = max(sqrt(u(1,iEdge)**2 + v(1,iEdge)**2),0.1) turb_vflux(1) = -rho_edge(1,iEdge)*ust_edge*ust_edge*(u(1,iEdge)/velocity_magnitude) @@ -859,7 +939,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, delsq_w, & w, rho_edge, rho_zz, divergence, zz, & eddy_visc_horz, eddy_visc_vert, & - config_les_model, config_les_surface, & + les_model_opt, les_surface_opt, & tend_w_euler ) @@ -879,8 +959,8 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge - character (len=StrKIND) :: config_les_model - character (len=StrKIND) :: config_les_surface + integer, intent(in) :: les_model_opt + integer, intent(in) :: les_surface_opt real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 @@ -913,6 +993,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, integer :: cell1, cell2, iEdge, iCell, i, k real (kind=RKIND) :: r_areaCell, edge_sign, w_turb_flux + ! !OMP BARRIER why is this openmp barrier here??? ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). @@ -922,8 +1003,6 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, DEBUG_WRITE(' begin w_dissipation_3d ') - DEBUG_WRITE(' les model is '//trim(config_les_model)) - DEBUG_WRITE(' les surface is '//trim(config_les_surface)) DEBUG_WRITE(' 4th order hyperviscosity is $r ' COMMA realArgs=(/h_mom_eddy_visc4/)) !$acc enter data create(turb_vflux) @@ -1020,7 +1099,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end if - if ( config_les_model /= "none") then + if ( les_model_opt /= LES_MODEL_NONE ) then !$acc parallel default(present) @@ -1070,7 +1149,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo eddy_visc_horz, eddy_visc_vert, & bv_freq2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars_dummy, mix_scalars, & - config_les_model, config_les_surface, clock, dt, & + les_model_opt, les_surface_opt, clock, dt, & config_surface_heat_flux, config_surface_moisture_flux, & uReconstructZonal, uReconstructMeridional, & hfx, qfx, & @@ -1096,8 +1175,8 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo logical, intent(in) :: config_mix_full, mix_scalars - character (len=StrKIND) :: config_les_model - character (len=StrKIND) :: config_les_surface + integer, intent(in) :: les_model_opt + integer, intent(in) :: les_surface_opt type (MPAS_Clock_type), intent(in) :: clock real (kind=RKIND), intent(in) :: dt @@ -1157,8 +1236,6 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo DEBUG_WRITE(' begin scalar_dissipation_3d ') - DEBUG_WRITE(' les model is '//trim(config_les_model)) - DEBUG_WRITE(' les surface is '//trim(config_les_surface)) DEBUG_WRITE(' 4th order hyperviscosity is $r ' COMMA realArgs=(/h_theta_eddy_visc4/)) if( mix_scalars .and. (dynamics_substep == 1)) call mpas_log_write(' scalar mixing on ') @@ -1373,7 +1450,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end if - if ( config_les_model /= "none") then + if ( les_model_opt /= LES_MODEL_NONE ) then !$acc parallel default(present) @@ -1384,7 +1461,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain turb_vflux(1) = 0. ! lower bc flux handled where ??? - if ( config_les_model == "3d_smagorinsky") then + if ( les_model_opt == LES_MODEL_3D_SMAGORINSKY ) then !$acc loop vector do k=2,nVertLevels prandtl_1d_inverse(k) = prandtl_inv @@ -1424,16 +1501,16 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! test boundary conditions for supercell and les test cases - if( config_les_surface == "specified" .or. config_les_surface == "varying" ) then + if( les_surface_opt == LES_SURFACE_SPECIFIED .or. les_surface_opt == LES_SURFACE_VARYING ) then - if( config_les_surface == "specified" ) then + if( les_surface_opt == LES_SURFACE_SPECIFIED ) then moisture_flux = config_surface_moisture_flux heat_flux = config_surface_heat_flux ! place holder routine for time-varying specified ! call flux_les_sas( heat_flux, moisture_flux, clock, dt ) - else if ( config_les_surface == "varying" ) then + else if ( les_surface_opt == LES_SURFACE_VARYING ) then heat_flux = hfx(iCell)/rho_zz(1,iCell)/cp moisture_flux = qfx(iCell)/rho_zz(1,iCell) endif @@ -1484,7 +1561,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do - if( config_les_surface == "specified" .or. config_les_surface == "varying" ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv + if( les_surface_opt == LES_SURFACE_SPECIFIED .or. les_surface_opt == LES_SURFACE_VARYING ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv !$acc loop vector collapse(2) do k=1,nVertLevels diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 4307dca8f0..644963c3e6 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4791,6 +4791,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + use mpas_atm_dissipation_models, only : les_model_from_string, les_surface_from_string + implicit none ! @@ -4868,6 +4870,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys character (len=StrKIND), pointer :: config_horiz_mixing character (len=StrKIND), pointer :: config_les_model character (len=StrKIND), pointer :: config_les_surface + integer :: les_model_opt, les_surface_opt real (kind=RKIND), pointer :: config_surface_heat_flux real (kind=RKIND), pointer :: config_surface_moisture_flux real (kind=RKIND), pointer :: config_surface_drag_coefficient @@ -5052,6 +5055,9 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys call mpas_pool_get_array(mesh, 'cf2', cf2) call mpas_pool_get_array(mesh, 'cf3', cf3) + les_model_opt = les_model_from_string(config_les_model) + les_surface_opt = les_surface_from_string(config_les_surface) + call atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels, & nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, index_qv, index_qc, moist_start, moist_end, & tend_scalars, & @@ -5066,8 +5072,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & - tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_mix_scalars, config_horiz_mixing, config_les_model, & - config_les_surface, prandtl_3d_inv, config_del4u_div_factor, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_mix_scalars, config_horiz_mixing, les_model_opt, & + les_surface_opt, prandtl_3d_inv, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dynamics_substep, dt, & config_mpas_cam_coef, & @@ -5101,8 +5107,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & - tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_mix_scalars, config_horiz_mixing, config_les_model, & - config_les_surface, prandtl_3d_inv, config_del4u_div_factor, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_mix_scalars, config_horiz_mixing, les_model_opt, & + les_surface_opt, prandtl_3d_inv, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dynamics_substep, dt, & config_mpas_cam_coef, & @@ -5115,6 +5121,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm use mpas_atm_dimensions + use mpas_atm_dissipation_models, only : LES_MODEL_NONE implicit none @@ -5225,8 +5232,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: coef_3rd_order, c_s logical :: config_mix_full, config_mix_scalars character (len=StrKIND) :: config_horiz_mixing - character (len=StrKIND) :: config_les_model - character (len=StrKIND) :: config_les_surface + integer, intent(in) :: les_model_opt + integer, intent(in) :: les_surface_opt real (kind=RKIND) :: config_surface_heat_flux real (kind=RKIND) :: config_surface_moisture_flux real (kind=RKIND) :: config_surface_drag_coefficient @@ -5297,7 +5304,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (perturbation_coriolis) then !$acc enter data copyin(u_init, v_init) end if - if (trim(config_les_model) /= 'none') then + if (les_model_opt /= LES_MODEL_NONE) then !$acc enter data copyin(exner, pressure_b, bn2) end if !$acc enter data copyin(ustm, hfx, qfx) @@ -5333,7 +5340,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc enter data copyin(rw_save, rt_diabatic_tend) !$acc enter data create(rthdynten) !$acc enter data copyin(t_init) - if (trim(config_les_model) /= 'none') then + if (les_model_opt /= LES_MODEL_NONE) then !$acc enter data copyin(ur_cell, vr_cell) else #ifdef CURVATURE @@ -5369,7 +5376,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! Smagorinsky eddy viscosity, based on horizontal deformation (in this case on model coordinate surfaces). ! The integration coefficients were precomputed and stored in deformation_coef_* - if(config_les_model == "none") then + if(les_model_opt == LES_MODEL_NONE) then if(config_horiz_mixing == "2d_smagorinsky") then @@ -5396,14 +5403,14 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end if - else if (config_les_model /= "none") then + else if (les_model_opt /= LES_MODEL_NONE) then ! call mpas_log_write(' BV call, index qv, qc, tke $i $i $i ', intArgs=(/index_qv, index_qc, index_tke/)) call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) - call les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & + call les_models( les_model_opt, les_surface_opt, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & u, v, ur_cell, vr_cell, & w, c_s, bn2, zgrid, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & @@ -5620,7 +5627,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & config_del4u_div_factor, zgrid, & eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & - fzm, fzp, config_les_model, config_les_surface, & + fzm, fzp, les_model_opt, les_surface_opt, & config_surface_drag_coefficient, & delsq_u, delsq_vorticity, delsq_divergence, & u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, tend_u_euler ) @@ -5762,7 +5769,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm delsq_w, & w, rho_edge, rho_zz, divergence, zz, & eddy_visc_horz, eddy_visc_vert, & - config_les_model, config_les_surface, & + les_model_opt, les_surface_opt, & tend_w_euler ) end if ! mixing for w computed in first rk_step @@ -5922,7 +5929,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eddy_visc_horz, eddy_visc_vert, & bn2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars, config_mix_scalars, & - config_les_model, config_les_surface, clock, dt, & + les_model_opt, les_surface_opt, clock, dt, & config_surface_heat_flux, config_surface_moisture_flux, & ur_cell, vr_cell, & hfx, qfx, & @@ -5982,7 +5989,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (perturbation_coriolis) then !$acc exit data delete(u_init, v_init) end if - if (trim(config_les_model) /= 'none') then + if (les_model_opt /= LES_MODEL_NONE) then !$acc exit data delete(exner, pressure_b) !$acc exit data copyout(bn2) end if @@ -6019,7 +6026,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc exit data delete(rw_save, rt_diabatic_tend) !$acc exit data copyout(rthdynten) !$acc exit data delete(t_init) - if (trim(config_les_model) /= 'none') then + if (les_model_opt /= LES_MODEL_NONE) then !$acc exit data delete(ur_cell, vr_cell) else #ifdef CURVATURE From 27c8b388688183364cffaa647e74565bec204c9d Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 24 Feb 2026 17:48:48 -0700 Subject: [PATCH 155/214] Revert init_atm_case_squall_line routine to v8.3.1 This commit reverts all changes to the init_atm_case_squall_line routine since the v8.3.1 tag. These changes are not strictly necessary to the initial LES capability, and for the present, the initialization case 10 (init_atm_case_les) is the only supported test case for use with LES options. --- .../mpas_init_atm_cases.F | 27 +++---------------- 1 file changed, 3 insertions(+), 24 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 9c372cb163..02b8391dbf 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -1429,11 +1429,10 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d integer, dimension(:), pointer :: nEdgesOnEdge integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge - real (kind=RKIND), pointer :: x_period, y_period + integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, nz1, itr, cell1, cell2 integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve integer, pointer :: index_qv - integer, pointer :: index_tke real (kind=RKIND), dimension(nVertLevels + 1 ) :: zc, zw, ah real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm @@ -1460,7 +1459,6 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d real (kind=RKIND), pointer :: nominalMinDc logical, pointer :: on_a_sphere real (kind=RKIND), pointer :: sphere_radius - real (kind=RKIND), pointer :: config_ztop real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta real (kind=RKIND), dimension(:), pointer :: u_init, qv_init, angleEdge, fEdge, fVertex @@ -1482,13 +1480,10 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) - - call mpas_pool_get_config(mesh, 'x_period', x_period) - call mpas_pool_get_config(mesh, 'y_period', y_period) + call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) call mpas_pool_get_config(configs, 'config_interface_projection', config_interface_projection) - call mpas_pool_get_config(configs, 'config_ztop', config_ztop) ! ! Scale all distances @@ -1511,8 +1506,6 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d areaTriangle(:) = areaTriangle(:) * a_scale**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 nominalMinDc = nominalMinDc * a_scale - x_period = x_period * a_scale - y_period = y_period * a_scale call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) @@ -1573,7 +1566,6 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d call mpas_pool_get_array(state, 'scalars', scalars) call mpas_pool_get_dimension(state, 'index_qv', index_qv) - call mpas_pool_get_dimension(state, 'index_tke', index_tke) scalars(:,:,:) = 0. @@ -1601,8 +1593,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d ! metrics for hybrid coordinate and vertical stretching str = 1.0 -! zt = 20000. - zt = config_ztop + zt = 20000. dz = zt/float(nz1) ! write(0,*) ' dz = ',dz @@ -1889,18 +1880,6 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) end do end do -! -! initial seed for tke -! -! call mpas_log_write('index_qv $i ', intArgs=(/index_qv/)) -! call mpas_log_write('index_tke $i ', intArgs=(/index_tke/)) - scalars(index_tke,:,:) = 0. - - do k = 1,nz1 - do i=1,nCells - scalars(index_tke,k,i) = 0.1 - end do - end do do itr=1,30 From e9d81de891bb9c22b0fd61452c6638a827f836f1 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 24 Feb 2026 17:54:36 -0700 Subject: [PATCH 156/214] Revert the init_atm_case_mtn_wave routine to v8.3.1 This commit reverts all changes to the init_atm_case_mtn_wave routine since the v8.3.1 tag. These changes are not strictly necessary to the initial LES capability, and they can be re-introduced separately in future. --- src/core_init_atmosphere/mpas_init_atm_cases.F | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 02b8391dbf..2629e9972d 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -2034,7 +2034,6 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag integer, dimension(:), pointer :: nEdgesOnEdge, nEdgesOnCell integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge, cellsOnCell real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge - real (kind=RKIND), pointer :: x_period, y_period integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, itr, cell1, cell2, nz1 integer, pointer :: nEdges, maxEdges, nCellsSolve, nVertices @@ -2093,8 +2092,6 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) - call mpas_pool_get_config(mesh, 'x_period', x_period) - call mpas_pool_get_config(mesh, 'y_period', y_period) call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) @@ -2136,8 +2133,6 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag areaTriangle(:) = areaTriangle(:) * a_scale**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 nominalMinDc = nominalMinDc * a_scale - x_period = x_period * a_scale - y_period = y_period * a_scale call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) From 493fd4b978f0e12b9949d34f0f953b9f3f6f6621 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 3 Mar 2026 20:30:13 +0000 Subject: [PATCH 157/214] Fix CMake builds by adding mpas_atm_dissipation_models.F to source file list MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This commit adds the file mpas_atm_dissipation_models.F to the definition of ATMOSPHERE_CORE_DYNAMICS_SOURCES in src/core_atmosphere/CMakeLists.txt . Without this change, builds of the MPAS atmosphere core using CMake would fail: MPAS-Model/src/core_atmosphere/dynamics/mpas_atm_time_integration.F:38:8: 38 | use mpas_atm_dissipation_models | 1 Fatal Error: Cannot open module file ‘mpas_atm_dissipation_models.mod’ for reading at (1): No such file or directory compilation terminated. --- src/core_atmosphere/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core_atmosphere/CMakeLists.txt b/src/core_atmosphere/CMakeLists.txt index 0667b67187..d98e0d5aeb 100644 --- a/src/core_atmosphere/CMakeLists.txt +++ b/src/core_atmosphere/CMakeLists.txt @@ -335,6 +335,7 @@ list(TRANSFORM ATMOSPHERE_CORE_DIAGNOSTIC_SOURCES PREPEND diagnostics/) # dynamics/ set(ATMOSPHERE_CORE_DYNAMICS_SOURCES mpas_atm_boundaries.F + mpas_atm_dissipation_models.F mpas_atm_iau.F mpas_atm_time_integration.F) list(TRANSFORM ATMOSPHERE_CORE_DYNAMICS_SOURCES PREPEND dynamics/) From 66517f6013fccc482805e4c98d5e6beb38fbafb6 Mon Sep 17 00:00:00 2001 From: Daniel Rosen Date: Wed, 4 Feb 2026 12:03:05 -0700 Subject: [PATCH 158/214] Add MPAS_ESMF to Makefile opts for external ESMF - MPAS_ESMF=embedded (default), uses internal ESMF timekeeping lib - MPAS_ESMF=external, uses external ESMF lib defined by ESMFMKFILE - Replaces hardcoded esmf_time_f90 include with MPAS_ESMF_INC - Replaces hardcoded esmf_time lib with MPAS_ESMF_LIBS --- Makefile | 22 +++++++++++++++++++ src/Makefile | 2 +- src/core_atmosphere/Makefile | 4 ++-- src/core_atmosphere/chemistry/Makefile | 4 ++-- src/core_atmosphere/chemistry/musica/Makefile | 4 ++-- src/core_atmosphere/diagnostics/Makefile | 4 ++-- src/core_atmosphere/dynamics/Makefile | 4 ++-- src/core_atmosphere/physics/Makefile | 4 ++-- .../physics_noahmp/drivers/mpas/Makefile | 2 +- .../physics/physics_wrf/Makefile | 4 ++-- src/core_atmosphere/utils/Makefile | 6 ++--- src/core_init_atmosphere/Makefile | 4 ++-- src/core_landice/Makefile | 2 +- src/core_ocean/Makefile | 2 +- src/core_seaice/analysis_members/Makefile | 6 ++--- src/core_seaice/model_forward/Makefile | 4 ++-- src/core_seaice/shared/Makefile | 4 ++-- src/core_sw/Makefile | 4 ++-- src/core_test/Makefile | 4 ++-- src/driver/Makefile | 4 ++-- src/external/Makefile | 8 ++++++- src/framework/Makefile | 4 ++-- src/operators/Makefile | 4 ++-- 23 files changed, 69 insertions(+), 41 deletions(-) diff --git a/Makefile b/Makefile index 36fef81853..07ba5f9556 100644 --- a/Makefile +++ b/Makefile @@ -685,6 +685,24 @@ CPPINCLUDES = FCINCLUDES = LIBS = +export MPAS_ESMF ?= embedded +ifeq "$(MPAS_ESMF)" "external" + ifeq ($(wildcard $(ESMFMKFILE)), ) + $(error ESMFMKFILE must be set if MPAS_ESMF=external) + endif + include $(ESMFMKFILE) + export MPAS_ESMF_INC = $(ESMF_F90COMPILEPATHS) + export MPAS_ESMF_LIB = $(ESMF_F90LINKPATHS) $(ESMF_F90ESMFLINKPATHS) $(ESMF_F90ESMFLINKLIBS) + override CPPFLAGS += -DMPAS_EXTERNAL_ESMF_LIB=true + ESMF_MESSAGE="MPAS was built with an external ESMF library using ESMFMKFILE" +else ifeq "$(MPAS_ESMF)" "embedded" + export MPAS_ESMF_INC = -I$(PWD)/src/external/esmf_time_f90 + export MPAS_ESMF_LIB = -L$(PWD)/src/external/esmf_time_f90 -lesmf_time + ESMF_MESSAGE="MPAS was built with the embedded ESMF timekeeping library." +else + $(error Invalid MPAS_ESMF option: $(MPAS_ESMF) - valid options "embedded", "external") +endif + ifneq "$(PIO)" "" # # Regardless of PIO library version, look for a lib subdirectory of PIO path @@ -1563,6 +1581,7 @@ endif @echo $(GEN_F90_MESSAGE) @echo $(TIMER_MESSAGE) @echo $(IO_MESSAGE) + @echo $(ESMF_MESSAGE) @echo "*******************************************************************************" clean: cd src; $(MAKE) clean RM="$(RM)" CORE="$(CORE)" AUTOCLEAN="$(AUTOCLEAN)" @@ -1619,6 +1638,9 @@ errmsg: @echo " OPENACC=true - builds and links with OpenACC flags. Default is to not use OpenACC." @echo " PRECISION=double - builds with default double-precision real kind. Default is to use single-precision." @echo " SHAREDLIB=true - generate position-independent code suitable for use in a shared library. Default is false." + @echo " MPAS_ESMF=opt - Selects the ESMF library to be used for MPAS. Options are:" + @echo " MPAS_ESMF=embedded - Use the embedded ESMF timekeeping library (default)" + @echo " MPAS_ESMF=external - Use an external ESMF library, determined by ESMFMKFILE" @echo "" @echo "Ensure that NETCDF, PNETCDF, PIO, and PAPI (if USE_PAPI=true) are environment variables" @echo "that point to the absolute paths for the libraries." diff --git a/src/Makefile b/src/Makefile index b9c037c8cc..c06a592d95 100644 --- a/src/Makefile +++ b/src/Makefile @@ -9,7 +9,7 @@ else all: mpas mpas: $(AUTOCLEAN_DEPS) externals frame ops dycore drver - $(LINKER) $(LDFLAGS) -o $(EXE_NAME) driver/*.o -L. -ldycore -lops -lframework $(LIBS) -I./external/esmf_time_f90 -L./external/esmf_time_f90 -lesmf_time + $(LINKER) $(LDFLAGS) -o $(EXE_NAME) driver/*.o -L. -ldycore -lops -lframework $(LIBS) $(MPAS_ESMF_INC) $(MPAS_ESMF_LIB) externals: $(AUTOCLEAN_DEPS) ( cd external; $(MAKE) FC="$(FC)" SFC="$(SFC)" CC="$(CC)" SCC="$(SCC)" FFLAGS="$(FFLAGS)" CFLAGS="$(CFLAGS)" CPP="$(CPP)" NETCDF="$(NETCDF)" CORE="$(CORE)" all ) diff --git a/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index 9c3a58686e..e7d5e9a2fe 100644 --- a/src/core_atmosphere/Makefile +++ b/src/core_atmosphere/Makefile @@ -95,7 +95,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(PHYSICS) $(CHEMISTRY) $(CPPINCLUDES) -I./inc $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I./physics/physics_mmm -I./physics/physics_noaa/UGWP -I../external/esmf_time_f90 -I./chemistry + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I./physics/physics_mmm -I./physics/physics_noaa/UGWP $(MPAS_ESMF_INC) -I./chemistry else - $(FC) $(CPPFLAGS) $(PHYSICS) $(CHEMISTRY) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./inc -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I./physics/physics_mmm -I./physics/physics_noaa/UGWP -I../external/esmf_time_f90 -I./chemistry + $(FC) $(CPPFLAGS) $(PHYSICS) $(CHEMISTRY) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./inc -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I./physics/physics_mmm -I./physics/physics_noaa/UGWP $(MPAS_ESMF_INC) -I./chemistry endif diff --git a/src/core_atmosphere/chemistry/Makefile b/src/core_atmosphere/chemistry/Makefile index 6293e231a8..7ea503e5b6 100644 --- a/src/core_atmosphere/chemistry/Makefile +++ b/src/core_atmosphere/chemistry/Makefile @@ -41,7 +41,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./musica -I.. -I../../framework -I../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./musica -I.. -I../../framework $(MPAS_ESMF_INC) else - $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./musica -I.. -I../../framework -I../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./musica -I.. -I../../framework $(MPAS_ESMF_INC) endif diff --git a/src/core_atmosphere/chemistry/musica/Makefile b/src/core_atmosphere/chemistry/musica/Makefile index 3a11055c77..c5bd89cc21 100644 --- a/src/core_atmosphere/chemistry/musica/Makefile +++ b/src/core_atmosphere/chemistry/musica/Makefile @@ -24,8 +24,8 @@ clean: .F.o: ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../../framework $(MPAS_ESMF_INC) else - $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../../framework $(MPAS_ESMF_INC) endif diff --git a/src/core_atmosphere/diagnostics/Makefile b/src/core_atmosphere/diagnostics/Makefile index 614bc1c137..a3d2e4dcda 100644 --- a/src/core_atmosphere/diagnostics/Makefile +++ b/src/core_atmosphere/diagnostics/Makefile @@ -41,7 +41,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators -I../dynamics -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators -I../dynamics -I../physics -I../physics/physics_wrf $(MPAS_ESMF_INC) else - $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../framework -I../../operators -I../dynamics -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../framework -I../../operators -I../dynamics -I../physics -I../physics/physics_wrf $(MPAS_ESMF_INC) endif diff --git a/src/core_atmosphere/dynamics/Makefile b/src/core_atmosphere/dynamics/Makefile index 1bf21fff9d..bf42768edd 100644 --- a/src/core_atmosphere/dynamics/Makefile +++ b/src/core_atmosphere/dynamics/Makefile @@ -21,7 +21,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../physics/physics_mmm -I../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../physics/physics_mmm $(MPAS_ESMF_INC) else - $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../physics/physics_mmm -I../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../physics/physics_mmm $(MPAS_ESMF_INC) endif diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index 75eec25931..ac5ff5d6f3 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -262,7 +262,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(HYDROSTATIC) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I.. -I../../framework -I../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I.. -I../../framework $(MPAS_ESMF_INC) else - $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I./physics_noaa/UGWP -I.. -I../../framework -I../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I./physics_noaa/UGWP -I.. -I../../framework $(MPAS_ESMF_INC) endif diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/Makefile b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/Makefile index 5f816fff44..034930ee05 100644 --- a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/Makefile +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/Makefile @@ -70,5 +70,5 @@ clean: $(RM) *.i .F90.o: - $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F90 $(CPPINCLUDES) $(FCINCLUDES) -I. -I../../utility -I../../src -I../../../../../framework -I../../../../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F90 $(CPPINCLUDES) $(FCINCLUDES) -I. -I../../utility -I../../src -I../../../../../framework $(MPAS_ESMF_INC) diff --git a/src/core_atmosphere/physics/physics_wrf/Makefile b/src/core_atmosphere/physics/physics_wrf/Makefile index 4495b74960..2c4d0079ef 100644 --- a/src/core_atmosphere/physics/physics_wrf/Makefile +++ b/src/core_atmosphere/physics/physics_wrf/Makefile @@ -123,7 +123,7 @@ clean: .F.o: ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../physics_mmm -I../../../framework -I../../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../physics_mmm -I../../../framework $(MPAS_ESMF_INC) else - $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../physics_mmm -I../physics_noaa/UGWP -I../../../framework -I../../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../physics_mmm -I../physics_noaa/UGWP -I../../../framework $(MPAS_ESMF_INC) endif diff --git a/src/core_atmosphere/utils/Makefile b/src/core_atmosphere/utils/Makefile index 39765f9ee9..8166210d89 100644 --- a/src/core_atmosphere/utils/Makefile +++ b/src/core_atmosphere/utils/Makefile @@ -7,7 +7,7 @@ endif all: $(UTILS) build_tables: build_tables.o atmphys_build_tables_thompson.o - $(LINKER) $(LDFLAGS) -o build_tables build_tables.o atmphys_build_tables_thompson.o -L../../framework -L../physics -lphys -lframework $(LIBS) -L../../external/esmf_time_f90 -lesmf_time + $(LINKER) $(LDFLAGS) -o build_tables build_tables.o atmphys_build_tables_thompson.o -L../../framework -L../physics -lphys -lframework $(LIBS) $(MPAS_ESMF_LIBS) mv build_tables ../../.. @@ -27,7 +27,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators -I../physics -I../physics/physics_mmm -I../physics/physics_wrf -I../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators -I../physics -I../physics/physics_mmm -I../physics/physics_wrf $(MPAS_ESMF_INC) else - $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../framework -I../../operators -I../physics -I../physics/physics_mmm -I../physics/physics_wrf -I../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../framework -I../../operators -I../physics -I../physics/physics_mmm -I../physics/physics_wrf $(MPAS_ESMF_INC) endif diff --git a/src/core_init_atmosphere/Makefile b/src/core_init_atmosphere/Makefile index f0c08a1ca9..3057a4cc07 100644 --- a/src/core_init_atmosphere/Makefile +++ b/src/core_init_atmosphere/Makefile @@ -134,9 +134,9 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(CPPINCLUDES) -I./inc $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators $(MPAS_ESMF_INC) else - $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./inc -I../framework -I../operators -I../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./inc -I../framework -I../operators $(MPAS_ESMF_INC) endif .c.o: diff --git a/src/core_landice/Makefile b/src/core_landice/Makefile index 89280f29e4..572112f291 100644 --- a/src/core_landice/Makefile +++ b/src/core_landice/Makefile @@ -2,7 +2,7 @@ .SUFFIXES: .F .o .cpp .PHONY: mode_forward shared analysis_members -SHARED_INCLUDES = -I$(PWD)/../framework -I$(PWD)/../external/esmf_time_f90 -I$(PWD)/../operators +SHARED_INCLUDES = -I$(PWD)/../framework $(MPAS_ESMF_INC) -I$(PWD)/../operators SHARED_INCLUDES += -I$(PWD)/shared -I$(PWD)/analysis_members -I$(PWD)/mode_forward all: core_landice diff --git a/src/core_ocean/Makefile b/src/core_ocean/Makefile index a793d09603..6108b90395 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -1,7 +1,7 @@ .SUFFIXES: .F .c .o -OCEAN_SHARED_INCLUDES = -I$(PWD)/../framework -I$(PWD)/../external/esmf_time_f90 -I$(PWD)/../operators +OCEAN_SHARED_INCLUDES = -I$(PWD)/../framework $(MPAS_ESMF_INC) -I$(PWD)/../operators OCEAN_SHARED_INCLUDES += -I$(PWD)/BGC -I$(PWD)/shared -I$(PWD)/analysis_members -I$(PWD)/cvmix -I$(PWD)/mode_forward -I$(PWD)/mode_analysis -I$(PWD)/mode_init all: shared libcvmix analysis_members libBGC diff --git a/src/core_seaice/analysis_members/Makefile b/src/core_seaice/analysis_members/Makefile index 4999f0382a..2da2ca7074 100644 --- a/src/core_seaice/analysis_members/Makefile +++ b/src/core_seaice/analysis_members/Makefile @@ -19,10 +19,10 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 -I../../external/esmf_time_f90 -I../../framework -I../../operators -I../column -I../shared -I../model_forward $(FCINCLUDES) + $(FC) $(FFLAGS) -c $*.f90 $(MPAS_ESMF_INC) -I../../framework -I../../operators -I../column -I../shared -I../model_forward $(FCINCLUDES) else - $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F -I../../external/esmf_time_f90 -I../../framework -I../../operators -I../column -I../shared -I../model_forward $(CPPINCLUDES) $(FCINCLUDES) + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(MPAS_ESMF_INC) -I../../framework -I../../operators -I../column -I../shared -I../model_forward $(CPPINCLUDES) $(FCINCLUDES) endif .c.o: - $(CC) $(CPPFLAGS) $(CFLAGS) $(CINCLUDES) -I../../external/esmf_time_f90 -I../../framework -I../../operators -I../column -I../shared -I../model_forward -c $< + $(CC) $(CPPFLAGS) $(CFLAGS) $(CINCLUDES) $(MPAS_ESMF_INC) -I../../framework -I../../operators -I../column -I../shared -I../model_forward -c $< diff --git a/src/core_seaice/model_forward/Makefile b/src/core_seaice/model_forward/Makefile index 523922976e..1ee3fbd52d 100644 --- a/src/core_seaice/model_forward/Makefile +++ b/src/core_seaice/model_forward/Makefile @@ -23,7 +23,7 @@ endif ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS_noSMP) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators -I../../external/esmf_time_f90 -I../column -I../shared + $(FC) $(FFLAGS_noSMP) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators $(MPAS_ESMF_INC) -I../column -I../shared else - $(FC) $(CPPFLAGS) $(FFLAGS_noSMP) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../framework -I../../operators -I../../external/esmf_time_f90 -I../column -I../shared + $(FC) $(CPPFLAGS) $(FFLAGS_noSMP) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../framework -I../../operators $(MPAS_ESMF_INC) -I../column -I../shared endif diff --git a/src/core_seaice/shared/Makefile b/src/core_seaice/shared/Makefile index 0f0cf3827e..bdb9b181d3 100644 --- a/src/core_seaice/shared/Makefile +++ b/src/core_seaice/shared/Makefile @@ -85,7 +85,7 @@ clean: ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators -I../../external/esmf_time_f90 -I../column + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators $(MPAS_ESMF_INC) -I../column else - $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../framework -I../../operators -I../../external/esmf_time_f90 -I../column + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../framework -I../../operators $(MPAS_ESMF_INC) -I../column endif diff --git a/src/core_sw/Makefile b/src/core_sw/Makefile index 34ccfe5bce..038ca62bfe 100644 --- a/src/core_sw/Makefile +++ b/src/core_sw/Makefile @@ -55,7 +55,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 -Iinc + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators $(MPAS_ESMF_INC) -Iinc else - $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 -Iinc + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../framework -I../operators $(MPAS_ESMF_INC) -Iinc endif diff --git a/src/core_test/Makefile b/src/core_test/Makefile index e11e5dbb50..ab90084721 100644 --- a/src/core_test/Makefile +++ b/src/core_test/Makefile @@ -67,7 +67,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators $(MPAS_ESMF_INC) else - $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../framework -I../operators $(MPAS_ESMF_INC) endif diff --git a/src/driver/Makefile b/src/driver/Makefile index 8e041c8f70..9ac55e5022 100644 --- a/src/driver/Makefile +++ b/src/driver/Makefile @@ -23,7 +23,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I../core_$(CORE) -I../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I../core_$(CORE) $(MPAS_ESMF_INC) else - $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../framework -I../operators -I../core_$(CORE) -I../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../framework -I../operators -I../core_$(CORE) $(MPAS_ESMF_INC) endif diff --git a/src/external/Makefile b/src/external/Makefile index 9f048d3880..b6161562e8 100644 --- a/src/external/Makefile +++ b/src/external/Makefile @@ -1,6 +1,12 @@ .SUFFIXES: .F .c .o -all: esmf_time ezxml-lib smiol-lib +EMBEDDED_LIBS= +ifeq "$(MPAS_ESMF)" "embedded" + EMBEDDED_LIBS += esmf_time +endif +EMBEDDED_LIBS += ezxml-lib smiol-lib + +all: $(EMBEDDED_LIBS) esmf_time: ( cd esmf_time_f90; $(MAKE) FC="$(FC)" FFLAGS="$(FFLAGS)" CPP="$(CPP)" CPPFLAGS="$(CPPFLAGS) -DHIDE_MPI" GEN_F90=$(GEN_F90) ) diff --git a/src/framework/Makefile b/src/framework/Makefile index 0e5f792b5e..29f05f3b12 100644 --- a/src/framework/Makefile +++ b/src/framework/Makefile @@ -128,9 +128,9 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) $(MPAS_ESMF_INC) else - $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) $(MPAS_ESMF_INC) endif .c.o: diff --git a/src/operators/Makefile b/src/operators/Makefile index b4d7085e90..6a3d1301e7 100644 --- a/src/operators/Makefile +++ b/src/operators/Makefile @@ -39,7 +39,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework $(MPAS_ESMF_INC) else - $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../framework -I../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../framework $(MPAS_ESMF_INC) endif From 116cb426c570bb544f0643bc7ea796b939b8893e Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Mon, 10 Nov 2025 10:12:29 -0700 Subject: [PATCH 159/214] MICM configuration is now driven by a MUSICA namelist option with added logging Registry.xml: Added a MUSICA namelist record gated by MPAS_USE_MUSICA with the `config_micm_file` option so the MICM JSON path can be provided through the standard configuration system. mpas_atm_chemistry.F: Removed the hardcoded `chapman.json`, pull the MICM file path from the configs pool, then propagate errors from `musica_init` via `mpas_log_write` to fail when initialization breaks. mpas_musica.F: Track the species description pointer and log each MICM species name from `state%species_ordering` so users can verify the runtime mapping. --- src/core_atmosphere/Registry.xml | 9 ++++++++ .../chemistry/mpas_atm_chemistry.F | 22 ++++++++++--------- .../chemistry/musica/mpas_musica.F | 22 ++++++++++++++++++- 3 files changed, 42 insertions(+), 11 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 4281c40bba..88c0b0928d 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -394,6 +394,15 @@ possible_values="`mpas_dmpar', `mpas_halo'"/> +#ifdef MPAS_USE_MUSICA + + + +#endif + diff --git a/src/core_atmosphere/chemistry/mpas_atm_chemistry.F b/src/core_atmosphere/chemistry/mpas_atm_chemistry.F index 39715cf37a..7fda1f27a8 100644 --- a/src/core_atmosphere/chemistry/mpas_atm_chemistry.F +++ b/src/core_atmosphere/chemistry/mpas_atm_chemistry.F @@ -43,7 +43,7 @@ subroutine chemistry_init(configs, dimensions) use mpas_musica, only: musica_init #endif use mpas_log, only : mpas_log_write - use mpas_derived_types, only: mpas_pool_type + use mpas_derived_types, only: mpas_pool_type, MPAS_LOG_CRIT use mpas_kind_types, only: StrKIND use mpas_pool_routines, only: mpas_pool_get_config, mpas_pool_get_dimension @@ -51,13 +51,11 @@ subroutine chemistry_init(configs, dimensions) type (mpas_pool_type), intent(in) :: dimensions #ifdef MPAS_USE_MUSICA - integer :: error_code - character(len=:), allocatable :: error_message - integer :: nVertLevels - integer, pointer :: nVertLevels_ptr - ! MUSICA will get the MICM JSON config from a namelist - ! hardcode filepath for now - character(len=StrKIND) :: filepath = 'chapman.json' + character(len=StrKIND), pointer :: filepath_ptr + integer :: error_code + character(len=:), allocatable :: error_message + integer :: nVertLevels + integer, pointer :: nVertLevels_ptr #endif call mpas_log_write('Initializing chemistry packages...') @@ -66,9 +64,13 @@ subroutine chemistry_init(configs, dimensions) call mpas_pool_get_dimension(dimensions, 'nVertLevels', nVertLevels_ptr) nVertLevels = nVertLevels_ptr - call musica_init(filepath, nVertLevels, error_code, error_message) + call mpas_pool_get_config(configs, 'config_micm_file', filepath_ptr) - ! TODO check error_code and generate MPAS error log message + call musica_init(filepath_ptr, nVertLevels, error_code, error_message) + + if (error_code /= 0) then + call mpas_log_write(error_message, messageType=MPAS_LOG_CRIT) + end if #endif end subroutine chemistry_init diff --git a/src/core_atmosphere/chemistry/musica/mpas_musica.F b/src/core_atmosphere/chemistry/musica/mpas_musica.F index 649b2b3624..a531a2414e 100644 --- a/src/core_atmosphere/chemistry/musica/mpas_musica.F +++ b/src/core_atmosphere/chemistry/musica/mpas_musica.F @@ -29,6 +29,7 @@ module mpas_musica type(micm_t), pointer :: micm => null ( ) ! Pointer to the MICM ODE solver instance type(state_t), pointer :: state => null ( ) ! Pointer to the state of the MICM solver + logical :: musica_is_initialized = .false. ! Flag to track if MUSICA was successfully initialized contains @@ -61,13 +62,22 @@ subroutine musica_init(filename_of_micm_configuration, & type(error_t) :: error type(string_t) :: micm_version - ! TEMPORARY: Hard-coded options for the MICM solver integer :: solver_type = RosenbrockStandardOrder + integer :: i_species + + ! Skip MUSICA initialization if no configuration file is provided + if (len_trim(filename_of_micm_configuration) == 0) then + call mpas_log_write('MUSICA chemistry disabled: no MICM configuration file specified') + error_code = 0 + error_message = '' + return + end if micm_version = get_micm_version() call mpas_log_write('Initializing MUSICA chemistry package...') + call mpas_log_write('MICM configuration file: ' // trim(filename_of_micm_configuration)) call mpas_log_write('MICM version: ' // micm_version%value_) call mpas_log_write('MICM number of grid cells: $i', intArgs=[number_of_grid_cells]) @@ -77,6 +87,12 @@ subroutine musica_init(filename_of_micm_configuration, & state => micm%get_state(number_of_grid_cells, error) if (has_error_occurred(error, error_message, error_code)) return + do i_species = 1, state%species_ordering%size() + call mpas_log_write('MICM species: ' // state%species_ordering%name(i_species)) + end do + + musica_is_initialized = .true. + end subroutine musica_init !------------------------------------------------------------------------ @@ -96,6 +112,8 @@ subroutine musica_step() use mpas_log, only : mpas_log_write + if (.not. musica_is_initialized) return + call mpas_log_write('Stepping MUSICA chemistry package...') ! Here we would typically call the TUV-x and MICM packages to perform @@ -117,6 +135,8 @@ subroutine musica_finalize() use mpas_log, only : mpas_log_write + if (.not. musica_is_initialized) return + call mpas_log_write('Finalizing MUSICA chemistry package...') ! Here we would typically clean up resources, but for now we do nothing. From 05458b3492dff450c11b6e9cd9e4021cd8c1b786 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 11 Mar 2026 16:22:40 -0600 Subject: [PATCH 160/214] Initialize the mpi_errcode argument to MPI_Abort in MPAS's log_abort routine The mpi_errcode variable in log_abort that is passed as the errorcode input argument to MPI_Abort was previously uninitialized, leading to the potential use of uninitialized memory in MPI_Abort (or in routines called by MPI_Abort). In practice, the uninitialized value in mpi_errcode caused no problems, though when running MPAS with valgrind's memcheck tool, it could lead to the generation of (possibly numerous) uninitialized memory errors in the log from memcheck. This commit initializes mpi_errcode with a value of 6, corresponding to the POSIX SIGABRT signal number, though the specific value is probably not important. --- src/framework/mpas_log.F | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/framework/mpas_log.F b/src/framework/mpas_log.F index 08404ca4c0..d3cdc27093 100644 --- a/src/framework/mpas_log.F +++ b/src/framework/mpas_log.F @@ -847,6 +847,8 @@ subroutine log_abort() deallocate(mpas_log_info) #ifdef _MPI + mpi_errcode = 6 ! corresponds to POSIX SIGABRT, though the specific + ! value here probably does not matter much call MPI_Abort(MPI_COMM_WORLD, mpi_errcode, mpi_ierr) #else stop From 824c6a3f210066e9dd50b198f5b24f7895308f84 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 12 Mar 2026 15:59:17 -0600 Subject: [PATCH 161/214] Initialize the mpi_errcode argument to MPI_Abort in mpas_dmpar_global_abort The mpi_errcode variable in mpas_dmpar_global_abort that is passed as the errorcode input argument to MPI_Abort was previously uninitialized, leading to the potential use of uninitialized memory in MPI_Abort (or in routines called by MPI_Abort). In practice, the uninitialized value in mpi_errcode caused no problems, though when running MPAS with valgrind's memcheck tool, it could lead to the generation of uninitialized memory errors in the log from memcheck. This commit initializes mpi_errcode with a value of 6, corresponding to the POSIX SIGABRT signal number, though the specific value is probably not important. --- src/framework/mpas_abort.F | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/framework/mpas_abort.F b/src/framework/mpas_abort.F index 6dddc941e1..02403d3ace 100644 --- a/src/framework/mpas_abort.F +++ b/src/framework/mpas_abort.F @@ -94,6 +94,8 @@ subroutine mpas_dmpar_global_abort(mesg, deferredAbort)!{{{ if (.not. local_deferredAbort) then #ifdef _MPI + mpi_errcode = 6 ! corresponds to POSIX SIGABRT, though the specific + ! value here probably does not matter much call MPI_Abort(MPI_COMM_WORLD, mpi_errcode, mpi_ierr) #else stop From 97680bd3dd2b9484d17f93200060d0f5331cf784 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 12 Mar 2026 16:06:04 -0600 Subject: [PATCH 162/214] Initialize the mpi_errcode argument to MPI_Abort in mpas_dmpar_abort The mpi_errcode variable in mpas_dmpar_abort that is passed as the errorcode input argument to MPI_Abort was previously uninitialized, leading to the potential use of uninitialized memory in MPI_Abort (or in routines called by MPI_Abort). In practice, the uninitialized value in mpi_errcode caused no problems, though when running MPAS with valgrind's memcheck tool, it could lead to the generation of uninitialized memory errors in the log from memcheck. This commit initializes mpi_errcode with a value of 6, corresponding to the POSIX SIGABRT signal number, though the specific value is probably not important. --- src/framework/mpas_dmpar.F | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/framework/mpas_dmpar.F b/src/framework/mpas_dmpar.F index 8e5340e420..95d2f3d7b5 100644 --- a/src/framework/mpas_dmpar.F +++ b/src/framework/mpas_dmpar.F @@ -349,6 +349,8 @@ subroutine mpas_dmpar_abort(dminfo)!{{{ #ifdef _MPI integer :: mpi_ierr, mpi_errcode + mpi_errcode = 6 ! corresponds to POSIX SIGABRT, though the specific + ! value here probably does not matter much call MPI_Abort(dminfo % comm, mpi_errcode, mpi_ierr) #endif From d62480fdd533fffb28549863c1ff3fcbc800ce65 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 6 Mar 2026 00:30:22 +0000 Subject: [PATCH 163/214] Compute, rather than read from input, deformation_coef_* fields at model startup This commit removes the deformation_coef_{c2,s2,cs,c,s} fields from the definition of the 'invariant' stream in the atmosphere core's Registry.xml file (effectively removing them from the 'input' and 'restart' streams as well), and adds a new routine, atm_initialize_deformation_weights, to the atm_core module to compute these fields at model start-up. --- src/core_atmosphere/Registry.xml | 5 - src/core_atmosphere/mpas_atm_core.F | 241 ++++++++++++++++++++++++++++ 2 files changed, 241 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index fb8cfe959a..afd92b94ad 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -545,11 +545,6 @@ - - - - - #ifdef MPAS_CAM_DYCORE diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index 35c4034815..df9a800292 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -419,6 +419,10 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) logical, pointer :: config_do_restart, config_do_DAcycling + logical, pointer :: on_a_sphere + real (kind=RKIND), pointer :: sphere_radius + + call atm_compute_signs(mesh) call mpas_pool_get_subpool(block % structs, 'diag', diag) @@ -470,6 +474,10 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) !!!!! End compute inverses !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) + call atm_initialize_deformation_weights(mesh, nCells, on_a_sphere, sphere_radius) + call atm_adv_coef_compression(mesh) call atm_couple_coef_3rd_order(mesh, block % configs) @@ -1600,5 +1608,238 @@ subroutine mpas_atm_run_compatibility(dminfo, blockList, streamManager, ierr) end subroutine mpas_atm_run_compatibility + + subroutine atm_initialize_deformation_weights(mesh, nCells, on_a_sphere, sphere_radius) + +! +! compute the cell coefficients for the deformation calculations +! WCS, 13 July 2010 +! + + use mpas_vector_operations, only : mpas_fix_periodicity + use mpas_timer, only : mpas_timer_start, mpas_timer_stop + use mpas_geometry_utils, only : mpas_sphere_angle, mpas_plane_angle, mpas_arc_length + + implicit none + + type (mpas_pool_type), intent(inout) :: mesh + integer, intent(in) :: nCells + logical, intent(in) :: on_a_sphere + real (kind=RKIND), intent(in) :: sphere_radius + +! local variables + + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c2, deformation_coef_s2, deformation_coef_cs + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c, deformation_coef_s + integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, cellsOnCell, verticesOnCell + integer, dimension(:), pointer :: nEdgesOnCell + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge, angleEdge + + real (kind=RKIND), dimension(nCells) :: theta_abs + + real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates + real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere + real (kind=RKIND) :: dl + integer :: i, ip1, ip2, n + integer :: iCell + real (kind=RKIND) :: pii + real (kind=RKIND), dimension(25) :: xp, yp + real (kind=RKIND) :: xe, ye + + integer, dimension(25) :: cell_list + + integer :: iv, ie + logical :: do_the_cell + real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, dx, dy + + real(kind=RKIND), pointer :: x_period, y_period + + + call mpas_pool_get_config(mesh, 'x_period', x_period) + call mpas_pool_get_config(mesh, 'y_period', y_period) + + call mpas_pool_get_array(mesh, 'deformation_coef_c2', deformation_coef_c2) + call mpas_pool_get_array(mesh, 'deformation_coef_s2', deformation_coef_s2) + call mpas_pool_get_array(mesh, 'deformation_coef_cs', deformation_coef_cs) + call mpas_pool_get_array(mesh, 'deformation_coef_c', deformation_coef_c) + call mpas_pool_get_array(mesh, 'deformation_coef_s', deformation_coef_s) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array(mesh, 'xCell', xCell) + call mpas_pool_get_array(mesh, 'yCell', yCell) + call mpas_pool_get_array(mesh, 'zCell', zCell) + call mpas_pool_get_array(mesh, 'xVertex', xVertex) + call mpas_pool_get_array(mesh, 'yVertex', yVertex) + call mpas_pool_get_array(mesh, 'zVertex', zVertex) + call mpas_pool_get_array(mesh, 'xEdge', xEdge) + call mpas_pool_get_array(mesh, 'yEdge', yEdge) + call mpas_pool_get_array(mesh, 'zEdge', zEdge) + call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) + + deformation_coef_c2(:,:) = 0. + deformation_coef_s2(:,:) = 0. + deformation_coef_cs(:,:) = 0. + deformation_coef_c(:,:) = 0. + deformation_coef_s(:,:) = 0. + + pii = 2.*asin(1.0) + + do iCell = 1, nCells + + cell_list(1) = iCell + do i=2,nEdgesOnCell(iCell)+1 + cell_list(i) = cellsOnCell(i-1,iCell) + end do + n = nEdgesOnCell(iCell) + 1 + +! check to see if we are reaching outside the halo + + do_the_cell = .true. + do i=1,n + if (cell_list(i) > nCells) do_the_cell = .false. + end do + + + if (.not. do_the_cell) cycle + + ! compute poynomial fit for this cell if all needed neighbors exist + + if (on_a_sphere) then + + ! xc holds the center point and the vertex points of the cell, + ! normalized to a sphere or radius 1. + + xc(1) = xCell(iCell)/sphere_radius + yc(1) = yCell(iCell)/sphere_radius + zc(1) = zCell(iCell)/sphere_radius + + do i=2,n + iv = verticesOnCell(i-1,iCell) + xc(i) = xVertex(iv)/sphere_radius + yc(i) = yVertex(iv)/sphere_radius + zc(i) = zVertex(iv)/sphere_radius + end do + + ! + ! In case the current cell center lies at exactly z=1.0, the sphere_angle() routine + ! may generate an FPE since the triangle it is given will have a zero side length + ! adjacent to the vertex whose angle we are trying to find; in this case, simply + ! set the value of theta_abs directly + ! + if (zc(1) == 1.0) then + theta_abs(iCell) = pii/2. + else + ! theta_abs is the angle to the first vertex from the center, normalized so that + ! an eastward pointing vector has a angle of 0. + theta_abs(iCell) = pii/2. - mpas_sphere_angle( xc(1), yc(1), zc(1), & + xc(2), yc(2), zc(2), & + 0.0_RKIND, 0.0_RKIND, 1.0_RKIND ) + end if + + ! here we are constructing the tangent-plane cell. + ! thetat is the angle in the (x,y) tangent-plane coordinate from + ! the cell center to each vertex, normalized so that an + ! eastward pointing vector has a angle of 0. + + ! dl_sphere is the spherical distance from the cell center + ! to the sphere vertex points for the cell. + + thetat(1) = theta_abs(iCell) + do i=1,n-1 + + ip2 = i+2 + if (ip2 > n) ip2 = 2 + + thetav(i) = mpas_sphere_angle( xc(1), yc(1), zc(1), & + xc(i+1), yc(i+1), zc(i+1), & + xc(ip2), yc(ip2), zc(ip2) ) + dl_sphere(i) = sphere_radius*mpas_arc_length( xc(1), yc(1), zc(1), & + xc(i+1), yc(i+1), zc(i+1) ) + if(i.gt.1) thetat(i) = thetat(i-1)+thetav(i-1) + end do + + ! xp and yp are the tangent-plane vertex points with the cell center at (0,0) + + do i=1,n-1 + xp(i) = cos(thetat(i)) * dl_sphere(i) + yp(i) = sin(thetat(i)) * dl_sphere(i) + end do + + else ! On an x-y plane + + do i=1,n-1 + iv = verticesOnCell(i,iCell) + xp(i) = mpas_fix_periodicity(xVertex(iv),xCell(iCell),x_period) - xCell(iCell) + yp(i) = mpas_fix_periodicity(yVertex(iv),yCell(iCell),y_period) - yCell(iCell) + end do + + do i=1,n-1 + ie = edgesOnCell(i,iCell) + xe = mpas_fix_periodicity(xEdge(ie),xCell(iCell),x_period) - xCell(iCell) + ye = mpas_fix_periodicity(yEdge(ie),yCell(iCell),y_period) - yCell(iCell) + thetat(i) = atan2(ye,xe) + end do + + theta_abs(iCell) = thetat(1) + + end if + + ! (1) compute cell area on the tangent plane used in the integrals + ! (2) compute angle of cell edge normal vector. here we are repurposing thetat + thetat(1) = theta_abs(iCell) + + do i=2,n-1 + ip1 = i+1 + if (ip1 == n) ip1 = 1 + thetat(i) = mpas_plane_angle( 0.0_RKIND, 0.0_RKIND, 0.0_RKIND, & + xp(i)-xp(i-1), yp(i)-yp(i-1), 0.0_RKIND, & + xp(ip1)-xp(i), yp(ip1)-yp(i), 0.0_RKIND, & + 0.0_RKIND, 0.0_RKIND, 1.0_RKIND) + thetat(i) = thetat(i) + thetat(i-1) + end do + + area_cell = 0. + do i=1,n-1 + ip1 = i+1 + if (ip1 == n) ip1 = 1 + dx = xp(ip1)-xp(i) + dy = yp(ip1)-yp(i) + area_cell = area_cell + 0.25*(xp(i)+xp(ip1))*(yp(ip1)-yp(i)) - 0.25*(yp(i)+yp(ip1))*(xp(ip1)-xp(i)) + thetat(i) = atan2(dy,dx)-pii/2. + end do + + ! coefficients - see documentation for the formulas. + + do i=1,n-1 + ip1 = i+1 + if (ip1 == n) ip1 = 1 + dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2) + sint2 = (sin(thetat(i)))**2 + cost2 = (cos(thetat(i)))**2 + sint_cost = sin(thetat(i))*cos(thetat(i)) + deformation_coef_c2(i,iCell) = dl*cost2/area_cell + deformation_coef_s2(i,iCell) = dl*sint2/area_cell + deformation_coef_cs(i,iCell) = dl*sint_cost/area_cell + deformation_coef_c(i,iCell) = dl*cos(thetat(i))/area_cell + deformation_coef_s(i,iCell) = dl*sin(thetat(i))/area_cell + if (cellsOnEdge(1,EdgesOnCell(i,iCell)) /= iCell) then + deformation_coef_c2(i,iCell) = - deformation_coef_c2(i,iCell) + deformation_coef_s2(i,iCell) = - deformation_coef_s2(i,iCell) + deformation_coef_cs(i,iCell) = - deformation_coef_cs(i,iCell) +! deformation_coef_c(i,iCell) = - deformation_coef_c(i,iCell) +! deformation_coef_s(i,iCell) = - deformation_coef_s(i,iCell) + end if + + end do + + end do + + end subroutine atm_initialize_deformation_weights + end module atm_core From 580e00476ba96adb9356ec9b8e75177061a7676c Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 6 Mar 2026 00:31:24 +0000 Subject: [PATCH 164/214] Remove deformation_coef_* fields and their computation from init_atmosphere core This commit removes the deformation_coef_{c2,s2,cs,c,s} fields from the init_atmosphere core, including the removal of these fields from the init_atmosphere core's Registry.xml file as well as the removal of code in the atm_advection module for computing these fields. --- src/core_init_atmosphere/Registry.xml | 25 -- src/core_init_atmosphere/mpas_atm_advection.F | 309 +----------------- 2 files changed, 9 insertions(+), 325 deletions(-) diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 938b8dde37..0a80532158 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -478,11 +478,6 @@ - - - - - @@ -588,11 +583,6 @@ - - - - - @@ -1134,21 +1124,6 @@ - - - - - - - - - - diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index 4852b17117..f4d44c984e 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -11,7 +11,6 @@ module atm_advection use mpas_derived_types use mpas_pool_routines use mpas_constants - use mpas_vector_operations use mpas_abort, only : mpas_dmpar_global_abort use mpas_log, only : mpas_log_write @@ -759,14 +758,10 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b real (kind=RKIND), dimension(:,:), pointer :: cell_gradient_coef_x, cell_gradient_coef_y - real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c2, deformation_coef_s2, deformation_coef_cs - real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c, deformation_coef_s integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, cellsOnCell, verticesOnCell integer, dimension(:), pointer :: nEdgesOnCell real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex - real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge, angleEdge - real (kind=RKIND), dimension(:), pointer :: areaCell real (kind=RKIND), dimension(nCells) :: theta_abs @@ -777,32 +772,19 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere integer :: iCell real (kind=RKIND) :: pii real (kind=RKIND), dimension(25) :: xp, yp - real (kind=RKIND) :: xe, ye real (kind=RKIND) :: length_scale integer, dimension(25) :: cell_list - integer :: iv, ie + integer :: iv logical :: do_the_cell real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, dx, dy - logical, pointer :: is_periodic - real(kind=RKIND), pointer :: x_period, y_period - - - call mpas_pool_get_config(mesh, 'is_periodic', is_periodic) - call mpas_pool_get_config(mesh, 'x_period', x_period) - call mpas_pool_get_config(mesh, 'y_period', y_period) call mpas_pool_get_array(mesh, 'defc_a', defc_a) call mpas_pool_get_array(mesh, 'defc_b', defc_b) call mpas_pool_get_array(mesh, 'cell_gradient_coef_x', cell_gradient_coef_x) call mpas_pool_get_array(mesh, 'cell_gradient_coef_y', cell_gradient_coef_y) - call mpas_pool_get_array(mesh, 'deformation_coef_c2', deformation_coef_c2) - call mpas_pool_get_array(mesh, 'deformation_coef_s2', deformation_coef_s2) - call mpas_pool_get_array(mesh, 'deformation_coef_cs', deformation_coef_cs) - call mpas_pool_get_array(mesh, 'deformation_coef_c', deformation_coef_c) - call mpas_pool_get_array(mesh, 'deformation_coef_s', deformation_coef_s) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) @@ -814,19 +796,9 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere call mpas_pool_get_array(mesh, 'xVertex', xVertex) call mpas_pool_get_array(mesh, 'yVertex', yVertex) call mpas_pool_get_array(mesh, 'zVertex', zVertex) - call mpas_pool_get_array(mesh, 'xEdge', xEdge) - call mpas_pool_get_array(mesh, 'yEdge', yEdge) - call mpas_pool_get_array(mesh, 'zEdge', zEdge) - call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) - call mpas_pool_get_array(mesh, 'areaCell', areaCell) defc_a(:,:) = 0. defc_b(:,:) = 0. - deformation_coef_c2(:,:) = 0. - deformation_coef_s2(:,:) = 0. - deformation_coef_cs(:,:) = 0. - deformation_coef_c(:,:) = 0. - deformation_coef_s(:,:) = 0. cell_gradient_coef_x(:,:) = 0. cell_gradient_coef_y(:,:) = 0. @@ -916,58 +888,21 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere else ! On an x-y plane - do i=1,n-1 - iv = verticesOnCell(i,iCell) - xp(i) = mpas_fix_periodicity(xVertex(iv),xCell(iCell),x_period) - xCell(iCell) - yp(i) = mpas_fix_periodicity(yVertex(iv),yCell(iCell),y_period) - yCell(iCell) - end do + theta_abs(iCell) = 0.0 - ! if(iCell.lt.11) then - ! call mpas_log_write(' setting defc coefs, cell $i', intArgs=(/iCell/)) - ! do i=1,n-1 - ! iv = verticesOnCell(i,iCell) - ! call mpas_log_write(' xp,yp,xvc,yvc, $r $r $r $r', realArgs=(/xp(i),yp(i),xVertex(iv)-xCell(iCell),yVertex(iv)-yCell(iCell)/)) - ! end do - ! end if + xp(1) = xCell(iCell) + yp(1) = yCell(iCell) - do i=1,n-1 - ie = edgesOnCell(i,iCell) - xe = mpas_fix_periodicity(xEdge(ie),xCell(iCell),x_period) - xCell(iCell) - ye = mpas_fix_periodicity(yEdge(ie),yCell(iCell),y_period) - yCell(iCell) - thetat(i) = atan2(ye,xe) + do i=2,n + iv = verticesOnCell(i-1,iCell) + xp(i) = xVertex(iv) + yp(i) = yVertex(iv) end do - ! if(iCell .lt. 11) then - ! call mpas_log_write(' edge angles, plane calc, cell $i', intArgs=(/iCell/)) - ! do i=1,n-1 - ! call mpas_log_write(' edge angle $r', realArgs=(/thetat(i)*180./3.1415926/)) - ! end do - ! end if - - theta_abs(iCell) = thetat(1) - end if ! (1) compute cell area on the tangent plane used in the integrals ! (2) compute angle of cell edge normal vector. here we are repurposing thetat - thetat(1) = theta_abs(iCell) - - do i=2,n-1 - ip1 = i+1 - if (ip1 == n) ip1 = 1 - thetat(i) = plane_angle( 0.0_RKIND, 0.0_RKIND, 0.0_RKIND, & - xp(i)-xp(i-1), yp(i)-yp(i-1), 0.0_RKIND, & - xp(ip1)-xp(i), yp(ip1)-yp(i), 0.0_RKIND, & - 0.0_RKIND, 0.0_RKIND, 1.0_RKIND) - thetat(i) = thetat(i) + thetat(i-1) - end do - - ! if(iCell .lt. 11) then - ! call mpas_log_write(' edge angles, generic calc, cell $i', intArgs=(/iCell/)) - ! do i=1,n-1 - ! call mpas_log_write(' edge angle $r', realArgs=(/thetat(i)*180./3.1415926/)) - ! end do - ! end if area_cell = 0. do i=1,n-1 @@ -992,241 +927,15 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere defc_b(i,iCell) = dl*2.*sint_cost/area_cell cell_gradient_coef_x(i,iCell) = dl*cos(thetat(i))/area_cell cell_gradient_coef_y(i,iCell) = dl*sin(thetat(i))/area_cell - deformation_coef_c2(i,iCell) = dl*cost2/area_cell - deformation_coef_s2(i,iCell) = dl*sint2/area_cell - deformation_coef_cs(i,iCell) = dl*sint_cost/area_cell - deformation_coef_c(i,iCell) = dl*cos(thetat(i))/area_cell - deformation_coef_s(i,iCell) = dl*sin(thetat(i))/area_cell if (cellsOnEdge(1,EdgesOnCell(i,iCell)) /= iCell) then defc_a(i,iCell) = - defc_a(i,iCell) defc_b(i,iCell) = - defc_b(i,iCell) - deformation_coef_c2(i,iCell) = - deformation_coef_c2(i,iCell) - deformation_coef_s2(i,iCell) = - deformation_coef_s2(i,iCell) - deformation_coef_cs(i,iCell) = - deformation_coef_cs(i,iCell) -! deformation_coef_c(i,iCell) = - deformation_coef_c(i,iCell) -! deformation_coef_s(i,iCell) = - deformation_coef_s(i,iCell) end if end do end do - call atm_init_test_coefs( deformation_coef_c2, deformation_coef_s2, & - deformation_coef_cs, deformation_coef_c, & - deformation_coef_s, & - is_periodic, on_a_sphere, & - x_period, y_period, & - xEdge, yEdge, zEdge, & - xCell, yCell, zCell, nCells, & - angleEdge, nEdgesOnCell, edgesOnCell ) - - end subroutine atm_initialize_deformation_weights - - subroutine atm_init_test_coefs( deformation_coef_c2, deformation_coef_s2, & - deformation_coef_cs, deformation_coef_c, & - deformation_coef_s, & - is_periodic, on_a_sphere, & - x_period, y_period, & - xEdge, yEdge, zEdge, & - xCell, yCell, zCell, nCells, & - angleEdge, nEdgesOnCell, edgesOnCell ) - - implicit none - - logical :: is_periodic, on_a_sphere - integer :: nCells - integer, dimension(:) :: nEdgesOnCell - real (kind=RKIND) :: x_period, y_period - real (kind=RKIND), dimension(:,:) :: deformation_coef_c2, deformation_coef_s2 - real (kind=RKIND), dimension(:,:) :: deformation_coef_cs - real (kind=RKIND), dimension(:,:) :: deformation_coef_c, deformation_coef_s - integer, dimension(:,:) :: edgesOnCell - real (kind=RKIND), dimension(:) :: angleEdge, xEdge, yEdge, zEdge - real (kind=RKIND), dimension(:) :: xCell, yCell, zCell - - ! local variables - - integer :: iCell, iEdge, ie - real (kind=RKIND) :: cos_edge, sin_edge, ux, uy, vx, vy, wx, wy - real (kind=RKIND) :: xc, yc, xe, ye - real (kind=RKIND) :: angle_e, ue, ve, we, e_int - real (kind=RKIND) :: dudx, dudy, dvdx, dvdy, dwdx, dwdy - real (kind=RKIND) :: dudx_c, dudy_c, dvdx_c, dvdy_c, dwdx_c, dwdy_c - - real (kind=RKIND) :: dudx_err_max, dudy_err_max, dvdx_err_max, dvdy_err_max, dwdx_err_max, dwdy_err_max - real (kind=RKIND) :: dudx_err_tot, dudy_err_tot, dvdx_err_tot, dvdy_err_tot, dwdx_err_tot, dwdy_err_tot - real (kind=RKIND) :: dudx_max, dudy_max, dvdx_max, dvdy_max, dwdx_max, dwdy_max - - real (kind=RKIND) :: ang - real (kind=RKIND), parameter :: x_vel= 1.0, y_vel=1.0, w_vel=1.0 - real (kind=RKIND) :: u_edge, v_edge, w_edge, x, y, angle, xl, yl - real (kind=RKIND) :: dudx_cell, dudy_cell, dvdx_cell, dvdy_cell, dwdx_cell, dwdy_cell - - ! Test tunction definitions - ! - ! here are the velocity field functions and their derivatives. - ! First a simple test: U = x_vel*(-x+y), V = y_vel * (-x+y), W = w_vel*(-x+y) - - u_edge(x,y,ang,xl,yl) = (x_vel*(x+y)) * cos(ang) + (y_vel * (x+y) * sin(ang)) - v_edge(x,y,ang,xl,yl) = -(x_vel*(x+y)) * sin(ang) + (y_vel * (x+y) * cos(ang)) - w_edge(x,y,xl,yl) = w_vel * (x+y) - - dudx_cell(x,y,xl,yl) = x_vel - dudy_cell(x,y,xl,yl) = x_vel - dvdx_cell(x,y,xl,yl) = y_vel - dvdy_cell(x,y,xl,yl) = y_vel - dwdx_cell(x,y,xl,yl) = w_vel - dwdy_cell(x,y,xl,yl) = w_vel - - ! ----------------- - - if ( (.not. on_a_sphere) .and. (is_periodic) ) then ! test is for doubly-periodic Cartesian plane only - - dudx_err_max = 0. - dudy_err_max = 0. - dvdx_err_max = 0. - dvdy_err_max = 0. - dwdx_err_max = 0. - dwdy_err_max = 0. - - dudx_err_tot = 0. - dudy_err_tot = 0. - dvdx_err_tot = 0. - dvdy_err_tot = 0. - dwdx_err_tot = 0. - dwdy_err_tot = 0. - - dudx_max = 0. - dudy_max = 0. - dvdx_max = 0. - dvdy_max = 0. - dwdx_max = 0. - dwdy_max = 0. - - do iCell = 1, nCells - - dudx = 0. - dudy = 0. - dvdx = 0. - dvdy = 0. - dwdx = 0. - dwdy = 0. - - xc = xCell(iCell) - yc = yCell(iCell) - - dudx_c = dudx_cell(xc,yc,x_period,y_period) - dudy_c = dudy_cell(xc,yc,x_period,y_period) - dvdx_c = dvdx_cell(xc,yc,x_period,y_period) - dvdy_c = dvdy_cell(xc,yc,x_period,y_period) - dwdx_c = dwdx_cell(xc,yc,x_period,y_period) - dwdy_c = dwdy_cell(xc,yc,x_period,y_period) - - do iEdge = 1, nEdgesOnCell(iCell) - - ie = edgesOnCell(iEdge,iCell) - angle_e = angleEdge(ie) - xe = xEdge(ie) - ye = yEdge(ie) - - xe = mpas_fix_periodicity(xe,xc,x_period) - ye = mpas_fix_periodicity(ye,yc,y_period) - - ue = u_edge(xe,ye,angle_e,x_period,y_period) - ve = v_edge(xe,ye,angle_e,x_period,y_period) - we = w_edge(xe,ye,x_period,y_period) - - dudx = dudx + deformation_coef_c2(iEdge,iCell)*ue & - - deformation_coef_cs(iEdge,iCell)*ve - dudy = dudy + deformation_coef_cs(iEdge,iCell)*ue & - - deformation_coef_s2(iEdge,iCell)*ve - dvdx = dvdx + deformation_coef_cs(iEdge,iCell)*ue & - + deformation_coef_c2(iEdge,iCell)*ve - dvdy = dvdy + deformation_coef_s2(iEdge,iCell)*ue & - + deformation_coef_cs(iEdge,iCell)*ve - - dwdx = dwdx + deformation_coef_c(iEdge,iCell)*we - dwdy = dwdy + deformation_coef_s(iEdge,iCell)*we - - end do - - ! call mpas_log_write(' u_x, u_y, $r, $r ', realArgs=(/dudx, dudy/)) - ! call mpas_log_write(' v_x, v_y, $r, $r ', realArgs=(/dvdx, dvdy/)) - ! call mpas_log_write(' w_x, w_y, $r, $r ', realArgs=(/dwdx, dwdy/)) - - ! check result for cell - - e_int = abs(dudx_c - dudx) - dudx_err_tot = dudx_err_tot + e_int - dudx_err_max = max(dudx_err_max, e_int) - - e_int = abs(dudy_c - dudy) - dudy_err_tot = dudy_err_tot + e_int - dudy_err_max = max(dudy_err_max, e_int) - - e_int = abs(dvdx_c - dvdx) - dvdx_err_tot = dvdx_err_tot + e_int - dvdx_err_max = max(dvdx_err_max, e_int) - - e_int = abs(dvdy_c - dvdy) - dvdy_err_tot = dvdy_err_tot + e_int - dvdy_err_max = max(dvdy_err_max, e_int) - - e_int = abs(dwdx_c - dwdx) - dwdx_err_tot = dwdx_err_tot + e_int - dwdx_err_max = max(dwdx_err_max, e_int) - - e_int = abs(dwdy_c - dwdy) - dwdy_err_tot = dwdy_err_tot + e_int - dwdy_err_max = max(dwdy_err_max, e_int) - - dudx_max = max(dudx_max, abs(dudx_c)) - dudy_max = max(dudy_max, abs(dudy_c)) - dvdx_max = max(dvdx_max, abs(dvdx_c)) - dvdy_max = max(dvdy_max, abs(dvdy_c)) - dwdx_max = max(dwdx_max, abs(dwdx_c)) - dwdy_max = max(dwdy_max, abs(dwdy_c)) - - end do - - ! scale errors - - dudx_err_max = dudx_err_max/dudx_max - dudy_err_max = dudy_err_max/dudy_max - dvdx_err_max = dvdx_err_max/dvdx_max - dvdy_err_max = dvdy_err_max/dvdy_max - dwdx_err_max = dwdx_err_max/dwdx_max - dwdy_err_max = dwdy_err_max/dwdy_max - - dudx_err_tot = dudx_err_tot/dudx_max/real(nCells) - dudy_err_tot = dudy_err_tot/dudy_max/real(nCells) - dvdx_err_tot = dvdx_err_tot/dvdx_max/real(nCells) - dvdy_err_tot = dvdy_err_tot/dvdy_max/real(nCells) - dwdx_err_tot = dwdx_err_tot/dwdx_max/real(nCells) - dwdy_err_tot = dwdy_err_tot/dwdy_max/real(nCells) - - ! output - - call mpas_log_write(' ') - call mpas_log_write(' deformation coefficients check ') - call mpas_log_write(' dudx check, max abs(dudx), max and avg error $r, $r, $r', & - realArgs=(/dudx_max, dudx_err_max, dudx_err_tot/)) - call mpas_log_write(' dudy check, max abs(dudy), max and avg error $r, $r, $r', & - realArgs=(/dudy_max, dudy_err_max, dudy_err_tot/)) - call mpas_log_write(' dvdx check, max abs(dvdx), max and avg error $r, $r, $r', & - realArgs=(/dvdx_max, dvdx_err_max, dvdx_err_tot/)) - call mpas_log_write(' dvdy check, max abs(dvdy), max and avg error $r, $r, $r', & - realArgs=(/dvdy_max, dvdy_err_max, dvdy_err_tot/)) - call mpas_log_write(' dwdx check, max abs(dwdx), max and avg error $r, $r, $r', & - realArgs=(/dwdx_max, dwdx_err_max, dwdx_err_tot/)) - call mpas_log_write(' dwdy check, max abs(dwdy), max and avg error $r, $r, $r', & - realArgs=(/dwdy_max, dwdy_err_max, dwdy_err_tot/)) - call mpas_log_write(' ') - - end if - - end subroutine atm_init_test_coefs - -end module atm_advection + end module atm_advection From c63f2c94f80bc9f031aaf996eac3f0c8cfd7f677 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Mon, 9 Mar 2026 12:16:35 -0600 Subject: [PATCH 165/214] Add routines in mpas_atm_time_integration to consolidate ACC data tranfers This commit introduces a set of routines to mpas_atm_time_integration in order to begin consolidating OpenACC data transfers between host and device during the course of the dynamical core execution. As the atm_compute_solve_diagnostics subroutine also being called once before the time integration loop, we also introduce a separate pair of subroutines to handle data movements around the first call to atm_compute_solve_diagnostics. The mesh/time-invariant fields are still copied onto the device in the call to mpas_atm_dynamics_init and removed from the device during the call to mpas_atm_dynamics_finalize, with the exception of certain fields moved in mpas_atm_pre/post_compute_solve_diagnostics. This is a special case due to atm_compute_solve_diagnostics being called for the first time before the call to mpas_atm_dynamics_init. --- .../dynamics/mpas_atm_time_integration.F | 932 ++++++++++++++++++ 1 file changed, 932 insertions(+) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 5591ffe6d4..f8538b1dcf 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -515,6 +515,938 @@ subroutine mpas_atm_dynamics_init(domain) end subroutine mpas_atm_dynamics_init + subroutine mpas_atm_pre_compute_solve_diagnostics(block) + + implicit none + + type (block_type), intent(inout) :: block + +#ifdef MPAS_OPENACC + type (mpas_pool_type), pointer :: mesh + type (mpas_pool_type), pointer :: diag + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: tend_physics + real (kind=RKIND), dimension(:,:), pointer :: rthdynten + + real (kind=RKIND), dimension(:,:), pointer :: h_edge, v, vorticity, ke, pv_edge, & + pv_vertex, pv_cell, gradPVn, gradPVt, divergence + real (kind=RKIND), dimension(:,:), pointer :: u, h + + real (kind=RKIND), dimension(:,:), pointer :: zz + real (kind=RKIND), dimension(:,:,:), pointer :: zb_cell + real (kind=RKIND), dimension(:,:,:), pointer :: zb3_cell + real (kind=RKIND), dimension(:), pointer :: fzm + real (kind=RKIND), dimension(:), pointer :: fzp + real (kind=RKIND), dimension(:,:,:), pointer :: zb + real (kind=RKIND), dimension(:,:,:), pointer :: zb3 + + + real (kind=RKIND), dimension(:), pointer :: dvEdge + integer, dimension(:,:), pointer :: cellsOnCell + integer, dimension(:,:), pointer :: cellsOnEdge + integer, dimension(:,:), pointer :: advCellsForEdge + integer, dimension(:,:), pointer :: edgesOnCell + integer, dimension(:), pointer :: nAdvCellsForEdge + integer, dimension(:), pointer :: nEdgesOnCell + real (kind=RKIND), dimension(:,:), pointer :: adv_coefs + real (kind=RKIND), dimension(:,:), pointer :: adv_coefs_3rd + real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign + real (kind=RKIND), dimension(:), pointer :: invAreaCell + integer, dimension(:), pointer :: bdyMaskCell + integer, dimension(:), pointer :: bdyMaskEdge + real (kind=RKIND), dimension(:), pointer :: specZoneMaskEdge + real (kind=RKIND), dimension(:), pointer :: invDvEdge + real (kind=RKIND), dimension(:), pointer :: dcEdge + real (kind=RKIND), dimension(:), pointer :: invDcEdge + integer, dimension(:,:), pointer :: edgesOnEdge + integer, dimension(:,:), pointer :: edgesOnVertex + real (kind=RKIND), dimension(:,:), pointer :: edgesOnVertex_sign + integer, dimension(:), pointer :: nEdgesOnEdge + real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge + integer, dimension(:,:), pointer :: cellsOnVertex + integer, dimension(:,:), pointer :: verticesOnCell + integer, dimension(:,:), pointer :: verticesOnEdge + real (kind=RKIND), dimension(:), pointer :: invAreaTriangle + integer, dimension(:,:), pointer :: kiteForCell + real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + real (kind=RKIND), dimension(:), pointer :: fEdge + real (kind=RKIND), dimension(:), pointer :: fVertex + + nullify(mesh) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + nullify(state) + call mpas_pool_get_subpool(block % structs, 'state', state) + nullify(diag) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + + call mpas_pool_get_array(state, 'rho_zz', h, 1) + !$acc enter data create(h) + + call mpas_pool_get_array(state, 'u', u, 1) + !$acc enter data copyin(u) + + call mpas_pool_get_array(diag, 'v', v) + !$acc enter data copyin(v) + + call mpas_pool_get_array(diag, 'rho_edge', h_edge) + !$acc enter data copyin(h_edge) + + call mpas_pool_get_array(diag, 'vorticity', vorticity) + !$acc enter data copyin(vorticity) + + call mpas_pool_get_array(diag, 'divergence', divergence) + !$acc enter data copyin(divergence) + + call mpas_pool_get_array(diag, 'ke', ke) + !$acc enter data copyin(ke) + + call mpas_pool_get_array(diag, 'pv_edge', pv_edge) + !$acc enter data copyin(pv_edge) + + call mpas_pool_get_array(diag, 'pv_vertex', pv_vertex) + !$acc enter data copyin(pv_vertex) + + call mpas_pool_get_array(diag, 'pv_cell', pv_cell) + !$acc enter data copyin(pv_cell) + + call mpas_pool_get_array(diag, 'gradPVn', gradPVn) + !$acc enter data copyin(gradPVn) + + call mpas_pool_get_array(diag, 'gradPVt', gradPVt) + !$acc enter data copyin(gradPVt) + + ! Required by atm_init_coupled_diagnostics + call mpas_pool_get_array(mesh, 'zz', zz) + !$acc enter data copyin(zz) + + call mpas_pool_get_array(mesh, 'zb_cell', zb_cell) + !$acc enter data copyin(zb_cell) + + call mpas_pool_get_array(mesh, 'zb3_cell', zb3_cell) + !$acc enter data copyin(zb3_cell) + + call mpas_pool_get_array(mesh, 'fzm', fzm) + !$acc enter data copyin(fzm) + + call mpas_pool_get_array(mesh, 'fzp', fzp) + !$acc enter data copyin(fzp) + + call mpas_pool_get_array(mesh, 'zb', zb) + !$acc enter data copyin(zb) + + call mpas_pool_get_array(mesh, 'zb3', zb3) + !$acc enter data copyin(zb3) + + ! Required by atm_compute_solve_diagnostics + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + !$acc enter data copyin(dvEdge) + + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + !$acc enter data copyin(cellsOnEdge) + + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + !$acc enter data copyin(edgesOnCell) + + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + !$acc enter data copyin(nEdgesOnCell) + + call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + !$acc enter data copyin(edgesOnCell_sign) + + call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) + !$acc enter data copyin(invAreaCell) + + call mpas_pool_get_array(mesh, 'invDvEdge', invDvEdge) + !$acc enter data copyin(invDvEdge) + + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + !$acc enter data copyin(dcEdge) + + call mpas_pool_get_array(mesh, 'invDcEdge', invDcEdge) + !$acc enter data copyin(invDcEdge) + + call mpas_pool_get_array(mesh, 'edgesOnEdge', edgesOnEdge) + !$acc enter data copyin(edgesOnEdge) + + call mpas_pool_get_array(mesh, 'edgesOnVertex', edgesOnVertex) + !$acc enter data copyin(edgesOnVertex) + + call mpas_pool_get_array(mesh, 'edgesOnVertex_sign', edgesOnVertex_sign) + !$acc enter data copyin(edgesOnVertex_sign) + + call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) + !$acc enter data copyin(nEdgesOnEdge) + + call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) + !$acc enter data copyin(weightsOnEdge) + + call mpas_pool_get_array(mesh, 'verticesOnCell', verticesOnCell) + !$acc enter data copyin(verticesOnCell) + + call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) + !$acc enter data copyin(verticesOnEdge) + + call mpas_pool_get_array(mesh, 'invAreaTriangle', invAreaTriangle) + !$acc enter data copyin(invAreaTriangle) + + call mpas_pool_get_array(mesh, 'kiteForCell', kiteForCell) + !$acc enter data copyin(kiteForCell) + + call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + !$acc enter data copyin(kiteAreasOnVertex) + + call mpas_pool_get_array(mesh, 'fVertex', fVertex) + !$acc enter data copyin(fVertex) + +#endif + + end subroutine mpas_atm_pre_compute_solve_diagnostics + + + subroutine mpas_atm_post_compute_solve_diagnostics(block) + + implicit none + + type (block_type), intent(inout) :: block + +#ifdef MPAS_OPENACC + type (mpas_pool_type), pointer :: mesh + type (mpas_pool_type), pointer :: diag + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: tend_physics + real (kind=RKIND), dimension(:,:), pointer :: rthdynten + + real (kind=RKIND), dimension(:,:), pointer :: h_edge, v, vorticity, ke, pv_edge, & + pv_vertex, pv_cell, gradPVn, gradPVt, divergence + real (kind=RKIND), dimension(:,:), pointer :: u, h + + real (kind=RKIND), dimension(:,:), pointer :: zz + real (kind=RKIND), dimension(:,:,:), pointer :: zb_cell + real (kind=RKIND), dimension(:,:,:), pointer :: zb3_cell + real (kind=RKIND), dimension(:), pointer :: fzm + real (kind=RKIND), dimension(:), pointer :: fzp + real (kind=RKIND), dimension(:,:,:), pointer :: zb + real (kind=RKIND), dimension(:,:,:), pointer :: zb3 + + + real (kind=RKIND), dimension(:), pointer :: dvEdge + integer, dimension(:,:), pointer :: cellsOnCell + integer, dimension(:,:), pointer :: cellsOnEdge + integer, dimension(:,:), pointer :: advCellsForEdge + integer, dimension(:,:), pointer :: edgesOnCell + integer, dimension(:), pointer :: nAdvCellsForEdge + integer, dimension(:), pointer :: nEdgesOnCell + real (kind=RKIND), dimension(:,:), pointer :: adv_coefs + real (kind=RKIND), dimension(:,:), pointer :: adv_coefs_3rd + real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign + real (kind=RKIND), dimension(:), pointer :: invAreaCell + integer, dimension(:), pointer :: bdyMaskCell + integer, dimension(:), pointer :: bdyMaskEdge + real (kind=RKIND), dimension(:), pointer :: specZoneMaskEdge + real (kind=RKIND), dimension(:), pointer :: invDvEdge + real (kind=RKIND), dimension(:), pointer :: dcEdge + real (kind=RKIND), dimension(:), pointer :: invDcEdge + integer, dimension(:,:), pointer :: edgesOnEdge + integer, dimension(:,:), pointer :: edgesOnVertex + real (kind=RKIND), dimension(:,:), pointer :: edgesOnVertex_sign + integer, dimension(:), pointer :: nEdgesOnEdge + real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge + integer, dimension(:,:), pointer :: cellsOnVertex + integer, dimension(:,:), pointer :: verticesOnCell + integer, dimension(:,:), pointer :: verticesOnEdge + real (kind=RKIND), dimension(:), pointer :: invAreaTriangle + integer, dimension(:,:), pointer :: kiteForCell + real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + real (kind=RKIND), dimension(:), pointer :: fEdge + real (kind=RKIND), dimension(:), pointer :: fVertex + + nullify(mesh) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + nullify(state) + call mpas_pool_get_subpool(block % structs, 'state', state) + nullify(diag) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + + call mpas_pool_get_array(state, 'rho_zz', h, 1) + !$acc exit data copyout(h) + call mpas_pool_get_array(state, 'u', u, 1) + !$acc exit data copyout(u) + + call mpas_pool_get_array(diag, 'v', v) + !$acc exit data copyout(v) + call mpas_pool_get_array(diag, 'rho_edge', h_edge) + !$acc exit data copyout(h_edge) + call mpas_pool_get_array(diag, 'vorticity', vorticity) + !$acc exit data copyout(vorticity) + call mpas_pool_get_array(diag, 'divergence', divergence) + !$acc exit data copyout(divergence) + call mpas_pool_get_array(diag, 'ke', ke) + !$acc exit data copyout(ke) + call mpas_pool_get_array(diag, 'pv_edge', pv_edge) + !$acc exit data copyout(pv_edge) + call mpas_pool_get_array(diag, 'pv_vertex', pv_vertex) + !$acc exit data copyout(pv_vertex) + call mpas_pool_get_array(diag, 'pv_cell', pv_cell) + !$acc exit data copyout(pv_cell) + call mpas_pool_get_array(diag, 'gradPVn', gradPVn) + !$acc exit data copyout(gradPVn) + call mpas_pool_get_array(diag, 'gradPVt', gradPVt) + !$acc exit data copyout(gradPVt) + + ! Required by atm_init_coupled_diagnostics + call mpas_pool_get_array(mesh, 'zz', zz) + !$acc exit data delete(zz) + + call mpas_pool_get_array(mesh, 'zb_cell', zb_cell) + !$acc exit data delete(zb_cell) + + call mpas_pool_get_array(mesh, 'zb3_cell', zb3_cell) + !$acc exit data delete(zb3_cell) + + call mpas_pool_get_array(mesh, 'fzm', fzm) + !$acc exit data delete(fzm) + + call mpas_pool_get_array(mesh, 'fzp', fzp) + !$acc exit data delete(fzp) + + call mpas_pool_get_array(mesh, 'zb', zb) + !$acc exit data delete(zb) + + call mpas_pool_get_array(mesh, 'zb3', zb3) + !$acc exit data delete(zb3) + + + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + !$acc exit data delete(dvEdge) + + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + !$acc exit data delete(cellsOnEdge) + + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + !$acc exit data delete(edgesOnCell) + + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + !$acc exit data delete(nEdgesOnCell) + + call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + !$acc exit data delete(edgesOnCell_sign) + + call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) + !$acc exit data delete(invAreaCell) + + call mpas_pool_get_array(mesh, 'invDvEdge', invDvEdge) + !$acc exit data delete(invDvEdge) + + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + !$acc exit data delete(dcEdge) + + call mpas_pool_get_array(mesh, 'invDcEdge', invDcEdge) + !$acc exit data delete(invDcEdge) + + call mpas_pool_get_array(mesh, 'edgesOnEdge', edgesOnEdge) + !$acc exit data delete(edgesOnEdge) + + call mpas_pool_get_array(mesh, 'edgesOnVertex', edgesOnVertex) + !$acc exit data delete(edgesOnVertex) + + call mpas_pool_get_array(mesh, 'edgesOnVertex_sign', edgesOnVertex_sign) + !$acc exit data delete(edgesOnVertex_sign) + + call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) + !$acc exit data delete(nEdgesOnEdge) + + call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) + !$acc exit data delete(weightsOnEdge) + + call mpas_pool_get_array(mesh, 'verticesOnCell', verticesOnCell) + !$acc exit data delete(verticesOnCell) + + call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) + !$acc exit data delete(verticesOnEdge) + + call mpas_pool_get_array(mesh, 'invAreaTriangle', invAreaTriangle) + !$acc exit data delete(invAreaTriangle) + + call mpas_pool_get_array(mesh, 'kiteForCell', kiteForCell) + !$acc exit data delete(kiteForCell) + + call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + !$acc exit data delete(kiteAreasOnVertex) + + call mpas_pool_get_array(mesh, 'fVertex', fVertex) + !$acc exit data delete(fVertex) + +#endif + + end subroutine mpas_atm_post_compute_solve_diagnostics + + subroutine mpas_atm_pre_dynamics(domain) + + implicit none + + type (domain_type), intent(inout) :: domain + + +#ifdef MPAS_OPENACC + type (mpas_pool_type), pointer :: mesh + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: diag + type (mpas_pool_type), pointer :: tend + type (mpas_pool_type), pointer :: tend_physics + type (mpas_pool_type), pointer :: lbc + + logical, pointer :: config_apply_lbcs_ptr + logical :: config_apply_lbcs + + real (kind=RKIND), dimension(:,:), pointer :: ru, ru_p + real (kind=RKIND), dimension(:,:), pointer :: ru_save + real (kind=RKIND), dimension(:,:), pointer :: rw, rw_p + real (kind=RKIND), dimension(:,:), pointer :: rw_save + real (kind=RKIND), dimension(:,:), pointer :: rtheta_p + real (kind=RKIND), dimension(:,:), pointer :: exner, exner_base + real (kind=RKIND), dimension(:,:), pointer :: rtheta_base, rho_base + real (kind=RKIND), dimension(:,:), pointer :: rtheta_p_save + real (kind=RKIND), dimension(:,:), pointer :: rho_p, rho_pp, rho, theta, theta_base + real (kind=RKIND), dimension(:,:), pointer :: rho_p_save + real (kind=RKIND), dimension(:,:), pointer :: rho_zz_old_split + real (kind=RKIND), dimension(:,:), pointer :: cqw, rtheta_pp_old, rtheta_pp + real (kind=RKIND), dimension(:,:), pointer :: cqu, pressure_base, pressure_p, pressure, v + real (kind=RKIND), dimension(:,:), pointer :: kdiff, pv_edge, pv_vertex, pv_cell, rho_edge, h_divergence, ke + real (kind=RKIND), dimension(:,:), pointer :: cofwr, cofwz, coftz, cofwt, a_tri, alpha_tri, gamma_tri + real (kind=RKIND), dimension(:), pointer :: cofrz + real (kind=RKIND), dimension(:,:), pointer :: gradPVn, gradPVt + + + real (kind=RKIND), dimension(:,:), pointer :: u_1, u_2 + real (kind=RKIND), dimension(:,:), pointer :: w_1, w_2 + real (kind=RKIND), dimension(:,:), pointer :: theta_m_1, theta_m_2 + real (kind=RKIND), dimension(:,:), pointer :: rho_zz_1, rho_zz_2 + real (kind=RKIND), dimension(:,:,:), pointer :: scalars_1, scalars_2 + real (kind=RKIND), dimension(:,:), pointer :: ruAvg, wwAvg, ruAvg_split, wwAvg_split + + integer, pointer :: nCells_ptr + integer :: nCells + real (kind=RKIND), dimension(:,:), pointer :: uReconstructZonal, uReconstructMeridional, uReconstructX, uReconstructY, uReconstructZ + + real (kind=RKIND), dimension(:,:), pointer :: tend_ru, tend_rt, tend_rho, tend_rw, rt_diabatic_tend + real (kind=RKIND), dimension(:,:), pointer :: tend_u_euler, tend_w_euler, tend_theta_euler + real(kind=RKIND), dimension(:,:), pointer :: tend_w_pgf, tend_w_buoy + real(kind=RKIND), dimension(:,:,:), pointer :: scalar_tend_save + + real (kind=RKIND), dimension(:,:), pointer :: rthdynten, divergence, vorticity + + real (kind=RKIND), dimension(:,:), pointer :: lbc_u, lbc_w, lbc_ru, lbc_rho_edge, lbc_rho, lbc_rtheta_m, lbc_rho_zz, lbc_theta + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_u, lbc_tend_w, lbc_tend_ru, lbc_tend_rho_edge, lbc_tend_rho + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rtheta_m, lbc_tend_rho_zz, lbc_tend_theta + + real (kind=RKIND), dimension(:,:,:), pointer :: lbc_scalars, lbc_tend_scalars + + nullify(mesh) + nullify(state) + nullify(diag) + nullify(tend) + nullify(tend_physics) + nullify(lbc) + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', mesh) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) + call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tend) + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend_physics', tend_physics) + call mpas_pool_get_subpool(domain % blocklist % structs, 'lbc', lbc) + + call mpas_pool_get_config(domain % blocklist % configs, 'config_apply_lbcs', config_apply_lbcs_ptr) + config_apply_lbcs = config_apply_lbcs_ptr + + call mpas_pool_get_array(diag, 'ru', ru) + !$acc enter data copyin(ru) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'ru_p', ru_p) + !$acc enter data copyin(ru_p) + call mpas_pool_get_array(diag, 'ru_save', ru_save) + !$acc enter data copyin(ru_save) + call mpas_pool_get_array(diag, 'rw', rw) + !$acc enter data copyin(rw) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'rw_p', rw_p) + !$acc enter data copyin(rw_p) + call mpas_pool_get_array(diag, 'rw_save', rw_save) + !$acc enter data copyin(rw_save) + call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) + !$acc enter data copyin(rtheta_p) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'rtheta_p_save', rtheta_p_save) + !$acc enter data copyin(rtheta_p_save) + call mpas_pool_get_array(diag, 'exner', exner) + !$acc enter data copyin(exner) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'exner_base', exner_base) + !$acc enter data copyin(exner_base) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'rtheta_base', rtheta_base) + !$acc enter data copyin(rtheta_base) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'rho_base', rho_base) + !$acc enter data copyin(rho_base) + call mpas_pool_get_array(diag, 'rho', rho) + !$acc enter data copyin(rho) + call mpas_pool_get_array(diag, 'theta', theta) + !$acc enter data copyin(theta) + call mpas_pool_get_array(diag, 'theta_base', theta_base) + !$acc enter data copyin(theta_base) + call mpas_pool_get_array(diag, 'rho_p', rho_p) + !$acc enter data copyin(rho_p) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'rho_p_save', rho_p_save) + !$acc enter data copyin(rho_p_save) + call mpas_pool_get_array(diag, 'rho_pp', rho_pp) + !$acc enter data copyin(rho_pp) + call mpas_pool_get_array(diag, 'rho_zz_old_split', rho_zz_old_split) + !$acc enter data copyin(rho_zz_old_split) + call mpas_pool_get_array(diag, 'cqw', cqw) + !$acc enter data copyin(cqw) + call mpas_pool_get_array(diag, 'cqu', cqu) + !$acc enter data copyin(cqu) + call mpas_pool_get_array(diag, 'pressure_p', pressure_p) + !$acc enter data copyin(pressure_p) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'pressure_base', pressure_base) + !$acc enter data copyin(pressure_base) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'pressure', pressure) + !$acc enter data copyin(pressure) + call mpas_pool_get_array(diag, 'v', v) + !$acc enter data copyin(v) ! use values from atm_compute_solve_diagnostics + call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) + !$acc enter data copyin(rtheta_pp) + call mpas_pool_get_array(diag, 'rtheta_pp_old', rtheta_pp_old) + !$acc enter data copyin(rtheta_pp_old) + call mpas_pool_get_array(diag, 'kdiff', kdiff) + !$acc enter data copyin(kdiff) + call mpas_pool_get_array(diag, 'pv_edge', pv_edge) + !$acc enter data copyin(pv_edge) ! use values from atm_compute_solve_diagnostics + call mpas_pool_get_array(diag, 'pv_vertex', pv_vertex) + !$acc enter data copyin(pv_vertex) + call mpas_pool_get_array(diag, 'pv_cell', pv_cell) + !$acc enter data copyin(pv_cell) + call mpas_pool_get_array(diag, 'rho_edge', rho_edge) + !$acc enter data copyin(rho_edge) ! use values from atm_compute_solve_diagnostics + call mpas_pool_get_array(diag, 'h_divergence', h_divergence) + !$acc enter data copyin(h_divergence) + call mpas_pool_get_array(diag, 'ke', ke) + !$acc enter data copyin(ke) ! use values from atm_compute_solve_diagnostics + call mpas_pool_get_array(diag, 'gradPVn', gradPVn) + !$acc enter data copyin(gradPVn) + call mpas_pool_get_array(diag, 'gradPVt', gradPVt) + !$acc enter data copyin(gradPVt) + + call mpas_pool_get_array(diag, 'alpha_tri', alpha_tri) + !$acc enter data copyin(alpha_tri) + call mpas_pool_get_array(diag, 'gamma_tri', gamma_tri) + !$acc enter data copyin(gamma_tri) + call mpas_pool_get_array(diag, 'a_tri', a_tri) + !$acc enter data copyin(a_tri) + call mpas_pool_get_array(diag, 'cofwr', cofwr) + !$acc enter data copyin(cofwr) + call mpas_pool_get_array(diag, 'cofwz', cofwz) + !$acc enter data copyin(cofwz) + call mpas_pool_get_array(diag, 'coftz', coftz) + !$acc enter data copyin(coftz) + call mpas_pool_get_array(diag, 'cofwt', cofwt) + !$acc enter data copyin(cofwt) + call mpas_pool_get_array(diag, 'cofrz', cofrz) + !$acc enter data copyin(cofrz) + call mpas_pool_get_array(diag, 'vorticity', vorticity) + !$acc enter data copyin(vorticity) + call mpas_pool_get_array(diag, 'divergence', divergence) + !$acc enter data copyin(divergence) + call mpas_pool_get_array(diag, 'ruAvg', ruAvg) + !$acc enter data copyin(ruAvg) + call mpas_pool_get_array(diag, 'ruAvg_split', ruAvg_split) + !$acc enter data copyin(ruAvg_split) + call mpas_pool_get_array(diag, 'wwAvg', wwAvg) + !$acc enter data copyin(wwAvg) + call mpas_pool_get_array(diag, 'wwAvg_split', wwAvg_split) + !$acc enter data copyin(wwAvg_split) + + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCells_ptr) + nCells = nCells_ptr + call mpas_pool_get_array(diag, 'uReconstructX', uReconstructX) + !$acc enter data create(uReconstructX) + call mpas_pool_get_array(diag, 'uReconstructY', uReconstructY) + !$acc enter data create(uReconstructY) + call mpas_pool_get_array(diag, 'uReconstructZ', uReconstructZ) + !$acc enter data create(uReconstructZ) + call mpas_pool_get_array(diag, 'uReconstructZonal', uReconstructZonal) + !$acc enter data copyin(uReconstructZonal) + call mpas_pool_get_array(diag, 'uReconstructMeridional', uReconstructMeridional) + !$acc enter data copyin(uReconstructMeridional) + + call mpas_pool_get_array(state, 'u', u_1, 1) + !$acc enter data copyin(u_1) + call mpas_pool_get_array(state, 'u', u_2, 2) + !$acc enter data copyin(u_2) + call mpas_pool_get_array(state, 'w', w_1, 1) + !$acc enter data copyin(w_1) + call mpas_pool_get_array(state, 'w', w_2, 2) + !$acc enter data copyin(w_2) + call mpas_pool_get_array(state, 'theta_m', theta_m_1, 1) + !$acc enter data copyin(theta_m_1) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(state, 'theta_m', theta_m_2, 2) + !$acc enter data copyin(theta_m_2) + call mpas_pool_get_array(state, 'rho_zz', rho_zz_1, 1) + !$acc enter data copyin(rho_zz_1) + call mpas_pool_get_array(state, 'rho_zz', rho_zz_2, 2) + !$acc enter data copyin(rho_zz_2) + call mpas_pool_get_array(state, 'scalars', scalars_1, 1) + !$acc enter data copyin(scalars_1) + call mpas_pool_get_array(state, 'scalars', scalars_2, 2) + !$acc enter data copyin(scalars_2) + + call mpas_pool_get_array(tend, 'u', tend_ru) + !$acc enter data copyin(tend_ru) + call mpas_pool_get_array(tend, 'rho_zz', tend_rho) + !$acc enter data copyin(tend_rho) + call mpas_pool_get_array(tend, 'theta_m', tend_rt) + !$acc enter data copyin(tend_rt) + call mpas_pool_get_array(tend, 'w', tend_rw) + !$acc enter data copyin(tend_rw) + call mpas_pool_get_array(tend, 'rt_diabatic_tend', rt_diabatic_tend) + !$acc enter data copyin(rt_diabatic_tend) + call mpas_pool_get_array(tend, 'u_euler', tend_u_euler) + !$acc enter data copyin(tend_u_euler) + call mpas_pool_get_array(tend, 'theta_euler', tend_theta_euler) + !$acc enter data copyin(tend_theta_euler) + call mpas_pool_get_array(tend, 'w_euler', tend_w_euler) + !$acc enter data copyin(tend_w_euler) + call mpas_pool_get_array(tend, 'w_pgf', tend_w_pgf) + !$acc enter data copyin(tend_w_pgf) + call mpas_pool_get_array(tend, 'w_buoy', tend_w_buoy) + !$acc enter data copyin(tend_w_buoy) + call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend_save) + !$acc enter data copyin(scalar_tend_save) + + + if(config_apply_lbcs) then + call mpas_pool_get_array(lbc, 'lbc_u', lbc_u, 2) + !$acc enter data copyin(lbc_u) + call mpas_pool_get_array(lbc, 'lbc_w', lbc_w, 2) + !$acc enter data copyin(lbc_w) + call mpas_pool_get_array(lbc, 'lbc_ru', lbc_ru, 2) + !$acc enter data copyin(lbc_ru) + call mpas_pool_get_array(lbc, 'lbc_rho_edge', lbc_rho_edge, 2) + !$acc enter data copyin(lbc_rho_edge) + call mpas_pool_get_array(lbc, 'lbc_theta', lbc_theta, 2) + !$acc enter data copyin(lbc_theta) + call mpas_pool_get_array(lbc, 'lbc_rtheta_m', lbc_rtheta_m, 2) + !$acc enter data copyin(lbc_rtheta_m) + call mpas_pool_get_array(lbc, 'lbc_rho_zz', lbc_rho_zz, 2) + !$acc enter data copyin(lbc_rho_zz) + call mpas_pool_get_array(lbc, 'lbc_rho', lbc_rho, 2) + !$acc enter data copyin(lbc_rho) + call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_scalars, 2) + !$acc enter data copyin(lbc_scalars) + + call mpas_pool_get_array(lbc, 'lbc_u', lbc_tend_u, 1) + !$acc enter data copyin(lbc_tend_u) + call mpas_pool_get_array(lbc, 'lbc_ru', lbc_tend_ru, 1) + !$acc enter data copyin(lbc_tend_ru) + call mpas_pool_get_array(lbc, 'lbc_rho_edge', lbc_tend_rho_edge, 1) + !$acc enter data copyin(lbc_tend_rho_edge) + call mpas_pool_get_array(lbc, 'lbc_w', lbc_tend_w, 1) + !$acc enter data copyin(lbc_tend_w) + call mpas_pool_get_array(lbc, 'lbc_theta', lbc_tend_theta, 1) + !$acc enter data copyin(lbc_tend_theta) + call mpas_pool_get_array(lbc, 'lbc_rtheta_m', lbc_tend_rtheta_m, 1) + !$acc enter data copyin(lbc_tend_rtheta_m) + call mpas_pool_get_array(lbc, 'lbc_rho_zz', lbc_tend_rho_zz, 1) + !$acc enter data copyin(lbc_tend_rho_zz) + call mpas_pool_get_array(lbc, 'lbc_rho', lbc_tend_rho, 1) + !$acc enter data copyin(lbc_tend_rho) + call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_tend_scalars, 1) + !$acc enter data copyin(lbc_tend_scalars) + end if + + call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) + !$acc enter data copyin(rthdynten) + +#endif + + end subroutine mpas_atm_pre_dynamics + + + subroutine mpas_atm_post_dynamics(domain) + + implicit none + + type (domain_type), intent(inout) :: domain + + +#ifdef MPAS_OPENACC + type (mpas_pool_type), pointer :: mesh + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: diag + type (mpas_pool_type), pointer :: tend + type (mpas_pool_type), pointer :: tend_physics + type (mpas_pool_type), pointer :: lbc + + logical, pointer :: config_apply_lbcs_ptr + logical :: config_apply_lbcs + + real (kind=RKIND), dimension(:,:), pointer :: ru, ru_p + real (kind=RKIND), dimension(:,:), pointer :: ru_save + real (kind=RKIND), dimension(:,:), pointer :: rw, rw_p + real (kind=RKIND), dimension(:,:), pointer :: rw_save + real (kind=RKIND), dimension(:,:), pointer :: rtheta_p + real (kind=RKIND), dimension(:,:), pointer :: exner, exner_base + real (kind=RKIND), dimension(:,:), pointer :: rtheta_base, rho_base + real (kind=RKIND), dimension(:,:), pointer :: rtheta_p_save + real (kind=RKIND), dimension(:,:), pointer :: rho_p, rho_pp, rho, theta, theta_base + real (kind=RKIND), dimension(:,:), pointer :: rho_p_save + real (kind=RKIND), dimension(:,:), pointer :: rho_zz_old_split + real (kind=RKIND), dimension(:,:), pointer :: cqw, rtheta_pp_old, rtheta_pp + real (kind=RKIND), dimension(:,:), pointer :: cqu, pressure_base, pressure_p, pressure, v + real (kind=RKIND), dimension(:,:), pointer :: kdiff, pv_edge, pv_vertex, pv_cell, rho_edge, h_divergence, ke + real (kind=RKIND), dimension(:,:), pointer :: cofwr, cofwz, coftz, cofwt, a_tri, alpha_tri, gamma_tri + real (kind=RKIND), dimension(:), pointer :: cofrz + real (kind=RKIND), dimension(:,:), pointer :: gradPVn, gradPVt + + real (kind=RKIND), dimension(:,:), pointer :: u_1, u_2 + real (kind=RKIND), dimension(:,:), pointer :: w_1, w_2 + real (kind=RKIND), dimension(:,:), pointer :: theta_m_1, theta_m_2 + real (kind=RKIND), dimension(:,:), pointer :: rho_zz_1, rho_zz_2 + real (kind=RKIND), dimension(:,:,:), pointer :: scalars_1, scalars_2 + real (kind=RKIND), dimension(:,:), pointer :: ruAvg, wwAvg, ruAvg_split, wwAvg_split + + integer, pointer :: nCells_ptr + integer :: nCells + real (kind=RKIND), dimension(:,:), pointer :: uReconstructZonal, uReconstructMeridional, uReconstructX, uReconstructY, uReconstructZ + + real (kind=RKIND), dimension(:,:), pointer :: tend_ru, tend_rt, tend_rho, tend_rw, rt_diabatic_tend + real (kind=RKIND), dimension(:,:), pointer :: tend_u_euler, tend_w_euler, tend_theta_euler + real(kind=RKIND), dimension(:,:), pointer :: tend_w_pgf, tend_w_buoy + real(kind=RKIND), dimension(:,:,:), pointer :: scalar_tend_save + + real (kind=RKIND), dimension(:,:), pointer :: rthdynten, divergence, vorticity + + real (kind=RKIND), dimension(:,:), pointer :: lbc_u, lbc_w, lbc_ru, lbc_rho_edge, lbc_rho, lbc_rtheta_m, lbc_rho_zz, lbc_theta + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_u, lbc_tend_w, lbc_tend_ru, lbc_tend_rho_edge, lbc_tend_rho + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rtheta_m, lbc_tend_rho_zz, lbc_tend_theta + + real (kind=RKIND), dimension(:,:,:), pointer :: lbc_scalars, lbc_tend_scalars + + nullify(mesh) + nullify(state) + nullify(diag) + nullify(tend) + nullify(tend_physics) + nullify(lbc) + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', mesh) + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) + call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tend) + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend_physics', tend_physics) + call mpas_pool_get_subpool(domain % blocklist % structs, 'lbc', lbc) + + call mpas_pool_get_config(domain % blocklist % configs, 'config_apply_lbcs', config_apply_lbcs_ptr) + config_apply_lbcs = config_apply_lbcs_ptr + + call mpas_pool_get_array(diag, 'ru', ru) + !$acc exit data copyout(ru) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'ru_p', ru_p) + !$acc exit data copyout(ru_p) + call mpas_pool_get_array(diag, 'ru_save', ru_save) + !$acc exit data delete(ru_save) + call mpas_pool_get_array(diag, 'rw', rw) + !$acc exit data copyout(rw) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'rw_p', rw_p) + !$acc exit data copyout(rw_p) + call mpas_pool_get_array(diag, 'rw_save', rw_save) + !$acc exit data delete(rw_save) + call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) + !$acc exit data copyout(rtheta_p) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'rtheta_p_save', rtheta_p_save) + !$acc exit data delete(rtheta_p_save) + call mpas_pool_get_array(diag, 'exner', exner) + !$acc exit data copyout(exner) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'exner_base', exner_base) + !$acc exit data copyout(exner_base) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'rtheta_base', rtheta_base) + !$acc exit data copyout(rtheta_base) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'rho_base', rho_base) + !$acc exit data copyout(rho_base) + call mpas_pool_get_array(diag, 'rho', rho) + !$acc exit data copyout(rho) + call mpas_pool_get_array(diag, 'theta', theta) + !$acc exit data copyout(theta) + call mpas_pool_get_array(diag, 'theta_base', theta_base) + !$acc exit data copyout(theta_base) + call mpas_pool_get_array(diag, 'rho_p', rho_p) + !$acc exit data copyout(rho_p) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'rho_p_save', rho_p_save) + !$acc exit data delete(rho_p_save) + call mpas_pool_get_array(diag, 'rho_pp', rho_pp) + !$acc exit data copyout(rho_pp) + call mpas_pool_get_array(diag, 'rho_zz_old_split', rho_zz_old_split) + !$acc exit data delete(rho_zz_old_split) + call mpas_pool_get_array(diag, 'cqw', cqw) + !$acc exit data delete(cqw) + call mpas_pool_get_array(diag, 'cqu', cqu) + !$acc exit data copyout(cqu) + call mpas_pool_get_array(diag, 'pressure_p', pressure_p) + !$acc exit data copyout(pressure_p) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'pressure_base', pressure_base) + !$acc exit data copyout(pressure_base) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(diag, 'pressure', pressure) + !$acc exit data copyout(pressure) + call mpas_pool_get_array(diag, 'v', v) + !$acc exit data copyout(v) ! use values from atm_compute_solve_diagnostics + call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) + !$acc exit data copyout(rtheta_pp) + call mpas_pool_get_array(diag, 'rtheta_pp_old', rtheta_pp_old) + !$acc exit data copyout(rtheta_pp_old) + call mpas_pool_get_array(diag, 'kdiff', kdiff) + !$acc exit data copyout(kdiff) + call mpas_pool_get_array(diag, 'pv_edge', pv_edge) + !$acc exit data copyout(pv_edge) ! use values from atm_compute_solve_diagnostics + call mpas_pool_get_array(diag, 'pv_vertex', pv_vertex) + !$acc exit data copyout(pv_vertex) + call mpas_pool_get_array(diag, 'pv_cell', pv_cell) + !$acc exit data delete(pv_cell) + call mpas_pool_get_array(diag, 'rho_edge', rho_edge) + !$acc exit data copyout(rho_edge) ! use values from atm_compute_solve_diagnostics + call mpas_pool_get_array(diag, 'h_divergence', h_divergence) + !$acc exit data copyout(h_divergence) + call mpas_pool_get_array(diag, 'ke', ke) + !$acc exit data copyout(ke) ! use values from atm_compute_solve_diagnostics + call mpas_pool_get_array(diag, 'gradPVn', gradPVn) + !$acc exit data delete(gradPVn) + call mpas_pool_get_array(diag, 'gradPVt', gradPVt) + !$acc exit data delete(gradPVt) + + call mpas_pool_get_array(diag, 'alpha_tri', alpha_tri) + !$acc exit data delete(alpha_tri) + call mpas_pool_get_array(diag, 'gamma_tri', gamma_tri) + !$acc exit data delete(gamma_tri) + call mpas_pool_get_array(diag, 'a_tri', a_tri) + !$acc exit data delete(a_tri) + call mpas_pool_get_array(diag, 'cofwr', cofwr) + !$acc exit data delete(cofwr) + call mpas_pool_get_array(diag, 'cofwz', cofwz) + !$acc exit data delete(cofwz) + call mpas_pool_get_array(diag, 'coftz', coftz) + !$acc exit data delete(coftz) + call mpas_pool_get_array(diag, 'cofwt', cofwt) + !$acc exit data delete(cofwt) + call mpas_pool_get_array(diag, 'cofrz', cofrz) + !$acc exit data delete(cofrz) + call mpas_pool_get_array(diag, 'vorticity', vorticity) + !$acc exit data copyout(vorticity) + call mpas_pool_get_array(diag, 'divergence', divergence) + !$acc exit data copyout(divergence) + call mpas_pool_get_array(diag, 'ruAvg', ruAvg) + !$acc exit data copyout(ruAvg) + call mpas_pool_get_array(diag, 'ruAvg_split', ruAvg_split) + !$acc exit data copyout(ruAvg_split) + call mpas_pool_get_array(diag, 'wwAvg', wwAvg) + !$acc exit data copyout(wwAvg) + call mpas_pool_get_array(diag, 'wwAvg_split', wwAvg_split) + !$acc exit data copyout(wwAvg_split) + + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCells_ptr) + nCells = nCells_ptr + call mpas_pool_get_array(diag, 'uReconstructX', uReconstructX) + !$acc exit data copyout(uReconstructX) + call mpas_pool_get_array(diag, 'uReconstructY', uReconstructY) + !$acc exit data copyout(uReconstructY) + call mpas_pool_get_array(diag, 'uReconstructZ', uReconstructZ) + !$acc exit data copyout(uReconstructZ) + call mpas_pool_get_array(diag, 'uReconstructZonal', uReconstructZonal) + !$acc exit data copyout(uReconstructZonal) + call mpas_pool_get_array(diag, 'uReconstructMeridional', uReconstructMeridional) + !$acc exit data copyout(uReconstructMeridional) + + call mpas_pool_get_array(state, 'u', u_1, 1) + !$acc exit data copyout(u_1) + call mpas_pool_get_array(state, 'u', u_2, 2) + !$acc exit data copyout(u_2) + call mpas_pool_get_array(state, 'w', w_1, 1) + !$acc exit data copyout(w_1) + call mpas_pool_get_array(state, 'w', w_2, 2) + !$acc exit data copyout(w_2) + call mpas_pool_get_array(state, 'theta_m', theta_m_1, 1) + !$acc exit data copyout(theta_m_1) ! use values from atm_init_coupled_diagnostics + call mpas_pool_get_array(state, 'theta_m', theta_m_2, 2) + !$acc exit data copyout(theta_m_2) ! Delete gives incorrect results + call mpas_pool_get_array(state, 'rho_zz', rho_zz_1, 1) + !$acc exit data copyout(rho_zz_1) + call mpas_pool_get_array(state, 'rho_zz', rho_zz_2, 2) + !$acc exit data copyout(rho_zz_2) + call mpas_pool_get_array(state, 'scalars', scalars_1, 1) + !$acc exit data copyout(scalars_1) + call mpas_pool_get_array(state, 'scalars', scalars_2, 2) + !$acc exit data copyout(scalars_2) ! Delete gives incorrect results + + + call mpas_pool_get_array(tend, 'u', tend_ru) + !$acc exit data copyout(tend_ru) + call mpas_pool_get_array(tend, 'rho_zz', tend_rho) + !$acc exit data copyout(tend_rho) + call mpas_pool_get_array(tend, 'theta_m', tend_rt) + !$acc exit data copyout(tend_rt) + call mpas_pool_get_array(tend, 'w', tend_rw) + !$acc exit data copyout(tend_rw) + call mpas_pool_get_array(tend, 'rt_diabatic_tend', rt_diabatic_tend) + !$acc exit data copyout(rt_diabatic_tend) + call mpas_pool_get_array(tend, 'u_euler', tend_u_euler) + !$acc exit data copyout(tend_u_euler) + call mpas_pool_get_array(tend, 'theta_euler', tend_theta_euler) + !$acc exit data copyout(tend_theta_euler) + call mpas_pool_get_array(tend, 'w_euler', tend_w_euler) + !$acc exit data copyout(tend_w_euler) + call mpas_pool_get_array(tend, 'w_pgf', tend_w_pgf) + !$acc exit data copyout(tend_w_pgf) + call mpas_pool_get_array(tend, 'w_buoy', tend_w_buoy) + !$acc exit data copyout(tend_w_buoy) + call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend_save) + !$acc exit data copyout(scalar_tend_save) + + if(config_apply_lbcs) then + call mpas_pool_get_array(lbc, 'lbc_u', lbc_u, 2) + !$acc exit data delete(lbc_u) + call mpas_pool_get_array(lbc, 'lbc_w', lbc_w, 2) + !$acc exit data delete(lbc_w) + call mpas_pool_get_array(lbc, 'lbc_ru', lbc_ru, 2) + !$acc exit data delete(lbc_ru) + call mpas_pool_get_array(lbc, 'lbc_rho_edge', lbc_rho_edge, 2) + !$acc exit data delete(lbc_rho_edge) + call mpas_pool_get_array(lbc, 'lbc_theta', lbc_theta, 2) + !$acc exit data delete(lbc_theta) + call mpas_pool_get_array(lbc, 'lbc_rtheta_m', lbc_rtheta_m, 2) + !$acc exit data delete(lbc_rtheta_m) + call mpas_pool_get_array(lbc, 'lbc_rho_zz', lbc_rho_zz, 2) + !$acc exit data delete(lbc_rho_zz) + call mpas_pool_get_array(lbc, 'lbc_rho', lbc_rho, 2) + !$acc exit data delete(lbc_rho) + call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_scalars, 2) + !$acc exit data delete(lbc_scalars) + + call mpas_pool_get_array(lbc, 'lbc_u', lbc_tend_u, 1) + !$acc exit data delete(lbc_tend_u) + call mpas_pool_get_array(lbc, 'lbc_ru', lbc_tend_ru, 1) + !$acc exit data delete(lbc_tend_ru) + call mpas_pool_get_array(lbc, 'lbc_rho_edge', lbc_tend_rho_edge, 1) + !$acc exit data delete(lbc_tend_rho_edge) + call mpas_pool_get_array(lbc, 'lbc_w', lbc_tend_w, 1) + !$acc exit data delete(lbc_tend_w) + call mpas_pool_get_array(lbc, 'lbc_theta', lbc_tend_theta, 1) + !$acc exit data delete(lbc_tend_theta) + call mpas_pool_get_array(lbc, 'lbc_rtheta_m', lbc_tend_rtheta_m, 1) + !$acc exit data delete(lbc_tend_rtheta_m) + call mpas_pool_get_array(lbc, 'lbc_rho_zz', lbc_tend_rho_zz, 1) + !$acc exit data delete(lbc_tend_rho_zz) + call mpas_pool_get_array(lbc, 'lbc_rho', lbc_tend_rho, 1) + !$acc exit data delete(lbc_tend_rho) + call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_tend_scalars, 1) + !$acc exit data delete(lbc_tend_scalars) + end if + + call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) + !$acc exit data copyout(rthdynten) +#endif + + end subroutine mpas_atm_post_dynamics + !---------------------------------------------------------------------------- ! routine MPAS_atm_dynamics_finalize From f751a6af5ce2ca3ac2f83d8ccce6e649f9af55ef Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Mon, 9 Mar 2026 12:42:01 -0600 Subject: [PATCH 166/214] Introducing routines in mpas_atm_iau to consolidate ACC data tranfers This commit introduces a set of routines to mpas_atm_iau, building on the previous commit, to begin consolidating OpenACC data transfers between host and device during the course of the dynamical core execution. As the IAU code is currently executed on CPUs, it is necessary to synchronize the fields needed for this computation with the host before the call to atm_add_tend_anal_incr and sync back to the device after this call. --- src/core_atmosphere/dynamics/mpas_atm_iau.F | 60 +++++++++++++++++++++ 1 file changed, 60 insertions(+) diff --git a/src/core_atmosphere/dynamics/mpas_atm_iau.F b/src/core_atmosphere/dynamics/mpas_atm_iau.F index 654fd3ae82..e2e6af0059 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_iau.F +++ b/src/core_atmosphere/dynamics/mpas_atm_iau.F @@ -76,6 +76,66 @@ real (kind=RKIND) function atm_iau_coef(configs, itimestep, dt) result(wgt_iau) end if end function atm_iau_coef + +!================================================================================================== + subroutine pre_add_tend_anal_incr(configs,structs) +!================================================================================================== + + implicit none + + type (mpas_pool_type), intent(in) :: configs + type (mpas_pool_type), intent(inout) :: structs + +#ifdef MPAS_OPENACC + type (mpas_pool_type), pointer :: tend + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: diag + + real (kind=RKIND), dimension(:,:), pointer :: rho_edge, rho_zz, theta_m + real (kind=RKIND), dimension(:,:,:), pointer :: scalars, tend_scalars + + call mpas_pool_get_subpool(structs, 'tend', tend) + call mpas_pool_get_subpool(structs, 'state', state) + call mpas_pool_get_subpool(structs, 'diag', diag) + + call mpas_pool_get_array(state, 'theta_m', theta_m, 1) + call mpas_pool_get_array(state, 'scalars', scalars, 1) + call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) + call mpas_pool_get_array(diag , 'rho_edge', rho_edge) + !$acc update self(theta_m, scalars, rho_zz, rho_edge) + + call mpas_pool_get_array(tend, 'scalars_tend', tend_scalars) + !$acc update self(tend_scalars) +#endif + + end subroutine pre_add_tend_anal_incr + +!================================================================================================== + subroutine post_add_tend_anal_incr(configs,structs, tend_ru, tend_rtheta, tend_rho) +!================================================================================================== + + implicit none + + type (mpas_pool_type), intent(in) :: configs + type (mpas_pool_type), intent(inout) :: structs + real (kind=RKIND), dimension(:,:), intent(inout) :: tend_ru + real (kind=RKIND), dimension(:,:), intent(inout) :: tend_rtheta + real (kind=RKIND), dimension(:,:), intent(inout) :: tend_rho + +#ifdef MPAS_OPENACC + type (mpas_pool_type), pointer :: tend + + real (kind=RKIND), dimension(:,:,:), pointer :: tend_scalars + + call mpas_pool_get_subpool(structs, 'tend', tend) + + !$acc update device(tend_ru, tend_rtheta, tend_rho) + + call mpas_pool_get_array(tend, 'scalars_tend', tend_scalars) + !$acc update device(tend_scalars) +#endif + + end subroutine post_add_tend_anal_incr !================================================================================================== subroutine atm_add_tend_anal_incr (configs, structs, itimestep, dt, tend_ru, tend_rtheta, tend_rho) From 79112a17cbf10ab5c264e996305a6a1958f76721 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Mon, 9 Mar 2026 13:00:19 -0600 Subject: [PATCH 167/214] Introducing routines in mpas_atmphys_interface to consolidate ACC data tranfers This commit introduces a set of routines to mpas_atmphys_interface, building on the last two commits, to begin consolidating OpenACC data transfers between host and device during the course of the dynamical core execution. As the microphysics is currently executed on CPUs, it is necessary to synchronize the fields needed for this computation with the host before the call to microphysics from the dycore and sync back to the device after this call. --- .../physics/mpas_atmphys_interface.F | 78 +++++++++++++++++++ 1 file changed, 78 insertions(+) diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index 67d744bd78..8bbbaa28b5 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -17,6 +17,8 @@ module mpas_atmphys_interface private public:: allocate_forall_physics, & deallocate_forall_physics, & + pre_microphysics, & + post_microphysics, & MPAS_to_physics, & microphysics_from_MPAS, & microphysics_to_MPAS @@ -546,6 +548,40 @@ subroutine MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics,its,ite end subroutine MPAS_to_physics +!================================================================================================================= + subroutine pre_microphysics(configs,state,diag,time_lev) +!================================================================================================================= + +!input variables: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: state + type(mpas_pool_type),intent(in):: diag + + integer:: time_lev + +#ifdef MPAS_OPENACC +!local pointers: + real(kind=RKIND),dimension(:,:),pointer :: exner,pressure_b,w + real(kind=RKIND),dimension(:,:),pointer :: rho_zz,theta_m,pressure_p + real(kind=RKIND),dimension(:,:,:),pointer:: scalars + + + call mpas_pool_get_array(diag,'exner' ,exner ) + call mpas_pool_get_array(diag,'pressure_base',pressure_b) + call mpas_pool_get_array(diag,'pressure_p' ,pressure_p) + + call mpas_pool_get_array(state,'rho_zz' ,rho_zz ,time_lev) + call mpas_pool_get_array(state,'theta_m',theta_m,time_lev) + call mpas_pool_get_array(state,'w' ,w ,time_lev) + !$acc update host(exner, pressure_b, pressure_p, rho_zz, theta_m, w) + + call mpas_pool_get_array(state,'scalars',scalars,time_lev) + !$acc update host(scalars) + +#endif + +end subroutine pre_microphysics + !================================================================================================================= subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend_physics,its,ite) !================================================================================================================= @@ -1089,6 +1125,48 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te end subroutine microphysics_to_MPAS +!================================================================================================================= + subroutine post_microphysics(configs,state,diag,tend,time_lev) +!================================================================================================================= + +!input variables: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: state + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(inout):: tend + + + integer:: time_lev + +#ifdef MPAS_OPENACC +!local pointers: + real(kind=RKIND),dimension(:,:),pointer :: exner,exner_b,pressure_b,rtheta_p,rtheta_b + real(kind=RKIND),dimension(:,:),pointer :: rho_zz,theta_m,pressure_p + real(kind=RKIND),dimension(:,:,:),pointer:: scalars + real(kind=RKIND),dimension(:,:),pointer :: rt_diabatic_tend + + call mpas_pool_get_array(diag,'exner' ,exner ) + call mpas_pool_get_array(diag,'exner_base' ,exner_b ) + call mpas_pool_get_array(diag,'pressure_base',pressure_b) + call mpas_pool_get_array(diag,'pressure_p' ,pressure_p) + call mpas_pool_get_array(diag,'rtheta_base' ,rtheta_b ) + call mpas_pool_get_array(diag,'rtheta_p' ,rtheta_p ) + + call mpas_pool_get_array(state,'rho_zz' ,rho_zz ,time_lev) + call mpas_pool_get_array(state,'theta_m',theta_m,time_lev) + + call mpas_pool_get_array(state,'scalars',scalars,time_lev) + + call mpas_pool_get_array(tend,'rt_diabatic_tend',rt_diabatic_tend) + + + !$acc update device(exner, exner_b, pressure_b, pressure_p, rtheta_b) + !$acc update device(rtheta_p, rho_zz, theta_m, scalars) + !$acc update device(rt_diabatic_tend) +#endif + +end subroutine post_microphysics + !================================================================================================================= end module mpas_atmphys_interface !================================================================================================================= From dd204b71984f3ed43f8c6337a84d0d1008d4f2c8 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Mon, 9 Mar 2026 13:16:22 -0600 Subject: [PATCH 168/214] Introducing routines in mpas_atmphys_todynamics to consolidate ACC data tranfers This commit introduces a set of routines to mpas_atmphys_todynamics, building on the last several commits, to begin consolidating OpenACC data transfers between host and device during the course of the dynamical core execution. As the computation of the physics tendencies is currently executed on CPUs, it is necessary to synchronize the fields needed for this computation with the host before the call to physics_get_tend and sync back to the device after this call --- .../physics/mpas_atmphys_todynamics.F | 57 ++++++++++++++++++- 1 file changed, 56 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index cebf566cc4..154940be73 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -13,10 +13,11 @@ module mpas_atmphys_todynamics use mpas_atm_dimensions use mpas_atmphys_constants, only: R_d,R_v,degrad + use mpas_timer, only: mpas_timer_start, mpas_timer_stop implicit none private - public:: physics_get_tend + public:: physics_get_tend, pre_physics_get_tend, post_physics_get_tend !Interface between the physics parameterizations and the non-hydrostatic dynamical core. @@ -47,6 +48,40 @@ module mpas_atmphys_todynamics contains + +!================================================================================================================= + subroutine pre_physics_get_tend(configs,state,diag,tend) +!================================================================================================================= + +!input variables: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: state + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(in):: tend + +#ifdef MPAS_OPENACC +!local variables: + real(kind=RKIND),dimension(:,:),pointer:: mass ! time level 2 rho_zz + real(kind=RKIND),dimension(:,:),pointer:: mass_edge ! diag rho_edge + real(kind=RKIND),dimension(:,:),pointer:: theta_m ! time level 1 + real(kind=RKIND),dimension(:,:,:),pointer:: scalars + + real(kind=RKIND),dimension(:,:),pointer:: tend_u_phys + real(kind=RKIND),dimension(:,:,:),pointer:: tend_scalars + + call mpas_pool_get_array(state,'theta_m' ,theta_m,1) + call mpas_pool_get_array(state,'scalars' ,scalars,1) + call mpas_pool_get_array(state,'rho_zz' ,mass,2 ) + call mpas_pool_get_array(diag ,'rho_edge',mass_edge) + call mpas_pool_get_array(diag ,'tend_u_phys',tend_u_phys) + + !$acc update self(theta_m, scalars, mass, mass_edge) + + call mpas_pool_get_array(tend,'scalars_tend',tend_scalars) + !$acc update self(tend_scalars) ! Probably not needed +#endif + + end subroutine pre_physics_get_tend !================================================================================================================= subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_step,dynamics_substep, & @@ -232,6 +267,26 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s end subroutine physics_get_tend + !================================================================================================================= + subroutine post_physics_get_tend(configs,state,diag,tend) +!================================================================================================================= + +!input variables: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: state + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(in):: tend + +#ifdef MPAS_OPENACC +!local variables: + real(kind=RKIND),dimension(:,:,:),pointer:: tend_scalars + + call mpas_pool_get_array(tend,'scalars_tend',tend_scalars) + !$acc update device(tend_scalars) +#endif + + end subroutine post_physics_get_tend + !================================================================================================================= subroutine physics_get_tend_work( & block,mesh,nCells,nEdges,nCellsSolve,nEdgesSolve,rk_step,dynamics_substep, & From d25cc81cfda00fa9520d4954258b9b2b6b80a6e6 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Mon, 9 Mar 2026 13:49:49 -0600 Subject: [PATCH 169/214] Add routines in mpas_vector_reconstruction to consolidate ACC data tranfers This commit introduces a set of routines to mpas_vector_reconstruction, on top of the last several commits, to begin consolidating OpenACC data transfers between host and device during the course of the dynamical core execution. The call to mpas_reconstruct_2d is currently executed on device (GPU), and there is no need for ACC data transfers around this call within the time integration loop. However, mpas_reconstruct_2d is also invoked once before the start of the time integration loop and it becomes necessary to synchronize the fields needed for mpas_reconstruct_2d with the device before this call and sync back to the host following this call. --- src/operators/mpas_vector_reconstruction.F | 135 +++++++++++++++++++++ 1 file changed, 135 insertions(+) diff --git a/src/operators/mpas_vector_reconstruction.F b/src/operators/mpas_vector_reconstruction.F index 605da9cd6d..6e93c485fc 100644 --- a/src/operators/mpas_vector_reconstruction.F +++ b/src/operators/mpas_vector_reconstruction.F @@ -349,6 +349,141 @@ subroutine mpas_reconstruct_2d(meshPool, u, uReconstructX, uReconstructY, uRecon end subroutine mpas_reconstruct_2d!}}} +!*********************************************************************** +! +! routine mpas_reconstruct_2d_h2d +! +!> \brief Host to device data transfer routine for MPAS 2D Vector reconstruction +!> \author Abishek Gopal +!> \date 03/09/2026 +!> \details +!> Purpose: Transfer data needed for 2D vector reconstruction from host to device +!----------------------------------------------------------------------- + subroutine mpas_reconstruct_2d_h2d(meshPool, u, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional, includeHalos)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + real (kind=RKIND), dimension(:,:), intent(in) :: u !< Input: Velocity field on edges + real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructX !< Output: X Component of velocity reconstructed to cell centers + real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructY !< Output: Y Component of velocity reconstructed to cell centers + real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructZ !< Output: Z Component of velocity reconstructed to cell centers + real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructZonal !< Output: Zonal Component of velocity reconstructed to cell centers + real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructMeridional !< Output: Meridional Component of velocity reconstructed to cell centers + logical, optional, intent(in) :: includeHalos !< Input: Optional logical that allows reconstruction over halo regions + +#ifdef MPAS_OPENACC + logical :: includeHalosLocal + integer, dimension(:,:), pointer :: edgesOnCell + integer, dimension(:), pointer :: nEdgesOnCell + integer :: nCells + integer, pointer :: nCells_ptr + real(kind=RKIND), dimension(:), pointer :: latCell, lonCell + real (kind=RKIND), dimension(:,:,:), pointer :: coeffs_reconstruct + + if ( present(includeHalos) ) then + includeHalosLocal = includeHalos + else + includeHalosLocal = .false. + end if + + ! stored arrays used during compute procedure + call mpas_pool_get_array(meshPool, 'coeffs_reconstruct', coeffs_reconstruct) + + ! temporary variables + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + + if ( includeHalosLocal ) then + call mpas_pool_get_dimension(meshPool, 'nCells', nCells_ptr) + else + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCells_ptr) + end if + nCells = nCells_ptr + + MPAS_ACC_TIMER_START('mpas_reconstruct_2d [ACC_data_xfer]') + ! Only use sections needed, nCells may be all cells or only non-halo cells + !$acc enter data copyin(coeffs_reconstruct(:,:,1:nCells),nEdgesOnCell(1:nCells), & + !$acc edgesOnCell(:,1:nCells),latCell(1:nCells),lonCell(1:nCells)) + !$acc enter data copyin(u(:,:)) + !$acc enter data create(uReconstructX(:,1:nCells),uReconstructY(:,1:nCells), & + !$acc uReconstructZ(:,1:nCells),uReconstructZonal(:,1:nCells), & + !$acc uReconstructMeridional(:,1:nCells)) + MPAS_ACC_TIMER_STOP('mpas_reconstruct_2d [ACC_data_xfer]') +#endif + + end subroutine mpas_reconstruct_2d_h2d!}}} + + +!*********************************************************************** +! +! routine mpas_reconstruct_2d_d2h +! +!> \brief Device to host data transfer routine for MPAS 2D Vector reconstruction +!> \author Abishek Gopal +!> \date 03/09/2026 +!> \details +!> Purpose: Transfer data back to host after call to 2D vector reconstruction +!----------------------------------------------------------------------- + subroutine mpas_reconstruct_2d_d2h(meshPool, u, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional, includeHalos)!{{{ + + implicit none + + type (mpas_pool_type), intent(in) :: meshPool !< Input: Mesh information + real (kind=RKIND), dimension(:,:), intent(in) :: u !< Input: Velocity field on edges + real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructX !< Output: X Component of velocity reconstructed to cell centers + real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructY !< Output: Y Component of velocity reconstructed to cell centers + real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructZ !< Output: Z Component of velocity reconstructed to cell centers + real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructZonal !< Output: Zonal Component of velocity reconstructed to cell centers + real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructMeridional !< Output: Meridional Component of velocity reconstructed to cell centers + logical, optional, intent(in) :: includeHalos !< Input: Optional logical that allows reconstruction over halo regions + +#ifdef MPAS_OPENACC + logical :: includeHalosLocal + integer, dimension(:,:), pointer :: edgesOnCell + integer, dimension(:), pointer :: nEdgesOnCell + integer :: nCells + integer, pointer :: nCells_ptr + real(kind=RKIND), dimension(:), pointer :: latCell, lonCell + real (kind=RKIND), dimension(:,:,:), pointer :: coeffs_reconstruct + + if ( present(includeHalos) ) then + includeHalosLocal = includeHalos + else + includeHalosLocal = .false. + end if + + ! stored arrays used during compute procedure + call mpas_pool_get_array(meshPool, 'coeffs_reconstruct', coeffs_reconstruct) + + ! temporary variables + call mpas_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(meshPool, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(meshPool, 'latCell', latCell) + call mpas_pool_get_array(meshPool, 'lonCell', lonCell) + + if ( includeHalosLocal ) then + call mpas_pool_get_dimension(meshPool, 'nCells', nCells_ptr) + else + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCells_ptr) + end if + nCells = nCells_ptr + + MPAS_ACC_TIMER_START('mpas_reconstruct_2d [ACC_data_xfer]') + !$acc exit data delete(coeffs_reconstruct(:,:,1:nCells),nEdgesOnCell(1:nCells), & + !$acc edgesOnCell(:,1:nCells),latCell(1:nCells),lonCell(1:nCells)) + !$acc exit data delete(u(:,:)) + !$acc exit data copyout(uReconstructX(:,1:nCells),uReconstructY(:,1:nCells), & + !$acc uReconstructZ(:,1:nCells), uReconstructZonal(:,1:nCells), & + !$acc uReconstructMeridional(:,1:nCells)) + MPAS_ACC_TIMER_STOP('mpas_reconstruct_2d [ACC_data_xfer]') +#endif + + end subroutine mpas_reconstruct_2d_d2h!}}} + + !*********************************************************************** ! ! routine mpas_reconstruct_1d From 7172760dfa085f87715d7b846002316b55a5a82a Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Mon, 9 Mar 2026 16:17:22 -0600 Subject: [PATCH 170/214] Consolidating OpenACC device-host memory transfers This commit introduces changes to the MPAS Atmosphere core to consolidate OpenACC host and device data transfers during the course of the dynamical core execution. This commit adds calls to OpenACC device-host memory transfer subroutines, introduced in previous commits, in order to eliminate extraneous data transfers in the dynamical core. Much of the previously distributed data movement statements have been consolidated in two subroutines, mpas_atm_pre_dynamics and mpas_atm_post_dynamics These pair of subroutines are called once per timestep in the atmosphere core, right before and after the call to atm_srk3. The mesh/time-invariant fields are still copied onto the device in mpas_atm_ dynamics_init and removed from the device in mpas_atm_dynamics_finalize, with the exception of select fields transferred in the subroutines mpas_atm_pre_compute_solve_diagnostics and mpas_atm_post_compute_solve_diagnostics This is a special case due to atm_compute_solve_diagnostics being called for the first time before the call to mpas_atm_dynamics_init. This commit also invokes host-device data transfer routines in the mpas_atm_iau, mpas_atmphys_interface and mpas_atmphys_todynamics modules to ensure that the code regions performing computations related to IAU, microphysics and physics tendencies, all of which are currently executed on CPUs, are using the most field values from dynamical core running on GPUs, and vice versa. In addition, this commit also includes explicit data transfers around halo exchanges in the atm_srk3 subroutine. --- .../dynamics/mpas_atm_boundaries.F | 32 -- .../dynamics/mpas_atm_time_integration.F | 514 +++++------------- src/core_atmosphere/mpas_atm_core.F | 12 +- src/operators/mpas_vector_reconstruction.F | 36 +- 4 files changed, 149 insertions(+), 445 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F index 787e7719a1..6c19ed7931 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F +++ b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F @@ -395,18 +395,14 @@ subroutine mpas_atm_get_bdy_tend(clock, block, vertDim, horizDim, field, delta_t nullify(tend) call mpas_pool_get_array(lbc, 'lbc_'//trim(field), tend, 1) - MPAS_ACC_TIMER_START('mpas_atm_get_bdy_tend [ACC_data_xfer]') if (associated(tend)) then - !$acc enter data copyin(tend) else call mpas_pool_get_array(lbc, 'lbc_scalars', tend_scalars, 1) - !$acc enter data copyin(tend_scalars) ! Ensure the integer pointed to by idx_ptr is copied to the gpu device call mpas_pool_get_dimension(lbc, 'index_'//trim(field), idx_ptr) idx = idx_ptr end if - MPAS_ACC_TIMER_STOP('mpas_atm_get_bdy_tend [ACC_data_xfer]') !$acc parallel default(present) if (associated(tend)) then @@ -426,13 +422,6 @@ subroutine mpas_atm_get_bdy_tend(clock, block, vertDim, horizDim, field, delta_t end if !$acc end parallel - MPAS_ACC_TIMER_START('mpas_atm_get_bdy_tend [ACC_data_xfer]') - if (associated(tend)) then - !$acc exit data delete(tend) - else - !$acc exit data delete(tend_scalars) - end if - MPAS_ACC_TIMER_STOP('mpas_atm_get_bdy_tend [ACC_data_xfer]') end subroutine mpas_atm_get_bdy_tend @@ -533,9 +522,6 @@ subroutine mpas_atm_get_bdy_state_2d(clock, block, vertDim, horizDim, field, del ! query the field as a scalar constituent ! if (associated(tend) .and. associated(state)) then - MPAS_ACC_TIMER_START('mpas_atm_get_bdy_state_2d [ACC_data_xfer]') - !$acc enter data copyin(tend, state) - MPAS_ACC_TIMER_STOP('mpas_atm_get_bdy_state_2d [ACC_data_xfer]') !$acc parallel default(present) !$acc loop gang vector collapse(2) @@ -546,9 +532,6 @@ subroutine mpas_atm_get_bdy_state_2d(clock, block, vertDim, horizDim, field, del end do !$acc end parallel - MPAS_ACC_TIMER_START('mpas_atm_get_bdy_state_2d [ACC_data_xfer]') - !$acc exit data delete(tend, state) - MPAS_ACC_TIMER_STOP('mpas_atm_get_bdy_state_2d [ACC_data_xfer]') else call mpas_pool_get_array(lbc, 'lbc_scalars', tend_scalars, 1) call mpas_pool_get_array(lbc, 'lbc_scalars', state_scalars, 2) @@ -556,10 +539,6 @@ subroutine mpas_atm_get_bdy_state_2d(clock, block, vertDim, horizDim, field, del idx=idx_ptr ! Avoid non-array pointer for OpenACC - MPAS_ACC_TIMER_START('mpas_atm_get_bdy_state_2d [ACC_data_xfer]') - !$acc enter data copyin(tend_scalars, state_scalars) - MPAS_ACC_TIMER_STOP('mpas_atm_get_bdy_state_2d [ACC_data_xfer]') - !$acc parallel default(present) !$acc loop gang vector collapse(2) do i=1, horizDim+1 @@ -569,9 +548,6 @@ subroutine mpas_atm_get_bdy_state_2d(clock, block, vertDim, horizDim, field, del end do !$acc end parallel - MPAS_ACC_TIMER_START('mpas_atm_get_bdy_state_2d [ACC_data_xfer]') - !$acc exit data delete(tend_scalars, state_scalars) - MPAS_ACC_TIMER_STOP('mpas_atm_get_bdy_state_2d [ACC_data_xfer]') end if end subroutine mpas_atm_get_bdy_state_2d @@ -652,10 +628,6 @@ subroutine mpas_atm_get_bdy_state_3d(clock, block, innerDim, vertDim, horizDim, call mpas_pool_get_array(lbc, 'lbc_'//trim(field), tend, 1) call mpas_pool_get_array(lbc, 'lbc_'//trim(field), state, 2) - MPAS_ACC_TIMER_START('mpas_atm_get_bdy_state_3d [ACC_data_xfer]') - !$acc enter data copyin(tend, state) - MPAS_ACC_TIMER_STOP('mpas_atm_get_bdy_state_3d [ACC_data_xfer]') - !$acc parallel default(present) !$acc loop gang vector collapse(3) do i=1, horizDim+1 @@ -667,10 +639,6 @@ subroutine mpas_atm_get_bdy_state_3d(clock, block, innerDim, vertDim, horizDim, end do !$acc end parallel - MPAS_ACC_TIMER_START('mpas_atm_get_bdy_state_3d [ACC_data_xfer]') - !$acc exit data delete(tend, state) - MPAS_ACC_TIMER_STOP('mpas_atm_get_bdy_state_3d [ACC_data_xfer]') - end subroutine mpas_atm_get_bdy_state_3d diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index f8538b1dcf..8be3c79623 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -24,10 +24,11 @@ module atm_time_integration ! Added only clause to keep xlf90 from getting confused from the overloaded abs intrinsic in mpas_timekeeping use mpas_derived_types, only : MPAS_Time_type, MPAS_TimeInterval_type, MPAS_NOW use mpas_timekeeping, only: mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+) - use mpas_timer + use mpas_timer, only: mpas_timer_start, mpas_timer_stop #ifdef DO_PHYSICS use mpas_atmphys_driver_microphysics + use mpas_atmphys_interface, only: pre_microphysics, post_microphysics use mpas_atmphys_todynamics use mpas_atmphys_utilities #endif @@ -72,6 +73,7 @@ module atm_time_integration !$acc declare create(s_max_arr, s_min_arr) !$acc declare create(flux_array, flux_upwind_tmp_arr) !$acc declare create(flux_tmp_arr, wdtn_arr) + !$acc declare create(rho_zz_int) real (kind=RKIND), dimension(:,:), allocatable :: ru_driving_tend ! regional_MPAS addition real (kind=RKIND), dimension(:,:), allocatable :: rt_driving_tend ! regional_MPAS addition @@ -295,6 +297,8 @@ subroutine mpas_atm_dynamics_init(domain) real (kind=RKIND), dimension(:), pointer :: angleEdge real (kind=RKIND), dimension(:), pointer :: meshScalingDel2 real (kind=RKIND), dimension(:), pointer :: meshScalingDel4 + real (kind=RKIND), dimension(:), pointer :: u_init, v_init, qv_init + real (kind=RKIND), dimension(:,:), pointer :: t_init real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c2 real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_s2 real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_cs @@ -497,6 +501,18 @@ subroutine mpas_atm_dynamics_init(domain) call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) !$acc enter data copyin(meshScalingDel4) + call mpas_pool_get_array(mesh, 'u_init', u_init) + !$acc enter data copyin(u_init) + + call mpas_pool_get_array(mesh, 'v_init', v_init) + !$acc enter data copyin(v_init) + + call mpas_pool_get_array(mesh, 't_init', t_init) + !$acc enter data copyin(t_init) + + call mpas_pool_get_array(mesh, 'qv_init', qv_init) + !$acc enter data copyin(qv_init) + call mpas_pool_get_array(mesh, 'deformation_coef_c2', deformation_coef_c2) !$acc enter data copyin(deformation_coef_c2) @@ -1420,7 +1436,6 @@ subroutine mpas_atm_post_dynamics(domain) !$acc exit data delete(lbc_rho) call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_scalars, 2) !$acc exit data delete(lbc_scalars) - call mpas_pool_get_array(lbc, 'lbc_u', lbc_tend_u, 1) !$acc exit data delete(lbc_tend_u) call mpas_pool_get_array(lbc, 'lbc_ru', lbc_tend_ru, 1) @@ -1537,6 +1552,8 @@ subroutine mpas_atm_dynamics_finalize(domain) real (kind=RKIND), dimension(:), pointer :: angleEdge real (kind=RKIND), dimension(:), pointer :: meshScalingDel2 real (kind=RKIND), dimension(:), pointer :: meshScalingDel4 + real (kind=RKIND), dimension(:), pointer :: u_init, v_init, qv_init + real (kind=RKIND), dimension(:,:), pointer :: t_init real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c2 real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_s2 real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_cs @@ -1740,6 +1757,18 @@ subroutine mpas_atm_dynamics_finalize(domain) call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) !$acc exit data delete(meshScalingDel4) + call mpas_pool_get_array(mesh, 'u_init', u_init) + !$acc exit data delete(u_init) + + call mpas_pool_get_array(mesh, 'v_init', v_init) + !$acc exit data delete(v_init) + + call mpas_pool_get_array(mesh, 't_init', t_init) + !$acc exit data delete(t_init) + + call mpas_pool_get_array(mesh, 'qv_init', qv_init) + !$acc exit data delete(qv_init) + call mpas_pool_get_array(mesh, 'deformation_coef_c2', deformation_coef_c2) !$acc exit data delete(deformation_coef_c2) @@ -1797,12 +1826,14 @@ subroutine atm_timestep(domain, dt, nowTime, itimestep, exchange_halo_group) config_apply_lbcs = config_apply_lbcs_ptr + call mpas_atm_pre_dynamics(domain) if (trim(config_time_integration) == 'SRK3') then call atm_srk3(domain, dt, itimestep, exchange_halo_group) else call mpas_log_write('Unknown time integration option '//trim(config_time_integration), messageType=MPAS_LOG_ERR) call mpas_log_write('Currently, only ''SRK3'' is supported.', messageType=MPAS_LOG_CRIT) end if + call mpas_atm_post_dynamics(domain) call mpas_set_timeInterval(dtInterval, dt=dt) currTime = nowTime + dtInterval @@ -1896,6 +1927,8 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) real (kind=RKIND), dimension(:,:,:), pointer :: scalars, scalars_1, scalars_2 real (kind=RKIND), dimension(:,:), pointer :: rqvdynten, rthdynten, theta_m + real (kind=RKIND), dimension(:,:), pointer :: pressure_p, rtheta_p, exner, tend_u + real (kind=RKIND), dimension(:,:), pointer :: rho_pp, rtheta_pp, ru_p, rw_p, pv_edge, rho_edge real (kind=RKIND) :: theta_local, fac_m #ifndef MPAS_CAM_DYCORE @@ -2063,7 +2096,13 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) ! ! Communicate halos for theta_m, scalars, pressure_p, and rtheta_p ! + call mpas_pool_get_array(state, 'theta_m', theta_m, 1) + call mpas_pool_get_array(state, 'scalars', scalars_1, 1) + call mpas_pool_get_array(diag, 'pressure_p', pressure_p) + call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) + !$acc update self(theta_m,scalars_1,pressure_p,rtheta_p) call exchange_halo_group(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') + !$acc update device(theta_m,scalars_1,pressure_p,rtheta_p) call mpas_timer_start('atm_rk_integration_setup') @@ -2098,6 +2137,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_timer_stop('atm_compute_moist_coefficients') #ifdef DO_PHYSICS + call pre_physics_get_tend(block % configs, state, diag, tend) call mpas_timer_start('physics_get_tend') rk_step = 1 dynamics_substep = 1 @@ -2106,6 +2146,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) tend_ru_physics, tend_rtheta_physics, tend_rho_physics, & exchange_halo_group ) call mpas_timer_stop('physics_get_tend') + call post_physics_get_tend(block % configs, state, diag, tend) #else #ifndef MPAS_CAM_DYCORE ! @@ -2117,15 +2158,21 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) #endif #endif + !$acc enter data copyin(tend_rtheta_physics,tend_rho_physics,tend_ru_physics) + ! ! IAU - Incremental Analysis Update ! if (trim(config_IAU_option) /= 'off') then + call pre_add_tend_anal_incr(block % configs, block % structs) call atm_add_tend_anal_incr(block % configs, block % structs, itimestep, dt, & tend_ru_physics, tend_rtheta_physics, tend_rho_physics) + call post_add_tend_anal_incr(block % configs, block % structs, tend_ru_physics, & + tend_rtheta_physics, tend_rho_physics) end if + DYNAMICS_SUBSTEPS : do dynamics_substep = 1, dynamics_split ! Compute the coefficients for the vertically implicit solve in the acoustic step. @@ -2144,8 +2191,10 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !$OMP END PARALLEL DO call mpas_timer_stop('atm_compute_vert_imp_coefs') + call mpas_pool_get_array(diag, 'exner', exner) + !$acc update self(exner) call exchange_halo_group(domain, 'dynamics:exner') - + !$acc update device(exner) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! BEGIN Runge-Kutta loop @@ -2224,7 +2273,10 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !*********************************** ! tend_u + call mpas_pool_get_array(tend, 'u', tend_u) + !$acc update self(tend_u) call exchange_halo_group(domain, 'dynamics:tend_u') + !$acc update device(tend_u) call mpas_timer_start('small_step_prep') @@ -2300,7 +2352,10 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) do small_step = 1, number_sub_steps(rk_step) + call mpas_pool_get_array(diag, 'rho_pp', rho_pp) + !$acc update self(rho_pp) call exchange_halo_group(domain, 'dynamics:rho_pp') + !$acc update device(rho_pp) call mpas_timer_start('atm_advance_acoustic_step') @@ -2322,8 +2377,10 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) ! rtheta_pp ! This is the only communications needed during the acoustic steps because we solve for u on all edges of owned cells - + call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) + !$acc update self(rtheta_pp) call exchange_halo_group(domain, 'dynamics:rtheta_pp') + !$acc update device(rtheta_pp) ! complete update of horizontal momentum by including 3d divergence damping at the end of the acoustic step @@ -2343,7 +2400,13 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) ! ! Communicate halos for rw_p[1,2], ru_p[1,2], rho_pp[1,2], rtheta_pp[2] ! + call mpas_pool_get_array(diag, 'ru_p', ru_p) + call mpas_pool_get_array(diag, 'rw_p', rw_p) + call mpas_pool_get_array(diag, 'rho_pp', rho_pp) + call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) + !$acc update self(rw_p,ru_p,rho_pp,rtheta_pp) call exchange_halo_group(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') + !$acc update device(rw_p,ru_p,rho_pp,rtheta_pp) call mpas_timer_start('atm_recover_large_step_variables') @@ -2378,7 +2441,6 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_atm_get_bdy_state(clock, block, nVertLevels, nEdges, 'u', time_dyn_step, ru_driving_values) ! do this inline at present - it is simple enough - !$acc enter data copyin(u) !$acc parallel default(present) !$acc loop gang worker do iEdge = 1, nEdgesSolve @@ -2390,12 +2452,10 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) end if end do !$acc end parallel - !$acc exit data copyout(u) call mpas_atm_get_bdy_state(clock, block, nVertLevels, nEdges, 'ru', time_dyn_step, ru_driving_values) call mpas_pool_get_array(diag, 'ru', u) ! do this inline at present - it is simple enough - !$acc enter data copyin(u) !$acc parallel default(present) !$acc loop gang worker do iEdge = 1, nEdges @@ -2407,7 +2467,6 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) end if end do !$acc end parallel - !$acc exit data copyout(u) deallocate(ru_driving_values) @@ -2415,12 +2474,15 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !------------------------------------------------------------------- + call mpas_pool_get_array(state, 'u', u, 2) + !$acc update self(u) ! u if (config_apply_lbcs) then call exchange_halo_group(domain, 'dynamics:u_123') else call exchange_halo_group(domain, 'dynamics:u_3') end if + !$acc update device(u) ! scalar advection: RK3 scheme of Skamarock and Gassmann (2011). ! PD or monotonicity constraints applied only on the final Runge-Kutta substep. @@ -2432,7 +2494,10 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS scalar transport + call mpas_pool_get_array(state, 'scalars', scalars_2, 2) + !$acc update self(scalars_2) call exchange_halo_group(domain, 'dynamics:scalars') + !$acc update device(scalars_2) allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) @@ -2484,17 +2549,25 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_timer_stop('atm_compute_solve_diagnostics') + call mpas_pool_get_array(state, 'w', w, 2) + call mpas_pool_get_array(diag, 'pv_edge', pv_edge) + call mpas_pool_get_array(diag, 'rho_edge', rho_edge) + !$acc update self(w,pv_edge,rho_edge) if (config_scalar_advection .and. (.not. config_split_dynamics_transport) ) then ! ! Communicate halos for w[1,2], pv_edge[1,2], rho_edge[1,2], scalars[1,2] ! + call mpas_pool_get_array(state, 'scalars', scalars_2, 2) + !$acc update self(scalars_2) call exchange_halo_group(domain, 'dynamics:w,pv_edge,rho_edge,scalars') + !$acc update device(scalars_2) else ! ! Communicate halos for w[1,2], pv_edge[1,2], rho_edge[1,2] ! call exchange_halo_group(domain, 'dynamics:w,pv_edge,rho_edge') end if + !$acc update device(w,pv_edge,rho_edge) ! set the zero-gradient condition on w for regional_MPAS @@ -2508,7 +2581,10 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !$OMP END PARALLEL DO ! w halo values needs resetting after regional boundary update + call mpas_pool_get_array(state, 'w', w, 2) + !$acc update self(w) call exchange_halo_group(domain, 'dynamics:w') + !$acc update device(w) end if ! end of regional_MPAS addition @@ -2519,7 +2595,12 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) ! ! Communicate halos for theta_m[1,2], pressure_p[1,2], and rtheta_p[1,2] ! + call mpas_pool_get_array(state, 'theta_m', theta_m, 2) + call mpas_pool_get_array(diag, 'pressure_p', pressure_p) + call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) + !$acc update self(theta_m,pressure_p,rtheta_p) call exchange_halo_group(domain, 'dynamics:theta_m,pressure_p,rtheta_p') + !$acc update device(theta_m,pressure_p,rtheta_p) ! ! Note: A halo exchange for 'exner' here as well as after the call @@ -2556,6 +2637,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) deallocate(qtot) ! we are finished with these now + !$acc exit data delete(tend_rtheta_physics,tend_rho_physics,tend_ru_physics) #ifndef MPAS_CAM_DYCORE call mpas_deallocate_scratch_field(tend_rtheta_physicsField) call mpas_deallocate_scratch_field(tend_rho_physicsField) @@ -2584,7 +2666,10 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS scalar transport ! need to fill halo for horizontal filter + call mpas_pool_get_array(state, 'scalars', scalars_2, 2) + !$acc update self(scalars_2) call exchange_halo_group(domain, 'dynamics:scalars') + !$acc update device(scalars_2) allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) @@ -2610,7 +2695,10 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !------------------------------------------------------------------------------------------------------------------------ if (rk_step < 3) then + call mpas_pool_get_array(state, 'scalars', scalars_2, 2) + !$acc update self(scalars_2) call exchange_halo_group(domain, 'dynamics:scalars') + !$acc update device(scalars_2) end if end do RK3_SPLIT_TRANSPORT @@ -2632,7 +2720,8 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) uReconstructY, & uReconstructZ, & uReconstructZonal, & - uReconstructMeridional & + uReconstructMeridional, & + lACC = .true. & ) @@ -2642,16 +2731,24 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) ! #ifdef DO_PHYSICS + MPAS_ACC_TIMER_START('atm_srk3: physics ACC_data_xfer') call mpas_pool_get_array(state, 'scalars', scalars_1, 1) + !$acc update self(scalars_1) call mpas_pool_get_array(state, 'scalars', scalars_2, 2) + !$acc update self(scalars_2) + MPAS_ACC_TIMER_STOP('atm_srk3: physics ACC_data_xfer') if(config_convection_scheme == 'cu_grell_freitas' .or. & config_convection_scheme == 'cu_ntiedtke') then + MPAS_ACC_TIMER_START('atm_srk3: physics ACC_data_xfer') call mpas_pool_get_array(tend_physics, 'rqvdynten', rqvdynten) call mpas_pool_get_array(state, 'theta_m', theta_m, 2) + !$acc update self(theta_m) call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) + !$acc update self(rthdynten) + MPAS_ACC_TIMER_STOP('atm_srk3: physics ACC_data_xfer') !NOTE: The calculation of the tendency due to horizontal and vertical advection for the water vapor mixing ratio !requires that the subroutine atm_advance_scalars_mono was called on the third Runge Kutta step, so that a halo @@ -2676,8 +2773,12 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) where ( scalars_2(:,:,:) < 0.0) & scalars_2(:,:,:) = 0.0 + MPAS_ACC_TIMER_START('atm_srk3: physics ACC_data_xfer') + !$acc update device(scalars_2, rthdynten) + MPAS_ACC_TIMER_STOP('atm_srk3: physics ACC_data_xfer') !call microphysics schemes: if (trim(config_microp_scheme) /= 'off') then + call pre_microphysics( block % configs, state, diag, 2) call mpas_timer_start('microphysics') !$OMP PARALLEL DO do thread=1,nThreads @@ -2686,6 +2787,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) end do !$OMP END PARALLEL DO call mpas_timer_stop('microphysics') + call post_microphysics( block % configs, state, diag, tend, 2) end if ! @@ -2723,7 +2825,10 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) if (config_apply_lbcs) then ! adjust boundary values for regional_MPAS scalar transport + call mpas_pool_get_array(state, 'scalars', scalars_2, 2) + !$acc update self(scalars_2) call exchange_halo_group(domain, 'dynamics:scalars') + !$acc update device(scalars_2) allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) @@ -3000,12 +3105,6 @@ subroutine atm_rk_integration_setup( state, diag, nVertLevels, num_scalars, & call mpas_pool_get_array(state, 'scalars', scalars_1, 1) call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - MPAS_ACC_TIMER_START('atm_rk_integration_setup [ACC_data_xfer]') - !$acc enter data create(ru_save, u_2, rw_save, rtheta_p_save, rho_p_save, & - !$acc w_2, theta_m_2, rho_zz_2, rho_zz_old_split, scalars_2) & - !$acc copyin(ru, rw, rtheta_p, rho_p, u_1, w_1, theta_m_1, & - !$acc rho_zz_1, scalars_1) - MPAS_ACC_TIMER_STOP('atm_rk_integration_setup [ACC_data_xfer]') !$acc kernels theta_m_2(:,cellEnd+1) = 0.0_RKIND @@ -3053,12 +3152,6 @@ subroutine atm_rk_integration_setup( state, diag, nVertLevels, num_scalars, & end do !$acc end parallel - MPAS_ACC_TIMER_START('atm_rk_integration_setup [ACC_data_xfer]') - !$acc exit data copyout(ru_save, rw_save, rtheta_p_save, rho_p_save, u_2, & - !$acc w_2, theta_m_2, rho_zz_2, rho_zz_old_split, scalars_2) & - !$acc delete(ru, rw, rtheta_p, rho_p, u_1, w_1, theta_m_1, & - !$acc rho_zz_1, scalars_1) - MPAS_ACC_TIMER_STOP('atm_rk_integration_setup [ACC_data_xfer]') end subroutine atm_rk_integration_setup @@ -3109,11 +3202,6 @@ subroutine atm_compute_moist_coefficients( dims, state, diag, mesh, & moist_start = moist_start_ptr moist_end = moist_end_ptr - MPAS_ACC_TIMER_START('atm_compute_moist_coefficients [ACC_data_xfer]') - !$acc enter data create(cqw, cqu) & - !$acc copyin(scalars) - MPAS_ACC_TIMER_STOP('atm_compute_moist_coefficients [ACC_data_xfer]') - !$acc parallel default(present) !$acc loop gang worker ! do iCell = cellSolveStart,cellSolveEnd @@ -3162,10 +3250,6 @@ subroutine atm_compute_moist_coefficients( dims, state, diag, mesh, & end do !$acc end parallel - MPAS_ACC_TIMER_START('atm_compute_moist_coefficients [ACC_data_xfer]') - !$acc exit data copyout(cqw, cqu) & - !$acc delete(scalars) - MPAS_ACC_TIMER_STOP('atm_compute_moist_coefficients [ACC_data_xfer]') end subroutine atm_compute_moist_coefficients @@ -3303,11 +3387,7 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, real (kind=RKIND) :: dtseps, c2, qtotal, rcv real (kind=RKIND), dimension( nVertLevels ) :: b_tri, c_tri - MPAS_ACC_TIMER_START('atm_compute_vert_imp_coefs_work [ACC_data_xfer]') - !$acc enter data copyin(cqw, p, t, rb, rtb, rt, pb) - !$acc enter data create(cofrz, cofwr, cofwz, coftz, cofwt, a_tri, b_tri, & - !$acc c_tri, alpha_tri, gamma_tri) - MPAS_ACC_TIMER_STOP('atm_compute_vert_imp_coefs_work [ACC_data_xfer]') + !$acc enter data create(b_tri, c_tri) ! set coefficients rcv = rgas/(cp-rgas) @@ -3393,11 +3473,7 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, end do ! loop over cells !$acc end parallel - MPAS_ACC_TIMER_START('atm_compute_vert_imp_coefs_work [ACC_data_xfer]') - !$acc exit data copyout(cofrz, cofwr, cofwz, coftz, cofwt, a_tri, b_tri, & - !$acc c_tri, alpha_tri, gamma_tri) - !$acc exit data delete(cqw, p, t, rb, rtb, rt, pb) - MPAS_ACC_TIMER_STOP('atm_compute_vert_imp_coefs_work [ACC_data_xfer]') + !$acc exit data delete(b_tri, c_tri) end subroutine atm_compute_vert_imp_coefs_work @@ -3501,9 +3577,6 @@ subroutine atm_set_smlstep_pert_variables_work(nCells, nEdges, & integer :: iCell, iEdge, i, k real (kind=RKIND) :: flux - MPAS_ACC_TIMER_START('atm_set_smlstep_pert_variables [ACC_data_xfer]') - !$acc enter data copyin(u_tend, w_tend) - MPAS_ACC_TIMER_STOP('atm_set_smlstep_pert_variables [ACC_data_xfer]') ! we solve for omega instead of w (see Klemp et al MWR 2007), ! so here we change the w_p tendency to an omega_p tendency @@ -3536,10 +3609,6 @@ subroutine atm_set_smlstep_pert_variables_work(nCells, nEdges, & end do !$acc end parallel - MPAS_ACC_TIMER_START('atm_set_smlstep_pert_variables [ACC_data_xfer]') - !$acc exit data delete(u_tend) - !$acc exit data copyout(w_tend) - MPAS_ACC_TIMER_STOP('atm_set_smlstep_pert_variables [ACC_data_xfer]') end subroutine atm_set_smlstep_pert_variables_work @@ -3779,17 +3848,6 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart c2 = cp * rcv rdts = 1./dts - MPAS_ACC_TIMER_START('atm_advance_acoustic_step [ACC_data_xfer]') - !$acc enter data copyin(exner,cqu,cofwt,coftz,cofrz,cofwr,cofwz, & - !$acc a_tri,alpha_tri,gamma_tri,rho_zz,theta_m,w, & - !$acc tend_ru,tend_rho,tend_rt,tend_rw,rw,rw_save) - !$acc enter data create(rtheta_pp_old) - if(small_step == 1) then - !$acc enter data create(ru_p,ruAvg,rho_pp,rtheta_pp,wwAvg,rw_p) - else - !$acc enter data copyin(ru_p,ruAvg,rho_pp,rtheta_pp,wwAvg,rw_p) - end if - MPAS_ACC_TIMER_STOP('atm_advance_acoustic_step [ACC_data_xfer]') if(small_step /= 1) then ! not needed on first small step @@ -4018,13 +4076,6 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart end do ! end of loop over cells !$acc end parallel - MPAS_ACC_TIMER_START('atm_advance_acoustic_step [ACC_data_xfer]') - !$acc exit data delete(exner,cqu,cofwt,coftz,cofrz,cofwr,cofwz, & - !$acc a_tri,alpha_tri,gamma_tri,rho_zz,theta_m,w, & - !$acc tend_ru,tend_rho,tend_rt,tend_rw,rw,rw_save) - !$acc exit data copyout(rtheta_pp_old,ru_p,ruAvg,rho_pp, & - !$acc rtheta_pp,wwAvg,rw_p) - MPAS_ACC_TIMER_STOP('atm_advance_acoustic_step [ACC_data_xfer]') end subroutine atm_advance_acoustic_step_work @@ -4076,9 +4127,6 @@ subroutine atm_divergence_damping_3d( state, diag, mesh, configs, dts, edgeStart nCellsSolve = nCellsSolve_ptr nVertLevels = nVertLevels_ptr - MPAS_ACC_TIMER_START('atm_divergence_damping_3d [ACC_data_xfer]') - !$acc enter data copyin(ru_p, rtheta_pp, rtheta_pp_old, theta_m) - MPAS_ACC_TIMER_STOP('atm_divergence_damping_3d [ACC_data_xfer]') !$acc parallel default(present) !$acc loop gang worker @@ -4111,10 +4159,6 @@ subroutine atm_divergence_damping_3d( state, diag, mesh, configs, dts, edgeStart end do ! end loop over edges !$acc end parallel - MPAS_ACC_TIMER_START('atm_divergence_damping_3d [ACC_data_xfer]') - !$acc exit data copyout(ru_p) & - !$acc delete(rtheta_pp, rtheta_pp_old, theta_m) - MPAS_ACC_TIMER_STOP('atm_divergence_damping_3d [ACC_data_xfer]') end subroutine atm_divergence_damping_3d @@ -4305,17 +4349,6 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE integer :: i, iCell, iEdge, k, cell1, cell2 real (kind=RKIND) :: invNs, rcv, p0, flux - MPAS_ACC_TIMER_START('atm_recover_large_step_variables [ACC_data_xfer]') - !$acc enter data copyin(rho_p_save,rho_pp,rho_base,rw_save,rw_p, & - !$acc rtheta_p_save,rtheta_pp,rtheta_base, & - !$acc ru_save,ru_p,wwAvg,ruAvg) & - !$acc create(rho_zz,rho_p,rw,w,rtheta_p,theta_m, & - !$acc ru,u) - if (rk_step == 3) then - !$acc enter data copyin(rt_diabatic_tend,exner_base) & - !$acc create(exner,pressure_p) - end if - MPAS_ACC_TIMER_STOP('atm_recover_large_step_variables [ACC_data_xfer]') rcv = rgas/(cp-rgas) p0 = 1.0e+05 ! this should come from somewhere else... @@ -4461,17 +4494,6 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE end do !$acc end parallel - MPAS_ACC_TIMER_START('atm_recover_large_step_variables [ACC_data_xfer]') - !$acc exit data delete(rho_p_save,rho_pp,rho_base,rw_save,rw_p, & - !$acc rtheta_p_save,rtheta_pp,rtheta_base, & - !$acc ru_save,ru_p) & - !$acc copyout(rho_zz,rho_p,rw,w,rtheta_p,theta_m, & - !$acc ru,u,wwAvg,ruAvg) - if (rk_step == 3) then - !$acc exit data delete(rt_diabatic_tend,exner_base) & - !$acc copyout(exner,pressure_p) - end if - MPAS_ACC_TIMER_STOP('atm_recover_large_step_variables [ACC_data_xfer]') end subroutine atm_recover_large_step_variables_work @@ -4706,10 +4728,6 @@ subroutine atm_advance_scalars_work(nCells, num_scalars, dt, & weight_time_old = 1. - weight_time_new - MPAS_ACC_TIMER_START('atm_advance_scalars [ACC_data_xfer]') - !$acc enter data copyin(uhAvg, scalar_new) - MPAS_ACC_TIMER_STOP('atm_advance_scalars [ACC_data_xfer]') - !$acc parallel async !$acc loop gang worker private(scalar_weight2, ica) do iEdge=edgeStart,edgeEnd @@ -4804,12 +4822,6 @@ subroutine atm_advance_scalars_work(nCells, num_scalars, dt, & ! MPAS_ACC_TIMER_START('atm_advance_scalars [ACC_data_xfer]') -#ifndef DO_PHYSICS - !$acc enter data create(scalar_tend_save) -#else - !$acc enter data copyin(scalar_tend_save) -#endif - !$acc enter data copyin(scalar_old, fnm, fnp, rdnw, wwAvg, rho_zz_old, rho_zz_new) !$acc enter data create(scalar_tend_column) MPAS_ACC_TIMER_STOP('atm_advance_scalars [ACC_data_xfer]') @@ -4892,9 +4904,7 @@ subroutine atm_advance_scalars_work(nCells, num_scalars, dt, & !$acc end parallel MPAS_ACC_TIMER_START('atm_advance_scalars [ACC_data_xfer]') - !$acc exit data copyout(scalar_new) - !$acc exit data delete(scalar_tend_column, uhAvg, wwAvg, scalar_old, fnm, fnp, & - !$acc rdnw, rho_zz_old, rho_zz_new, scalar_tend_save) + !$acc exit data delete(scalar_tend_column) MPAS_ACC_TIMER_STOP('atm_advance_scalars [ACC_data_xfer]') end subroutine atm_advance_scalars_work @@ -5152,22 +5162,6 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge ! The transport will maintain this positive definite solution and optionally, shape preservation (monotonicity). - MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') - !$acc data present(nEdgesOnCell, edgesOnCell, edgesOnCell_sign, & - !$acc invAreaCell, cellsOnCell, cellsOnEdge, nAdvCellsForEdge, & - !$acc advCellsForEdge, adv_coefs, adv_coefs_3rd, dvEdge, bdyMaskCell) - -#ifdef DO_PHYSICS - !$acc enter data copyin(scalar_tend) -#else - !$acc enter data create(scalar_tend) -#endif - if (local_advance_density) then - !$acc enter data copyin(rho_zz_int) - end if - !$acc enter data copyin(scalars_old, rho_zz_old, rdnw, uhAvg, wwAvg) - MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') - !$acc parallel !$acc loop gang worker @@ -5190,8 +5184,6 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge !$acc end parallel MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') - !$acc exit data copyout(scalar_tend) - !$acc update self(scalars_old) MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') @@ -5254,13 +5246,7 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge end if - MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') - if (.not. local_advance_density) then - !$acc enter data copyin(rho_zz_new) - end if - !$acc enter data copyin(scalars_new, fnm, fnp) !$acc enter data create(scale_arr) - MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') do iScalar = 1, num_scalars @@ -5763,18 +5749,7 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge end do ! loop over scalars - MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') - if (local_advance_density) then - !$acc exit data copyout(rho_zz_int) - else - !$acc exit data delete(rho_zz_new) - end if - !$acc exit data copyout(scalars_new) - !$acc exit data delete(scalars_old, scale_arr, rho_zz_old, wwAvg, & - !$acc uhAvg, fnm, fnp, rdnw) - - !$acc end data - MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') + !$acc exit data delete(scale_arr) end subroutine atm_advance_scalars_mono_work @@ -6305,57 +6280,14 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm MPAS_ACC_TIMER_START('atm_compute_dyn_tend_work [ACC_data_xfer]') - if (perturbation_coriolis) then - !$acc enter data copyin(u_init, v_init) - end if if (les_model_opt /= LES_MODEL_NONE) then - !$acc enter data copyin(exner, pressure_b, bn2) + !$acc enter data copyin(bn2) end if !$acc enter data copyin(ustm, hfx, qfx) - if (rk_step == 1) then - !$acc enter data create(tend_w_euler) - !$acc enter data create(tend_u_euler) - !$acc enter data create(tend_theta_euler) - !$acc enter data create(tend_rho) - - !$acc enter data copyin(tend_rho_physics) - !$acc enter data copyin(rb, rr_save) - !$acc enter data copyin(divergence, vorticity) - !$acc enter data copyin(v) - else - !$acc enter data copyin(tend_w_euler) - !$acc enter data copyin(tend_u_euler) - !$acc enter data copyin(tend_theta_euler) - !$acc enter data copyin(tend_rho) - end if - !$acc enter data create(tend_u) - !$acc enter data copyin(cqu, pp, u, w, pv_edge, rho_edge, ke) - !$acc enter data create(h_divergence) - !$acc enter data copyin(ru, rw) !$acc enter data create(rayleigh_damp_coef) - !$acc enter data copyin(tend_ru_physics) - !$acc enter data create(tend_w) - !$acc enter data copyin(rho_zz) - !$acc enter data create(tend_theta) - !$acc enter data copyin(theta_m) - !$acc enter data copyin(ru_save, theta_m_save) - !$acc enter data copyin(cqw) - !$acc enter data copyin(tend_rtheta_physics) - !$acc enter data copyin(rw_save, rt_diabatic_tend) - !$acc enter data create(rthdynten) - !$acc enter data copyin(t_init) - if (les_model_opt /= LES_MODEL_NONE) then - !$acc enter data copyin(ur_cell, vr_cell) - else -#ifdef CURVATURE - !$acc enter data copyin(ur_cell, vr_cell) -#endif - end if !$acc enter data create(eddy_visc_horz) !$acc enter data create(eddy_visc_vert) !$acc enter data create(prandtl_3d_inv) - !$acc enter data copyin(scalars) - !$acc enter data copyin(tend_scalars) MPAS_ACC_TIMER_STOP('atm_compute_dyn_tend_work [ACC_data_xfer]') prandtl_inv = 1.0_RKIND / prandtl @@ -6990,58 +6922,14 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc end parallel MPAS_ACC_TIMER_START('atm_compute_dyn_tend_work [ACC_data_xfer]') - if (perturbation_coriolis) then - !$acc exit data delete(u_init, v_init) - end if if (les_model_opt /= LES_MODEL_NONE) then - !$acc exit data delete(exner, pressure_b) !$acc exit data copyout(bn2) end if !$acc exit data delete(ustm, hfx, qfx) - if (rk_step == 1) then - !$acc exit data copyout(tend_w_euler) - !$acc exit data copyout(tend_u_euler) - !$acc exit data copyout(tend_theta_euler) - !$acc exit data copyout(tend_rho) - - !$acc exit data delete(tend_rho_physics) - !$acc exit data delete(rb, rr_save) - !$acc exit data delete(divergence, vorticity) - !$acc exit data delete(v) - else - !$acc exit data delete(tend_w_euler) - !$acc exit data delete(tend_u_euler) - !$acc exit data delete(tend_theta_euler) - !$acc exit data delete(tend_rho) - end if - !$acc exit data copyout(tend_u) - !$acc exit data delete(cqu, pp, u, w, pv_edge, rho_edge, ke) - !$acc exit data copyout(h_divergence) - !$acc exit data delete(ru, rw) !$acc exit data delete(rayleigh_damp_coef) - !$acc exit data delete(tend_ru_physics) - !$acc exit data copyout(tend_w) - !$acc exit data delete(rho_zz) - !$acc exit data copyout(tend_theta) - !$acc exit data delete(theta_m) - !$acc exit data delete(ru_save, theta_m_save) - !$acc exit data delete(cqw) - !$acc exit data delete(tend_rtheta_physics) - !$acc exit data delete(rw_save, rt_diabatic_tend) - !$acc exit data copyout(rthdynten) - !$acc exit data delete(t_init) - if (les_model_opt /= LES_MODEL_NONE) then - !$acc exit data delete(ur_cell, vr_cell) - else -#ifdef CURVATURE - !$acc exit data delete(ur_cell, vr_cell) -#endif - end if !$acc exit data delete(eddy_visc_horz) !$acc exit data delete(eddy_visc_vert) !$acc exit data delete(prandtl_3d_inv) - !$acc exit data delete(scalars) - !$acc exit data copyout(tend_scalars) MPAS_ACC_TIMER_STOP('atm_compute_dyn_tend_work [ACC_data_xfer]') end subroutine atm_compute_dyn_tend_work @@ -7210,26 +7098,10 @@ subroutine atm_compute_solve_diagnostics_work(nCells, nEdges, nVertices, & logical :: reconstruct_v - MPAS_ACC_TIMER_START('atm_compute_solve_diagnostics [ACC_data_xfer]') - !$acc enter data copyin(cellsOnEdge,dcEdge,dvEdge, & - !$acc edgesOnVertex,edgesOnVertex_sign,invAreaTriangle, & - !$acc nEdgesOnCell,edgesOnCell, & - !$acc edgesOnCell_sign,invAreaCell, & - !$acc invAreaTriangle,edgesOnVertex, & - !$acc verticesOnCell,kiteForCell,kiteAreasOnVertex, & - !$acc nEdgesOnEdge,edgesOnEdge,weightsOnEdge, & - !$acc fVertex, & - !$acc verticesOnEdge, & - !$acc invDvEdge,invDcEdge) - !$acc enter data copyin(u,h) - MPAS_ACC_TIMER_STOP('atm_compute_solve_diagnostics [ACC_data_xfer]') ! ! Compute height on cell edges at velocity locations ! - MPAS_ACC_TIMER_START('atm_compute_solve_diagnostics [ACC_data_xfer]') - !$acc enter data create(h_edge,vorticity,divergence) - MPAS_ACC_TIMER_STOP('atm_compute_solve_diagnostics [ACC_data_xfer]') !$acc parallel default(present) !$acc loop gang do iEdge=edgeStart,edgeEnd @@ -7314,9 +7186,6 @@ subroutine atm_compute_solve_diagnostics_work(nCells, nEdges, nVertices, & ! ! Replace 2.0 with 2 in exponentiation to avoid outside chance that ! compiler will actually allow "float raised to float" operation - MPAS_ACC_TIMER_START('atm_compute_solve_diagnostics [ACC_data_xfer]') - !$acc enter data create(ke) - MPAS_ACC_TIMER_STOP('atm_compute_solve_diagnostics [ACC_data_xfer]') !$acc parallel default(present) !$acc loop gang do iCell=cellStart,cellEnd @@ -7411,14 +7280,6 @@ subroutine atm_compute_solve_diagnostics_work(nCells, nEdges, nVertices, & if(rk_step /= 3) reconstruct_v = .false. end if - MPAS_ACC_TIMER_START('atm_compute_solve_diagnostics [ACC_data_xfer]') - if (reconstruct_v) then - !$acc enter data create(v) - else - !$acc enter data copyin(v) - end if - MPAS_ACC_TIMER_STOP('atm_compute_solve_diagnostics [ACC_data_xfer]') - if (reconstruct_v) then !$acc parallel default(present) !$acc loop gang @@ -7446,9 +7307,6 @@ subroutine atm_compute_solve_diagnostics_work(nCells, nEdges, nVertices, & ! ! Avoid dividing h_vertex by areaTriangle and move areaTriangle into ! numerator for the pv_vertex calculation - MPAS_ACC_TIMER_START('atm_compute_solve_diagnostics [ACC_data_xfer]') - !$acc enter data create(pv_vertex) - MPAS_ACC_TIMER_STOP('atm_compute_solve_diagnostics [ACC_data_xfer]') !$acc parallel default(present) !$acc loop collapse(2) do iVertex = vertexStart,vertexEnd @@ -7472,9 +7330,6 @@ subroutine atm_compute_solve_diagnostics_work(nCells, nEdges, nVertices, & ! Compute pv at the edges ! ( this computes pv_edge at all edges bounding real cells ) ! - MPAS_ACC_TIMER_START('atm_compute_solve_diagnostics [ACC_data_xfer]') - !$acc enter data create(pv_edge) - MPAS_ACC_TIMER_STOP('atm_compute_solve_diagnostics [ACC_data_xfer]') !$acc parallel default(present) !$acc loop collapse(2) do iEdge = edgeStart,edgeEnd @@ -7492,9 +7347,6 @@ subroutine atm_compute_solve_diagnostics_work(nCells, nEdges, nVertices, & ! ( this computes pv_cell for all real cells ) ! only needed for APVM upwinding ! - MPAS_ACC_TIMER_START('atm_compute_solve_diagnostics [ACC_data_xfer]') - !$acc enter data create(pv_cell) - MPAS_ACC_TIMER_STOP('atm_compute_solve_diagnostics [ACC_data_xfer]') !$acc parallel default(present) !$acc loop gang do iCell=cellStart,cellEnd @@ -7533,9 +7385,6 @@ subroutine atm_compute_solve_diagnostics_work(nCells, nEdges, nVertices, & ! Merged loops for calculating gradPVt, gradPVn and pv_edge ! Also precomputed inverses of dvEdge and dcEdge to avoid repeated divisions ! - MPAS_ACC_TIMER_START('atm_compute_solve_diagnostics [ACC_data_xfer]') - !$acc enter data create(gradPVt,gradPVn) - MPAS_ACC_TIMER_STOP('atm_compute_solve_diagnostics [ACC_data_xfer]') r = config_apvm_upwinding * dt !$acc parallel default(present) !$acc loop gang @@ -7552,31 +7401,10 @@ subroutine atm_compute_solve_diagnostics_work(nCells, nEdges, nVertices, & end do !$acc end parallel - MPAS_ACC_TIMER_START('atm_compute_solve_diagnostics [ACC_data_xfer]') - !$acc exit data delete(pv_cell,gradPVt,gradPVn) - MPAS_ACC_TIMER_STOP('atm_compute_solve_diagnostics [ACC_data_xfer]') end if ! apvm upwinding - MPAS_ACC_TIMER_START('atm_compute_solve_diagnostics [ACC_data_xfer]') - !$acc exit data delete(cellsOnEdge,dcEdge,dvEdge, & - !$acc edgesOnVertex,edgesOnVertex_sign,invAreaTriangle, & - !$acc nEdgesOnCell,edgesOnCell, & - !$acc edgesOnCell_sign,invAreaCell, & - !$acc invAreaTriangle,edgesOnVertex, & - !$acc verticesOnCell,kiteForCell,kiteAreasOnVertex, & - !$acc nEdgesOnEdge,edgesOnEdge,weightsOnEdge, & - !$acc verticesOnEdge, & - !$acc fVertex,invDvEdge,invDcEdge) - !$acc exit data delete(u,h) - !$acc exit data copyout(h_edge,vorticity,divergence, & - !$acc ke, & - !$acc v, & - !$acc pv_vertex, & - !$acc pv_edge) - MPAS_ACC_TIMER_STOP('atm_compute_solve_diagnostics [ACC_data_xfer]') - end subroutine atm_compute_solve_diagnostics_work @@ -7665,17 +7493,13 @@ subroutine atm_init_coupled_diagnostics(state, time_lev, diag, mesh, configs, & call mpas_pool_get_array(mesh, 'zb3_cell', zb3_cell) MPAS_ACC_TIMER_START('atm_init_coupled_diagnostics [ACC_data_xfer]') - ! copyin invariant fields - !$acc enter data copyin(cellsOnEdge,nEdgesOnCell,edgesOnCell, & - !$acc edgesOnCell_sign,zz,fzm,fzp,zb,zb3, & - !$acc zb_cell,zb3_cell) ! copyin the data that is only on the right-hand side - !$acc enter data copyin(scalars(index_qv,:,:),u,w,rho,theta, & + !$acc enter data copyin(scalars(index_qv,:,:),w,rho,theta, & !$acc rho_base,theta_base) ! copyin the data that will be modified in this routine - !$acc enter data create(theta_m,rho_zz,ru,rw,rho_p,rtheta_base, & + !$acc enter data create(theta_m,ru,rw,rho_p,rtheta_base, & !$acc rtheta_p,exner,exner_base,pressure_p, & !$acc pressure_base) MPAS_ACC_TIMER_STOP('atm_init_coupled_diagnostics [ACC_data_xfer]') @@ -7799,17 +7623,12 @@ subroutine atm_init_coupled_diagnostics(state, time_lev, diag, mesh, configs, & !$acc end parallel MPAS_ACC_TIMER_START('atm_init_coupled_diagnostics [ACC_data_xfer]') - ! delete invariant fields - !$acc exit data delete(cellsOnEdge,nEdgesOnCell,edgesOnCell, & - !$acc edgesOnCell_sign,zz,fzm,fzp,zb,zb3, & - !$acc zb_cell,zb3_cell) - ! delete the data that is only on the right-hand side - !$acc exit data delete(scalars(index_qv,:,:),u,w,rho,theta, & + !$acc exit data delete(scalars(index_qv,:,:),w,rho,theta, & !$acc rho_base,theta_base) ! copyout the data that will be modified in this routine - !$acc exit data copyout(theta_m,rho_zz,ru,rw,rho_p,rtheta_base, & + !$acc exit data copyout(theta_m,ru,rw,rho_p,rtheta_base, & !$acc rtheta_p,exner,exner_base,pressure_p, & !$acc pressure_base) MPAS_ACC_TIMER_STOP('atm_init_coupled_diagnostics [ACC_data_xfer]') @@ -7876,13 +7695,6 @@ subroutine atm_rk_dynamics_substep_finish( state, diag, nVertLevels, dynamics_su call mpas_pool_get_array(state, 'rho_zz', rho_zz_1, 1) call mpas_pool_get_array(state, 'rho_zz', rho_zz_2, 2) - MPAS_ACC_TIMER_START('atm_rk_dynamics_substep_finish [ACC_data_xfer]') - !$acc enter data create(ru_save, u_1, rtheta_p_save, theta_m_1, rho_p_save, rw_save, & - !$acc w_1, rho_zz_1) & - !$acc copyin(ru, u_2, rtheta_p, rho_p, theta_m_2, rho_zz_2, rw, & - !$acc w_2, ruAvg, wwAvg, ruAvg_split, wwAvg_split, rho_zz_old_split) - MPAS_ACC_TIMER_STOP('atm_rk_dynamics_substep_finish [ACC_data_xfer]') - ! Interim fix for the atm_compute_dyn_tend_work subroutine accessing uninitialized values ! in garbage cells of theta_m !$acc kernels @@ -7987,13 +7799,6 @@ subroutine atm_rk_dynamics_substep_finish( state, diag, nVertLevels, dynamics_su !$acc end parallel end if - MPAS_ACC_TIMER_START('atm_rk_dynamics_substep_finish [ACC_data_xfer]') - !$acc exit data copyout(ru_save, u_1, rtheta_p_save, rho_p_save, rw_save, & - !$acc w_1, theta_m_1, rho_zz_1, ruAvg, wwAvg, ruAvg_split, & - !$acc wwAvg_split) & - !$acc delete(ru, u_2, rtheta_p, rho_p, theta_m_2, rho_zz_2, rw, & - !$acc w_2, rho_zz_old_split) - MPAS_ACC_TIMER_STOP('atm_rk_dynamics_substep_finish [ACC_data_xfer]') end subroutine atm_rk_dynamics_substep_finish @@ -8048,9 +7853,6 @@ subroutine atm_zero_gradient_w_bdy_work( w, bdyMaskCell, nearestRelaxationCell, integer :: iCell, k - MPAS_ACC_TIMER_START('atm_zero_gradient_w_bdy_work [ACC_data_xfer]') - !$acc enter data copyin(w) - MPAS_ACC_TIMER_STOP('atm_zero_gradient_w_bdy_work [ACC_data_xfer]') !$acc parallel default(present) !$acc loop gang worker @@ -8066,9 +7868,6 @@ subroutine atm_zero_gradient_w_bdy_work( w, bdyMaskCell, nearestRelaxationCell, end do !$acc end parallel - MPAS_ACC_TIMER_START('atm_zero_gradient_w_bdy_work [ACC_data_xfer]') - !$acc exit data copyout(w) - MPAS_ACC_TIMER_STOP('atm_zero_gradient_w_bdy_work [ACC_data_xfer]') end subroutine atm_zero_gradient_w_bdy_work @@ -8109,11 +7908,6 @@ subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, mesh, config, nVertLevel call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) call mpas_pool_get_array(tend, 'rt_diabatic_tend', rt_diabatic_tend) - MPAS_ACC_TIMER_START('atm_bdy_adjust_dynamics_speczone_tend [ACC_data_xfer]') - !$acc enter data copyin(tend_ru,tend_rho,tend_rt,tend_rw, & - !$acc rt_diabatic_tend) - MPAS_ACC_TIMER_STOP('atm_bdy_adjust_dynamics_speczone_tend [ACC_data_xfer]') - !$acc parallel default(present) !$acc loop gang worker do iCell = cellSolveStart, cellSolveEnd @@ -8140,11 +7934,6 @@ subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, mesh, config, nVertLevel end if end do !$acc end parallel - - MPAS_ACC_TIMER_START('atm_bdy_adjust_dynamics_speczone_tend [ACC_data_xfer]') - !$acc exit data copyout(tend_ru,tend_rho,tend_rt, & - !$acc tend_rw,rt_diabatic_tend) - MPAS_ACC_TIMER_STOP('atm_bdy_adjust_dynamics_speczone_tend [ACC_data_xfer]') end subroutine atm_bdy_adjust_dynamics_speczone_tend @@ -8230,10 +8019,7 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( config, tend, state, diag, me divdamp_coef = divdamp_coef_ptr vertexDegree = vertexDegree_ptr - MPAS_ACC_TIMER_START('atm_bdy_adjust_dynamics_relaxzone_tend [ACC_data_xfer]') - !$acc enter data copyin(tend_rho, tend_rt, rho_zz, theta_m, tend_ru, ru) !$acc enter data create(divergence1, divergence2, vorticity1, vorticity2) - MPAS_ACC_TIMER_STOP('atm_bdy_adjust_dynamics_relaxzone_tend [ACC_data_xfer]') ! First, Rayleigh damping terms for ru, rtheta_m and rho_zz !$acc parallel default(present) @@ -8378,11 +8164,7 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( config, tend, state, diag, me end do ! end of loop over edges !$acc end parallel - MPAS_ACC_TIMER_START('atm_bdy_adjust_dynamics_relaxzone_tend [ACC_data_xfer]') - !$acc exit data copyout(tend_rho, tend_rt, tend_ru) - !$acc exit data delete(rho_zz, theta_m, ru, & - !$acc divergence1, divergence2, vorticity1, vorticity2) - MPAS_ACC_TIMER_STOP('atm_bdy_adjust_dynamics_relaxzone_tend [ACC_data_xfer]') + !$acc exit data delete(divergence1, divergence2, vorticity1, vorticity2) end subroutine atm_bdy_adjust_dynamics_relaxzone_tend @@ -8416,10 +8198,6 @@ subroutine atm_bdy_reset_speczone_values( state, diag, mesh, nVertLevels, & call mpas_pool_get_array(state, 'theta_m', theta_m, 2) call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) call mpas_pool_get_array(diag, 'rtheta_base', rtheta_base) - - MPAS_ACC_TIMER_START('atm_bdy_reset_speczone_values [ACC_data_xfer]') - !$acc enter data copyin(rtheta_base, theta_m, rtheta_p) - MPAS_ACC_TIMER_STOP('atm_bdy_reset_speczone_values [ACC_data_xfer]') !$acc parallel default(present) !$acc loop gang worker @@ -8434,11 +8212,6 @@ subroutine atm_bdy_reset_speczone_values( state, diag, mesh, nVertLevels, & end do !$acc end parallel - MPAS_ACC_TIMER_START('atm_bdy_reset_speczone_values [ACC_data_xfer]') - !$acc exit data copyout(theta_m, rtheta_p) & - !$acc delete(rtheta_base) - MPAS_ACC_TIMER_STOP('atm_bdy_reset_speczone_values [ACC_data_xfer]') - end subroutine atm_bdy_reset_speczone_values !------------------------------------------------------------------------- @@ -8527,10 +8300,7 @@ subroutine atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, integer :: iCell, iEdge, iScalar, i, k, cell1, cell2 !--- - MPAS_ACC_TIMER_START('atm_bdy_adjust_scalars [ACC_data_xfer]') - !$acc enter data create(scalars_tmp) & - !$acc copyin(scalars_new) - MPAS_ACC_TIMER_STOP('atm_bdy_adjust_scalars [ACC_data_xfer]') + !$acc enter data create(scalars_tmp) !$acc parallel default(present) !$acc loop gang worker @@ -8612,10 +8382,7 @@ subroutine atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, end do !$acc end parallel - MPAS_ACC_TIMER_START('atm_bdy_adjust_scalars [ACC_data_xfer]') - !$acc exit data delete(scalars_tmp) & - !$acc copyout(scalars_new) - MPAS_ACC_TIMER_STOP('atm_bdy_adjust_scalars [ACC_data_xfer]') + !$acc exit data delete(scalars_tmp) end subroutine atm_bdy_adjust_scalars_work @@ -8685,10 +8452,6 @@ subroutine atm_bdy_set_scalars_work( scalars_driving, scalars_new, & !--- - MPAS_ACC_TIMER_START('atm_bdy_set_scalars_work [ACC_data_xfer]') - !$acc enter data copyin(scalars_new) - MPAS_ACC_TIMER_STOP('atm_bdy_set_scalars_work [ACC_data_xfer]') - !$acc parallel default(present) !$acc loop gang worker do iCell = cellSolveStart, cellSolveEnd ! threaded over cells @@ -8709,10 +8472,6 @@ subroutine atm_bdy_set_scalars_work( scalars_driving, scalars_new, & end do ! updates now in temp storage !$acc end parallel - - MPAS_ACC_TIMER_START('atm_bdy_set_scalars_work [ACC_data_xfer]') - !$acc exit data copyout(scalars_new) - MPAS_ACC_TIMER_STOP('atm_bdy_set_scalars_work [ACC_data_xfer]') end subroutine atm_bdy_set_scalars_work @@ -8782,16 +8541,6 @@ subroutine summarize_timestep(domain) nVertLevels = nVertLevels_ptr num_scalars = num_scalars_ptr - MPAS_ACC_TIMER_START('summarize_timestep [ACC_data_xfer]') - if (config_print_detailed_minmax_vel) then - !$acc enter data copyin(w,u,v) - else if (config_print_global_minmax_vel) then - !$acc enter data copyin(w,u) - end if - if (config_print_global_minmax_sca) then - !$acc enter data copyin(scalars) - end if - MPAS_ACC_TIMER_STOP('summarize_timestep [ACC_data_xfer]') if (config_print_detailed_minmax_vel) then call mpas_log_write('') @@ -9150,17 +8899,6 @@ subroutine summarize_timestep(domain) end if - MPAS_ACC_TIMER_START('summarize_timestep [ACC_data_xfer]') - if (config_print_detailed_minmax_vel) then - !$acc exit data delete(w,u,v) - else if (config_print_global_minmax_vel) then - !$acc exit data delete(w,u) - end if - if (config_print_global_minmax_sca) then - !$acc exit data delete(scalars) - end if - MPAS_ACC_TIMER_STOP('summarize_timestep [ACC_data_xfer]') - end subroutine summarize_timestep end module atm_time_integration diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index 35c4034815..7a79527910 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -30,7 +30,8 @@ function atm_core_init(domain, startTimeStamp) result(ierr) use mpas_atm_dimensions, only : mpas_atm_set_dims use mpas_atm_diagnostics_manager, only : mpas_atm_diag_setup use mpas_atm_threading, only : mpas_atm_threading_init - use atm_time_integration, only : mpas_atm_dynamics_init + use atm_time_integration, only : mpas_atm_dynamics_init, & + mpas_atm_pre_dynamics, mpas_atm_post_dynamics use mpas_timer, only : mpas_timer_start, mpas_timer_stop use mpas_attlist, only : mpas_modify_att use mpas_string_utils, only : mpas_string_replace @@ -507,6 +508,7 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) + call mpas_atm_pre_compute_solve_diagnostics(block) !$OMP PARALLEL DO do thread=1,nThreads if (.not. config_do_restart .or. (config_do_restart .and. config_do_DAcycling)) then @@ -525,6 +527,7 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) edgeThreadStart(thread), edgeThreadEnd(thread)) end do !$OMP END PARALLEL DO + call mpas_atm_post_compute_solve_diagnostics(block) deallocate(ke_vertex) deallocate(ke_edge) @@ -538,13 +541,18 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) call mpas_pool_get_array(diag, 'uReconstructZ', uReconstructZ) call mpas_pool_get_array(diag, 'uReconstructZonal', uReconstructZonal) call mpas_pool_get_array(diag, 'uReconstructMeridional', uReconstructMeridional) + call mpas_reconstruct_2d_h2d(mesh, u, uReconstructX, uReconstructY, uReconstructZ, & + uReconstructZonal, uReconstructMeridional) call mpas_reconstruct(mesh, u, & uReconstructX, & uReconstructY, & uReconstructZ, & uReconstructZonal, & - uReconstructMeridional & + uReconstructMeridional, & + lACC = .true. & ) + call mpas_reconstruct_2d_d2h(mesh, u, uReconstructX, uReconstructY, uReconstructZ, & + uReconstructZonal, uReconstructMeridional) #ifdef DO_PHYSICS !proceed with initialization of physics parameterization if moist_physics is set to true: diff --git a/src/operators/mpas_vector_reconstruction.F b/src/operators/mpas_vector_reconstruction.F index 6e93c485fc..a1f92914bd 100644 --- a/src/operators/mpas_vector_reconstruction.F +++ b/src/operators/mpas_vector_reconstruction.F @@ -202,7 +202,8 @@ end subroutine mpas_init_reconstruct!}}} !> Input: grid meta data and vector component data residing at cell edges !> Output: reconstructed vector field (measured in X,Y,Z) located at cell centers !----------------------------------------------------------------------- - subroutine mpas_reconstruct_2d(meshPool, u, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional, includeHalos)!{{{ + subroutine mpas_reconstruct_2d(meshPool, u, uReconstructX, uReconstructY, uReconstructZ, & + uReconstructZonal, uReconstructMeridional, includeHalos, lACC)!{{{ implicit none @@ -214,9 +215,11 @@ subroutine mpas_reconstruct_2d(meshPool, u, uReconstructX, uReconstructY, uRecon real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructZonal !< Output: Zonal Component of velocity reconstructed to cell centers real (kind=RKIND), dimension(:,:), intent(out) :: uReconstructMeridional !< Output: Meridional Component of velocity reconstructed to cell centers logical, optional, intent(in) :: includeHalos !< Input: Optional logical that allows reconstruction over halo regions + logical, optional, intent(in) :: lACC !< Input: Optional logical that controls execution on the GPU with OpenACC ! temporary arrays needed in the compute procedure logical :: includeHalosLocal + logical :: lACCLocal integer, pointer :: nCells_ptr, nVertLevels_ptr integer :: nCells, nVertLevels integer, dimension(:,:), pointer :: edgesOnCell @@ -236,6 +239,12 @@ subroutine mpas_reconstruct_2d(meshPool, u, uReconstructX, uReconstructY, uRecon includeHalosLocal = .false. end if + if ( present(lACC) ) then + lACCLocal = lACC + else + lACCLocal = .false. + end if + ! stored arrays used during compute procedure call mpas_pool_get_array(meshPool, 'coeffs_reconstruct', coeffs_reconstruct) @@ -258,19 +267,9 @@ subroutine mpas_reconstruct_2d(meshPool, u, uReconstructX, uReconstructY, uRecon call mpas_pool_get_config(meshPool, 'on_a_sphere', on_a_sphere) - MPAS_ACC_TIMER_START('mpas_reconstruct_2d [ACC_data_xfer]') - ! Only use sections needed, nCells may be all cells or only non-halo cells - !$acc enter data copyin(coeffs_reconstruct(:,:,1:nCells),nEdgesOnCell(1:nCells), & - !$acc edgesOnCell(:,1:nCells),latCell(1:nCells),lonCell(1:nCells)) - !$acc enter data copyin(u(:,:)) - !$acc enter data create(uReconstructX(:,1:nCells),uReconstructY(:,1:nCells), & - !$acc uReconstructZ(:,1:nCells),uReconstructZonal(:,1:nCells), & - !$acc uReconstructMeridional(:,1:nCells)) - MPAS_ACC_TIMER_STOP('mpas_reconstruct_2d [ACC_data_xfer]') - ! loop over cell centers !$omp do schedule(runtime) - !$acc parallel default(present) + !$acc parallel default(present) if(lACCLocal) !$acc loop gang do iCell = 1, nCells ! initialize the reconstructed vectors @@ -305,7 +304,7 @@ subroutine mpas_reconstruct_2d(meshPool, u, uReconstructX, uReconstructY, uRecon if (on_a_sphere) then !$omp do schedule(runtime) - !$acc parallel default(present) + !$acc parallel default(present) if(lACCLocal) !$acc loop gang do iCell = 1, nCells clat = cos(latCell(iCell)) @@ -325,7 +324,7 @@ subroutine mpas_reconstruct_2d(meshPool, u, uReconstructX, uReconstructY, uRecon !$omp end do else !$omp do schedule(runtime) - !$acc parallel default(present) + !$acc parallel default(present) if(lACCLocal) !$acc loop gang vector collapse(2) do iCell = 1, nCells do k = 1, nVertLevels @@ -337,15 +336,6 @@ subroutine mpas_reconstruct_2d(meshPool, u, uReconstructX, uReconstructY, uRecon !$omp end do end if - MPAS_ACC_TIMER_START('mpas_reconstruct_2d [ACC_data_xfer]') - !$acc exit data delete(coeffs_reconstruct(:,:,1:nCells),nEdgesOnCell(1:nCells), & - !$acc edgesOnCell(:,1:nCells),latCell(1:nCells),lonCell(1:nCells)) - !$acc exit data delete(u(:,:)) - !$acc exit data copyout(uReconstructX(:,1:nCells),uReconstructY(:,1:nCells), & - !$acc uReconstructZ(:,1:nCells), uReconstructZonal(:,1:nCells), & - !$acc uReconstructMeridional(:,1:nCells)) - MPAS_ACC_TIMER_STOP('mpas_reconstruct_2d [ACC_data_xfer]') - end subroutine mpas_reconstruct_2d!}}} From eabe6d02a40dc32aa91788050cd58e26d08dc948 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Mon, 9 Mar 2026 17:16:01 -0600 Subject: [PATCH 171/214] Adding timers to measure ACC memory transfer costs This commit introduces changes to previously existing timers, and adds new timers in order to measure the time taken for OpenACC host-device memory transfers in various code regions after the memory movement consolidation introduced the previous commit. --- src/core_atmosphere/dynamics/mpas_atm_iau.F | 18 +++++++- .../dynamics/mpas_atm_time_integration.F | 44 ++++++++++++++++++- .../physics/mpas_atmphys_interface.F | 14 ++++++ .../physics/mpas_atmphys_todynamics.F | 13 ++++++ 4 files changed, 86 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_iau.F b/src/core_atmosphere/dynamics/mpas_atm_iau.F index e2e6af0059..d5650f6dee 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_iau.F +++ b/src/core_atmosphere/dynamics/mpas_atm_iau.F @@ -5,6 +5,15 @@ ! Additional copyright and license information can be found in the LICENSE file ! distributed with this code, or at http://mpas-dev.github.com/license.html ! + +#ifdef MPAS_OPENACC +#define MPAS_ACC_TIMER_START(X) call mpas_timer_start(X) +#define MPAS_ACC_TIMER_STOP(X) call mpas_timer_stop(X) +#else +#define MPAS_ACC_TIMER_START(X) +#define MPAS_ACC_TIMER_STOP(X) +#endif + module mpas_atm_iau use mpas_derived_types @@ -13,9 +22,10 @@ module mpas_atm_iau use mpas_dmpar use mpas_constants use mpas_log, only : mpas_log_write + use mpas_timer, only: mpas_timer_start, mpas_timer_stop + + !public :: atm_compute_iau_coef, atm_add_tend_anal_incr - !public :: atm_compute_iau_coef, atm_add_tend_anal_incr - contains !================================================================================================== @@ -98,6 +108,7 @@ subroutine pre_add_tend_anal_incr(configs,structs) call mpas_pool_get_subpool(structs, 'state', state) call mpas_pool_get_subpool(structs, 'diag', diag) + MPAS_ACC_TIMER_START('atm_srk3: physics ACC_data_xfer') call mpas_pool_get_array(state, 'theta_m', theta_m, 1) call mpas_pool_get_array(state, 'scalars', scalars, 1) call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) @@ -106,6 +117,7 @@ subroutine pre_add_tend_anal_incr(configs,structs) call mpas_pool_get_array(tend, 'scalars_tend', tend_scalars) !$acc update self(tend_scalars) + MPAS_ACC_TIMER_STOP('atm_srk3: physics ACC_data_xfer') #endif end subroutine pre_add_tend_anal_incr @@ -129,10 +141,12 @@ subroutine post_add_tend_anal_incr(configs,structs, tend_ru, tend_rtheta, tend_r call mpas_pool_get_subpool(structs, 'tend', tend) + MPAS_ACC_TIMER_START('atm_srk3: physics ACC_data_xfer') !$acc update device(tend_ru, tend_rtheta, tend_rho) call mpas_pool_get_array(tend, 'scalars_tend', tend_scalars) !$acc update device(tend_scalars) + MPAS_ACC_TIMER_STOP('atm_srk3: physics ACC_data_xfer') #endif end subroutine post_add_tend_anal_incr diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 8be3c79623..19c9ed8978 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -324,6 +324,8 @@ subroutine mpas_atm_dynamics_init(domain) nullify(mesh) call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', mesh) + MPAS_ACC_TIMER_START('mpas_dynamics_init [ACC_data_xfer]') + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) !$acc enter data copyin(dvEdge) @@ -527,6 +529,8 @@ subroutine mpas_atm_dynamics_init(domain) call mpas_pool_get_array(mesh, 'deformation_coef_s', deformation_coef_s) !$acc enter data copyin(deformation_coef_s) + + MPAS_ACC_TIMER_STOP('mpas_dynamics_init [ACC_data_xfer]') #endif end subroutine mpas_atm_dynamics_init @@ -595,6 +599,8 @@ subroutine mpas_atm_pre_compute_solve_diagnostics(block) nullify(diag) call mpas_pool_get_subpool(block % structs, 'diag', diag) + MPAS_ACC_TIMER_START('first_compute_solve_diagnostics [ACC_data_xfer]') + call mpas_pool_get_array(state, 'rho_zz', h, 1) !$acc enter data create(h) @@ -714,6 +720,7 @@ subroutine mpas_atm_pre_compute_solve_diagnostics(block) call mpas_pool_get_array(mesh, 'fVertex', fVertex) !$acc enter data copyin(fVertex) + MPAS_ACC_TIMER_STOP('first_compute_solve_diagnostics [ACC_data_xfer]') #endif end subroutine mpas_atm_pre_compute_solve_diagnostics @@ -783,6 +790,8 @@ subroutine mpas_atm_post_compute_solve_diagnostics(block) nullify(diag) call mpas_pool_get_subpool(block % structs, 'diag', diag) + MPAS_ACC_TIMER_START('first_compute_solve_diagnostics [ACC_data_xfer]') + call mpas_pool_get_array(state, 'rho_zz', h, 1) !$acc exit data copyout(h) call mpas_pool_get_array(state, 'u', u, 1) @@ -892,6 +901,7 @@ subroutine mpas_atm_post_compute_solve_diagnostics(block) call mpas_pool_get_array(mesh, 'fVertex', fVertex) !$acc exit data delete(fVertex) + MPAS_ACC_TIMER_STOP('first_compute_solve_diagnostics [ACC_data_xfer]') #endif end subroutine mpas_atm_post_compute_solve_diagnostics @@ -973,6 +983,7 @@ subroutine mpas_atm_pre_dynamics(domain) call mpas_pool_get_config(domain % blocklist % configs, 'config_apply_lbcs', config_apply_lbcs_ptr) config_apply_lbcs = config_apply_lbcs_ptr + MPAS_ACC_TIMER_START('atm_srk3 [ACC_data_xfer]') call mpas_pool_get_array(diag, 'ru', ru) !$acc enter data copyin(ru) ! use values from atm_init_coupled_diagnostics call mpas_pool_get_array(diag, 'ru_p', ru_p) @@ -1176,6 +1187,7 @@ subroutine mpas_atm_pre_dynamics(domain) call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) !$acc enter data copyin(rthdynten) + MPAS_ACC_TIMER_STOP('atm_srk3 [ACC_data_xfer]') #endif end subroutine mpas_atm_pre_dynamics @@ -1257,6 +1269,7 @@ subroutine mpas_atm_post_dynamics(domain) call mpas_pool_get_config(domain % blocklist % configs, 'config_apply_lbcs', config_apply_lbcs_ptr) config_apply_lbcs = config_apply_lbcs_ptr + MPAS_ACC_TIMER_START('atm_srk3 [ACC_data_xfer]') call mpas_pool_get_array(diag, 'ru', ru) !$acc exit data copyout(ru) ! use values from atm_init_coupled_diagnostics call mpas_pool_get_array(diag, 'ru_p', ru_p) @@ -1458,6 +1471,7 @@ subroutine mpas_atm_post_dynamics(domain) call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) !$acc exit data copyout(rthdynten) + MPAS_ACC_TIMER_STOP('atm_srk3 [ACC_data_xfer]') #endif end subroutine mpas_atm_post_dynamics @@ -2096,6 +2110,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) ! ! Communicate halos for theta_m, scalars, pressure_p, and rtheta_p ! + MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(state, 'theta_m', theta_m, 1) call mpas_pool_get_array(state, 'scalars', scalars_1, 1) call mpas_pool_get_array(diag, 'pressure_p', pressure_p) @@ -2103,6 +2118,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !$acc update self(theta_m,scalars_1,pressure_p,rtheta_p) call exchange_halo_group(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') !$acc update device(theta_m,scalars_1,pressure_p,rtheta_p) + MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_timer_start('atm_rk_integration_setup') @@ -2191,10 +2207,12 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !$OMP END PARALLEL DO call mpas_timer_stop('atm_compute_vert_imp_coefs') - call mpas_pool_get_array(diag, 'exner', exner) + MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') + call mpas_pool_get_array(diag, 'exner', exner) !$acc update self(exner) call exchange_halo_group(domain, 'dynamics:exner') !$acc update device(exner) + MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! BEGIN Runge-Kutta loop @@ -2273,10 +2291,12 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !*********************************** ! tend_u + MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(tend, 'u', tend_u) !$acc update self(tend_u) call exchange_halo_group(domain, 'dynamics:tend_u') !$acc update device(tend_u) + MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_timer_start('small_step_prep') @@ -2352,10 +2372,12 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) do small_step = 1, number_sub_steps(rk_step) + MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(diag, 'rho_pp', rho_pp) !$acc update self(rho_pp) call exchange_halo_group(domain, 'dynamics:rho_pp') !$acc update device(rho_pp) + MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_timer_start('atm_advance_acoustic_step') @@ -2377,10 +2399,12 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) ! rtheta_pp ! This is the only communications needed during the acoustic steps because we solve for u on all edges of owned cells + MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) !$acc update self(rtheta_pp) call exchange_halo_group(domain, 'dynamics:rtheta_pp') !$acc update device(rtheta_pp) + MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') ! complete update of horizontal momentum by including 3d divergence damping at the end of the acoustic step @@ -2400,6 +2424,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) ! ! Communicate halos for rw_p[1,2], ru_p[1,2], rho_pp[1,2], rtheta_pp[2] ! + MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(diag, 'ru_p', ru_p) call mpas_pool_get_array(diag, 'rw_p', rw_p) call mpas_pool_get_array(diag, 'rho_pp', rho_pp) @@ -2407,6 +2432,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !$acc update self(rw_p,ru_p,rho_pp,rtheta_pp) call exchange_halo_group(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') !$acc update device(rw_p,ru_p,rho_pp,rtheta_pp) + MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_timer_start('atm_recover_large_step_variables') @@ -2474,6 +2500,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !------------------------------------------------------------------- + MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(state, 'u', u, 2) !$acc update self(u) ! u @@ -2483,6 +2510,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call exchange_halo_group(domain, 'dynamics:u_3') end if !$acc update device(u) + MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') ! scalar advection: RK3 scheme of Skamarock and Gassmann (2011). ! PD or monotonicity constraints applied only on the final Runge-Kutta substep. @@ -2494,10 +2522,12 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS scalar transport + MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(state, 'scalars', scalars_2, 2) !$acc update self(scalars_2) call exchange_halo_group(domain, 'dynamics:scalars') !$acc update device(scalars_2) + MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) @@ -2549,6 +2579,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_timer_stop('atm_compute_solve_diagnostics') + MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(state, 'w', w, 2) call mpas_pool_get_array(diag, 'pv_edge', pv_edge) call mpas_pool_get_array(diag, 'rho_edge', rho_edge) @@ -2568,6 +2599,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call exchange_halo_group(domain, 'dynamics:w,pv_edge,rho_edge') end if !$acc update device(w,pv_edge,rho_edge) + MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') ! set the zero-gradient condition on w for regional_MPAS @@ -2580,11 +2612,13 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) end do !$OMP END PARALLEL DO + MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') ! w halo values needs resetting after regional boundary update call mpas_pool_get_array(state, 'w', w, 2) !$acc update self(w) call exchange_halo_group(domain, 'dynamics:w') !$acc update device(w) + MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') end if ! end of regional_MPAS addition @@ -2595,12 +2629,14 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) ! ! Communicate halos for theta_m[1,2], pressure_p[1,2], and rtheta_p[1,2] ! + MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(state, 'theta_m', theta_m, 2) call mpas_pool_get_array(diag, 'pressure_p', pressure_p) call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) !$acc update self(theta_m,pressure_p,rtheta_p) call exchange_halo_group(domain, 'dynamics:theta_m,pressure_p,rtheta_p') !$acc update device(theta_m,pressure_p,rtheta_p) + MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') ! ! Note: A halo exchange for 'exner' here as well as after the call @@ -2665,11 +2701,13 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS scalar transport + MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') ! need to fill halo for horizontal filter call mpas_pool_get_array(state, 'scalars', scalars_2, 2) !$acc update self(scalars_2) call exchange_halo_group(domain, 'dynamics:scalars') !$acc update device(scalars_2) + MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) @@ -2695,10 +2733,12 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !------------------------------------------------------------------------------------------------------------------------ if (rk_step < 3) then + MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(state, 'scalars', scalars_2, 2) !$acc update self(scalars_2) call exchange_halo_group(domain, 'dynamics:scalars') !$acc update device(scalars_2) + MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') end if end do RK3_SPLIT_TRANSPORT @@ -2825,10 +2865,12 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) if (config_apply_lbcs) then ! adjust boundary values for regional_MPAS scalar transport + MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(state, 'scalars', scalars_2, 2) !$acc update self(scalars_2) call exchange_halo_group(domain, 'dynamics:scalars') !$acc update device(scalars_2) + MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index 8bbbaa28b5..0ba98371e8 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -6,12 +6,22 @@ ! distributed with this code, or at http://mpas-dev.github.com/license.html ! !================================================================================================================= + +#ifdef MPAS_OPENACC +#define MPAS_ACC_TIMER_START(X) call mpas_timer_start(X) +#define MPAS_ACC_TIMER_STOP(X) call mpas_timer_stop(X) +#else +#define MPAS_ACC_TIMER_START(X) +#define MPAS_ACC_TIMER_STOP(X) +#endif + module mpas_atmphys_interface use mpas_kind_types use mpas_pool_routines use mpas_atmphys_constants use mpas_atmphys_vars + use mpas_timer, only: mpas_timer_start, mpas_timer_stop implicit none private @@ -566,6 +576,7 @@ subroutine pre_microphysics(configs,state,diag,time_lev) real(kind=RKIND),dimension(:,:,:),pointer:: scalars + MPAS_ACC_TIMER_START('pre_microphysics [ACC_data_xfer]') call mpas_pool_get_array(diag,'exner' ,exner ) call mpas_pool_get_array(diag,'pressure_base',pressure_b) call mpas_pool_get_array(diag,'pressure_p' ,pressure_p) @@ -578,6 +589,7 @@ subroutine pre_microphysics(configs,state,diag,time_lev) call mpas_pool_get_array(state,'scalars',scalars,time_lev) !$acc update host(scalars) + MPAS_ACC_TIMER_STOP('pre_microphysics [ACC_data_xfer]') #endif end subroutine pre_microphysics @@ -1160,9 +1172,11 @@ subroutine post_microphysics(configs,state,diag,tend,time_lev) call mpas_pool_get_array(tend,'rt_diabatic_tend',rt_diabatic_tend) + MPAS_ACC_TIMER_START('post_microphysics [ACC_data_xfer]') !$acc update device(exner, exner_b, pressure_b, pressure_p, rtheta_b) !$acc update device(rtheta_p, rho_zz, theta_m, scalars) !$acc update device(rt_diabatic_tend) + MPAS_ACC_TIMER_STOP('post_microphysics [ACC_data_xfer]') #endif end subroutine post_microphysics diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index 154940be73..39f3aea841 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -6,6 +6,15 @@ ! distributed with this code, or at http://mpas-dev.github.com/license.html ! !================================================================================================================= + +#ifdef MPAS_OPENACC +#define MPAS_ACC_TIMER_START(X) call mpas_timer_start(X) +#define MPAS_ACC_TIMER_STOP(X) call mpas_timer_stop(X) +#else +#define MPAS_ACC_TIMER_START(X) +#define MPAS_ACC_TIMER_STOP(X) +#endif + module mpas_atmphys_todynamics use mpas_kind_types use mpas_pool_routines @@ -69,6 +78,7 @@ subroutine pre_physics_get_tend(configs,state,diag,tend) real(kind=RKIND),dimension(:,:),pointer:: tend_u_phys real(kind=RKIND),dimension(:,:,:),pointer:: tend_scalars + MPAS_ACC_TIMER_START('atm_srk3: physics ACC_data_xfer') call mpas_pool_get_array(state,'theta_m' ,theta_m,1) call mpas_pool_get_array(state,'scalars' ,scalars,1) call mpas_pool_get_array(state,'rho_zz' ,mass,2 ) @@ -79,6 +89,7 @@ subroutine pre_physics_get_tend(configs,state,diag,tend) call mpas_pool_get_array(tend,'scalars_tend',tend_scalars) !$acc update self(tend_scalars) ! Probably not needed + MPAS_ACC_TIMER_STOP('atm_srk3: physics ACC_data_xfer') #endif end subroutine pre_physics_get_tend @@ -281,8 +292,10 @@ subroutine post_physics_get_tend(configs,state,diag,tend) !local variables: real(kind=RKIND),dimension(:,:,:),pointer:: tend_scalars + MPAS_ACC_TIMER_START('atm_srk3: physics ACC_data_xfer') call mpas_pool_get_array(tend,'scalars_tend',tend_scalars) !$acc update device(tend_scalars) + MPAS_ACC_TIMER_STOP('atm_srk3: physics ACC_data_xfer') #endif end subroutine post_physics_get_tend From 84aa45b55741f030ec394d1f4ecb3cdd42163f0c Mon Sep 17 00:00:00 2001 From: "G. Dylan Dickerson" Date: Mon, 16 Mar 2026 23:57:48 -0600 Subject: [PATCH 172/214] Enable GPU-aware halo exchanges via OpenACC directives This commit enables execution of halo exchanges on GPUs via OpenACC directives, if the MPAS atmosphere core has been built with an appropriate GPU-aware MPI distribution. Module mpas_halo is modified in the following ways to enable GPU-aware halo exchanges: - In the call to mpas_halo_exch_group_complete, OpenACC directives copy to device all the relevant fields and metadata that are required for the packing and unpacking loops later. - OpenACC directives are introduced around the packing and unpacking loops to perform the field to/from send/recv buffer operations on the device. The attach clauses introduced to the parallel constructs ensures that the device pointers are attached to the device targets at the start of the parallel region and detached at the end of the region. - The actual MPI_Isend and MPI_Irecv operations use GPU-aware MPI, by wrapping these calls within !$acc host_data constructs. Note: This commit introduces temporary host-device data movements in the atm_core_init routine around the two calls to exchange_halo_group. This is required just for this commit as all halo-exchanges occur on the device and fields not yet present on the device must be copied over to it before the halo exchanges and back to host after it. These copies will be removed in subsequent commits. --- .../dynamics/mpas_atm_time_integration.F | 34 --------- src/core_atmosphere/mpas_atm_core.F | 19 +++++ src/framework/mpas_halo.F | 76 +++++++++++++++++++ 3 files changed, 95 insertions(+), 34 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 19c9ed8978..77109da9bc 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -2115,9 +2115,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_pool_get_array(state, 'scalars', scalars_1, 1) call mpas_pool_get_array(diag, 'pressure_p', pressure_p) call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) - !$acc update self(theta_m,scalars_1,pressure_p,rtheta_p) call exchange_halo_group(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') - !$acc update device(theta_m,scalars_1,pressure_p,rtheta_p) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_timer_start('atm_rk_integration_setup') @@ -2209,9 +2207,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(diag, 'exner', exner) - !$acc update self(exner) call exchange_halo_group(domain, 'dynamics:exner') - !$acc update device(exner) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -2293,9 +2289,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) ! tend_u MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(tend, 'u', tend_u) - !$acc update self(tend_u) call exchange_halo_group(domain, 'dynamics:tend_u') - !$acc update device(tend_u) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_timer_start('small_step_prep') @@ -2374,9 +2368,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(diag, 'rho_pp', rho_pp) - !$acc update self(rho_pp) call exchange_halo_group(domain, 'dynamics:rho_pp') - !$acc update device(rho_pp) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_timer_start('atm_advance_acoustic_step') @@ -2401,9 +2393,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) ! This is the only communications needed during the acoustic steps because we solve for u on all edges of owned cells MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) - !$acc update self(rtheta_pp) call exchange_halo_group(domain, 'dynamics:rtheta_pp') - !$acc update device(rtheta_pp) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') ! complete update of horizontal momentum by including 3d divergence damping at the end of the acoustic step @@ -2429,9 +2419,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_pool_get_array(diag, 'rw_p', rw_p) call mpas_pool_get_array(diag, 'rho_pp', rho_pp) call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) - !$acc update self(rw_p,ru_p,rho_pp,rtheta_pp) call exchange_halo_group(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') - !$acc update device(rw_p,ru_p,rho_pp,rtheta_pp) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_timer_start('atm_recover_large_step_variables') @@ -2502,14 +2490,12 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(state, 'u', u, 2) - !$acc update self(u) ! u if (config_apply_lbcs) then call exchange_halo_group(domain, 'dynamics:u_123') else call exchange_halo_group(domain, 'dynamics:u_3') end if - !$acc update device(u) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') ! scalar advection: RK3 scheme of Skamarock and Gassmann (2011). @@ -2524,9 +2510,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - !$acc update self(scalars_2) call exchange_halo_group(domain, 'dynamics:scalars') - !$acc update device(scalars_2) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) @@ -2583,22 +2567,18 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_pool_get_array(state, 'w', w, 2) call mpas_pool_get_array(diag, 'pv_edge', pv_edge) call mpas_pool_get_array(diag, 'rho_edge', rho_edge) - !$acc update self(w,pv_edge,rho_edge) if (config_scalar_advection .and. (.not. config_split_dynamics_transport) ) then ! ! Communicate halos for w[1,2], pv_edge[1,2], rho_edge[1,2], scalars[1,2] ! call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - !$acc update self(scalars_2) call exchange_halo_group(domain, 'dynamics:w,pv_edge,rho_edge,scalars') - !$acc update device(scalars_2) else ! ! Communicate halos for w[1,2], pv_edge[1,2], rho_edge[1,2] ! call exchange_halo_group(domain, 'dynamics:w,pv_edge,rho_edge') end if - !$acc update device(w,pv_edge,rho_edge) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') ! set the zero-gradient condition on w for regional_MPAS @@ -2615,9 +2595,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') ! w halo values needs resetting after regional boundary update call mpas_pool_get_array(state, 'w', w, 2) - !$acc update self(w) call exchange_halo_group(domain, 'dynamics:w') - !$acc update device(w) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') end if ! end of regional_MPAS addition @@ -2633,9 +2611,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_pool_get_array(state, 'theta_m', theta_m, 2) call mpas_pool_get_array(diag, 'pressure_p', pressure_p) call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) - !$acc update self(theta_m,pressure_p,rtheta_p) call exchange_halo_group(domain, 'dynamics:theta_m,pressure_p,rtheta_p') - !$acc update device(theta_m,pressure_p,rtheta_p) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') ! @@ -2704,9 +2680,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') ! need to fill halo for horizontal filter call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - !$acc update self(scalars_2) call exchange_halo_group(domain, 'dynamics:scalars') - !$acc update device(scalars_2) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) @@ -2735,9 +2709,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) if (rk_step < 3) then MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - !$acc update self(scalars_2) call exchange_halo_group(domain, 'dynamics:scalars') - !$acc update device(scalars_2) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') end if @@ -2867,9 +2839,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - !$acc update self(scalars_2) call exchange_halo_group(domain, 'dynamics:scalars') - !$acc update device(scalars_2) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) @@ -5226,7 +5196,6 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge !$acc end parallel MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') - !$acc update self(scalars_old) MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') !$OMP BARRIER @@ -5236,7 +5205,6 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge !$OMP BARRIER MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') - !$acc update device(scalars_old) MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') ! @@ -5633,7 +5601,6 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge ! MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') - !$acc update self(scale_arr) MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') !$OMP BARRIER @@ -5643,7 +5610,6 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge !$OMP BARRIER MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') - !$acc update device(scale_arr) MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') !$acc parallel diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index 7a79527910..5da37f931b 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -60,6 +60,7 @@ function atm_core_init(domain, startTimeStamp) result(ierr) character (len=StrKIND), pointer :: initial_time1, initial_time2 type (MPAS_Time_Type) :: startTime + real (kind=RKIND), dimension(:,:), pointer :: u, ru, rw, pv_edge real (kind=RKIND), pointer :: nominalMinDc real (kind=RKIND), pointer :: config_len_disp real (kind=RKIND), pointer :: Time @@ -238,7 +239,14 @@ function atm_core_init(domain, startTimeStamp) result(ierr) startTime = mpas_get_clock_time(clock, MPAS_START_TIME, ierr) call mpas_get_time(startTime, dateTimeString=startTimeStamp) + ! This copy is temporarily needed to ensure that the field u is available on the device + ! prior to the GPU-direct halo exchange in the call to exchange_halo_group. It will be + ! removed in subsequent commits that introduce a namelist option to select whether halo exchanges + ! are performed on the device or not. + call mpas_pool_get_array(domain % blocklist % allFields, 'u', u, 1) + !$acc enter data copyin(u) call exchange_halo_group(domain, 'initialization:u') + !$acc exit data copyout(u) ! @@ -276,7 +284,18 @@ function atm_core_init(domain, startTimeStamp) result(ierr) block => block % next end do + ! This copy is temporarily needed to ensure that ru, rw, pv_edge are available on the device + ! prior to the GPU-direct halo exchange in the call to exchange_halo_group. It will be + ! removed in subsequent commits that introduce a namelist option to select whether halo exchanges + ! are performed on the device or not. + call mpas_pool_get_array(domain % blocklist % allFields, 'ru', ru, 1) + !$acc enter data copyin(ru) + call mpas_pool_get_array(domain % blocklist % allFields, 'rw', rw, 1) + !$acc enter data copyin(rw) + call mpas_pool_get_array(domain % blocklist % allFields, 'pv_edge', pv_edge) + !$acc enter data copyin(pv_edge) call exchange_halo_group(domain, 'initialization:pv_edge,ru,rw') + !$acc exit data copyout(pv_edge,ru,rw) call mpas_atm_diag_setup(domain % streamManager, domain % blocklist % configs, & domain % blocklist % structs, domain % clock, domain % dminfo) diff --git a/src/framework/mpas_halo.F b/src/framework/mpas_halo.F index 4ab8817c23..582afa7c34 100644 --- a/src/framework/mpas_halo.F +++ b/src/framework/mpas_halo.F @@ -280,6 +280,29 @@ subroutine mpas_halo_exch_group_complete(domain, groupName, iErr) call refactor_lists(domain, groupName, iErr) + ! Logic to return early if there are no neighbors to send to + if ( newGroup% nGroupSendNeighbors <=0 ) then + return + end if + + + ! Always copy in the main data member first + !$acc enter data copyin(newGroup) + ! Then the data in the members of the type + !$acc enter data copyin(newGroup % recvBuf(:), newGroup % sendBuf(:)) + !$acc enter data copyin(newGroup % fields(:)) + do i = 1, newGroup % nFields + !$acc enter data copyin(newGroup % fields(i)) + !$acc enter data copyin(newGroup % fields(i) % nSendLists(:,:)) + !$acc enter data copyin(newGroup % fields(i) % packOffsets(:)) + !$acc enter data copyin(newGroup % fields(i) % sendListSrc(:,:,:)) + !$acc enter data copyin(newGroup % fields(i) % sendListDst(:,:,:)) + !$acc enter data copyin(newGroup % fields(i) % nRecvLists(:,:)) + !$acc enter data copyin(newGroup % fields(i) % unpackOffsets(:)) + !$acc enter data copyin(newGroup % fields(i) % recvListSrc(:,:,:)) + !$acc enter data copyin(newGroup % fields(i) % recvListDst(:,:,:)) + end do + end subroutine mpas_halo_exch_group_complete @@ -349,15 +372,26 @@ subroutine mpas_halo_exch_group_destroy(domain, groupName, iErr) deallocate(cursor % fields(i) % compactHaloInfo) deallocate(cursor % fields(i) % compactSendLists) deallocate(cursor % fields(i) % compactRecvLists) + !$acc exit data delete(cursor % fields(i) % nSendLists(:,:)) deallocate(cursor % fields(i) % nSendLists) + !$acc exit data delete(cursor % fields(i) % sendListSrc(:,:,:)) deallocate(cursor % fields(i) % sendListSrc) + !$acc exit data delete(cursor % fields(i) % sendListDst(:,:,:)) deallocate(cursor % fields(i) % sendListDst) + !$acc exit data delete(cursor % fields(i) % packOffsets(:)) deallocate(cursor % fields(i) % packOffsets) + !$acc exit data delete(cursor % fields(i) % nRecvLists(:,:)) deallocate(cursor % fields(i) % nRecvLists) + !$acc exit data delete(cursor % fields(i) % recvListSrc(:,:,:)) deallocate(cursor % fields(i) % recvListSrc) + !$acc exit data delete(cursor % fields(i) % recvListDst(:,:,:)) deallocate(cursor % fields(i) % recvListDst) + !$acc exit data delete(cursor % fields(i) % unpackOffsets(:)) deallocate(cursor % fields(i) % unpackOffsets) + !$acc exit data delete(cursor % fields(i)) end do + ! Use finalize here in-case the copyins in ..._complete increment the reference counter + !$acc exit data finalize delete(cursor % fields(:)) deallocate(cursor % fields) deallocate(cursor % groupPackOffsets) deallocate(cursor % groupSendNeighbors) @@ -368,10 +402,14 @@ subroutine mpas_halo_exch_group_destroy(domain, groupName, iErr) deallocate(cursor % groupToFieldRecvIdx) deallocate(cursor % groupRecvOffsets) deallocate(cursor % groupRecvCounts) + !$acc exit data delete(cursor % sendBuf(:)) deallocate(cursor % sendBuf) + !$acc exit data delete(cursor % recvBuf(:)) deallocate(cursor % recvBuf) deallocate(cursor % sendRequests) deallocate(cursor % recvRequests) + ! Finalize here as well, just in-case + !$acc exit data finalize delete(cursor) deallocate(cursor) end subroutine mpas_halo_exch_group_destroy @@ -577,6 +615,11 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) messageType=MPAS_LOG_CRIT) end if + ! Logic to return early if there are no neighbors to send to + if ( group% nGroupSendNeighbors <= 0 ) then + return + end if + ! ! Get the rank of this task and the MPI communicator to use from the first field in ! the group; all fields should be using the same communicator, so this should not @@ -598,9 +641,11 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) bufstart = group % groupRecvOffsets(i) bufend = group % groupRecvOffsets(i) + group % groupRecvCounts(i) - 1 !TO DO: how do we determine appropriate type here? + !$acc host_data use_device(group % recvBuf) call MPI_Irecv(group % recvBuf(bufstart:bufend), group % groupRecvCounts(i), MPI_REALKIND, & group % groupRecvNeighbors(i), group % groupRecvNeighbors(i), comm, & group % recvRequests(i), mpi_ierr) + !$acc end host_data else group % recvRequests(i) = MPI_REQUEST_NULL end if @@ -642,8 +687,11 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) ! ! Pack send buffer for all neighbors for current field ! + !$acc parallel default(present) attach(group % fields(i) % r1arr) + !$acc loop gang collapse(2) do iEndp = 1, nSendEndpts do iHalo = 1, nHalos + !$acc loop vector do j = 1, maxNSendList if (j <= nSendLists(iHalo,iEndp)) then group % sendBuf(packOffsets(iEndp) + sendListDst(j,iHalo,iEndp)) = & @@ -652,6 +700,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) end do end do end do + !$acc end parallel ! ! Packing code for 2-d real-valued fields @@ -663,9 +712,16 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) ! ! Pack send buffer for all neighbors for current field ! + ! Use data regions for specificity and so the reference or attachment counters are easier to make sense of + ! Present should also cause an attach action. OpenACC Spec2.7 Section 2.7.2 describes 'attach action' + ! !$acc data present(group) present(group % fields(i)) present(group % sendBuf(:), group % fields(i) % sendListSrc(:,:,:)) + + !$acc parallel default(present) attach(group % fields(i) % r2arr) + !$acc loop gang collapse(3) do iEndp = 1, nSendEndpts do iHalo = 1, nHalos do j = 1, maxNSendList + !$acc loop vector do i1 = 1, dim1 if (j <= nSendLists(iHalo,iEndp)) then group % sendBuf(packOffsets(iEndp) + dim1 * (sendListDst(j,iHalo,iEndp) - 1) + i1) = & @@ -675,6 +731,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) end do end do end do + !$acc end parallel ! ! Packing code for 3-d real-valued fields @@ -686,10 +743,13 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) ! ! Pack send buffer for all neighbors for current field ! + !$acc parallel default(present) attach(group % fields(i) % r3arr) + !$acc loop gang collapse(4) do iEndp = 1, nSendEndpts do iHalo = 1, nHalos do j = 1, maxNSendList do i2 = 1, dim2 + !$acc loop vector do i1 = 1, dim1 if (j <= nSendLists(iHalo,iEndp)) then group % sendBuf(packOffsets(iEndp) + dim1*dim2*(sendListDst(j,iHalo,iEndp) - 1) & @@ -701,6 +761,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) end do end do end do + !$acc end parallel end select end if @@ -714,9 +775,11 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) bufstart = group % groupSendOffsets(i) bufend = group % groupSendOffsets(i) + group % groupSendCounts(i) - 1 !TO DO: how do we determine appropriate type here? + !$acc host_data use_device(group % sendBuf) call MPI_Isend(group % sendBuf(bufstart:bufend), group % groupSendCounts(i), MPI_REALKIND, & group % groupSendNeighbors(i), rank, comm, & group % sendRequests(i), mpi_ierr) + !$acc end host_data else group % sendRequests(i) = MPI_REQUEST_NULL end if @@ -771,7 +834,10 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) ! ! Unpack recv buffer from all neighbors for current field ! + !$acc parallel default(present) attach(group % fields(i) % r1arr) + !$acc loop gang do iHalo = 1, nHalos + !$acc loop vector do j = 1, maxNRecvList if (j <= nRecvLists(iHalo,iEndp)) then group % fields(i) % r1arr(recvListDst(j,iHalo,iEndp)) = & @@ -779,6 +845,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) end if end do end do + !$acc end parallel ! ! Unpacking code for 2-d real-valued fields @@ -787,8 +854,12 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) ! ! Unpack recv buffer from all neighbors for current field ! + !$acc parallel default(present) attach(group % fields(i) % r2arr) + !$acc loop gang do iHalo = 1, nHalos + !$acc loop worker do j = 1, maxNRecvList + !$acc loop vector do i1 = 1, dim1 if (j <= nRecvLists(iHalo,iEndp)) then group % fields(i) % r2arr(i1, recvListDst(j,iHalo,iEndp)) = & @@ -797,6 +868,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) end do end do end do + !$acc end parallel ! ! Unpacking code for 3-d real-valued fields @@ -805,8 +877,11 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) ! ! Unpack recv buffer from all neighbors for current field ! + !$acc parallel default(present) attach(group % fields(i) % r3arr) + !$acc loop gang collapse(2) do iHalo = 1, nHalos do j = 1, maxNRecvList + !$acc loop vector collapse(2) do i2 = 1, dim2 do i1 = 1, dim1 if (j <= nRecvLists(iHalo,iEndp)) then @@ -818,6 +893,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) end do end do end do + !$acc end parallel end select end if From b0ce63013ab05bd81c39a6488e0b610720084c64 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Tue, 17 Mar 2026 09:28:06 -0600 Subject: [PATCH 173/214] New namelist option to switch on or off GPU-aware MPI halo exchanges Introducing a new namelist option under development, config_gpu_aware_mpi, which will control whether the MPAS runs on GPUs will use GPU-aware MPI or perform a device<->host update of variables around the call to a purely CPU-based halo exchange. Note: This feature is not available to use when config_halo_exch_method is set to 'mpas_dmpar' --- src/core_atmosphere/Registry.xml | 5 ++ .../dynamics/mpas_atm_time_integration.F | 89 +++++++++++++------ src/core_atmosphere/mpas_atm_core.F | 19 ---- src/framework/mpas_dmpar.F | 9 +- src/framework/mpas_halo.F | 25 ++++-- src/framework/mpas_halo_interface.inc | 3 +- 6 files changed, 95 insertions(+), 55 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index c389db81dd..abf6fc58fe 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -443,6 +443,11 @@ units="-" description="Method to use for exchanging halos" possible_values="`mpas_dmpar', `mpas_halo'"/> + + #ifdef MPAS_USE_MUSICA diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 77109da9bc..68329ef3b3 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1918,6 +1918,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) logical, pointer :: config_scalar_advection logical, pointer :: config_positive_definite logical, pointer :: config_monotonic + logical, pointer :: config_gpu_aware_mpi character (len=StrKIND), pointer :: config_microp_scheme character (len=StrKIND), pointer :: config_convection_scheme @@ -1962,6 +1963,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_pool_get_config(block % configs, 'config_scalar_advection', config_scalar_advection) call mpas_pool_get_config(block % configs, 'config_positive_definite', config_positive_definite) call mpas_pool_get_config(block % configs, 'config_monotonic', config_monotonic) + call mpas_pool_get_config(block % configs, 'config_gpu_aware_mpi', config_gpu_aware_mpi) call mpas_pool_get_config(block % configs, 'config_IAU_option', config_IAU_option) ! config variables for dynamics-transport splitting, WCS 18 November 2014 call mpas_pool_get_config(block % configs, 'config_split_dynamics_transport', config_split_dynamics_transport) @@ -2115,7 +2117,9 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_pool_get_array(state, 'scalars', scalars_1, 1) call mpas_pool_get_array(diag, 'pressure_p', pressure_p) call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) - call exchange_halo_group(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') + !$acc update self(theta_m,scalars_1,pressure_p,rtheta_p) if (.not. config_gpu_aware_mpi) + call exchange_halo_group(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', config_gpu_aware_mpi) + !$acc update device(theta_m,scalars_1,pressure_p,rtheta_p) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_timer_start('atm_rk_integration_setup') @@ -2207,7 +2211,9 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(diag, 'exner', exner) - call exchange_halo_group(domain, 'dynamics:exner') + !$acc update self(exner) if (.not. config_gpu_aware_mpi) + call exchange_halo_group(domain, 'dynamics:exner', config_gpu_aware_mpi) + !$acc update device(exner) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -2289,7 +2295,9 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) ! tend_u MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(tend, 'u', tend_u) - call exchange_halo_group(domain, 'dynamics:tend_u') + !$acc update self(tend_u) if (.not. config_gpu_aware_mpi) + call exchange_halo_group(domain, 'dynamics:tend_u', config_gpu_aware_mpi) + !$acc update device(tend_u) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_timer_start('small_step_prep') @@ -2368,7 +2376,9 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(diag, 'rho_pp', rho_pp) - call exchange_halo_group(domain, 'dynamics:rho_pp') + !$acc update self(rho_pp) if (.not. config_gpu_aware_mpi) + call exchange_halo_group(domain, 'dynamics:rho_pp', config_gpu_aware_mpi) + !$acc update device(rho_pp) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_timer_start('atm_advance_acoustic_step') @@ -2393,7 +2403,9 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) ! This is the only communications needed during the acoustic steps because we solve for u on all edges of owned cells MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) - call exchange_halo_group(domain, 'dynamics:rtheta_pp') + !$acc update self(rtheta_pp) if (.not. config_gpu_aware_mpi) + call exchange_halo_group(domain, 'dynamics:rtheta_pp', config_gpu_aware_mpi) + !$acc update device(rtheta_pp) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') ! complete update of horizontal momentum by including 3d divergence damping at the end of the acoustic step @@ -2419,7 +2431,9 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_pool_get_array(diag, 'rw_p', rw_p) call mpas_pool_get_array(diag, 'rho_pp', rho_pp) call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) - call exchange_halo_group(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') + !$acc update self(rw_p,ru_p,rho_pp,rtheta_pp) if (.not. config_gpu_aware_mpi) + call exchange_halo_group(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', config_gpu_aware_mpi) + !$acc update device(rw_p,ru_p,rho_pp,rtheta_pp) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_timer_start('atm_recover_large_step_variables') @@ -2490,12 +2504,14 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(state, 'u', u, 2) + !$acc update self(u) if (.not. config_gpu_aware_mpi) ! u if (config_apply_lbcs) then - call exchange_halo_group(domain, 'dynamics:u_123') + call exchange_halo_group(domain, 'dynamics:u_123', config_gpu_aware_mpi) else - call exchange_halo_group(domain, 'dynamics:u_3') + call exchange_halo_group(domain, 'dynamics:u_3', config_gpu_aware_mpi) end if + !$acc update device(u) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') ! scalar advection: RK3 scheme of Skamarock and Gassmann (2011). @@ -2504,13 +2520,15 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) if (config_scalar_advection .and. (.not. config_split_dynamics_transport) ) then call advance_scalars('scalars', domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & - config_time_integration_order, config_split_dynamics_transport, exchange_halo_group) + config_time_integration_order, config_split_dynamics_transport, config_gpu_aware_mpi, exchange_halo_group) if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS scalar transport MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - call exchange_halo_group(domain, 'dynamics:scalars') + !$acc update self(scalars_2) if (.not. config_gpu_aware_mpi) + call exchange_halo_group(domain, 'dynamics:scalars', config_gpu_aware_mpi) + !$acc update device(scalars_2) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) @@ -2567,18 +2585,22 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_pool_get_array(state, 'w', w, 2) call mpas_pool_get_array(diag, 'pv_edge', pv_edge) call mpas_pool_get_array(diag, 'rho_edge', rho_edge) + !$acc update self(w,pv_edge,rho_edge) if (.not. config_gpu_aware_mpi) if (config_scalar_advection .and. (.not. config_split_dynamics_transport) ) then ! ! Communicate halos for w[1,2], pv_edge[1,2], rho_edge[1,2], scalars[1,2] ! call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - call exchange_halo_group(domain, 'dynamics:w,pv_edge,rho_edge,scalars') + !$acc update self(scalars_2) if (.not. config_gpu_aware_mpi) + call exchange_halo_group(domain, 'dynamics:w,pv_edge,rho_edge,scalars', config_gpu_aware_mpi) + !$acc update device(scalars_2) if (.not. config_gpu_aware_mpi) else ! ! Communicate halos for w[1,2], pv_edge[1,2], rho_edge[1,2] ! - call exchange_halo_group(domain, 'dynamics:w,pv_edge,rho_edge') + call exchange_halo_group(domain, 'dynamics:w,pv_edge,rho_edge', config_gpu_aware_mpi) end if + !$acc update device(w,pv_edge,rho_edge) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') ! set the zero-gradient condition on w for regional_MPAS @@ -2595,7 +2617,9 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') ! w halo values needs resetting after regional boundary update call mpas_pool_get_array(state, 'w', w, 2) - call exchange_halo_group(domain, 'dynamics:w') + !$acc update self(w) if (.not. config_gpu_aware_mpi) + call exchange_halo_group(domain, 'dynamics:w', config_gpu_aware_mpi) + !$acc update device(w) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') end if ! end of regional_MPAS addition @@ -2611,7 +2635,9 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_pool_get_array(state, 'theta_m', theta_m, 2) call mpas_pool_get_array(diag, 'pressure_p', pressure_p) call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) - call exchange_halo_group(domain, 'dynamics:theta_m,pressure_p,rtheta_p') + !$acc update self(theta_m,pressure_p,rtheta_p) if (.not. config_gpu_aware_mpi) + call exchange_halo_group(domain, 'dynamics:theta_m,pressure_p,rtheta_p', config_gpu_aware_mpi) + !$acc update device(theta_m,pressure_p,rtheta_p) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') ! @@ -2673,14 +2699,16 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call advance_scalars('scalars', domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & - config_time_integration_order, config_split_dynamics_transport, exchange_halo_group) + config_time_integration_order, config_split_dynamics_transport, config_gpu_aware_mpi, exchange_halo_group) if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS scalar transport MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') ! need to fill halo for horizontal filter call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - call exchange_halo_group(domain, 'dynamics:scalars') + !$acc update self(scalars_2) if (.not. config_gpu_aware_mpi) + call exchange_halo_group(domain, 'dynamics:scalars', config_gpu_aware_mpi) + !$acc update device(scalars_2) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) @@ -2709,7 +2737,9 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) if (rk_step < 3) then MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - call exchange_halo_group(domain, 'dynamics:scalars') + !$acc update self(scalars_2) if (.not. config_gpu_aware_mpi) + call exchange_halo_group(domain, 'dynamics:scalars', config_gpu_aware_mpi) + !$acc update device(scalars_2) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') end if @@ -2839,7 +2869,9 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - call exchange_halo_group(domain, 'dynamics:scalars') + !$acc update self(scalars_2) if (.not. config_gpu_aware_mpi) + call exchange_halo_group(domain, 'dynamics:scalars', config_gpu_aware_mpi) + !$acc update device(scalars_2) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_srk3: halo_exchanges + ACC_data_xfer') allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) @@ -2893,7 +2925,7 @@ end subroutine atm_srk3 ! !----------------------------------------------------------------------- subroutine advance_scalars(field_name, domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & - config_time_integration_order, config_split_dynamics_transport, exchange_halo_group) + config_time_integration_order, config_split_dynamics_transport, config_gpu_aware_mpi, exchange_halo_group) implicit none @@ -2906,6 +2938,7 @@ subroutine advance_scalars(field_name, domain, rk_step, rk_timestep, config_mono logical, intent(in) :: config_positive_definite integer, intent(in) :: config_time_integration_order logical, intent(in) :: config_split_dynamics_transport + logical, intent(in) :: config_gpu_aware_mpi procedure (halo_exchange_routine) :: exchange_halo_group ! Local variables @@ -3037,7 +3070,7 @@ subroutine advance_scalars(field_name, domain, rk_step, rk_timestep, config_mono edgeThreadStart(thread), edgeThreadEnd(thread), & cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & scalar_old_arr, scalar_new_arr, s_max_arr, s_min_arr, wdtn_arr, & - flux_array, flux_upwind_tmp_arr, flux_tmp_arr, & + flux_array, flux_upwind_tmp_arr, flux_tmp_arr, config_gpu_aware_mpi, & exchange_halo_group, & advance_density=config_split_dynamics_transport, rho_zz_int=rho_zz_int) end if @@ -4937,7 +4970,7 @@ subroutine atm_advance_scalars_mono(field_name, block, tend, state, diag, mesh, cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, & scalar_old, scalar_new, s_max, s_min, wdtn, flux_arr, & - flux_upwind_tmp, flux_tmp, exchange_halo_group, advance_density, rho_zz_int) + flux_upwind_tmp, flux_tmp, config_gpu_aware_mpi, exchange_halo_group, advance_density, rho_zz_int) implicit none @@ -4958,6 +4991,7 @@ subroutine atm_advance_scalars_mono(field_name, block, tend, state, diag, mesh, real (kind=RKIND), dimension(:,:), intent(inout) :: wdtn real (kind=RKIND), dimension(:,:), intent(inout) :: flux_arr real (kind=RKIND), dimension(:,:), intent(inout) :: flux_upwind_tmp, flux_tmp + logical, intent(in) :: config_gpu_aware_mpi procedure (halo_exchange_routine) :: exchange_halo_group logical, intent(in), optional :: advance_density real (kind=RKIND), dimension(:,:), intent(inout), optional :: rho_zz_int @@ -5036,7 +5070,7 @@ subroutine atm_advance_scalars_mono(field_name, block, tend, state, diag, mesh, edgesOnCell, edgesOnCell_sign, nEdgesOnCell, fnm, fnp, rdnw, nAdvCellsForEdge, & advCellsForEdge, adv_coefs, adv_coefs_3rd, scalar_old, scalar_new, s_max, s_min, & wdtn, scale_arr, flux_arr, flux_upwind_tmp, flux_tmp, & - bdyMaskCell, bdyMaskEdge, & + bdyMaskCell, bdyMaskEdge, config_gpu_aware_mpi, & exchange_halo_group, advance_density, rho_zz_int) call mpas_deallocate_scratch_field(scale) @@ -5084,7 +5118,7 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge edgesOnCell, edgesOnCell_sign, nEdgesOnCell, fnm, fnp, rdnw, nAdvCellsForEdge, & advCellsForEdge, adv_coefs, adv_coefs_3rd, scalar_old, scalar_new, s_max, s_min, & wdtn, scale_arr, flux_arr, flux_upwind_tmp, flux_tmp, & - bdyMaskCell, bdyMaskEdge, & + bdyMaskCell, bdyMaskEdge, config_gpu_aware_mpi, & exchange_halo_group, advance_density, rho_zz_int) use mpas_atm_dimensions, only : nVertLevels @@ -5100,6 +5134,7 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge real (kind=RKIND), intent(in) :: dt integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd integer, intent(in) :: cellSolveStart, cellSolveEnd + logical, intent(in) :: config_gpu_aware_mpi procedure (halo_exchange_routine) :: exchange_halo_group logical, intent(in), optional :: advance_density real (kind=RKIND), dimension(:,:), intent(inout), optional :: rho_zz_int @@ -5196,15 +5231,17 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge !$acc end parallel MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + !$acc update self(scalars_old) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') !$OMP BARRIER !$OMP MASTER - call exchange_halo_group(block % domain, 'dynamics:'//trim(field_name)//'_old') + call exchange_halo_group(block % domain, 'dynamics:'//trim(field_name)//'_old', config_gpu_aware_mpi) !$OMP END MASTER !$OMP BARRIER MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + !$acc update device(scalars_old) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') ! @@ -5601,15 +5638,17 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge ! MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + !$acc update self(scale_arr) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') !$OMP BARRIER !$OMP MASTER - call exchange_halo_group(block % domain, 'dynamics:scale') + call exchange_halo_group(block % domain, 'dynamics:scale', config_gpu_aware_mpi) !$OMP END MASTER !$OMP BARRIER MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + !$acc update device(scale_arr) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') !$acc parallel diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index 5da37f931b..7a79527910 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -60,7 +60,6 @@ function atm_core_init(domain, startTimeStamp) result(ierr) character (len=StrKIND), pointer :: initial_time1, initial_time2 type (MPAS_Time_Type) :: startTime - real (kind=RKIND), dimension(:,:), pointer :: u, ru, rw, pv_edge real (kind=RKIND), pointer :: nominalMinDc real (kind=RKIND), pointer :: config_len_disp real (kind=RKIND), pointer :: Time @@ -239,14 +238,7 @@ function atm_core_init(domain, startTimeStamp) result(ierr) startTime = mpas_get_clock_time(clock, MPAS_START_TIME, ierr) call mpas_get_time(startTime, dateTimeString=startTimeStamp) - ! This copy is temporarily needed to ensure that the field u is available on the device - ! prior to the GPU-direct halo exchange in the call to exchange_halo_group. It will be - ! removed in subsequent commits that introduce a namelist option to select whether halo exchanges - ! are performed on the device or not. - call mpas_pool_get_array(domain % blocklist % allFields, 'u', u, 1) - !$acc enter data copyin(u) call exchange_halo_group(domain, 'initialization:u') - !$acc exit data copyout(u) ! @@ -284,18 +276,7 @@ function atm_core_init(domain, startTimeStamp) result(ierr) block => block % next end do - ! This copy is temporarily needed to ensure that ru, rw, pv_edge are available on the device - ! prior to the GPU-direct halo exchange in the call to exchange_halo_group. It will be - ! removed in subsequent commits that introduce a namelist option to select whether halo exchanges - ! are performed on the device or not. - call mpas_pool_get_array(domain % blocklist % allFields, 'ru', ru, 1) - !$acc enter data copyin(ru) - call mpas_pool_get_array(domain % blocklist % allFields, 'rw', rw, 1) - !$acc enter data copyin(rw) - call mpas_pool_get_array(domain % blocklist % allFields, 'pv_edge', pv_edge) - !$acc enter data copyin(pv_edge) call exchange_halo_group(domain, 'initialization:pv_edge,ru,rw') - !$acc exit data copyout(pv_edge,ru,rw) call mpas_atm_diag_setup(domain % streamManager, domain % blocklist % configs, & domain % blocklist % structs, domain % clock, domain % dminfo) diff --git a/src/framework/mpas_dmpar.F b/src/framework/mpas_dmpar.F index a107412d97..e18cc4a310 100644 --- a/src/framework/mpas_dmpar.F +++ b/src/framework/mpas_dmpar.F @@ -7450,10 +7450,11 @@ end subroutine mpas_dmpar_exch_group_end_halo_exch!}}} !> exchange is complete. ! !----------------------------------------------------------------------- - subroutine mpas_dmpar_exch_group_full_halo_exch(domain, groupName, iErr)!{{{ + subroutine mpas_dmpar_exch_group_full_halo_exch(domain, groupName, withGPUAwareMPI, iErr)!{{{ type (domain_type), intent(inout) :: domain character (len=*), intent(in) :: groupName + logical, optional, intent(in) :: withGPUAwareMPI integer, optional, intent(out) :: iErr type (mpas_exchange_group), pointer :: exchGroupPtr @@ -7463,6 +7464,12 @@ subroutine mpas_dmpar_exch_group_full_halo_exch(domain, groupName, iErr)!{{{ iErr = MPAS_DMPAR_NOERR end if + if (present(withGPUAwareMPI)) then + if (withGPUAwareMPI) then + call mpas_log_write(' GPU-aware MPI not implemented in this module', MPAS_LOG_CRIT) + end if + end if + nLen = len_trim(groupName) DMPAR_DEBUG_WRITE(' -- Trying to perform a full exchange for group ' // trim(groupName)) diff --git a/src/framework/mpas_halo.F b/src/framework/mpas_halo.F index 582afa7c34..c596ab08e0 100644 --- a/src/framework/mpas_halo.F +++ b/src/framework/mpas_halo.F @@ -533,7 +533,7 @@ end subroutine mpas_halo_exch_group_add_field !> exchange group. ! !----------------------------------------------------------------------- - subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) + subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, withGPUAwareMPI, iErr) #ifdef MPAS_USE_MPI_F08 use mpi_f08, only : MPI_Datatype, MPI_Comm @@ -565,6 +565,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) ! Arguments type (domain_type), intent(inout) :: domain character (len=*), intent(in) :: groupName + logical, optional, intent(in) :: withGPUAwareMPI integer, optional, intent(out) :: iErr ! Local variables @@ -580,6 +581,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) integer :: comm #endif integer :: mpi_ierr + logical:: useGPUAwareMPI type (mpas_halo_group), pointer :: group integer, dimension(:), pointer :: compactHaloInfo integer, dimension(:), pointer :: compactSendLists @@ -598,6 +600,11 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) iErr = 0 end if + useGPUAwareMPI = .false. + if (present(withGPUAwareMPI)) then + useGPUAwareMPI = withGPUAwareMPI + end if + ! ! Find this halo exhange group in the list of groups ! @@ -641,7 +648,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) bufstart = group % groupRecvOffsets(i) bufend = group % groupRecvOffsets(i) + group % groupRecvCounts(i) - 1 !TO DO: how do we determine appropriate type here? - !$acc host_data use_device(group % recvBuf) + !$acc host_data use_device(group % recvBuf) if(useGPUAwareMPI) call MPI_Irecv(group % recvBuf(bufstart:bufend), group % groupRecvCounts(i), MPI_REALKIND, & group % groupRecvNeighbors(i), group % groupRecvNeighbors(i), comm, & group % recvRequests(i), mpi_ierr) @@ -687,7 +694,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) ! ! Pack send buffer for all neighbors for current field ! - !$acc parallel default(present) attach(group % fields(i) % r1arr) + !$acc parallel default(present) attach(group % fields(i) % r1arr) if(useGPUAwareMPI) !$acc loop gang collapse(2) do iEndp = 1, nSendEndpts do iHalo = 1, nHalos @@ -716,7 +723,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) ! Present should also cause an attach action. OpenACC Spec2.7 Section 2.7.2 describes 'attach action' ! !$acc data present(group) present(group % fields(i)) present(group % sendBuf(:), group % fields(i) % sendListSrc(:,:,:)) - !$acc parallel default(present) attach(group % fields(i) % r2arr) + !$acc parallel default(present) attach(group % fields(i) % r2arr) if(useGPUAwareMPI) !$acc loop gang collapse(3) do iEndp = 1, nSendEndpts do iHalo = 1, nHalos @@ -743,7 +750,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) ! ! Pack send buffer for all neighbors for current field ! - !$acc parallel default(present) attach(group % fields(i) % r3arr) + !$acc parallel default(present) attach(group % fields(i) % r3arr) if(useGPUAwareMPI) !$acc loop gang collapse(4) do iEndp = 1, nSendEndpts do iHalo = 1, nHalos @@ -775,7 +782,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) bufstart = group % groupSendOffsets(i) bufend = group % groupSendOffsets(i) + group % groupSendCounts(i) - 1 !TO DO: how do we determine appropriate type here? - !$acc host_data use_device(group % sendBuf) + !$acc host_data use_device(group % sendBuf) if(useGPUAwareMPI) call MPI_Isend(group % sendBuf(bufstart:bufend), group % groupSendCounts(i), MPI_REALKIND, & group % groupSendNeighbors(i), rank, comm, & group % sendRequests(i), mpi_ierr) @@ -834,7 +841,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) ! ! Unpack recv buffer from all neighbors for current field ! - !$acc parallel default(present) attach(group % fields(i) % r1arr) + !$acc parallel default(present) attach(group % fields(i) % r1arr) if(useGPUAwareMPI) !$acc loop gang do iHalo = 1, nHalos !$acc loop vector @@ -854,7 +861,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) ! ! Unpack recv buffer from all neighbors for current field ! - !$acc parallel default(present) attach(group % fields(i) % r2arr) + !$acc parallel default(present) attach(group % fields(i) % r2arr) if(useGPUAwareMPI) !$acc loop gang do iHalo = 1, nHalos !$acc loop worker @@ -877,7 +884,7 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) ! ! Unpack recv buffer from all neighbors for current field ! - !$acc parallel default(present) attach(group % fields(i) % r3arr) + !$acc parallel default(present) attach(group % fields(i) % r3arr) if(useGPUAwareMPI) !$acc loop gang collapse(2) do iHalo = 1, nHalos do j = 1, maxNRecvList diff --git a/src/framework/mpas_halo_interface.inc b/src/framework/mpas_halo_interface.inc index 8f0934fbb0..b1dd9a9c99 100644 --- a/src/framework/mpas_halo_interface.inc +++ b/src/framework/mpas_halo_interface.inc @@ -3,12 +3,13 @@ ! in a named group ! abstract interface - subroutine halo_exchange_routine(domain, halo_group, ierr) + subroutine halo_exchange_routine(domain, halo_group, withGPUAwareMPI, ierr) use mpas_derived_types, only : domain_type type (domain_type), intent(inout) :: domain character(len=*), intent(in) :: halo_group + logical, intent(in), optional :: withGPUAwareMPI integer, intent(out), optional :: ierr end subroutine halo_exchange_routine From 968254e9f811f6edb9b5c3b853dccd0bc5823047 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 6 Mar 2026 00:36:35 +0000 Subject: [PATCH 174/214] Remove defc_a and defc_b from the init_atmosphere and atmosphere cores With the introduction of the deformation_coef_* fields in merge commit 63f2d449 (PR #1405), the defc_a and defc_b fields are no longer needed in either the init_atmosphere or the atmosphere core. Accordingly, this commit removes the defc_a and defc_b fields from the Registry.xml files as well as source code in both of these cores. --- src/core_atmosphere/Registry.xml | 10 +------- .../dynamics/mpas_atm_time_integration.F | 25 ++----------------- src/core_init_atmosphere/Registry.xml | 11 -------- src/core_init_atmosphere/mpas_atm_advection.F | 18 +------------ 4 files changed, 4 insertions(+), 60 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index fd1a7baccf..e82ba9179c 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -552,8 +552,6 @@ - - #ifdef MPAS_CAM_DYCORE @@ -1619,13 +1617,6 @@ - - - - - #ifdef MPAS_CAM_DYCORE @@ -1633,6 +1624,7 @@ #endif + diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 19c9ed8978..1b8a764b44 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -291,8 +291,6 @@ subroutine mpas_atm_dynamics_init(domain) real (kind=RKIND), dimension(:), pointer :: latCell real (kind=RKIND), dimension(:), pointer :: lonCell real (kind=RKIND), dimension(:,:,:), pointer :: coeffs_reconstruct - real (kind=RKIND), dimension(:,:), pointer :: defc_a - real (kind=RKIND), dimension(:,:), pointer :: defc_b real (kind=RKIND), dimension(:), pointer :: latEdge real (kind=RKIND), dimension(:), pointer :: angleEdge real (kind=RKIND), dimension(:), pointer :: meshScalingDel2 @@ -485,12 +483,6 @@ subroutine mpas_atm_dynamics_init(domain) call mpas_pool_get_array(mesh, 'coeffs_reconstruct', coeffs_reconstruct) !$acc enter data copyin(coeffs_reconstruct) - call mpas_pool_get_array(mesh, 'defc_a', defc_a) - !$acc enter data copyin(defc_a) - - call mpas_pool_get_array(mesh, 'defc_b', defc_b) - !$acc enter data copyin(defc_b) - call mpas_pool_get_array(mesh, 'latEdge', latEdge) !$acc enter data copyin(latEdge) @@ -1560,8 +1552,6 @@ subroutine mpas_atm_dynamics_finalize(domain) real (kind=RKIND), dimension(:), pointer :: latCell real (kind=RKIND), dimension(:), pointer :: lonCell real (kind=RKIND), dimension(:,:,:), pointer :: coeffs_reconstruct - real (kind=RKIND), dimension(:,:), pointer :: defc_a - real (kind=RKIND), dimension(:,:), pointer :: defc_b real (kind=RKIND), dimension(:), pointer :: latEdge real (kind=RKIND), dimension(:), pointer :: angleEdge real (kind=RKIND), dimension(:), pointer :: meshScalingDel2 @@ -1753,12 +1743,6 @@ subroutine mpas_atm_dynamics_finalize(domain) call mpas_pool_get_array(mesh, 'coeffs_reconstruct', coeffs_reconstruct) !$acc exit data delete(coeffs_reconstruct) - call mpas_pool_get_array(mesh, 'defc_a', defc_a) - !$acc exit data delete(defc_a) - - call mpas_pool_get_array(mesh, 'defc_b', defc_b) - !$acc exit data delete(defc_b) - call mpas_pool_get_array(mesh, 'latEdge', latEdge) !$acc exit data delete(latEdge) @@ -5877,7 +5861,6 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys real (kind=RKIND), pointer :: r_earth real (kind=RKIND), dimension(:,:), pointer :: ur_cell, vr_cell - real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c2, deformation_coef_s2, deformation_coef_cs real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c, deformation_coef_s real (kind=RKIND), dimension(:,:), pointer :: prandtl_3d_inv @@ -6014,8 +5997,6 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys call mpas_pool_get_array(mesh, 'latCell', latCell) call mpas_pool_get_array(mesh, 'latEdge', latEdge) call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) - call mpas_pool_get_array(mesh, 'defc_a', defc_a) - call mpas_pool_get_array(mesh, 'defc_b', defc_b) call mpas_pool_get_array(mesh, 'deformation_coef_c2', deformation_coef_c2) call mpas_pool_get_array(mesh, 'deformation_coef_s2', deformation_coef_s2) call mpas_pool_get_array(mesh, 'deformation_coef_cs', deformation_coef_cs) @@ -6091,7 +6072,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & - rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & + rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, & deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_mix_scalars, config_horiz_mixing, les_model_opt, & les_surface_opt, prandtl_3d_inv, config_del4u_div_factor, & @@ -6126,7 +6107,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & - rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & + rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, & deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_mix_scalars, config_horiz_mixing, les_model_opt, & les_surface_opt, prandtl_3d_inv, config_del4u_div_factor, & @@ -6242,8 +6223,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: ur_cell real (kind=RKIND), dimension(nVertLevels,nCells+1) :: vr_cell - real (kind=RKIND), dimension(maxEdges,nCells+1) :: defc_a - real (kind=RKIND), dimension(maxEdges,nCells+1) :: defc_b real (kind=RKIND), dimension(maxEdges,nCells+1) :: deformation_coef_c2, deformation_coef_s2, deformation_coef_cs real (kind=RKIND), dimension(maxEdges,nCells+1) :: deformation_coef_c, deformation_coef_s diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 0a80532158..fc9be9fb65 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -474,8 +474,6 @@ - - @@ -579,8 +577,6 @@ - - @@ -1111,13 +1107,6 @@ - - - - - diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index f4d44c984e..7d9c7beb24 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -756,7 +756,6 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere ! local variables - real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b real (kind=RKIND), dimension(:,:), pointer :: cell_gradient_coef_x, cell_gradient_coef_y integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, cellsOnCell, verticesOnCell integer, dimension(:), pointer :: nEdgesOnCell @@ -778,11 +777,9 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere integer :: iv logical :: do_the_cell - real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, dx, dy + real (kind=RKIND) :: area_cell, dx, dy - call mpas_pool_get_array(mesh, 'defc_a', defc_a) - call mpas_pool_get_array(mesh, 'defc_b', defc_b) call mpas_pool_get_array(mesh, 'cell_gradient_coef_x', cell_gradient_coef_x) call mpas_pool_get_array(mesh, 'cell_gradient_coef_y', cell_gradient_coef_y) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) @@ -797,9 +794,6 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere call mpas_pool_get_array(mesh, 'yVertex', yVertex) call mpas_pool_get_array(mesh, 'zVertex', zVertex) - defc_a(:,:) = 0. - defc_b(:,:) = 0. - cell_gradient_coef_x(:,:) = 0. cell_gradient_coef_y(:,:) = 0. @@ -920,18 +914,8 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere ip1 = i+1 if (ip1 == n) ip1 = 1 dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2) - sint2 = (sin(thetat(i)))**2 - cost2 = (cos(thetat(i)))**2 - sint_cost = sin(thetat(i))*cos(thetat(i)) - defc_a(i,iCell) = dl*(cost2 - sint2)/area_cell - defc_b(i,iCell) = dl*2.*sint_cost/area_cell cell_gradient_coef_x(i,iCell) = dl*cos(thetat(i))/area_cell cell_gradient_coef_y(i,iCell) = dl*sin(thetat(i))/area_cell - if (cellsOnEdge(1,EdgesOnCell(i,iCell)) /= iCell) then - defc_a(i,iCell) = - defc_a(i,iCell) - defc_b(i,iCell) = - defc_b(i,iCell) - end if - end do end do From 365f28c7ff59f08bb118da38c2580f1eae333092 Mon Sep 17 00:00:00 2001 From: Jim Wittig Date: Fri, 20 Mar 2026 08:16:16 -0600 Subject: [PATCH 175/214] Use the checkout_externals utility to checkout physics submodules with cmake. core_atmosphere requires specific versions of the physics code from https://github.com/NCAR/MMM-physics.git and https://github.com/NOAA-GSL/UGWP.git The checkout_externals utility uses the versions of those repositories specified in src/core_atmosphere/Externals.cfg. The gnu make build system uses checkout_externals; this change modifies the cmake build files to use the same mechanism as the make build system. --- src/core_atmosphere/CMakeLists.txt | 38 +++++++----------------------- 1 file changed, 9 insertions(+), 29 deletions(-) diff --git a/src/core_atmosphere/CMakeLists.txt b/src/core_atmosphere/CMakeLists.txt index 0667b67187..bc324aa2a2 100644 --- a/src/core_atmosphere/CMakeLists.txt +++ b/src/core_atmosphere/CMakeLists.txt @@ -97,20 +97,16 @@ set(ATMOSPHERE_CORE_PHYSICS_WRF_SOURCES list(TRANSFORM ATMOSPHERE_CORE_PHYSICS_WRF_SOURCES PREPEND physics/physics_wrf/) -set(ATMOSPHERE_CORE_PHYSICS_MMM_DIR ${CMAKE_CURRENT_SOURCE_DIR}/physics/physics_mmm) - -if(NOT EXISTS ${ATMOSPHERE_CORE_PHYSICS_MMM_DIR}) - set(PHYSICS_MMM_REPO_URL "https://github.com/NCAR/MMM-physics") - execute_process(COMMAND git clone ${PHYSICS_MMM_REPO_URL} ${ATMOSPHERE_CORE_PHYSICS_MMM_DIR} - RESULT_VARIABLE GIT_CLONE_RESULT - OUTPUT_VARIABLE GIT_CLONE_OUTPUT - ERROR_VARIABLE GIT_CLONE_ERROR) - if(NOT GIT_CLONE_RESULT EQUAL 0) - message(FATAL_ERROR "Git clone failed with error: ${GIT_CLONE_ERROR}") - endif() - +set(CHECKOUT ${CMAKE_CURRENT_SOURCE_DIR}/tools/manage_externals/checkout_externals ) +execute_process( COMMAND + ${CHECKOUT} --externals ${CMAKE_CURRENT_SOURCE_DIR}/Externals.cfg + WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/physics/ + RESULT_VARIABLE MANAGE_EXTERNALS_STATUS + ) +if ( ${MANAGE_EXTERNALS_STATUS} AND NOT ${MANAGE_EXTERNALS_STATUS} EQUAL 0 ) + message( FATAL_ERROR "Failed to checkout external repos via manage_externals" ) else() - message(STATUS "Directory ${DIR_TO_CHECK} already exists, skipping clone") + message( STATUS "Finished checking out external repos via manage_externals" ) endif() set(ATMOSPHERE_CORE_PHYSICS_MMM_SOURCES @@ -130,22 +126,6 @@ set(ATMOSPHERE_CORE_PHYSICS_MMM_SOURCES list(TRANSFORM ATMOSPHERE_CORE_PHYSICS_MMM_SOURCES PREPEND physics/physics_mmm/) -set(ATMOSPHERE_CORE_PHYSICS_NOAA_DIR ${CMAKE_CURRENT_SOURCE_DIR}/physics/physics_noaa/UGWP) - -if(NOT EXISTS ${ATMOSPHERE_CORE_PHYSICS_NOAA_DIR}) - set(PHYSICS_NOAA_REPO_URL "https://github.com/NOAA-GSL/UGWP.git") - execute_process(COMMAND git clone ${PHYSICS_NOAA_REPO_URL} ${ATMOSPHERE_CORE_PHYSICS_NOAA_DIR} - RESULT_VARIABLE GIT_CLONE_RESULT - OUTPUT_VARIABLE GIT_CLONE_OUTPUT - ERROR_VARIABLE GIT_CLONE_ERROR) - if(NOT GIT_CLONE_RESULT EQUAL 0) - message(FATAL_ERROR "Git clone failed with error: ${GIT_CLONE_ERROR}") - endif() - -else() - message(STATUS "Directory ${DIR_TO_CHECK} already exists, skipping clone") -endif() - set(ATMOSPHERE_CORE_PHYSICS_NOAA_SOURCES bl_ugwp.F bl_ugwpv1_ngw.F From c62883633ec7747af30122aeffc0dcb1e698d0db Mon Sep 17 00:00:00 2001 From: jihyeonjang Date: Mon, 12 Jan 2026 13:11:31 -0700 Subject: [PATCH 176/214] Fix evapprod indexing typo in mpas_atmphys_interface.F This fixes a typo in src/core_atmosphere/physics/mpas_atmphys_interface.F where evapprod(k,k) was used instead of evapprod(k,i), introduced in 8e0057689d. The fix corrects diagnostic output, but should not affect the model state or simulation results. The change is based on the commit where the typo was introduced, so it can be applied cleanly to older MPAS versions without unrelated changes. --- src/core_atmosphere/physics/mpas_atmphys_interface.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index 76fcc20e25..f604cb4058 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -573,7 +573,7 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, qg_p(i,k,j) = qg(k,i) rainprod_p(i,k,j) = rainprod(k,i) - evapprod_p(i,k,j) = evapprod(k,k) + evapprod_p(i,k,j) = evapprod(k,i) recloud_p(i,k,j) = re_cloud(k,i) reice_p(i,k,j) = re_ice(k,i) resnow_p(i,k,j) = re_snow(k,i) From e57a71725d1cb59322a1db94449d63cef0fc9c8d Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 24 Mar 2026 16:43:10 -0600 Subject: [PATCH 177/214] Remove PV diagnostics from default "output" stream in MPAS-Atmosphere This commit removes the following PV diagnostic fields from the default "output" stream for MPAS-Atmosphere: ertel_pv u_pv v_pv theta_pv vort_pv iLev_DT depv_dt_lw depv_dt_sw depv_dt_bl depv_dt_cu depv_dt_mix dtheta_dt_mp depv_dt_mp depv_dt_diab depv_dt_fric depv_dt_diab_pv depv_dt_fric_pv These fields may not be of general interest, and so removing them saves space in output files (the "history" netCDF files are ~20% smaller based on testing with a global 60-km mesh). Additionally, removing these fields from default output streams saves a small amount of computation time, as the logic in the mpas_pv_diagnostics module computes these diagnostics only if they are requested in an output stream. --- src/core_atmosphere/Registry.xml | 21 --------------------- 1 file changed, 21 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 2f6820d719..af40165713 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -917,28 +917,7 @@ - - - - - - - - #ifdef DO_PHYSICS - - - - - - - - - - - - - From 0e772211d36438932ce4e75b2e15aae7d36111b6 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Wed, 25 Mar 2026 12:55:41 -0600 Subject: [PATCH 178/214] Consolidating multiple definitions of vertical_interp into init_atm_vinterp This commit consolidates the multiple definitions of function vertical_interp, found in modules mpas_init_atm_cases and init_atm_vinterp in the init_atmosphere core and introduces one uniform definition in the init_atm_vinterp module --- .../mpas_init_atm_cases.F | 96 +------------------ .../mpas_init_atm_vinterp.F | 19 +++- 2 files changed, 16 insertions(+), 99 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index a146cb3d00..5757e16baa 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -16,6 +16,7 @@ module init_atm_cases use atm_advection use mpas_RBF_interpolation use mpas_vector_reconstruction + use init_atm_vinterp, only: vertical_interp use mpas_timer use mpas_init_atm_static use mpas_init_atm_surface @@ -7595,101 +7596,6 @@ integer function nearest_edge(target_lat, target_lon, & end function nearest_edge - real (kind=RKIND) function vertical_interp(target_z, nz, zf, order, extrap, surface_val, sealev_val, ierr) - - implicit none - - real (kind=RKIND), intent(in) :: target_z - integer, intent(in) :: nz - real (kind=RKIND), dimension(2,nz), intent(in) :: zf ! zf(1,:) is column of vertical coordinate values, zf(2,:) is column of field values - integer, intent(in), optional :: order - integer, intent(in), optional :: extrap ! can take values 0 = constant, 1 = linear (default), 2 = lapse-rate - real (kind=RKIND), intent(in), optional :: surface_val - real (kind=RKIND), intent(in), optional :: sealev_val - integer, intent(out), optional :: ierr - - integer :: k, lm, lp - real (kind=RKIND) :: wm, wp - real (kind=RKIND) :: slope - - integer :: interp_order, extrap_type - real (kind=RKIND) :: surface, sealevel - - if (present(ierr)) ierr = 0 - - if (present(order)) then - interp_order = order - else - interp_order = 2 - end if - - if (present(extrap)) then - extrap_type = extrap - else - extrap_type = 1 - end if - - if (present(surface_val)) then - surface = surface_val - else - surface = 200100.0 - end if - - if (present(sealev_val)) then - sealevel = sealev_val - else - sealevel = 201300.0 - end if - - ! - ! Extrapolation required - ! - if (target_z < zf(1,1)) then - if (extrap_type == 0) then - vertical_interp = zf(2,1) - else if (extrap_type == 1) then - slope = (zf(2,2) - zf(2,1)) / (zf(1,2) - zf(1,1)) - vertical_interp = zf(2,1) + slope * (target_z - zf(1,1)) - else if (extrap_type == 2) then - vertical_interp = zf(2,1) - (target_z - zf(1,1))*0.0065 - end if - return - end if - if (target_z >= zf(1,nz)) then - if (extrap_type == 0) then - vertical_interp = zf(2,nz) - else if (extrap_type == 1) then - slope = (zf(2,nz) - zf(2,nz-1)) / (zf(1,nz) - zf(1,nz-1)) - vertical_interp = zf(2,nz) + slope * (target_z - zf(1,nz)) - else if (extrap_type == 2) then - call mpas_log_write('extrap_type == 2 not implemented for target_z >= zf(1,nz)', messageType=MPAS_LOG_ERR) - if (present(ierr)) ierr = 1 - return - end if - return - end if - - - ! - ! No extrapolation required - ! - do k=1,nz-1 - if (target_z >= zf(1,k) .and. target_z < zf(1,k+1)) then - lm = k - lp = k+1 - wm = (zf(1,k+1) - target_z) / (zf(1,k+1) - zf(1,k)) - wp = (target_z - zf(1,k)) / (zf(1,k+1) - zf(1,k)) - exit - end if - end do - - vertical_interp = wm*zf(2,lm) + wp*zf(2,lp) - - return - - end function vertical_interp - - !---------------------------------------------------------------------------------------------------------- real (kind=RKIND) function env_qv( temperature, pressure, rh_max ) diff --git a/src/core_init_atmosphere/mpas_init_atm_vinterp.F b/src/core_init_atmosphere/mpas_init_atm_vinterp.F index c5163d2708..164cfac546 100644 --- a/src/core_init_atmosphere/mpas_init_atm_vinterp.F +++ b/src/core_init_atmosphere/mpas_init_atm_vinterp.F @@ -22,7 +22,10 @@ module init_atm_vinterp ! ! Purpose: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - real (kind=RKIND) function vertical_interp(target_z, nz, zf, order, extrap, surface_val, sealev_val) + real (kind=RKIND) function vertical_interp(target_z, nz, zf, order, extrap, surface_val, sealev_val, ierr) + + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_ERR implicit none @@ -30,10 +33,11 @@ real (kind=RKIND) function vertical_interp(target_z, nz, zf, order, extrap, surf integer, intent(in) :: nz real (kind=RKIND), dimension(2,nz), intent(in) :: zf ! zf(1,:) is column of vertical coordinate values, zf(2,:) is column of field values integer, intent(in), optional :: order - integer, intent(in), optional :: extrap + integer, intent(in), optional :: extrap ! can take values 0 = constant, 1 = linear (default), 2 = lapse-rate real (kind=RKIND), intent(in), optional :: surface_val real (kind=RKIND), intent(in), optional :: sealev_val - + integer, intent(out), optional :: ierr + integer :: k, lm, lp real (kind=RKIND) :: wm, wp real (kind=RKIND) :: slope @@ -41,7 +45,8 @@ real (kind=RKIND) function vertical_interp(target_z, nz, zf, order, extrap, surf integer :: interp_order, extrap_type real (kind=RKIND) :: surface, sealevel - + if (present(ierr)) ierr = 0 + if (present(order)) then interp_order = order else @@ -75,6 +80,8 @@ real (kind=RKIND) function vertical_interp(target_z, nz, zf, order, extrap, surf else if (extrap_type == 1) then slope = (zf(2,2) - zf(2,1)) / (zf(1,2) - zf(1,1)) vertical_interp = zf(2,1) + slope * (target_z - zf(1,1)) + else if (extrap_type == 2) then + vertical_interp = zf(2,1) - (target_z - zf(1,1))*0.0065 end if return end if @@ -84,6 +91,10 @@ real (kind=RKIND) function vertical_interp(target_z, nz, zf, order, extrap, surf else if (extrap_type == 1) then slope = (zf(2,nz) - zf(2,nz-1)) / (zf(1,nz) - zf(1,nz-1)) vertical_interp = zf(2,nz) + slope * (target_z - zf(1,nz)) + else if (extrap_type == 2) then + call mpas_log_write('extrap_type == 2 not implemented for target_z >= zf(1,nz)', messageType=MPAS_LOG_ERR) + if (present(ierr)) ierr = 1 + return end if return end if From 01242ccc55c0cf64d448f1c056e66acb9215f311 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Wed, 25 Mar 2026 13:06:26 -0600 Subject: [PATCH 179/214] Add units for config_mpas_cam_coef in atmosphere Registry.xml --- src/core_atmosphere/Registry.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index f7dd0ae04b..a430723bef 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -299,7 +299,7 @@ possible_values="0 $\leq$ config_xnutr $\leq$ 1"/> From 099fee95ab0f9dba1c6c1320a00e7dbf709e5c26 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Fri, 27 Mar 2026 14:36:43 -0600 Subject: [PATCH 180/214] Correcting the ESMF link path in src/core_atmosphere/utils/Makefile This commit corrects the link path for the ESMF module by replacing the incorrect make variable MPAS_ESMF_LIBS with MPAS_ESMF_LIB, which is the variable defined in the root Makefile. This issue came to attention due to a linking error that arises when building the MPAS atmosphere core with the nvhpc compiler in DEBUG mode. --- src/core_atmosphere/utils/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/utils/Makefile b/src/core_atmosphere/utils/Makefile index 8166210d89..da9f3b947d 100644 --- a/src/core_atmosphere/utils/Makefile +++ b/src/core_atmosphere/utils/Makefile @@ -7,7 +7,7 @@ endif all: $(UTILS) build_tables: build_tables.o atmphys_build_tables_thompson.o - $(LINKER) $(LDFLAGS) -o build_tables build_tables.o atmphys_build_tables_thompson.o -L../../framework -L../physics -lphys -lframework $(LIBS) $(MPAS_ESMF_LIBS) + $(LINKER) $(LDFLAGS) -o build_tables build_tables.o atmphys_build_tables_thompson.o -L../../framework -L../physics -lphys -lframework $(LIBS) $(MPAS_ESMF_LIB) mv build_tables ../../.. From bca11716247d9e3a62ae9d3adc4e69765ce5aa99 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Mon, 30 Mar 2026 16:14:32 -0600 Subject: [PATCH 181/214] Define new package, 'les', and attach it to the 'tke' constituent of var_arrays This commit defines a new package, 'les', for the atmosphere core, and it attaches this package to the 'tke' constituent in the 'scalars', 'scalars_tend', and 'lbc_scalars' var_arrays in the atmosphere core's Registry.xml file. The 'tke' constituent is only required when an LES model has been selected at runtime (i.e., config_les_model = '3d_smagorinsky' or config_les_model = 'prognostic_1.5_order'), and the 'les' package is therefore active if and only if config_les_model is not 'none'. --- src/core_atmosphere/Registry.xml | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index fb8cfe959a..fbda257803 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -468,6 +468,9 @@ + @@ -1757,7 +1760,8 @@ packages="mp_thompson_aers_in"/> + description="Turbulent kinetic energy for the prognostic tke LES scheme" + packages="les"/> #endif @@ -2123,7 +2127,8 @@ packages="mp_thompson_aers_in"/> + description="Tendency of tke multiplied by dry air density divided by d(zeta)/dz" + packages="les"/> #endif @@ -2205,7 +2210,8 @@ + description="Lateral boundary tendency of TKE" + packages="les"/> From 77c59fad7927bf6fed28a9e4134d151d74f50a3c Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 31 Mar 2026 15:00:23 -0600 Subject: [PATCH 182/214] Fix build failure for mpas_atm_dissipation_models when DO_PHYSICS is not defined When DO_PHYSICS is not defined, the mpas_atmphys_constants.F code in src/core_atmosphere/physics is not compiled, leading to build failures for mpas_atm_dissipation_models.F in the src/core_atmosphere/dynamics directory, since the calculate_n2 routine within the mpas_atm_dissipation_models module relies on the definitions of parameters from the mpas_atmphys_constants module. The fix provided by this commit involves adding local definitions of the required physical constants in the calculate_n2 routine only when the DO_PHYSICS macro is not defined. When DO_PHYSICS is defined, the definitions of these physical constants are imported from the mpas_atmphys_constants module as before. --- .../dynamics/mpas_atm_dissipation_models.F | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 450ed045c1..8c386b1d8e 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -11,7 +11,6 @@ module mpas_atm_dissipation_models use mpas_kind_types, only : RKIND - use mpas_atmphys_constants use mpas_constants use mpas_log use mpas_timekeeping, only : mpas_get_clock_time, mpas_get_time @@ -465,6 +464,24 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in use mpas_atm_dimensions ! pull nVertLevels and num_scalars from here +#ifdef DO_PHYSICS + use mpas_atmphys_constants, only : svp1, svp2, svp3, svpt0, xlv, R_d, R_v, ep_2 +#else + ! + ! If stand-alone MPAS-Atmosphere physics are not being used, provide + ! definitions for constants needed in the caculation of the moist + ! Brunt-Vaisala frequency following those in mpas_atmphys_constants. + ! + real(kind=RKIND), parameter :: svp1 = 0.6112 + real(kind=RKIND), parameter :: svp2 = 17.67 + real(kind=RKIND), parameter :: svp3 = 29.65 + real(kind=RKIND), parameter :: svpt0 = 273.15 + real(kind=RKIND), parameter :: xlv = 2.50e6 !latent heat of vaporization [J/kg] + real (kind=RKIND), parameter :: R_d = 287.0_RKIND !< Constant: Gas constant for dry air [J kg-1 K-1] + real(kind=RKIND), parameter :: R_v = 461.6 !gas constant for water vapor [J/kg/K] + real(kind=RKIND), parameter :: ep_2 = R_d/R_v +#endif + integer, intent(in) :: cellStart, cellEnd, nCells integer, intent(in) :: index_qv, index_qc real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: bn2 From 02fcc5c7509e93627bc31219b6a211bf605f7fec Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 31 Mar 2026 17:59:13 -0600 Subject: [PATCH 183/214] Fix crash in atm_compute_dyn_tend when DO_PHYSICS is not defined in build When DO_PHYSICS is not defined in a build of the atmosphere core, the diag_physics pool/var_struct is not defined in the Registry.xml file, leading to a crash in the atm_compute_dyn_tend routine when attempting to query ustm, hfx, or qfx from the diag_physics pool. The simple fix in this commit is to guard the calls to mpas_pool_get_array for ustm, hfx, and qfx in the atm_compute_dyn_tend with preprocessor directives, so that the access of these arrays from the diag_physics pool occurs only when DO_PHYSICS is defined. Note that the atm_compute_dyn_tend routine already contains logic to accommodate situations in which ustm, hfx, and qfx are not available (because they are allocated only when the either of the bl_mynn_in or bl_ysu_in packages are active), and so it's only the calls to set pointers to these arrays from the diag_physics pool that need to be guarded. --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 5591ffe6d4..5bebbe9f41 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5025,11 +5025,14 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) nullify(ustm) - call mpas_pool_get_array(diag_physics,'ustm',ustm) nullify(hfx) - call mpas_pool_get_array(diag_physics,'hfx',hfx) nullify(qfx) + +#ifdef DO_PHYSICS + call mpas_pool_get_array(diag_physics,'ustm',ustm) + call mpas_pool_get_array(diag_physics,'hfx',hfx) call mpas_pool_get_array(diag_physics,'qfx',qfx) +#endif nopbl = .false. if (.not. associated(ustm) & From 0e5a47a0e1bcccd6e3d99909b76e740a643c4db6 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 1 Apr 2026 15:06:53 -0600 Subject: [PATCH 184/214] Update version number to 8.4.0 --- README.md | 2 +- src/core_atmosphere/Registry.xml | 2 +- src/core_init_atmosphere/Registry.xml | 2 +- src/core_landice/Registry.xml | 2 +- src/core_ocean/Registry.xml | 2 +- src/core_seaice/Registry.xml | 2 +- src/core_sw/Registry.xml | 2 +- src/core_test/Registry.xml | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) diff --git a/README.md b/README.md index a4f23e5523..8db0d85898 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -MPAS-v8.3.1 +MPAS-v8.4.0 ==== The Model for Prediction Across Scales (MPAS) is a collaborative project for diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 195a1e1e4d..f1a55bc3a3 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index fc9be9fb65..9b3910e205 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 1153d48c25..73e23a13db 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 29cf098fef..5089d8cb30 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -1,5 +1,5 @@ - + - + - + diff --git a/src/core_test/Registry.xml b/src/core_test/Registry.xml index 4c3f48bc7a..5e77060980 100644 --- a/src/core_test/Registry.xml +++ b/src/core_test/Registry.xml @@ -1,5 +1,5 @@ - + From 32d2b1b85e900e45aa6ed7775a5f8278df80a04c Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Wed, 1 Apr 2026 15:45:24 -0600 Subject: [PATCH 185/214] Fix calls to mpas_halo_exch_group_full_halo_exch in mpas_halo_testing This commit introduces explicit argument names for the optional argument iErr in calls to mpas_halo_exch_group_full_halo_exch in mpas_halo_testing. The merge of PR 1355 to develop, which introduced an extra optional argument (withGPUAwareMPI) to the signature of mpas_halo_exch_group_full_halo_exch, broke the build of the test core. This commit fixes the build of the test core. --- src/core_test/mpas_halo_testing.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_test/mpas_halo_testing.F b/src/core_test/mpas_halo_testing.F index 8ad1551989..ef1843a773 100644 --- a/src/core_test/mpas_halo_testing.F +++ b/src/core_test/mpas_halo_testing.F @@ -168,7 +168,7 @@ subroutine mpas_halo_tests(domain, ierr) end do end do - call mpas_halo_exch_group_full_halo_exch(domain, 'persistent_group', ierr_local) + call mpas_halo_exch_group_full_halo_exch(domain, 'persistent_group', iErr=ierr_local) ierr = ior(ierr, ierr_local) diff = 0.0_RKIND @@ -228,7 +228,7 @@ subroutine mpas_halo_tests(domain, ierr) end do end do - call mpas_halo_exch_group_full_halo_exch(domain, 'scratch_group', ierr_local) + call mpas_halo_exch_group_full_halo_exch(domain, 'scratch_group', iErr=ierr_local) ierr = ior(ierr, ierr_local) diff = 0.0_RKIND From 8f667d53f8c94e7dfa84a7da6f2f9f2c16dcc9dd Mon Sep 17 00:00:00 2001 From: Ming Chen Date: Mon, 5 Jan 2026 14:45:48 -0700 Subject: [PATCH 186/214] Fix segfault when CAM radiation is activated in MPAS-Atmosphere This commit fixes bugs that cause MPAS-Atmosphere to crash when the CAM radiation scheme is activated. Several arrays are allocated only when the RRTMG radiation scheme is activated. However, these arrays were being used when the CAM radiation scheme is turned on, leading to a segmentation fault. This commit fixes this issue by conditionally using these arrays only when the RRTMG scheme has been selected at runtime. --- .../mpas_atmphys_driver_radiation_sw.F | 56 ++++++++++++------- 1 file changed, 37 insertions(+), 19 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F index 96a4996378..3a14275826 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F @@ -459,9 +459,6 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i swupbc_p(i,j) = 0.0_RKIND swupt_p(i,j) = 0.0_RKIND swuptc_p(i,j) = 0.0_RKIND - swddir_p(i,j) = 0.0_RKIND - swddni_p(i,j) = 0.0_RKIND - swddif_p(i,j) = 0.0_RKIND enddo do k = kts,kte @@ -472,21 +469,30 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i enddo aer_opt = 0 - do n = 1,nbndsw - do j = jts,jte - do k = kts,kte - do i = its,ite - tauaer_p(i,k,j,n) = 0._RKIND - ssaaer_p(i,k,j,n) = 1._RKIND - asyaer_p(i,k,j,n) = 0._RKIND - enddo - enddo - enddo - enddo radiation_sw_select: select case (trim(radt_sw_scheme)) case("rrtmg_sw") + do j = jts,jte + do i = its,ite + swddir_p(i,j) = 0.0_RKIND + swddni_p(i,j) = 0.0_RKIND + swddif_p(i,j) = 0.0_RKIND + enddo + enddo + + do n = 1,nbndsw + do j = jts,jte + do k = kts,kte + do i = its,ite + tauaer_p(i,k,j,n) = 0._RKIND + ssaaer_p(i,k,j,n) = 1._RKIND + asyaer_p(i,k,j,n) = 0._RKIND + enddo + enddo + enddo + enddo + microp_select: select case(microp_scheme) case("mp_thompson","mp_thompson_aerosols","mp_wsm6") if(config_microp_re) then @@ -705,12 +711,15 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i end subroutine radiation_sw_from_MPAS !================================================================================================================= - subroutine radiation_sw_to_MPAS(diag_physics,tend_physics,its,ite) + subroutine radiation_sw_to_MPAS(configs,diag_physics,tend_physics,its,ite) !================================================================================================================= !input arguments: type(mpas_pool_type),intent(inout):: diag_physics type(mpas_pool_type),intent(inout):: tend_physics + type(mpas_pool_type),intent(in):: configs +!local pointers: + character(len=StrKIND),pointer:: radt_sw_scheme integer,intent(in):: its,ite @@ -743,6 +752,8 @@ subroutine radiation_sw_to_MPAS(diag_physics,tend_physics,its,ite) call mpas_pool_get_array(diag_physics,'swddif' ,swddif ) call mpas_pool_get_array(tend_physics,'rthratensw',rthratensw) + call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme) + do j = jts,jte do i = its,ite @@ -757,11 +768,18 @@ subroutine radiation_sw_to_MPAS(diag_physics,tend_physics,its,ite) swupbc(i) = swupbc_p(i,j) swupt(i) = swupt_p(i,j) swuptc(i) = swuptc_p(i,j) - swddir(i) = swddir_p(i,j) - swddni(i) = swddni_p(i,j) - swddif(i) = swddif_p(i,j) enddo + radiation_sw_select: select case (trim(radt_sw_scheme)) + case("rrtmg_sw") + do i = its,ite + swddir(i) = swddir_p(i,j) + swddni(i) = swddni_p(i,j) + swddif(i) = swddif_p(i,j) + enddo + case default + end select radiation_sw_select + do k = kts,kte do i = its,ite rthratensw(k,i) = rthratensw_p(i,k,j) @@ -981,7 +999,7 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic end select radiation_sw_select !copy local arrays to MPAS grid: - call radiation_sw_to_MPAS(diag_physics,tend_physics,its,ite) + call radiation_sw_to_MPAS(configs,diag_physics,tend_physics,its,ite) !call mpas_log_write('--- end subroutine driver_radiation_sw.') From 00f5ad2b0589e32df68d05f163b096031e8e60f4 Mon Sep 17 00:00:00 2001 From: Ming Chen Date: Wed, 1 Apr 2026 15:16:33 -0600 Subject: [PATCH 187/214] Fix snow initialization over seaice points in MPAS-A This commit fixes an issue in snow initialization over the Arctic Ocean and other areas covered by seaice. Snow water equivalent (as well as snow depth and snow cover) in the initial conditions of MPAS was set to zero over sea ice areas. This leads to a significant warm bias of skintemp during model integration. When MPAS is initialized in winter, the simulated conditions over polar regions become physically unrealistic. This commit corrects snow initialization, making it physically reasonable over Arctic Ocean and other areas covered by seaice in winter. --- .../physics/mpas_atmphys_initialize_real.F | 9 +++++++++ src/core_init_atmosphere/mpas_init_atm_cases.F | 3 --- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F index d6dc1bc0c1..f67ed9a87a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F +++ b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F @@ -606,6 +606,7 @@ subroutine physics_init_seaice(mesh, input, dims, configs) real(kind=RKIND),pointer:: tsk_seaice_threshold real(kind=RKIND),dimension(:),pointer :: vegfra real(kind=RKIND),dimension(:),pointer :: seaice,snoalb,xice + real(kind=RKIND),dimension(:),pointer :: snow, snowh, snowc real(kind=RKIND),dimension(:),pointer :: skintemp,tmn,xland real(kind=RKIND),dimension(:,:),pointer:: tslb,smois,sh2o,smcrel @@ -637,6 +638,9 @@ subroutine physics_init_seaice(mesh, input, dims, configs) call mpas_pool_get_array(input, 'seaice', seaice) call mpas_pool_get_array(input, 'xice', xice) + call mpas_pool_get_array(input, 'snowc', snowc) + call mpas_pool_get_array(input, 'snowh', snowh) + call mpas_pool_get_array(input, 'snow', snow) call mpas_pool_get_array(input, 'vegfra', vegfra) call mpas_pool_get_array(input, 'skintemp', skintemp) @@ -699,6 +703,11 @@ subroutine physics_init_seaice(mesh, input, dims, configs) call mpas_log_write('$i $r $r $r', intArgs=(/iCell/), & realArgs=(/real(landmask(iCell),kind=RKIND),xland(iCell),xice(iCell)/)) xice(iCell) = 0._RKIND + if(landmask(iCell) .eq. 0) then + snowc(iCell) = 0._RKIND ! snow = 0 over water points + snowh(iCell) = 0._RKIND + snow(iCell) = 0._RKIND + endif endif enddo diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 7d43b5ee83..e2774c69a5 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -4122,9 +4122,6 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state interp_list(2) = W_AVERAGE4 interp_list(3) = 0 - masked = 0 - fillval = 0.0 - nInterpPoints = nCells latPoints => latCell lonPoints => lonCell From deaad7f897708b06bb0f6408849d00948b5e5349 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 7 Apr 2026 18:39:18 -0600 Subject: [PATCH 188/214] Update config_init_case Registry.xml description to include LES case This commit updates the Registry.xml entry for the config_init_case namelist option in the init_atmosphere core so that its description and possible_values attributes reflect the addition of the new LES initialization case (case 10). --- src/core_init_atmosphere/Registry.xml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 938b8dde37..acfa64d052 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -65,8 +65,9 @@ 7 = real-data initial conditions from, e.g., GFS, \newline 8 = surface field (SST, sea-ice) update file for use with real-data simulations \newline 9 = lateral boundary conditions update file for use with real-data simulations \newline + 10 = idealized LES case \newline 13 = CAM-MPAS 3-d grid with specified topography and zeta levels" - possible_values="1 -- 9, or 13"/> + possible_values="1 -- 10, or 13"/> Date: Mon, 6 Apr 2026 13:58:52 -0700 Subject: [PATCH 189/214] Fix premature use of optional argument in mpas_get_stream_filename If no optional `ierr` argument is provided in calling the subroutine `mpas_get_stream_filename()` the model segfaults by trying to assign to the nonexistent argument. Additionally, `ierr` is set to zero to initialize, but as this module uses its own error codes it should instead use `MPAS_STREAM_MGR_NOERR`. This change checks if `ierr` is present, and if so initializes it to `MPAS_STREAM_MGR_NOERR`. --- src/framework/mpas_stream_manager.F | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/framework/mpas_stream_manager.F b/src/framework/mpas_stream_manager.F index 7a3c7b079a..8a4a1b4ad3 100644 --- a/src/framework/mpas_stream_manager.F +++ b/src/framework/mpas_stream_manager.F @@ -4073,7 +4073,9 @@ subroutine mpas_get_stream_filename(manager, streamID, when, blockID, filename, type (MPAS_TimeInterval_type) :: filename_interval type (MPAS_Time_type) :: now_time - ierr = 0 + if ( present(ierr) ) then + ierr = MPAS_STREAM_MGR_NOERR + end if if ( present(blockID) ) then blockID_local = blockID From aa7e7f4e17ed32cca47c740fb5354acaa430add3 Mon Sep 17 00:00:00 2001 From: Clark Evans Date: Fri, 24 Apr 2026 23:30:31 -0600 Subject: [PATCH 190/214] Remove redundant variable definitions in mpas_atmphys_initialize_real.F --- src/core_atmosphere/physics/mpas_atmphys_initialize_real.F | 1 - 1 file changed, 1 deletion(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F index 9922d623f0..31d3a7fa2d 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F +++ b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F @@ -944,7 +944,6 @@ subroutine physics_init_seaice(mesh, input, dims, configs) real(kind=RKIND),dimension(:),pointer :: seaice,snoalb,xice real(kind=RKIND),dimension(:),pointer :: snow, snowh, snowc real(kind=RKIND),dimension(:),pointer :: skintemp,tmn,xland - real(kind=RKIND),dimension(:),pointer :: snow, snowh real(kind=RKIND),dimension(:,:),pointer:: tslb,smois,sh2o,smcrel logical, pointer :: config_frac_seaice From 6a9dd74bce483991fd6343370d38629c0dc5fe6f Mon Sep 17 00:00:00 2001 From: Clark Evans Date: Sat, 25 Apr 2026 15:59:57 -0600 Subject: [PATCH 191/214] Update mpas_atm_time_integration.F The horizontal mixing added by NSSL relied on kdiff in the atm_compute_dyn_tend_work subroutine. However, the v8.4 release removed kdiff in favor of eddy_visc_horz. This commit changes kdiff to eddy_visc_horz only in this subroutine. --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index c88b93bc5f..c7d942d2a1 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -6802,7 +6802,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion - kdiffu = 0.5*(kdiff(k,cell1)+kdiff(k,cell2)) + kdiffu = 0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) ! include 2nd-orer diffusion here tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & @@ -7142,7 +7142,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & - (kdiff(k,cell1)+kdiff(k,cell2)+kdiff(k-1,cell1)+kdiff(k-1,cell2)) + (eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)+eddy_visc_horz(k-1,cell1)+eddy_visc_horz(k-1,cell2)) tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux end do end do @@ -7348,7 +7348,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux - theta_turb_flux = theta_turb_flux*0.5*(kdiff(k,cell1)+kdiff(k,cell2)) * pr_scale + theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux end do From 88ea5ba150c511c57055dc21e7cca294b44c770c Mon Sep 17 00:00:00 2001 From: Clark Evans Date: Sat, 25 Apr 2026 16:30:06 -0600 Subject: [PATCH 192/214] Update mpas_atmphys_driver.F Replace halo_exchange_routine subroutine with a call to the new common definition in mpas_halo_interface.inc (introduced in the upstream v8.4.0 in other locations). --- .../physics/mpas_atmphys_driver.F | 17 ++--------------- 1 file changed, 2 insertions(+), 15 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index 2954bb6d68..4c82721afc 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -33,21 +33,8 @@ module mpas_atmphys_driver private public:: physics_driver - ! - ! Abstract interface for routine used to communicate halos of fields - ! in a named group - ! - abstract interface - subroutine halo_exchange_routine(domain, halo_group, ierr) - - use mpas_derived_types, only : domain_type - - type (domain_type), intent(inout) :: domain - character(len=*), intent(in) :: halo_group - integer, intent(out), optional :: ierr - - end subroutine halo_exchange_routine - end interface + ! Provides definition of halo_exchange_routine +#include "mpas_halo_interface.inc" !MPAS top physics driver. !Laura D. Fowler (send comments to laura@ucar.edu). From 26fed47cee4aaf6a077ea61e38ce656d49938697 Mon Sep 17 00:00:00 2001 From: Clark Evans Date: Sat, 25 Apr 2026 16:43:03 -0600 Subject: [PATCH 193/214] Update mpas_atmphys_driver_convection.F Replace halo exchange code with the unified implementation from the upstream v8.4 release. --- .../physics/mpas_atmphys_driver_convection.F | 15 ++------------- 1 file changed, 2 insertions(+), 13 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F index e54a6673d0..38c8bda76c 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F @@ -32,20 +32,9 @@ module mpas_atmphys_driver_convection driver_convection, & update_convection_step1, & update_convection_step2 - ! Abstract interface for routine used to communicate halos of fields - ! in a named group - ! - abstract interface - subroutine halo_exchange_routine(domain, halo_group, ierr) - use mpas_derived_types, only : domain_type - - type (domain_type), intent(inout) :: domain - character(len=*), intent(in) :: halo_group - integer, intent(out), optional :: ierr - - end subroutine halo_exchange_routine - end interface + ! Provides definition of halo_exchange_routine +#include "mpas_halo_interface.inc" !MPAS driver for parameterization of convection. From 0e33c5040fe90d9efb695544b990e9173aebc306 Mon Sep 17 00:00:00 2001 From: Clark Evans Date: Wed, 29 Apr 2026 21:18:02 -0600 Subject: [PATCH 194/214] Update CI tests for noaa/develop and v8.4 --- .github/workflows/bld_mpas_images.yaml | 4 ++-- .github/workflows/run_mpas.yml | 18 +++++++++--------- .github/workflows/run_mpas_hrrr.yml | 10 +++++----- 3 files changed, 16 insertions(+), 16 deletions(-) diff --git a/.github/workflows/bld_mpas_images.yaml b/.github/workflows/bld_mpas_images.yaml index 75c33ac538..48a795b695 100644 --- a/.github/workflows/bld_mpas_images.yaml +++ b/.github/workflows/bld_mpas_images.yaml @@ -4,8 +4,8 @@ run-name: CI Image Build for MPAS-A on: push: branches: - # Only build containers when pushing to gsl/develop - - "gsl/develop" + # Only build containers when pushing to noaa/develop + - "noaa/develop" jobs: docker: diff --git a/.github/workflows/run_mpas.yml b/.github/workflows/run_mpas.yml index f4e911f4d8..72a879dd12 100644 --- a/.github/workflows/run_mpas.yml +++ b/.github/workflows/run_mpas.yml @@ -26,12 +26,12 @@ on: [push, pull_request, workflow_dispatch] # # Tests: # Baseline Codebase Repository:Branch Physics build type -# 1/7) MPAS-Dev:v8.3.0 mesoscale_reference Release/Debug -# 2/8) MPAS-Dev:v8.3.0 convection_permitting Release/Debug -# 3/9) MPAS-Dev:v8.3.0 mesoscale_reference_noahmp Release/Debug -# 4/10) ufs-community:gsl/develop mesoscale_reference Release/Debug -# 5/11) ufs-community:gsl/develop convection_permitting Release/Debug -# 6/12) ufs-community:gsl/develop mesoscale_reference_noahmp Release/Debug +# 1/7) MPAS-Dev:v8.4.0 mesoscale_reference Release/Debug +# 2/8) MPAS-Dev:v8.4.0 convection_permitting Release/Debug +# 3/9) MPAS-Dev:v8.4.0 mesoscale_reference_noahmp Release/Debug +# 4/10) ufs-community:noaa/develop mesoscale_reference Release/Debug +# 5/11) ufs-community:noaa/develop convection_permitting Release/Debug +# 6/12) ufs-community:noaa/develop mesoscale_reference_noahmp Release/Debug # ############################################################################################# jobs: @@ -43,13 +43,13 @@ jobs: f-compiler: [gfortran]#,ifx] physics: [mesoscale_reference, convection_permitting, mesoscale_reference_noahmp] repo: [ufs-community, MPAS-Dev] - branch: [gsl/develop, v8.3.0] + branch: [noaa/develop, v8.4.0] build-type: [Debug, Release] exclude: - repo: MPAS-Dev - branch: gsl/develop + branch: noaa/develop - repo: ufs-community - branch: v8.3.0 + branch: v8.4.0 include: # Set container images for each compiler - f-compiler: gfortran diff --git a/.github/workflows/run_mpas_hrrr.yml b/.github/workflows/run_mpas_hrrr.yml index 655c70b6ec..1b78f55ae1 100644 --- a/.github/workflows/run_mpas_hrrr.yml +++ b/.github/workflows/run_mpas_hrrr.yml @@ -22,9 +22,9 @@ on: [push, pull_request, workflow_dispatch] # # Tests: # Baseline Codebase Repository:Branch Physics IC source season build-type -# 1/4) ufs-community:gsl/develop hrrrv5 gfs winter Release/Debug -# 2/5) ufs-community:gsl/develop hrrrv5 rap summer Release/Debug -# 3/6) ufs-community:gsl/develop hrrrv5 rap winter Release/Debug +# 1/4) ufs-community:noaa/develop hrrrv5 gfs winter Release/Debug +# 2/5) ufs-community:noaa/develop hrrrv5 rap summer Release/Debug +# 3/6) ufs-community:noaa/develop hrrrv5 rap winter Release/Debug # ############################################################################################# jobs: @@ -90,7 +90,7 @@ jobs: if: contains(matrix.build-type, 'Debug') run: | cd ${runner_ROOT} - git clone --recursive --branch gsl/develop https://github.com/ufs-community/MPAS-Model.git MPAS-Model-BL + git clone --recursive --branch noaa/develop https://github.com/ufs-community/MPAS-Model.git MPAS-Model-BL cd ${mpas_bl_ROOT} make ${{matrix.bld_target}} CORE=atmosphere DEBUG=true @@ -98,7 +98,7 @@ jobs: if: contains(matrix.build-type, 'Release') run: | cd ${runner_ROOT} - git clone --recursive --branch gsl/develop https://github.com/ufs-community/MPAS-Model.git MPAS-Model-BL + git clone --recursive --branch noaa/develop https://github.com/ufs-community/MPAS-Model.git MPAS-Model-BL cd ${mpas_bl_ROOT} make ${{matrix.bld_target}} CORE=atmosphere From 31483cecaa4b8a72f06543bab80976805880a4bc Mon Sep 17 00:00:00 2001 From: Clark Evans Date: Thu, 30 Apr 2026 10:46:40 -0600 Subject: [PATCH 195/214] Update GFL submodule to latest version --- src/core_atmosphere/physics/physics_noaa/GFL | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/physics/physics_noaa/GFL b/src/core_atmosphere/physics/physics_noaa/GFL index bf6a4b0d58..ac88af7f62 160000 --- a/src/core_atmosphere/physics/physics_noaa/GFL +++ b/src/core_atmosphere/physics/physics_noaa/GFL @@ -1 +1 @@ -Subproject commit bf6a4b0d58f112322fbf9b11d43ed2027aeb56fa +Subproject commit ac88af7f62d9d6b9d84b3f00acb0f3b2c4120b96 From 62a5bdcf845991efefbddfef19f3921d0dcf737e Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 5 May 2026 15:55:17 -0600 Subject: [PATCH 196/214] v8.3.1-2.28: Hotfix for CI tests * v8.3.1-2.28: Hotfix for CI tests --------- Co-authored-by: dustinswales --- .github/workflows/run_mpas.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/run_mpas.yml b/.github/workflows/run_mpas.yml index 72a879dd12..bba11e04b2 100644 --- a/.github/workflows/run_mpas.yml +++ b/.github/workflows/run_mpas.yml @@ -183,7 +183,7 @@ jobs: - name: Link lateral boundary condition file for regional MPAS. run: | cd ${runner_ROOT}/run_bl - ln -sf ${MPAS_ROOT}/${mpas_ics}/mpas.lbc.nc. + ln -sf ${MPAS_ROOT}/${mpas_ics}/mpas.lbc.nc . - name: Link Thompson MP data tables to run directory if: contains(matrix.physics, 'convection_permitting') From 67bf1cc94e9764504478688b543591a73246abd9 Mon Sep 17 00:00:00 2001 From: Clark Evans Date: Wed, 3 Jun 2026 15:36:39 -0600 Subject: [PATCH 197/214] Maybe revert changes again... --- src/core_atmosphere/physics/physics_noaa/GFL | 2 +- src/core_atmosphere/physics/physics_noaa/MYNN-EDMF | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_atmosphere/physics/physics_noaa/GFL b/src/core_atmosphere/physics/physics_noaa/GFL index ac88af7f62..bf6a4b0d58 160000 --- a/src/core_atmosphere/physics/physics_noaa/GFL +++ b/src/core_atmosphere/physics/physics_noaa/GFL @@ -1 +1 @@ -Subproject commit ac88af7f62d9d6b9d84b3f00acb0f3b2c4120b96 +Subproject commit bf6a4b0d58f112322fbf9b11d43ed2027aeb56fa diff --git a/src/core_atmosphere/physics/physics_noaa/MYNN-EDMF b/src/core_atmosphere/physics/physics_noaa/MYNN-EDMF index c942418a47..c6d08709e8 160000 --- a/src/core_atmosphere/physics/physics_noaa/MYNN-EDMF +++ b/src/core_atmosphere/physics/physics_noaa/MYNN-EDMF @@ -1 +1 @@ -Subproject commit c942418a47a29dee09b51b377286da6bb25160e3 +Subproject commit c6d08709e83fbc6245e91a65600fd78c7219f1ee From b38b07d6080e35f7c433fa1d97ddf302346f7b5c Mon Sep 17 00:00:00 2001 From: Clark Evans Date: Wed, 3 Jun 2026 15:41:29 -0600 Subject: [PATCH 198/214] Revert MYNN-EDMF --- src/core_atmosphere/physics/physics_noaa/MYNN-EDMF | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/physics/physics_noaa/MYNN-EDMF b/src/core_atmosphere/physics/physics_noaa/MYNN-EDMF index c6d08709e8..c942418a47 160000 --- a/src/core_atmosphere/physics/physics_noaa/MYNN-EDMF +++ b/src/core_atmosphere/physics/physics_noaa/MYNN-EDMF @@ -1 +1 @@ -Subproject commit c6d08709e83fbc6245e91a65600fd78c7219f1ee +Subproject commit c942418a47a29dee09b51b377286da6bb25160e3 From d54a6991b341cdf0af5cd3bbed807f8d37950794 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Jun 2026 22:41:59 +0000 Subject: [PATCH 199/214] Update version number to 8.4.1 --- README.md | 2 +- src/core_atmosphere/Registry.xml | 2 +- src/core_init_atmosphere/Registry.xml | 2 +- src/core_landice/Registry.xml | 2 +- src/core_ocean/Registry.xml | 2 +- src/core_seaice/Registry.xml | 2 +- src/core_sw/Registry.xml | 2 +- src/core_test/Registry.xml | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) diff --git a/README.md b/README.md index 8db0d85898..a1e6701152 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -MPAS-v8.4.0 +MPAS-v8.4.1 ==== The Model for Prediction Across Scales (MPAS) is a collaborative project for diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index f1a55bc3a3..efa912ad73 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index d45a115e33..831901565a 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 73e23a13db..c9ad026dd5 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 5089d8cb30..1137f23e8a 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -1,5 +1,5 @@ - + - + - + diff --git a/src/core_test/Registry.xml b/src/core_test/Registry.xml index 5e77060980..3c17174919 100644 --- a/src/core_test/Registry.xml +++ b/src/core_test/Registry.xml @@ -1,5 +1,5 @@ - + From 563a7a2e4fae878a892df6803881f36c25fdf322 Mon Sep 17 00:00:00 2001 From: Abishek Gopal Date: Wed, 27 May 2026 15:35:16 -0600 Subject: [PATCH 200/214] Check for duplicate namelist options in active_when attributes This commit addresses the compiler errors that occur with the generated code when a namelist option appears more than once in an active_when attribute in a package definition in Registry.xml. e.g., config_foo > 0 .and. config_foo < 10. The solution involves modifying the logic in package_logic_routine and gen_pkg_debug_info in src/tools/registry/gen_inc.c to identify the unique namelist options in the active_when attributes. This commit introduces a simple helper function, add_unique_key_to_list, to add unique namelist options to a string list. This list is then iterated over by subsequent logic in order to ensure that there are no multiply defined variables in the generated Fortran code. Presently, the MAX_LIST_SIZE macro caps the maximum number of unique namelist options allowed in the active_when attribute at 20. --- src/tools/registry/gen_inc.c | 87 ++++++++++++++++++++++++++++++------ 1 file changed, 74 insertions(+), 13 deletions(-) diff --git a/src/tools/registry/gen_inc.c b/src/tools/registry/gen_inc.c index 5ec8b06d18..bee81db012 100644 --- a/src/tools/registry/gen_inc.c +++ b/src/tools/registry/gen_inc.c @@ -28,11 +28,13 @@ int package_logic_routine(FILE *fd, regex_t *preg, const char *corename, const char *packagename, const char *packagewhen, ezxml_t registry); void gen_pkg_debug_info(FILE *fd, regex_t *preg, ezxml_t registry, - const char *packagename, const char *packagewhen); + const char *packagename, const char *packagewhen, + char **nmloptions_list, int num_nmloptions); #define NUM_MODIFIED_ATTRS 2 #define NUM_IGNORED_ATTRS 9 #define NUM_NUMERIC_ATTRS 1 +#define MAX_LIST_SIZE 20 static const char *NUMERIC_ATTRS[NUM_NUMERIC_ATTRS] = { "missing_value" @@ -2725,6 +2727,46 @@ int generate_package_logic(ezxml_t registry)/*{{{*/ }/*}}}*/ +/****************************************************************************** + * + * add_unique_key_to_list + * + * Adds a string to a list of strings, if it is not already present. + * Allocates a copy of the key string and stores it at the next available + * index in string_list. + * + * Inputs: + * string_list - an array of char pointers to store strings + * key - a null-terminated string containing the key to add + * num_keys - the current number of keys stored in string_list + * + * Outputs: + * string_list - updated with the new key appended, if not a duplicate + * num_keys - incremented by 1 if the key was successfully added + * + * Return value: 0 if the key was added successfully, 1 if the key was + * already present in the list, and -1 if the list is full. + * + ******************************************************************************/ +int add_unique_key_to_list(char **string_list, const char *key, int *num_keys) +{ + + for (int i = 0; i < *num_keys; i++) { + if (strcmp(string_list[i], key) == 0) { + return 1; + } + } + + if (*num_keys < MAX_LIST_SIZE) { + string_list[*num_keys] = strdup(key); + (*num_keys)++; + return 0; + } else { + return -1; + } +} + + /****************************************************************************** * * package_logic_routine @@ -2756,7 +2798,9 @@ int package_logic_routine(FILE *fd, regex_t *preg, const char *corename, ezxml_t packages_xml, package_xml; char *match; regoff_t next; - + char *nmloptions_list[MAX_LIST_SIZE]; + int num_nmloptions = 0; + int ierr; fortprintf(fd, "\n"); fortprintf(fd, " !\n"); @@ -2777,9 +2821,23 @@ int package_logic_routine(FILE *fd, regex_t *preg, const char *corename, fortprintf(fd, " logical, pointer :: %sActive\n", packagename); fortprintf(fd, "\n"); + fprintf(stdout, "Parsing active_when string for package %s: %s\n", packagename, packagewhen); next = 0; while ((match = nmlopt_from_str(preg, packagewhen, &next)) != NULL) { const char *nmltype; + ierr = add_unique_key_to_list(nmloptions_list, match, &num_nmloptions); + if (ierr < 0) { + // Error case: too many unique namelist options in active_when attribute. + fprintf(stderr, "Error: Too many unique namelist options specified in active_when" + " attribute for %s package. Maximum allowed is %d.\n", packagename, MAX_LIST_SIZE); + free(match); + for (int i = 0; i < num_nmloptions; i++) free(nmloptions_list[i]); + return 1; + } else if (ierr == 1) { + // Namelist option already in list, so we can skip it. + free(match); + continue; + } nmltype = nmlopt_type(registry, match); @@ -2809,20 +2867,21 @@ int package_logic_routine(FILE *fd, regex_t *preg, const char *corename, } fortprintf(fd, "\n"); - next = 0; - while ((match = nmlopt_from_str(preg, packagewhen, &next)) != NULL) { - - fortprintf(fd, " nullify(%s)\n", match, match); - fortprintf(fd, " call mpas_pool_get_config(configPool, '%s', %s)\n", match, match); - - free(match); + for (int i = 0; i < num_nmloptions; i++) { + fortprintf(fd, " nullify(%s)\n", nmloptions_list[i]); + fortprintf(fd, " call mpas_pool_get_config(configPool, '%s', %s)\n", nmloptions_list[i], nmloptions_list[i]); } + fortprintf(fd, "\n"); fortprintf(fd, " nullify(%sActive)\n", packagename); fortprintf(fd, " call mpas_pool_get_package(packagePool, '%sActive', %sActive)\n", packagename, packagename); fortprintf(fd, "\n"); - gen_pkg_debug_info(fd, preg, registry, packagename, packagewhen); + gen_pkg_debug_info(fd, preg, registry, packagename, packagewhen, nmloptions_list, num_nmloptions); + + for (int i = 0; i < num_nmloptions; i++) { + free(nmloptions_list[i]); + } fortprintf(fd, " %sActive = ( %s )\n", packagename, packagewhen); fortprintf(fd, " call mpas_log_write(' %s : $l', logicArgs=[%sActive])\n", packagename, packagename); @@ -2929,10 +2988,12 @@ const char * nmlopt_type(ezxml_t registry, const char *nmlopt)/*{{{*/ * packagename - the name of the package for which code is being generated * packagewhen - the string containing the logical condition under which the * package is active + * nmloptions_list - a list of unique namelist options in the active_when attribute + * num_nmloptions - the number of unique namelist options in the active_when attribute * ******************************************************************************/ void gen_pkg_debug_info(FILE *fd, regex_t *preg, ezxml_t registry, - const char *packagename, const char *packagewhen)/*{{{*/ + const char *packagename, const char *packagewhen, char **nmloptions_list, int num_nmloptions)/*{{{*/ { char *match; regoff_t next = 0; @@ -2942,9 +3003,10 @@ void gen_pkg_debug_info(FILE *fd, regex_t *preg, ezxml_t registry, fortprintf(fd, " PACKAGE_LOGIC_PRINT(' namelist settings:')\n"); fortprintf(fd, " PACKAGE_LOGIC_PRINT(' ------------------')\n"); - while ((match = nmlopt_from_str(preg, packagewhen, &next)) != NULL) { + for (int i = 0; i < num_nmloptions; i++) { const char *nmltype; + match = nmloptions_list[i]; nmltype = nmlopt_type(registry, match); if (nmltype != NULL) { @@ -2959,7 +3021,6 @@ void gen_pkg_debug_info(FILE *fd, regex_t *preg, ezxml_t registry, } } - free(match); } fortprintf(fd, "\n"); }/*}}}*/ From ba33de23eada39d67a564fad6e07327c382d3cc4 Mon Sep 17 00:00:00 2001 From: Kuan-Chih Wang Date: Tue, 21 Apr 2026 13:50:09 -0600 Subject: [PATCH 201/214] Fix Fortran standard violation due to undefined pointer actual argument in atm_srk3 At line 1970 inside the `atm_srk3` time stepping subroutine, if the `DO_PHYSICS` macro is undefined, the `diag_physics` pointer will not be initialized by the call to the `mpas_pool_get_subpool` subroutine, and therefore its pointer association status will remain undefined. However, at line 2250, this pointer is used as an actual argument to call the `atm_compute_dyn_tend` subroutine, which constitutes a Fortran standard violation. Quoted from Fortran 2023, > 15.5.2.4 Argument association > Except in references to intrinsic inquiry functions, a pointer actual argument that > corresponds to a nonoptional nonpointer dummy argument shall be pointer associated with > a target. This bug can lead to a runtime crash for models that use MPAS as a dynamical core (e.g., CAM, CAM-SIMA). Fix this issue by adding the `pointer` attribute to the `diag_physics` dummy argument for the `atm_compute_dyn_tend` subroutine. --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 238ca7235f..c160729765 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5813,7 +5813,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys type (mpas_pool_type), intent(in) :: state type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh - type (mpas_pool_type), intent(in) :: diag_physics + type (mpas_pool_type), pointer, intent(in) :: diag_physics type (mpas_pool_type), intent(in) :: configs integer, intent(in) :: nVertLevels ! for allocating stack variables integer, intent(in) :: rk_step, dynamics_substep From df752678780b96136f89c2b2b6e3657e316cd742 Mon Sep 17 00:00:00 2001 From: Kuan-Chih Wang Date: Tue, 21 Apr 2026 14:35:05 -0600 Subject: [PATCH 202/214] Add missing dummy argument intent in atm_compute_dyn_tend Throughout the `atm_compute_dyn_tend` subroutine, the `tend_physics` pointer dummy argument never changes its pointer association status. Add the missing `intent(in)` attribute for better safety. --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index c160729765..b6e620fe12 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5809,7 +5809,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys ! Dummy arguments ! type (mpas_pool_type), intent(inout) :: tend - type (mpas_pool_type), pointer :: tend_physics + type (mpas_pool_type), pointer, intent(in) :: tend_physics type (mpas_pool_type), intent(in) :: state type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh From 94029b3e33382cf69b9e204fe2298ef9c4302952 Mon Sep 17 00:00:00 2001 From: Kuan-Chih Wang Date: Tue, 21 Apr 2026 14:49:58 -0600 Subject: [PATCH 203/214] Avoid implicit save attribute during variable declaration in atm_srk3 In Fortran, explicit initialization of a variable implies the `save` attribute, which may have surprising result and is not thread-safe. Avoid doing it to conform to the Fortran best practices. --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index b6e620fe12..227fbde862 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1918,7 +1918,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) type (mpas_pool_type), pointer :: diag_physics type (mpas_pool_type), pointer :: mesh type (mpas_pool_type), pointer :: tend - type (mpas_pool_type), pointer :: tend_physics => null() + type (mpas_pool_type), pointer :: tend_physics type (mpas_pool_type), pointer :: lbc ! regional_MPAS addition real (kind=RKIND), dimension(:,:), pointer :: w From 11d347a354e14603ec5271be7917f3c242939eea Mon Sep 17 00:00:00 2001 From: Clark Evans Date: Fri, 5 Jun 2026 15:00:22 -0600 Subject: [PATCH 204/214] Reducing rap/summer CI test timestep for testing --- .../cases/ufscommunity.hrrrv5.rap.summer/namelist.atmosphere | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/namelist.atmosphere b/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/namelist.atmosphere index 443cbba4b7..b6bb8473cd 100644 --- a/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/namelist.atmosphere +++ b/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/namelist.atmosphere @@ -1,6 +1,6 @@ &nhyd_model config_time_integration_order = 2 - config_dt = 720.0 + config_dt = 600.0 config_start_time = '2024-08-15_18:00:00' config_run_duration = '0_06:00:00' config_split_dynamics_transport = true From 95d33cd8ec2d875cf0ff544185439b520a4bb51b Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Thu, 7 May 2026 14:57:59 -0600 Subject: [PATCH 205/214] Limit the saturation vapor pressure e_s used in the Kessler microphysics This commit limits the saturation vapor pressure e_s used in the Kessler microphysics to a value at or below 99% of the full pressure. In the previous version of Kessler the saturation vapor pressure formula could produce unphysically large values of e_s at very low pressures (high model top) and cause the model to blow up. --- src/core_atmosphere/physics/physics_wrf/module_mp_kessler.F | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_kessler.F b/src/core_atmosphere/physics/physics_wrf/module_mp_kessler.F index 7dd2e36894..0e591ba32d 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_mp_kessler.F +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_kessler.F @@ -216,6 +216,7 @@ SUBROUTINE kessler( t, qv, qc, qr, rho, pii & gam = 2.5e+06/(1004.*pii(i,k,j)) ! qvs = 380.*exp(17.27*(temp-273.)/(temp- 36.))/pressure es = 1000.*svp1*exp(svp2*(temp-svpt0)/(temp-svp3)) + es = min(es, 0.99*pressure) qvs = ep2*es/(pressure-es) ! prod(i,k,j) = (qv(i,k,j)-qvs) / (1.+qvs*f5/(temp-36.)**2) prod(i,k,j) = (qv(i,k,j)-qvs) / (1.+pressure/(pressure-es)*qvs*f5/(temp-svp3)**2) From 4e03bc82c25a69a5040bce8c223471288ac73b8f Mon Sep 17 00:00:00 2001 From: Marcos Longo Date: Tue, 26 May 2026 08:21:30 -0300 Subject: [PATCH 206/214] This commit mirrors a similar commit in MONAN. It fixes a cryptic bug that only occurs when the code is modified to run with more than four soil layers. The logic in mpas_atmphys_driver_lsm_noahmp.F can be simplified to a single loop that will always work. Likewise, Registry_noahmp.xml does not need to have the combined number of soil plus snow levels (nzSoilLevels) hardcoded, it can be written as the sum of the levels so it always works. --- src/core_atmosphere/physics/Registry_noahmp.xml | 2 +- .../physics/mpas_atmphys_driver_lsm_noahmp.F | 6 +----- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/src/core_atmosphere/physics/Registry_noahmp.xml b/src/core_atmosphere/physics/Registry_noahmp.xml index 89d980f724..ec4c7b030a 100644 --- a/src/core_atmosphere/physics/Registry_noahmp.xml +++ b/src/core_atmosphere/physics/Registry_noahmp.xml @@ -16,7 +16,7 @@ - diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_noahmp.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_noahmp.F index 7b93e7cf62..e2eb8a8c55 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_noahmp.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_noahmp.F @@ -842,14 +842,10 @@ subroutine lsm_noahmp_toMPAS(diag_physics,diag_physics_noahmp,output_noahmp,sfc_ snicexy(ns,i) = mpas_noahmp%snicexy(i,n) snliqxy(ns,i) = mpas_noahmp%snliqxy(i,n) enddo - do ns = 1,nsnow + do ns = 1,nzsnow n = ns - nsnow zsnsoxy(ns,i) = mpas_noahmp%zsnsoxy(i,n) enddo - do ns = nsnow+1,nzsnow - n = ns - nsoil + 1 - zsnsoxy(ns,i) = mpas_noahmp%zsnsoxy(i,n) - enddo enddo From 7b79c0b0342fa1fd74d5ff2121272d6f8367087f Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 29 May 2026 09:56:38 -0600 Subject: [PATCH 207/214] Fix broken builds with GEN_F90=true by adding missing include paths to Makefiles This commit adds missing include paths to the Makefile recipes that are used when MPAS is compiled with GEN_F90=true. --- src/core_atmosphere/Makefile | 2 +- src/core_atmosphere/dynamics/Makefile | 2 +- src/core_atmosphere/physics/Makefile | 4 ++-- src/core_atmosphere/physics/physics_wrf/Makefile | 2 +- src/framework/Makefile | 2 +- 5 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index e7d5e9a2fe..bb2bd2c2e7 100644 --- a/src/core_atmosphere/Makefile +++ b/src/core_atmosphere/Makefile @@ -94,7 +94,7 @@ clean: .F.o: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" - $(CPP) $(CPPFLAGS) $(PHYSICS) $(CHEMISTRY) $(CPPINCLUDES) -I./inc $< > $*.f90 + $(CPP) $(CPPFLAGS) $(PHYSICS) $(CHEMISTRY) $(CPPINCLUDES) -I./inc -I../framework $< > $*.f90 $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I./physics/physics_mmm -I./physics/physics_noaa/UGWP $(MPAS_ESMF_INC) -I./chemistry else $(FC) $(CPPFLAGS) $(PHYSICS) $(CHEMISTRY) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./inc -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I./physics/physics_mmm -I./physics/physics_noaa/UGWP $(MPAS_ESMF_INC) -I./chemistry diff --git a/src/core_atmosphere/dynamics/Makefile b/src/core_atmosphere/dynamics/Makefile index bf42768edd..9b0741568d 100644 --- a/src/core_atmosphere/dynamics/Makefile +++ b/src/core_atmosphere/dynamics/Makefile @@ -20,7 +20,7 @@ clean: .F.o: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" - $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) $< > $*.f90 + $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) -I../../framework $< > $*.f90 $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../physics/physics_mmm $(MPAS_ESMF_INC) else $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../physics/physics_mmm $(MPAS_ESMF_INC) diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index ac5ff5d6f3..2b7422ddec 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -261,8 +261,8 @@ clean: .F.o: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" - $(CPP) $(CPPFLAGS) $(COREDEF) $(HYDROSTATIC) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I.. -I../../framework $(MPAS_ESMF_INC) + $(CPP) $(CPPFLAGS) $(COREDEF) $(HYDROSTATIC) $(CPPINCLUDES) -I../../framework $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I./physics_noaa/UGWP -I.. -I../../framework $(MPAS_ESMF_INC) else $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I./physics_noaa/UGWP -I.. -I../../framework $(MPAS_ESMF_INC) endif diff --git a/src/core_atmosphere/physics/physics_wrf/Makefile b/src/core_atmosphere/physics/physics_wrf/Makefile index 2c4d0079ef..28246dd963 100644 --- a/src/core_atmosphere/physics/physics_wrf/Makefile +++ b/src/core_atmosphere/physics/physics_wrf/Makefile @@ -123,7 +123,7 @@ clean: .F.o: ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../physics_mmm -I../../../framework $(MPAS_ESMF_INC) + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../physics_mmm -I../physics_noaa/UGWP -I../../../framework $(MPAS_ESMF_INC) else $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../physics_mmm -I../physics_noaa/UGWP -I../../../framework $(MPAS_ESMF_INC) endif diff --git a/src/framework/Makefile b/src/framework/Makefile index 29f05f3b12..a6f1c291e6 100644 --- a/src/framework/Makefile +++ b/src/framework/Makefile @@ -127,7 +127,7 @@ clean: .F.o: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) -I../external/SMIOL $< > $*.f90 $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) $(MPAS_ESMF_INC) else $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) $(MPAS_ESMF_INC) From d30b9951e2cff582157f3cec530a248237f2d7fb Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 26 May 2026 13:48:00 -0600 Subject: [PATCH 208/214] Atmosphere core allocates surface arrays based on sfclay choice not PBL choice When the LES options are run in real-data cases, the sfclayer physics is used but not the PBL physics. Many (over 30) 2d arrays were allocated based on PBL packages when their true dependence is on the sfclayer package. This caused a failure due to using unallocated arrays. The fix is to create and use instead a sfclayer package in the Registry. --- src/core_atmosphere/Registry.xml | 79 +++++++++++++++++--------------- 1 file changed, 41 insertions(+), 38 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index efa912ad73..425e0349d1 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -485,6 +485,9 @@ + @@ -2750,7 +2753,7 @@ + packages="bl_mynn_in;bl_ysu_in;sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> + packages="sfclayer"/> - - + - - - - From 97c0f8455168972fb5ad3c58f17a628e4a2db0af Mon Sep 17 00:00:00 2001 From: Clark Evans Date: Tue, 9 Jun 2026 21:21:00 -0600 Subject: [PATCH 209/214] Add qcg back to core_atmosphere/Registry.xml --- src/core_atmosphere/Registry.xml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 498c66c556..2286856b73 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -3684,6 +3684,10 @@ description="surface exchange coefficient for heat" packages="sfclayer"/> + + From 4ae22c3e429c7739e3d3df66902f99a7e09a685a Mon Sep 17 00:00:00 2001 From: Clark Evans Date: Tue, 9 Jun 2026 21:39:34 -0600 Subject: [PATCH 210/214] Update run_mpas.yml --- .github/workflows/run_mpas.yml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/.github/workflows/run_mpas.yml b/.github/workflows/run_mpas.yml index 2e1fa536ed..2ce0670a46 100644 --- a/.github/workflows/run_mpas.yml +++ b/.github/workflows/run_mpas.yml @@ -26,9 +26,9 @@ on: [push, pull_request, workflow_dispatch] # # Tests: # Baseline Codebase Repository:Branch Physics build type -# 1/7) MPAS-Dev:v8.4.0 mesoscale_reference Release/Debug -# 2/8) MPAS-Dev:v8.4.0 convection_permitting Release/Debug -# 3/9) MPAS-Dev:v8.4.0 mesoscale_reference_noahmp Release/Debug +# 1/7) MPAS-Dev:v8.4.1 mesoscale_reference Release/Debug +# 2/8) MPAS-Dev:v8.4.1 convection_permitting Release/Debug +# 3/9) MPAS-Dev:v8.4.1 mesoscale_reference_noahmp Release/Debug # 4/10) ufs-community:noaa/develop mesoscale_reference Release/Debug # 5/11) ufs-community:noaa/develop convection_permitting Release/Debug # 6/12) ufs-community:noaa/develop mesoscale_reference_noahmp Release/Debug @@ -43,13 +43,13 @@ jobs: f-compiler: [gfortran]#,ifx] physics: [mesoscale_reference, convection_permitting, mesoscale_reference_noahmp] repo: [ufs-community, MPAS-Dev] - branch: [noaa/develop, v8.4.0] + branch: [noaa/develop, v8.4.1] build-type: [Debug, Release] exclude: - repo: MPAS-Dev branch: noaa/develop - repo: ufs-community - branch: v8.4.0 + branch: v8.4.1 include: # Set container images for each compiler - f-compiler: gfortran From d4f633f6ec8be2754bd8189e6d04fc53fa61f1e6 Mon Sep 17 00:00:00 2001 From: Clark Evans Date: Wed, 10 Jun 2026 12:47:58 -0600 Subject: [PATCH 211/214] Add updated MYNN and MYJ sfc layer to sfclayer package definition --- src/core_atmosphere/Registry.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 2286856b73..f5a9097afb 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -521,7 +521,7 @@ active_when="trim(config_les_model) /= 'none'"/> + active_when="(trim(config_physics_suite) /= 'none' .and. trim(config_sfclayer_scheme) == 'suite') .or. any(trim(config_sfclayer_scheme) == [ character(len=StrKind) :: 'sf_monin_obukhov', 'sf_monin_obukhov_rev', 'sf_mynn', 'sf_mynnsfclay', 'sf_myj' ])"/> From a2c1812103c82b5ddcfdac1cd8c579fd0ecfda60 Mon Sep 17 00:00:00 2001 From: Clark Evans Date: Fri, 12 Jun 2026 09:22:02 -0600 Subject: [PATCH 212/214] Nudging the rap/summer timestep longer as a test --- .../cases/ufscommunity.hrrrv5.rap.summer/namelist.atmosphere | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/namelist.atmosphere b/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/namelist.atmosphere index b6bb8473cd..443cbba4b7 100644 --- a/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/namelist.atmosphere +++ b/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/namelist.atmosphere @@ -1,6 +1,6 @@ &nhyd_model config_time_integration_order = 2 - config_dt = 600.0 + config_dt = 720.0 config_start_time = '2024-08-15_18:00:00' config_run_duration = '0_06:00:00' config_split_dynamics_transport = true From 8fa0de07454577a151bf7559e88a41bc917d354d Mon Sep 17 00:00:00 2001 From: Clark Evans Date: Fri, 12 Jun 2026 09:44:33 -0600 Subject: [PATCH 213/214] Shorten the rap/summer timestep again, sigh --- .../cases/ufscommunity.hrrrv5.rap.summer/namelist.atmosphere | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/namelist.atmosphere b/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/namelist.atmosphere index 443cbba4b7..b6bb8473cd 100644 --- a/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/namelist.atmosphere +++ b/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/namelist.atmosphere @@ -1,6 +1,6 @@ &nhyd_model config_time_integration_order = 2 - config_dt = 720.0 + config_dt = 600.0 config_start_time = '2024-08-15_18:00:00' config_run_duration = '0_06:00:00' config_split_dynamics_transport = true From d72e5df14e3561c479b321438e49d0e066a829d4 Mon Sep 17 00:00:00 2001 From: Clark Evans Date: Fri, 12 Jun 2026 10:02:32 -0600 Subject: [PATCH 214/214] Change output interval for rap/summer test --- .../cases/ufscommunity.hrrrv5.rap.summer/streams.atmosphere | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/streams.atmosphere b/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/streams.atmosphere index 29d95c3b39..4664c9efd2 100644 --- a/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/streams.atmosphere +++ b/testing_and_setup/ufs-community/cases/ufscommunity.hrrrv5.rap.summer/streams.atmosphere @@ -14,7 +14,7 @@ type="output" filename_template="history.$Y-$M-$D_$h.$m.$s.nc" output_done_marker="yes" - output_interval="0:12:00" > + output_interval="0:10:00" > @@ -22,7 +22,7 @@ + output_timelevels="0-1-10m 2-6-2">