From 149d2a863dbed8c8ddeb3d7da82af3a0db96dbf7 Mon Sep 17 00:00:00 2001 From: Jerold Herwehe Date: Fri, 7 Oct 2022 12:10:05 -0400 Subject: [PATCH 01/17] Add 3-D grid analysis nudging FDDA to MPAS-A This EPA_FDDA commit will add 3-D grid analysis nudging FDDA to MPAS-A as an option to assist in keeping retrospective simulations dynamically on track to improve evaluation against observations. This FDDA development for MPAS-A (Bullock et al., 2018) nudges temperature, humidity, and wind toward target values and is based on the comparable FDDA feature available in WRF, including MPAS-A versions of many of the WRF FDDA options. Enabling analysis nudging FDDA in MPAS-A maintains high fidelity to the reference fields while still conserving mass. An extra step (additional details are provided in the associated pull request) using init_atmosphere_model is necessary to generate the FDDA file required for input to a subsequent MPAS-A simulation with FDDA enabled. New file: src/core_atmosphere/physics/mpas_atmphys_fdda.F Modified files: Makefile src/core_atmosphere/Registry.xml src/core_atmosphere/physics/Makefile src/core_atmosphere/physics/mpas_atmphys_control.F src/core_atmosphere/physics/mpas_atmphys_driver.F src/core_atmosphere/physics/mpas_atmphys_manager.F src/core_atmosphere/physics/mpas_atmphys_todynamics.F src/core_init_atmosphere/Registry.xml These EPA_FDDA code changes to MPAS-A are based on the 22 August 2022 "develop" branch of MPAS v7.3. Reference: Bullock Jr., O. R., H. Foroutan, R. C. Gilliam, and J. A. Herwehe, 2018: Adding four-dimensional data assimilation by analysis nudging to the Model for Prediction Across Scales Atmosphere (version 4.0). Geosci. Model Dev., 11, 28972922. https://doi.org/10.5194/gmd-11-2897-2018 --- Makefile | 12 +- src/core_atmosphere/Registry.xml | 150 +++++++++++ src/core_atmosphere/physics/Makefile | 7 + .../physics/mpas_atmphys_control.F | 21 +- .../physics/mpas_atmphys_driver.F | 26 +- .../physics/mpas_atmphys_fdda.F | 254 ++++++++++++++++++ .../physics/mpas_atmphys_manager.F | 4 +- .../physics/mpas_atmphys_todynamics.F | 53 +++- src/core_init_atmosphere/Registry.xml | 3 + 9 files changed, 516 insertions(+), 14 deletions(-) create mode 100644 src/core_atmosphere/physics/mpas_atmphys_fdda.F diff --git a/Makefile b/Makefile index f739e85194..c5cf4d6282 100644 --- a/Makefile +++ b/Makefile @@ -360,11 +360,11 @@ intel-mpi: # BUILDTARGET Intel compiler suite with Intel MPI library "CC_SERIAL = icc" \ "CXX_SERIAL = icpc" \ "FFLAGS_PROMOTION = -real-size 64" \ - "FFLAGS_OPT = -O3 -convert big_endian -free -align array64byte" \ - "CFLAGS_OPT = -O3" \ - "CXXFLAGS_OPT = -O3" \ + "FFLAGS_OPT = -O3 -xBROADWELL -fma -fp-model precise -traceback -no-wrap-margin -convert big_endian -free -align array64byte" \ + "CFLAGS_OPT = -O3 -xBROADWELL -fma -fp-model precise -traceback" \ + "CXXFLAGS_OPT = -O3 -xBROADWELL -fma -fp-model precise -traceback" \ "LDFLAGS_OPT = -O3" \ - "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback" \ + "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback -no-wrap-margin" \ "CFLAGS_DEBUG = -g -traceback" \ "CXXFLAGS_DEBUG = -g -traceback" \ "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ @@ -779,7 +779,7 @@ ifneq "$(LAPACK)" "" endif RM = rm -f -CPP = cpp -P -traditional +CPP = ${CXX_SERIAL} -E # Modified for use with the Intel C++ compiler RANLIB = ranlib ifdef CORE @@ -976,7 +976,7 @@ ifeq "$(findstring clean, $(MAKECMDGOALS))" "clean" # CHECK FOR CLEAN TARGET override AUTOCLEAN=false endif # END OF CLEAN TARGET CHECK -VER=$(shell git describe --dirty 2> /dev/null) +VER="v7.3.develop.EPA_FDDA" # Hard-coded specific version identifier #override CPPFLAGS += -DMPAS_GIT_VERSION=$(VER) ifeq "$(findstring v, $(VER))" "v" diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 4281c40bba..8f1256e654 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -828,6 +828,18 @@ + + + + + + + + + + + + @@ -1122,6 +1134,18 @@ #endif + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -2432,6 +2484,86 @@ description="threshold above which the accumulated grid-scale precipitation is reset" possible_values="Positive real values"/> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index 75eec25931..d4f80f083c 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -24,6 +24,7 @@ OBJS = \ mpas_atmphys_driver.o \ mpas_atmphys_driver_cloudiness.o \ mpas_atmphys_driver_convection.o \ + mpas_atmphys_fdda.o \ mpas_atmphys_driver_gwdo.o \ mpas_atmphys_driver_lsm.o \ mpas_atmphys_driver_lsm_noahmp.o \ @@ -96,6 +97,7 @@ mpas_atmphys_control.o: \ mpas_atmphys_driver.o: \ mpas_atmphys_driver_cloudiness.o \ mpas_atmphys_driver_convection.o \ + mpas_atmphys_fdda.o \ mpas_atmphys_driver_gwdo.o \ mpas_atmphys_driver_lsm.o \ mpas_atmphys_driver_lsm_noahmp.o \ @@ -120,6 +122,11 @@ mpas_atmphys_driver_convection.o: \ mpas_atmphys_utilities.o \ mpas_atmphys_vars.o +mpas_atmphys_fdda.o: \ + mpas_atmphys_constants.o \ + mpas_atmphys_utilities.o \ + mpas_atmphys_vars.o + mpas_atmphys_driver_gwdo.o: \ mpas_atmphys_vars.o \ mpas_atmphys_manager.o diff --git a/src/core_atmosphere/physics/mpas_atmphys_control.F b/src/core_atmosphere/physics/mpas_atmphys_control.F index b3162019e5..858ed8b7ef 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_control.F +++ b/src/core_atmosphere/physics/mpas_atmphys_control.F @@ -49,6 +49,8 @@ module mpas_atmphys_control ! Laura D. Fowler (laura@ucar.edu) / 2014-09-18. ! * renamed "wsm6" to "mp_wsm6" and "kessler" to "mp_kessler". ! Laura D. Fowler (laura@ucar.edu) / 2016-03-09. +! * added four-dimensional data assimilation scheme (based on WRF FDDA scheme). +! O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-03-21. ! * renamed "kain_fritsch" to "cu_kain_fritsch" and "tiedtke" to "cu_tiedtke". ! Laura D. Fowler (laura@ucar.edu) / 2016-03-22. ! * renamed "ysu" to "bl_ysu", "ysu_gwdo" to "bl_gwdo_ysu", and "monin_obukhov" to "sf_monin_obukhov". @@ -105,7 +107,8 @@ subroutine physics_namelist_check(configs) config_radt_cld_scheme, & config_radt_lw_scheme, & config_radt_sw_scheme, & - config_sfclayer_scheme + config_sfclayer_scheme, & + config_fdda_scheme !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') @@ -121,6 +124,7 @@ subroutine physics_namelist_check(configs) call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) call mpas_pool_get_config(configs,'config_sfclayer_scheme' ,config_sfclayer_scheme ) + call mpas_pool_get_config(configs,'config_fdda_scheme' ,config_fdda_scheme ) call mpas_log_write('') call mpas_log_write('----- Setting up physics suite '''//trim(config_physics_suite)//''' -----') @@ -139,6 +143,7 @@ subroutine physics_namelist_check(configs) if (trim(config_radt_cld_scheme) == 'suite') config_radt_cld_scheme = 'cld_fraction' if (trim(config_sfclayer_scheme) == 'suite') config_sfclayer_scheme = 'sf_monin_obukhov_rev' if (trim(config_lsm_scheme) == 'suite') config_lsm_scheme = 'sf_noah' + if (trim(config_fdda_scheme) == 'suite') config_fdda_scheme = 'off' else if (trim(config_physics_suite) == 'convection_permitting') then @@ -151,6 +156,7 @@ subroutine physics_namelist_check(configs) if (trim(config_radt_cld_scheme) == 'suite') config_radt_cld_scheme = 'cld_fraction' if (trim(config_sfclayer_scheme) == 'suite') config_sfclayer_scheme = 'sf_mynn' if (trim(config_lsm_scheme) == 'suite') config_lsm_scheme = 'sf_noah' + if (trim(config_fdda_scheme) == 'suite') config_fdda_scheme = 'off' else if (trim(config_physics_suite) == 'none') then @@ -163,6 +169,7 @@ subroutine physics_namelist_check(configs) if (trim(config_radt_cld_scheme) == 'suite') config_radt_cld_scheme = 'off' if (trim(config_sfclayer_scheme) == 'suite') config_sfclayer_scheme = 'off' if (trim(config_lsm_scheme) == 'suite') config_lsm_scheme = 'off' + if (trim(config_fdda_scheme) == 'suite') config_fdda_scheme = 'off' else @@ -172,6 +179,17 @@ subroutine physics_namelist_check(configs) end if +!fdda scheme: + if(.not. (config_fdda_scheme .eq. 'off' .or. & + config_fdda_scheme .eq. 'analysis' .or. & + config_fdda_scheme .eq. 'scaled' )) then + + write(mpas_err_message,'(A,A10)') 'illegal value for config_fdda_scheme:', & + trim(config_fdda_scheme) + call physics_error_fatal(mpas_err_message) + + endif + !cloud microphysics scheme: if(.not. (config_microp_scheme .eq. 'off' .or. & config_microp_scheme .eq. 'mp_kessler' .or. & @@ -327,6 +345,7 @@ subroutine physics_namelist_check(configs) call mpas_log_write(' config_radt_sw_scheme = '//trim(config_radt_sw_scheme)) call mpas_log_write(' config_sfclayer_scheme = '//trim(config_sfclayer_scheme)) call mpas_log_write(' config_lsm_scheme = '//trim(config_lsm_scheme)) + call mpas_log_write(' config_fdda_scheme = '//trim(config_fdda_scheme)) call mpas_log_write('') end subroutine physics_namelist_check diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index 8e31672657..63f6b5c985 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -21,6 +21,7 @@ module mpas_atmphys_driver use mpas_atmphys_driver_seaice,only: allocate_seaice,deallocate_seaice,driver_seaice use mpas_atmphys_driver_sfclayer use mpas_atmphys_driver_oml + use mpas_atmphys_fdda use mpas_atmphys_constants use mpas_atmphys_interface use mpas_atmphys_sfc_diagnostics,only: atmphys_sfc_diagnostics @@ -71,6 +72,7 @@ module mpas_atmphys_driver ! driver_radiation_sw : driver for short wave radiation schemes. ! driver_radiation_lw : driver for long wave radiation schemes. ! driver_sfclayer : driver for surface layer scheme. +! apply_fdda : applies four-dimensional data assimilation. ! update_convection_step1 : updates lifetime of deep convective clouds in Kain-Fritsch scheme. ! update_convection_step2 : updates accumulated precipitation output from convection schemes. ! update_radiation_diagnostics: updates accumualted radiation diagnostics from radiation schemes. @@ -88,13 +90,13 @@ module mpas_atmphys_driver ! Laura D. Fowler (laura@ucar.edu) / 2014-05-15. ! * renamed config_conv_deep_scheme to config_convection_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2014-09-18. -! * in the call to driver_convection, added block%configs needed for the implementation of the -! Grell-Freitas convection scheme. -! Laura D. Fowler (laura@ucar.edu) / 2016-03-30. ! * modified the call to the subroutines driver_sfclayer and driver_pbl for the implementation ! of the MYNN surface layer scheme and PBL schemes. itimestep and block%configs are added to ! the argument list. ! Laura D. Fowler (laura@ucar.edu) / 2015-01-06. +! * in the call to driver_convection, added block%configs needed for the implementation of the +! Grell-Freitas convection scheme. +! Laura D. Fowler (laura@ucar.edu) / 2016-03-30. ! * now only call subroutine update_convection_step2 when config_convection_scheme is not off. ! Laura D. Fowler (laura@ucar.edu) / 2016-04-13. ! * modified call to driver_cloudiness to accomodate the calculation of the cloud fraction with the Thompson @@ -122,6 +124,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) type(mpas_pool_type),pointer:: configs, & mesh, & state, & + fdda, & diag, & diag_physics, & diag_physics_noahmp, & @@ -135,6 +138,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) character(len=StrKIND),pointer:: config_bucket_update, & config_convection_scheme, & + config_fdda_scheme, & config_gwdo_scheme, & config_lsm_scheme, & config_pbl_scheme, & @@ -161,6 +165,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) call mpas_timer_start('physics driver') call mpas_pool_get_config(domain%configs,'config_convection_scheme',config_convection_scheme) + call mpas_pool_get_config(domain%configs,'config_fdda_scheme' ,config_fdda_scheme ) call mpas_pool_get_config(domain%configs,'config_gwdo_scheme' ,config_gwdo_scheme ) call mpas_pool_get_config(domain%configs,'config_lsm_scheme' ,config_lsm_scheme ) call mpas_pool_get_config(domain%configs,'config_pbl_scheme' ,config_pbl_scheme ) @@ -177,7 +182,8 @@ subroutine physics_driver(domain,itimestep,xtime_s) config_pbl_scheme .ne. 'off' .or. & config_radt_lw_scheme .ne. 'off' .or. & config_radt_sw_scheme .ne. 'off' .or. & - config_sfclayer_scheme .ne. 'off') then + config_sfclayer_scheme .ne. 'off' .or. & + config_fdda_scheme .ne. 'off') then block => domain % blocklist do while(associated(block)) @@ -185,6 +191,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) call mpas_pool_get_subpool(block%structs,'mesh' ,mesh ) call mpas_pool_get_subpool(block%structs,'state' ,state ) call mpas_pool_get_subpool(block%structs,'diag' ,diag ) + call mpas_pool_get_subpool(block%structs,'fdda' ,fdda ) 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,'output_noahmp' ,output_noahmp ) @@ -368,6 +375,17 @@ subroutine physics_driver(domain,itimestep,xtime_s) !$OMP END PARALLEL DO end if + !call to FDDA scheme within MPAS physics (not WRF physics) + if(config_fdda_scheme .ne. 'off') then + time_lev = 1 +!$OMP PARALLEL DO + do thread=1,nThreads + call apply_fdda(xtime_s,block%configs,mesh,state,time_lev,fdda,diag,diag_physics,tend_physics, & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + end do +!$OMP END PARALLEL DO + endif + !deallocate arrays shared by all physics parameterizations: call deallocate_forall_physics(block%configs) diff --git a/src/core_atmosphere/physics/mpas_atmphys_fdda.F b/src/core_atmosphere/physics/mpas_atmphys_fdda.F new file mode 100644 index 0000000000..ee7b966c9f --- /dev/null +++ b/src/core_atmosphere/physics/mpas_atmphys_fdda.F @@ -0,0 +1,254 @@ +!================================================================================================== + module mpas_atmphys_fdda + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + + use mpas_atmphys_constants + use mpas_atmphys_utilities + use mpas_atmphys_vars + + implicit none + private + public:: apply_fdda + + integer, private:: i,k + + +!MPAS grid nudging. +!O. Russell Bullock Jr. (send comments to bullock.russell@epa.gov). +!2016-03-30. +! +! subroutines in mpas_atmphys_fdda: +! ---------------------------------------------- +! apply_fdda : main fdda subroutine (called from subroutine physics_driver). +! + +! add-ons and modifications to sourcecode: +! ---------------------------------------- +! Original sourcecode by O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-03-30. +! +! * Added various controls for length-scaled FDDA application +! O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-08-11. +! * Modified to only require reads of "fdda_new" data arrays. "fdda_old" is initially +! set to initial conditions. At end of FDDA data interval, "fdda_old" is set to +! "fdda_new" and updated "fdda_new" data comes from FDDA input stream. +! O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-08-30. + + contains + +!================================================================================================== + subroutine apply_fdda(xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_physics,tend_physics, & + its,ite) +!================================================================================================== + +!input variables: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: state + type(mpas_pool_type),intent(in):: fdda + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(in):: diag_physics + integer,intent(in):: its,ite + integer,intent(in):: time_lev + real(kind=RKIND),intent(in):: xtime_s + +!inout variables: + type(mpas_pool_type),intent(inout):: tend_physics + +!local pointers: + integer,pointer:: index_qv,fdda_t_min_layer,fdda_q_min_layer,fdda_uv_min_layer + integer,dimension(:),pointer :: kpbl + real(kind=RKIND),pointer:: fdda_t_coef,fdda_q_coef,fdda_uv_coef + real(kind=RKIND),pointer:: fdda_int,fdda_scale_min,fdda_scale_max + real(kind=RKIND),pointer:: config_dt + real(kind=RKIND),pointer:: len_disp + real(kind=RKIND),dimension(:),pointer :: meshDensity + real(kind=RKIND),dimension(:,:),pointer :: rthfddaten,rqvfddaten + real(kind=RKIND),dimension(:,:),pointer :: rufddaten,rvfddaten + real(kind=RKIND),dimension(:,:),pointer :: qv_fdda_old,th_fdda_old,u_fdda_old,v_fdda_old + real(kind=RKIND),dimension(:,:),pointer :: qv_fdda_new,th_fdda_new,u_fdda_new,v_fdda_new + real(kind=RKIND),dimension(:,:),pointer :: u,v + real(kind=RKIND),dimension(:,:),pointer :: qv + real(kind=RKIND),dimension(:,:),pointer :: theta_m + real(kind=RKIND),dimension(:,:,:),pointer:: scalars + character(len=StrKIND),pointer:: fdda_scheme + logical,pointer:: fdda_t, fdda_t_in_pbl + logical,pointer:: fdda_q, fdda_q_in_pbl + logical,pointer:: fdda_uv,fdda_uv_in_pbl + logical,pointer:: config_do_restart + +!local variables: + real(kind=RKIND) :: tfrac + real(kind=RKIND) :: t_target,q_target,u_target,v_target + real(kind=RKIND) :: sfac + real(kind=RKIND) :: theta_p + real(kind=RKIND) :: srange,dcEdge_m + + integer :: i,k + + logical :: first_call = .true. + +!local parameters: + real(kind=RKIND),parameter:: rvrd = R_v/R_d + +!================================================================================================== + + call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) + call mpas_pool_get_config(configs,'config_dt' ,config_dt ) + call mpas_pool_get_config(configs,'config_fdda_scheme', fdda_scheme) + call mpas_pool_get_config(configs,'config_fdda_int',fdda_int) + call mpas_pool_get_config(configs,'config_fdda_t',fdda_t) + call mpas_pool_get_config(configs,'config_fdda_q',fdda_q) + call mpas_pool_get_config(configs,'config_fdda_uv',fdda_uv) + call mpas_pool_get_config(configs,'config_fdda_t_in_pbl',fdda_t_in_pbl) + call mpas_pool_get_config(configs,'config_fdda_q_in_pbl',fdda_q_in_pbl) + call mpas_pool_get_config(configs,'config_fdda_uv_in_pbl',fdda_uv_in_pbl) + call mpas_pool_get_config(configs,'config_fdda_t_min_layer',fdda_t_min_layer) + call mpas_pool_get_config(configs,'config_fdda_q_min_layer',fdda_q_min_layer) + call mpas_pool_get_config(configs,'config_fdda_uv_min_layer',fdda_uv_min_layer) + call mpas_pool_get_config(configs,'config_fdda_t_coef',fdda_t_coef) + call mpas_pool_get_config(configs,'config_fdda_q_coef',fdda_q_coef) + call mpas_pool_get_config(configs,'config_fdda_uv_coef',fdda_uv_coef) + call mpas_pool_get_config(configs,'config_fdda_scale_min',fdda_scale_min) + call mpas_pool_get_config(configs,'config_fdda_scale_max',fdda_scale_max) + call mpas_pool_get_config(configs,'config_len_disp' ,len_disp) + + call mpas_pool_get_array(mesh,'meshDensity',meshDensity) + + call mpas_pool_get_array(fdda,'qv_fdda_old',qv_fdda_old) + call mpas_pool_get_array(fdda,'th_fdda_old',th_fdda_old) + call mpas_pool_get_array(fdda,'u_fdda_old', u_fdda_old ) + call mpas_pool_get_array(fdda,'v_fdda_old', v_fdda_old ) + call mpas_pool_get_array(fdda,'qv_fdda_new',qv_fdda_new) + call mpas_pool_get_array(fdda,'th_fdda_new',th_fdda_new) + call mpas_pool_get_array(fdda,'u_fdda_new', u_fdda_new ) + call mpas_pool_get_array(fdda,'v_fdda_new', v_fdda_new ) + call mpas_pool_get_array(tend_physics,'rthfddaten',rthfddaten) + call mpas_pool_get_array(tend_physics,'rqvfddaten',rqvfddaten) + call mpas_pool_get_array(tend_physics,'rufddaten' ,rufddaten ) + call mpas_pool_get_array(tend_physics,'rvfddaten' ,rvfddaten ) + call mpas_pool_get_array(diag_physics,'kpbl',kpbl) + call mpas_pool_get_array(diag,'uReconstructZonal' ,u) + call mpas_pool_get_array(diag,'uReconstructMeridional',v) + + call mpas_pool_get_dimension(state,'index_qv',index_qv) + call mpas_pool_get_array(state,'scalars',scalars,time_lev) + qv => scalars(index_qv,:,:) + call mpas_pool_get_array(state,'theta_m',theta_m,time_lev) + +!check to see if 'old' FDDA target values need to be defined from initial conditions + if(first_call .and. .not. config_do_restart) then + qv_fdda_old = qv + th_fdda_old = theta_m / (1._RKIND + rvrd * qv) + u_fdda_old = u + v_fdda_old = v + first_call = .false. + endif + +!calculate time fraction within FDDA target data interval + tfrac = mod(xtime_s,fdda_int)/fdda_int + + fdda_select: select case(fdda_scheme) + + case ("scaled") + + srange = fdda_scale_max-fdda_scale_min + + DO i=its,ite + + dcEdge_m = len_disp / meshDensity(i)**0.25 + + if (dcEdge_m .lt. fdda_scale_max) then + if (dcEdge_m .lt. fdda_scale_min) then + sfac = 0.0 + else + sfac = (dcEdge_m-fdda_scale_min)/srange + endif + else + sfac = 1.0 + endif + + DO k=kts,kte + + theta_p = theta_m(k,i) / (1._RKIND + rvrd * qv(k,i)) + + if (fdda_t .and. k.gt.fdda_t_min_layer .and. (fdda_t_in_pbl .or. k.gt.kpbl(i))) then + t_target = (1.0-tfrac)*th_fdda_old(k,i)+tfrac*th_fdda_new(k,i) + rthfddaten(k,i) = fdda_t_coef * ( t_target - theta_p ) * sfac + else + rthfddaten(k,i) = 0. + endif + + if (fdda_q .and. k.gt.fdda_q_min_layer .and. (fdda_q_in_pbl .or. k.gt.kpbl(i))) then + q_target = (1.0-tfrac)*qv_fdda_old(k,i)+tfrac*qv_fdda_new(k,i) + rqvfddaten(k,i) = fdda_q_coef * ( q_target - qv(k,i) ) * sfac + else + rqvfddaten(k,i) = 0. + endif + + if (fdda_uv .and. k.gt.fdda_uv_min_layer .and. (fdda_uv_in_pbl .or. k.gt.kpbl(i))) then + u_target = (1.0-tfrac)*u_fdda_old(k,i)+tfrac*u_fdda_new(k,i) + rufddaten(k,i) = fdda_uv_coef * ( u_target - u(k,i) ) * sfac + v_target = (1.0-tfrac)*v_fdda_old(k,i)+tfrac*v_fdda_new(k,i) + rvfddaten(k,i) = fdda_uv_coef * ( v_target - v(k,i) ) * sfac + else + rufddaten(k,i) = 0. + rvfddaten(k,i) = 0. + endif + + ENDDO + ENDDO + + case("analysis") + + DO i=its,ite + DO k=kts,kte + + theta_p = theta_m(k,i) / (1._RKIND + rvrd * qv(k,i)) + + if (fdda_t .and. k.gt.fdda_t_min_layer .and. (fdda_t_in_pbl .or. k.gt.kpbl(i))) then + t_target = (1.0-tfrac)*th_fdda_old(k,i)+tfrac*th_fdda_new(k,i) + rthfddaten(k,i) = fdda_t_coef * ( t_target - theta_p ) + else + rthfddaten(k,i) = 0. + endif + + if (fdda_q .and. k.gt.fdda_q_min_layer .and. (fdda_q_in_pbl .or. k.gt.kpbl(i))) then + q_target = (1.0-tfrac)*qv_fdda_old(k,i)+tfrac*qv_fdda_new(k,i) + rqvfddaten(k,i) = fdda_q_coef * ( q_target - qv(k,i) ) + else + rqvfddaten(k,i) = 0. + endif + + if (fdda_uv .and. k.gt.fdda_uv_min_layer .and. (fdda_uv_in_pbl .or. k.gt.kpbl(i))) then + u_target = (1.0-tfrac)*u_fdda_old(k,i)+tfrac*u_fdda_new(k,i) + rufddaten(k,i) = fdda_uv_coef * ( u_target - u(k,i) ) + v_target = (1.0-tfrac)*v_fdda_old(k,i)+tfrac*v_fdda_new(k,i) + rvfddaten(k,i) = fdda_uv_coef * ( v_target - v(k,i) ) + else + rufddaten(k,i) = 0. + rvfddaten(k,i) = 0. + endif + + ENDDO + ENDDO + + case default + + end select fdda_select + +!check to see if this is the last time step within the current FDDA target data interval and +!if so, save the current "new" targets as the "old" targets for the next time step + if(mod(xtime_s+config_dt,fdda_int)/fdda_int .lt. tfrac) then + th_fdda_old = th_fdda_new + qv_fdda_old = qv_fdda_new + u_fdda_old = u_fdda_new + v_fdda_old = v_fdda_new + endif + + end subroutine apply_fdda + +!================================================================================================== + end module mpas_atmphys_fdda +!================================================================================================== diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index 2057148725..f0b94f656f 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -390,7 +390,8 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) config_lsm_scheme, & config_microp_scheme, & config_radt_lw_scheme, & - config_radt_sw_scheme + config_radt_sw_scheme, & + config_fdda_scheme character(len=StrKIND),pointer:: config_conv_interval, & config_pbl_interval, & @@ -427,6 +428,7 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) call mpas_pool_get_config(configs,'config_microp_scheme' ,config_microp_scheme ) call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) + call mpas_pool_get_config(configs,'config_fdda_scheme' ,config_fdda_scheme ) call mpas_pool_get_config(configs,'config_conv_interval' ,config_conv_interval ) call mpas_pool_get_config(configs,'config_pbl_interval' ,config_pbl_interval ) diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index 284b072851..df26521033 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -87,7 +87,8 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s convection_scheme, & microp_scheme, & radt_lw_scheme, & - radt_sw_scheme + radt_sw_scheme, & + fdda_scheme integer:: i,iCell,k,n integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs @@ -105,12 +106,14 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s real(kind=RKIND),dimension(:,:),pointer:: rthcuten,rqvcuten,rqccuten, & rqrcuten,rqicuten,rqscuten, & rucuten,rvcuten + real(kind=RKIND),dimension(:,:),pointer:: rthfddaten,rqvfddaten,rufddaten,rvfddaten real(kind=RKIND),dimension(:,:),pointer:: rthratenlw,rthratensw real(kind=RKIND),dimension(:,:),pointer:: tend_u_phys !nick real(kind=RKIND),dimension(:,:,:),pointer:: tend_scalars real(kind=RKIND),dimension(:,:),pointer:: rublten_Edge,rucuten_Edge + real(kind=RKIND),dimension(:,:),pointer:: rublten_Edge,rucuten_Edge,rufddaten_Edge real(kind=RKIND),dimension(:,:),allocatable:: tend_th @@ -126,6 +129,7 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s call mpas_pool_get_config(configs,'config_pbl_scheme' ,pbl_scheme ) call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,radt_lw_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,radt_sw_scheme ) + call mpas_pool_get_config(configs,'config_fdda_scheme' ,fdda_scheme ) call mpas_pool_get_array(state,'theta_m' ,theta_m,1) call mpas_pool_get_array(state,'scalars' ,scalars,1) @@ -169,6 +173,12 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s call mpas_pool_get_array(tend_physics,'rthratenlw',rthratenlw) call mpas_pool_get_array(tend_physics,'rthratensw',rthratensw) + call mpas_pool_get_array(tend_physics,'rufddaten',rufddaten) + call mpas_pool_get_array(tend_physics,'rvfddaten',rvfddaten) + call mpas_pool_get_array(tend_physics,'rthfddaten',rthfddaten) + call mpas_pool_get_array(tend_physics,'rqvfddaten',rqvfddaten) + call mpas_pool_get_array(tend_physics,'rufddaten_Edge',rufddaten_Edge) + call mpas_pool_get_array(tend,'scalars_tend',tend_scalars) @@ -182,7 +192,6 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s tend_rtheta_physics(:,:) = 0._RKIND tend_rho_physics(:,:) = 0._RKIND - !in case some variables are not allocated due to their associated packages. We need to make their pointers !associated here to avoid triggering run-time. checks when calling physics_get_tend_work: if(.not. associated(rucuten) ) allocate(rucuten(0,0) ) @@ -206,9 +215,15 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s if(.not. associated(rnifablten)) allocate(rnifablten(0,0)) if(.not. associated(rnwfablten)) allocate(rnwfablten(0,0)) + if(.not. associated(rufddaten)) allocate(rufddaten(0,0)) + if(.not. associated(rvfddaten)) allocate(rvfddaten(0,0)) + if(.not. associated(rthfddaten)) allocate(rthfddaten(0,0)) + if(.not. associated(rqvfddaten)) allocate(rqvfddaten(0,0)) + call physics_get_tend_work( & block,mesh,nCells,nEdges,nCellsSolve,nEdgesSolve,rk_step,dynamics_substep, & pbl_scheme,convection_scheme,microp_scheme,radt_lw_scheme,radt_sw_scheme, & + fdda_scheme, & index_qv,index_qc,index_qr,index_qi,index_qs, & index_nc,index_ni,index_nifa,index_nwfa, & mass,mass_edge,theta_m,scalars, & @@ -216,6 +231,7 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s rncblten,rniblten,rnifablten,rnwfablten, & rucuten,rvcuten,rthcuten,rqvcuten,rqccuten,rqrcuten,rqicuten,rqscuten, & rthratenlw,rthratensw,rublten_Edge,rucuten_Edge, & + rufddaten,rvfddaten,rthfddaten,rqvfddaten,rufddaten_Edge, & tend_th,tend_rtheta_physics,tend_scalars,tend_ru_physics,tend_u_phys, & exchange_halo_group) @@ -241,6 +257,11 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s if(size(rnifablten) == 0) deallocate(rnifablten) if(size(rnwfablten) == 0) deallocate(rnwfablten) + if(size(rufddaten) == 0) deallocate(rufddaten) + if(size(rvfddaten) == 0) deallocate(rvfddaten) + if(size(rthfddaten) == 0) deallocate(rthfddaten) + if(size(rqvfddaten) == 0) deallocate(rqvfddaten) + deallocate(tend_th) end subroutine physics_get_tend @@ -249,6 +270,7 @@ end subroutine physics_get_tend subroutine physics_get_tend_work( & block,mesh,nCells,nEdges,nCellsSolve,nEdgesSolve,rk_step,dynamics_substep, & pbl_scheme,convection_scheme,microp_scheme,radt_lw_scheme,radt_sw_scheme, & + fdda_scheme, & index_qv,index_qc,index_qr,index_qi,index_qs, & index_nc,index_ni,index_nifa,index_nwfa, & mass,mass_edge,theta_m,scalars, & @@ -256,6 +278,7 @@ subroutine physics_get_tend_work( & rncblten,rniblten,rnifablten,rnwfablten, & rucuten,rvcuten,rthcuten,rqvcuten,rqccuten,rqrcuten,rqicuten,rqscuten, & rthratenlw,rthratensw,rublten_Edge,rucuten_Edge, & + rufddaten,rvfddaten,rthfddaten,rqvfddaten,rufddaten_Edge, & tend_th,tend_theta,tend_scalars,tend_u,tend_u_phys, & exchange_halo_group) !================================================================================================================= @@ -271,6 +294,7 @@ subroutine physics_get_tend_work( & character(len=StrKIND),intent(in):: pbl_scheme character(len=StrKIND),intent(in):: radt_lw_scheme character(len=StrKIND),intent(in):: radt_sw_scheme + character(len=StrKIND),intent(in):: fdda_scheme integer,intent(in):: nCells,nEdges,nCellsSolve,nEdgesSolve integer,intent(in):: rk_step,dynamics_substep @@ -306,6 +330,12 @@ subroutine physics_get_tend_work( & real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rthratenlw real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rthratensw + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rufddaten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rvfddaten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rthfddaten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqvfddaten + real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: rufddaten_Edge + !inout arguments: real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: rublten_Edge real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: rucuten_Edge @@ -429,6 +459,25 @@ subroutine physics_get_tend_work( & enddo endif +!add coupled tendencies due to four-dimensional data assimilation (fdda): + if(fdda_scheme .ne. 'off') then + + rufddaten_Edge(:,:) = 0. + call tend_toEdges(block,mesh,rufddaten,rvfddaten,rufddaten_Edge) + do i = 1, nEdgesSolve + do k = 1, nVertLevels + tend_u(k,i)=tend_u(k,i)+rufddaten_Edge(k,i)*mass_edge(k,i) + enddo + enddo + + do i = 1, nCellsSolve + do k = 1, nVertLevels + tend_th(k,i) = tend_th(k,i) + rthfddaten(k,i)*mass(k,i) + tend_scalars(index_qv,k,i) = tend_scalars(index_qv,k,i) + rqvfddaten(k,i)*mass(k,i) + enddo + enddo + endif + !convert the tendency for the potential temperature to tendency for the modified potential temperature: do i = 1, nCellsSolve diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index cf4934a81b..35e2071412 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -615,6 +615,9 @@ + + + From 27022fdd865bc1e04ba40c621358c55a465fff3f Mon Sep 17 00:00:00 2001 From: May Wong Date: Tue, 15 Jul 2025 12:00:24 -0600 Subject: [PATCH 02/17] Adding new init_case = 10 in init_atmosphere to generate FDDA input files using provided intermediate files. Tested for GFS intermediate files and FDDA input files generated at the same file interval as fg_interval. --- src/core_init_atmosphere/Registry.xml | 61 ++ .../mpas_init_atm_cases.F | 897 +++++++++++++++++- .../mpas_init_atm_core_interface.F | 27 +- 3 files changed, 982 insertions(+), 3 deletions(-) diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 35e2071412..d4b6aa60dd 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -366,6 +366,7 @@ + @@ -686,6 +687,20 @@ + + + + + + + + @@ -1220,6 +1235,52 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 673ebfc525..b2d1cb7e4f 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -62,6 +62,7 @@ subroutine init_atm_setup_case(domain, stream_manager) type (mpas_pool_type), pointer :: diag type (mpas_pool_type), pointer :: diag_physics type (mpas_pool_type), pointer :: lbc_state + type (mpas_pool_type), pointer :: fdda_state integer, pointer :: config_init_case logical, pointer :: config_static_interp @@ -79,7 +80,7 @@ subroutine init_atm_setup_case(domain, stream_manager) real (kind=RKIND), pointer :: Time type (MPAS_Time_type) :: curr_time, stop_time, start_time - type (MPAS_TimeInterval_type) :: clock_interval, lbc_stream_interval, surface_stream_interval + type (MPAS_TimeInterval_type) :: clock_interval, lbc_stream_interval, surface_stream_interval, fdda_stream_interval type (MPAS_TimeInterval_type) :: time_since_start character(len=StrKIND) :: timeStart,timeString @@ -367,6 +368,70 @@ 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('Creating FDDA nudging analyses case') + + ! + ! Check that the first-guess interval (which is the same as the clock timestep) + ! matches the output interval of the 'fdda' stream + ! + clock_interval = mpas_get_clock_timestep(domain % clock, ierr=ierr) + fdda_stream_interval = MPAS_stream_mgr_get_stream_interval(stream_manager, 'fdda', MPAS_STREAM_OUTPUT, ierr) + if (clock_interval /= fdda_stream_interval) then + call mpas_log_write('****************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('The intermediate file interval specified by ''config_fg_interval''', messageType=MPAS_LOG_ERR) + call mpas_log_write('does not match the output_interval for the ''fdda'' stream.', messageType=MPAS_LOG_ERR) + call mpas_log_write('Please correct the namelist.init_atmosphere and/or', messageType=MPAS_LOG_ERR) + call mpas_log_write('streams.init_atmosphere files.', messageType=MPAS_LOG_ERR) + call mpas_log_write('****************************************************************', messageType=MPAS_LOG_CRIT) + end if + + curr_time = mpas_get_clock_time(domain % clock, MPAS_NOW) + stop_time = mpas_get_clock_time(domain % clock, MPAS_STOP_TIME) + + do while (curr_time <= stop_time) + + block_ptr => domain % blocklist + do while (associated(block_ptr)) + 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_pool_get_subpool(block_ptr % structs, 'fdda_state', fdda_state) + + call mpas_pool_get_array(state, 'xtime', xtime) + + call mpas_pool_get_dimension(block_ptr % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block_ptr % dimensions, 'nEdges', nEdges) + call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) + + call mpas_get_time(curr_time, dateTimeString=timeString) + xtime = timeString ! Set field valid time, xtime, to the current time in the time loop + + call init_atm_case_fdda(timeString, block_ptr, mesh, nCells, nEdges, nVertLevels, fg, state, & + diag, fdda_state, block_ptr % dimensions, block_ptr % configs) + + + block_ptr => block_ptr % next + end do + + call mpas_stream_mgr_write(stream_manager, streamID='fdda', ierr=ierr) + call mpas_stream_mgr_reset_alarms(stream_manager, streamID='fdda', direction=MPAS_STREAM_OUTPUT, ierr=ierr) + + call mpas_advance_clock(domain % clock) + curr_time = mpas_get_clock_time(domain % clock, MPAS_NOW) + + end do + + ! + ! Ensure that no output alarms are still ringing for the 'fdda' stream after + ! we exit the time loop above; the main run routine may write out all other + ! output streams with ringing alarms. + ! + call mpas_stream_mgr_reset_alarms(stream_manager, streamID='fdda', direction=MPAS_STREAM_OUTPUT, ierr=ierr) + + else if (config_init_case == 13 ) then call mpas_log_write(' CAM-MPAS grid ') @@ -6185,6 +6250,836 @@ subroutine init_atm_case_lbc(timestamp, block, mesh, nCells, nEdges, nVertLevels end subroutine init_atm_case_lbc + !----------------------------------------------------------------------- + ! routine init_atm_case_fdda + ! + !> \brief Computes th_fdda_new, qv_fdda_new, u_fdda_new, v_fdda_new fields for FDDA nudging + !> \details + !> This routine is similar to the init_atm_case_lbc routine in that it reads + !> atmospheric fields from "intermediate" files and horizontally and vertically + !> interpolates them to an MPAS mesh.However, it also includes the reconstructed + !> wind fields as originally in the FDDA nudging code. This routine is responsible for + !> producing only those fields that are needed for FDDA nudging. + ! + !----------------------------------------------------------------------- + subroutine init_atm_case_fdda(timestamp, block, mesh, nCells, nEdges, nVertLevels, fg, state, diag, fdda_state, dims, configs) + + use mpas_dmpar, only : mpas_dmpar_min_real, mpas_dmpar_max_real + use init_atm_read_met, only : met_data, read_met_init, read_met_close, read_next_met_field + use init_atm_llxy, only : proj_info, map_init, map_set, latlon_to_ij, PROJ_LATLON, PROJ_GAUSS, DEG_PER_RAD + use init_atm_hinterp, only : interp_sequence, FOUR_POINT, SIXTEEN_POINT, W_AVERAGE4, SEARCH + use mpas_hash, only : hashtable, mpas_hash_init, mpas_hash_destroy, mpas_hash_search, mpas_hash_size, mpas_hash_insert + + implicit none + + character(len=*), intent(in) :: timestamp + type (block_type), intent(inout), target :: block + type (mpas_pool_type), intent(inout) :: mesh + integer, intent(in) :: nCells + integer, intent(in) :: nEdges + integer, intent(in) :: nVertLevels + type (mpas_pool_type), intent(inout) :: fg + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout):: fdda_state + type (mpas_pool_type), intent(inout):: dims + type (mpas_pool_type), intent(inout):: configs + + type (parallel_info), pointer :: parinfo + type (dm_info), pointer :: dminfo + + real (kind=RKIND), parameter :: t0b = 250.0 + + type (met_data) :: field + type (proj_info) :: proj + + real (kind=RKIND), dimension(:), pointer :: dzu, fzm, fzp + real (kind=RKIND), dimension(:), pointer :: vert_level, latPoints, lonPoints + real (kind=RKIND), dimension(:,:), pointer :: zgrid, zz + real (kind=RKIND), dimension(:,:), pointer :: pressure, ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, t, rt + real (kind=RKIND), dimension(:), pointer :: destField1d + real (kind=RKIND), dimension(:,:), pointer :: destField2d + real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + + real (kind=RKIND) :: target_z + integer :: iCell, iEdge, i, k, nVertLevelsP1 + integer, pointer :: nCellsSolve + integer :: nInterpPoints, ndims + + integer :: nfglevels_actual + integer, pointer :: index_qv + + integer, dimension(5) :: interp_list + real (kind=RKIND) :: msgval + + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell + real (kind=RKIND), dimension(:,:), pointer :: sorted_arr + + integer :: sfc_k + + integer :: it + real (kind=RKIND) :: p_check + + integer :: istatus + + real (kind=RKIND), allocatable, dimension(:,:) :: rslab + + real (kind=RKIND) :: flux + real (kind=RKIND) :: lat, lon, x, y + + real (kind=RKIND) :: p0 + + real (kind=RKIND) :: etavs, ztemp + + real (kind=RKIND) :: rs, rcv + + ! calculation of the water vapor mixing ratio: + real (kind=RKIND) :: sh_max,sh_min,global_sh_max,global_sh_min + + character (len=StrKIND), pointer :: config_met_prefix + logical, pointer :: config_use_spechumd + integer, pointer :: config_nfglevels + integer, pointer :: config_theta_adv_order + real (kind=RKIND), pointer :: config_coef_3rd_order + + character (len=StrKIND), pointer :: config_extrap_airtemp + integer :: extrap_airtemp + + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell + real (kind=RKIND), dimension(:), pointer :: latEdge, lonEdge + real (kind=RKIND), dimension(:), pointer :: angleEdge + + real (kind=RKIND), dimension(:,:), pointer :: u + real (kind=RKIND), dimension(:,:), pointer :: w + real (kind=RKIND), dimension(:,:), pointer :: theta + real (kind=RKIND), dimension(:,:), pointer :: rho + real (kind=RKIND), dimension(:,:), pointer :: relhum + real (kind=RKIND), dimension(:,:), pointer :: spechum + real (kind=RKIND), dimension(:,:), pointer :: ru + real (kind=RKIND), dimension(:,:), pointer :: rw + + real (kind=RKIND), dimension(:,:), pointer :: uReconstructX + real (kind=RKIND), dimension(:,:), pointer :: uReconstructY + real (kind=RKIND), dimension(:,:), pointer :: uReconstructZ + real (kind=RKIND), dimension(:,:), pointer :: uReconstructZonal + real (kind=RKIND), dimension(:,:), pointer :: uReconstructMeridional + real (kind=RKIND), dimension(:,:), pointer :: u_fg + real (kind=RKIND), dimension(:,:), pointer :: v_fg + real (kind=RKIND), dimension(:,:), pointer :: z_fg + real (kind=RKIND), dimension(:,:), pointer :: t_fg + real (kind=RKIND), dimension(:,:), pointer :: rh_fg + real (kind=RKIND), dimension(:,:), pointer :: sh_fg + real (kind=RKIND), dimension(:,:), pointer :: p_fg + real (kind=RKIND), dimension(:), pointer :: soilz + + type (hashtable), allocatable :: level_hash + logical :: too_many_fg_levs + integer :: level_value + + character (len=StrKIND) :: errstring + + real (kind=RKIND) :: max_zgrid_local, max_zgrid_global + + + call mpas_log_write('Interpolating FDDA input fields at time '//trim(timestamp)) + + call mpas_pool_get_config(configs, 'config_met_prefix', config_met_prefix) + call mpas_pool_get_config(configs, 'config_use_spechumd', config_use_spechumd) + call mpas_pool_get_config(configs, 'config_nfglevels', config_nfglevels) + call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) + call mpas_pool_get_config(configs, 'config_coef_3rd_order', config_coef_3rd_order) + + call mpas_pool_get_config(configs, 'config_extrap_airtemp', config_extrap_airtemp) + if (trim(config_extrap_airtemp) == 'constant') then + extrap_airtemp = 0 + else if (trim(config_extrap_airtemp) == 'linear') then + extrap_airtemp = 1 + else if (trim(config_extrap_airtemp) == 'lapse-rate') then + extrap_airtemp = 2 + else + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('* Invalid value for namelist variable config_extrap_airtemp *', messageType=MPAS_LOG_ERR) + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_CRIT) + end if + call mpas_log_write("Using option '" // trim(config_extrap_airtemp) // "' for vertical extrapolation of temperature") + + dminfo => block % domain % dminfo + + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) + + call mpas_pool_get_array(mesh, 'zb', zb) + call mpas_pool_get_array(mesh, 'zb3', zb3) + + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'dzu', dzu) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + call mpas_pool_get_array(mesh, 'zz', zz) + + 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, 'pressure_base', ppb) + call mpas_pool_get_array(diag, 'pressure_p', pp) + call mpas_pool_get_array(diag, 'pressure', pressure) + call mpas_pool_get_array(diag, 'relhum', relhum) + call mpas_pool_get_array(diag, 'spechum', spechum) + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(diag, 'rw', rw) + + call mpas_pool_get_array(state, 'rho_zz', rho_zz) + call mpas_pool_get_array(diag, 'rho_p', rr) + call mpas_pool_get_array(state, 'theta_m', t) + call mpas_pool_get_array(diag, 'rtheta_p', rt) + call mpas_pool_get_array(fdda_state, 'scalars_fdda_new', scalars) + call mpas_pool_get_array(fdda_state, 'uEdge_fdda_new', u) + call mpas_pool_get_array(fdda_state, 'th_fdda_new', theta) + call mpas_pool_get_array(fdda_state, 'rho_fdda_new', rho) + call mpas_pool_get_array(fdda_state, 'uReconstructX_fdda_new', uReconstructX) + call mpas_pool_get_array(fdda_state, 'uReconstructY_fdda_new', uReconstructY) + call mpas_pool_get_array(fdda_state, 'uReconstructZ_fdda_new', uReconstructZ) + call mpas_pool_get_array(fdda_state, 'u_fdda_new', uReconstructZonal) + call mpas_pool_get_array(fdda_state, 'v_fdda_new', uReconstructMeridional) + + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + call mpas_pool_get_array(mesh, 'latEdge', latEdge) + call mpas_pool_get_array(mesh, 'lonEdge', lonEdge) + + call mpas_pool_get_array(fg, 'u', u_fg) + call mpas_pool_get_array(fg, 'v', v_fg) + call mpas_pool_get_array(fg, 'z', z_fg) + call mpas_pool_get_array(fg, 't', t_fg) + call mpas_pool_get_array(fg, 'rh', rh_fg) + call mpas_pool_get_array(fg, 'sh', sh_fg) + call mpas_pool_get_array(fg, 'p', p_fg) + + call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) + nVertLevelsP1 = nVertLevels + 1 + + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + + etavs = (1.0_RKIND - 0.252_RKIND) * pii / 2.0_RKIND + rcv = rgas / (cp - rgas) + p0 = 1.0e+05_RKIND + + scalars(:,:,:) = 0.0_RKIND + + ! + ! Check that we have what looks like a valid zgrid field. If the max value for zgrid is zero, + ! the input file likely does not contain vertical grid information. + ! + max_zgrid_local = maxval(zgrid(:,1:nCellsSolve)) + call mpas_dmpar_max_real(dminfo, max_zgrid_local, max_zgrid_global) + if (max_zgrid_global == 0.0_RKIND) then + call mpas_log_write('********************************************************************************', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('The maximum value of the zgrid field is 0. Please ensure that the ''input'' stream ', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('contains valid vertical grid information.', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('********************************************************************************', & + messageType=MPAS_LOG_CRIT) + end if + + + ! + ! Horizontally interpolate meteorological data + ! + allocate(vert_level(config_nfglevels)) + vert_level(:) = -1.0 + + ! adding a check that the timestamp is actually of length >= 13 + if ( len(trim(timestamp)) < 13 ) then + call mpas_log_write('********************************************************************************', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('init_atm_case_fdda: Error in reading timestamp for processing meteorological data files', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('********************************************************************************', & + messageType=MPAS_LOG_CRIT) + end if + + call read_met_init(trim(config_met_prefix), .false., timestamp(1:13), istatus) + + if (istatus /= 0) then + call mpas_log_write('********************************************************************************', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('Error opening initial meteorological data file '//trim(config_met_prefix)//':'//timestamp(1:13), & + messageType=MPAS_LOG_ERR) + call mpas_log_write('********************************************************************************', & + messageType=MPAS_LOG_CRIT) + end if + + allocate(level_hash) + call mpas_hash_init(level_hash) + too_many_fg_levs = .false. + + call read_next_met_field(field, istatus) + + do while (istatus == 0) + + interp_list(1) = FOUR_POINT + interp_list(2) = SEARCH + interp_list(3) = 0 + + msgval = -1.e30 + + if (trim(field % field) == 'UU' .or. & + trim(field % field) == 'VV' .or. & + trim(field % field) == 'TT' .or. & + trim(field % field) == 'RH' .or. & + trim(field % field) == 'SPECHUMD' .or. & + trim(field % field) == 'GHT' .or. & + trim(field % field) == 'SOILHGT' .or. & + trim(field % field) == 'PRES' .or. & + trim(field % field) == 'PRESSURE') then + + if (trim(field % field) /= 'SOILHGT') then + + ! Since the hash table can only store integers, transfer the bit pattern from + ! the real-valued xlvl into an integer; that the result is not an integer version + ! of the level is not important, since we only want to test uniqueness of levels + level_value = transfer(field % xlvl, level_value) + if (.not. mpas_hash_search(level_hash, level_value)) then + call mpas_hash_insert(level_hash, level_value) + if (mpas_hash_size(level_hash) > config_nfglevels) then + too_many_fg_levs = .true. + end if + end if + + ! + ! In case we have more than config_nfglevels levels, just keep cycling through + ! the remaining fields in the intermediate file for the purpose of counting how + ! many unique levels are found using the code above + ! + if (too_many_fg_levs) then + call read_next_met_field(field, istatus) + cycle + end if + + do k=1,config_nfglevels + if (vert_level(k) == field % xlvl .or. vert_level(k) == -1.0) exit + end do + if (vert_level(k) == -1.0) vert_level(k) = field % xlvl + else + k = 1 + end if + + ! + ! Set up projection + ! + call map_init(proj) + + if (field % iproj == PROJ_LATLON) then + call map_set(PROJ_LATLON, proj, & + latinc = real(field % deltalat,RKIND), & + loninc = real(field % deltalon,RKIND), & + knowni = 1.0_RKIND, & + knownj = 1.0_RKIND, & + lat1 = real(field % startlat,RKIND), & + lon1 = real(field % startlon,RKIND)) + else if (field % iproj == PROJ_GAUSS) then + call map_set(PROJ_GAUSS, proj, & + nlat = nint(field % deltalat), & + loninc = 360.0_RKIND / real(field % nx,RKIND), & + lat1 = real(field % startlat,RKIND), & + lon1 = real(field % startlon,RKIND)) + end if + + + ! + ! Horizontally interpolate the field at level k + ! + if (trim(field % field) == 'UU') then + call mpas_log_write('Interpolating U at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nEdges + latPoints => latEdge + lonPoints => lonEdge + call mpas_pool_get_array(fg, 'u', destField2d) + ndims = 2 + else if (trim(field % field) == 'VV') then + call mpas_log_write('Interpolating V at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nEdges + latPoints => latEdge + lonPoints => lonEdge + call mpas_pool_get_array(fg, 'v', destField2d) + ndims = 2 + else if (trim(field % field) == 'TT') then + call mpas_log_write('Interpolating TT at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 't', destField2d) + ndims = 2 + else if (trim(field % field) == 'RH') then + call mpas_log_write('Interpolating RH at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'rh', destField2d) + ndims = 2 + else if (trim(field % field) == 'SPECHUMD') then + call mpas_log_write('Interpolating SPECHUMD at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'sh', destField2d) + ndims = 2 + else if (trim(field % field) == 'GHT') then + call mpas_log_write('Interpolating GHT at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'z', destField2d) + ndims = 2 + else if (trim(field % field) == 'PRES') then + call mpas_log_write('Interpolating PRES at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'p', destField2d) + ndims = 2 + else if (trim(field % field) == 'PRESSURE') then + call mpas_log_write('Interpolating PRESSURE at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'p', destField2d) + ndims = 2 + else if (trim(field % field) == 'SOILHGT') then + call mpas_log_write('Interpolating SOILHGT') + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'soilz', destField1d) + ndims = 1 + end if + + allocate(rslab(-2:field % nx+3, field % ny)) + rslab(1:field % nx, 1:field % ny) = field % slab(1:field % nx, 1:field % ny) + rslab(0, 1:field % ny) = field % slab(field % nx, 1:field % ny) + rslab(-1, 1:field % ny) = field % slab(field % nx-1, 1:field % ny) + rslab(-2, 1:field % ny) = field % slab(field % nx-2, 1:field % ny) + rslab(field % nx+1, 1:field % ny) = field % slab(1, 1:field % ny) + rslab(field % nx+2, 1:field % ny) = field % slab(2, 1:field % ny) + rslab(field % nx+3, 1:field % ny) = field % slab(3, 1:field % ny) + + do i=1,nInterpPoints + lat = latPoints(i)*DEG_PER_RAD + lon = lonPoints(i)*DEG_PER_RAD + call latlon_to_ij(proj, lat, lon, x, y) + if (x < 0.5) then + lon = lon + 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + else if (x >= real(field%nx)+0.5) then + lon = lon - 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + end if + if (y < 0.5) then + y = 1.0 + else if (y >= real(field%ny)+0.5) then + y = real(field%ny) + end if + if (ndims == 1) then + destField1d(i) = interp_sequence(x, y, 1, rslab, -2, field%nx + 3, 1, field%ny, 1, 1, msgval, interp_list, 1) + else if (ndims == 2) then + destField2d(k,i) = interp_sequence(x, y, 1, rslab, -2, field%nx + 3, 1, field%ny, 1, 1, msgval, interp_list, 1) + end if + end do + + deallocate(rslab) + + end if + + deallocate(field % slab) + call read_next_met_field(field, istatus) + end do + + call read_met_close() + level_value = mpas_hash_size(level_hash) + call mpas_hash_destroy(level_hash) + deallocate(level_hash) + + if (too_many_fg_levs) then + write(errstring,'(a,i4)') ' Please increase config_nfglevels to at least ', level_value + call mpas_log_write('*******************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('Error: The meteorological data file has more than config_nfglevels.', messageType=MPAS_LOG_ERR) + call mpas_log_write(trim(errstring), messageType=MPAS_LOG_ERR) + call mpas_log_write(' in the namelist and re-run.', messageType=MPAS_LOG_ERR) + call mpas_log_write('*******************************************************************', messageType=MPAS_LOG_CRIT) + end if + + ! + ! Check how many distinct levels we actually found in the meteorological data + ! + do k=1,config_nfglevels + if (vert_level(k) == -1.0) exit + end do + nfglevels_actual = k-1 + call mpas_log_write('*************************************************') + call mpas_log_write('Found $i levels in the first-guess data', intArgs=(/nfglevels_actual/)) + call mpas_log_write('*************************************************') + + + ! + ! For isobaric data, fill in the 3-d pressure field; otherwise, ensure + ! that the surface pressure and height fields are filled in + ! + if (minval(p_fg(1:nfglevels_actual,1:nCellsSolve)) == 0.0 .and. & + maxval(p_fg(1:nfglevels_actual,1:nCellsSolve)) == 0.0) then + call mpas_log_write('Setting pressure field for isobaric data') + do k=1,config_nfglevels + if (vert_level(k) /= 200100.0) then + p_fg(k,:) = vert_level(k) + end if + end do + else + call mpas_pool_get_array(fg, 'z', z_fg) + call mpas_pool_get_array(fg, 'soilz', soilz) + call mpas_log_write('Assuming model-level input data') + do k=1,config_nfglevels + if (vert_level(k) == 200100.0) then + z_fg(k,:) = soilz(:) + end if + end do + end if + + + ! + ! Compute normal wind component and store in fg % u + ! + do iEdge=1,nEdges + do k=1,nfglevels_actual + u_fg(k,iEdge) = cos(angleEdge(iEdge)) * u_fg(k,iEdge) & + + sin(angleEdge(iEdge)) * v_fg(k,iEdge) + end do + end do + + + ! + ! Vertically interpolate meteorological data + ! + allocate(sorted_arr(2,nfglevels_actual)) + + do iCell=1,nCells + + ! T + sorted_arr(:,:) = -999.0 + do k = 1, nfglevels_actual + sorted_arr(1,k) = z_fg(k,iCell) + if (vert_level(k) == 200100.0) sorted_arr(1,k) = 99999.0 + sorted_arr(2,k) = t_fg(k,iCell) + end do + call mpas_quicksort(nfglevels_actual, sorted_arr) + do k = 1, nVertLevels + target_z = 0.5 * (zgrid(k,iCell) + zgrid(k+1,iCell)) + t(k,iCell) = vertical_interp(target_z, nfglevels_actual-1, & + sorted_arr(:,1:nfglevels_actual-1), order=1, & + extrap=extrap_airtemp, ierr=istatus) + if (istatus /= 0) then + write(errstring,'(a,i4,a,i10)') 'Error in interpolation of t(k,iCell) for k=', k, ', iCell=', iCell + call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write(trim(errstring), messageType=MPAS_LOG_ERR) + call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_CRIT) + end if + end do + + + ! RH + sorted_arr(:,:) = -999.0 + relhum(:,iCell) = 0._RKIND + do k = 1, nfglevels_actual + sorted_arr(1,k) = z_fg(k,iCell) + if (vert_level(k) == 200100.0) sorted_arr(1,k) = 99999.0 + sorted_arr(2,k) = rh_fg(k,iCell) + end do + call mpas_quicksort(nfglevels_actual, sorted_arr) + do k = nVertLevels, 1, -1 + 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) + !bugfix-from-v8.3.1 if (target_z < z_fg(1,iCell) .and. k < nVertLevels) relhum(k,iCell) = relhum(k+1,iCell) + end do + + + ! SPECHUM: if first-guess values are negative, set those values to zero before + ! vertical interpolation. + sorted_arr(:,:) = -999.0 + spechum(:,iCell) = 0._RKIND + do k = 1, nfglevels_actual + sorted_arr(1,k) = z_fg(k,iCell) + if (vert_level(k) == 200100.0) sorted_arr(1,k) = 99999.0 + sorted_arr(2,k) = max(0._RKIND,sh_fg(k,iCell)) + end do + call mpas_quicksort(nfglevels_actual, sorted_arr) + do k = nVertLevels, 1, -1 + 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) + !bugfix-from-v8.3.1 if (target_z < z_fg(1,iCell) .and. k < nVertLevels) spechum(k,iCell) = spechum(k+1,iCell) + end do + + + ! PRESSURE + sorted_arr(:,:) = -999.0 + do k = 1, nfglevels_actual + sorted_arr(1,k) = z_fg(k,iCell) + if (vert_level(k) == 200100.0) then + sorted_arr(1,k) = 99999.0 + sfc_k = k + p_fg(k,iCell) = 1.0 ! Any value that has valid log is fine... + end if + sorted_arr(2,k) = log(p_fg(k,iCell)) + end do + call mpas_quicksort(nfglevels_actual, sorted_arr) + do k = 1, nVertLevels + target_z = 0.5 * (zgrid(k,iCell) + zgrid(k+1,iCell)) + pressure(k,iCell) = exp(vertical_interp(target_z, nfglevels_actual-1, & + sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=1)) + end do + + end do + + + do iEdge=1,nEdges + + ! U + sorted_arr(:,:) = -999.0 + do k=1,nfglevels_actual + sorted_arr(1,k) = 0.5 * (z_fg(k,cellsOnEdge(1,iEdge)) + z_fg(k,cellsOnEdge(2,iEdge))) + if (vert_level(k) == 200100.0) sorted_arr(1,k) = 99999.0 + sorted_arr(2,k) = u_fg(k,iEdge) + end do + call mpas_quicksort(nfglevels_actual, sorted_arr) + do k=1,nVertLevels + target_z = 0.25 * (zgrid(k,cellsOnEdge(1,iEdge)) + zgrid(k+1,cellsOnEdge(1,iEdge)) & + + zgrid(k,cellsOnEdge(2,iEdge)) + zgrid(k+1,cellsOnEdge(2,iEdge))) + u(k,iEdge) = vertical_interp(target_z, nfglevels_actual-1, sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=1) + end do + + end do + + + ! + ! Reconstruct zonal and meridional winds for diagnostic puposes: + ! + call mpas_rbf_interp_initialize(mesh) + call mpas_init_reconstruct(mesh) + call mpas_reconstruct(mesh, u, & + uReconstructX, & + uReconstructY, & + uReconstructZ, & + uReconstructZonal, & + uReconstructMeridional & + ) + + + deallocate(sorted_arr) + + ! Diagnose the water vapor mixing ratios: + global_sh_min = 0._RKIND + global_sh_max = 0._RKIND + if(config_use_spechumd) then + sh_min = minval(spechum(:,1:nCellsSolve)) + sh_max = maxval(spechum(:,1:nCellsSolve)) + call mpas_dmpar_min_real(dminfo,sh_min,global_sh_min) + call mpas_dmpar_max_real(dminfo,sh_max,global_sh_max) + endif + call mpas_log_write('') + call mpas_log_write('--- global_sh_min = $r', realArgs=(/global_sh_min/)) + call mpas_log_write('--- global_sh_max = $r', realArgs=(/global_sh_max/)) + call mpas_log_write('') + + call mpas_log_write('--- config_use_spechumd = $l', logicArgs=(/config_use_spechumd/)) + if(.not. config_use_spechumd .or. (global_sh_min==0._RKIND .and. global_sh_max==0._RKIND)) then + !--- calculate the saturation mixing ratio and interpolated first-guess relative humidity: + if (config_use_spechumd) then + call mpas_log_write('config_use_spechumd=T, but specific humidity was not found in ' & + //trim(config_met_prefix)//':'//timestamp(1:13), messageType=MPAS_LOG_WARN) + end if + call mpas_log_write(' *** initializing water vapor mixing ratio using first-guess relative humidity') + call mpas_log_write('') + + do k = 1, nVertLevels + do iCell = 1, nCells + ! + ! Note: the RH field provided by ungrib should always be with respect to liquid water, + ! hence, we can always call rslf; see the routine fix_gfs_rh in WPS/ungrib/src/rrpr.F . + ! + rs = rslf(pressure(k,iCell),t(k,iCell)) + scalars(index_qv,k,iCell) = 0.01_RKIND*rs*relhum(k,iCell) + enddo + enddo + else + !--- use the interpolated first-guess specific humidity: + call mpas_log_write(' *** initializing water vapor mixing ratio using first-guess specific humidity') + call mpas_log_write('') + do k = 1, nVertLevels + do iCell = 1, nCells + scalars(index_qv,k,iCell) = spechum(k,iCell)/(1._RKIND-spechum(k,iCell)) + enddo + enddo + endif + + + ! + ! Diagnose fields needed in initial conditions file (u, w, rho, theta) + ! NB: At this point, "rho_zz" is simple dry density, and "theta_m" is regular potential temperature + ! + do iCell=1,nCells + + do k=1,nVertLevels + ! PI + p(k,iCell) = (pressure(k,iCell) / p0) ** (rgas / cp) + + ! THETA - can compute this using PI instead + t(k,iCell) = t(k,iCell) * (p0 / pressure(k,iCell)) ** (rgas / cp) + + ! RHO_ZZ + ! MW note. this is from _gfs case and is different from _lbc case. + rho_zz(k,iCell) = pressure(k,iCell) / rgas / (p(k,iCell) * t(k,iCell) & + * (1.0 + (rvord - 1.0) * scalars(index_qv,k,iCell))) + rho_zz(k,iCell) = rho_zz(k,iCell) / (1.0 + scalars(index_qv,k,iCell)) + end do + end do + + + + + ! + ! Reference state based on a dry isothermal atmosphere + ! + do iCell=1,nCells + do k=1,nVertLevels + ztemp = 0.5*(zgrid(k+1,iCell)+zgrid(k,iCell)) + ppb(k,iCell) = p0*exp(-gravity*ztemp/(rgas*t0b)) ! pressure_base + pb (k,iCell) = (ppb(k,iCell)/p0)**(rgas/cp) ! exner_base + rb (k,iCell) = ppb(k,iCell)/(rgas*t0b) ! rho_base + tb (k,iCell) = t0b/pb(k,iCell) ! theta_base + rtb(k,iCell) = rb(k,iCell)*tb(k,iCell) ! rtheta_base + p (k,iCell) = pb(k,iCell) ! exner + pp (k,iCell) = 0. ! pressure_p + rr (k,iCell) = 0. ! rho_p + end do + end do + + + + do iCell=1,nCells + k = 1 + +! WCS 20130821 - couple with vertical metric, note: rr is coupled here + rho_zz(k,iCell) = ((pressure(k,iCell) / p0)**(cv / cp)) * (p0 / rgas) & + / (t(k,iCell)*(1.0 + 1.61*scalars(index_qv,k,iCell))) / zz(k,iCell) + rr(k,iCell) = rho_zz(k,iCell) - rb(k,iCell) + + do k=2,nVertLevels + it = 0 + p_check = 2.0 * 0.0001 + do while ( (it < 30) .and. (p_check > 0.0001) ) + + p_check = pp(k,iCell) + +! WCS 20130821 - MPAS hydrostatic relation + pp(k,iCell) = pp(k-1,iCell) - (fzm(k)*rr(k,iCell) + fzp(k)*rr(k-1,iCell))*gravity*dzu(k) & + - (fzm(k)*rho_zz(k,iCell)*scalars(index_qv,k,iCell) & + + fzp(k)*rho_zz(k-1,iCell)*scalars(index_qv,k-1,iCell))*gravity*dzu(k) + pressure(k,iCell) = pp(k,iCell) + ppb(k,iCell) + p(k,iCell) = (pressure(k,iCell) / p0) ** (rgas / cp) + +! WCS 20130821 - couple with vertical metric + rho_zz(k,iCell) = pressure(k,iCell) / rgas & + / (p(k,iCell)*t(k,iCell)*(1.0 + 1.61*scalars(index_qv,k,iCell)))/zz(k,iCell) + rr(k,iCell) = rho_zz(k,iCell) - rb(k,iCell) + + p_check = abs(p_check - pp(k,iCell)) + + it = it + 1 + end do + end do + end do + + + + ! Compute theta_m and rho-tilde + do iCell=1,nCells + do k=1,nVertLevels + t(k,iCell) = t(k,iCell) * (1.0 + 1.61*scalars(index_qv,k,iCell)) +! WCS 20130821 - decouple rr from vertical metric + rr(k,iCell) = rr(k,iCell)*zz(k,iCell) + end do + end do + + + + do iEdge=1,nEdges + do k=1,nVertLevels + ru(k,iEdge) = u(k,iEdge) * 0.5*(rho_zz(k,cellsOnEdge(1,iEdge)) + rho_zz(k,cellsOnEdge(2,iEdge))) + end do + end do + + + + + rw(:,:) = 0.0 + do iCell=1,nCellsSolve + + do i=1,nEdgesOnCell(iCell) + iEdge=edgesOnCell(i,iCell) + + do k = 2, nVertLevels + flux = (fzm(k)*ru(k,iEdge)+fzp(k)*ru(k-1,iEdge)) + if (iCell == cellsOnEdge(1,iEdge)) then + rw(k,iCell) = rw(k,iCell) - (fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell))*zb(k,1,iEdge)*flux + else + rw(k,iCell) = rw(k,iCell) + (fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell))*zb(k,2,iEdge)*flux + end if + + if (config_theta_adv_order ==3) then + if (iCell == cellsOnEdge(1,iEdge)) then + rw(k,iCell) = rw(k,iCell) & + + sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order* & + (fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell))*zb3(k,1,iEdge)*flux + else + rw(k,iCell) = rw(k,iCell) & + - sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order* & + (fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell))*zb3(k,2,iEdge)*flux + end if + end if + + end do + + end do + + end do + + + + deallocate(vert_level) + + + + + ! 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_RKIND + 1.61_RKIND * scalars(index_qv,k,iCell)) + end do + end do + + + end subroutine init_atm_case_fdda + + + !----------------------------------------------------------------------- ! routine init_atm_case_cam_mpas ! diff --git a/src/core_init_atmosphere/mpas_init_atm_core_interface.F b/src/core_init_atmosphere/mpas_init_atm_core_interface.F index f277a4a72f..a40eb8ff3a 100644 --- a/src/core_init_atmosphere/mpas_init_atm_core_interface.F +++ b/src/core_init_atmosphere/mpas_init_atm_core_interface.F @@ -114,7 +114,7 @@ function init_atm_setup_packages(configs, streamInfo, packages, iocontext) resul integer :: ierr logical :: lexist - logical, pointer :: initial_conds, sfc_update, lbcs + logical, pointer :: initial_conds, sfc_update, lbcs, fdda logical, pointer :: gwd_stage_in, gwd_stage_out, vertical_stage_in, vertical_stage_out, met_stage_in, met_stage_out logical, pointer :: gwd_gsl_stage_out logical, pointer :: config_native_gwd_static, config_static_interp, config_vertical_grid, config_met_interp @@ -146,6 +146,9 @@ function init_atm_setup_packages(configs, streamInfo, packages, iocontext) resul nullify(lbcs) call mpas_pool_get_package(packages, 'lbcsActive', lbcs) + nullify(fdda) + call mpas_pool_get_package(packages, 'fddaActive', fdda) + nullify(gwd_stage_in) call mpas_pool_get_package(packages, 'gwd_stage_inActive', gwd_stage_in) @@ -205,6 +208,13 @@ function init_atm_setup_packages(configs, streamInfo, packages, iocontext) resul mp_thompson_aers_in = .false. end if + if (config_init_case == 10) then + fdda = .true. + else + fdda = .false. + end if + + if (config_init_case == 7) then ! @@ -256,6 +266,19 @@ function init_atm_setup_packages(configs, streamInfo, packages, iocontext) resul inquire(file="QNWFA_QNIFA_SIGMA_MONTHLY.dat",exist=lexist) if((lexist .and. met_stage_out) .or. (lexist .and. met_stage_in)) mp_thompson_aers_in = .true. + initial_conds = .false. ! Also, turn off the initial_conds package to avoid writing the IC "output" stream + ! + ! When interpolating FDDA input fields, we need all inputs that would be needed for the interpolation + ! of ICs (similar to LBC), so met_stage_in = .true. + ! + else if (config_init_case == 10) then + gwd_stage_in = .false. + gwd_stage_out = .false. + vertical_stage_in = .false. + vertical_stage_out = .false. + met_stage_in = .true. + met_stage_out = .true. + initial_conds = .false. ! Also, turn off the initial_conds package to avoid writing the IC "output" stream else if (config_init_case == 13) then @@ -285,7 +308,7 @@ function init_atm_setup_packages(configs, streamInfo, packages, iocontext) resul call mpas_pool_get_package(packages, 'first_guess_fieldActive', first_guess_field) first_guess_field = .false. - if ((config_init_case == 7 .and. config_met_interp) .or. config_init_case == 9) then + if ((config_init_case == 7 .and. config_met_interp) .or. config_init_case == 9 .or. config_init_case == 10) then first_guess_field = .true. end if From dd27c4a75a3c141fc05415ddc1ea89481a399cd4 Mon Sep 17 00:00:00 2001 From: May Wong Date: Thu, 17 Jul 2025 09:45:44 -0600 Subject: [PATCH 03/17] Changing FDDA stream variables from *_fdda_new to *_fdda. --- src/core_init_atmosphere/Registry.xml | 24 +++++++++---------- .../mpas_init_atm_cases.F | 20 ++++++++-------- 2 files changed, 22 insertions(+), 22 deletions(-) diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index d4b6aa60dd..cde516ae0f 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -1237,46 +1237,46 @@ - - - - - + - - - - - - - diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index b2d1cb7e4f..4d99f2b296 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -6253,7 +6253,7 @@ end subroutine init_atm_case_lbc !----------------------------------------------------------------------- ! routine init_atm_case_fdda ! - !> \brief Computes th_fdda_new, qv_fdda_new, u_fdda_new, v_fdda_new fields for FDDA nudging + !> \brief Computes th_fdda, qv_fdda, u_fdda, v_fdda fields for FDDA nudging !> \details !> This routine is similar to the init_atm_case_lbc routine in that it reads !> atmospheric fields from "intermediate" files and horizontally and vertically @@ -6438,15 +6438,15 @@ subroutine init_atm_case_fdda(timestamp, block, mesh, nCells, nEdges, nVertLevel call mpas_pool_get_array(diag, 'rho_p', rr) call mpas_pool_get_array(state, 'theta_m', t) call mpas_pool_get_array(diag, 'rtheta_p', rt) - call mpas_pool_get_array(fdda_state, 'scalars_fdda_new', scalars) - call mpas_pool_get_array(fdda_state, 'uEdge_fdda_new', u) - call mpas_pool_get_array(fdda_state, 'th_fdda_new', theta) - call mpas_pool_get_array(fdda_state, 'rho_fdda_new', rho) - call mpas_pool_get_array(fdda_state, 'uReconstructX_fdda_new', uReconstructX) - call mpas_pool_get_array(fdda_state, 'uReconstructY_fdda_new', uReconstructY) - call mpas_pool_get_array(fdda_state, 'uReconstructZ_fdda_new', uReconstructZ) - call mpas_pool_get_array(fdda_state, 'u_fdda_new', uReconstructZonal) - call mpas_pool_get_array(fdda_state, 'v_fdda_new', uReconstructMeridional) + call mpas_pool_get_array(fdda_state, 'scalars_fdda', scalars) + call mpas_pool_get_array(fdda_state, 'uEdge_fdda', u) + call mpas_pool_get_array(fdda_state, 'th_fdda', theta) + call mpas_pool_get_array(fdda_state, 'rho_fdda', rho) + call mpas_pool_get_array(fdda_state, 'uReconstructX_fdda', uReconstructX) + call mpas_pool_get_array(fdda_state, 'uReconstructY_fdda', uReconstructY) + call mpas_pool_get_array(fdda_state, 'uReconstructZ_fdda', uReconstructZ) + call mpas_pool_get_array(fdda_state, 'u_fdda', uReconstructZonal) + call mpas_pool_get_array(fdda_state, 'v_fdda', uReconstructMeridional) call mpas_pool_get_array(mesh, 'latCell', latCell) call mpas_pool_get_array(mesh, 'lonCell', lonCell) From 7d37aa4923939959a2b84fc7402d9b050c92cac4 Mon Sep 17 00:00:00 2001 From: May Wong Date: Wed, 30 Jul 2025 11:22:12 -0600 Subject: [PATCH 04/17] Changing th_fdda to theta_fdda --- src/core_init_atmosphere/Registry.xml | 2 +- src/core_init_atmosphere/mpas_init_atm_cases.F | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index cde516ae0f..30e7e3c600 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -1245,7 +1245,7 @@ description="Meridional component of reconstructed horizontal velocity at cell centers" packages="fdda"/> - diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 4d99f2b296..f683ea39bb 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -6253,7 +6253,7 @@ end subroutine init_atm_case_lbc !----------------------------------------------------------------------- ! routine init_atm_case_fdda ! - !> \brief Computes th_fdda, qv_fdda, u_fdda, v_fdda fields for FDDA nudging + !> \brief Computes theta_fdda, qv_fdda, u_fdda, v_fdda fields for FDDA nudging !> \details !> This routine is similar to the init_atm_case_lbc routine in that it reads !> atmospheric fields from "intermediate" files and horizontally and vertically @@ -6440,7 +6440,7 @@ subroutine init_atm_case_fdda(timestamp, block, mesh, nCells, nEdges, nVertLevel call mpas_pool_get_array(diag, 'rtheta_p', rt) call mpas_pool_get_array(fdda_state, 'scalars_fdda', scalars) call mpas_pool_get_array(fdda_state, 'uEdge_fdda', u) - call mpas_pool_get_array(fdda_state, 'th_fdda', theta) + call mpas_pool_get_array(fdda_state, 'theta_fdda', theta) call mpas_pool_get_array(fdda_state, 'rho_fdda', rho) call mpas_pool_get_array(fdda_state, 'uReconstructX_fdda', uReconstructX) call mpas_pool_get_array(fdda_state, 'uReconstructY_fdda', uReconstructY) From 636fb1deb75314e32e233c5c57a02093656f6ee2 Mon Sep 17 00:00:00 2001 From: May Wong Date: Wed, 30 Jul 2025 11:23:37 -0600 Subject: [PATCH 05/17] Moving FDDA scheme from the physics to the dynamics, implemented similar to mpas_atm_iau.F The FDDA scheme originally in physics/mpas_atmphys_fdda.F is now dynamics/mpas_atm_fdda.F, with added variable transformation and passing of FDDA tendencies to the dynamics through "tend_ru_physics, tend_rtheta_physics". Other changes include moving the FDDA configuration options in the namelist out of the physics namelist record and into its own fdda namelist record. --- src/core_atmosphere/Registry.xml | 170 +++++----- src/core_atmosphere/dynamics/Makefile | 2 +- src/core_atmosphere/dynamics/mpas_atm_fdda.F | 314 ++++++++++++++++++ .../dynamics/mpas_atm_time_integration.F | 15 + src/core_atmosphere/physics/Makefile | 7 - .../physics/mpas_atmphys_control.F | 21 +- .../physics/mpas_atmphys_driver.F | 20 +- .../physics/mpas_atmphys_fdda.F | 254 -------------- .../physics/mpas_atmphys_manager.F | 4 +- .../physics/mpas_atmphys_todynamics.F | 53 +-- 10 files changed, 422 insertions(+), 438 deletions(-) create mode 100644 src/core_atmosphere/dynamics/mpas_atm_fdda.F delete mode 100644 src/core_atmosphere/physics/mpas_atmphys_fdda.F diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 8f1256e654..1528d5f447 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -369,7 +369,90 @@ possible_values=".true. or .false."/> - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + diff --git a/src/core_atmosphere/dynamics/Makefile b/src/core_atmosphere/dynamics/Makefile index 6892633c68..f1907fa34f 100644 --- a/src/core_atmosphere/dynamics/Makefile +++ b/src/core_atmosphere/dynamics/Makefile @@ -5,7 +5,7 @@ OBJS = mpas_atm_time_integration.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_fdda.o mpas_atm_boundaries.o: diff --git a/src/core_atmosphere/dynamics/mpas_atm_fdda.F b/src/core_atmosphere/dynamics/mpas_atm_fdda.F new file mode 100644 index 0000000000..bbf3aebac0 --- /dev/null +++ b/src/core_atmosphere/dynamics/mpas_atm_fdda.F @@ -0,0 +1,314 @@ +!================================================================================================== + module mpas_atm_fdda + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + + use mpas_atmphys_constants + use mpas_atmphys_utilities + use mpas_atmphys_vars + use mpas_atmphys_todynamics, only : tend_toEdges + use mpas_log, only : mpas_log_write + + implicit none + private + public:: apply_fdda + + integer, private:: i,k + + +!MPAS grid nudging. +!O. Russell Bullock Jr. (send comments to bullock.russell@epa.gov). +!2016-03-30. +! +! subroutines in mpas_atm_fdda: +! ---------------------------------------------- +! apply_fdda : main fdda subroutine (called from subroutine physics_driver). +! + +! add-ons and modifications to sourcecode: +! ---------------------------------------- +! Original sourcecode by O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-03-30. +! +! * Added various controls for length-scaled FDDA application +! O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-08-11. +! * Modified to only require reads of "fdda_new" data arrays. "fdda_old" is initially +! set to initial conditions. At end of FDDA data interval, "fdda_old" is set to +! "fdda_new" and updated "fdda_new" data comes from FDDA input stream. +! O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-08-30. + + contains + +!================================================================================================== + subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_physics,tend,tend_physics, & + tend_ru, tend_rtheta) +!================================================================================================== + + !input variables: + type(block_type), intent(in) :: block + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: state + type(mpas_pool_type),intent(in):: fdda + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(in):: diag_physics + integer,intent(in):: time_lev + real(kind=RKIND),intent(in):: xtime_s + + !inout variables: + type(mpas_pool_type),intent(inout):: tend_physics + type(mpas_pool_type),intent(inout):: tend + + real (kind=RKIND), dimension(:,:), intent(inout) :: tend_ru + real (kind=RKIND), dimension(:,:), intent(inout) :: tend_rtheta + + !local pointers: + integer,pointer:: index_qv,fdda_t_min_layer,fdda_q_min_layer,fdda_uv_min_layer + integer,dimension(:),pointer :: kpbl + integer, pointer :: nCellsSolve, nVertLevels, nEdgesSolve + real(kind=RKIND),pointer:: fdda_t_coef,fdda_q_coef,fdda_uv_coef + real(kind=RKIND),pointer:: fdda_int,fdda_scale_min,fdda_scale_max + real(kind=RKIND),pointer:: config_dt + real(kind=RKIND),pointer:: len_disp + real(kind=RKIND),dimension(:),pointer :: meshDensity + real(kind=RKIND),dimension(:,:),pointer :: rthfddaten,rqvfddaten + real(kind=RKIND),dimension(:,:),pointer :: rufddaten,rvfddaten,rufddaten_Edge + real(kind=RKIND),dimension(:,:),pointer :: qv_fdda_old,th_fdda_old,u_fdda_old,v_fdda_old + real(kind=RKIND),dimension(:,:),pointer :: qv_fdda_new,th_fdda_new,u_fdda_new,v_fdda_new + real(kind=RKIND),dimension(:,:),pointer :: u,v + real(kind=RKIND),dimension(:,:),pointer :: qv + real(kind=RKIND),dimension(:,:),pointer :: theta_m + real(kind=RKIND),dimension(:,:,:),pointer:: scalars, tend_scalars + real(kind=RKIND),dimension(:,:),pointer:: rho_zz + real(kind=RKIND),dimension(:,:),pointer:: rho_edge + real (kind=RKIND), dimension(:,:), pointer :: tend_th ! tendency for potential temperature + character(len=StrKIND),pointer:: fdda_scheme + logical,pointer:: fdda_t, fdda_t_in_pbl + logical,pointer:: fdda_q, fdda_q_in_pbl + logical,pointer:: fdda_uv,fdda_uv_in_pbl + logical,pointer:: config_do_restart + + !local variables: + real(kind=RKIND) :: tfrac + real(kind=RKIND) :: t_target,q_target,u_target,v_target + real(kind=RKIND) :: sfac + real(kind=RKIND) :: theta_p + real(kind=RKIND) :: srange,dcEdge_m + + integer :: i,k + + logical :: first_call = .true. + + !local parameters: + + !================================================================================================== + + call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) + call mpas_pool_get_config(configs,'config_dt' ,config_dt ) + call mpas_pool_get_config(configs,'config_fdda_scheme', fdda_scheme) + call mpas_pool_get_config(configs,'config_fdda_int',fdda_int) + call mpas_pool_get_config(configs,'config_fdda_t',fdda_t) + call mpas_pool_get_config(configs,'config_fdda_q',fdda_q) + call mpas_pool_get_config(configs,'config_fdda_uv',fdda_uv) + call mpas_pool_get_config(configs,'config_fdda_t_in_pbl',fdda_t_in_pbl) + call mpas_pool_get_config(configs,'config_fdda_q_in_pbl',fdda_q_in_pbl) + call mpas_pool_get_config(configs,'config_fdda_uv_in_pbl',fdda_uv_in_pbl) + call mpas_pool_get_config(configs,'config_fdda_t_min_layer',fdda_t_min_layer) + call mpas_pool_get_config(configs,'config_fdda_q_min_layer',fdda_q_min_layer) + call mpas_pool_get_config(configs,'config_fdda_uv_min_layer',fdda_uv_min_layer) + call mpas_pool_get_config(configs,'config_fdda_t_coef',fdda_t_coef) + call mpas_pool_get_config(configs,'config_fdda_q_coef',fdda_q_coef) + call mpas_pool_get_config(configs,'config_fdda_uv_coef',fdda_uv_coef) + call mpas_pool_get_config(configs,'config_fdda_scale_min',fdda_scale_min) + call mpas_pool_get_config(configs,'config_fdda_scale_max',fdda_scale_max) + call mpas_pool_get_config(configs,'config_len_disp' ,len_disp) + + call mpas_pool_get_array(mesh,'meshDensity',meshDensity) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(fdda,'qv_fdda_old',qv_fdda_old) + call mpas_pool_get_array(fdda,'th_fdda_old',th_fdda_old) + call mpas_pool_get_array(fdda,'u_fdda_old', u_fdda_old ) + call mpas_pool_get_array(fdda,'v_fdda_old', v_fdda_old ) + call mpas_pool_get_array(fdda,'qv_fdda_new',qv_fdda_new) + call mpas_pool_get_array(fdda,'th_fdda_new',th_fdda_new) + call mpas_pool_get_array(fdda,'u_fdda_new', u_fdda_new ) + call mpas_pool_get_array(fdda,'v_fdda_new', v_fdda_new ) + call mpas_pool_get_array(tend_physics,'rthfddaten',rthfddaten) + call mpas_pool_get_array(tend_physics,'rqvfddaten',rqvfddaten) + call mpas_pool_get_array(tend_physics,'rufddaten_Edge' ,rufddaten_Edge ) + call mpas_pool_get_array(tend_physics,'rufddaten' ,rufddaten ) + call mpas_pool_get_array(tend_physics,'rvfddaten' ,rvfddaten ) + call mpas_pool_get_array(diag_physics,'kpbl',kpbl) + call mpas_pool_get_array(diag,'uReconstructZonal' ,u) + call mpas_pool_get_array(diag,'uReconstructMeridional',v) + call mpas_pool_get_array(tend,'scalars_tend' , tend_scalars ) + + call mpas_pool_get_dimension(state,'index_qv',index_qv) + call mpas_pool_get_array(state,'scalars',scalars,time_lev) + qv => scalars(index_qv,:,:) + call mpas_pool_get_array(state,'theta_m',theta_m,time_lev) + + call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) + call mpas_pool_get_array(diag , 'rho_edge', rho_edge) + + allocate(tend_th(nVertLevels,nCellsSolve)) + + !check to see if 'old' FDDA target values need to be defined from initial conditions + if(first_call .and. .not. config_do_restart) then + qv_fdda_old = qv + th_fdda_old = theta_m / (1._RKIND + rvord * qv) + u_fdda_old = u + v_fdda_old = v + first_call = .false. + endif + + !calculate time fraction within FDDA target data interval + tfrac = mod(xtime_s,fdda_int)/fdda_int + call mpas_log_write('inside FDDA: tfrac = $r', realArgs=(/tfrac/)) + + fdda_select: select case(fdda_scheme) + + case ("scaled") + + srange = fdda_scale_max-fdda_scale_min + + DO i=1, nCellsSolve + + dcEdge_m = len_disp / meshDensity(i)**0.25_RKIND + + if (dcEdge_m .lt. fdda_scale_max) then + if (dcEdge_m .lt. fdda_scale_min) then + sfac = 0.0_RKIND + else + sfac = (dcEdge_m-fdda_scale_min)/srange + endif + else + sfac = 1.0_RKIND + endif + + DO k=1,nVertLevels + + theta_p = theta_m(k,i) / (1._RKIND + rvord * qv(k,i)) + + if (fdda_t .and. k.gt.fdda_t_min_layer .and. (fdda_t_in_pbl .or. k.gt.kpbl(i))) then + t_target = (1.0_RKIND-tfrac)*th_fdda_old(k,i)+tfrac*th_fdda_new(k,i) + rthfddaten(k,i) = fdda_t_coef * ( t_target - theta_p ) * sfac + + else + rthfddaten(k,i) = 0._RKIND + endif + + if (fdda_q .and. k.gt.fdda_q_min_layer .and. (fdda_q_in_pbl .or. k.gt.kpbl(i))) then + q_target = (1.0_RKIND-tfrac)*qv_fdda_old(k,i)+tfrac*qv_fdda_new(k,i) + rqvfddaten(k,i) = fdda_q_coef * ( q_target - qv(k,i) ) * sfac + else + rqvfddaten(k,i) = 0._RKIND + endif + + if (fdda_uv .and. k.gt.fdda_uv_min_layer .and. (fdda_uv_in_pbl .or. k.gt.kpbl(i))) then + u_target = (1.0_RKIND-tfrac)*u_fdda_old(k,i)+tfrac*u_fdda_new(k,i) + rufddaten(k,i) = fdda_uv_coef * ( u_target - u(k,i) ) * sfac + v_target = (1.0_RKIND-tfrac)*v_fdda_old(k,i)+tfrac*v_fdda_new(k,i) + rvfddaten(k,i) = fdda_uv_coef * ( v_target - v(k,i) ) * sfac + else + rufddaten(k,i) = 0._RKIND + rvfddaten(k,i) = 0._RKIND + endif + + ENDDO + ENDDO + + case("analysis") + + DO i = 1, nCellsSolve + DO k = 1, nVertLevels + + theta_p = theta_m(k,i) / (1._RKIND + rvord * qv(k,i)) + + if (fdda_t .and. k.gt.fdda_t_min_layer .and. (fdda_t_in_pbl .or. k.gt.kpbl(i))) then + t_target = (1.0_RKIND-tfrac)*th_fdda_old(k,i)+tfrac*th_fdda_new(k,i) + rthfddaten(k,i) = fdda_t_coef * ( t_target - theta_p ) + else + rthfddaten(k,i) = 0._RKIND + endif + + if (fdda_q .and. k.gt.fdda_q_min_layer .and. (fdda_q_in_pbl .or. k.gt.kpbl(i))) then + q_target = (1.0_RKIND-tfrac)*qv_fdda_old(k,i)+tfrac*qv_fdda_new(k,i) + rqvfddaten(k,i) = fdda_q_coef * ( q_target - qv(k,i) ) + else + rqvfddaten(k,i) = 0._RKIND + endif + + if (fdda_uv .and. k.gt.fdda_uv_min_layer .and. (fdda_uv_in_pbl .or. k.gt.kpbl(i))) then + u_target = (1.0_RKIND-tfrac)*u_fdda_old(k,i)+tfrac*u_fdda_new(k,i) + rufddaten(k,i) = fdda_uv_coef * ( u_target - u(k,i) ) + v_target = (1.0_RKIND-tfrac)*v_fdda_old(k,i)+tfrac*v_fdda_new(k,i) + rvfddaten(k,i) = fdda_uv_coef * ( v_target - v(k,i) ) + else + rufddaten(k,i) = 0._RKIND + rvfddaten(k,i) = 0._RKIND + endif + + ENDDO + ENDDO + + case default + + end select fdda_select + + + ! MW: add transformation of the u,v wind nudging tendencies to those for horizontal normal velocity at the edge + rufddaten_Edge(:,:) = 0.0_RKIND + call tend_toEdges(block, mesh, rufddaten, rvfddaten, rufddaten_Edge) + + ! MW: add coupled tendencies for u on edges + do i = 1, nEdgesSolve + do k = 1, nVertLevels + tend_ru(k,i)=tend_ru(k,i)+rufddaten_Edge(k,i)*rho_edge(k,i) + enddo + enddo + call mpas_log_write('fdda: min/max rufddaten = $r, $r', realArgs=(/minval(rufddaten), maxval(rufddaten)/) ) + call mpas_log_write('fdda: min/max rvfddaten = $r, $r', realArgs=(/minval(rvfddaten), maxval(rvfddaten)/) ) + call mpas_log_write('fdda: min/max rufddaten_Edge = $r, $r', realArgs=(/minval(rufddaten_Edge), maxval(rufddaten_Edge)/) ) + + ! MW: add coupled tendencies for other variables at cell centers + tend_th = 0.0_RKIND + do i = 1, nCellsSolve + do k = 1, nVertLevels + tend_th(k,i) = tend_th(k,i) + rthfddaten(k,i)*rho_zz(k,i) + tend_scalars(index_qv,k,i) = tend_scalars(index_qv,k,i) + rqvfddaten(k,i)*rho_zz(k,i) + enddo + enddo + call mpas_log_write('fdda: min/max rthfddaten = $r, $r', realArgs=(/minval(rthfddaten), maxval(rthfddaten)/) ) + call mpas_log_write('fdda: min/max rqvfddaten = $r, $r', realArgs=(/minval(rqvfddaten), maxval(rqvfddaten)/) ) + + + ! if non-hydrostatic core, convert the tendency for the potential temperature to a + ! tendency for the modified potential temperature + do i = 1, nCellsSolve + do k = 1,nVertLevels + tend_th(k,i) = (1. + rvord * scalars(index_qv,k,i)) * tend_th(k,i) & + + rvord * theta_m(k,i) * rqvfddaten(k,i)*rho_zz(k,i) + tend_rtheta(k,i) = tend_rtheta(k,i) + tend_th(k,i) + end do + end do + + !check to see if this is the last time step within the current FDDA target data interval and + !if so, save the current "new" targets as the "old" targets for the next time step + if(mod(xtime_s+config_dt,fdda_int)/fdda_int .lt. tfrac) then + th_fdda_old = th_fdda_new + qv_fdda_old = qv_fdda_new + u_fdda_old = u_fdda_new + v_fdda_old = v_fdda_new + endif + + deallocate(tend_th) + + end subroutine apply_fdda + +!================================================================================================== + end module mpas_atm_fdda +!================================================================================================== diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 4fe2faefc4..b37e28a08a 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_fdda ! ! Abstract interface for routine used to communicate halos of fields @@ -859,6 +860,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) integer :: nCells, nEdges, nVertices, nEdgesSolve, nVertLevels, num_scalars character(len=StrKIND), pointer :: config_IAU_option + character(len=StrKIND), pointer :: config_fdda_scheme type (mpas_pool_type), pointer :: state type (mpas_pool_type), pointer :: diag @@ -867,6 +869,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) type (mpas_pool_type), pointer :: tend type (mpas_pool_type), pointer :: tend_physics => null() type (mpas_pool_type), pointer :: lbc ! regional_MPAS addition + type (mpas_pool_type), pointer :: fdda real (kind=RKIND), dimension(:,:), pointer :: w real (kind=RKIND), dimension(:,:), pointer :: u, uReconstructZonal, uReconstructMeridional, uReconstructX, uReconstructY, uReconstructZ @@ -901,6 +904,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_pool_get_config(block % configs, 'config_microp_scheme', config_microp_scheme) call mpas_pool_get_config(block % configs, 'config_convection_scheme', config_convection_scheme) #endif + call mpas_pool_get_config(block % configs, 'config_fdda_scheme', config_fdda_scheme) ! ! Retrieve field structures @@ -913,6 +917,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) #ifdef DO_PHYSICS call mpas_pool_get_subpool(block % structs, 'diag_physics', diag_physics) #endif + call mpas_pool_get_subpool(block % structs, 'fdda', fdda) ! ! Retrieve dimensions @@ -1102,6 +1107,16 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) tend_ru_physics, tend_rtheta_physics, tend_rho_physics) end if + ! + ! FDDA - Four-dimensional data assimilation (Grid point nudging) + ! + ! MW: Why are tend_ru_physics and tend_rtheta_physics global variables, but not tend_scalars? + if (trim(config_fdda_scheme) /= 'off') then + call apply_fdda( block, xtime_s, block % configs, mesh, state, 1, fdda, diag, diag_physics, tend, tend_physics, & + tend_ru_physics, tend_rtheta_physics) + end if + + DYNAMICS_SUBSTEPS : do dynamics_substep = 1, dynamics_split diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index d4f80f083c..75eec25931 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -24,7 +24,6 @@ OBJS = \ mpas_atmphys_driver.o \ mpas_atmphys_driver_cloudiness.o \ mpas_atmphys_driver_convection.o \ - mpas_atmphys_fdda.o \ mpas_atmphys_driver_gwdo.o \ mpas_atmphys_driver_lsm.o \ mpas_atmphys_driver_lsm_noahmp.o \ @@ -97,7 +96,6 @@ mpas_atmphys_control.o: \ mpas_atmphys_driver.o: \ mpas_atmphys_driver_cloudiness.o \ mpas_atmphys_driver_convection.o \ - mpas_atmphys_fdda.o \ mpas_atmphys_driver_gwdo.o \ mpas_atmphys_driver_lsm.o \ mpas_atmphys_driver_lsm_noahmp.o \ @@ -122,11 +120,6 @@ mpas_atmphys_driver_convection.o: \ mpas_atmphys_utilities.o \ mpas_atmphys_vars.o -mpas_atmphys_fdda.o: \ - mpas_atmphys_constants.o \ - mpas_atmphys_utilities.o \ - mpas_atmphys_vars.o - mpas_atmphys_driver_gwdo.o: \ mpas_atmphys_vars.o \ mpas_atmphys_manager.o diff --git a/src/core_atmosphere/physics/mpas_atmphys_control.F b/src/core_atmosphere/physics/mpas_atmphys_control.F index 858ed8b7ef..b3162019e5 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_control.F +++ b/src/core_atmosphere/physics/mpas_atmphys_control.F @@ -49,8 +49,6 @@ module mpas_atmphys_control ! Laura D. Fowler (laura@ucar.edu) / 2014-09-18. ! * renamed "wsm6" to "mp_wsm6" and "kessler" to "mp_kessler". ! Laura D. Fowler (laura@ucar.edu) / 2016-03-09. -! * added four-dimensional data assimilation scheme (based on WRF FDDA scheme). -! O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-03-21. ! * renamed "kain_fritsch" to "cu_kain_fritsch" and "tiedtke" to "cu_tiedtke". ! Laura D. Fowler (laura@ucar.edu) / 2016-03-22. ! * renamed "ysu" to "bl_ysu", "ysu_gwdo" to "bl_gwdo_ysu", and "monin_obukhov" to "sf_monin_obukhov". @@ -107,8 +105,7 @@ subroutine physics_namelist_check(configs) config_radt_cld_scheme, & config_radt_lw_scheme, & config_radt_sw_scheme, & - config_sfclayer_scheme, & - config_fdda_scheme + config_sfclayer_scheme !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') @@ -124,7 +121,6 @@ subroutine physics_namelist_check(configs) call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) call mpas_pool_get_config(configs,'config_sfclayer_scheme' ,config_sfclayer_scheme ) - call mpas_pool_get_config(configs,'config_fdda_scheme' ,config_fdda_scheme ) call mpas_log_write('') call mpas_log_write('----- Setting up physics suite '''//trim(config_physics_suite)//''' -----') @@ -143,7 +139,6 @@ subroutine physics_namelist_check(configs) if (trim(config_radt_cld_scheme) == 'suite') config_radt_cld_scheme = 'cld_fraction' if (trim(config_sfclayer_scheme) == 'suite') config_sfclayer_scheme = 'sf_monin_obukhov_rev' if (trim(config_lsm_scheme) == 'suite') config_lsm_scheme = 'sf_noah' - if (trim(config_fdda_scheme) == 'suite') config_fdda_scheme = 'off' else if (trim(config_physics_suite) == 'convection_permitting') then @@ -156,7 +151,6 @@ subroutine physics_namelist_check(configs) if (trim(config_radt_cld_scheme) == 'suite') config_radt_cld_scheme = 'cld_fraction' if (trim(config_sfclayer_scheme) == 'suite') config_sfclayer_scheme = 'sf_mynn' if (trim(config_lsm_scheme) == 'suite') config_lsm_scheme = 'sf_noah' - if (trim(config_fdda_scheme) == 'suite') config_fdda_scheme = 'off' else if (trim(config_physics_suite) == 'none') then @@ -169,7 +163,6 @@ subroutine physics_namelist_check(configs) if (trim(config_radt_cld_scheme) == 'suite') config_radt_cld_scheme = 'off' if (trim(config_sfclayer_scheme) == 'suite') config_sfclayer_scheme = 'off' if (trim(config_lsm_scheme) == 'suite') config_lsm_scheme = 'off' - if (trim(config_fdda_scheme) == 'suite') config_fdda_scheme = 'off' else @@ -179,17 +172,6 @@ subroutine physics_namelist_check(configs) end if -!fdda scheme: - if(.not. (config_fdda_scheme .eq. 'off' .or. & - config_fdda_scheme .eq. 'analysis' .or. & - config_fdda_scheme .eq. 'scaled' )) then - - write(mpas_err_message,'(A,A10)') 'illegal value for config_fdda_scheme:', & - trim(config_fdda_scheme) - call physics_error_fatal(mpas_err_message) - - endif - !cloud microphysics scheme: if(.not. (config_microp_scheme .eq. 'off' .or. & config_microp_scheme .eq. 'mp_kessler' .or. & @@ -345,7 +327,6 @@ subroutine physics_namelist_check(configs) call mpas_log_write(' config_radt_sw_scheme = '//trim(config_radt_sw_scheme)) call mpas_log_write(' config_sfclayer_scheme = '//trim(config_sfclayer_scheme)) call mpas_log_write(' config_lsm_scheme = '//trim(config_lsm_scheme)) - call mpas_log_write(' config_fdda_scheme = '//trim(config_fdda_scheme)) call mpas_log_write('') end subroutine physics_namelist_check diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index 63f6b5c985..6d7bbf8582 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -21,7 +21,6 @@ module mpas_atmphys_driver use mpas_atmphys_driver_seaice,only: allocate_seaice,deallocate_seaice,driver_seaice use mpas_atmphys_driver_sfclayer use mpas_atmphys_driver_oml - use mpas_atmphys_fdda use mpas_atmphys_constants use mpas_atmphys_interface use mpas_atmphys_sfc_diagnostics,only: atmphys_sfc_diagnostics @@ -72,7 +71,6 @@ module mpas_atmphys_driver ! driver_radiation_sw : driver for short wave radiation schemes. ! driver_radiation_lw : driver for long wave radiation schemes. ! driver_sfclayer : driver for surface layer scheme. -! apply_fdda : applies four-dimensional data assimilation. ! update_convection_step1 : updates lifetime of deep convective clouds in Kain-Fritsch scheme. ! update_convection_step2 : updates accumulated precipitation output from convection schemes. ! update_radiation_diagnostics: updates accumualted radiation diagnostics from radiation schemes. @@ -124,7 +122,6 @@ subroutine physics_driver(domain,itimestep,xtime_s) type(mpas_pool_type),pointer:: configs, & mesh, & state, & - fdda, & diag, & diag_physics, & diag_physics_noahmp, & @@ -138,7 +135,6 @@ subroutine physics_driver(domain,itimestep,xtime_s) character(len=StrKIND),pointer:: config_bucket_update, & config_convection_scheme, & - config_fdda_scheme, & config_gwdo_scheme, & config_lsm_scheme, & config_pbl_scheme, & @@ -165,7 +161,6 @@ subroutine physics_driver(domain,itimestep,xtime_s) call mpas_timer_start('physics driver') call mpas_pool_get_config(domain%configs,'config_convection_scheme',config_convection_scheme) - call mpas_pool_get_config(domain%configs,'config_fdda_scheme' ,config_fdda_scheme ) call mpas_pool_get_config(domain%configs,'config_gwdo_scheme' ,config_gwdo_scheme ) call mpas_pool_get_config(domain%configs,'config_lsm_scheme' ,config_lsm_scheme ) call mpas_pool_get_config(domain%configs,'config_pbl_scheme' ,config_pbl_scheme ) @@ -182,8 +177,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) config_pbl_scheme .ne. 'off' .or. & config_radt_lw_scheme .ne. 'off' .or. & config_radt_sw_scheme .ne. 'off' .or. & - config_sfclayer_scheme .ne. 'off' .or. & - config_fdda_scheme .ne. 'off') then + config_sfclayer_scheme .ne. 'off') then block => domain % blocklist do while(associated(block)) @@ -191,7 +185,6 @@ subroutine physics_driver(domain,itimestep,xtime_s) call mpas_pool_get_subpool(block%structs,'mesh' ,mesh ) call mpas_pool_get_subpool(block%structs,'state' ,state ) call mpas_pool_get_subpool(block%structs,'diag' ,diag ) - call mpas_pool_get_subpool(block%structs,'fdda' ,fdda ) 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,'output_noahmp' ,output_noahmp ) @@ -375,17 +368,6 @@ subroutine physics_driver(domain,itimestep,xtime_s) !$OMP END PARALLEL DO end if - !call to FDDA scheme within MPAS physics (not WRF physics) - if(config_fdda_scheme .ne. 'off') then - time_lev = 1 -!$OMP PARALLEL DO - do thread=1,nThreads - call apply_fdda(xtime_s,block%configs,mesh,state,time_lev,fdda,diag,diag_physics,tend_physics, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) - end do -!$OMP END PARALLEL DO - endif - !deallocate arrays shared by all physics parameterizations: call deallocate_forall_physics(block%configs) diff --git a/src/core_atmosphere/physics/mpas_atmphys_fdda.F b/src/core_atmosphere/physics/mpas_atmphys_fdda.F deleted file mode 100644 index ee7b966c9f..0000000000 --- a/src/core_atmosphere/physics/mpas_atmphys_fdda.F +++ /dev/null @@ -1,254 +0,0 @@ -!================================================================================================== - module mpas_atmphys_fdda - use mpas_kind_types - use mpas_derived_types - use mpas_pool_routines - - use mpas_atmphys_constants - use mpas_atmphys_utilities - use mpas_atmphys_vars - - implicit none - private - public:: apply_fdda - - integer, private:: i,k - - -!MPAS grid nudging. -!O. Russell Bullock Jr. (send comments to bullock.russell@epa.gov). -!2016-03-30. -! -! subroutines in mpas_atmphys_fdda: -! ---------------------------------------------- -! apply_fdda : main fdda subroutine (called from subroutine physics_driver). -! - -! add-ons and modifications to sourcecode: -! ---------------------------------------- -! Original sourcecode by O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-03-30. -! -! * Added various controls for length-scaled FDDA application -! O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-08-11. -! * Modified to only require reads of "fdda_new" data arrays. "fdda_old" is initially -! set to initial conditions. At end of FDDA data interval, "fdda_old" is set to -! "fdda_new" and updated "fdda_new" data comes from FDDA input stream. -! O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-08-30. - - contains - -!================================================================================================== - subroutine apply_fdda(xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_physics,tend_physics, & - its,ite) -!================================================================================================== - -!input variables: - type(mpas_pool_type),intent(in):: configs - type(mpas_pool_type),intent(in):: mesh - type(mpas_pool_type),intent(in):: state - type(mpas_pool_type),intent(in):: fdda - type(mpas_pool_type),intent(in):: diag - type(mpas_pool_type),intent(in):: diag_physics - integer,intent(in):: its,ite - integer,intent(in):: time_lev - real(kind=RKIND),intent(in):: xtime_s - -!inout variables: - type(mpas_pool_type),intent(inout):: tend_physics - -!local pointers: - integer,pointer:: index_qv,fdda_t_min_layer,fdda_q_min_layer,fdda_uv_min_layer - integer,dimension(:),pointer :: kpbl - real(kind=RKIND),pointer:: fdda_t_coef,fdda_q_coef,fdda_uv_coef - real(kind=RKIND),pointer:: fdda_int,fdda_scale_min,fdda_scale_max - real(kind=RKIND),pointer:: config_dt - real(kind=RKIND),pointer:: len_disp - real(kind=RKIND),dimension(:),pointer :: meshDensity - real(kind=RKIND),dimension(:,:),pointer :: rthfddaten,rqvfddaten - real(kind=RKIND),dimension(:,:),pointer :: rufddaten,rvfddaten - real(kind=RKIND),dimension(:,:),pointer :: qv_fdda_old,th_fdda_old,u_fdda_old,v_fdda_old - real(kind=RKIND),dimension(:,:),pointer :: qv_fdda_new,th_fdda_new,u_fdda_new,v_fdda_new - real(kind=RKIND),dimension(:,:),pointer :: u,v - real(kind=RKIND),dimension(:,:),pointer :: qv - real(kind=RKIND),dimension(:,:),pointer :: theta_m - real(kind=RKIND),dimension(:,:,:),pointer:: scalars - character(len=StrKIND),pointer:: fdda_scheme - logical,pointer:: fdda_t, fdda_t_in_pbl - logical,pointer:: fdda_q, fdda_q_in_pbl - logical,pointer:: fdda_uv,fdda_uv_in_pbl - logical,pointer:: config_do_restart - -!local variables: - real(kind=RKIND) :: tfrac - real(kind=RKIND) :: t_target,q_target,u_target,v_target - real(kind=RKIND) :: sfac - real(kind=RKIND) :: theta_p - real(kind=RKIND) :: srange,dcEdge_m - - integer :: i,k - - logical :: first_call = .true. - -!local parameters: - real(kind=RKIND),parameter:: rvrd = R_v/R_d - -!================================================================================================== - - call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) - call mpas_pool_get_config(configs,'config_dt' ,config_dt ) - call mpas_pool_get_config(configs,'config_fdda_scheme', fdda_scheme) - call mpas_pool_get_config(configs,'config_fdda_int',fdda_int) - call mpas_pool_get_config(configs,'config_fdda_t',fdda_t) - call mpas_pool_get_config(configs,'config_fdda_q',fdda_q) - call mpas_pool_get_config(configs,'config_fdda_uv',fdda_uv) - call mpas_pool_get_config(configs,'config_fdda_t_in_pbl',fdda_t_in_pbl) - call mpas_pool_get_config(configs,'config_fdda_q_in_pbl',fdda_q_in_pbl) - call mpas_pool_get_config(configs,'config_fdda_uv_in_pbl',fdda_uv_in_pbl) - call mpas_pool_get_config(configs,'config_fdda_t_min_layer',fdda_t_min_layer) - call mpas_pool_get_config(configs,'config_fdda_q_min_layer',fdda_q_min_layer) - call mpas_pool_get_config(configs,'config_fdda_uv_min_layer',fdda_uv_min_layer) - call mpas_pool_get_config(configs,'config_fdda_t_coef',fdda_t_coef) - call mpas_pool_get_config(configs,'config_fdda_q_coef',fdda_q_coef) - call mpas_pool_get_config(configs,'config_fdda_uv_coef',fdda_uv_coef) - call mpas_pool_get_config(configs,'config_fdda_scale_min',fdda_scale_min) - call mpas_pool_get_config(configs,'config_fdda_scale_max',fdda_scale_max) - call mpas_pool_get_config(configs,'config_len_disp' ,len_disp) - - call mpas_pool_get_array(mesh,'meshDensity',meshDensity) - - call mpas_pool_get_array(fdda,'qv_fdda_old',qv_fdda_old) - call mpas_pool_get_array(fdda,'th_fdda_old',th_fdda_old) - call mpas_pool_get_array(fdda,'u_fdda_old', u_fdda_old ) - call mpas_pool_get_array(fdda,'v_fdda_old', v_fdda_old ) - call mpas_pool_get_array(fdda,'qv_fdda_new',qv_fdda_new) - call mpas_pool_get_array(fdda,'th_fdda_new',th_fdda_new) - call mpas_pool_get_array(fdda,'u_fdda_new', u_fdda_new ) - call mpas_pool_get_array(fdda,'v_fdda_new', v_fdda_new ) - call mpas_pool_get_array(tend_physics,'rthfddaten',rthfddaten) - call mpas_pool_get_array(tend_physics,'rqvfddaten',rqvfddaten) - call mpas_pool_get_array(tend_physics,'rufddaten' ,rufddaten ) - call mpas_pool_get_array(tend_physics,'rvfddaten' ,rvfddaten ) - call mpas_pool_get_array(diag_physics,'kpbl',kpbl) - call mpas_pool_get_array(diag,'uReconstructZonal' ,u) - call mpas_pool_get_array(diag,'uReconstructMeridional',v) - - call mpas_pool_get_dimension(state,'index_qv',index_qv) - call mpas_pool_get_array(state,'scalars',scalars,time_lev) - qv => scalars(index_qv,:,:) - call mpas_pool_get_array(state,'theta_m',theta_m,time_lev) - -!check to see if 'old' FDDA target values need to be defined from initial conditions - if(first_call .and. .not. config_do_restart) then - qv_fdda_old = qv - th_fdda_old = theta_m / (1._RKIND + rvrd * qv) - u_fdda_old = u - v_fdda_old = v - first_call = .false. - endif - -!calculate time fraction within FDDA target data interval - tfrac = mod(xtime_s,fdda_int)/fdda_int - - fdda_select: select case(fdda_scheme) - - case ("scaled") - - srange = fdda_scale_max-fdda_scale_min - - DO i=its,ite - - dcEdge_m = len_disp / meshDensity(i)**0.25 - - if (dcEdge_m .lt. fdda_scale_max) then - if (dcEdge_m .lt. fdda_scale_min) then - sfac = 0.0 - else - sfac = (dcEdge_m-fdda_scale_min)/srange - endif - else - sfac = 1.0 - endif - - DO k=kts,kte - - theta_p = theta_m(k,i) / (1._RKIND + rvrd * qv(k,i)) - - if (fdda_t .and. k.gt.fdda_t_min_layer .and. (fdda_t_in_pbl .or. k.gt.kpbl(i))) then - t_target = (1.0-tfrac)*th_fdda_old(k,i)+tfrac*th_fdda_new(k,i) - rthfddaten(k,i) = fdda_t_coef * ( t_target - theta_p ) * sfac - else - rthfddaten(k,i) = 0. - endif - - if (fdda_q .and. k.gt.fdda_q_min_layer .and. (fdda_q_in_pbl .or. k.gt.kpbl(i))) then - q_target = (1.0-tfrac)*qv_fdda_old(k,i)+tfrac*qv_fdda_new(k,i) - rqvfddaten(k,i) = fdda_q_coef * ( q_target - qv(k,i) ) * sfac - else - rqvfddaten(k,i) = 0. - endif - - if (fdda_uv .and. k.gt.fdda_uv_min_layer .and. (fdda_uv_in_pbl .or. k.gt.kpbl(i))) then - u_target = (1.0-tfrac)*u_fdda_old(k,i)+tfrac*u_fdda_new(k,i) - rufddaten(k,i) = fdda_uv_coef * ( u_target - u(k,i) ) * sfac - v_target = (1.0-tfrac)*v_fdda_old(k,i)+tfrac*v_fdda_new(k,i) - rvfddaten(k,i) = fdda_uv_coef * ( v_target - v(k,i) ) * sfac - else - rufddaten(k,i) = 0. - rvfddaten(k,i) = 0. - endif - - ENDDO - ENDDO - - case("analysis") - - DO i=its,ite - DO k=kts,kte - - theta_p = theta_m(k,i) / (1._RKIND + rvrd * qv(k,i)) - - if (fdda_t .and. k.gt.fdda_t_min_layer .and. (fdda_t_in_pbl .or. k.gt.kpbl(i))) then - t_target = (1.0-tfrac)*th_fdda_old(k,i)+tfrac*th_fdda_new(k,i) - rthfddaten(k,i) = fdda_t_coef * ( t_target - theta_p ) - else - rthfddaten(k,i) = 0. - endif - - if (fdda_q .and. k.gt.fdda_q_min_layer .and. (fdda_q_in_pbl .or. k.gt.kpbl(i))) then - q_target = (1.0-tfrac)*qv_fdda_old(k,i)+tfrac*qv_fdda_new(k,i) - rqvfddaten(k,i) = fdda_q_coef * ( q_target - qv(k,i) ) - else - rqvfddaten(k,i) = 0. - endif - - if (fdda_uv .and. k.gt.fdda_uv_min_layer .and. (fdda_uv_in_pbl .or. k.gt.kpbl(i))) then - u_target = (1.0-tfrac)*u_fdda_old(k,i)+tfrac*u_fdda_new(k,i) - rufddaten(k,i) = fdda_uv_coef * ( u_target - u(k,i) ) - v_target = (1.0-tfrac)*v_fdda_old(k,i)+tfrac*v_fdda_new(k,i) - rvfddaten(k,i) = fdda_uv_coef * ( v_target - v(k,i) ) - else - rufddaten(k,i) = 0. - rvfddaten(k,i) = 0. - endif - - ENDDO - ENDDO - - case default - - end select fdda_select - -!check to see if this is the last time step within the current FDDA target data interval and -!if so, save the current "new" targets as the "old" targets for the next time step - if(mod(xtime_s+config_dt,fdda_int)/fdda_int .lt. tfrac) then - th_fdda_old = th_fdda_new - qv_fdda_old = qv_fdda_new - u_fdda_old = u_fdda_new - v_fdda_old = v_fdda_new - endif - - end subroutine apply_fdda - -!================================================================================================== - end module mpas_atmphys_fdda -!================================================================================================== diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index f0b94f656f..2057148725 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -390,8 +390,7 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) config_lsm_scheme, & config_microp_scheme, & config_radt_lw_scheme, & - config_radt_sw_scheme, & - config_fdda_scheme + config_radt_sw_scheme character(len=StrKIND),pointer:: config_conv_interval, & config_pbl_interval, & @@ -428,7 +427,6 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) call mpas_pool_get_config(configs,'config_microp_scheme' ,config_microp_scheme ) call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) - call mpas_pool_get_config(configs,'config_fdda_scheme' ,config_fdda_scheme ) call mpas_pool_get_config(configs,'config_conv_interval' ,config_conv_interval ) call mpas_pool_get_config(configs,'config_pbl_interval' ,config_pbl_interval ) diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index df26521033..3163ceb9a1 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -16,7 +16,7 @@ module mpas_atmphys_todynamics implicit none private - public:: physics_get_tend + public:: physics_get_tend, tend_toEdges !Interface between the physics parameterizations and the non-hydrostatic dynamical core. @@ -87,8 +87,7 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s convection_scheme, & microp_scheme, & radt_lw_scheme, & - radt_sw_scheme, & - fdda_scheme + radt_sw_scheme integer:: i,iCell,k,n integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs @@ -106,14 +105,12 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s real(kind=RKIND),dimension(:,:),pointer:: rthcuten,rqvcuten,rqccuten, & rqrcuten,rqicuten,rqscuten, & rucuten,rvcuten - real(kind=RKIND),dimension(:,:),pointer:: rthfddaten,rqvfddaten,rufddaten,rvfddaten real(kind=RKIND),dimension(:,:),pointer:: rthratenlw,rthratensw real(kind=RKIND),dimension(:,:),pointer:: tend_u_phys !nick real(kind=RKIND),dimension(:,:,:),pointer:: tend_scalars real(kind=RKIND),dimension(:,:),pointer:: rublten_Edge,rucuten_Edge - real(kind=RKIND),dimension(:,:),pointer:: rublten_Edge,rucuten_Edge,rufddaten_Edge real(kind=RKIND),dimension(:,:),allocatable:: tend_th @@ -129,7 +126,6 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s call mpas_pool_get_config(configs,'config_pbl_scheme' ,pbl_scheme ) call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,radt_lw_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,radt_sw_scheme ) - call mpas_pool_get_config(configs,'config_fdda_scheme' ,fdda_scheme ) call mpas_pool_get_array(state,'theta_m' ,theta_m,1) call mpas_pool_get_array(state,'scalars' ,scalars,1) @@ -173,12 +169,6 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s call mpas_pool_get_array(tend_physics,'rthratenlw',rthratenlw) call mpas_pool_get_array(tend_physics,'rthratensw',rthratensw) - call mpas_pool_get_array(tend_physics,'rufddaten',rufddaten) - call mpas_pool_get_array(tend_physics,'rvfddaten',rvfddaten) - call mpas_pool_get_array(tend_physics,'rthfddaten',rthfddaten) - call mpas_pool_get_array(tend_physics,'rqvfddaten',rqvfddaten) - call mpas_pool_get_array(tend_physics,'rufddaten_Edge',rufddaten_Edge) - call mpas_pool_get_array(tend,'scalars_tend',tend_scalars) @@ -215,15 +205,9 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s if(.not. associated(rnifablten)) allocate(rnifablten(0,0)) if(.not. associated(rnwfablten)) allocate(rnwfablten(0,0)) - if(.not. associated(rufddaten)) allocate(rufddaten(0,0)) - if(.not. associated(rvfddaten)) allocate(rvfddaten(0,0)) - if(.not. associated(rthfddaten)) allocate(rthfddaten(0,0)) - if(.not. associated(rqvfddaten)) allocate(rqvfddaten(0,0)) - call physics_get_tend_work( & block,mesh,nCells,nEdges,nCellsSolve,nEdgesSolve,rk_step,dynamics_substep, & pbl_scheme,convection_scheme,microp_scheme,radt_lw_scheme,radt_sw_scheme, & - fdda_scheme, & index_qv,index_qc,index_qr,index_qi,index_qs, & index_nc,index_ni,index_nifa,index_nwfa, & mass,mass_edge,theta_m,scalars, & @@ -231,7 +215,6 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s rncblten,rniblten,rnifablten,rnwfablten, & rucuten,rvcuten,rthcuten,rqvcuten,rqccuten,rqrcuten,rqicuten,rqscuten, & rthratenlw,rthratensw,rublten_Edge,rucuten_Edge, & - rufddaten,rvfddaten,rthfddaten,rqvfddaten,rufddaten_Edge, & tend_th,tend_rtheta_physics,tend_scalars,tend_ru_physics,tend_u_phys, & exchange_halo_group) @@ -257,10 +240,6 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s if(size(rnifablten) == 0) deallocate(rnifablten) if(size(rnwfablten) == 0) deallocate(rnwfablten) - if(size(rufddaten) == 0) deallocate(rufddaten) - if(size(rvfddaten) == 0) deallocate(rvfddaten) - if(size(rthfddaten) == 0) deallocate(rthfddaten) - if(size(rqvfddaten) == 0) deallocate(rqvfddaten) deallocate(tend_th) @@ -270,7 +249,6 @@ end subroutine physics_get_tend subroutine physics_get_tend_work( & block,mesh,nCells,nEdges,nCellsSolve,nEdgesSolve,rk_step,dynamics_substep, & pbl_scheme,convection_scheme,microp_scheme,radt_lw_scheme,radt_sw_scheme, & - fdda_scheme, & index_qv,index_qc,index_qr,index_qi,index_qs, & index_nc,index_ni,index_nifa,index_nwfa, & mass,mass_edge,theta_m,scalars, & @@ -278,7 +256,6 @@ subroutine physics_get_tend_work( & rncblten,rniblten,rnifablten,rnwfablten, & rucuten,rvcuten,rthcuten,rqvcuten,rqccuten,rqrcuten,rqicuten,rqscuten, & rthratenlw,rthratensw,rublten_Edge,rucuten_Edge, & - rufddaten,rvfddaten,rthfddaten,rqvfddaten,rufddaten_Edge, & tend_th,tend_theta,tend_scalars,tend_u,tend_u_phys, & exchange_halo_group) !================================================================================================================= @@ -294,7 +271,6 @@ subroutine physics_get_tend_work( & character(len=StrKIND),intent(in):: pbl_scheme character(len=StrKIND),intent(in):: radt_lw_scheme character(len=StrKIND),intent(in):: radt_sw_scheme - character(len=StrKIND),intent(in):: fdda_scheme integer,intent(in):: nCells,nEdges,nCellsSolve,nEdgesSolve integer,intent(in):: rk_step,dynamics_substep @@ -330,12 +306,6 @@ subroutine physics_get_tend_work( & real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rthratenlw real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rthratensw - real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rufddaten - real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rvfddaten - real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rthfddaten - real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqvfddaten - real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: rufddaten_Edge - !inout arguments: real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: rublten_Edge real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: rucuten_Edge @@ -459,25 +429,6 @@ subroutine physics_get_tend_work( & enddo endif -!add coupled tendencies due to four-dimensional data assimilation (fdda): - if(fdda_scheme .ne. 'off') then - - rufddaten_Edge(:,:) = 0. - call tend_toEdges(block,mesh,rufddaten,rvfddaten,rufddaten_Edge) - do i = 1, nEdgesSolve - do k = 1, nVertLevels - tend_u(k,i)=tend_u(k,i)+rufddaten_Edge(k,i)*mass_edge(k,i) - enddo - enddo - - do i = 1, nCellsSolve - do k = 1, nVertLevels - tend_th(k,i) = tend_th(k,i) + rthfddaten(k,i)*mass(k,i) - tend_scalars(index_qv,k,i) = tend_scalars(index_qv,k,i) + rqvfddaten(k,i)*mass(k,i) - enddo - enddo - endif - !convert the tendency for the potential temperature to tendency for the modified potential temperature: do i = 1, nCellsSolve From 8047f3cf150df34173e587dca0098c5ae15dccda Mon Sep 17 00:00:00 2001 From: May Wong Date: Wed, 30 Jul 2025 13:38:38 -0600 Subject: [PATCH 06/17] Moving FDDA tendency variables (rthfddaten, etc.) from the tend_physics variable structure to its own tend_fdda variable structure in the Registry. --- src/core_atmosphere/Registry.xml | 41 ++++--- src/core_atmosphere/dynamics/mpas_atm_fdda.F | 119 ++++++++++--------- 2 files changed, 88 insertions(+), 72 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 1528d5f447..63ebd8413a 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -2163,6 +2163,28 @@ #endif + + + + + + + + + + + + + + + + + @@ -3631,25 +3653,6 @@ description="tendency of water-friendly aerosol number concentration due to microphysics" packages="mp_thompson_aers_in"/> - - - - - - - - - - - - - - diff --git a/src/core_atmosphere/dynamics/mpas_atm_fdda.F b/src/core_atmosphere/dynamics/mpas_atm_fdda.F index bbf3aebac0..242648c93b 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_fdda.F +++ b/src/core_atmosphere/dynamics/mpas_atm_fdda.F @@ -1,48 +1,66 @@ !================================================================================================== - module mpas_atm_fdda - use mpas_kind_types - use mpas_derived_types - use mpas_pool_routines - - use mpas_atmphys_constants - use mpas_atmphys_utilities - use mpas_atmphys_vars - use mpas_atmphys_todynamics, only : tend_toEdges - use mpas_log, only : mpas_log_write - - implicit none - private - public:: apply_fdda - - integer, private:: i,k - - -!MPAS grid nudging. -!O. Russell Bullock Jr. (send comments to bullock.russell@epa.gov). -!2016-03-30. +! MPAS four-dimensional data assimilation (FDDA) grid nudging. ! -! subroutines in mpas_atm_fdda: -! ---------------------------------------------- -! apply_fdda : main fdda subroutine (called from subroutine physics_driver). -! - -! add-ons and modifications to sourcecode: -! ---------------------------------------- -! Original sourcecode by O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-03-30. +! O. Russell Bullock Jr. (send comments to bullock.russell@epa.gov). +! 2016-03-30. ! -! * Added various controls for length-scaled FDDA application -! O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-08-11. -! * Modified to only require reads of "fdda_new" data arrays. "fdda_old" is initially -! set to initial conditions. At end of FDDA data interval, "fdda_old" is set to -! "fdda_new" and updated "fdda_new" data comes from FDDA input stream. -! O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-08-30. - - contains +! subroutines in mpas_atm_fdda: +! ---------------------------------------------- +! apply_fdda : main fdda subroutine (called from subroutine physics_driver). +! +! + +! add-ons and modifications to sourcecode: +! ---------------------------------------- +! Original sourcecode by O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-03-30. +! +! * Added various controls for length-scaled FDDA application +! O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-08-11. +! * Modified to only require reads of "fdda_new" data arrays. "fdda_old" is initially +! set to initial conditions. At end of FDDA data interval, "fdda_old" is set to +! "fdda_new" and updated "fdda_new" data comes from FDDA input stream. +! O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-08-30. +! * Modified to add variable transformation and adding nudging tendencies to tend_ru, tend_rtheta +! May Wong (mwong@ucar.edu) / 2025-07-30 + + module mpas_atm_fdda -!================================================================================================== - subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_physics,tend,tend_physics, & + use mpas_kind_types + use mpas_derived_types + use mpas_pool_routines + + use mpas_atmphys_constants + use mpas_atmphys_utilities + use mpas_atmphys_vars + use mpas_atmphys_todynamics, only : tend_toEdges + use mpas_log, only : mpas_log_write + + implicit none + private + public:: apply_fdda + + integer, private:: i,k + + + contains + + !*********************************************************************** + ! + ! routine apply_fdda + ! + !> \brief Applies FDDA nudging tendencies to the RHS tendencies for dynamics + !> \author O. Russell Bullock Jr. + !> \date 30 March 2016 + !> \details + !> This routine computes the FDDA weighted nudging tendencies and adds them + !> to the 'physics' tendencies for the dynamics. + !> + !> Variable transformation and adding to the physics tendencies were added. + !> May Wong (mwong@ucar.edu) / 2025-07-30 + ! + !----------------------------------------------------------------------- + subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_physics,tend,tend_physics,tend_fdda, & tend_ru, tend_rtheta) -!================================================================================================== !input variables: type(block_type), intent(in) :: block @@ -58,6 +76,7 @@ subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_p !inout variables: type(mpas_pool_type),intent(inout):: tend_physics type(mpas_pool_type),intent(inout):: tend + type(mpas_pool_type),intent(inout):: tend_fdda real (kind=RKIND), dimension(:,:), intent(inout) :: tend_ru real (kind=RKIND), dimension(:,:), intent(inout) :: tend_rtheta @@ -136,11 +155,11 @@ subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_p call mpas_pool_get_array(fdda,'th_fdda_new',th_fdda_new) call mpas_pool_get_array(fdda,'u_fdda_new', u_fdda_new ) call mpas_pool_get_array(fdda,'v_fdda_new', v_fdda_new ) - call mpas_pool_get_array(tend_physics,'rthfddaten',rthfddaten) - call mpas_pool_get_array(tend_physics,'rqvfddaten',rqvfddaten) - call mpas_pool_get_array(tend_physics,'rufddaten_Edge' ,rufddaten_Edge ) - call mpas_pool_get_array(tend_physics,'rufddaten' ,rufddaten ) - call mpas_pool_get_array(tend_physics,'rvfddaten' ,rvfddaten ) + call mpas_pool_get_array(tend_fdda,'rthfddaten',rthfddaten) + call mpas_pool_get_array(tend_fdda,'rqvfddaten',rqvfddaten) + call mpas_pool_get_array(tend_fdda,'rufddaten_Edge' ,rufddaten_Edge ) + call mpas_pool_get_array(tend_fdda,'rufddaten' ,rufddaten ) + call mpas_pool_get_array(tend_fdda,'rvfddaten' ,rvfddaten ) call mpas_pool_get_array(diag_physics,'kpbl',kpbl) call mpas_pool_get_array(diag,'uReconstructZonal' ,u) call mpas_pool_get_array(diag,'uReconstructMeridional',v) @@ -270,9 +289,6 @@ subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_p tend_ru(k,i)=tend_ru(k,i)+rufddaten_Edge(k,i)*rho_edge(k,i) enddo enddo - call mpas_log_write('fdda: min/max rufddaten = $r, $r', realArgs=(/minval(rufddaten), maxval(rufddaten)/) ) - call mpas_log_write('fdda: min/max rvfddaten = $r, $r', realArgs=(/minval(rvfddaten), maxval(rvfddaten)/) ) - call mpas_log_write('fdda: min/max rufddaten_Edge = $r, $r', realArgs=(/minval(rufddaten_Edge), maxval(rufddaten_Edge)/) ) ! MW: add coupled tendencies for other variables at cell centers tend_th = 0.0_RKIND @@ -282,8 +298,6 @@ subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_p tend_scalars(index_qv,k,i) = tend_scalars(index_qv,k,i) + rqvfddaten(k,i)*rho_zz(k,i) enddo enddo - call mpas_log_write('fdda: min/max rthfddaten = $r, $r', realArgs=(/minval(rthfddaten), maxval(rthfddaten)/) ) - call mpas_log_write('fdda: min/max rqvfddaten = $r, $r', realArgs=(/minval(rqvfddaten), maxval(rqvfddaten)/) ) ! if non-hydrostatic core, convert the tendency for the potential temperature to a @@ -307,8 +321,7 @@ subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_p deallocate(tend_th) - end subroutine apply_fdda + end subroutine apply_fdda + -!================================================================================================== end module mpas_atm_fdda -!================================================================================================== From 4ba4a787ac2972f8c7ca08052c7db2c8f1b10868 Mon Sep 17 00:00:00 2001 From: May Wong Date: Wed, 30 Jul 2025 13:39:46 -0600 Subject: [PATCH 07/17] Moving FDDA tendency variables (rthfddaten, etc.) from the tend_physics variable structure to its own tend_fdda variable structure in the Registry. *Modified the call to apply_fdda to include tend_fdda --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 4 +++- 1 file changed, 3 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 b37e28a08a..59c3d05355 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -868,6 +868,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) 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_fdda => null() type (mpas_pool_type), pointer :: lbc ! regional_MPAS addition type (mpas_pool_type), pointer :: fdda @@ -914,6 +915,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_pool_get_subpool(block % structs, 'diag', diag) 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, 'tend_fdda', tend_fdda) #ifdef DO_PHYSICS call mpas_pool_get_subpool(block % structs, 'diag_physics', diag_physics) #endif @@ -1112,7 +1114,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) ! ! MW: Why are tend_ru_physics and tend_rtheta_physics global variables, but not tend_scalars? if (trim(config_fdda_scheme) /= 'off') then - call apply_fdda( block, xtime_s, block % configs, mesh, state, 1, fdda, diag, diag_physics, tend, tend_physics, & + call apply_fdda( block, xtime_s, block % configs, mesh, state, 1, fdda, diag, diag_physics, tend, tend_physics, tend_fdda, & tend_ru_physics, tend_rtheta_physics) end if From 9a6b6bf7adbc131121dceb4e8f1760bfde2cefae Mon Sep 17 00:00:00 2001 From: May Wong Date: Fri, 1 Aug 2025 11:43:00 -0600 Subject: [PATCH 08/17] Moving *_fdda_new, *_fdda_old variables into one variable *_fdda with two time levels. FDDA input fields are read in and shifted in time levels, similar to how LBC fields are done. --- src/core_atmosphere/Registry.xml | 38 ++--- src/core_atmosphere/dynamics/mpas_atm_fdda.F | 165 +++++++++++++++---- src/core_atmosphere/mpas_atm_core.F | 50 +++++- 3 files changed, 198 insertions(+), 55 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 63ebd8413a..00a911fe43 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1223,10 +1223,10 @@ input_interval="6:00:00" immutable="true"> - - - - + + + + - - - - - - - - - + - + - + - + - + diff --git a/src/core_atmosphere/dynamics/mpas_atm_fdda.F b/src/core_atmosphere/dynamics/mpas_atm_fdda.F index 242648c93b..872c311bcd 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_fdda.F +++ b/src/core_atmosphere/dynamics/mpas_atm_fdda.F @@ -7,6 +7,7 @@ ! subroutines in mpas_atm_fdda: ! ---------------------------------------------- ! apply_fdda : main fdda subroutine (called from subroutine physics_driver). +! mpas_atm_update_fdda_state : subroutine to read in fdda input stream and save/shift to correct time-level ! ! @@ -21,6 +22,9 @@ ! "fdda_new" and updated "fdda_new" data comes from FDDA input stream. ! O. Russell Bullock Jr. (bullock.russell@epa.gov) / 2016-08-30. ! * Modified to add variable transformation and adding nudging tendencies to tend_ru, tend_rtheta +! May Wong (mwong@ucar.edu) / 2025-07-30 +! * Modified to add subroutine mpas_atm_update_fdda_state to update the fdda target data arrays +! from the input stream. ! May Wong (mwong@ucar.edu) / 2025-07-30 module mpas_atm_fdda @@ -37,7 +41,7 @@ module mpas_atm_fdda implicit none private - public:: apply_fdda + public:: apply_fdda, mpas_atm_update_fdda_state integer, private:: i,k @@ -92,8 +96,8 @@ subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_p real(kind=RKIND),dimension(:),pointer :: meshDensity real(kind=RKIND),dimension(:,:),pointer :: rthfddaten,rqvfddaten real(kind=RKIND),dimension(:,:),pointer :: rufddaten,rvfddaten,rufddaten_Edge - real(kind=RKIND),dimension(:,:),pointer :: qv_fdda_old,th_fdda_old,u_fdda_old,v_fdda_old - real(kind=RKIND),dimension(:,:),pointer :: qv_fdda_new,th_fdda_new,u_fdda_new,v_fdda_new + real(kind=RKIND),dimension(:,:),pointer :: qv_fdda_old,theta_fdda_old,u_fdda_old,v_fdda_old + real(kind=RKIND),dimension(:,:),pointer :: qv_fdda_new,theta_fdda_new,u_fdda_new,v_fdda_new real(kind=RKIND),dimension(:,:),pointer :: u,v real(kind=RKIND),dimension(:,:),pointer :: qv real(kind=RKIND),dimension(:,:),pointer :: theta_m @@ -147,14 +151,14 @@ subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_p call mpas_pool_get_dimension(mesh, 'nEdgesSolve', nEdgesSolve) call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_array(fdda,'qv_fdda_old',qv_fdda_old) - call mpas_pool_get_array(fdda,'th_fdda_old',th_fdda_old) - call mpas_pool_get_array(fdda,'u_fdda_old', u_fdda_old ) - call mpas_pool_get_array(fdda,'v_fdda_old', v_fdda_old ) - call mpas_pool_get_array(fdda,'qv_fdda_new',qv_fdda_new) - call mpas_pool_get_array(fdda,'th_fdda_new',th_fdda_new) - call mpas_pool_get_array(fdda,'u_fdda_new', u_fdda_new ) - call mpas_pool_get_array(fdda,'v_fdda_new', v_fdda_new ) + call mpas_pool_get_array(fdda,'qv_fdda',qv_fdda_old , 1) + call mpas_pool_get_array(fdda,'theta_fdda',theta_fdda_old, 1) + call mpas_pool_get_array(fdda,'u_fdda', u_fdda_old , 1) + call mpas_pool_get_array(fdda,'v_fdda', v_fdda_old , 1) + call mpas_pool_get_array(fdda,'qv_fdda',qv_fdda_new , 2) + call mpas_pool_get_array(fdda,'theta_fdda',theta_fdda_new, 2) + call mpas_pool_get_array(fdda,'u_fdda', u_fdda_new , 2) + call mpas_pool_get_array(fdda,'v_fdda', v_fdda_new , 2) call mpas_pool_get_array(tend_fdda,'rthfddaten',rthfddaten) call mpas_pool_get_array(tend_fdda,'rqvfddaten',rqvfddaten) call mpas_pool_get_array(tend_fdda,'rufddaten_Edge' ,rufddaten_Edge ) @@ -175,14 +179,6 @@ subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_p allocate(tend_th(nVertLevels,nCellsSolve)) - !check to see if 'old' FDDA target values need to be defined from initial conditions - if(first_call .and. .not. config_do_restart) then - qv_fdda_old = qv - th_fdda_old = theta_m / (1._RKIND + rvord * qv) - u_fdda_old = u - v_fdda_old = v - first_call = .false. - endif !calculate time fraction within FDDA target data interval tfrac = mod(xtime_s,fdda_int)/fdda_int @@ -213,7 +209,7 @@ subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_p theta_p = theta_m(k,i) / (1._RKIND + rvord * qv(k,i)) if (fdda_t .and. k.gt.fdda_t_min_layer .and. (fdda_t_in_pbl .or. k.gt.kpbl(i))) then - t_target = (1.0_RKIND-tfrac)*th_fdda_old(k,i)+tfrac*th_fdda_new(k,i) + t_target = (1.0_RKIND-tfrac)*theta_fdda_old(k,i)+tfrac*theta_fdda_new(k,i) rthfddaten(k,i) = fdda_t_coef * ( t_target - theta_p ) * sfac else @@ -248,8 +244,10 @@ subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_p theta_p = theta_m(k,i) / (1._RKIND + rvord * qv(k,i)) if (fdda_t .and. k.gt.fdda_t_min_layer .and. (fdda_t_in_pbl .or. k.gt.kpbl(i))) then - t_target = (1.0_RKIND-tfrac)*th_fdda_old(k,i)+tfrac*th_fdda_new(k,i) + t_target = (1.0_RKIND-tfrac)*theta_fdda_old(k,i)+tfrac*theta_fdda_new(k,i) rthfddaten(k,i) = fdda_t_coef * ( t_target - theta_p ) + if (i.eq.1 .and. k.eq.1 ) call mpas_log_write('t_target, theta_p, theta_fdda_old, theta_fdda_new = $r, $r, $r, $r', & + realArgs=(/t_target, theta_p, theta_fdda_old(k,i), theta_fdda_new(k,i)/) ) else rthfddaten(k,i) = 0._RKIND endif @@ -273,6 +271,10 @@ subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_p ENDDO ENDDO + call mpas_log_write('in apply_fdda: min,max rthfddaten = $r, $r', realArgs=(/minval(rthfddaten), maxval(rthfddaten)/) ) + call mpas_log_write('in apply_fdda: min,max rqvfddaten = $r, $r', realArgs=(/minval(rqvfddaten), maxval(rqvfddaten)/) ) + call mpas_log_write('in apply_fdda: min,max rufddaten = $r, $r', realArgs=(/minval(rufddaten), maxval(rufddaten)/) ) + call mpas_log_write('in apply_fdda: min,max rvfddaten = $r, $r', realArgs=(/minval(rvfddaten), maxval(rvfddaten)/) ) case default @@ -310,18 +312,123 @@ subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_p end do end do - !check to see if this is the last time step within the current FDDA target data interval and - !if so, save the current "new" targets as the "old" targets for the next time step - if(mod(xtime_s+config_dt,fdda_int)/fdda_int .lt. tfrac) then - th_fdda_old = th_fdda_new - qv_fdda_old = qv_fdda_new - u_fdda_old = u_fdda_new - v_fdda_old = v_fdda_new - endif deallocate(tend_th) end subroutine apply_fdda + !*********************************************************************** + ! + ! routine mpas_atm_update_fdda_state + ! + !> \brief Reads new fdda input data and updates the FDDA tendencies + !> \author Michael Duda, May Wong + !> \date 30 July 2025 + !> \details + !> This routine reads from the 'fdda' stream all variables in the 'fdda' + !> pool. When called with firstCall=.true., the latest time before the + !> present is read into time level 2 of the fdda pool; otherwise, the + !> contents of time level 2 are shifted to time level 1, the earliest + !> time strictly later than the present is read into time level 2, and + !> the tendencies for all fields in the fdda pool are computed and stored + !> in time level 1. + !> + !> This subroutine for FDDA tendencies is based on mpas_atm_update_bdy_tend. + ! + !----------------------------------------------------------------------- + subroutine mpas_atm_update_fdda_state(clock, streamManager, block, firstCall, ierr) + + use mpas_constants, only : rvord + use mpas_stream_manager, only : mpas_stream_mgr_read + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_STREAM_MGR_NOERR, MPAS_LOG_ERR + use mpas_timekeeping, only : mpas_get_time + + implicit none + + type (mpas_clock_type), intent(in) :: clock + type (MPAS_streamManager_type), intent(inout) :: streamManager + type (block_type), intent(inout) :: block + logical, intent(in) :: firstCall + integer, intent(out) :: ierr + + character(len=StrKIND) :: lbc_intv_start_string + character(len=StrKIND) :: lbc_intv_end_string + + type (mpas_pool_type), pointer :: mesh + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: fdda + real (kind=RKIND) :: dt + + integer, pointer :: nCells + integer, pointer :: nEdges + integer, pointer :: index_qv + + real (kind=RKIND), dimension(:,:), pointer :: u + real (kind=RKIND), dimension(:,:), pointer :: ru + real (kind=RKIND), dimension(:,:), pointer :: rho_edge + real (kind=RKIND), dimension(:,:), pointer :: w + real (kind=RKIND), dimension(:,:), pointer :: theta + real (kind=RKIND), dimension(:,:), pointer :: rtheta_m + real (kind=RKIND), dimension(:,:), pointer :: rho_zz + real (kind=RKIND), dimension(:,:), pointer :: rho + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + + real (kind=RKIND), dimension(:,:), pointer :: qv_fdda + real (kind=RKIND), dimension(:,:), pointer :: theta_fdda + real (kind=RKIND), dimension(:,:), pointer :: u_fdda + real (kind=RKIND), dimension(:,:), pointer :: v_fdda + + + integer :: dd_intv, s_intv, sn_intv, sd_intv + type (MPAS_Time_Type) :: currTime + type (MPAS_TimeInterval_Type) :: lbc_interval + character(len=StrKIND) :: read_time + integer :: iEdge + integer :: cell1, cell2 + + + ierr = 0 + + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'fdda', fdda) + + if (firstCall) then + call MPAS_stream_mgr_read(streamManager, streamID='fdda', timeLevel=1, whence=MPAS_STREAM_LATEST_BEFORE, & + actualWhen=read_time, ierr=ierr) + if (ierr /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Could not read from ''fdda'' stream on or before the current date '// & + 'to update target FDDA fields', messageType=MPAS_LOG_ERR) + ierr = 1 + end if + + call MPAS_stream_mgr_read(streamManager, streamID='fdda', timeLevel=2, whence=MPAS_STREAM_EARLIEST_STRICTLY_AFTER, & + actualWhen=read_time, ierr=ierr) + if (ierr /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Could not read from ''fdda'' stream after the current date '// & + 'to update target FDDA fields', messageType=MPAS_LOG_ERR) + + ierr = 1 + end if + + else + call mpas_pool_shift_time_levels(fdda) + call MPAS_stream_mgr_read(streamManager, streamID='fdda', timeLevel=2, whence=MPAS_STREAM_EARLIEST_STRICTLY_AFTER, & + actualWhen=read_time, ierr=ierr) + if (ierr /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Could not read from ''fdda'' stream after the current date '// & + 'to update target FDDA fields', messageType=MPAS_LOG_ERR) + + ierr = 1 + end if + end if + if (ierr /= 0) then + return + end if + + end subroutine mpas_atm_update_fdda_state + + end module mpas_atm_fdda diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index f7d04a1f0c..12a92baf1e 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -611,6 +611,7 @@ function atm_core_run(domain) result(ierr) use mpas_timer, only : mpas_timer_start, mpas_timer_stop use mpas_atm_boundaries, only : mpas_atm_update_bdy_tend use mpas_atm_diagnostics_manager, only : mpas_atm_diag_update, mpas_atm_diag_compute, mpas_atm_diag_reset + use mpas_atm_fdda, only : mpas_atm_update_fdda_state implicit none @@ -620,6 +621,7 @@ function atm_core_run(domain) result(ierr) real (kind=RKIND) :: dt logical, pointer :: config_do_restart logical, pointer :: config_apply_lbcs + character(len=StrKIND),pointer:: config_fdda_scheme type (block_type), pointer :: block_ptr type (MPAS_Time_Type) :: currTime @@ -713,6 +715,7 @@ function atm_core_run(domain) result(ierr) #endif call mpas_pool_get_config(domain % blocklist % configs, 'config_apply_lbcs', config_apply_lbcs) + call mpas_pool_get_config(domain % blocklist % configs, 'config_fdda_scheme', config_fdda_scheme) ! ! Read initial boundary state @@ -733,6 +736,27 @@ function atm_core_run(domain) result(ierr) end do end if + ! + ! Read initial FDDA target state + ! + if ( trim(config_fdda_scheme) /= 'off' .and. & + MPAS_stream_mgr_ringing_alarms(domain % streamManager, streamID='fdda', direction=MPAS_STREAM_INPUT, ierr=ierr)) then + block_ptr => domain % blocklist + do while (associated(block_ptr)) + call mpas_atm_update_fdda_state(clock, domain % streamManager, block_ptr, .true., ierr) + if (ierr /= 0) then + currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) + call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp) + call mpas_log_write('Failed to process FDDA data on or before '//trim(timeStamp), messageType=MPAS_LOG_ERR) + return + end if + + block_ptr => block_ptr % next + end do + end if + + + ! During integration, time level 1 stores the model state at the beginning of the ! time step, and time level 2 stores the state advanced dt in time by timestep(...) itimestep = 1 @@ -761,10 +785,33 @@ function atm_core_run(domain) result(ierr) end do end if + ! + ! Read future FDDA target state and shift time levels + ! + if ( itimestep.ne.1 .and. trim(config_fdda_scheme) /= 'off' .and. & + MPAS_stream_mgr_ringing_alarms(domain % streamManager, streamID='fdda', direction=MPAS_STREAM_INPUT, ierr=ierr)) then + block_ptr => domain % blocklist + do while (associated(block_ptr)) + call mpas_atm_update_fdda_state(clock, domain % streamManager, block_ptr, .false., ierr) + if (ierr /= 0) then + call mpas_log_write('Failed to process FDDA data at next time after '//trim(timeStamp), messageType=MPAS_LOG_ERR) + return + end if + + block_ptr => block_ptr % next + end do + end if + + + + ! Regardless of whether boundary tendencies were updated, above, we do not want to read the 'lbc_in' stream ! as a general input stream, below. call MPAS_stream_mgr_reset_alarms(domain % streamManager, streamID='lbc_in', direction=MPAS_STREAM_INPUT, ierr=ierr) + ! MW: Similar to the 'lbc_in' stream, we want to reset the alarm for the fdda stream + call MPAS_stream_mgr_reset_alarms(domain % streamManager, streamID='fdda', direction=MPAS_STREAM_INPUT, ierr=ierr) + ! ! Read external field updates @@ -803,6 +850,8 @@ function atm_core_run(domain) result(ierr) call mpas_timer_stop("time integration") call mpas_log_write(' Timing for integration step: $r s', realArgs=(/real(integ_stop_time - integ_start_time, kind=RKIND)/)) + + ! Move time level 2 fields back into time level 1 for next time step call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) call mpas_pool_shift_time_levels(state) @@ -812,7 +861,6 @@ function atm_core_run(domain) result(ierr) call mpas_advance_clock(clock) currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) - call mpas_dmpar_get_time(diag_start_time) ! From 3ae1014965c56c23e221451d7d3af0412784157f Mon Sep 17 00:00:00 2001 From: Wei Wang Date: Sun, 17 Aug 2025 05:38:53 -0600 Subject: [PATCH 09/17] Corrections from rebasing: 1. Remove changes to Makefile from original PR 2. Add new fdda variables and remove the old in registry 3. Add missed argument xtime_s to calls to atm_srk3 and atm_timestep --- Makefile | 12 ++++++------ src/core_atmosphere/Registry.xml | 12 ++++-------- .../dynamics/mpas_atm_time_integration.F | 8 +++++--- src/core_atmosphere/mpas_atm_core.F | 2 +- 4 files changed, 16 insertions(+), 18 deletions(-) diff --git a/Makefile b/Makefile index c5cf4d6282..f739e85194 100644 --- a/Makefile +++ b/Makefile @@ -360,11 +360,11 @@ intel-mpi: # BUILDTARGET Intel compiler suite with Intel MPI library "CC_SERIAL = icc" \ "CXX_SERIAL = icpc" \ "FFLAGS_PROMOTION = -real-size 64" \ - "FFLAGS_OPT = -O3 -xBROADWELL -fma -fp-model precise -traceback -no-wrap-margin -convert big_endian -free -align array64byte" \ - "CFLAGS_OPT = -O3 -xBROADWELL -fma -fp-model precise -traceback" \ - "CXXFLAGS_OPT = -O3 -xBROADWELL -fma -fp-model precise -traceback" \ + "FFLAGS_OPT = -O3 -convert big_endian -free -align array64byte" \ + "CFLAGS_OPT = -O3" \ + "CXXFLAGS_OPT = -O3" \ "LDFLAGS_OPT = -O3" \ - "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback -no-wrap-margin" \ + "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback" \ "CFLAGS_DEBUG = -g -traceback" \ "CXXFLAGS_DEBUG = -g -traceback" \ "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ @@ -779,7 +779,7 @@ ifneq "$(LAPACK)" "" endif RM = rm -f -CPP = ${CXX_SERIAL} -E # Modified for use with the Intel C++ compiler +CPP = cpp -P -traditional RANLIB = ranlib ifdef CORE @@ -976,7 +976,7 @@ ifeq "$(findstring clean, $(MAKECMDGOALS))" "clean" # CHECK FOR CLEAN TARGET override AUTOCLEAN=false endif # END OF CLEAN TARGET CHECK -VER="v7.3.develop.EPA_FDDA" # Hard-coded specific version identifier +VER=$(shell git describe --dirty 2> /dev/null) #override CPPFLAGS += -DMPAS_GIT_VERSION=$(VER) ifeq "$(findstring v, $(VER))" "v" diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 00a911fe43..bf97b90cb7 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -915,14 +915,10 @@ - - - - - - - - + + + + diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 59c3d05355..ce0435c85a 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -737,7 +737,7 @@ subroutine mpas_atm_dynamics_finalize(domain) end subroutine mpas_atm_dynamics_finalize - subroutine atm_timestep(domain, dt, nowTime, itimestep, exchange_halo_group) + subroutine atm_timestep(domain, dt, nowTime, itimestep, xtime_s, exchange_halo_group) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Advance model state forward in time by the specified time step ! @@ -753,6 +753,7 @@ subroutine atm_timestep(domain, dt, nowTime, itimestep, exchange_halo_group) real (kind=RKIND), intent(in) :: dt type (MPAS_Time_type), intent(in) :: nowTime integer, intent(in) :: itimestep + real (kind=RKIND), intent(in) :: xtime_s procedure (halo_exchange_routine) :: exchange_halo_group @@ -776,7 +777,7 @@ subroutine atm_timestep(domain, dt, nowTime, itimestep, exchange_halo_group) config_apply_lbcs = config_apply_lbcs_ptr if (trim(config_time_integration) == 'SRK3') then - call atm_srk3(domain, dt, itimestep, exchange_halo_group) + call atm_srk3(domain, dt, itimestep, xtime_s, 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) @@ -801,7 +802,7 @@ subroutine atm_timestep(domain, dt, nowTime, itimestep, exchange_halo_group) end subroutine atm_timestep - subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) + subroutine atm_srk3(domain, dt, itimestep, xtime_s, exchange_halo_group) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Advance model state forward in time by the specified time step using ! time-split RK3 scheme @@ -820,6 +821,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) type (domain_type), intent(inout) :: domain real (kind=RKIND), intent(in) :: dt integer, intent(in) :: itimestep + real (kind=RKIND), intent(in) :: xtime_s procedure (halo_exchange_routine) :: exchange_halo_group integer :: thread diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index 12a92baf1e..1e2e77dc98 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -1067,7 +1067,7 @@ subroutine atm_do_timestep(domain, dt, itimestep) endif #endif - call atm_timestep(domain, dt, currTime, itimestep, exchange_halo_group) + call atm_timestep(domain, dt, currTime, itimestep, xtime_s, exchange_halo_group) end subroutine atm_do_timestep From 601cf8fa1b32f9ea0ff648e156c0a487eb4e035e Mon Sep 17 00:00:00 2001 From: May Wong Date: Tue, 30 Jun 2026 10:24:29 -0600 Subject: [PATCH 10/17] Merging modifications based on the EPA analysis nudging tool to V8.4.1 release --- Makefile | 126 +- README.md | 2 +- cmake/Functions/MPAS_Functions.cmake | 1 + cmake/Modules/FindPnetCDF.cmake | 10 +- src/Makefile | 2 +- src/core_atmosphere/CMakeLists.txt | 39 +- src/core_atmosphere/Makefile | 29 +- src/core_atmosphere/Registry.xml | 261 +- src/core_atmosphere/chemistry/Makefile | 47 + .../chemistry/mpas_atm_chemistry.F | 128 + src/core_atmosphere/chemistry/musica/Makefile | 31 + .../chemistry/musica/mpas_musica.F | 181 ++ src/core_atmosphere/diagnostics/Makefile | 4 +- .../diagnostics/mpas_cloud_diagnostics.F | 6 +- src/core_atmosphere/dynamics/Makefile | 11 +- .../dynamics/mpas_atm_boundaries.F | 32 - .../dynamics/mpas_atm_dissipation_models.F | 1639 ++++++++++ src/core_atmosphere/dynamics/mpas_atm_iau.F | 78 +- .../dynamics/mpas_atm_time_integration.F | 2752 ++++++++++------- src/core_atmosphere/mpas_atm_core.F | 387 ++- src/core_atmosphere/mpas_atm_halos.F | 17 +- src/core_atmosphere/physics/Makefile | 6 +- .../physics/Registry_noahmp.xml | 2 +- .../physics/mpas_atmphys_driver_lsm_noahmp.F | 6 +- .../mpas_atmphys_driver_radiation_sw.F | 56 +- .../physics/mpas_atmphys_init.F | 24 +- .../physics/mpas_atmphys_initialize_real.F | 9 + .../physics/mpas_atmphys_interface.F | 149 +- .../physics/mpas_atmphys_lsm_noahmpinit.F | 2 +- .../physics/mpas_atmphys_todynamics.F | 83 +- .../drivers/mpas/EnergyVarOutTransferMod.F90 | 2 +- .../physics_noahmp/drivers/mpas/Makefile | 2 +- .../physics/physics_wrf/Makefile | 4 +- .../physics/physics_wrf/module_cu_gf.mpas.F | 1 + .../physics/physics_wrf/module_mp_kessler.F | 1 + .../physics/physics_wrf/module_sf_urban.F | 3 + src/core_atmosphere/utils/Makefile | 6 +- src/core_init_atmosphere/Makefile | 4 +- src/core_init_atmosphere/Registry.xml | 28 +- src/core_init_atmosphere/mpas_atm_advection.F | 18 +- .../mpas_init_atm_cases.F | 1137 +++++-- .../mpas_init_atm_vinterp.F | 19 +- src/core_landice/Makefile | 2 +- src/core_landice/Registry.xml | 2 +- src/core_ocean/Makefile | 2 +- src/core_ocean/Registry.xml | 2 +- src/core_seaice/Registry.xml | 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_sw/Registry.xml | 2 +- src/core_test/Makefile | 11 +- src/core_test/Registry.xml | 2 +- src/core_test/mpas_halo_testing.F | 4 +- src/core_test/mpas_test_core.F | 29 +- src/core_test/mpas_test_core_io.F | 200 ++ src/core_test/mpas_test_core_stream_list.F | 653 ++++ src/core_test/mpas_test_core_streams.F | 169 +- src/driver/Makefile | 4 +- src/external/Makefile | 8 +- src/external/SMIOL/smiol.c | 9 +- src/framework/CMakeLists.txt | 3 + src/framework/Makefile | 12 +- src/framework/mpas_abort.F | 2 + src/framework/mpas_block_creator.F | 1 + src/framework/mpas_block_decomp.F | 347 ++- src/framework/mpas_dmpar.F | 13 +- src/framework/mpas_field_routines.F | 9 + src/framework/mpas_framework.F | 24 +- src/framework/mpas_halo.F | 85 +- src/framework/mpas_halo_interface.inc | 16 + src/framework/mpas_io.F | 63 +- src/framework/mpas_io_types.inc | 3 +- src/framework/mpas_log.F | 2 + src/framework/mpas_pool_routines.F | 10 + src/framework/mpas_ptscotch_interface.F | 453 +++ src/framework/mpas_stream_inquiry.F | 2 +- src/framework/mpas_stream_list.F | 15 +- src/framework/mpas_stream_manager.F | 29 +- src/framework/mpas_timekeeping.F | 1 + src/framework/ptscotch_interface.c | 280 ++ src/operators/Makefile | 4 +- src/operators/mpas_vector_reconstruction.F | 155 +- src/tools/registry/gen_inc.c | 87 +- 85 files changed, 8302 insertions(+), 1778 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 create mode 100644 src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F create mode 100644 src/core_test/mpas_test_core_io.F create mode 100644 src/core_test/mpas_test_core_stream_list.F create mode 100644 src/framework/mpas_halo_interface.inc create mode 100644 src/framework/mpas_ptscotch_interface.F create mode 100644 src/framework/ptscotch_interface.c diff --git a/Makefile b/Makefile index f739e85194..07ba5f9556 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" \ @@ -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" \ @@ -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 @@ -759,6 +777,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.*), ) @@ -872,6 +899,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 +1415,63 @@ 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)), ) + +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: @# @@ -1424,6 +1522,20 @@ 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 + +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)" \ @@ -1460,6 +1572,8 @@ mpas_main: $(MAIN_DEPS) @echo $(OPENMP_MESSAGE) @echo $(OPENMP_OFFLOAD_MESSAGE) @echo $(OPENACC_MESSAGE) + @echo $(MUSICA_MESSAGE) + @echo $(SCOTCH_MESSAGE) @echo $(SHAREDLIB_MESSAGE) ifeq "$(AUTOCLEAN)" "true" @echo $(AUTOCLEAN_MESSAGE) @@ -1467,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)" @@ -1523,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/README.md b/README.md index a4f23e5523..a1e6701152 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -MPAS-v8.3.1 +MPAS-v8.4.1 ==== The Model for Prediction Across Scales (MPAS) is a collaborative project for 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 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() 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/CMakeLists.txt b/src/core_atmosphere/CMakeLists.txt index 0667b67187..7fdbe66992 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 @@ -335,6 +315,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/) diff --git a/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index 966027bc77..bb2bd2c2e7 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 -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) $(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 $(MPAS_ESMF_INC) -I./chemistry endif diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index bf97b90cb7..cc90397193 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + @@ -146,16 +146,46 @@ description="Formulation of horizontal mixing" possible_values="`2d_fixed' or `2d_smagorinsky'"/> + + + + + + + + + + + + - @@ -264,12 +294,12 @@ possible_values="Positive real values"/> @@ -292,6 +322,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"/> + + + + + + + + + @@ -475,8 +526,22 @@ units="-" description="Method to use for exchanging halos" possible_values="`mpas_dmpar', `mpas_halo'"/> + + +#ifdef MPAS_USE_MUSICA + + + +#endif + @@ -500,6 +565,12 @@ + + @@ -575,8 +646,6 @@ - - #ifdef MPAS_CAM_DYCORE @@ -1008,28 +1077,7 @@ - - - - - - - - #ifdef DO_PHYSICS - - - - - - - - - - - - - @@ -1587,6 +1635,18 @@ + + + + + + + + @@ -1650,13 +1710,6 @@ - - - - - #ifdef MPAS_CAM_DYCORE @@ -1664,6 +1717,21 @@ #endif + + + + + + + + + + + + #endif @@ -2040,8 +2112,20 @@ - + + + + + + + + + @@ -2143,6 +2227,10 @@ + + #endif @@ -2243,6 +2331,11 @@ + + @@ -2356,6 +2449,11 @@ description="number of microphysics time-steps per physics time-steps" possible_values="Positive integers"/> + + + 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"/> - - + - - - - @@ -3089,10 +3187,10 @@ - - - - + + diff --git a/src/core_atmosphere/chemistry/Makefile b/src/core_atmosphere/chemistry/Makefile new file mode 100644 index 0000000000..7ea503e5b6 --- /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 $(MPAS_ESMF_INC) +else + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./musica -I.. -I../../framework $(MPAS_ESMF_INC) +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..7fda1f27a8 --- /dev/null +++ b/src/core_atmosphere/chemistry/mpas_atm_chemistry.F @@ -0,0 +1,128 @@ +! 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, MPAS_LOG_CRIT + 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 + 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...') + +#ifdef MPAS_USE_MUSICA + call mpas_pool_get_dimension(dimensions, 'nVertLevels', nVertLevels_ptr) + nVertLevels = nVertLevels_ptr + + call mpas_pool_get_config(configs, 'config_micm_file', filepath_ptr) + + 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 + + + !------------------------------------------------------------------------ + ! 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..c5bd89cc21 --- /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 $(MPAS_ESMF_INC) +else + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../../framework $(MPAS_ESMF_INC) +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..a531a2414e --- /dev/null +++ b/src/core_atmosphere/chemistry/musica/mpas_musica.F @@ -0,0 +1,181 @@ +! 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 + logical :: musica_is_initialized = .false. ! Flag to track if MUSICA was successfully initialized + + 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 + 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]) + + 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 + + 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 + + !------------------------------------------------------------------------ + ! 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 + + 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 + ! 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 + + 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. + + 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/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/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/dynamics/Makefile b/src/core_atmosphere/dynamics/Makefile index f1907fa34f..16f40d0cef 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_fdda.o +mpas_atm_time_integration.o: mpas_atm_boundaries.o mpas_atm_iau.o mpas_atm_dissipation_models.o mpas_atm_fdda.o mpas_atm_boundaries.o: @@ -19,8 +20,8 @@ clean: .F.o: $(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 + $(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 -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/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_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F new file mode 100644 index 0000000000..8c386b1d8e --- /dev/null +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -0,0 +1,1639 @@ +! 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 +! 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 + use mpas_constants + use mpas_log + 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 + ! 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 + + 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, & + 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 + 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 + + + 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 + + !$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)) + 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 + 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 + + !$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 + + DEBUG_WRITE(' exiting smagorinsky_2d ') + + end subroutine smagorinsky_2d + +!--------------------------------------- + + 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, & + 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 + + 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 + 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(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 + 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), 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 + 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(out) :: 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 + 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 + real (kind=RKIND) :: eddy_visc_h, eddy_visc_v + + logical, parameter :: test_tke=.true. + ! real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 + + + !$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 + + 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 + + !$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(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) + 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 + + !$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 + dwdy(k) = dwdy(k) + deformation_coef_s(iEdge,iCell)*wk + end do + + 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 + 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 + + !$acc loop vector + 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 (les_model_opt == 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))) + 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 (les_model_opt == LES_MODEL_PROGNOSTIC_15_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) + 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 + + ! 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 + + ! 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) + + buoyancy = -eddy_visc_v*bv_freq2(k,iCell) + + ! 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 + + dissipation = -c_dissipation*(scalars(index_tke,k,iCell)**(1.5))/diss_length + + ! computing eddy viscosities ********* + + 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 ) + + end do + + else + +!MGD call mpas_log_write(' in les_models, no les scheme for '//trim(config_les_model), messageType=MPAS_LOG_CRIT) + + end if ! end of les_model_opt 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 + +!--------------------------------------- + + 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 + +#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 + 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 + 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 + + + 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)) + + 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 + + !$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 + + ! 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 + + end do + + bn2(1,iCell) = bn2(2,iCell) + bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) + + end do + + !$acc end parallel + + !$acc exit data delete(theta, temp, qvsw, coefa) + + DEBUG_WRITE(' exiting BV frequency calculations ') + + 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, 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 ) + + 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, 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 + 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), intent(in) :: config_surface_drag_coefficient + + 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,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 + 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 + + + ! 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(:), intent(in) :: ustm + + 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, u_diffusion_les, 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 + real (kind=RKIND) :: ust_edge + + real (kind=RKIND) :: velocity_magnitude + real (kind=RKIND) :: tau_12_factor + + + DEBUG_WRITE(' begin u_dissipation_3d ') + 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 + + ! 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 enter data create(u_mix) + !$acc enter data create(turb_vflux) + + !$acc parallel default(present) + + tau_12_factor = 0.0 + if(les_model_opt /= LES_MODEL_NONE) tau_12_factor = 1.0 + + !$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)) + + !$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 + ! 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 + + 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) + + 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 for les formulation + + if ( les_model_opt /= 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.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) + 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 + + 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 ( 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) + 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 + + !$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 + +!------------------------ + + 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, & + les_model_opt, les_surface_opt, & + 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 + + 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 + + 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) :: divergence + 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. + + + DEBUG_WRITE(' begin w_dissipation_3d ') + DEBUG_WRITE(' 4th order hyperviscosity is $r ' COMMA realArgs=(/h_mom_eddy_visc4/)) + + !$acc enter data create(turb_vflux) + + !$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 * & + ( 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 + + !$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 + + 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) & + -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k) + end do + end do + + !$acc end parallel + + end if + + if ( les_model_opt /= 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)) & + + divergence(k,iCell) ) + end do + + 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 + +!----------------------------------------------------- + + 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, & + les_model_opt, les_surface_opt, clock, dt, & + 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 + + 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 + integer, intent(in) :: dynamics_substep + + real (kind=RKIND), intent(in) :: config_surface_heat_flux + real (kind=RKIND), intent(in) :: config_surface_moisture_flux + + logical, intent(in) :: config_mix_full, mix_scalars + + 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 + + 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) :: uReconstructZonal, uReconstructMeridional + + 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 + 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(:), intent(in) :: hfx, qfx + + 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, prandtl_1d_inverse + real (kind=RKIND), dimension(num_scalars,nVertLevels+1) :: turb_vflux_scalars + 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 + + + DEBUG_WRITE(' begin scalar_dissipation_3d ') + 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 ') + + !$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 + + !$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. +! 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 + + !$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 + + if(mix_scalars .and. (dynamics_substep == 1)) then ! dissipation for scalars, including 4th-order filter. Likely needs optimization + + do iScalar=1,num_scalars + + !$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) + 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. +! 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 + + !$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_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 + + 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 + + !$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 + + !$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)-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 + + if ( les_model_opt /= 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 + + turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain + turb_vflux(1) = 0. ! lower bc flux handled where ??? + + if ( les_model_opt == LES_MODEL_3D_SMAGORINSKY ) then + !$acc loop vector + 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 + + !$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) + end do + + 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(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 + + if( les_surface_opt == LES_SURFACE_SPECIFIED .or. les_surface_opt == LES_SURFACE_VARYING ) 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 ( 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 + + 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) + + 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 + + !$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)) + end do + + if (mix_scalars ) then + + ! compute turbulent fluxes + !$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 + do iScalar=1,num_scalars + 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( 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 + 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 if ! mix scalars + + 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 + +!----------- + +! subroutine flux_les_sas(heat_flux, moisture_flux, clock, dt) + +! implicit none + +! 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)) + +! 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_atm_dissipation_models diff --git a/src/core_atmosphere/dynamics/mpas_atm_iau.F b/src/core_atmosphere/dynamics/mpas_atm_iau.F index 654fd3ae82..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 !================================================================================================== @@ -76,6 +86,70 @@ 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) + + 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) + 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) + MPAS_ACC_TIMER_STOP('atm_srk3: physics ACC_data_xfer') +#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) + + 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 !================================================================================================== subroutine atm_add_tend_anal_incr (configs, structs, itimestep, dt, tend_ru, tend_rtheta, tend_rho) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index ce0435c85a..9fa2dbc7ba 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -16,7 +16,6 @@ module atm_time_integration - use mpas_derived_types use mpas_pool_routines use mpas_kind_types use mpas_constants @@ -25,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 @@ -37,22 +37,10 @@ module atm_time_integration use mpas_atm_iau use mpas_atm_fdda + use mpas_atm_dissipation_models - ! - ! 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 @@ -86,6 +74,7 @@ end subroutine halo_exchange_routine !$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 @@ -157,6 +146,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('') @@ -178,6 +168,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 -----') @@ -261,18 +282,27 @@ 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 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 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 + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_s #endif #ifdef MPAS_CAM_DYCORE @@ -293,6 +323,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) @@ -362,104 +394,1080 @@ subroutine mpas_atm_dynamics_init(domain) call mpas_pool_get_array(mesh, 'cellsOnVertex', cellsOnVertex) !$acc enter data copyin(cellsOnVertex) - call mpas_pool_get_array(mesh, 'verticesOnCell', verticesOnCell) - !$acc enter data copyin(verticesOnCell) + 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) + + call mpas_pool_get_array(mesh, 'fEdge', fEdge) + !$acc enter data copyin(fEdge) + + call mpas_pool_get_array(mesh, 'zz', zz) + !$acc enter data copyin(zz) + + call mpas_pool_get_array(mesh, 'rdzw', rdzw) + !$acc enter data copyin(rdzw) + + call mpas_pool_get_array(mesh, 'rdzu', rdzu) + !$acc enter data copyin(rdzu) + + 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) + + call mpas_pool_get_array(mesh, 'nearestRelaxationCell', nearestRelaxationCell) + !$acc enter data copyin(nearestRelaxationCell) + + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + !$acc enter data copyin(zgrid) + + call mpas_pool_get_array(mesh, 'zxu', zxu) + !$acc enter data copyin(zxu) + + 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) + + call mpas_pool_get_array(mesh, 'meshScalingRegionalCell', meshScalingRegionalCell) + !$acc enter data copyin(meshScalingRegionalCell) + + call mpas_pool_get_array(mesh, 'meshScalingRegionalEdge', meshScalingRegionalEdge) + !$acc enter data copyin(meshScalingRegionalEdge) + + call mpas_pool_get_array(mesh, 'latCell', latCell) + !$acc enter data copyin(latCell) + + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + !$acc enter data copyin(lonCell) + + call mpas_pool_get_array(mesh, 'coeffs_reconstruct', coeffs_reconstruct) + !$acc enter data copyin(coeffs_reconstruct) + + call mpas_pool_get_array(mesh, 'latEdge', latEdge) + !$acc enter data copyin(latEdge) + + call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) + !$acc enter data copyin(angleEdge) + + call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) + !$acc enter data copyin(meshScalingDel2) + + 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) + + 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) + + MPAS_ACC_TIMER_STOP('mpas_dynamics_init [ACC_data_xfer]') +#endif + + 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) + + 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) + + 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) + + MPAS_ACC_TIMER_STOP('first_compute_solve_diagnostics [ACC_data_xfer]') +#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) + + 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) + !$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) + + MPAS_ACC_TIMER_STOP('first_compute_solve_diagnostics [ACC_data_xfer]') +#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 + + 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) + !$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_array(mesh, 'verticesOnEdge', verticesOnEdge) - !$acc enter data copyin(verticesOnEdge) + 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(mesh, 'invAreaTriangle', invAreaTriangle) - !$acc enter data copyin(invAreaTriangle) + 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(mesh, 'kiteForCell', kiteForCell) - !$acc enter data copyin(kiteForCell) + 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) - 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) + 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(mesh, 'fEdge', fEdge) - !$acc enter data copyin(fEdge) + call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) + !$acc enter data copyin(rthdynten) - call mpas_pool_get_array(mesh, 'zz', zz) - !$acc enter data copyin(zz) + MPAS_ACC_TIMER_STOP('atm_srk3 [ACC_data_xfer]') +#endif - call mpas_pool_get_array(mesh, 'rdzw', rdzw) - !$acc enter data copyin(rdzw) + end subroutine mpas_atm_pre_dynamics - call mpas_pool_get_array(mesh, 'rdzu', rdzu) - !$acc enter data copyin(rdzu) - call mpas_pool_get_array(mesh, 'zb_cell', zb_cell) - !$acc enter data copyin(zb_cell) + subroutine mpas_atm_post_dynamics(domain) - call mpas_pool_get_array(mesh, 'zb3_cell', zb3_cell) - !$acc enter data copyin(zb3_cell) + implicit none - call mpas_pool_get_array(mesh, 'fzm', fzm) - !$acc enter data copyin(fzm) + type (domain_type), intent(inout) :: domain - 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) +#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 - call mpas_pool_get_array(mesh, 'zb3', zb3) - !$acc enter data copyin(zb3) + logical, pointer :: config_apply_lbcs_ptr + logical :: config_apply_lbcs - call mpas_pool_get_array(mesh, 'nearestRelaxationCell', nearestRelaxationCell) - !$acc enter data copyin(nearestRelaxationCell) + 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 - call mpas_pool_get_array(mesh, 'zgrid', zgrid) - !$acc enter data copyin(zgrid) + 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 - call mpas_pool_get_array(mesh, 'zxu', zxu) - !$acc enter data copyin(zxu) + integer, pointer :: nCells_ptr + integer :: nCells + real (kind=RKIND), dimension(:,:), pointer :: uReconstructZonal, uReconstructMeridional, uReconstructX, uReconstructY, uReconstructZ - call mpas_pool_get_array(mesh, 'dss', dss) - !$acc enter data copyin(dss) + 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 - call mpas_pool_get_array(mesh, 'specZoneMaskCell', specZoneMaskCell) - !$acc enter data copyin(specZoneMaskCell) + real (kind=RKIND), dimension(:,:), pointer :: rthdynten, divergence, vorticity - call mpas_pool_get_array(mesh, 'meshScalingRegionalCell', meshScalingRegionalCell) - !$acc enter data copyin(meshScalingRegionalCell) + 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 - call mpas_pool_get_array(mesh, 'meshScalingRegionalEdge', meshScalingRegionalEdge) - !$acc enter data copyin(meshScalingRegionalEdge) + real (kind=RKIND), dimension(:,:,:), pointer :: lbc_scalars, lbc_tend_scalars - call mpas_pool_get_array(mesh, 'latCell', latCell) - !$acc enter data copyin(latCell) + 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_array(mesh, 'lonCell', lonCell) - !$acc enter data copyin(lonCell) + 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(mesh, 'coeffs_reconstruct', coeffs_reconstruct) - !$acc enter data copyin(coeffs_reconstruct) + 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) + !$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(mesh, 'defc_a', defc_a) - !$acc enter data copyin(defc_a) + 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_array(mesh, 'defc_b', defc_b) - !$acc enter data copyin(defc_b) + 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(mesh, 'latEdge', latEdge) - !$acc enter data copyin(latEdge) + 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(mesh, 'angleEdge', angleEdge) - !$acc enter data copyin(angleEdge) - call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) - !$acc enter data copyin(meshScalingDel2) + 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(mesh, 'meshScalingDel4', meshScalingDel4) - !$acc enter data copyin(meshScalingDel4) + 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_dynamics_init + end subroutine mpas_atm_post_dynamics !---------------------------------------------------------------------------- @@ -535,18 +1543,27 @@ 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 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 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 + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_s #endif @@ -697,6 +1714,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) @@ -715,12 +1744,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) @@ -732,6 +1755,33 @@ 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) + + 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 @@ -776,12 +1826,14 @@ subroutine atm_timestep(domain, dt, nowTime, itimestep, xtime_s, exchange_halo_g 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, xtime_s, 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 @@ -853,6 +1905,7 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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 @@ -869,8 +1922,8 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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_fdda => null() + type (mpas_pool_type), pointer :: tend_physics type (mpas_pool_type), pointer :: lbc ! regional_MPAS addition type (mpas_pool_type), pointer :: fdda @@ -879,6 +1932,8 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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 @@ -898,6 +1953,7 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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) @@ -1049,7 +2105,15 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, exchange_halo_group) ! ! Communicate halos for theta_m, scalars, pressure_p, and rtheta_p ! - call exchange_halo_group(domain, 'dynamics:theta_m,scalars,pressure_p,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) + call mpas_pool_get_array(diag, 'rtheta_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') @@ -1084,6 +2148,7 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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 @@ -1092,6 +2157,7 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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 ! @@ -1103,12 +2169,17 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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 ! @@ -1122,6 +2193,7 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, exchange_halo_group) + DYNAMICS_SUBSTEPS : do dynamics_substep = 1, dynamics_split ! Compute the coefficients for the vertically implicit solve in the acoustic step. @@ -1140,8 +2212,12 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, exchange_halo_group) !$OMP END PARALLEL DO call mpas_timer_stop('atm_compute_vert_imp_coefs') - call exchange_halo_group(domain, 'dynamics:exner') - + MPAS_ACC_TIMER_START('atm_srk3: halo_exchanges + ACC_data_xfer') + call mpas_pool_get_array(diag, 'exner', 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') !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! BEGIN Runge-Kutta loop @@ -1190,7 +2266,8 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, exchange_halo_group) !$OMP PARALLEL DO do thread=1,nThreads - call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, block % configs, nVertLevels, rk_step, dt, & + 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), & @@ -1219,7 +2296,12 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, exchange_halo_group) !*********************************** ! tend_u - call exchange_halo_group(domain, 'dynamics: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) 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') @@ -1295,7 +2377,12 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, exchange_halo_group) do small_step = 1, number_sub_steps(rk_step) - call exchange_halo_group(domain, 'dynamics:rho_pp') + 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) 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') @@ -1317,8 +2404,12 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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 exchange_halo_group(domain, 'dynamics:rtheta_pp') + 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) 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 @@ -1338,7 +2429,15 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, exchange_halo_group) ! ! Communicate halos for rw_p[1,2], ru_p[1,2], rho_pp[1,2], rtheta_pp[2] ! - call exchange_halo_group(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') + 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) + call mpas_pool_get_array(diag, 'rtheta_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') @@ -1373,7 +2472,6 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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 @@ -1385,12 +2483,10 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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 @@ -1402,7 +2498,6 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, exchange_halo_group) end if end do !$acc end parallel - !$acc exit data copyout(u) deallocate(ru_driving_values) @@ -1410,12 +2505,17 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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). ! PD or monotonicity constraints applied only on the final Runge-Kutta substep. @@ -1423,11 +2523,16 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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 - call exchange_halo_group(domain, 'dynamics:scalars') + 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) 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)) @@ -1479,17 +2584,27 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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) + !$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 exchange_halo_group(domain, 'dynamics:w,pv_edge,rho_edge,scalars') + call mpas_pool_get_array(state, 'scalars', scalars_2, 2) + !$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 @@ -1502,8 +2617,13 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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 exchange_halo_group(domain, 'dynamics:w') + call mpas_pool_get_array(state, 'w', w, 2) + !$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 @@ -1514,7 +2634,14 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, exchange_halo_group) ! ! Communicate halos for theta_m[1,2], pressure_p[1,2], and rtheta_p[1,2] ! - call exchange_halo_group(domain, 'dynamics:theta_m,pressure_p,rtheta_p') + 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) 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') ! ! Note: A halo exchange for 'exner' here as well as after the call @@ -1551,6 +2678,7 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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) @@ -1574,12 +2702,17 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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 exchange_halo_group(domain, 'dynamics:scalars') + call mpas_pool_get_array(state, 'scalars', scalars_2, 2) + !$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)) @@ -1605,7 +2738,12 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, exchange_halo_group) !------------------------------------------------------------------------------------------------------------------------ if (rk_step < 3) then - call exchange_halo_group(domain, 'dynamics:scalars') + 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) 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 end do RK3_SPLIT_TRANSPORT @@ -1627,7 +2765,8 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, exchange_halo_group) uReconstructY, & uReconstructZ, & uReconstructZonal, & - uReconstructMeridional & + uReconstructMeridional, & + lACC = .true. & ) @@ -1637,16 +2776,24 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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 @@ -1671,8 +2818,12 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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 @@ -1681,6 +2832,7 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, 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 ! @@ -1718,7 +2870,12 @@ subroutine atm_srk3(domain, dt, itimestep, xtime_s, exchange_halo_group) if (config_apply_lbcs) then ! adjust boundary values for regional_MPAS scalar transport - call exchange_halo_group(domain, 'dynamics:scalars') + 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) 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)) @@ -1771,7 +2928,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 @@ -1784,6 +2941,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 @@ -1915,7 +3073,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 @@ -1995,12 +3153,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 @@ -2048,12 +3200,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 @@ -2104,11 +3250,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 @@ -2157,10 +3298,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 @@ -2194,12 +3331,15 @@ 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) + call mpas_pool_get_array(mesh, 'ewm', ewm) call mpas_pool_get_array(mesh, 'rdzu', rdzu) call mpas_pool_get_array(mesh, 'rdzw', rdzw) @@ -2231,9 +3371,10 @@ 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, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -2241,9 +3382,10 @@ 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, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -2257,7 +3399,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 @@ -2279,6 +3420,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 @@ -2292,14 +3435,9 @@ 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 - dtseps = .5*dts*(1.+epssm) rcv = rgas/(cp-rgas) c2 = cp*rcv @@ -2307,7 +3445,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) end do !$acc end parallel @@ -2318,15 +3456,15 @@ 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)) 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) = 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 @@ -2339,9 +3477,10 @@ 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*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 @@ -2356,31 +3495,33 @@ 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) + + 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) end do + 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) + 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 !$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 @@ -2484,9 +3625,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 @@ -2519,10 +3657,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 @@ -2576,10 +3710,10 @@ 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 + integer, pointer :: nEdges, nCellsSolve call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) @@ -2589,6 +3723,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) @@ -2646,16 +3785,14 @@ 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 & ) @@ -2668,7 +3805,8 @@ 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 & ) @@ -2722,6 +3860,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 @@ -2738,7 +3880,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 @@ -2747,25 +3889,13 @@ 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]') - !$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 @@ -2907,31 +4037,32 @@ 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) & + - 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) + 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)) + 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 @@ -2939,7 +4070,7 @@ 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)-(dts**2)*a_tri(k,iCell)*rw_p(k-1,iCell))*alpha_tri(k,iCell) end do !MGD VECTOR DEPENDENCE @@ -2964,7 +4095,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) end do ! update rho_pp and theta_pp given updated rw_p @@ -2972,9 +4103,10 @@ 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) - 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 @@ -2984,7 +4116,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) end do end if @@ -2992,13 +4124,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 @@ -3050,9 +4175,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 @@ -3085,10 +4207,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 @@ -3279,17 +4397,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... @@ -3435,17 +4542,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 @@ -3680,10 +4776,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 @@ -3778,12 +4870,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]') @@ -3866,9 +4952,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 @@ -3889,7 +4973,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 @@ -3910,6 +4994,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 @@ -3988,7 +5073,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) @@ -4036,7 +5121,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 @@ -4052,6 +5137,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 @@ -4126,22 +5212,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 @@ -4164,19 +5234,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 exit data copyout(scalar_tend) - - !$acc update self(scalars_old) + !$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) + !$acc update device(scalars_old) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') ! @@ -4228,13 +5296,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 @@ -4579,17 +5641,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) + !$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) + !$acc update device(scale_arr) if (.not. config_gpu_aware_mpi) MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') !$acc parallel @@ -4737,23 +5799,12 @@ 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 - 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, dynamics_substep, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -4769,19 +5820,22 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + use mpas_atm_dissipation_models, only : les_model_from_string, les_surface_from_string + implicit none ! ! 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 + 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 + 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 @@ -4797,7 +5851,9 @@ 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, 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 @@ -4807,7 +5863,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 @@ -4822,19 +5878,30 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:), pointer :: rdzu, rdzw, fzm, fzp, qv_init real (kind=RKIND), dimension(:,:), pointer :: t_init + real (kind=RKIND), dimension(:), pointer:: ustm, hfx, qfx real (kind=RKIND), pointer :: cf1, cf2, cf3 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 + real(kind=RKIND), dimension(:,:), pointer :: tend_w_pgf, tend_w_buoy 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 + 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 real (kind=RKIND), pointer :: config_del4u_div_factor real (kind=RKIND), pointer :: config_h_theta_eddy_visc4 real (kind=RKIND), pointer :: config_h_mom_eddy_visc4 @@ -4847,12 +5914,22 @@ 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 :: index_qv, index_qc, index_tke + + logical :: inactive_rthdynten + logical :: nopbl 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) + call mpas_pool_get_config(configs, 'config_surface_heat_flux', config_surface_heat_flux) + call mpas_pool_get_config(configs, 'config_surface_moisture_flux', config_surface_moisture_flux) + call mpas_pool_get_config(configs, 'config_surface_drag_coefficient', config_surface_drag_coefficient) call mpas_pool_get_config(configs, 'config_del4u_div_factor', config_del4u_div_factor) call mpas_pool_get_config(configs, 'config_h_theta_eddy_visc4', config_h_theta_eddy_visc4) call mpas_pool_get_config(configs, 'config_h_mom_eddy_visc4', config_h_mom_eddy_visc4) @@ -4883,7 +5960,9 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, 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) 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) @@ -4896,9 +5975,32 @@ 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) + nullify(ustm) + nullify(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) & + .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) @@ -4922,8 +6024,11 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, 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) + 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) @@ -4947,6 +6052,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) @@ -4963,6 +6070,9 @@ 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_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) @@ -4974,53 +6084,73 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, 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, moist_start, moist_end, & + 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, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + 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, & 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, & - tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & + 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, & 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, & - rthdynten, & + config_surface_heat_flux, config_surface_moisture_flux, config_surface_drag_coefficient, & + rthdynten, ustm, hfx, qfx, & 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 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, 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, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + 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, & 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, & - tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & + 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, & 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, & - rthdynten, & + config_surface_heat_flux, config_surface_moisture_flux, config_surface_drag_coefficient, & + rthdynten, ustm, hfx, qfx, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) use mpas_atm_dimensions + use mpas_atm_dissipation_models, only : LES_MODEL_NONE implicit none @@ -5030,7 +6160,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, index_qc, moist_start, moist_end, index_tke real (kind=RKIND), dimension(nEdges+1) :: fEdge real (kind=RKIND), dimension(nEdges+1) :: dvEdge @@ -5069,7 +6199,11 @@ 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 + 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 real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw_save @@ -5079,6 +6213,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 @@ -5115,15 +6250,20 @@ 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 real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_pgf 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 + 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 real (kind=RKIND) :: config_del4u_div_factor real (kind=RKIND) :: config_h_theta_eddy_visc4 real (kind=RKIND) :: config_h_mom_eddy_visc4 @@ -5131,7 +6271,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 - 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 @@ -5155,6 +6295,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 @@ -5172,6 +6316,9 @@ 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) :: reference_u + flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ua*( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 @@ -5181,43 +6328,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 (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 create(kdiff) - !$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) - !$acc enter data copyin(u_init, v_init) - 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) + if (les_model_opt /= LES_MODEL_NONE) then + !$acc enter data copyin(bn2) 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 copyin(ustm, hfx, qfx) !$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) -#ifdef CURVATURE - !$acc enter data copyin(ur_cell, vr_cell) -#endif + !$acc enter data create(eddy_visc_horz) + !$acc enter data create(eddy_visc_vert) + !$acc enter data create(prandtl_3d_inv) MPAS_ACC_TIMER_STOP('atm_compute_dyn_tend_work [ACC_data_xfer]') prandtl_inv = 1.0_RKIND / prandtl @@ -5240,57 +6358,51 @@ 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 + if(les_model_opt == LES_MODEL_NONE) then - !$acc parallel default(present) - !$acc loop gang worker private(d_diag, d_off_diag) - do iCell = cellStart,cellEnd + if(config_horiz_mixing == "2d_smagorinsky") then - !$acc loop vector - do k = 1, nVertLevels - d_diag(k) = 0.0_RKIND - d_off_diag(k) = 0.0_RKIND - end do + 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 ) - !$acc loop seq - do iEdge=1,nEdgesOnCell(iCell) + else if(config_horiz_mixing == "2d_fixed") then + + !$acc parallel default(present) + !$acc loop gang worker + do iCell = cellStart, cellEnd !$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)) + do k = 1, nVertLevels + eddy_visc_horz(k,iCell) = config_h_theta_eddy_visc2 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) - end do - end do - !$acc end parallel + !$acc end parallel + + h_mom_eddy_visc4 = config_h_mom_eddy_visc4 + h_theta_eddy_visc4 = config_h_theta_eddy_visc4 - h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 - h_theta_eddy_visc4 = h_mom_eddy_visc4 + end if - else if(config_horiz_mixing == "2d_fixed") then + else if (les_model_opt /= LES_MODEL_NONE) then - !$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 + ! call mpas_log_write(' BV call, index qv, qc, tke $i $i $i ', intArgs=(/index_qv, index_qc, index_tke/)) - h_mom_eddy_visc4 = config_h_mom_eddy_visc4 - h_theta_eddy_visc4 = config_h_theta_eddy_visc4 + call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & + cellStart, cellEnd, nCells) + + 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, & + 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 @@ -5307,7 +6419,7 @@ 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 end do !$acc end parallel @@ -5317,8 +6429,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) @@ -5400,281 +6510,112 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc loop vector do k=1,nVertLevels tend_u_euler(k,iEdge) = - cqu(k,iEdge)*( (pp(k,cell2)-pp(k,cell1))*invDcEdge(iEdge)/(.5*(zz(k,cell2)+zz(k,cell1))) & - -0.5*zxu(k,iEdge)*(dpdz(k,cell1)+dpdz(k,cell2)) ) - end do - - end if - - ! vertical transport of u - - wduz(1) = 0. - - k = 2 - wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2))*(fzm(k)*u(k,iEdge)+fzp(k)*u(k-1,iEdge)) - !$acc loop vector - do k=3,nVertLevels-1 - wduz(k) = flux3( u(k-2,iEdge),u(k-1,iEdge),u(k,iEdge),u(k+1,iEdge),0.5*(rw(k,cell1)+rw(k,cell2)), 1.0_RKIND ) - end do - k = nVertLevels - wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2))*(fzm(k)*u(k,iEdge)+fzp(k)*u(k-1,iEdge)) - - wduz(nVertLevels+1) = 0. - -!DIR$ IVDEP - !$acc loop vector - do k=1,nVertLevels - tend_u(k,iEdge) = - rdzw(k)*(wduz(k+1)-wduz(k)) ! first use of tend_u - end do - - ! Next, nonlinear Coriolis term (q) following Ringler et al JCP 2009 - - !$acc loop vector - do k=1,nVertLevels - q(k) = 0.0_RKIND - end do - - !$acc loop seq - do j = 1,nEdgesOnEdge(iEdge) - eoe = edgesOnEdge(j,iEdge) - - !$acc loop vector - do k=1,nVertLevels - workpv = 0.5 * (pv_edge(k,iEdge) + pv_edge(k,eoe)) -! the original definition of pv_edge had a factor of 1/density. We have removed that factor -! given that it was not integral to any conservation property of the system - q(k) = q(k) + weightsOnEdge(j,iEdge) * u(k,eoe) * workpv - end do - end do - -!DIR$ IVDEP - !$acc loop vector - do k=1,nVertLevels - - ! horizontal ke gradient and vorticity terms in the vector invariant formulation - ! of the horizontal momentum equation - tend_u(k,iEdge) = tend_u(k,iEdge) + rho_edge(k,iEdge)* (q(k) - (ke(k,cell2) - ke(k,cell1)) & - * invDcEdge(iEdge)) & - - u(k,iEdge)*0.5*(h_divergence(k,cell1)+h_divergence(k,cell2)) -#ifdef CURVATURE - ! curvature terms for the sphere - tend_u(k,iEdge) = tend_u(k,iEdge) & - - 2.*omega*cos(angleEdge(iEdge))*cos(latEdge(iEdge)) & - *rho_edge(k,iEdge)*.25*(w(k,cell1)+w(k+1,cell1)+w(k,cell2)+w(k+1,cell2)) & - - u(k,iEdge)*.25*(w(k+1,cell1)+w(k,cell1)+w(k,cell2)+w(k+1,cell2)) & - *rho_edge(k,iEdge) * inv_r_earth -#endif - end do - - end do - !$acc end parallel - - ! - ! horizontal mixing for u - ! mixing terms are integrated using forward-Euler, so this tendency is only computed in the - ! first Runge-Kutta substep and saved for use in later RK substeps 2 and 3. - ! - - if (rk_step == 1) then - -!$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)) + -0.5*zxu(k,iEdge)*(dpdz(k,cell1)+dpdz(k,cell2)) ) + end do -!DIR$ IVDEP - !$acc loop vector - do k=1,nVertLevels + end if - ! 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 transport of u - ! - ! vertical mixing for u - 2nd order filter in physical (z) space - ! - if ( v_mom_eddy_visc2 > 0.0 ) then + wduz(1) = 0. - if (config_mix_full) then ! mix full state + k = 2 + wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2))*(fzm(k)*u(k,iEdge)+fzp(k)*u(k-1,iEdge)) + !$acc loop vector + do k=3,nVertLevels-1 + wduz(k) = flux3( u(k-2,iEdge),u(k-1,iEdge),u(k,iEdge),u(k+1,iEdge),0.5*(rw(k,cell1)+rw(k,cell2)), 1.0_RKIND ) + end do + k = nVertLevels + wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2))*(fzm(k)*u(k,iEdge)+fzp(k)*u(k-1,iEdge)) - !$acc parallel default(present) - !$acc loop gang worker - do iEdge=edgeSolveStart,edgeSolveEnd + wduz(nVertLevels+1) = 0. - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) +!DIR$ IVDEP + !$acc loop vector + do k=1,nVertLevels + tend_u(k,iEdge) = - rdzw(k)*(wduz(k+1)-wduz(k)) ! first use of tend_u + end do - !$acc loop vector - do k=2,nVertLevels-1 + ! Next, nonlinear Coriolis term (q) following Ringler et al JCP 2009 - 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)) + !$acc loop vector + do k=1,nVertLevels + q(k) = 0.0_RKIND + end do - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) + !$acc loop seq + do j = 1,nEdgesOnEdge(iEdge) + eoe = edgesOnEdge(j,iEdge) - 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 + !$acc loop vector + do k=1,nVertLevels + workpv = 0.5 * (pv_edge(k,iEdge) + pv_edge(k,eoe)) +! the original definition of pv_edge had a factor of 1/density. We have removed that factor +! given that it was not integral to any conservation property of the system + q(k) = q(k) + weightsOnEdge(j,iEdge) * u(k,eoe) * workpv + end do + end do - else ! idealized cases where we mix on the perturbation from the initial 1-D state + if (perturbation_coriolis) then ! this is correct only for constant f + !$acc loop seq + do j = 1,nEdgesOnEdge(iEdge) + eoe = edgesOnEdge(j,iEdge) - !$acc parallel default(present) - !$acc loop gang worker private(u_mix) - do iEdge=edgeSolveStart,edgeSolveEnd + !$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) +! q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * 0.729210E-04 + end do + end do + end if - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) +!DIR$ IVDEP + !$acc loop vector + do k=1,nVertLevels - !$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 + ! horizontal ke gradient and vorticity terms in the vector invariant formulation + ! of the horizontal momentum equation + tend_u(k,iEdge) = tend_u(k,iEdge) + rho_edge(k,iEdge)* (q(k) - (ke(k,cell2) - ke(k,cell1)) & + * invDcEdge(iEdge)) & + - u(k,iEdge)*0.5*(h_divergence(k,cell1)+h_divergence(k,cell2)) +#ifdef CURVATURE + ! curvature terms for the sphere + tend_u(k,iEdge) = tend_u(k,iEdge) & + - 2.*omega*cos(angleEdge(iEdge))*cos(latEdge(iEdge)) & + *rho_edge(k,iEdge)*.25*(w(k,cell1)+w(k+1,cell1)+w(k,cell2)+w(k+1,cell2)) & + - u(k,iEdge)*.25*(w(k+1,cell1)+w(k,cell1)+w(k,cell2)+w(k+1,cell2)) & + *rho_edge(k,iEdge) * inv_r_earth +#endif + end do - !$acc loop vector - do k=2,nVertLevels-1 + end do + !$acc end parallel - 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)) + ! + ! horizontal mixing for u + ! mixing terms are integrated using forward-Euler, so this tendency is only computed in the + ! first Runge-Kutta substep and saved for use in later RK substeps 2 and 3. + ! - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) + if (rk_step == 1) then - 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 +!$OMP BARRIER - end if ! mix perturbation state + 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, 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 ) - end if ! vertical mixing of horizontal momentum end if ! (rk_step 1 test for computing mixing terms) @@ -5802,82 +6743,20 @@ 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 - - end if ! horizontal mixing for w computed in first rk_step + 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, & + les_model_opt, les_surface_opt, & + tend_w_euler ) + + 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, @@ -5930,27 +6809,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) @@ -6041,69 +6899,25 @@ 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 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, & + les_model_opt, les_surface_opt, clock, dt, & + 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 @@ -6144,116 +6958,26 @@ 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 !$acc end parallel MPAS_ACC_TIMER_START('atm_compute_dyn_tend_work [ACC_data_xfer]') - 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(kdiff) - !$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) - !$acc exit data delete(u_init, v_init) - 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) + if (les_model_opt /= LES_MODEL_NONE) then + !$acc exit data copyout(bn2) 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(ustm, hfx, qfx) !$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) -#ifdef CURVATURE - !$acc exit data delete(ur_cell, vr_cell) -#endif + !$acc exit data delete(eddy_visc_horz) + !$acc exit data delete(eddy_visc_vert) + !$acc exit data delete(prandtl_3d_inv) MPAS_ACC_TIMER_STOP('atm_compute_dyn_tend_work [ACC_data_xfer]') end subroutine atm_compute_dyn_tend_work @@ -6422,26 +7146,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 @@ -6526,9 +7234,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 @@ -6623,14 +7328,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 @@ -6658,9 +7355,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 @@ -6684,9 +7378,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 @@ -6704,9 +7395,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 @@ -6745,9 +7433,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 @@ -6764,31 +7449,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 @@ -6877,17 +7541,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]') @@ -7011,17 +7671,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]') @@ -7088,13 +7743,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 @@ -7199,13 +7847,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 @@ -7260,9 +7901,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 @@ -7278,9 +7916,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 @@ -7321,11 +7956,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 @@ -7352,11 +7982,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 @@ -7442,10 +8067,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) @@ -7590,11 +8212,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 @@ -7628,10 +8246,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 @@ -7646,11 +8260,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 !------------------------------------------------------------------------- @@ -7739,10 +8348,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 @@ -7824,10 +8430,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 @@ -7897,10 +8500,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 @@ -7921,10 +8520,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 @@ -7994,16 +8589,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('') @@ -8362,17 +8947,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 1e2e77dc98..6d49af72a5 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 @@ -43,11 +30,15 @@ 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 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 @@ -295,6 +286,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 @@ -390,6 +388,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 @@ -421,6 +420,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) @@ -472,6 +475,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) @@ -509,6 +516,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 @@ -527,6 +535,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) @@ -540,13 +549,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: @@ -566,6 +580,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 +591,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 @@ -1033,9 +1048,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 @@ -1067,6 +1085,10 @@ subroutine atm_do_timestep(domain, dt, itimestep) endif #endif +#ifdef DO_CHEMISTRY + call chemistry_step() +#endif + call atm_timestep(domain, dt, currTime, itimestep, xtime_s, exchange_halo_group) end subroutine atm_do_timestep @@ -1085,6 +1107,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 @@ -1101,6 +1127,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) @@ -1298,8 +1331,11 @@ 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 + + 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) @@ -1307,14 +1343,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) @@ -1322,11 +1356,83 @@ 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 + 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, + +#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 + 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)) +#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 + 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)) +#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) + deallocate(epssm_coeff_u) + deallocate(height_w_levels) + deallocate(epssm_coeff_w) + end subroutine atm_compute_damping_coefs @@ -1558,5 +1664,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 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/Makefile b/src/core_atmosphere/physics/Makefile index 75eec25931..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 -I../../external/esmf_time_f90 + $(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 -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/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 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.') diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index 5e851ad923..5183f5a974 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -73,13 +73,14 @@ module mpas_atmphys_init ! Laura D. Fowler (laura@ucar.edu) / 2024-02-14. ! * added call to subroutine init_lsm_noahmp to initialize the Noah-MP land surface scheme. ! Laura D. Fowler (laura@ucar.edu) / 2024-03-11. - +! * added initialization of the integer variable mp_top_level to the physics_init code. +! Bill Skamarock / 2025-10-17 contains !================================================================================================================= - 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) !================================================================================================================= @@ -98,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 @@ -149,13 +151,16 @@ subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,state integer,dimension(:),pointer:: jindx1_tau, jindx2_tau real(kind=RKIND),dimension(:),pointer:: ddy_j1tau, ddy_j2tau real(kind=RKIND),dimension(:),pointer:: latCell + real(kind=RKIND),pointer:: config_microphysics_top + integer,pointer:: mp_top_level !local variables and arrays: type(MPAS_Time_Type):: currTime logical:: init_done integer:: ierr,julday - integer:: iCell,iLag + integer:: iCell,iLag,k + real(kind=RKIND):: layer_height !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') @@ -170,6 +175,7 @@ subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,state call mpas_pool_get_config(configs,'config_sfclayer_scheme' ,config_sfclayer_scheme ) call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) + call mpas_pool_get_config(configs,'config_microphysics_top' ,config_microphysics_top ) call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) call mpas_pool_get_dimension(mesh,'nLags' ,nLags ) @@ -237,6 +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(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) @@ -265,6 +272,17 @@ subroutine physics_init(dminfo,stream_manager,clock,configs,mesh,diag,tend,state enddo endif +! set the level above which microphysics tendencies will be ignored + mp_top_level = 0 + layer_height = 0.5/rdzw(1) + if(layer_height .le. config_microphysics_top) mp_top_level = 1 + do k=2,nVertLevels + layer_height = layer_height + dzu(k) + if(layer_height .le. config_microphysics_top) mp_top_level = k + end do + call mpas_log_write('physics init: config_microphysics_top and level $r $i ', & + realArgs=(/config_microphysics_top/),intArgs=(/mp_top_level/)) + !initialization of counters i_acsw* and i_aclw*. i_acsw* and i_aclw* track the number of times !the accumulated long and short-wave radiation fluxes exceed their prescribed theshold values. if(.not. config_do_restart) then 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_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index 71e46dfcd2..feeb8db80f 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -6,17 +6,29 @@ ! 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 public:: allocate_forall_physics, & deallocate_forall_physics, & + pre_microphysics, & + post_microphysics, & MPAS_to_physics, & microphysics_from_MPAS, & microphysics_to_MPAS @@ -64,7 +76,8 @@ module mpas_atmphys_interface ! Laura D. Fowler (laura@ucar.edu) / 2016-04-11. ! * corrected the calculation of the surface pressure, mainly extrapolation of the air density to the surface. ! Laura D. Fowler (laura@ucar.edu) / 2016-04-25. - +! * changed microphysics update such that the microphsyics tendency is ignored above level mp_top_level +! Bill Skamarock / 2025/10/17 contains @@ -545,6 +558,42 @@ 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 + + + 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) + + 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) + + MPAS_ACC_TIMER_STOP('pre_microphysics [ACC_data_xfer]') +#endif + +end subroutine pre_microphysics + !================================================================================================================= subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend_physics,its,ite) !================================================================================================================= @@ -649,7 +698,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) @@ -810,6 +859,7 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te real(kind=RKIND),dimension(:,:),pointer :: rthmpten,rqvmpten,rqcmpten,rqrmpten,rqimpten,rqsmpten,rqgmpten real(kind=RKIND),dimension(:,:),pointer :: rncmpten,rnimpten,rnrmpten,rnifampten,rnwfampten real(kind=RKIND),dimension(:,:,:),pointer:: scalars + integer,pointer:: mp_top_level !local variables: integer:: icount @@ -823,6 +873,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(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 ) call mpas_pool_get_array(diag,'pressure_base' ,pressure_b ) @@ -849,7 +901,7 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te !update variables needed in the dynamical core: do j = jts,jte - do k = kts,kte + do k = kts,mp_top_level do i = its,ite !initializes tendency of coupled potential temperature potential temperature, and @@ -881,6 +933,18 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te enddo enddo + ! no microphysics updates above mp_top_level + ! why are we not applying this to theta and qv? + if(kte .gt. mp_top_level) then + do i = its,ite + do k = mp_top_level+1,kte + qc(k,i) = 0. + qr(k,i) = 0. + rt_diabatic_tend(k,i) = 0. + enddo + enddo + endif + !update surface pressure and calculates the surface pressure tendency: do j = jts,jte do i = its,ite @@ -917,7 +981,7 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te call mpas_pool_get_array(diag_physics,'refl10cm',refl10cm) do j = jts,jte - do k = kts,kte + do k = kts,mp_top_level do i = its,ite qi(k,i) = qi_p(i,k,j) qs(k,i) = qs_p(i,k,j) @@ -932,6 +996,22 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te enddo enddo + ! no microphysics updates above mp_top_level + if(kte .gt. mp_top_level) then + do i = its,ite + do k = mp_top_level+1,kte + qi(k,i) = 0. + qs(k,i) = 0. + qg(k,i) = 0. + rainprod(k,i) = 0. + evapprod(k,i) = 0. + re_cloud(k,i) = re_qc_bg + re_ice(k,i) = re_qi_bg + re_snow(k,i) = re_qs_bg + enddo + enddo + end if + mp2_select: select case(trim(mp_scheme)) case("mp_thompson","mp_thompson_aerosols") call mpas_pool_get_dimension(state,'index_ni',index_ni) @@ -993,8 +1073,8 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te call mpas_pool_get_array(tend_physics,'rqsmpten',rqsmpten) call mpas_pool_get_array(tend_physics,'rqgmpten',rqgmpten) - do k = kts,kte do i = its,ite + do k = kts,mp_top_level rthmpten(k,i) = (theta_m(k,i)/(1._RKIND+R_v/R_d*max(0._RKIND,qv(k,i)))-rthmpten(k,i))/dt_dyn rqvmpten(k,i) = (qv(k,i)-rqvmpten(k,i))/dt_dyn rqcmpten(k,i) = (qc(k,i)-rqcmpten(k,i))/dt_dyn @@ -1005,6 +1085,21 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te enddo enddo + ! no microphysics tendency above level mp_top_level + if(kte .gt. mp_top_level) then + do i = its, ite + do k = mp_top_level+1, kte + rthmpten(k,i) = 0. + rqvmpten(k,i) = 0. + rqcmpten(k,i) = 0. + rqrmpten(k,i) = 0. + rqimpten(k,i) = 0. + rqsmpten(k,i) = 0. + rqgmpten(k,i) = 0. + enddo + enddo + endif + mp2_tend_select: select case(trim(mp_scheme)) case("mp_thompson","mp_thompson_aerosols") call mpas_pool_get_array(tend_physics,'rnimpten',rnimpten) @@ -1042,6 +1137,50 @@ 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) + + + 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 + !================================================================================================================= end module mpas_atmphys_interface !================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F index 19ad287d00..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,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 diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index 3163ceb9a1..3cc8a43c8d 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 @@ -13,10 +22,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, tend_toEdges + public:: physics_get_tend, pre_physics_get_tend, post_physics_get_tend, tend_toEdges !Interface between the physics parameterizations and the non-hydrostatic dynamical core. @@ -41,25 +51,48 @@ 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) + ! Provides definition of halo_exchange_routine +#include "mpas_halo_interface.inc" - use mpas_derived_types, only : domain_type - type (domain_type), intent(inout) :: domain - character(len=*), intent(in) :: halo_group - integer, intent(out), optional :: ierr + contains - end subroutine halo_exchange_routine - end interface +!================================================================================================================= + subroutine pre_physics_get_tend(configs,state,diag,tend) +!================================================================================================================= - contains +!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 + + 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 ) + 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 + MPAS_ACC_TIMER_STOP('atm_srk3: physics ACC_data_xfer') +#endif + + end subroutine pre_physics_get_tend !================================================================================================================= subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_step,dynamics_substep, & @@ -245,6 +278,28 @@ 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 + + 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 + !================================================================================================================= subroutine physics_get_tend_work( & block,mesh,nCells,nEdges,nCellsSolve,nEdgesSolve,rk_step,dynamics_substep, & 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) 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..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 -I../../../external/esmf_time_f90 + $(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 -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/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_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) 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/core_atmosphere/utils/Makefile b/src/core_atmosphere/utils/Makefile index 39765f9ee9..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) -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_LIB) 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_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 30e7e3c600..bec5b2c4bb 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + @@ -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"/> + + + + - - @@ -570,8 +579,6 @@ - - @@ -1119,13 +1126,6 @@ - - - - - @@ -1189,6 +1189,8 @@ + 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 diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index f683ea39bb..b5924be7cf 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 @@ -368,9 +369,30 @@ 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 + else if (config_init_case == 10) then - call mpas_log_write('Creating FDDA nudging analyses case') + 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 == 11 ) then + + call mpas_log_write('FDDA analysis nudging case') ! ! Check that the first-guess interval (which is the same as the clock timestep) @@ -431,7 +453,6 @@ subroutine init_atm_setup_case(domain, stream_manager) ! call mpas_stream_mgr_reset_alarms(stream_manager, streamID='fdda', direction=MPAS_STREAM_OUTPUT, ierr=ierr) - else if (config_init_case == 13 ) then call mpas_log_write(' CAM-MPAS grid ') @@ -464,7 +485,7 @@ subroutine init_atm_setup_case(domain, stream_manager) 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 @@ -2826,6 +2847,8 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state integer, pointer :: config_nsm real (kind=RKIND), pointer :: config_dzmin real (kind=RKIND), pointer :: config_ztop + logical, pointer :: config_hybrid_coordinate + real (kind=RKIND), pointer :: config_hybrid_top_z logical, pointer :: config_tc_vertical_grid character (len=StrKIND), pointer :: config_specified_zeta_levels logical, pointer :: config_use_spechumd @@ -2902,6 +2925,8 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state call mpas_pool_get_config(configs, 'config_nsm', config_nsm) call mpas_pool_get_config(configs, 'config_dzmin', config_dzmin) call mpas_pool_get_config(configs, 'config_ztop', config_ztop) + call mpas_pool_get_config(configs, 'config_hybrid_coordinate', config_hybrid_coordinate) + call mpas_pool_get_config(configs, 'config_hybrid_top_z', config_hybrid_top_z) call mpas_pool_get_config(configs, 'config_tc_vertical_grid', config_tc_vertical_grid) call mpas_pool_get_config(configs, 'config_specified_zeta_levels', config_specified_zeta_levels) call mpas_pool_get_config(configs, 'config_use_spechumd', config_use_spechumd) @@ -3220,38 +3245,36 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state ! ah(k) = 1.-zw(k)/zt is the basic terrain-following coordinate ! ah(k) = 0 is a height coordinate - hybrid = .true. -! hybrid = .false. - kz = nz - if (hybrid) then + if (config_hybrid_coordinate) then - zh = 30000.0 -! zh = 0.5*zt - + zh = config_hybrid_top_z do k=1,nz if (zw(k) < zh) then ah(k) = cos(.5*pii*zw(k)/zh)**6 - -!!! ah(k) = ah(k)*(1.-zw(k)/zt) - else ah(k) = 0. kz = min(kz,k) end if end do + call mpas_log_write('Hybrid vertical coordinate is used. Transition height, ztop are $r $r ',realArgs=(/config_hybrid_top_z,zt/)) else + zh = zt do k=1,nz ah(k) = 1.-zw(k)/zt end do + call mpas_log_write('Hybrid vertical coordinate is not selected. ztop is ',realArgs=(/zt/)) end if + call mpas_log_write(' ') + call mpas_log_write(' interface k, height, ah value ') do k=1,nz call mpas_log_write('$i $r $r', intArgs=(/k/), realArgs=(/zw(k), ah(k)/)) end do + call mpas_log_write(' ') do k=1,nz1 dzw (k) = zw(k+1)-zw(k) @@ -3302,6 +3325,12 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state if (smooth) then + call mpas_log_write(' ') + call mpas_log_write(' surfaces will be smoothed, dzmin = $r ',realArgs=(/config_dzmin/)) + call mpas_log_write(' base number of smoothing passes = $i ',intArgs=(/config_nsm/)) + call mpas_log_write(' ') + call mpas_log_write(' level, smoothing steps, smoothing factor, smallest fractional dz ') + dzmin = config_dzmin allocate(sm0(nCells+1)) @@ -3322,7 +3351,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state do i=1,config_nsm + k do iCell=1,nCells - sm = sm0(iCell) * min((3.0*zw(k)/zt)**2.0, 1.0_RKIND) + sm = sm0(iCell) * min((3.0*zw(k)/zh)**2.0, 1.0_RKIND) hs1(iCell) = 0. do j = 1,nEdgesOnCell(iCell) @@ -3367,7 +3396,8 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state call mpas_dmpar_min_real(dminfo, dzminf, dzminf_global) call mpas_log_write('$i $i $r $r', intArgs=(/k,i/), realArgs=(/sm,dzminf_global/(zw(k)-zw(k-1))/)) end do - + call mpas_log_write(' ') + deallocate(sm0) do k=kz,nz @@ -3376,10 +3406,15 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state else + call mpas_log_write(' ') + call mpas_log_write(' surfaces are not smoothed ') + call mpas_log_write(' level, smallest fractional dz ') + do k=2,nz1 dzmina = minval(zw(k)+ah(k)*hx(k,:)-zw(k-1)-ah(k-1)*hx(k-1,:)) call mpas_log_write('$i $r', intArgs=(/k/), realArgs=(/dzmina/(zw(k)-zw(k-1))/)) end do + call mpas_log_write(' ') end if @@ -4568,9 +4603,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 @@ -6249,182 +6281,868 @@ subroutine init_atm_case_lbc(timestamp, block, mesh, nCells, nEdges, nVertLevels end subroutine init_atm_case_lbc +!--------------------- - !----------------------------------------------------------------------- - ! routine init_atm_case_fdda - ! - !> \brief Computes theta_fdda, qv_fdda, u_fdda, v_fdda fields for FDDA nudging - !> \details - !> This routine is similar to the init_atm_case_lbc routine in that it reads - !> atmospheric fields from "intermediate" files and horizontally and vertically - !> interpolates them to an MPAS mesh.However, it also includes the reconstructed - !> wind fields as originally in the FDDA nudging code. This routine is responsible for - !> producing only those fields that are needed for FDDA nudging. - ! - !----------------------------------------------------------------------- - subroutine init_atm_case_fdda(timestamp, block, mesh, nCells, nEdges, nVertLevels, fg, state, diag, fdda_state, dims, configs) - - use mpas_dmpar, only : mpas_dmpar_min_real, mpas_dmpar_max_real - use init_atm_read_met, only : met_data, read_met_init, read_met_close, read_next_met_field - use init_atm_llxy, only : proj_info, map_init, map_set, latlon_to_ij, PROJ_LATLON, PROJ_GAUSS, DEG_PER_RAD - use init_atm_hinterp, only : interp_sequence, FOUR_POINT, SIXTEEN_POINT, W_AVERAGE4, SEARCH - use mpas_hash, only : hashtable, mpas_hash_init, mpas_hash_destroy, mpas_hash_search, mpas_hash_size, mpas_hash_insert + subroutine init_atm_case_les(dminfo, mesh, fg, nCells, nVertLevels, state, diag, test_case, configs) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Large Eddy Simulation (les) test case setup + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! implicit none - character(len=*), intent(in) :: timestamp - type (block_type), intent(inout), target :: block + 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) :: nEdges integer, intent(in) :: nVertLevels - type (mpas_pool_type), intent(inout) :: fg type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(inout) :: diag - type (mpas_pool_type), intent(inout):: fdda_state - type (mpas_pool_type), intent(inout):: dims type (mpas_pool_type), intent(inout):: configs - type (parallel_info), pointer :: parinfo - type (dm_info), pointer :: dminfo - - real (kind=RKIND), parameter :: t0b = 250.0 - - type (met_data) :: field - type (proj_info) :: proj + integer, intent(in) :: test_case - real (kind=RKIND), dimension(:), pointer :: dzu, fzm, fzp - real (kind=RKIND), dimension(:), pointer :: vert_level, latPoints, lonPoints - real (kind=RKIND), dimension(:,:), pointer :: zgrid, zz - real (kind=RKIND), dimension(:,:), pointer :: pressure, ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, t, rt - real (kind=RKIND), dimension(:), pointer :: destField1d - real (kind=RKIND), dimension(:,:), pointer :: destField2d - real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 + 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 - real (kind=RKIND) :: target_z - integer :: iCell, iEdge, i, k, nVertLevelsP1 - integer, pointer :: nCellsSolve - integer :: nInterpPoints, ndims - - integer :: nfglevels_actual - integer, pointer :: index_qv - - integer, dimension(5) :: interp_list - real (kind=RKIND) :: msgval - - integer, dimension(:), pointer :: nEdgesOnCell - integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell - real (kind=RKIND), dimension(:,:), pointer :: sorted_arr - - integer :: sfc_k - - integer :: it - real (kind=RKIND) :: p_check - - integer :: istatus - - real (kind=RKIND), allocatable, dimension(:,:) :: rslab - - real (kind=RKIND) :: flux - real (kind=RKIND) :: lat, lon, x, y - - real (kind=RKIND) :: p0 - - real (kind=RKIND) :: etavs, ztemp - - real (kind=RKIND) :: rs, rcv + real (kind=RKIND), dimension(:), pointer :: xland + integer, dimension(:), pointer :: landmask, lu_index - ! calculation of the water vapor mixing ratio: - real (kind=RKIND) :: sh_max,sh_min,global_sh_max,global_sh_min + !This is temporary variable here. It just need when calculate tangential velocity v. + 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 - character (len=StrKIND), pointer :: config_met_prefix - logical, pointer :: config_use_spechumd - integer, pointer :: config_nfglevels - integer, pointer :: config_theta_adv_order - real (kind=RKIND), pointer :: config_coef_3rd_order + 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 - character (len=StrKIND), pointer :: config_extrap_airtemp - integer :: extrap_airtemp + real (kind=RKIND), dimension(nVertLevels + 1 ) :: zc, zw, ah + real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm - real (kind=RKIND), dimension(:), pointer :: latCell, lonCell - real (kind=RKIND), dimension(:), pointer :: latEdge, lonEdge - real (kind=RKIND), dimension(:), pointer :: angleEdge + real (kind=RKIND), dimension(nVertLevels, nCells) :: thi, tbi, cqwb - real (kind=RKIND), dimension(:,:), pointer :: u - real (kind=RKIND), dimension(:,:), pointer :: w - real (kind=RKIND), dimension(:,:), pointer :: theta - real (kind=RKIND), dimension(:,:), pointer :: rho - real (kind=RKIND), dimension(:,:), pointer :: relhum - real (kind=RKIND), dimension(:,:), pointer :: spechum - real (kind=RKIND), dimension(:,:), pointer :: ru - real (kind=RKIND), dimension(:,:), pointer :: rw + real (kind=RKIND) :: xnutr + real (kind=RKIND) :: ztemp, zd, zt, dz, str - real (kind=RKIND), dimension(:,:), pointer :: uReconstructX - real (kind=RKIND), dimension(:,:), pointer :: uReconstructY - real (kind=RKIND), dimension(:,:), pointer :: uReconstructZ - real (kind=RKIND), dimension(:,:), pointer :: uReconstructZonal - real (kind=RKIND), dimension(:,:), pointer :: uReconstructMeridional - real (kind=RKIND), dimension(:,:), pointer :: u_fg - real (kind=RKIND), dimension(:,:), pointer :: v_fg - real (kind=RKIND), dimension(:,:), pointer :: z_fg - real (kind=RKIND), dimension(:,:), pointer :: t_fg - real (kind=RKIND), dimension(:,:), pointer :: rh_fg - real (kind=RKIND), dimension(:,:), pointer :: sh_fg - real (kind=RKIND), dimension(:,:), pointer :: p_fg - real (kind=RKIND), dimension(:), pointer :: soilz + real (kind=RKIND), dimension(nVertLevels ) :: qvb, qvp, zg + real (kind=RKIND), dimension(nVertLevels ) :: t_init_1d - type (hashtable), allocatable :: level_hash - logical :: too_many_fg_levs - integer :: level_value + real (kind=RKIND) :: cof1, cof2 + real (kind=RKIND), pointer :: cf1, cf2, cf3 + real (kind=RKIND) :: pitop, pibtop, ptopb, ptop, rcp, rcv, p0 + real (kind=RKIND) :: a_scale - character (len=StrKIND) :: errstring + 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) :: max_zgrid_local, max_zgrid_global + real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta + 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) + 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_log_write('Interpolating FDDA input fields at time '//trim(timestamp)) + 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) - call mpas_pool_get_config(configs, 'config_met_prefix', config_met_prefix) - call mpas_pool_get_config(configs, 'config_use_spechumd', config_use_spechumd) - call mpas_pool_get_config(configs, 'config_nfglevels', config_nfglevels) - call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) - call mpas_pool_get_config(configs, 'config_coef_3rd_order', config_coef_3rd_order) + ! + ! Scale all distances + ! - call mpas_pool_get_config(configs, 'config_extrap_airtemp', config_extrap_airtemp) - if (trim(config_extrap_airtemp) == 'constant') then - extrap_airtemp = 0 - else if (trim(config_extrap_airtemp) == 'linear') then - extrap_airtemp = 1 - else if (trim(config_extrap_airtemp) == 'lapse-rate') then - extrap_airtemp = 2 - else - call mpas_log_write('*************************************************************', messageType=MPAS_LOG_ERR) - call mpas_log_write('* Invalid value for namelist variable config_extrap_airtemp *', messageType=MPAS_LOG_ERR) - call mpas_log_write('*************************************************************', messageType=MPAS_LOG_CRIT) - end if - call mpas_log_write("Using option '" // trim(config_extrap_airtemp) // "' for vertical extrapolation of temperature") + a_scale = 1.0 - dminfo => block % domain % dminfo + 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 + x_period = x_period * a_scale + y_period = y_period * a_scale - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + 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_array(mesh, 'angleEdge', angleEdge) - call mpas_pool_get_array(mesh, 'zb', zb) - call mpas_pool_get_array(mesh, 'zb3', zb3) + 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(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(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, '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) + 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) + 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 ) + 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 ) then + u_init(k) = u_vel + v_init(k) = v_vel + end if + 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. + qvp(k) = scalars(index_qv,k,1)*1000. + zg(k) = .5*(zgrid(k,1)+zgrid(k+1,1)) +!********************************************************************* + 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(' 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=(/zg(k),rb(k,1),tb(k,1),rtb(k,1),t(k,1),rr(k,1),p(k,1),qvp(k)/)) + end do + +! +! potential temperature perturbation +! + +! 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 +! + 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 + + 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 + fEdge(iEdge) = 7.2921e-05 + end do + + do iVtx=1,nVertices + ! fVertex(iVtx) = 1.e-04 + fVertex(iVtx) = 7.2921e-05 + 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 + + 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 + + + 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. +! SAS case sounding + + if(variable == 'u') then + atm_get_sounding = 2.0 ! SAS value + + else if (variable == 'v') then + atm_get_sounding = 0. + + else if (variable == 'theta') then + + 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 = max(7.8/1000. - (height-442.5)*0.004/1000.,0.0) + end if + + 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 = 15.0 + else if (variable == 'v') then + atm_get_sounding_1 = 0. + else if (variable == 'qv') then + + 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. 500.) then + atm_get_sounding_1 = 300. + else if(height .le. 600.) then + atm_get_sounding_1 = 300. + (height-500.)*3./100. + else + atm_get_sounding_1 = 303. + (height-600.)*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 + + 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 + +!----------- + + !----------------------------------------------------------------------- + ! routine init_atm_case_fdda + ! + !> \brief Computes theta_fdda, qv_fdda, u_fdda, v_fdda fields for FDDA nudging + !> \details + !> This routine is similar to the init_atm_case_lbc routine in that it reads + !> atmospheric fields from "intermediate" files and horizontally and vertically + !> interpolates them to an MPAS mesh.However, it also includes the reconstructed + !> wind fields as originally in the FDDA nudging code. This routine is responsible for + !> producing only those fields that are needed for FDDA nudging. + ! + !----------------------------------------------------------------------- + subroutine init_atm_case_fdda(timestamp, block, mesh, nCells, nEdges, nVertLevels, fg, state, diag, fdda_state, dims, configs) + + use mpas_dmpar, only : mpas_dmpar_min_real, mpas_dmpar_max_real + use init_atm_read_met, only : met_data, read_met_init, read_met_close, read_next_met_field + use init_atm_llxy, only : proj_info, map_init, map_set, latlon_to_ij, PROJ_LATLON, PROJ_GAUSS, DEG_PER_RAD + use init_atm_hinterp, only : interp_sequence, FOUR_POINT, SIXTEEN_POINT, W_AVERAGE4, SEARCH + use mpas_hash, only : hashtable, mpas_hash_init, mpas_hash_destroy, mpas_hash_search, mpas_hash_size, mpas_hash_insert + + implicit none + + character(len=*), intent(in) :: timestamp + type (block_type), intent(inout), target :: block + type (mpas_pool_type), intent(inout) :: mesh + integer, intent(in) :: nCells + integer, intent(in) :: nEdges + integer, intent(in) :: nVertLevels + type (mpas_pool_type), intent(inout) :: fg + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout):: fdda_state + type (mpas_pool_type), intent(inout):: dims + type (mpas_pool_type), intent(inout):: configs + + type (parallel_info), pointer :: parinfo + type (dm_info), pointer :: dminfo + + real (kind=RKIND), parameter :: t0b = 250.0 + + type (met_data) :: field + type (proj_info) :: proj + + real (kind=RKIND), dimension(:), pointer :: dzu, fzm, fzp + real (kind=RKIND), dimension(:), pointer :: vert_level, latPoints, lonPoints + real (kind=RKIND), dimension(:,:), pointer :: zgrid, zz + real (kind=RKIND), dimension(:,:), pointer :: pressure, ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, t, rt + real (kind=RKIND), dimension(:), pointer :: destField1d + real (kind=RKIND), dimension(:,:), pointer :: destField2d + real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + + real (kind=RKIND) :: target_z + integer :: iCell, iEdge, i, k, nVertLevelsP1 + integer, pointer :: nCellsSolve + integer :: nInterpPoints, ndims + + integer :: nfglevels_actual + integer, pointer :: index_qv + + integer, dimension(5) :: interp_list + real (kind=RKIND) :: msgval + + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell + real (kind=RKIND), dimension(:,:), pointer :: sorted_arr + + integer :: sfc_k + + integer :: it + real (kind=RKIND) :: p_check + + integer :: istatus + + real (kind=RKIND), allocatable, dimension(:,:) :: rslab + + real (kind=RKIND) :: flux + real (kind=RKIND) :: lat, lon, x, y + + real (kind=RKIND) :: p0 + + real (kind=RKIND) :: etavs, ztemp + + real (kind=RKIND) :: rs, rcv + + ! calculation of the water vapor mixing ratio: + real (kind=RKIND) :: sh_max,sh_min,global_sh_max,global_sh_min + + character (len=StrKIND), pointer :: config_met_prefix + logical, pointer :: config_use_spechumd + integer, pointer :: config_nfglevels + integer, pointer :: config_theta_adv_order + real (kind=RKIND), pointer :: config_coef_3rd_order + + character (len=StrKIND), pointer :: config_extrap_airtemp + integer :: extrap_airtemp + + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell + real (kind=RKIND), dimension(:), pointer :: latEdge, lonEdge + real (kind=RKIND), dimension(:), pointer :: angleEdge + + real (kind=RKIND), dimension(:,:), pointer :: u + real (kind=RKIND), dimension(:,:), pointer :: w + real (kind=RKIND), dimension(:,:), pointer :: theta + real (kind=RKIND), dimension(:,:), pointer :: rho + real (kind=RKIND), dimension(:,:), pointer :: relhum + real (kind=RKIND), dimension(:,:), pointer :: spechum + real (kind=RKIND), dimension(:,:), pointer :: ru + real (kind=RKIND), dimension(:,:), pointer :: rw + + real (kind=RKIND), dimension(:,:), pointer :: uReconstructX + real (kind=RKIND), dimension(:,:), pointer :: uReconstructY + real (kind=RKIND), dimension(:,:), pointer :: uReconstructZ + real (kind=RKIND), dimension(:,:), pointer :: uReconstructZonal + real (kind=RKIND), dimension(:,:), pointer :: uReconstructMeridional + real (kind=RKIND), dimension(:,:), pointer :: u_fg + real (kind=RKIND), dimension(:,:), pointer :: v_fg + real (kind=RKIND), dimension(:,:), pointer :: z_fg + real (kind=RKIND), dimension(:,:), pointer :: t_fg + real (kind=RKIND), dimension(:,:), pointer :: rh_fg + real (kind=RKIND), dimension(:,:), pointer :: sh_fg + real (kind=RKIND), dimension(:,:), pointer :: p_fg + real (kind=RKIND), dimension(:), pointer :: soilz + + type (hashtable), allocatable :: level_hash + logical :: too_many_fg_levs + integer :: level_value + + character (len=StrKIND) :: errstring + + real (kind=RKIND) :: max_zgrid_local, max_zgrid_global + + + call mpas_log_write('Interpolating FDDA input fields at time '//trim(timestamp)) + + call mpas_pool_get_config(configs, 'config_met_prefix', config_met_prefix) + call mpas_pool_get_config(configs, 'config_use_spechumd', config_use_spechumd) + call mpas_pool_get_config(configs, 'config_nfglevels', config_nfglevels) + call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) + call mpas_pool_get_config(configs, 'config_coef_3rd_order', config_coef_3rd_order) + + call mpas_pool_get_config(configs, 'config_extrap_airtemp', config_extrap_airtemp) + if (trim(config_extrap_airtemp) == 'constant') then + extrap_airtemp = 0 + else if (trim(config_extrap_airtemp) == 'linear') then + extrap_airtemp = 1 + else if (trim(config_extrap_airtemp) == 'lapse-rate') then + extrap_airtemp = 2 + else + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('* Invalid value for namelist variable config_extrap_airtemp *', messageType=MPAS_LOG_ERR) + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_CRIT) + end if + call mpas_log_write("Using option '" // trim(config_extrap_airtemp) // "' for vertical extrapolation of temperature") + + dminfo => block % domain % dminfo + + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) + + call mpas_pool_get_array(mesh, 'zb', zb) + call mpas_pool_get_array(mesh, 'zb3', zb3) + + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'dzu', dzu) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + call mpas_pool_get_array(mesh, 'zz', zz) + + 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, 'pressure_base', ppb) call mpas_pool_get_array(diag, 'pressure_p', pp) @@ -7112,6 +7830,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 @@ -7283,6 +8002,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 ! @@ -7761,101 +8487,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 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_landice/Registry.xml b/src/core_landice/Registry.xml index 1153d48c25..c9ad026dd5 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -1,5 +1,5 @@ - + 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_ocean/Registry.xml b/src/core_ocean/Registry.xml index 29cf098fef..1137f23e8a 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -1,5 +1,5 @@ - + - + $*.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_sw/Registry.xml b/src/core_sw/Registry.xml index 225a25e51d..a79c0875ba 100644 --- a/src/core_sw/Registry.xml +++ b/src/core_sw/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_test/Makefile b/src/core_test/Makefile index 5518eceda0..ab90084721 100644 --- a/src/core_test/Makefile +++ b/src/core_test/Makefile @@ -11,7 +11,9 @@ 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 \ + mpas_test_core_io.o all: core_test @@ -42,7 +44,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_io.o mpas_test_core_halo_exch.o: @@ -64,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/core_test/Registry.xml b/src/core_test/Registry.xml index 4c3f48bc7a..3c17174919 100644 --- a/src/core_test/Registry.xml +++ b/src/core_test/Registry.xml @@ -1,5 +1,5 @@ - + 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 diff --git a/src/core_test/mpas_test_core.F b/src/core_test/mpas_test_core.F index b9824d7db5..f0bbc1dda9 100644 --- a/src/core_test/mpas_test_core.F +++ b/src/core_test/mpas_test_core.F @@ -91,11 +91,13 @@ 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 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 @@ -164,12 +166,23 @@ 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 + 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('') @@ -212,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 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 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 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/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 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} diff --git a/src/framework/Makefile b/src/framework/Makefile index 2d8e7dc92b..a6f1c291e6 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 @@ -85,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_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) @@ -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: @@ -123,10 +127,10 @@ clean: .F.o: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../external/esmf_time_f90 + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) -I../external/SMIOL $< > $*.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/framework/mpas_abort.F b/src/framework/mpas_abort.F index e00a3cfd67..4839105851 100644 --- a/src/framework/mpas_abort.F +++ b/src/framework/mpas_abort.F @@ -98,6 +98,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 diff --git a/src/framework/mpas_block_creator.F b/src/framework/mpas_block_creator.F index 812222f43d..e9fea7253f 100644 --- a/src/framework/mpas_block_creator.F +++ b/src/framework/mpas_block_creator.F @@ -985,6 +985,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_block_decomp.F b/src/framework/mpas_block_decomp.F index 4f3d197d5d..dc3d9e4e13 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 @@ -51,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 @@ -77,9 +82,12 @@ 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. + call mpas_timer_start('mpas_block_decomp_cells_for_proc') + if (numBlocks == 0) then dminfo % total_blocks = dminfo % nProcs else @@ -95,53 +103,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 + + ! 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 - read(unit=iunit, fmt=*, iostat=err) + 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 @@ -285,8 +325,231 @@ 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!}}} +!*********************************************************************** +! +! 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)!{{{ + + 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 + 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)) + + 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. + 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) + + 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. + 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) + + call mpas_timer_stop('scotch_total') + + end subroutine mpas_block_decomp_scotch +#endif + !*********************************************************************** ! ! routine mpas_block_decomp_partitioned_edge_list diff --git a/src/framework/mpas_dmpar.F b/src/framework/mpas_dmpar.F index 6d68c0c656..e18cc4a310 100644 --- a/src/framework/mpas_dmpar.F +++ b/src/framework/mpas_dmpar.F @@ -391,6 +391,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 @@ -1493,7 +1495,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 @@ -7448,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 @@ -7461,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_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..10367a3d9c 100644 --- a/src/framework/mpas_framework.F +++ b/src/framework/mpas_framework.F @@ -26,8 +26,14 @@ 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 +#ifdef MPAS_OPENACC private :: report_acc_devices +#endif contains @@ -207,7 +213,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 +256,20 @@ 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(' SCOTCH support: ' // & +#ifdef MPAS_SCOTCH + 'yes') +#else + 'no') #endif call mpas_log_write('') diff --git a/src/framework/mpas_halo.F b/src/framework/mpas_halo.F index 4ab8817c23..c596ab08e0 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 @@ -495,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 @@ -527,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 @@ -542,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 @@ -560,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 ! @@ -577,6 +622,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 +648,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) 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) + !$acc end host_data else group % recvRequests(i) = MPI_REQUEST_NULL end if @@ -642,8 +694,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) if(useGPUAwareMPI) + !$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 +707,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 +719,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) if(useGPUAwareMPI) + !$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 +738,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 +750,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) if(useGPUAwareMPI) + !$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 +768,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 +782,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) if(useGPUAwareMPI) 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 +841,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) if(useGPUAwareMPI) + !$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 +852,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 +861,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) if(useGPUAwareMPI) + !$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 +875,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 +884,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) if(useGPUAwareMPI) + !$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 +900,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 diff --git a/src/framework/mpas_halo_interface.inc b/src/framework/mpas_halo_interface.inc new file mode 100644 index 0000000000..b1dd9a9c99 --- /dev/null +++ b/src/framework/mpas_halo_interface.inc @@ -0,0 +1,16 @@ + ! + ! Abstract interface for routine used to communicate halos of fields + ! in a named group + ! + abstract interface + 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 + end interface diff --git a/src/framework/mpas_io.F b/src/framework/mpas_io.F index 09514a3667..5b3b5642bb 100644 --- a/src/framework/mpas_io.F +++ b/src/framework/mpas_io.F @@ -7,6 +7,10 @@ ! module mpas_io +#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 use mpas_dmpar @@ -1847,6 +1851,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 +1995,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 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) + message = ' exceeds buffer size: len('//trim(fieldname)//')=$i, len(buffer)=$i' + 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) + 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 +2795,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 +6535,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. diff --git a/src/framework/mpas_log.F b/src/framework/mpas_log.F index 8e51b8ca1f..6b3faed9b1 100644 --- a/src/framework/mpas_log.F +++ b/src/framework/mpas_log.F @@ -852,6 +852,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 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) 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/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 diff --git a/src/framework/mpas_stream_list.F b/src/framework/mpas_stream_list.F index 1ac079b6a0..293fbb67ed 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 @@ -112,21 +112,24 @@ 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 % 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 + nullify(stream % next) + exit + end if node => node % next end do - node % next => stream end if list % nItems = list % nItems + 1 diff --git a/src/framework/mpas_stream_manager.F b/src/framework/mpas_stream_manager.F index d00fcaa800..8a4a1b4ad3 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 @@ -4048,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 diff --git a/src/framework/mpas_timekeeping.F b/src/framework/mpas_timekeeping.F index 659d9bb4f4..bfecc3e0f7 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 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 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 diff --git a/src/operators/mpas_vector_reconstruction.F b/src/operators/mpas_vector_reconstruction.F index 605da9cd6d..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,6 +336,131 @@ subroutine mpas_reconstruct_2d(meshPool, u, uReconstructX, uReconstructY, uRecon !$omp end do end if + 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)) @@ -345,8 +469,9 @@ subroutine mpas_reconstruct_2d(meshPool, u, uReconstructX, uReconstructY, uRecon !$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!}}} + end subroutine mpas_reconstruct_2d_d2h!}}} !*********************************************************************** 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 88159c81b5ae30cf20edda9c39d77be353246a21 Mon Sep 17 00:00:00 2001 From: May Wong Date: Tue, 30 Jun 2026 10:48:30 -0600 Subject: [PATCH 11/17] * Removing uEdge_fdda, uReconstructX_fdda, uReconstructY_fdda, uReconstructZ_fdda from the fdda_state variable structure in core_init_atmosphere, so they are not output by default in the FDDA target files. * Setting config_init_case = 11 in core_init_atmosphere to be the analysis nudging case --- src/core_init_atmosphere/Registry.xml | 15 --------------- src/core_init_atmosphere/mpas_init_atm_cases.F | 2 ++ .../mpas_init_atm_core_interface.F | 6 +++--- 3 files changed, 5 insertions(+), 18 deletions(-) diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index bec5b2c4bb..1f9b436442 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -1262,25 +1262,10 @@ description="Rain water mixing ratio input for FDDA nudging"/> - - - - - - - diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index b5924be7cf..5cbd03cc63 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -6972,6 +6972,8 @@ end function atm_get_sounding_2 ! routine init_atm_case_fdda ! !> \brief Computes theta_fdda, qv_fdda, u_fdda, v_fdda fields for FDDA nudging + !> \author Michael Duda, May Wong + !> \date 2025-07-30 !> \details !> This routine is similar to the init_atm_case_lbc routine in that it reads !> atmospheric fields from "intermediate" files and horizontally and vertically diff --git a/src/core_init_atmosphere/mpas_init_atm_core_interface.F b/src/core_init_atmosphere/mpas_init_atm_core_interface.F index a40eb8ff3a..f66a3ac2e8 100644 --- a/src/core_init_atmosphere/mpas_init_atm_core_interface.F +++ b/src/core_init_atmosphere/mpas_init_atm_core_interface.F @@ -208,7 +208,7 @@ function init_atm_setup_packages(configs, streamInfo, packages, iocontext) resul mp_thompson_aers_in = .false. end if - if (config_init_case == 10) then + if (config_init_case == 11) then fdda = .true. else fdda = .false. @@ -271,7 +271,7 @@ function init_atm_setup_packages(configs, streamInfo, packages, iocontext) resul ! When interpolating FDDA input fields, we need all inputs that would be needed for the interpolation ! of ICs (similar to LBC), so met_stage_in = .true. ! - else if (config_init_case == 10) then + else if (config_init_case == 11) then gwd_stage_in = .false. gwd_stage_out = .false. vertical_stage_in = .false. @@ -308,7 +308,7 @@ function init_atm_setup_packages(configs, streamInfo, packages, iocontext) resul call mpas_pool_get_package(packages, 'first_guess_fieldActive', first_guess_field) first_guess_field = .false. - if ((config_init_case == 7 .and. config_met_interp) .or. config_init_case == 9 .or. config_init_case == 10) then + if ((config_init_case == 7 .and. config_met_interp) .or. config_init_case == 9 .or. config_init_case == 11) then first_guess_field = .true. end if From 6feeb707de0ca54c2bc2022521a796c52a17c0d1 Mon Sep 17 00:00:00 2001 From: May Wong Date: Tue, 30 Jun 2026 10:53:57 -0600 Subject: [PATCH 12/17] Removing mpas_log_write statements in core_atmosphere/dynamics/mpas_atm_fdda.F --- src/core_atmosphere/dynamics/mpas_atm_fdda.F | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_fdda.F b/src/core_atmosphere/dynamics/mpas_atm_fdda.F index 872c311bcd..1a61eba5f5 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_fdda.F +++ b/src/core_atmosphere/dynamics/mpas_atm_fdda.F @@ -182,7 +182,7 @@ subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_p !calculate time fraction within FDDA target data interval tfrac = mod(xtime_s,fdda_int)/fdda_int - call mpas_log_write('inside FDDA: tfrac = $r', realArgs=(/tfrac/)) + !call mpas_log_write('inside FDDA: tfrac = $r', realArgs=(/tfrac/)) fdda_select: select case(fdda_scheme) @@ -246,8 +246,8 @@ subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_p if (fdda_t .and. k.gt.fdda_t_min_layer .and. (fdda_t_in_pbl .or. k.gt.kpbl(i))) then t_target = (1.0_RKIND-tfrac)*theta_fdda_old(k,i)+tfrac*theta_fdda_new(k,i) rthfddaten(k,i) = fdda_t_coef * ( t_target - theta_p ) - if (i.eq.1 .and. k.eq.1 ) call mpas_log_write('t_target, theta_p, theta_fdda_old, theta_fdda_new = $r, $r, $r, $r', & - realArgs=(/t_target, theta_p, theta_fdda_old(k,i), theta_fdda_new(k,i)/) ) + !if (i.eq.1 .and. k.eq.1 ) call mpas_log_write('t_target, theta_p, theta_fdda_old, theta_fdda_new = $r, $r, $r, $r', & + ! realArgs=(/t_target, theta_p, theta_fdda_old(k,i), theta_fdda_new(k,i)/) ) else rthfddaten(k,i) = 0._RKIND endif @@ -271,10 +271,10 @@ subroutine apply_fdda(block,xtime_s,configs,mesh,state,time_lev,fdda,diag,diag_p ENDDO ENDDO - call mpas_log_write('in apply_fdda: min,max rthfddaten = $r, $r', realArgs=(/minval(rthfddaten), maxval(rthfddaten)/) ) - call mpas_log_write('in apply_fdda: min,max rqvfddaten = $r, $r', realArgs=(/minval(rqvfddaten), maxval(rqvfddaten)/) ) - call mpas_log_write('in apply_fdda: min,max rufddaten = $r, $r', realArgs=(/minval(rufddaten), maxval(rufddaten)/) ) - call mpas_log_write('in apply_fdda: min,max rvfddaten = $r, $r', realArgs=(/minval(rvfddaten), maxval(rvfddaten)/) ) + !call mpas_log_write('in apply_fdda: min,max rthfddaten = $r, $r', realArgs=(/minval(rthfddaten), maxval(rthfddaten)/) ) + !call mpas_log_write('in apply_fdda: min,max rqvfddaten = $r, $r', realArgs=(/minval(rqvfddaten), maxval(rqvfddaten)/) ) + !call mpas_log_write('in apply_fdda: min,max rufddaten = $r, $r', realArgs=(/minval(rufddaten), maxval(rufddaten)/) ) + !call mpas_log_write('in apply_fdda: min,max rvfddaten = $r, $r', realArgs=(/minval(rvfddaten), maxval(rvfddaten)/) ) case default From 1bca336fd89f6f9c17922af1acc0a04e0934b92e Mon Sep 17 00:00:00 2001 From: May Wong Date: Tue, 30 Jun 2026 11:55:55 -0600 Subject: [PATCH 13/17] Added uReconstructX_fdda, etc. back to the fdda_state variable structure. To minimize the output fields needed in the target analysis nudging files written out, modified the default output variables for the fdda stream instead. --- src/core_init_atmosphere/Registry.xml | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 1f9b436442..8fd74a00c6 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -703,7 +703,10 @@ immutable="true"> - + + + + @@ -1247,6 +1250,10 @@ description="Meridional component of reconstructed horizontal velocity at cell centers" packages="fdda"/> + + @@ -1266,6 +1273,18 @@ units="kg m^{-3}" description="Dry air density input for FDDA nudging"/> + + + + + + From 3348fccd17cf8bee8b8cfef1c268fa02f7581e4c Mon Sep 17 00:00:00 2001 From: May Wong Date: Tue, 30 Jun 2026 12:02:46 -0600 Subject: [PATCH 14/17] Output scalars_fdda, not qv_fdda. --- src/core_init_atmosphere/Registry.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 8fd74a00c6..a94411e52a 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -706,7 +706,7 @@ - + From 2aec7d926ca409b722730a2f4fb2078338f451f9 Mon Sep 17 00:00:00 2001 From: May Wong Date: Tue, 30 Jun 2026 12:10:15 -0600 Subject: [PATCH 15/17] In Registry.xml, scalars_fdda is a var_array, not variable. --- src/core_init_atmosphere/Registry.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index a94411e52a..7983d3ac80 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -706,7 +706,7 @@ - + From a16f533f3f4c37d69576cdef425bfe5f590f1bc6 Mon Sep 17 00:00:00 2001 From: May Wong Date: Tue, 30 Jun 2026 13:00:10 -0600 Subject: [PATCH 16/17] Corrected typo in Registry.xml --- src/core_init_atmosphere/Registry.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 7983d3ac80..48697c7177 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -706,7 +706,7 @@ - + From cf6211b2d6cda3fd5112142ca2cddb75e199b5a7 Mon Sep 17 00:00:00 2001 From: May Wong Date: Wed, 1 Jul 2026 16:18:05 -0600 Subject: [PATCH 17/17] Change the name of the namelist record for the nudging namelist configurations from 'fdda' to 'nudging' in atmosphere_model. --- 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 cc90397193..0d1e08ae7d 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -420,7 +420,7 @@ possible_values=".true. or .false."/> - +