From a6eeeeaa38c8d7cd4c124c9c5ff35d4d27082590 Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Thu, 23 May 2024 21:41:59 -0600 Subject: [PATCH 01/23] Framework for adding tendency diagnostics, updating PV diagnostics - Add tendency and PV packages declarations to Registry.xml - Add Registry_tendencies.xml file with tendency package variables - Update Registry_diagnostics.xml with Registry_tendencies.xml and namelist config option declarations - Update Registry_pv.xml with all variables required to make modifications to PV diagnostics package --- src/core_atmosphere/Registry.xml | 28 +- .../diagnostics/Registry_diagnostics.xml | 48 ++ .../diagnostics/Registry_pv.xml | 434 ++++++++++++++-- .../diagnostics/Registry_tendencies.xml | 484 ++++++++++++++++++ 4 files changed, 953 insertions(+), 41 deletions(-) create mode 100644 src/core_atmosphere/diagnostics/Registry_tendencies.xml diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 10cfbca3ea..d92bb38c2f 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -410,6 +410,13 @@ + + + + + + + @@ -1628,8 +1635,16 @@ #endif - + + + + + + @@ -1715,9 +1730,6 @@ - - @@ -1929,6 +1941,14 @@ packages="mp_thompson_aers_in"/> #endif + + + + + + diff --git a/src/core_atmosphere/diagnostics/Registry_diagnostics.xml b/src/core_atmosphere/diagnostics/Registry_diagnostics.xml index b9e7dc5682..322d5148cf 100644 --- a/src/core_atmosphere/diagnostics/Registry_diagnostics.xml +++ b/src/core_atmosphere/diagnostics/Registry_diagnostics.xml @@ -19,6 +19,54 @@ #include "Registry_soundings.xml" + +#include "Registry_tendencies.xml" + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_atmosphere/diagnostics/Registry_pv.xml b/src/core_atmosphere/diagnostics/Registry_pv.xml index d776ec2a15..e42292a023 100644 --- a/src/core_atmosphere/diagnostics/Registry_pv.xml +++ b/src/core_atmosphere/diagnostics/Registry_pv.xml @@ -1,68 +1,428 @@ - - + + + - - + + - - - - + description="Ertel's potential vorticity (1 PVU = 10^{-6} m^{2} s^{-1} K kg^{-1})" + packages="pv_diagnostics"/> - + - - - -#ifdef DO_PHYSICS + + + description="Diabatic PV tendency from longwave radiation parameterization scheme" + packages="pv_tendencies"/> + description="Diabatic PV tendency from shortwave radiation parameterization scheme" + packages="pv_tendencies"/> + description="Diabatic PV tendency from PBL parameterization scheme" + packages="pv_tendencies"/> + description="Diabatic PV tendency from cumulus parameterization scheme" + packages="pv_tendencies"/> - - + description="Diabatic PV tendency from microphysics parameterization scheme" + packages="pv_tendencies"/> - + description="Diabatic PV tendency from explicit horizontal mixing" + packages="pv_tendencies"/> + + description="Sum of calculated PV tendencies from diabatic processes" + packages="pv_tendencies"/> + + + + + + + + description="Sum of calculated PV tendencies from frictional processes" + packages="pv_tendencies"/> + + + + + + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + description="Diabatic PV tendency on dynamic tropopause diagnosed at beginning of previous time step (i.e., iLev_DT_prev)" + packages="pv_tendencies"/> -#endif + description="Frictional PV tendency on dynamic tropopause diagnosed at beginning of previous time step (i.e., iLev_DT_prev)" + packages="pv_tendencies"/> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + description="1 if within troposphere based on PV flood fill" + packages="pv_diagnostics"/> + + + + + + + + diff --git a/src/core_atmosphere/diagnostics/Registry_tendencies.xml b/src/core_atmosphere/diagnostics/Registry_tendencies.xml new file mode 100644 index 0000000000..618cb79cc3 --- /dev/null +++ b/src/core_atmosphere/diagnostics/Registry_tendencies.xml @@ -0,0 +1,484 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + From 47d1203b77acb12ff01f0b4ca5fc37ac26872e86 Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Fri, 24 May 2024 14:22:28 -0600 Subject: [PATCH 02/23] Check compatability between diagnostic configs and connect configs to variable packages - Added mpas_atm_diagnostics_packages.F in /src/core_atmosphere/diagnostics to setup the tendency and PV diagnostics packages based on config options and ensure comptability between the config options selected in the namelist - Modified Makefile in /src/core_atmosphere/diagnostics to reflect this new script - Modified mpas_atm_core_interface.F to call mpas_atm_diagnostics_packages.F to setup these packages --- src/core_atmosphere/diagnostics/Makefile | 3 +- .../mpas_atm_diagnostics_packages.F | 250 ++++++++++++++++++ src/core_atmosphere/mpas_atm_core_interface.F | 13 + 3 files changed, 265 insertions(+), 1 deletion(-) create mode 100644 src/core_atmosphere/diagnostics/mpas_atm_diagnostics_packages.F diff --git a/src/core_atmosphere/diagnostics/Makefile b/src/core_atmosphere/diagnostics/Makefile index 614bc1c137..0efd219e10 100644 --- a/src/core_atmosphere/diagnostics/Makefile +++ b/src/core_atmosphere/diagnostics/Makefile @@ -25,12 +25,13 @@ mpas_soundings.o: ################### Generally no need to modify below here ################### -OBJS = mpas_atm_diagnostics_manager.o mpas_atm_diagnostics_utils.o +OBJS = mpas_atm_diagnostics_manager.o mpas_atm_diagnostics_utils.o mpas_atm_diagnostics_packages.o all: $(DIAGNOSTIC_MODULES) $(OBJS) mpas_atm_diagnostics_manager.o: mpas_atm_diagnostics_utils.o $(DIAGNOSTIC_MODULES) +mpas_atm_diagnostics_packages.o: mpas_atm_diagnostics_utils.o clean: $(RM) *.o *.mod *.f90 diff --git a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_packages.F b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_packages.F new file mode 100644 index 0000000000..08edbdb333 --- /dev/null +++ b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_packages.F @@ -0,0 +1,250 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!================================================================================================================= + module mpas_atm_diagnostics_packages + + + use mpas_kind_types + use mpas_derived_types, only : mpas_pool_type, mpas_io_context_type, MPAS_LOG_ERR, MPAS_LOG_WARN + use mpas_pool_routines, only : mpas_pool_get_config, mpas_pool_get_package + use mpas_log, only : mpas_log_write + + implicit none + private + public :: diagnostics_setup_packages + + +! Module mpas_diagnostics_packages contains the definitions for the tendency and PV diagnostics packages +! Script is modeled after mpas_atmphys_packages.F +! +! Manda Chasteen, 21 May 2024 + + contains + + +!================================================================================================================= + function diagnostics_setup_packages(configs, packages, iocontext) result(ierr) +!================================================================================================================= + + ! inout arguments: + type (mpas_pool_type), intent(inout) :: configs + type (mpas_pool_type), intent(inout) :: packages + type (mpas_io_context_type), intent(inout) :: iocontext + + ! microphysics config: + character(len=StrKIND), pointer :: config_microp_scheme + + ! LBC config: + logical, pointer :: config_apply_lbcs + + ! Tendencies diagnostics config: + logical, pointer :: config_tend + + ! MC note: May's code in mpas_atm_core_interface is written in terms of tendenciesActive, but + ! physics code is written in terms of package names in Registry... why? + + ! Tendencies package: + logical, pointer :: tendenciesActive + + ! PV diagnostics configs: + logical, pointer :: config_pv_diag, config_pv_tend, config_pv_scalar, & + config_pv_microphys, config_pv_isobaric + + ! PV diagnostics packages: + logical, pointer :: pv_diagnosticsActive, pv_tendenciesActive, pv_scalarActive, & + pv_microphysicsActive, pv_isobaricActive + + integer :: ierr + +!----------------------------------------------------------------------------------------------------------------- + +! call mpas_log_write('') +! call mpas_log_write('--- enter subroutine diagnostics_setup_packages:') + + ierr = 0 + +!----------------------------------------------------------------------------------------------------------------- +!--- initialization of package for model tendency diagnostics: +!----------------------------------------------------------------------------------------------------------------- + + call mpas_log_write('----- Setting up tendency diagnostics variables -----') + call mpas_log_write('') + + nullify(config_tend) + call mpas_pool_get_config(configs, 'config_tend', config_tend) + + nullify(tendenciesActive) + call mpas_pool_get_package(packages, 'tendenciesActive', tendenciesActive) + + if (associated(config_tend) .and. associated(tendenciesActive)) then + tendenciesActive = config_tend + call mpas_log_write(' tendenciesActive = $l', logicArgs=(/tendenciesActive/)) + else + ierr = ierr + 1 + call mpas_log_write('Package setup failed for ''tendencies''. '// & + 'Either ''tendencies'' is not a package, or ''config_tend'' is not a namelist option.', & + messageType=MPAS_LOG_ERR) + end if + + +!----------------------------------------------------------------------------------------------------------------- +!--- initialization of packages for PV diagnostics: +! This contains compatability checks for various config_pv options. +!----------------------------------------------------------------------------------------------------------------- + + call mpas_log_write('----- Performing compatability checks for PV diagnostics configs -----') + call mpas_log_write('') + + call mpas_pool_get_config(configs, 'config_apply_lbcs', config_apply_lbcs) + call mpas_pool_get_config(configs, 'config_microp_scheme', config_microp_scheme) + + nullify(config_pv_diag) + call mpas_pool_get_config(configs, 'config_pv_diag', config_pv_diag) + + nullify(config_pv_tend) + call mpas_pool_get_config(configs, 'config_pv_tend', config_pv_tend) + + nullify(config_pv_scalar) + call mpas_pool_get_config(configs, 'config_pv_scalar', config_pv_scalar) + + nullify(config_pv_microphys) + call mpas_pool_get_config(configs, 'config_pv_microphys', config_pv_microphys) + + nullify(config_pv_isobaric) + call mpas_pool_get_config(configs, 'config_pv_isobaric', config_pv_isobaric) + + + ! Before setting packages, need to check compatability of config flags and then disable them as appropriate. + + ! if limited area simulation, disable all PV flags if activated + if (config_apply_lbcs .and. (config_pv_diag .or. config_pv_tend .or. config_pv_scalar & + .or. config_pv_microphys .or. config_pv_isobaric)) then + call mpas_log_write('PV diagnostics are not supported for limited-area simulations. Disabling.', MPAS_LOG_WARN) + config_pv_diag = .false. + config_pv_tend = .false. + config_pv_scalar = .false. + config_pv_microphys = .false. + config_pv_isobaric = .false. + end if + + ! if dependent config_pv flags are activated but parent config_pv_diag flag is not, deactivate them. + if ((.not. config_pv_diag) .and. (config_pv_tend .or. config_pv_scalar .or. config_pv_microphys .or. config_pv_isobaric)) then + config_pv_tend = .false. + config_pv_scalar = .false. + config_pv_microphys = .false. + config_pv_isobaric = .false. + call mpas_log_write('config_pv_diag is not activated; deactivated all dependent PV configs.', MPAS_LOG_WARN) + end if + + ! if config_pv_tend is activated but config_tend is not, deactivate. + if ((.not. config_tend) .and. (config_pv_tend .or. config_pv_microphys .or. config_pv_isobaric)) then + config_pv_tend = .false. + config_pv_microphys = .false. + config_pv_isobaric = .false. + call mpas_log_write('config_tend is not activated; deactivated all dependent PV configs.', MPAS_LOG_WARN) + end if + + ! if config_pv_microphys or config_pv_isobaric is activated but config_pv_tend is not, deactivate. + if ((.not. config_pv_tend) .and. (config_pv_microphys .or. config_pv_isobaric)) then + config_pv_microphys = .false. + config_pv_isobaric = .false. + call mpas_log_write('config_pv_tend is not activated; deactivated all dependent PV configs.', MPAS_LOG_WARN) + end if + + ! Ensure Thompson scheme is enabled for microphysics PV tendencies + if ((config_pv_microphys) .and. (config_microp_scheme /= 'mp_thompson')) then + call mpas_log_write('config_pv_microphys is not compatible with = '''//trim(config_microp_scheme)//''' -- disabling', MPAS_LOG_WARN) + config_pv_microphys = .false. + end if + + + call mpas_log_write('----- Setting up PV diagnostics variables -----') + call mpas_log_write('') + + nullify(pv_diagnosticsActive) + nullify(pv_tendenciesActive) + nullify(pv_scalarActive) + nullify(pv_microphysicsActive) + nullify(pv_isobaricActive) + + call mpas_pool_get_package(packages, 'pv_diagnosticsActive', pv_diagnosticsActive) + call mpas_pool_get_package(packages, 'pv_tendenciesActive', pv_tendenciesActive) + call mpas_pool_get_package(packages, 'pv_scalarActive', pv_scalarActive) + call mpas_pool_get_package(packages, 'pv_microphysicsActive', pv_microphysicsActive) + call mpas_pool_get_package(packages, 'pv_isobaricActive', pv_isobaricActive) + + + ! pv_diagnostics: + if (associated(config_pv_diag) .and. associated(pv_diagnosticsActive)) then + pv_diagnosticsActive = config_pv_diag + call mpas_log_write(' pv_diagnosticsActive = $l', logicArgs=(/pv_diagnosticsActive/)) + else + ierr = ierr + 1 + call mpas_log_write('Package setup failed for ''pv_diagnostics''. '// & + 'Either ''pv_diagnostics'' is not a package, ''config_pv_diag'' is not a namelist option, or '//& + ' ''config_pv_diag'' has been disabled due to incompatability with other model configuration options.', & + messageType=MPAS_LOG_ERR) + end if + + ! pv_tendencies: + if (associated(config_pv_tend) .and. associated(pv_tendenciesActive)) then + pv_tendenciesActive = config_pv_tend + call mpas_log_write(' pv_tendenciesActive = $l', logicArgs=(/pv_tendenciesActive/)) + else + ierr = ierr + 1 + call mpas_log_write('Package setup failed for ''pv_tendencies''. '// & + 'Either ''pv_tendencies'' is not a package, ''config_pv_tend'' is not a namelist option, or '//& + ' ''config_pv_tend'' has been disabled due to incompatability with other model configuration options.', & + messageType=MPAS_LOG_ERR) + end if + + ! pv_scalar: + if (associated(config_pv_scalar) .and. associated(pv_scalarActive)) then + pv_scalarActive = config_pv_scalar + call mpas_log_write(' pv_scalarActive = $l', logicArgs=(/pv_scalarActive/)) + else + ierr = ierr + 1 + call mpas_log_write('Package setup failed for ''pv_scalar''. '// & + 'Either ''pv_scalar'' is not a package, ''config_pv_scalar'' is not a namelist option, or '//& + ' ''config_pv_scalar'' has been disabled due to incompatability with other model configuration options.', & + messageType=MPAS_LOG_ERR) + end if + + ! pv_microphys: + if (associated(config_pv_microphys) .and. associated(pv_microphysicsActive)) then + pv_microphysicsActive = config_pv_microphys + call mpas_log_write(' pv_microphysicsActive = $l', logicArgs=(/pv_microphysicsActive/)) + else + ierr = ierr + 1 + call mpas_log_write('Package setup failed for ''pv_microphysics''. '// & + 'Either ''pv_microphysics'' is not a package, ''config_pv_microphys'' is not a namelist option, or '//& + ' ''config_pv_microphys'' has been disabled due to incompatability with other model configuration options.', & + messageType=MPAS_LOG_ERR) + end if + + ! pv_isobaric: + if (associated(config_pv_isobaric) .and. associated(pv_isobaricActive)) then + pv_isobaricActive = config_pv_isobaric + call mpas_log_write(' pv_isobaricActive = $l', logicArgs=(/pv_isobaricActive/)) + else + ierr = ierr + 1 + call mpas_log_write('Package setup failed for ''pv_isobaric''. '// & + 'Either ''pv_isobaric'' is not a package, ''config_pv_isobaric'' is not a namelist option, or '//& + ' ''config_pv_isobaric'' has been disabled due to incompatability with other model configuration options.', & + messageType=MPAS_LOG_ERR) + end if + + + end function diagnostics_setup_packages + +!================================================================================================================= + end module mpas_atm_diagnostics_packages +!================================================================================================================= + + + diff --git a/src/core_atmosphere/mpas_atm_core_interface.F b/src/core_atmosphere/mpas_atm_core_interface.F index c8db24ceac..0af1bdbc97 100644 --- a/src/core_atmosphere/mpas_atm_core_interface.F +++ b/src/core_atmosphere/mpas_atm_core_interface.F @@ -110,6 +110,8 @@ function atm_setup_packages(configs, streamInfo, packages, iocontext) result(ier use mpas_atmphys_packages #endif + use mpas_atm_diagnostics_packages ! MC added + implicit none type (mpas_pool_type), intent(inout) :: configs @@ -208,6 +210,17 @@ function atm_setup_packages(configs, streamInfo, packages, iocontext) result(ier end if #endif + + ! MC ADDED + ! Tendency and PV diagnostics + ! + local_ierr = diagnostics_setup_packages(configs, packages, iocontext) + if (local_ierr /= 0) then + ierr = ierr + 1 + call mpas_log_write('Package setup failed for diagnostics in core_atmosphere', messageType=MPAS_LOG_ERR) + end if + + end function atm_setup_packages From 022000f78a2513a428e28af110cf5f445f247d6d Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Wed, 29 May 2024 18:26:05 -0600 Subject: [PATCH 03/23] Implementation of code for tendencies diagnostics - Updated mpas_atm_halos.F with new halo groups for GWDO tendencies and horizontal momentum tendencies - Updated mpas_atmphys_todynamics.F to include physics tendency diagnostic calculations - Updated mpas_atmphys_interface.F to include microphysics tendency diagnostic calculations - Updated mpas_atm_time_integration.F to include calculations and subroutines for tendency diagnostics --- .../dynamics/mpas_atm_time_integration.F | 1176 ++++++++++++++++- src/core_atmosphere/mpas_atm_core_interface.F | 2 +- src/core_atmosphere/mpas_atm_halos.F | 65 + .../physics/mpas_atmphys_interface.F | 72 +- .../physics/mpas_atmphys_todynamics.F | 291 +++- 5 files changed, 1478 insertions(+), 128 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index e2bafe8752..9c0fb47fbe 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -523,6 +523,15 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) type (field2DReal), pointer :: tend_ru_physicsField, tend_rtheta_physicsField, tend_rho_physicsField #endif + ! MW for ITM + logical, pointer :: config_tend + real (kind=RKIND), dimension(:,:), pointer :: acc_u_tend_dyn_small, acc_u_tend_dyn_small_ReconstructZonal, & + acc_u_tend_dyn_small_ReconstructMeridional, & + acc_u_tend_dyn_small_ReconstructX, acc_u_tend_dyn_small_ReconstructY, & + acc_u_tend_dyn_small_ReconstructZ + real (kind=RKIND), dimension(:,:), pointer :: acc_qv_tend_dyn_large, dqv_dt_dyn + !end MW + real (kind=RKIND) :: time_dyn_step logical, parameter :: debug = .false. @@ -545,6 +554,8 @@ 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_tend', config_tend) ! MW: for tendency diagnostics + ! ! Retrieve field structures @@ -721,6 +732,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) rk_step = 1 dynamics_substep = 1 call physics_get_tend( block, mesh, state, diag, tend, tend_physics, & + diag_physics, & ! MW on ITM for GWDO tends block % configs, rk_step, dynamics_substep, & tend_ru_physics, tend_rtheta_physics, tend_rho_physics, & exchange_halo_group ) @@ -808,6 +820,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !$OMP PARALLEL DO do thread=1,nThreads call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, block % configs, nVertLevels, rk_step, dt, & + rk_timestep(rk_step), & ! MW on ITM cellThreadStart(thread), cellThreadEnd(thread), & vertexThreadStart(thread), vertexThreadEnd(thread), & edgeThreadStart(thread), edgeThreadEnd(thread), & @@ -1153,6 +1166,29 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) ! end if + ! + ! MW for ITM: accumulate tendencies over each dynamic substep + ! + if ( config_tend ) then + call mpas_timer_start('Tendency and PV diagnostics') + call mpas_timer_start('atm_accumulate_tend') +!$OMP PARALLEL DO + do thread=1,nThreads + call atm_accumulate_tend( state, diag, mesh, block % configs, nCells, nVertLevels, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & + dt_dynamics, dynamics_substep, dynamics_split ) + end do +!$OMP END PARALLEL DO + call mpas_timer_stop('Tendency and PV diagnostics') + call mpas_timer_stop('atm_accumulate_tend') + end if + + ! dynamics-transport split, WCS 18 November 2014 ! (1) time level 1 needs to be set to time level 2 ! (2) need to accumulate ruAvg and wwAvg over the dynamics substeps, prepare for use in transport @@ -1176,6 +1212,29 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) end do DYNAMICS_SUBSTEPS + ! + ! MW on ITM: reconstruct zonal and meridional components of the horizontal momentum tendencies + ! + if ( config_tend ) then + call mpas_timer_start('Tendency and PV diagnostics') + call mpas_timer_start('atm_reconstruct_tend') +!$OMP PARALLEL DO + do thread=1,nThreads + call atm_reconstruct_tend(domain, diag, mesh, block % configs, nCells, nVertLevels, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & + dt_dynamics, dynamics_substep, dynamics_split, & + exchange_halo_group) + end do +!$OMP END PARALLEL DO + call mpas_timer_stop('Tendency and PV diagnostics') + call mpas_timer_stop('atm_reconstruct_tend') + end if + deallocate(qtot) ! we are finished with these now @@ -1324,6 +1383,18 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) end if + + ! MW on ITM + if ( config_tend ) then + call mpas_timer_start('Tendency and PV diagnostics') + call mpas_pool_get_array(diag, 'acc_qv_tend_dyn_large', acc_qv_tend_dyn_large) + acc_qv_tend_dyn_large(:,:) = acc_qv_tend_dyn_large(:,:) + ( scalars_2(index_qv,:,:) - scalars_1(index_qv,:,:) ) / config_dt + + call mpas_timer_stop('Tendency and PV diagnostics') + + endif + !----- + !simply set to zero negative mixing ratios of different water species (for now): where ( scalars_2(:,:,:) < 0.0) & scalars_2(:,:,:) = 0.0 @@ -2170,6 +2241,10 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, integer, pointer :: nEdges, nCellsSolve + ! MW on ITM: tendency variables + logical, pointer :: config_tend + real (kind=RKIND), dimension(:,:), pointer :: ru_tend_dyn_small, rth_tend_dyn_small + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) @@ -2237,6 +2312,19 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, ! epssm is the offcentering coefficient for the vertically implicit integration. call mpas_pool_get_config(configs, 'config_epssm', epssm) + + ! MW on ITM: accumulate acoustic time-step dynamic tendencies + call mpas_pool_get_config(configs, 'config_tend', config_tend) + + if ( config_tend ) then + call mpas_pool_get_array(diag, 'ru_tend_dyn_small', ru_tend_dyn_small) + call mpas_pool_get_array(diag, 'rth_tend_dyn_small', rth_tend_dyn_small) + else + allocate(ru_tend_dyn_small(nVertLevels,nEdges+1)) + allocate(rth_tend_dyn_small(nVertLevels,nCells+1)) + endif + + 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, & @@ -2244,9 +2332,18 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & dts, small_step, epssm, cf1, cf2, cf3, & - specZoneMaskEdge, specZoneMaskCell & + specZoneMaskEdge, specZoneMaskCell, & + config_tend, ru_tend_dyn_small=ru_tend_dyn_small, rth_tend_dyn_small=rth_tend_dyn_small & ! MW ITM ) + + !MC: deallocation for ITM variables + if (.not. config_tend) then + deallocate(ru_tend_dyn_small) + deallocate(rth_tend_dyn_small) + endif + + end subroutine atm_advance_acoustic_step @@ -2257,7 +2354,8 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & dts, small_step, epssm, cf1, cf2, cf3, & - specZoneMaskEdge, specZoneMaskCell & + specZoneMaskEdge, specZoneMaskCell, & + config_tend, ru_tend_dyn_small, rth_tend_dyn_small & ! MW on ITM ) use mpas_atm_dimensions @@ -2330,6 +2428,13 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart real (kind=RKIND), dimension(nVertLevels) :: ts, rs + ! MW variables for ITM + ! MC: optional args don't work as intended; code will break without var allocations + logical, intent(in) :: config_tend + real (kind=RKIND), dimension(nVertLevels,nEdges+1), optional :: ru_tend_dyn_small + real (kind=RKIND), dimension(nVertLevels,nCells+1), optional :: rth_tend_dyn_small + + ! ! Local variables ! @@ -2369,8 +2474,13 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart pgrad = cqu(k,iEdge)*0.5*c2*(exner(k,cell1)+exner(k,cell2))*pgrad pgrad = pgrad + 0.5*zxu(k,iEdge)*gravity*(rho_pp(k,cell1)+rho_pp(k,cell2)) ru_p(k,iEdge) = ru_p(k,iEdge) + dts*(tend_ru(k,iEdge) - (1.0_RKIND - specZoneMaskEdge(iEdge))*pgrad) + + if ( config_tend ) then ! MW on ITM + ru_tend_dyn_small(k,iEdge) = ru_tend_dyn_small(k,iEdge) -dts*pgrad + endif end do + ! accumulate ru_p for use later in scalar transport !DIR$ IVDEP do k=1,nVertLevels @@ -2394,6 +2504,10 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP do k=1,nVertLevels ru_p(k,iEdge) = dts*tend_ru(k,iEdge) + + if (config_tend) then + ru_tend_dyn_small(k,iEdge) = 0. ! MW on ITM: zero-ing for first small timestep; only accumulate during RK_STEP + endif end do !DIR$ IVDEP do k=1,nVertLevels @@ -2425,6 +2539,8 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart rho_pp(1:nVertLevels,iCell) = 0.0 rtheta_pp(1:nVertLevels,iCell) = 0.0 rw_p(:,iCell) = 0.0 + + if (config_tend) rth_tend_dyn_small(1:nVertLevels,iCell) = 0.0 ! MW on ITM end if if(specZoneMaskCell(iCell) == 0.0) then ! not specified zone, compute... @@ -2450,6 +2566,14 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP do k=1, nVertLevels + + ! MW on ITM + if (config_tend) then + rth_tend_dyn_small(k,iCell) = rth_tend_dyn_small(k,iCell) + ts(k) & + - resm*rdzw(k)*( coftz(k+1,iCell)*rw_p(k+1,iCell) & + - coftz(k,iCell)*rw_p(k,iCell)) + endif + 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) & @@ -2491,11 +2615,11 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP do k=2,nVertLevels - rw_p(k,iCell) = (rw_p(k,iCell) + (rw_save(k ,iCell) - rw(k ,iCell)) -dts*dss(k,iCell)* & - (fzm(k)*zz (k,iCell)+fzp(k)*zz (k-1,iCell)) & - *(fzm(k)*rho_zz(k,iCell)+fzp(k)*rho_zz(k-1,iCell)) & - *w(k,iCell) )/(1.0+dts*dss(k,iCell)) & - - (rw_save(k ,iCell) - rw(k ,iCell)) + rw_p(k,iCell) = (rw_p(k,iCell) + (rw_save(k,iCell) - rw(k,iCell)) -dts*dss(k,iCell) & + * (fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) & + * (fzm(k)*rho_zz(k,iCell)+fzp(k)*rho_zz(k-1,iCell)) & + * w(k,iCell))/(1.0+dts*dss(k,iCell)) & + - (rw_save(k,iCell) - rw(k,iCell)) end do ! accumulate (rho*omega)' for use later in scalar transport @@ -2504,13 +2628,22 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) end do - ! update rho_pp and theta_pp given updated rw_p - !DIR$ IVDEP do k=1,nVertLevels - rho_pp(k,iCell) = rs(k) - cofrz(k) *(rw_p(k+1,iCell)-rw_p(k ,iCell)) + ! MW on ITM + ! note: rth_tend_dyn_small possibly needs to be recalculated using full theta values + ! to account for round-off errors. This can be done after the last small time-step + ! in atm_recover_large_step_variables. + if (config_tend) then + rth_tend_dyn_small(k,iCell) = rth_tend_dyn_small(k,iCell) & + - rdzw(k)*(coftz(k+1,iCell)*rw_p(k+1,iCell) & + - coftz(k,iCell)*rw_p(k,iCell)) + endif + + ! update rho_pp and theta_pp given updated rw_p + 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)) + -coftz(k,iCell)*rw_p(k,iCell)) end do else ! specifed zone in regional_MPAS @@ -2554,6 +2687,10 @@ subroutine atm_divergence_damping_3d( state, diag, mesh, configs, dts, edgeStart real (kind=RKIND) :: divCell1, divCell2, rdts, coef_divdamp integer :: cell1, cell2, iEdge, k + !MW on ITM + logical, pointer :: config_tend + real (kind=RKIND), dimension(:,:), pointer :: ru_tend_smdiv + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'specZoneMaskEdge', specZoneMaskEdge) ! call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) @@ -2568,6 +2705,11 @@ subroutine atm_divergence_damping_3d( state, diag, mesh, configs, dts, edgeStart call mpas_pool_get_config(configs, 'config_smdiv', smdiv) call mpas_pool_get_config(configs, 'config_len_disp', config_len_disp) + ! MW on ITM + call mpas_pool_get_config(configs, 'config_tend', config_tend) + if (config_tend) call mpas_pool_get_array(diag, 'ru_tend_smdiv', ru_tend_smdiv) + + rdts = 1.0_RKIND / dts coef_divdamp = 2.0_RKIND * smdiv * config_len_disp * rdts @@ -2594,6 +2736,12 @@ subroutine atm_divergence_damping_3d( state, diag, mesh, configs, dts, edgeStart ru_p(k,iEdge) = ru_p(k,iEdge) + coef_divdamp*(divCell2-divCell1)*(1.0_RKIND - specZoneMaskEdge(iEdge)) & /(theta_m(k,cell1)+theta_m(k,cell2)) + ! MW on ITM + if (config_tend) then + ru_tend_smdiv(k,iEdge) = ru_tend_smdiv(k,iEdge) + coef_divdamp*(divCell2-divCell1) & + / (theta_m(k,cell1)+theta_m(k,cell2)) + end if + end do end if ! edges for block-owned cells end do ! end loop over edges @@ -2635,6 +2783,12 @@ subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, d integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell integer, dimension(:), pointer :: nEdgesOnCell + ! MW for ITM and PV tendencies + logical, pointer :: config_tend, config_pv_tend + real (kind=RKIND), dimension(:,:), pointer :: u_tend_dcpl, w_tend_dcpl, th_tend_dcpl, rho_zz_1 + real (kind=RKIND), dimension(:,:), pointer :: ru_tend_dyn_small, rw_tend_dyn_small ! for PV but currently in tendency subroutines + real (kind=RKIND), dimension(:,:), pointer :: w1 ! for PV but currently in tendency subroutines + integer :: i, iCell, iEdge, k, cell1, cell2 integer, pointer :: nVertLevels, nCells, nCellsSolve, nEdges, nEdgesSolve real (kind=RKIND) :: invNs, rcv, p0, flux @@ -2698,6 +2852,30 @@ subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, d call mpas_pool_get_array(mesh, 'cf2', cf2) call mpas_pool_get_array(mesh, 'cf3', cf3) + ! For tendency and PV tendency diagnostics: + ! + ! MC: Conditional variables based on config flags + call mpas_pool_get_config(configs, 'config_tend', config_tend) + call mpas_pool_get_config(configs, 'config_pv_tend', config_pv_tend) + + call mpas_pool_get_array(state, 'rho_zz', rho_zz_1, 1) + call mpas_pool_get_array(state, 'w', w1, 1) + + if (config_tend) then + call mpas_pool_get_array(diag, 'u_tend_dcpl', u_tend_dcpl) + call mpas_pool_get_array(diag, 'w_tend_dcpl', w_tend_dcpl) + call mpas_pool_get_array(diag, 'th_tend_dcpl', th_tend_dcpl) + call mpas_pool_get_array(diag, 'ru_tend_dyn_small', ru_tend_dyn_small) + call mpas_pool_get_array(diag, 'rw_tend_dyn_small', rw_tend_dyn_small) + else + allocate(u_tend_dcpl(nVertLevels,nEdges+1)) + allocate(w_tend_dcpl(nVertLevels+1,nCells+1)) + allocate(th_tend_dcpl(nVertLevels,nCells+1)) + allocate(ru_tend_dyn_small(nVertLevels,nEdges+1)) + allocate(rw_tend_dyn_small(nVertLevels+1,nCells+1)) + endif + ! end diagnostics + call atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nEdgesSolve, dt, ns, rk_step, & wwAvg, rw_save, w, rw, rw_p, rtheta_p, rtheta_pp, rtheta_p_save, rt_diabatic_tend, rho_p, & @@ -2707,7 +2885,23 @@ subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, d cf1, cf2, cf3, & bdyMaskCell, & ! addition for regional_MPAS cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & + config_tend, config_pv_tend, & + u_tend_dcpl=u_tend_dcpl, w_tend_dcpl=w_tend_dcpl, th_tend_dcpl=th_tend_dcpl, rho_zz_1=rho_zz_1, & ! MW on ITM + ru_tend_dyn_small=ru_tend_dyn_small, rw_tend_dyn_small=rw_tend_dyn_small, & ! MW - PV; to recover dw/dt from d(omega)/dt + w1=w1 & ! MW: added for PV-wbudget + ) + + + ! MC: variable deallocation + if (.not. config_tend) then + deallocate(u_tend_dcpl) + deallocate(w_tend_dcpl) + deallocate(th_tend_dcpl) + deallocate(ru_tend_dyn_small) + deallocate(rw_tend_dyn_small) + endif + end subroutine atm_recover_large_step_variables @@ -2720,7 +2914,12 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE cf1, cf2, cf3, & bdyMaskCell, & ! addition for regional_MPAS cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & + config_tend, config_pv_tend, & ! MW - tendency and PV tendencies + u_tend_dcpl, w_tend_dcpl, th_tend_dcpl, rho_zz_1, & ! MW on ITM, PV + ru_tend_dyn_small, rw_tend_dyn_small, & ! PV; to recover dw/dt from d(omega)/dt + w1 & ! MW: added for PV-wbudget + ) use mpas_atm_dimensions @@ -2779,6 +2978,16 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + ! For tendency and PV diagnostics + logical, intent(in) :: config_tend, config_pv_tend + real (kind=RKIND), dimension(nVertLevels,nCells+1), optional :: rho_zz_1 ! from beginning of dynamic time step + real (kind=RKIND), dimension(nVertLevels,nEdges+1), optional :: u_tend_dcpl, ru_tend_dyn_small !, u_tend ! grab from (tend, 'u'), need to make sure units for ru_dyn_small is ok for rw_dyn_small + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), optional :: w_tend_dcpl, rw_tend_dyn_small !, rw_tend_dyn_large ! here, dyn_large includes diffusion too + real (kind=RKIND), dimension(nVertLevels,nCells+1), optional :: th_tend_dcpl + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), optional :: w1 + + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rho_zz_save ! local; save the before-update rho_zz for diabatic theta tendency + ! diag end ! ! Local variables @@ -2794,6 +3003,7 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE ! initializing the "garbage cell" of rho_zz to a non-zero value do k=1,nVertLevels rho_zz(k,nCells+1) = 1.0 + rho_zz_save(k,nCells+1) = 1.0 ! MW end do ! compute new density everywhere so we can compute u from ru. @@ -2806,6 +3016,7 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE !DIR$ IVDEP do k = 1, nVertLevels rho_p(k,iCell) = rho_p_save(k,iCell) + rho_pp(k,iCell) + rho_zz_save(k,iCell) = rho_zz(k,iCell) ! MW: saving time-level t rho_zz rho_zz(k,iCell) = rho_p(k,iCell) + rho_base(k,iCell) end do @@ -2827,13 +3038,28 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE if (rk_step == 3) then !DIR$ IVDEP do k = 1, nVertLevels + ! MW bug fix: + ! rho_zz is not consistent with the rho_zz used in computing rt_diabatic_tend at time-level t + ! rho_zz_save (see above) is the time-level t rho_zz value before it is updated. + + !rtheta_p(k,iCell) = rtheta_p_save(k,iCell) + rtheta_pp(k,iCell) & + ! - dt * rho_zz(k,iCell) * rt_diabatic_tend(k,iCell) + ! rtheta_p(k,iCell) = rtheta_p_save(k,iCell) + rtheta_pp(k,iCell) & - - dt * rho_zz(k,iCell) * rt_diabatic_tend(k,iCell) + - dt * rho_zz_save(k,iCell) * rt_diabatic_tend(k,iCell) + theta_m(k,iCell) = (rtheta_p(k,iCell) + rtheta_base(k,iCell))/rho_zz(k,iCell) exner(k,iCell) = (zz(k,iCell)*(rgas/p0)*(rtheta_p(k,iCell)+rtheta_base(k,iCell)))**rcv ! pressure_p is perturbation pressure pressure_p(k,iCell) = zz(k,iCell) * rgas * (exner(k,iCell)*rtheta_p(k,iCell)+rtheta_base(k,iCell) & * (exner(k,iCell)-exner_base(k,iCell))) + + ! MW on ITM: compute decoupling term (change in rho_zz) + if (config_tend) then + th_tend_dcpl(k,iCell) = (rho_zz_1(k,iCell) - rho_zz(k,iCell))/rho_zz_1(k,iCell) * & + theta_m(k,iCell) + end if + end do else !DIR$ IVDEP @@ -2861,6 +3087,13 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE ruAvg(k,iEdge) = ru_save(k,iEdge) + (ruAvg(k,iEdge) * invNs) ru(k,iEdge) = ru_save(k,iEdge) + ru_p(k,iEdge) u(k,iEdge) = 2.*ru(k,iEdge)/(rho_zz(k,cell1)+rho_zz(k,cell2)) + + ! MW on ITM: compute decoupling term + if (rk_step == 3 .and. config_tend) then + u_tend_dcpl(k,iEdge) = ( 0.5*(rho_zz_1(k,cell1)+rho_zz_1(k,cell2)) - & + 0.5*(rho_zz(k,cell1)+rho_zz(k,cell2)))/(0.5*(rho_zz_1(k,cell1)+rho_zz_1(k,cell2)))*u(k,iEdge) + end if + end do end do @@ -2892,12 +3125,24 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE w(1,iCell) = w(1,iCell)/(cf1*rho_zz(1,iCell)+cf2*rho_zz(2,iCell)+cf3*rho_zz(3,iCell)) + !MW: no change in density at the surface; vertical flux <=> horizontal fluxes + if (config_pv_tend) w_tend_dcpl(1,iCell) = 0.0_RKIND !DIR$ IVDEP do k = 2, nVertLevels w(k,iCell) = w(k,iCell)/(fzm(k)*rho_zz(k,iCell)+fzp(k)*rho_zz(k-1,iCell)) end do + + if (config_pv_tend) then + !MW: assign this back to rw_tend_dyn_small for output + !DIR$ IVDEP + do k = 1, nVertLevels + rw_tend_dyn_small(k,iCell) = w(k,iCell) - w1(k,iCell) ! this is the full tendency + end do + end if + + end if ! addition for regional_MPAS, no spec zone update end do @@ -4212,6 +4457,7 @@ end subroutine atm_advance_scalars_mono_work subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, nVertLevels, rk_step, dt, & + dt_rk, & ! MW on ITM cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -4241,6 +4487,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, integer, intent(in) :: nVertLevels ! for allocating stack variables integer, intent(in) :: rk_step real (kind=RKIND), intent(in) :: dt + real (kind=RKIND), intent(in) :: dt_rk ! MW on ITM integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd @@ -4306,6 +4553,15 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), pointer :: config_rayleigh_damp_u_timescale_days integer, pointer :: config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels + ! MW on ITM: dynamic and physics tendencies + logical, pointer :: config_tend, config_pv_tend + real (kind=RKIND), dimension(:,:), pointer :: ru_tend_dyn_large, ru_tend_physics, & + ru_tend_diff, ru_tend_smdiv + real (kind=RKIND), dimension(:,:), pointer :: rw_tend_diff ! adding this for PV friction term + real (kind=RKIND), dimension(:,:), pointer :: rw_tend_dyn_large ! MW added for PV + real (kind=RKIND), dimension(:,:), pointer :: rth_tend_dyn_large, rth_tend_physics, & + rth_tend_diff + call mpas_pool_get_config(mesh, 'sphere_radius', r_earth) call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) @@ -4432,50 +4688,112 @@ 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) + + ! MW on ITM + call mpas_pool_get_config(configs, 'config_tend', config_tend) + call mpas_pool_get_config(configs, 'config_pv_tend', config_pv_tend) + + if (config_tend) then + call mpas_pool_get_array(diag, 'ru_tend_dyn_large', ru_tend_dyn_large) + call mpas_pool_get_array(diag, 'ru_tend_diff', ru_tend_diff) + call mpas_pool_get_array(diag, 'ru_tend_physics', ru_tend_physics) + call mpas_pool_get_array(diag, 'ru_tend_smdiv', ru_tend_smdiv) + call mpas_pool_get_array(diag, 'rth_tend_dyn_large', rth_tend_dyn_large) + call mpas_pool_get_array(diag, 'rth_tend_diff', rth_tend_diff) + call mpas_pool_get_array(diag, 'rth_tend_physics', rth_tend_physics) + else ! MC: adding allocation + allocate(ru_tend_dyn_large(nVertLevels,nEdges+1)) + allocate(ru_tend_diff(nVertLevels,nEdges+1)) + allocate(ru_tend_physics(nVertLevels,nEdges+1)) + allocate(ru_tend_smdiv(nVertLevels,nEdges+1)) + allocate(rth_tend_dyn_large(nVertLevels,nCells+1)) + allocate(rth_tend_diff(nVertLevels,nCells+1)) + allocate(rth_tend_physics(nVertLevels,nCells+1)) + end if + + if (config_pv_tend) then + call mpas_pool_get_array(diag, 'rw_tend_dyn_large', rw_tend_dyn_large) + call mpas_pool_get_array(diag, 'rw_tend_diff', rw_tend_diff) + else ! MC: adding allocation + allocate(rw_tend_dyn_large(nVertLevels+1,nCells+1)) + allocate(rw_tend_diff(nVertLevels+1,nCells+1)) + end if + ! end ITM and PV + + call atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels, & - nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, moist_start, moist_end, & - fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & - weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & - divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & - rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & - theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & - 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, & - config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & - config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & - config_mpas_cam_coef, & - config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & - config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & - rthdynten, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, moist_start, moist_end, & + fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & + weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & + divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & + rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & + h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & + 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, & + config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & + config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & + config_mpas_cam_coef, & + config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & + config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & + rthdynten, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & + ! MW on ITM + dt_rk, config_tend, config_pv_tend, & + ru_tend_dyn_large=ru_tend_dyn_large, ru_tend_diff=ru_tend_diff, ru_tend_physics=ru_tend_physics, ru_tend_smdiv=ru_tend_smdiv, & ! optional + rth_tend_dyn_large=rth_tend_dyn_large, rth_tend_diff=rth_tend_diff, rth_tend_physics=rth_tend_physics, & ! optional + rw_tend_dyn_large=rw_tend_dyn_large, rw_tend_diff=rw_tend_diff & ! for PV, optional + ) + + + ! MC: diagnostic deallocation + if (.not. config_tend) then + deallocate(ru_tend_dyn_large) + deallocate(ru_tend_diff) + deallocate(ru_tend_physics) + deallocate(ru_tend_smdiv) + deallocate(rth_tend_dyn_large) + deallocate(rth_tend_diff) + deallocate(rth_tend_physics) + end if + if (.not. config_pv_tend) then + deallocate(rw_tend_dyn_large) + deallocate(rw_tend_diff) + 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, & - 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, & - 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, & - config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & - config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & - config_mpas_cam_coef, & - config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & - config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & - rthdynten, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, moist_start, moist_end, & + fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & + weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & + divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & + rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & + h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & + 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, & + config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & + config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & + config_mpas_cam_coef, & + config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & + config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & + rthdynten, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & + ! MW on ITM + dt_rk, config_tend, config_pv_tend, & + ru_tend_dyn_large, ru_tend_diff, ru_tend_physics, ru_tend_smdiv, & + rth_tend_dyn_large, rth_tend_diff, rth_tend_physics, & + rw_tend_dyn_large, rw_tend_diff & ! adding this for PV friction term + ! + ) use mpas_atm_dimensions @@ -4603,6 +4921,15 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + ! + ! MW on ITM + ! + logical, intent(in) :: config_tend, config_pv_tend + real (kind=RKIND), intent(in) :: dt_rk + real (kind=RKIND), dimension(nVertLevels,nEdges+1), optional :: ru_tend_dyn_large, ru_tend_diff, ru_tend_physics, & + ru_tend_smdiv + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), optional ::rw_tend_dyn_large, rw_tend_diff + real (kind=RKIND), dimension(nVertLevels,nCells+1), optional :: rth_tend_dyn_large, rth_tend_diff, rth_tend_physics ! ! Local variables @@ -4829,6 +5156,11 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$OMP BARRIER + ! Initialize tendency diagnostic variables + if (config_tend) ru_tend_diff(1:nVertLevels,edgeStart:edgeEnd) = 0.0 ! MW on ITM + if (config_pv_tend) rw_tend_diff(1:nVertLevels+1,cellStart:cellEnd) = 0.0 ! MW: adding this for PV friction term + + ! 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. @@ -4916,7 +5248,12 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm 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 - + + ! MW: for ITM + if (config_tend) then + ru_tend_diff(k,iEdge) = ru_tend_diff(k,iEdge) - u_diffusion + end if + end do end do @@ -4946,8 +5283,16 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm 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)) + (u(k+1,iEdge)-u(k,iEdge))/(zp-z0) & + -(u(k,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm)) + + ! MW for ITM + if (config_tend) then + ru_tend_diff(k,iEdge) = ru_tend_diff(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 if + end do end do @@ -4977,6 +5322,15 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm 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)) + + + ! MW on ITM + if (config_tend) then + ru_tend_diff(k,iEdge) = ru_tend_diff(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 if + end do end do @@ -5009,6 +5363,15 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm do iEdge=edgeSolveStart,edgeSolveEnd !DIR$ IVDEP do k=1,nVertLevels + + ! MW on ITM: large time-step dynamic tendency + if (rk_step == 3 .and. config_tend) then + ru_tend_smdiv(k,iEdge) = 0. + ru_tend_dyn_large(k,iEdge) = dt_rk*(tend_u(k,iEdge) + tend_u_euler(k,iEdge) - ru_tend_diff(k,iEdge)) + ru_tend_diff(k,iEdge) = dt_rk*ru_tend_diff(k,iEdge) + ru_tend_physics(k,iEdge) = dt_rk*tend_ru_physics(k,iEdge) ! will eventually use each scheme's tendency + end if + ! tend_u(k,iEdge) = tend_u(k,iEdge) + tend_u_euler(k,iEdge) tend_u(k,iEdge) = tend_u(k,iEdge) + tend_u_euler(k,iEdge) + tend_ru_physics(k,iEdge) end do @@ -5104,6 +5467,12 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm 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 + + ! MW: added for PV friction term + if (config_pv_tend) then + rw_tend_diff(k,iCell) = rw_tend_diff(k,iCell) + w_turb_flux + end if + end do end do end do @@ -5123,6 +5492,12 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) + + ! MW: added for PV friction term + if (config_pv_tend) then + rw_tend_diff(k,iCell) = rw_tend_diff(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) + end if + end do end do @@ -5185,6 +5560,14 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm 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) + + ! MW: added for PV tendencies + if (config_pv_tend) then + rw_tend_diff(k,iCell) = rw_tend_diff(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 if + end do end do @@ -5327,6 +5710,12 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm do k=1,nVertLevels tend_theta(k,iCell) = tend_theta(k,iCell)*invAreaCell(iCell) -rdzw(k)*(wdtz(k+1)-wdtz(k)) rthdynten(k,iCell) = (tend_theta(k,iCell)-tend_rho(k,iCell)*theta_m(k,iCell))/rho_zz(k,iCell) + + ! MW on ITM: note tendency saved BEFORE new rt_diabatic_tend is added + if (config_tend) then + rth_tend_dyn_large(k,iCell) = dt_rk*tend_theta(k,iCell) + end if + tend_theta(k,iCell) = tend_theta(k,iCell) + rho_zz(k,iCell)*rt_diabatic_tend(k,iCell) end do end do @@ -5388,6 +5777,13 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm 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) + + ! MW on ITM + if (rk_step == 3 .and. config_tend) then + rth_tend_diff(k,iCell) = dt_rk*tend_theta_euler(k,iCell) + rth_tend_physics(k,iCell) = dt_rk*tend_rtheta_physics(k,iCell) + end if + end do end do @@ -6981,4 +7377,674 @@ subroutine summarize_timestep(domain) end subroutine summarize_timestep + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Accumulate tendencies for initial tendency diagnostics and PV tendency + ! diagnostics + ! + ! Author: May Wong (mwong@ucar.edu) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine atm_accumulate_tend( state, diag, mesh, configs, nCells, nVertLevels, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & + dt_dyn, dynamics_substep, dynamics_split) + implicit none + + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: configs + integer, intent(in) :: nCells ! for allocating stack variables + integer, intent(in) :: nVertLevels ! for allocating stack variables + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + real (kind=RKIND), intent(in) :: dt_dyn + integer, intent(in) :: dynamics_substep, dynamics_split + + integer, pointer :: nCellsSolve, nEdges + integer, dimension(:,:), pointer :: cellsOnEdge + + real (kind=RKIND), dimension(:), pointer :: fzm, fzp + real (kind=RKIND), dimension(:,:), pointer :: zz + real (kind=RKIND), dimension(:,:), pointer :: u_1, w_1 + real (kind=RKIND), dimension(:,:), pointer :: rho_zz, rho_zz_1 + + ! For tendency diagnostics (also used for PV diagnostics): + real (kind=RKIND), dimension(:,:), pointer :: ru_tend_dyn_small, ru_tend_dyn_large, ru_tend_diff, & + ru_tend_physics, rublten_tend, rugwdo_tend, rucuten_tend, & + ru_tend_smdiv, u_tend_dcpl + real (kind=RKIND), dimension(:,:), pointer :: rth_tend_dyn_small, rth_tend_dyn_large, rth_tend_diff, & + rth_tend_physics, rthblten_tend, rthcuten_tend, rthratensw_tend, rthratenlw_tend, & + th_tend_dcpl + real (kind=RKIND), dimension(:,:), pointer :: rqv_tend_diff, qvblten_tend, qvcuten_tend + real (kind=RKIND), dimension(:,:), pointer :: acc_u_tend_dyn_small, acc_u_tend_dyn_large, acc_u_tend_diff, & + acc_u_tend_physics, acc_ublten, acc_ugwdoten, acc_ucuten, acc_u_tend_smdiv, & + acc_u_tend_dcpl + real (kind=RKIND), dimension(:,:), pointer :: acc_th_tend_dyn_small, acc_th_tend_dyn_large, acc_th_tend_diff, & + acc_th_tend_physics, acc_thblten, acc_thcuten, acc_thratensw, acc_thratenlw, & + acc_th_tend_dcpl + real (kind=RKIND), dimension(:,:), pointer :: acc_qv_tend_dyn_large, acc_qv_tend_diff, acc_qvblten, acc_qvcuten + + ! For PV diagnostics: + logical, pointer :: config_pv_tend + + real (kind=RKIND), dimension(:,:), pointer :: u_tend_diff, w_tend_diff + real (kind=RKIND), dimension(:,:), pointer :: rw_tend_dyn_large, rw_tend_dyn_small, rw_tend_diff, w_tend_dcpl + real (kind=RKIND), dimension(:,:), pointer :: du_dt_dyn, dw_dt_dyn + real (kind=RKIND), dimension(:,:), pointer :: dthetam_dt_dyn, dthetam_dt_mix + real (kind=RKIND), dimension(:,:), pointer :: dqv_dt_dyn ! Added for PV + + ! PV -- physics tendencies: + real (kind=RKIND), dimension(:,:), pointer :: tend_u_pbl, tend_u_cu + real (kind=RKIND), dimension(:,:), pointer :: thmblten, qvblten, thmcuten, qvcuten + real (kind=RKIND), dimension(:,:), pointer :: thmswten, thmlwten + + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + + ! MW: get fzm and fzp for computing rho_zz at w-levels for PV diagnostics + 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(state, 'w', w_1, 1) + call mpas_pool_get_array(state, 'u', u_1, 1) + call mpas_pool_get_array(state, 'rho_zz', rho_zz_1, 1) ! for debugging + call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) ! for debugging + + call mpas_pool_get_array( diag, 'ru_tend_dyn_small', ru_tend_dyn_small) + call mpas_pool_get_array( diag, 'ru_tend_dyn_large', ru_tend_dyn_large) + call mpas_pool_get_array( diag, 'ru_tend_diff', ru_tend_diff) + call mpas_pool_get_array( diag, 'ru_tend_physics', ru_tend_physics) + call mpas_pool_get_array( diag, 'rublten_tend', rublten_tend) + call mpas_pool_get_array( diag, 'rugwdo_tend', rugwdo_tend) + call mpas_pool_get_array( diag, 'rucuten_tend', rucuten_tend) + call mpas_pool_get_array( diag, 'ru_tend_smdiv', ru_tend_smdiv) + call mpas_pool_get_array( diag, 'u_tend_dcpl', u_tend_dcpl) + + call mpas_pool_get_array( diag, 'acc_u_tend_dyn_small', acc_u_tend_dyn_small) + call mpas_pool_get_array( diag, 'acc_u_tend_dyn_large', acc_u_tend_dyn_large) + call mpas_pool_get_array( diag, 'acc_u_tend_diff', acc_u_tend_diff) + call mpas_pool_get_array( diag, 'acc_u_tend_physics', acc_u_tend_physics) + call mpas_pool_get_array( diag, 'acc_ublten', acc_ublten ) + call mpas_pool_get_array( diag, 'acc_ugwdoten', acc_ugwdoten ) + call mpas_pool_get_array( diag, 'acc_ucuten', acc_ucuten ) + call mpas_pool_get_array( diag, 'acc_u_tend_smdiv', acc_u_tend_smdiv) + call mpas_pool_get_array( diag, 'acc_u_tend_dcpl', acc_u_tend_dcpl) + + call mpas_pool_get_array( diag, 'rth_tend_dyn_small', rth_tend_dyn_small) + call mpas_pool_get_array( diag, 'rth_tend_dyn_large', rth_tend_dyn_large) + call mpas_pool_get_array( diag, 'rth_tend_diff', rth_tend_diff) + call mpas_pool_get_array( diag, 'rth_tend_physics', rth_tend_physics) + call mpas_pool_get_array( diag, 'rthblten_tend', rthblten_tend) + call mpas_pool_get_array( diag, 'rthcuten_tend', rthcuten_tend) + call mpas_pool_get_array( diag, 'rthratensw_tend', rthratensw_tend) + call mpas_pool_get_array( diag, 'rthratenlw_tend', rthratenlw_tend) + call mpas_pool_get_array( diag, 'th_tend_dcpl', th_tend_dcpl) + + !MW note: acc_th_tend_diabatic is accumulated in physics/mpas_atmphys_interface.F + call mpas_pool_get_array( diag, 'acc_th_tend_dyn_small', acc_th_tend_dyn_small) + call mpas_pool_get_array( diag, 'acc_th_tend_dyn_large', acc_th_tend_dyn_large) + call mpas_pool_get_array( diag, 'acc_th_tend_diff', acc_th_tend_diff) + call mpas_pool_get_array( diag, 'acc_th_tend_physics', acc_th_tend_physics) + call mpas_pool_get_array( diag, 'acc_thblten', acc_thblten) + call mpas_pool_get_array( diag, 'acc_thcuten', acc_thcuten) + call mpas_pool_get_array( diag, 'acc_thratensw', acc_thratensw) + call mpas_pool_get_array( diag, 'acc_thratenlw', acc_thratenlw) + call mpas_pool_get_array( diag, 'acc_th_tend_dcpl', acc_th_tend_dcpl) + + call mpas_pool_get_array( diag, 'rqv_tend_diff', rqv_tend_diff) + call mpas_pool_get_array( diag, 'qvblten_tend', qvblten_tend) + call mpas_pool_get_array( diag, 'qvcuten_tend', qvcuten_tend) + + !MW note: acc_qv_mp is accumulated in physics/mpas_atmphys_interface.F + call mpas_pool_get_array( diag, 'acc_qv_tend_dyn_large', acc_qv_tend_dyn_large) + call mpas_pool_get_array( diag, 'acc_qv_tend_diff', acc_qv_tend_diff) + call mpas_pool_get_array( diag, 'acc_qvblten', acc_qvblten) + call mpas_pool_get_array( diag, 'acc_qvcuten', acc_qvcuten) + + ! For PV diagnostics: + call mpas_pool_get_config(configs, 'config_pv_tend', config_pv_tend) + if (config_pv_tend) then + call mpas_pool_get_array( diag, 'u_tend_diff', u_tend_diff) + call mpas_pool_get_array( diag, 'w_tend_diff', w_tend_diff) + call mpas_pool_get_array( diag, 'rw_tend_diff', rw_tend_diff) + call mpas_pool_get_array( diag, 'rw_tend_dyn_large', rw_tend_dyn_large) + call mpas_pool_get_array( diag, 'rw_tend_dyn_small', rw_tend_dyn_small) + call mpas_pool_get_array( diag, 'w_tend_dcpl', w_tend_dcpl) + call mpas_pool_get_array( diag, 'dthetam_dt_dyn', dthetam_dt_dyn) + call mpas_pool_get_array( diag, 'dthetam_dt_mix', dthetam_dt_mix) + call mpas_pool_get_array( diag, 'dqv_dt_dyn', dqv_dt_dyn) + call mpas_pool_get_array( diag, 'du_dt_dyn', du_dt_dyn) + call mpas_pool_get_array( diag, 'dw_dt_dyn', dw_dt_dyn) + + ! Physics for PV: + call mpas_pool_get_array( diag, 'tend_u_cu', tend_u_cu) + call mpas_pool_get_array( diag, 'tend_u_pbl', tend_u_pbl) + call mpas_pool_get_array( diag, 'thmblten', thmblten) + call mpas_pool_get_array( diag, 'qvblten', qvblten) + call mpas_pool_get_array( diag, 'thmcuten', thmcuten) + call mpas_pool_get_array( diag, 'qvcuten', qvcuten) + call mpas_pool_get_array( diag, 'thmswten', thmswten) + call mpas_pool_get_array( diag, 'thmlwten', thmlwten) + else + allocate(u_tend_diff(nVertLevels,nEdges+1)) + allocate(w_tend_diff(nVertLevels+1,nCells+1)) + allocate(rw_tend_diff(nVertLevels+1,nCells+1)) + allocate(rw_tend_dyn_large(nVertLevels+1,nCells+1)) + allocate(rw_tend_dyn_small(nVertLevels+1,nCells+1)) + allocate(w_tend_dcpl(nVertLevels+1,nCells+1)) + allocate(dthetam_dt_dyn(nVertLevels,nCells+1)) + allocate(dthetam_dt_mix(nVertLevels,nCells+1)) + allocate(dqv_dt_dyn(nVertLevels,nCells+1)) + allocate(du_dt_dyn(nVertLevels,nEdges+1)) + allocate(dw_dt_dyn(nVertLevels+1,nCells+1)) + + allocate(tend_u_cu(nVertLevels,nEdges+1)) + allocate(tend_u_pbl(nVertLevels,nEdges+1)) + allocate(thmblten(nVertLevels,nCells+1)) + allocate(qvblten(nVertLevels,nCells+1)) + allocate(thmcuten(nVertLevels,nCells+1)) + allocate(qvcuten(nVertLevels,nCells+1)) + allocate(thmswten(nVertLevels,nCells+1)) + allocate(thmlwten(nVertLevels,nCells+1)) + end if + + call atm_accumulate_tend_work(nCells, nEdges, nCellsSolve, cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & + fzm, fzp, zz, & + ru_tend_dyn_small, ru_tend_dyn_large, ru_tend_diff, ru_tend_physics, & + rublten_tend, rugwdo_tend, rucuten_tend, ru_tend_smdiv, u_tend_dcpl, & + rth_tend_dyn_small, rth_tend_dyn_large, rth_tend_diff, rth_tend_physics, & + rthblten_tend, rthcuten_tend, rthratensw_tend, rthratenlw_tend, th_tend_dcpl, & + rqv_tend_diff, qvblten_tend, qvcuten_tend, & + acc_u_tend_dyn_small, acc_u_tend_dyn_large, acc_u_tend_diff, acc_u_tend_physics, & + acc_ublten, acc_ugwdoten, acc_ucuten, acc_u_tend_smdiv, acc_u_tend_dcpl, & + acc_th_tend_dyn_small, acc_th_tend_dyn_large, acc_th_tend_diff, acc_th_tend_physics, & + acc_thblten, acc_thcuten, acc_thratensw, acc_thratenlw, & + acc_th_tend_dcpl, & + acc_qv_tend_dyn_large, acc_qv_tend_diff, acc_qvblten, acc_qvcuten, & + cellsOnEdge, dt_dyn, dynamics_substep, dynamics_split, rho_zz_1, rho_zz, & + config_pv_tend, & + u_tend_diff=u_tend_diff, w_tend_diff=w_tend_diff, rw_tend_dyn_small=rw_tend_dyn_small, rw_tend_dyn_large=rw_tend_dyn_large, & ! MW: Added for PV + rw_tend_diff=rw_tend_diff, w_tend_dcpl=w_tend_dcpl, & ! MW: Added for PV + dthetam_dt_dyn=dthetam_dt_dyn, dthetam_dt_mix=dthetam_dt_mix, dqv_dt_dyn=dqv_dt_dyn, du_dt_dyn=du_dt_dyn, dw_dt_dyn=dw_dt_dyn, & ! MW: Added for PV + tend_u_cu=tend_u_cu, tend_u_pbl=tend_u_pbl, thmblten=thmblten, qvblten=qvblten, thmcuten=thmcuten, qvcuten=qvcuten, & ! MC: Added for PV + thmswten=thmswten, thmlwten=thmlwten ) + + + ! MC: deallocate PV variables if allocated above + if (.not. config_pv_tend) then + deallocate(u_tend_diff) + deallocate(w_tend_diff) + deallocate(rw_tend_diff) + deallocate(rw_tend_dyn_large) + deallocate(rw_tend_dyn_small) + deallocate(w_tend_dcpl) + deallocate(dthetam_dt_dyn) + deallocate(dthetam_dt_mix) + deallocate(dqv_dt_dyn) + deallocate(du_dt_dyn) + deallocate(dw_dt_dyn) + + deallocate(tend_u_cu) + deallocate(tend_u_pbl) + deallocate(thmblten) + deallocate(qvblten) + deallocate(thmcuten) + deallocate(qvcuten) + deallocate(thmswten) + deallocate(thmlwten) + end if + + + end subroutine atm_accumulate_tend + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Accumulate tendencies for initial tendency diagnostics and PV tendency + ! diagnostics + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine atm_accumulate_tend_work(nCells, nEdges, nCellsSolve, cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & + fzm, fzp, zz, & + ru_tend_dyn_small, ru_tend_dyn_large, ru_tend_diff, ru_tend_physics, & + rublten_tend, rugwdo_tend, rucuten_tend, ru_tend_smdiv, u_tend_dcpl, & + rth_tend_dyn_small, rth_tend_dyn_large, rth_tend_diff, rth_tend_physics, & + rthblten_tend, rthcuten_tend, rthratensw_tend, rthratenlw_tend, th_tend_dcpl, & + rqv_tend_diff, qvblten_tend, qvcuten_tend, & + acc_u_tend_dyn_small, acc_u_tend_dyn_large, acc_u_tend_diff, acc_u_tend_physics, & + acc_ublten, acc_ugwdoten, acc_ucuten, acc_u_tend_smdiv, acc_u_tend_dcpl, & + acc_th_tend_dyn_small, acc_th_tend_dyn_large, acc_th_tend_diff, acc_th_tend_physics, & + acc_thblten, acc_thcuten, acc_thratensw, acc_thratenlw, & + acc_th_tend_dcpl, & + acc_qv_tend_dyn_large, acc_qv_tend_diff, acc_qvblten, acc_qvcuten, & + cellsOnEdge, dt_dyn, dynamics_substep, dynamics_split, rho_zz_1, rho_zz, & + config_pv_tend, & + u_tend_diff, w_tend_diff, rw_tend_dyn_small, rw_tend_dyn_large, rw_tend_diff, w_tend_dcpl, & ! MW: Added for PV + dthetam_dt_dyn, dthetam_dt_mix, dqv_dt_dyn, du_dt_dyn, dw_dt_dyn, & ! MW: Added for PV + tend_u_cu, tend_u_pbl, thmblten, qvblten, thmcuten, qvcuten, & ! MC: Added for PV + thmswten, thmlwten ) + + use mpas_atm_dimensions + + implicit none + ! + ! Dummy arguments + ! + integer, intent(in) :: nCells, nEdges, nCellsSolve + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + + real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzm + real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzp + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1), optional :: u_tend_diff + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), optional :: w_tend_diff, rw_tend_dyn_small, rw_tend_dyn_large, rw_tend_diff, w_tend_dcpl + + real (kind=RKIND), intent(in) :: dt_dyn + integer, intent(in) :: dynamics_substep, dynamics_split + + ! Local variables + integer :: iEdge, k, cell1, cell2 + integer :: iCell + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: ru_tend_dyn_small, ru_tend_dyn_large, ru_tend_diff, & + ru_tend_physics, rublten_tend, rugwdo_tend, rucuten_tend, & + ru_tend_smdiv, u_tend_dcpl + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: acc_u_tend_dyn_small, acc_u_tend_dyn_large, acc_u_tend_diff, & + acc_u_tend_physics, acc_ublten, acc_ugwdoten, acc_ucuten, acc_u_tend_smdiv, & + acc_u_tend_dcpl + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rth_tend_dyn_small, rth_tend_dyn_large, rth_tend_diff, & + rth_tend_physics, rthblten_tend, rthcuten_tend, rthratensw_tend, rthratenlw_tend, & + th_tend_dcpl + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: acc_th_tend_dyn_small, acc_th_tend_dyn_large, acc_th_tend_diff, & + acc_th_tend_physics, acc_thblten, acc_thcuten, acc_thratensw, acc_thratenlw, & + acc_th_tend_dcpl + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rqv_tend_diff, qvblten_tend, qvcuten_tend + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: acc_qv_tend_dyn_large, acc_qv_tend_diff, & + acc_qvblten, acc_qvcuten + + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rho_zz_1, rho_zz + + ! Adding for PV + logical, intent(in) :: config_pv_tend + real (kind=RKIND), dimension(nVertLevels,nCells+1), optional :: dthetam_dt_dyn, dthetam_dt_mix, dqv_dt_dyn ! adding for PV + real (kind=RKIND), dimension(nVertLevels,nEdges+1), optional :: du_dt_dyn ! adding for PV + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), optional :: dw_dt_dyn ! adding for PV + real (kind=RKIND), dimension(nVertLevels,nEdges+1), optional :: tend_u_pbl, tend_u_cu ! adding for PV + real (kind=RKIND), dimension(nVertLevels,nCells+1), optional :: thmblten, qvblten, thmcuten, qvcuten ! adding for PV + real (kind=RKIND), dimension(nVertLevels,nCells+1), optional :: thmswten, thmlwten ! adding for PV + + integer, dimension(2,nEdges+1) :: cellsOnEdge + real (kind=RKIND) :: drho_zz, drho_zz_W + + !MW: Reset if at the beginning of dynamics_split (adding for PV friction term) + if ( (dynamics_substep == 1) .and. config_pv_tend ) then + do iEdge=edgeStart,edgeEnd + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + ! update edges for block-owned cells + if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then +!DIR$ IVDEP + do k=1,nVertLevels + u_tend_diff(k,iEdge) = 0.0 + tend_u_pbl(k,iEdge) = 0.0 ! MC added MC_TODO: check if these are needed here... + tend_u_cu(k,iEdge) = 0.0 ! MC added + enddo + end if + end do + + do iCell=cellSolveStart,cellSolveEnd ! loop over all owned cells to solve +!DIR$ IVDEP + ! MC_TODO: these are also initialized in PV code. only needs to be done once + do k=1,nVertLevels + w_tend_diff(k,iCell) = 0.0 + dw_dt_dyn(k,iCell) = 0.0 + dthetam_dt_dyn(k,iCell) = 0.0 + dthetam_dt_mix(k,iCell) = 0.0 + thmblten(k,iCell) = 0.0 + qvblten(k,iCell) = 0.0 + thmcuten(k,iCell) = 0.0 + qvcuten(k,iCell) = 0.0 + thmswten(k,iCell) = 0.0 + thmlwten(k,iCell) = 0.0 + end do + w_tend_diff(nVertLevels+1,iCell) = 0.0 + dw_dt_dyn(nVertLevels+1,iCell) = 0.0 + end do + end if + + + do iEdge=edgeStart,edgeEnd ! MGD do we really just need edges touching owned cells? + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + ! update edges for block-owned cells + if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then +!DIR$ IVDEP + do k=1,nVertLevels + + drho_zz = 2./(rho_zz_1(k,cell1)+rho_zz_1(k,cell2)) + + ! note: individual physics terms are already tendencies; other tendencies are integrated over dt_dyn + acc_u_tend_dyn_small(k,iEdge) = acc_u_tend_dyn_small(k,iEdge) + ru_tend_dyn_small(k,iEdge)/(dt_dyn*dynamics_split)*drho_zz + acc_u_tend_dyn_large(k,iEdge) = acc_u_tend_dyn_large(k,iEdge) + ru_tend_dyn_large(k,iEdge)/(dt_dyn*dynamics_split)*drho_zz + acc_u_tend_diff(k,iEdge) = acc_u_tend_diff(k,iEdge) + ru_tend_diff(k,iEdge)/(dt_dyn*dynamics_split)*drho_zz + acc_u_tend_physics(k,iEdge) = acc_u_tend_physics(k,iEdge) + ru_tend_physics(k,iEdge)/(dt_dyn*dynamics_split)*drho_zz + acc_ublten(k,iEdge) = acc_ublten(k,iEdge) + rublten_tend(k,iEdge)/dynamics_split*drho_zz + acc_ugwdoten(k,iEdge) = acc_ugwdoten(k,iEdge) + rugwdo_tend(k,iEdge)/dynamics_split*drho_zz + acc_ucuten(k,iEdge) = acc_ucuten(k,iEdge) + rucuten_tend(k,iEdge)/dynamics_split*drho_zz + acc_u_tend_smdiv(k,iEdge) = acc_u_tend_smdiv(k,iEdge) + ru_tend_smdiv(k,iEdge)/(dt_dyn*dynamics_split)*drho_zz + acc_u_tend_dcpl(k,iEdge) = acc_u_tend_dcpl(k,iEdge) + u_tend_dcpl(k,iEdge)/(dt_dyn*dynamics_split) + + if (config_pv_tend) then + u_tend_diff(k,iEdge) = u_tend_diff(k,iEdge) + ru_tend_diff(k,iEdge)/(dt_dyn*dynamics_split)*drho_zz ! Added for PV + + ! Adding alternative way to calculate horizontal winds dynamics term using the decoupled ru budget terms, but we don't + ! want it accumulated over integration, only over the full model time step + ! This term is zero-ed in pv_diagnostics_reset at every time step + du_dt_dyn(k,iEdge) = du_dt_dyn(k,iEdge) + ru_tend_dyn_small(k,iEdge)/(dt_dyn*dynamics_split)*drho_zz & + + ru_tend_dyn_large(k,iEdge)/(dt_dyn*dynamics_split)*drho_zz & + + ru_tend_smdiv(k,iEdge)/(dt_dyn*dynamics_split)*drho_zz & + + u_tend_dcpl(k,iEdge)/(dt_dyn*dynamics_split) + + ! MC: -- adding for PV friction tends + tend_u_pbl(k,iEdge) = tend_u_pbl(k,iEdge) + rublten_tend(k,iEdge)/dynamics_split*drho_zz + tend_u_cu(k,iEdge) = tend_u_cu(k,iEdge) + rucuten_tend(k,iEdge)/dynamics_split*drho_zz + end if + + end do + end if ! end test for block-owned cells + end do ! end loop over edges + + + do iCell=cellSolveStart,cellSolveEnd ! loop over all owned cells to solve + + if (config_pv_tend) then + dw_dt_dyn(1,iCell) = dw_dt_dyn(1,iCell) + rw_tend_dyn_small(1,iCell)/(dt_dyn*dynamics_split) ! this is total tendency of w (see recover_xxx) + end if + +!DIR$ IVDEP + do k=1,nVertLevels + + drho_zz = 1./rho_zz_1(k,iCell) + + ! theta_m + ! MW note: acc_th_tend_diabatic is accumulated in physics/mpas_atmphys_interface.F + acc_th_tend_dyn_small(k,iCell) = acc_th_tend_dyn_small(k,iCell) + rth_tend_dyn_small(k,iCell)/(dt_dyn*dynamics_split)*drho_zz + acc_th_tend_dyn_large(k,iCell) = acc_th_tend_dyn_large(k,iCell) + rth_tend_dyn_large(k,iCell)/(dt_dyn*dynamics_split)*drho_zz + acc_th_tend_diff(k,iCell) = acc_th_tend_diff(k,iCell) + rth_tend_diff(k,iCell)/(dt_dyn*dynamics_split)*drho_zz + acc_th_tend_physics(k,iCell) = acc_th_tend_physics(k,iCell) + rth_tend_physics(k,iCell)/(dt_dyn*dynamics_split)*drho_zz + acc_thblten(k,iCell) = acc_thblten(k,iCell) + rthblten_tend(k,iCell)/dynamics_split*drho_zz + acc_thcuten(k,iCell) = acc_thcuten(k,iCell) + rthcuten_tend(k,iCell)/dynamics_split*drho_zz + acc_thratensw(k,iCell) = acc_thratensw(k,iCell) + rthratensw_tend(k,iCell)/dynamics_split*drho_zz + acc_thratenlw(k,iCell) = acc_thratenlw(k,iCell) + rthratenlw_tend(k,iCell)/dynamics_split*drho_zz + acc_th_tend_dcpl(k,iCell) = acc_th_tend_dcpl(k,iCell) + th_tend_dcpl(k,iCell)/(dt_dyn*dynamics_split) + + ! qv + acc_qvblten(k,iCell) = acc_qvblten(k,iCell) + qvblten_tend(k,iCell)/dynamics_split + acc_qvcuten(k,iCell) = acc_qvcuten(k,iCell) + qvcuten_tend(k,iCell)/dynamics_split + + ! For PV tendencies: + if (config_pv_tend) then + ! MC: theta_m and qv tendencies from physics parameterizations + ! Note: thmmpten, qvmpten are calculated in physics/mpas_atmphys_interface.F + qvblten(k,iCell) = qvblten(k,iCell) + qvblten_tend(k,iCell)/dynamics_split + thmblten(k,iCell) = thmblten(k,iCell) + rthblten_tend(k,iCell)/dynamics_split*drho_zz + + qvcuten(k,iCell) = qvcuten(k,iCell) + qvcuten_tend(k,iCell)/dynamics_split + thmcuten(k,iCell) = thmcuten(k,iCell) + rthcuten_tend(k,iCell)/dynamics_split*drho_zz + + ! Shortwave and longwave radiation (no moisture tendencies) + thmswten(k,iCell) = thmswten(k,iCell) + rthratensw_tend(k,iCell)/dynamics_split*drho_zz + thmlwten(k,iCell) = thmlwten(k,iCell) + rthratenlw_tend(k,iCell)/dynamics_split*drho_zz + + ! Vertical velocity + if ( k > 1 ) then + drho_zz_w = 1./( fzm(k)*rho_zz_1(k,iCell) + fzp(k)*rho_zz_1(k-1,iCell)) + dw_dt_dyn(k,iCell) = dw_dt_dyn(k,iCell) + rw_tend_dyn_small(k,iCell)/(dt_dyn*dynamics_split) - (rw_tend_diff(k,iCell)*drho_zz_w/(dt_dyn*dynamics_split)) + w_tend_diff(k,iCell) = w_tend_diff(k,iCell) + rw_tend_diff(k,iCell)*drho_zz_w/(dt_dyn*dynamics_split) ! only for use with PV diagnostics (not accumulated) + endif + + ! Adding alternative way to calculate theta dynamics term using theta_m budget term, but we don't + ! want it accumulated over integration, only over the full model time step + ! This term is zero-ed in pv_diagnostics_reset at every time step + dthetam_dt_dyn(k,iCell) = dthetam_dt_dyn(k,iCell) + (rth_tend_dyn_small(k,iCell)/(dt_dyn*dynamics_split)*drho_zz) + & + (rth_tend_dyn_large(k,iCell)/(dt_dyn*dynamics_split)*drho_zz) + & + (th_tend_dcpl(k,iCell)/(dt_dyn*dynamics_split)) + dthetam_dt_mix(k,iCell) = dthetam_dt_mix(k,iCell) + rth_tend_diff(k,iCell)/(dt_dyn*dynamics_split)*drho_zz + + end if ! config_pv_tend + end do ! end loop over vertical levels + end do ! end of loop over cells + + end subroutine atm_accumulate_tend_work + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! For tendency diagnostics: reconstruct horizontal momentum tendencies to its + ! zonal/meridional components and return at cell centers + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine atm_reconstruct_tend(domain, diag, mesh, configs, nCells, nVertLevels, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & + dt_dyn, dynamics_substep, dynamics_split, & + exchange_halo_group) + + implicit none + + type (domain_type), intent(inout) :: domain ! MC added for new halo + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: configs + integer, intent(in) :: nCells ! for allocating stack variables + integer, intent(in) :: nVertLevels ! for allocating stack variables + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + real (kind=RKIND), intent(in) :: dt_dyn + integer, intent(in) :: dynamics_substep, dynamics_split + procedure (halo_exchange_routine) :: exchange_halo_group ! MC added + + real (kind=RKIND), dimension(:,:), pointer :: ru_tend_dyn_small, ru_tend_dyn_large, ru_tend_diff, & + ru_tend_physics, rublten_tend, rucuten_tend, & + ru_tend_smdiv, u_tend_dcpl + real (kind=RKIND), dimension(:,:), pointer :: u_1, u_2 + real (kind=RKIND), dimension(:,:), pointer :: rho_zz + real (kind=RKIND), dimension(:,:), pointer :: acc_u_tend_dyn_small, & + acc_u_tend_dyn_small_ReconstructX, acc_u_tend_dyn_small_ReconstructY, & + acc_u_tend_dyn_small_ReconstructZ, & + acc_u_tend_dyn_small_ReconstructZonal, acc_u_tend_dyn_small_ReconstructMeridional, & + acc_u_tend_dyn_large, & + acc_u_tend_dyn_large_ReconstructX, acc_u_tend_dyn_large_ReconstructY, & + acc_u_tend_dyn_large_ReconstructZ, & + acc_u_tend_dyn_large_ReconstructZonal, acc_u_tend_dyn_large_ReconstructMeridional, & + acc_u_tend_diff, & + acc_u_tend_diff_ReconstructX, acc_u_tend_diff_ReconstructY, & + acc_u_tend_diff_ReconstructZ, & + acc_u_tend_diff_ReconstructZonal, acc_u_tend_diff_ReconstructMeridional, & + acc_u_tend_physics, & + acc_u_tend_physics_ReconstructX, acc_u_tend_physics_ReconstructY, & + acc_u_tend_physics_ReconstructZ, & + acc_u_tend_physics_ReconstructZonal, acc_u_tend_physics_ReconstructMeridional, & + acc_ublten, & + acc_ublten_ReconstructX, acc_ublten_ReconstructY, & + acc_ublten_ReconstructZ, & + acc_ublten_ReconstructZonal, acc_ublten_ReconstructMeridional, & + acc_ugwdoten, & + acc_ugwdoten_ReconstructX, acc_ugwdoten_ReconstructY, & + acc_ugwdoten_ReconstructZ, & + acc_ugwdoten_ReconstructZonal, acc_ugwdoten_ReconstructMeridional, & + acc_ucuten, & + acc_ucuten_ReconstructX, acc_ucuten_ReconstructY, & + acc_ucuten_ReconstructZ, & + acc_ucuten_ReconstructZonal, acc_ucuten_ReconstructMeridional, & + acc_u_tend_smdiv, & + acc_u_tend_smdiv_ReconstructX, acc_u_tend_smdiv_ReconstructY, & + acc_u_tend_smdiv_ReconstructZ, & + acc_u_tend_smdiv_ReconstructZonal, acc_u_tend_smdiv_ReconstructMeridional, & + acc_u_tend_dcpl, & + acc_u_tend_dcpl_ReconstructX, acc_u_tend_dcpl_ReconstructY, & + acc_u_tend_dcpl_ReconstructZ, & + acc_u_tend_dcpl_ReconstructZonal, acc_u_tend_dcpl_ReconstructMeridional + + ! Added for PV + real (kind=RKIND), dimension(:,:), pointer :: uReconstructX_dyn, uReconstructY_dyn, uReconstructZ_dyn, & + uReconstructZonal_dyn, uReconstructMeridional_dyn + + integer, pointer :: nCellsSolve, nEdges + integer, dimension(:,:), pointer :: cellsOnEdge + + ! MC: Updated halo exchange + call exchange_halo_group(domain, 'diagnostics:u_tend') + + + call mpas_pool_get_array( diag, 'acc_u_tend_dyn_small', acc_u_tend_dyn_small) + call mpas_pool_get_array( diag, 'acc_u_tend_dyn_small_ReconstructX', acc_u_tend_dyn_small_ReconstructX) + call mpas_pool_get_array( diag, 'acc_u_tend_dyn_small_ReconstructY', acc_u_tend_dyn_small_ReconstructY) + call mpas_pool_get_array( diag, 'acc_u_tend_dyn_small_ReconstructZ', acc_u_tend_dyn_small_ReconstructZ) + call mpas_pool_get_array( diag, 'acc_u_tend_dyn_small_ReconstructZonal', acc_u_tend_dyn_small_ReconstructZonal) + call mpas_pool_get_array( diag, 'acc_u_tend_dyn_small_ReconstructMeridional', acc_u_tend_dyn_small_ReconstructMeridional) + + call mpas_reconstruct(mesh, acc_u_tend_dyn_small, & + acc_u_tend_dyn_small_ReconstructX, & + acc_u_tend_dyn_small_ReconstructY, & + acc_u_tend_dyn_small_ReconstructZ, & + acc_u_tend_dyn_small_ReconstructZonal, & + acc_u_tend_dyn_small_ReconstructMeridional & + ) + + + call mpas_pool_get_array( diag, 'acc_u_tend_dyn_large', acc_u_tend_dyn_large) + call mpas_pool_get_array( diag, 'acc_u_tend_dyn_large_ReconstructX', acc_u_tend_dyn_large_ReconstructX) + call mpas_pool_get_array( diag, 'acc_u_tend_dyn_large_ReconstructY', acc_u_tend_dyn_large_ReconstructY) + call mpas_pool_get_array( diag, 'acc_u_tend_dyn_large_ReconstructZ', acc_u_tend_dyn_large_ReconstructZ) + call mpas_pool_get_array( diag, 'acc_u_tend_dyn_large_ReconstructZonal', acc_u_tend_dyn_large_ReconstructZonal) + call mpas_pool_get_array( diag, 'acc_u_tend_dyn_large_ReconstructMeridional', acc_u_tend_dyn_large_ReconstructMeridional) + + call mpas_reconstruct(mesh, acc_u_tend_dyn_large, & + acc_u_tend_dyn_large_ReconstructX, & + acc_u_tend_dyn_large_ReconstructY, & + acc_u_tend_dyn_large_ReconstructZ, & + acc_u_tend_dyn_large_ReconstructZonal, & + acc_u_tend_dyn_large_ReconstructMeridional & + ) + + + call mpas_pool_get_array( diag, 'acc_u_tend_diff', acc_u_tend_diff) + call mpas_pool_get_array( diag, 'acc_u_tend_diff_ReconstructX', acc_u_tend_diff_ReconstructX) + call mpas_pool_get_array( diag, 'acc_u_tend_diff_ReconstructY', acc_u_tend_diff_ReconstructY) + call mpas_pool_get_array( diag, 'acc_u_tend_diff_ReconstructZ', acc_u_tend_diff_ReconstructZ) + call mpas_pool_get_array( diag, 'acc_u_tend_diff_ReconstructZonal', acc_u_tend_diff_ReconstructZonal) + call mpas_pool_get_array( diag, 'acc_u_tend_diff_ReconstructMeridional', acc_u_tend_diff_ReconstructMeridional) + + call mpas_reconstruct(mesh, acc_u_tend_diff, & + acc_u_tend_diff_ReconstructX, & + acc_u_tend_diff_ReconstructY, & + acc_u_tend_diff_ReconstructZ, & + acc_u_tend_diff_ReconstructZonal, & + acc_u_tend_diff_ReconstructMeridional & + ) + + + call mpas_pool_get_array( diag, 'acc_u_tend_physics', acc_u_tend_physics) + call mpas_pool_get_array( diag, 'acc_u_tend_physics_ReconstructX', acc_u_tend_physics_ReconstructX) + call mpas_pool_get_array( diag, 'acc_u_tend_physics_ReconstructY', acc_u_tend_physics_ReconstructY) + call mpas_pool_get_array( diag, 'acc_u_tend_physics_ReconstructZ', acc_u_tend_physics_ReconstructZ) + call mpas_pool_get_array( diag, 'acc_u_tend_physics_ReconstructZonal', acc_u_tend_physics_ReconstructZonal) + call mpas_pool_get_array( diag, 'acc_u_tend_physics_ReconstructMeridional', acc_u_tend_physics_ReconstructMeridional) + + call mpas_reconstruct(mesh, acc_u_tend_physics, & + acc_u_tend_physics_ReconstructX, & + acc_u_tend_physics_ReconstructY, & + acc_u_tend_physics_ReconstructZ, & + acc_u_tend_physics_ReconstructZonal, & + acc_u_tend_physics_ReconstructMeridional & + ) + + + call mpas_pool_get_array( diag, 'acc_ublten', acc_ublten) + call mpas_pool_get_array( diag, 'acc_ublten_ReconstructX', acc_ublten_ReconstructX) + call mpas_pool_get_array( diag, 'acc_ublten_ReconstructY', acc_ublten_ReconstructY) + call mpas_pool_get_array( diag, 'acc_ublten_ReconstructZ', acc_ublten_ReconstructZ) + call mpas_pool_get_array( diag, 'acc_ublten_ReconstructZonal', acc_ublten_ReconstructZonal) + call mpas_pool_get_array( diag, 'acc_ublten_ReconstructMeridional', acc_ublten_ReconstructMeridional) + + call mpas_reconstruct(mesh, acc_ublten, & + acc_ublten_ReconstructX, & + acc_ublten_ReconstructY, & + acc_ublten_ReconstructZ, & + acc_ublten_ReconstructZonal, & + acc_ublten_ReconstructMeridional & + ) + + + call mpas_pool_get_array( diag, 'acc_ugwdoten', acc_ugwdoten) + call mpas_pool_get_array( diag, 'acc_ugwdoten_ReconstructX', acc_ugwdoten_ReconstructX) + call mpas_pool_get_array( diag, 'acc_ugwdoten_ReconstructY', acc_ugwdoten_ReconstructY) + call mpas_pool_get_array( diag, 'acc_ugwdoten_ReconstructZ', acc_ugwdoten_ReconstructZ) + call mpas_pool_get_array( diag, 'acc_ugwdoten_ReconstructZonal', acc_ugwdoten_ReconstructZonal) + call mpas_pool_get_array( diag, 'acc_ugwdoten_ReconstructMeridional', acc_ugwdoten_ReconstructMeridional) + + call mpas_reconstruct(mesh, acc_ugwdoten, & + acc_ugwdoten_ReconstructX, & + acc_ugwdoten_ReconstructY, & + acc_ugwdoten_ReconstructZ, & + acc_ugwdoten_ReconstructZonal, & + acc_ugwdoten_ReconstructMeridional & + ) + + + call mpas_pool_get_array( diag, 'acc_ucuten', acc_ucuten) + call mpas_pool_get_array( diag, 'acc_ucuten_ReconstructX', acc_ucuten_ReconstructX) + call mpas_pool_get_array( diag, 'acc_ucuten_ReconstructY', acc_ucuten_ReconstructY) + call mpas_pool_get_array( diag, 'acc_ucuten_ReconstructZ', acc_ucuten_ReconstructZ) + call mpas_pool_get_array( diag, 'acc_ucuten_ReconstructZonal', acc_ucuten_ReconstructZonal) + call mpas_pool_get_array( diag, 'acc_ucuten_ReconstructMeridional', acc_ucuten_ReconstructMeridional) + + call mpas_reconstruct(mesh, acc_ucuten, & + acc_ucuten_ReconstructX, & + acc_ucuten_ReconstructY, & + acc_ucuten_ReconstructZ, & + acc_ucuten_ReconstructZonal, & + acc_ucuten_ReconstructMeridional & + ) + + + call mpas_pool_get_array( diag, 'acc_u_tend_smdiv', acc_u_tend_smdiv) + call mpas_pool_get_array( diag, 'acc_u_tend_smdiv_ReconstructX', acc_u_tend_smdiv_ReconstructX) + call mpas_pool_get_array( diag, 'acc_u_tend_smdiv_ReconstructY', acc_u_tend_smdiv_ReconstructY) + call mpas_pool_get_array( diag, 'acc_u_tend_smdiv_ReconstructZ', acc_u_tend_smdiv_ReconstructZ) + call mpas_pool_get_array( diag, 'acc_u_tend_smdiv_ReconstructZonal', acc_u_tend_smdiv_ReconstructZonal) + call mpas_pool_get_array( diag, 'acc_u_tend_smdiv_ReconstructMeridional', acc_u_tend_smdiv_ReconstructMeridional) + + call mpas_reconstruct(mesh, acc_u_tend_smdiv, & + acc_u_tend_smdiv_ReconstructX, & + acc_u_tend_smdiv_ReconstructY, & + acc_u_tend_smdiv_ReconstructZ, & + acc_u_tend_smdiv_ReconstructZonal, & + acc_u_tend_smdiv_ReconstructMeridional & + ) + + + call mpas_pool_get_array( diag, 'acc_u_tend_dcpl', acc_u_tend_dcpl) + call mpas_pool_get_array( diag, 'acc_u_tend_dcpl_ReconstructX', acc_u_tend_dcpl_ReconstructX) + call mpas_pool_get_array( diag, 'acc_u_tend_dcpl_ReconstructY', acc_u_tend_dcpl_ReconstructY) + call mpas_pool_get_array( diag, 'acc_u_tend_dcpl_ReconstructZ', acc_u_tend_dcpl_ReconstructZ) + call mpas_pool_get_array( diag, 'acc_u_tend_dcpl_ReconstructZonal', acc_u_tend_dcpl_ReconstructZonal) + call mpas_pool_get_array( diag, 'acc_u_tend_dcpl_ReconstructMeridional', acc_u_tend_dcpl_ReconstructMeridional) + + call mpas_reconstruct(mesh, acc_u_tend_dcpl, & + acc_u_tend_dcpl_ReconstructX, & + acc_u_tend_dcpl_ReconstructY, & + acc_u_tend_dcpl_ReconstructZ, & + acc_u_tend_dcpl_ReconstructZonal, & + acc_u_tend_dcpl_ReconstructMeridional & + ) + + + end subroutine atm_reconstruct_tend + + end module atm_time_integration diff --git a/src/core_atmosphere/mpas_atm_core_interface.F b/src/core_atmosphere/mpas_atm_core_interface.F index 0af1bdbc97..502d254ec2 100644 --- a/src/core_atmosphere/mpas_atm_core_interface.F +++ b/src/core_atmosphere/mpas_atm_core_interface.F @@ -110,7 +110,7 @@ function atm_setup_packages(configs, streamInfo, packages, iocontext) result(ier use mpas_atmphys_packages #endif - use mpas_atm_diagnostics_packages ! MC added + use mpas_atm_diagnostics_packages implicit none diff --git a/src/core_atmosphere/mpas_atm_halos.F b/src/core_atmosphere/mpas_atm_halos.F index df02ee30a2..1edbccb4e1 100644 --- a/src/core_atmosphere/mpas_atm_halos.F +++ b/src/core_atmosphere/mpas_atm_halos.F @@ -28,6 +28,10 @@ end subroutine halo_exchange_routine procedure (halo_exchange_routine), pointer :: exchange_halo_group + ! MC: added logicals for diagnostics packages + logical, pointer :: config_tend + logical, pointer :: config_pv_diag, config_pv_tend, config_pv_scalar, & + config_pv_microphys contains @@ -62,6 +66,8 @@ subroutine atm_build_halo_groups(domain, ierr) ! Local variables character(len=StrKIND), pointer :: config_halo_exch_method + ! MC: check for diagnostics packages + call mpas_pool_get_config(domain % blocklist % configs, 'config_tend', config_tend) ! ! Determine from the namelist option config_halo_exch_method which halo exchange method to employ @@ -177,7 +183,28 @@ subroutine atm_build_halo_groups(domain, ierr) call mpas_dmpar_exch_group_create(domain, 'physics:cuten') call mpas_dmpar_exch_group_add_field(domain, 'physics:cuten', 'rucuten', timeLevel=1, haloLayers=(/1,2/)) call mpas_dmpar_exch_group_add_field(domain, 'physics:cuten', 'rvcuten', timeLevel=1, haloLayers=(/1,2/)) + #endif + ! + ! MC: Set up halo exchange groups used by diagnostics packages + ! + if (config_tend) then + call mpas_dmpar_exch_group_create(domain, 'physics:bldiff') + call mpas_dmpar_exch_group_add_field(domain, 'physics:bldiff', 'rubldiff', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'physics:bldiff', 'rvbldiff', timeLevel=1, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'diagnostics:u_tend') ! MC - called in mpas_atm_time_integration.F, atm_reconstruct_tend + call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_u_tend_dyn_small', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_u_tend_dyn_large', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_u_tend_diff', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_u_tend_physics', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_ublten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_ugwdoten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_ucuten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_u_tend_smdiv', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_u_tend_dcpl', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:u_tend', 'du_dt_dyn', timeLevel=1, haloLayers=(/1,2/)) + end if ! ! Set routine to exchange a halo group @@ -312,6 +339,28 @@ subroutine atm_build_halo_groups(domain, ierr) call mpas_halo_exch_group_complete(domain, 'physics:cuten') #endif + ! + ! MC: Set up halo exchange groups used by diagnostics packages + ! + if (config_tend) then + call mpas_halo_exch_group_create(domain, 'physics:bldiff') + call mpas_halo_exch_group_add_field(domain, 'physics:bldiff', 'rubldiff', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'physics:bldiff', 'rvbldiff', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'physics:bldiff') + + call mpas_halo_exch_group_create(domain, 'diagnostics:u_tend') ! MC - called in mpas_atm_time_integration.F, atm_reconstruct_tend + call mpas_halo_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_u_tend_dyn_small', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_u_tend_dyn_large', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_u_tend_diff', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_u_tend_physics', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_ublten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_ugwdoten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_ucuten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_u_tend_smdiv', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'diagnostics:u_tend', 'acc_u_tend_dcpl', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'diagnostics:u_tend', 'du_dt_dyn', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'diagnostics:u_tend') + end if ! ! Set routine to exchange a halo group ! @@ -398,6 +447,14 @@ subroutine atm_destroy_halo_groups(domain, ierr) call mpas_dmpar_exch_group_destroy(domain, 'physics:blten') call mpas_dmpar_exch_group_destroy(domain, 'physics:cuten') #endif + ! + ! Destroy halo exchange groups used by diagnostics + ! + if (config_tend) then + call mpas_dmpar_exch_group_destroy(domain, 'physics:bldiff') + call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:u_tend') + end if + else if (trim(config_halo_exch_method) == 'mpas_halo') then @@ -435,6 +492,14 @@ subroutine atm_destroy_halo_groups(domain, ierr) call mpas_halo_exch_group_destroy(domain, 'physics:cuten') #endif + ! + ! MC: Destroy halo exchange groups used by diagnostics + ! + if (config_tend) then + call mpas_halo_exch_group_destroy(domain, 'physics:bldiff') + call mpas_halo_exch_group_destroy(domain, 'diagnostics:u_tend') + end if + call mpas_halo_finalize(domain) else diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index b467bb09b8..29b540da7e 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -564,6 +564,10 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, real(kind=RKIND),dimension(:,:),pointer :: rncmpten,rnimpten,rnrmpten,rnifampten,rnwfampten real(kind=RKIND),dimension(:,:,:),pointer:: scalars +! MW added for ITM + logical, pointer :: config_tend + real(kind=RKIND), dimension(:,:), pointer :: qv_mp_tend + !local variables: integer:: i,k,j @@ -590,6 +594,13 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, qc => scalars(index_qc,:,:) qr => scalars(index_qr,:,:) +! MW on ITM -- MC added + call mpas_pool_get_config(configs, 'config_tend', config_tend) + + if (config_tend) then ! MC added! + call mpas_pool_get_array(diag, 'qv_mp_tend', qv_mp_tend) + end if + !initialize variables needed in the cloud microphysics schemes: do j = jts, jte do k = kts, kte @@ -607,6 +618,11 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, z_p(i,k,j) = zgrid(k,i) dz_p(i,k,j) = zgrid(k+1,i) - zgrid(k,i) w_p(i,k,j) = w(k,i) + + ! MW on ITM -- MC added + if (config_tend) then + qv_mp_tend(k,i) = qv(k,i) ! save qv before call to microphysics + endif enddo enddo enddo @@ -788,7 +804,7 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te real(kind=RKIND),dimension(:,:),pointer :: zz,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 :: rt_diabatic_tend - real(kind=RKIND),dimension(:,:),pointer :: dtheta_dt_mp + real(kind=RKIND),dimension(:,:),pointer :: dtheta_dt_mp ! MC note: this eventually should be removed real(kind=RKIND),dimension(:,:),pointer :: qv,qc,qr,qi,qs,qg real(kind=RKIND),dimension(:,:),pointer :: nc,ni,nr,nifa,nwfa real(kind=RKIND),dimension(:,:),pointer :: rainprod,evapprod @@ -797,6 +813,11 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te real(kind=RKIND),dimension(:,:),pointer :: rncmpten,rnimpten,rnrmpten,rnifampten,rnwfampten real(kind=RKIND),dimension(:,:,:),pointer:: scalars +! MW on ITM: accumulating theta diabatic tendency term MC added + logical, pointer :: config_tend, config_pv_tend + real(kind=RKIND),dimension(:,:),pointer :: acc_th_tend_diabatic + real(kind=RKIND),dimension(:,:),pointer :: qv_mp_tend, acc_qv_mp_tend + !local variables: integer:: icount integer:: i,k,j @@ -833,6 +854,29 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te call mpas_pool_get_array(tend,'rt_diabatic_tend',rt_diabatic_tend) +! MW on ITM MC ADDED + call mpas_pool_get_config(configs, 'config_tend', config_tend) + + if (config_tend) then + call mpas_pool_get_array(diag,'acc_th_tend_diabatic', acc_th_tend_diabatic) + call mpas_pool_get_array(diag,'qv_mp_tend', qv_mp_tend) + call mpas_pool_get_array(diag,'acc_qv_mp_tend', acc_qv_mp_tend) + else + allocate(acc_th_tend_diabatic, MOLD=rt_diabatic_tend) + allocate(qv_mp_tend, MOLD=rt_diabatic_tend) + allocate(acc_qv_mp_tend, MOLD=rt_diabatic_tend) + end if + + ! MC -- adding config here so code won't break before other mods; dtheta_dt_mp will be removed from this section eventually + call mpas_pool_get_config(configs, 'config_pv_tend', config_pv_tend) + + if (config_pv_tend) then + call mpas_pool_get_array(diag,'dtheta_dt_mp', dtheta_dt_mp) ! MC note -- this eventually should be removed + else + allocate(dtheta_dt_mp, MOLD=rt_diabatic_tend) + end if + + !update variables needed in the dynamical core: do j = jts,jte do k = kts,kte @@ -841,7 +885,9 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te !initializes tendency of coupled potential temperature potential temperature, and !potential temperature heating rate from microphysics: rt_diabatic_tend(k,i) = theta_m(k,i) - dtheta_dt_mp(k,i) = theta_m(k,i)/(1._RKIND+rvord*qv(k,i)) + dtheta_dt_mp(k,i) = theta_m(k,i)/(1._RKIND+rvord*qv(k,i)) ! MC note -- this was changed in my code and ultimately removed; + ! should eventually be removed + !updates water vapor, cloud liquid water, rain mixing ratios, modified potential temperature, !tendency of coupled potential temperature, and potential temperature heating rate from microphysics: @@ -851,7 +897,8 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te theta_m(k,i) = th_p(i,k,j) * (1._RKIND+rvord*qv_p(i,k,j)) rt_diabatic_tend(k,i) = (theta_m(k,i) - rt_diabatic_tend(k,i))/dt_dyn - dtheta_dt_mp(k,i) = (theta_m(k,i)/(1._RKIND+rvord*qv(k,i))-dtheta_dt_mp(k,i))/(dt_dyn) + dtheta_dt_mp(k,i) = (theta_m(k,i)/(1._RKIND+rvord*qv(k,i))-dtheta_dt_mp(k,i))/(dt_dyn) ! MC note -- this was changed in my code and ultimately removed; + ! should eventually be removed !density-weighted perturbation potential temperature: rtheta_p(k,i) = rho_zz(k,i) * theta_m(k,i) - rtheta_b(k,i) @@ -863,6 +910,13 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te pressure_p(k,i) = zz(k,i)*R_d*(exner(k,i)*rtheta_p(k,i) & + (exner(k,i)-exner_b(k,i))*rtheta_b(k,i)) + + ! MW on ITM: flux version MC ADDED + if (config_tend) then + acc_th_tend_diabatic(k,i) = acc_th_tend_diabatic(k,i) + rt_diabatic_tend(k,i) + acc_qv_mp_tend(k,i) = acc_qv_mp_tend(k,i) + ( qv(k,i) - qv_mp_tend(k,i))/dt_dyn + end if + enddo enddo enddo @@ -1025,6 +1079,18 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te case default end select mp_tend_select + if (.not. config_tend) then + deallocate(acc_th_tend_diabatic) + deallocate(qv_mp_tend) + deallocate(acc_qv_mp_tend) + end if + +! MC adding for now + if (.not. config_pv_tend) then + deallocate(dtheta_dt_mp) + end if + + end subroutine microphysics_to_MPAS !================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index 81100225a0..5f81727471 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -11,7 +11,7 @@ module mpas_atmphys_todynamics use mpas_pool_routines use mpas_dmpar use mpas_atm_dimensions - + use mpas_timer ! MC added for tendencies use mpas_atmphys_constants, only: R_d,R_v,degrad implicit none @@ -33,6 +33,23 @@ module mpas_atmphys_todynamics ! ! add-ons and modifications to sourcecode: ! ---------------------------------------- +! * added calculation of the advective tendency of the potential temperature due to horizontal +! and vertical advection, and horizontal mixing (diffusion). +! Laura D. Fowler (birch.mmm.ucar.edu) / 2013-11-19. +! * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. +! Laura D. Fowler (laura@ucar.edu) / 2014-04-22. +! * modified sourcecode to use pools. +! 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. +! * renamed "tiedtke" with "cu_tiedtke". +! Laura D. Fowler (laura@ucar.edu) / 2016-03-22. +! * modified the sourcecode to accomodate the packages "cu_kain_fritsch_in" and "cu_ntiedtke_in". +! Laura D. Fowler (laura@ucar.edu) / 2016-03-24. +! * added the option bl_mynn for the calculation of the tendency for the cloud ice number concentration. +! Laura D. Fowler (laura@ucar.edu) / 2016-04-11. +! * in subroutine physics_get_tend_work, added the option cu_ntiedtke in the calculation of rucuten_Edge. +! Laura D. Fowler (laura@ucar.edu) / 2016-10-28. ! * cleaned-up subroutines physics_get_tend and physics_get_tend_work. ! Laura D. Fowler (laura@ucar.edu) / 2018-01-23. ! * removed the option bl_mynn_wrf390. @@ -40,6 +57,8 @@ module mpas_atmphys_todynamics ! * added tendencies of cloud liquid water number concentration, and water-friendly and ice-friendly aerosol ! number concentrations due to PBL processes. ! Laura D. Fowler (laura@ucar.edu) / 2024-05-16. +! * Added support for initial tendency diagnostics package variables and timers +! May Wong (mwong@ucar.edu) and Manda Chasteen (chasteen@ucar.edu) / 2024-05-29 ! ! Abstract interface for routine used to communicate halos of fields @@ -62,8 +81,8 @@ end subroutine halo_exchange_routine !================================================================================================================= - subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_step,dynamics_substep, & - tend_ru_physics,tend_rtheta_physics,tend_rho_physics,exchange_halo_group) + subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, diag_physics, configs, rk_step, dynamics_substep, & + tend_ru_physics, tend_rtheta_physics, tend_rho_physics, exchange_halo_group ) !================================================================================================================= !input variables: @@ -79,6 +98,7 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s 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 ! MW: added for ITM real(kind=RKIND),intent(inout),dimension(:,:):: tend_ru_physics,tend_rtheta_physics,tend_rho_physics @@ -87,7 +107,10 @@ 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, & + gwdo_scheme ! MW: for ITM + + logical, pointer :: config_tend ! MC -- for tendency diagnostics package integer:: i,iCell,k,n integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs @@ -102,18 +125,27 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s real(kind=RKIND),dimension(:,:),pointer:: rthblten,rqvblten,rqcblten, & rqiblten,rqsblten,rublten,rvblten real(kind=RKIND),dimension(:,:),pointer:: rncblten,rniblten,rnifablten,rnwfablten + real(kind=RKIND),dimension(:,:),pointer:: rubldiff, rvbldiff ! MW on ITM: GWDO; MC added + real(kind=RKIND),dimension(:,:),pointer:: rthcuten,rqvcuten,rqccuten, & rqrcuten,rqicuten,rqscuten, & rucuten,rvcuten 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(:,:),allocatable:: tend_th +! MC: will no longer be needed for PV and removed in subsequent commit + real(kind=RKIND),dimension(:,:),pointer:: tend_u_phys + +! MW: for ITM + real(kind=RKIND),dimension(:,:),pointer:: rucuten_tend, rublten_tend, rugwdo_tend + real(kind=RKIND),dimension(:,:),pointer:: rthcuten_tend, rthblten_tend, rthratenlw_tend, rthratensw_tend + real(kind=RKIND),dimension(:,:),pointer:: qvcuten_tend, qvblten_tend + !================================================================================================================= call mpas_pool_get_dimension(mesh,'nCells',nCells) @@ -126,12 +158,15 @@ 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_gwdo_scheme' ,gwdo_scheme ) ! MW on ITM: GWDO + call mpas_pool_get_config(configs,'config_tend', config_tend) ! MC: for tendency diagnostics 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(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) + + call mpas_pool_get_array(diag , 'tend_u_phys', tend_u_phys) ! MC - for PV; will be removed in subsequent commits call mpas_pool_get_dimension(state,'index_qv',index_qv) call mpas_pool_get_dimension(state,'index_qc',index_qc) @@ -171,6 +206,20 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s call mpas_pool_get_array(tend,'scalars_tend',tend_scalars) +! MW on ITM + call mpas_pool_get_array(diag_physics, 'rubldiff', rubldiff) ! MW on ITM: GWDO contrib. to rublten + call mpas_pool_get_array(diag_physics, 'rvbldiff', rvbldiff) ! MW on ITM + + call mpas_pool_get_array(diag, 'rublten_tend', rublten_tend) + call mpas_pool_get_array(diag, 'rugwdo_tend', rugwdo_tend) + call mpas_pool_get_array(diag, 'rucuten_tend', rucuten_tend) + call mpas_pool_get_array(diag, 'rthblten_tend', rthblten_tend) + call mpas_pool_get_array(diag, 'rthcuten_tend', rthcuten_tend) + call mpas_pool_get_array(diag, 'rthratenlw_tend', rthratenlw_tend) + call mpas_pool_get_array(diag, 'rthratensw_tend', rthratensw_tend) + call mpas_pool_get_array(diag, 'qvblten_tend', qvblten_tend) + call mpas_pool_get_array(diag, 'qvcuten_tend', qvcuten_tend) + !initialize the tendency for the potential temperature and all scalars due to PBL, convection, !and longwave and shortwave radiation: @@ -182,42 +231,67 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s tend_rtheta_physics(:,:) = 0._RKIND tend_rho_physics(:,:) = 0._RKIND + tend_u_phys(:,:) = 0._RKIND ! MC: this fix was needed because tend_u_phys and tend_u_diff accumulate in PV code; + ! will no longer be necessary once this var is removed + ! + ! 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(rublten) ) allocate(rublten(0,0) ) + if (.not. associated(rvblten) ) allocate(rvblten(0,0) ) + if (.not. associated(rthblten)) allocate(rthblten(0,0)) + if (.not. associated(rqvblten)) allocate(rqvblten(0,0)) + if (.not. associated(rqcblten)) allocate(rqcblten(0,0)) + if (.not. associated(rqiblten)) allocate(rqiblten(0,0)) + if (.not. associated(rqsblten)) allocate(rqsblten(0,0)) + if (.not. associated(rncblten)) allocate(rncblten(0,0)) + if (.not. associated(rniblten)) allocate(rniblten(0,0)) + if (.not. associated(rnifablten)) allocate(rnifablten(0,0)) + if (.not. associated(rnwfablten)) allocate(rnwfablten(0,0)) + + if (.not. associated(rucuten) ) allocate(rucuten(0,0) ) + if (.not. associated(rvcuten) ) allocate(rvcuten(0,0) ) + if (.not. associated(rthcuten)) allocate(rthcuten(0,0)) + if (.not. associated(rqvcuten)) allocate(rqvcuten(0,0)) + if (.not. associated(rqccuten)) allocate(rqccuten(0,0)) + if (.not. associated(rqicuten)) allocate(rqicuten(0,0)) + if (.not. associated(rqrcuten)) allocate(rqrcuten(0,0)) + if (.not. associated(rqscuten)) allocate(rqscuten(0,0)) + +! MC -- adding below for tendency variables + if (.not. associated(rublten_tend)) allocate(rublten_tend(nVertLevels,nEdges+1)) + if (.not. associated(rugwdo_tend)) allocate(rugwdo_tend(nVertLevels,nEdges+1)) + if (.not. associated(rucuten_tend)) allocate(rucuten_tend(nVertLevels,nEdges+1)) + if (.not. associated(rthblten_tend)) allocate(rthblten_tend(nVertLevels,nCells+1)) + if (.not. associated(rthcuten_tend)) allocate(rthcuten_tend(nVertLevels,nCells+1)) + if (.not. associated(rthratenlw_tend)) allocate(rthratenlw_tend(nVertLevels,nCells+1)) + if (.not. associated(rthratensw_tend)) allocate(rthratensw_tend(nVertLevels,nCells+1)) + if (.not. associated(qvblten_tend)) allocate(qvblten_tend(nVertLevels,nCells+1)) + if (.not. associated(qvcuten_tend)) allocate(qvcuten_tend(nVertLevels,nCells+1)) -!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) ) - if(.not. associated(rvcuten) ) allocate(rvcuten(0,0) ) - if(.not. associated(rthcuten)) allocate(rthcuten(0,0)) - if(.not. associated(rqvcuten)) allocate(rqvcuten(0,0)) - if(.not. associated(rqccuten)) allocate(rqccuten(0,0)) - if(.not. associated(rqicuten)) allocate(rqicuten(0,0)) - if(.not. associated(rqrcuten)) allocate(rqrcuten(0,0)) - if(.not. associated(rqscuten)) allocate(rqscuten(0,0)) - - if(.not. associated(rublten) ) allocate(rublten(0,0) ) - if(.not. associated(rvblten) ) allocate(rvblten(0,0) ) - if(.not. associated(rthblten)) allocate(rthblten(0,0)) - if(.not. associated(rqvblten)) allocate(rqvblten(0,0)) - if(.not. associated(rqcblten)) allocate(rqcblten(0,0)) - if(.not. associated(rqiblten)) allocate(rqiblten(0,0)) - if(.not. associated(rqsblten)) allocate(rqsblten(0,0)) - if(.not. associated(rncblten)) allocate(rncblten(0,0)) - if(.not. associated(rniblten)) allocate(rniblten(0,0)) - if(.not. associated(rnifablten)) allocate(rnifablten(0,0)) - if(.not. associated(rnwfablten)) allocate(rnwfablten(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, & - index_qv,index_qc,index_qr,index_qi,index_qs, & - index_nc,index_ni,index_nifa,index_nwfa, & - mass,mass_edge,theta_m,scalars, & - rublten,rvblten,rthblten,rqvblten,rqcblten,rqiblten,rqsblten, & - rncblten,rniblten,rnifablten,rnwfablten, & - rucuten,rvcuten,rthcuten,rqvcuten,rqccuten,rqrcuten,rqicuten,rqscuten, & - rthratenlw,rthratensw,rublten_Edge,rucuten_Edge, & - tend_th,tend_rtheta_physics,tend_scalars,tend_ru_physics,tend_u_phys, & - exchange_halo_group) + block, mesh, nCells, nEdges, nCellsSolve, nEdgesSolve, rk_step, dynamics_substep, & + pbl_scheme, convection_scheme, microp_scheme, radt_lw_scheme, radt_sw_scheme, & + gwdo_scheme, config_tend, & ! diagnostics packages + index_qv, index_qc, index_qr, index_qi, index_qs, & + index_nc, index_ni, index_nifa, index_nwfa, & + mass, mass_edge, theta_m, scalars, & + rublten, rvblten, rthblten, rqvblten, rqcblten, rqiblten, rqsblten, & + rncblten, rniblten, rnifablten, rnwfablten, & + rucuten, rvcuten, rthcuten, rqvcuten, rqccuten, rqrcuten, rqicuten, rqscuten, & + rthratenlw, rthratensw, rublten_Edge, rucuten_Edge, & + ! MW on ITM + rubldiff, rvbldiff, & ! GWDO + rublten_tend, rucuten_tend, rugwdo_tend, & + rthblten_tend, rthcuten_tend, rthratenlw_tend, rthratensw_tend, & + qvblten_tend, qvcuten_tend, & + ! + tend_th, tend_rtheta_physics, tend_scalars, tend_ru_physics, & + tend_u_phys, & ! MC - will be removed + exchange_halo_group) + + !clean up any pointers that were allocated with zero size before the call to physics_get_tend_work: if(size(rucuten) == 0 ) deallocate(rucuten ) @@ -241,25 +315,45 @@ 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) +! MC -- adding below for tendency variables. only deallocate if allocated above + if (.not. config_tend) then + deallocate(rublten_tend) + deallocate(rugwdo_tend) + deallocate(rucuten_tend) + deallocate(rthblten_tend) + deallocate(rthcuten_tend) + deallocate(rthratenlw_tend) + deallocate(rthratensw_tend) + deallocate(qvblten_tend) + deallocate(qvcuten_tend) + end if + deallocate(tend_th) 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, & - index_qv,index_qc,index_qr,index_qi,index_qs, & - index_nc,index_ni,index_nifa,index_nwfa, & - mass,mass_edge,theta_m,scalars, & - rublten,rvblten,rthblten,rqvblten,rqcblten,rqiblten,rqsblten, & - rncblten,rniblten,rnifablten,rnwfablten, & - rucuten,rvcuten,rthcuten,rqvcuten,rqccuten,rqrcuten,rqicuten,rqscuten, & - rthratenlw,rthratensw,rublten_Edge,rucuten_Edge, & - tend_th,tend_theta,tend_scalars,tend_u,tend_u_phys, & + block, mesh, nCells, nEdges, nCellsSolve, nEdgesSolve, rk_step, dynamics_substep, & + pbl_scheme, convection_scheme, microp_scheme, radt_lw_scheme, radt_sw_scheme, & + gwdo_scheme, config_tend, & ! diagnostics packages + index_qv, index_qc, index_qr, index_qi, index_qs, & + index_nc, index_ni, index_nifa, index_nwfa, & + mass, mass_edge, theta_m, scalars, & + rublten, rvblten, rthblten, rqvblten, rqcblten, rqiblten, rqsblten, & + rncblten, rniblten, rnifablten, rnwfablten, & + rucuten, rvcuten, rthcuten, rqvcuten, rqccuten, rqrcuten, rqicuten, rqscuten, & + rthratenlw, rthratensw, rublten_Edge, rucuten_Edge, & + ! MW on ITM + rubldiff, rvbldiff, & ! GWDO + rublten_tend, rucuten_tend, rugwdo_tend, & + rthblten_tend, rthcuten_tend, rthratenlw_tend, rthratensw_tend, & + qvblten_tend, qvcuten_tend, & + ! + tend_th, tend_theta, tend_scalars, tend_u, & + tend_u_phys, & ! MC - will be removed exchange_halo_group) !================================================================================================================= - !input arguments: procedure(halo_exchange_routine):: exchange_halo_group @@ -271,6 +365,8 @@ 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):: gwdo_scheme ! MW on ITM: GWDO + logical, intent(in) :: config_tend ! MC added for ITM integer,intent(in):: nCells,nEdges,nCellsSolve,nEdgesSolve integer,intent(in):: rk_step,dynamics_substep @@ -310,31 +406,69 @@ subroutine physics_get_tend_work( & real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: rublten_Edge real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: rucuten_Edge real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: tend_u - real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: tend_u_phys - real(kind=RKIND),intent(inout),dimension(nVertLevels,nCells+1):: tend_th real(kind=RKIND),intent(inout),dimension(nVertLevels,nCells+1):: tend_theta - real(kind=RKIND),intent(inout),dimension(num_scalars,nVertLevels,nCells+1):: tend_scalars +! For diagnostics packages + real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: tend_u_phys ! MC - eventually remove + +! MW on ITM + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rubldiff + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rvbldiff + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: rucuten_tend + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: rublten_tend + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: rugwdo_tend + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: rthcuten_tend + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: rthblten_tend + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: rthratenlw_tend + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: rthratensw_tend + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: qvblten_tend + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: qvcuten_tend + + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: rubldiff_Edge ! local +! end MW + !local variables: integer:: i,k - real(kind=RKIND):: coeff + real(kind=RKIND):: coeff + +!========================================================================================== + + ! MW on ITM: diagnosing tendences due to GWDO scheme: + call mpas_timer_start('Tendency and PV diagnostics') ! MC - added timer for dedicated diag calculation + if (config_tend .and. (gwdo_scheme .ne. 'off')) then ! MC - added config_tend flag here. otherwise will break if config_tend is off due to halo group specs + if (rk_step == 1 .and. dynamics_substep == 1) then + ! note: uncoupled tendency doesn't change over dynamic full time step/ + ! physics is only called once per timestep + call exchange_halo_group(block % domain, 'physics:bldiff') + call tend_toEdges(block,mesh,rubldiff,rvbldiff,rubldiff_Edge) + end if + + do i = 1, nEdgesSolve + do k = 1, nVertLevels + rugwdo_tend(k,i) = rubldiff_Edge(k,i)*mass_edge(k,i) + end do + end do + + end if + call mpas_timer_stop('Tendency and PV diagnostics') + ! end GWDO -!----------------------------------------------------------------------------------------------------------------- -!add coupled tendencies due to PBL processes: - if(pbl_scheme .ne. 'off') then - if(rk_step == 1 .and. dynamics_substep == 1) then + !add coupled tendencies due to PBL processes: + if (pbl_scheme .ne. 'off') then + if (rk_step == 1 .and. dynamics_substep == 1) then call exchange_halo_group(block%domain,'physics:blten') call tend_toEdges(block,mesh,rublten,rvblten,rublten_Edge) - tend_u_phys(1:nVertLevels,1:nEdges) = rublten_Edge(1:nVertLevels,1:nEdges) + tend_u_phys(1:nVertLevels,1:nEdges) = rublten_Edge(1:nVertLevels,1:nEdges) ! MC -- will be removed end if do i = 1, nEdgesSolve do k = 1, nVertLevels tend_u(k,i)=tend_u(k,i)+rublten_Edge(k,i)*mass_edge(k,i) + rublten_tend(k,i) = rublten_Edge(k,i)*mass_edge(k,i) ! MW on ITM enddo enddo @@ -344,6 +478,10 @@ subroutine physics_get_tend_work( & tend_scalars(index_qv,k,i) = tend_scalars(index_qv,k,i) + rqvblten(k,i)*mass(k,i) tend_scalars(index_qc,k,i) = tend_scalars(index_qc,k,i) + rqcblten(k,i)*mass(k,i) tend_scalars(index_qi,k,i) = tend_scalars(index_qi,k,i) + rqiblten(k,i)*mass(k,i) + + + rthblten_tend(k,i) = rthblten(k,i)*mass(k,i) ! MW on ITM + qvblten_tend(k,i) = rqvblten(k,i) ! MW on ITM; decoupled using mass at time t in advance_scalar_mono enddo enddo @@ -364,14 +502,17 @@ subroutine physics_get_tend_work( & endif -!add coupled tendencies due to convection: - if(convection_scheme .ne. 'off') then + !add coupled tendencies due to convection: + if (convection_scheme .ne. 'off') then do i = 1, nCellsSolve do k = 1, nVertLevels tend_th(k,i) = tend_th(k,i) + rthcuten(k,i)*mass(k,i) tend_scalars(index_qv,k,i) = tend_scalars(index_qv,k,i) + rqvcuten(k,i)*mass(k,i) tend_scalars(index_qc,k,i) = tend_scalars(index_qc,k,i) + rqccuten(k,i)*mass(k,i) tend_scalars(index_qi,k,i) = tend_scalars(index_qi,k,i) + rqicuten(k,i)*mass(k,i) + + rthcuten_tend(k,i) = rthcuten(k,i)*mass(k,i) ! MW on ITM + qvcuten_tend(k,i) = rqvcuten(k,i) ! MW on ITM; decoupled using mass at time t in advance_scalar_mono enddo enddo @@ -389,7 +530,7 @@ subroutine physics_get_tend_work( & call exchange_halo_group(block%domain,'physics:cuten') call tend_toEdges(block,mesh,rucuten,rvcuten,rucuten_Edge) - tend_u_phys(1:nVertLevels,1:nEdges) = tend_u_phys(1:nVertLevels,1:nEdges) & + tend_u_phys(1:nVertLevels,1:nEdges) = tend_u_phys(1:nVertLevels,1:nEdges) & ! MC -- will be removed + rucuten_Edge(1:nVertLevels,1:nEdges) endif do i = 1, nEdgesSolve @@ -403,31 +544,43 @@ subroutine physics_get_tend_work( & endif -!add coupled tendencies due to longwave radiation: - if(radt_lw_scheme .ne. 'off') then + !add coupled tendencies due to longwave radiation: + if (radt_lw_scheme .ne. 'off') then do i = 1, nCellsSolve do k = 1, nVertLevels tend_th(k,i) = tend_th(k,i) + rthratenlw(k,i)*mass(k,i) + + rthratenlw_tend(k,i) = rthratenlw(k,i)*mass(k,i) ! MW on ITM enddo enddo endif -!add coupled tendencies due to shortwave radiation: - if(radt_sw_scheme .ne. 'off') then + !add coupled tendencies due to shortwave radiation: + if (radt_sw_scheme .ne. 'off') then do i = 1, nCellsSolve do k = 1, nVertLevels tend_th(k,i) = tend_th(k,i) + rthratensw(k,i)*mass(k,i) + + rthratensw_tend(k,i) = rthratensw(k,i)*mass(k,i) ! MW on ITM enddo enddo endif -!convert the tendency for the potential temperature to tendency for the modified potential temperature: + !convert the tendency for the potential temperature to tendency for the modified potential temperature: do i = 1, nCellsSolve do k = 1, nVertLevels coeff = (1. + R_v/R_d * scalars(index_qv,k,i)) tend_th(k,i) = coeff * tend_th(k,i) + R_v/R_d * theta_m(k,i) * tend_scalars(index_qv,k,i) / coeff + + ! MW on ITM + rthblten_tend(k,i) = coeff * rthblten_tend(k,i) + R_v/R_d * theta_m(k,i) * mass(k,i)*qvblten_tend(k,i) / coeff + rthcuten_tend(k,i) = coeff * rthcuten_tend(k,i) + R_v/R_d * theta_m(k,i) * mass(k,i)*qvcuten_tend(k,i) / coeff + rthratenlw_tend(k,i) = coeff * rthratenlw_tend(k,i) + rthratensw_tend(k,i) = coeff * rthratensw_tend(k,i) + ! MW:end + tend_theta(k,i) = tend_theta(k,i) + tend_th(k,i) enddo enddo From 571bef98d425afae347b07458509e4f56d8c167a Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Mon, 1 Jul 2024 23:31:23 -0600 Subject: [PATCH 04/23] Cleaned up Registry_tendencies.xml - Removed extraneous variables - Changed descriptions to specify tendencies of moist potential temperature --- .../diagnostics/Registry_diagnostics.xml | 11 ++- .../diagnostics/Registry_tendencies.xml | 74 +++++-------------- 2 files changed, 25 insertions(+), 60 deletions(-) diff --git a/src/core_atmosphere/diagnostics/Registry_diagnostics.xml b/src/core_atmosphere/diagnostics/Registry_diagnostics.xml index 322d5148cf..fb6d55badf 100644 --- a/src/core_atmosphere/diagnostics/Registry_diagnostics.xml +++ b/src/core_atmosphere/diagnostics/Registry_diagnostics.xml @@ -26,7 +26,14 @@ - + + + + + - - - - @@ -83,42 +79,6 @@ description="Uncoupled vertical momentum tendency from diffusion" packages="tendencies"/> - - - - - - - - - - - - - - - - - - @@ -145,39 +105,39 @@ @@ -244,35 +204,35 @@ packages="tendencies"/> From 7622e5d316afe62e3a844d49d5f2f8bfcc1a4e19 Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Mon, 8 Jul 2024 18:29:42 -0600 Subject: [PATCH 05/23] Fix order of calls to timers --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 9c0fb47fbe..8ba48bd4b1 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1184,8 +1184,8 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) dt_dynamics, dynamics_substep, dynamics_split ) end do !$OMP END PARALLEL DO - call mpas_timer_stop('Tendency and PV diagnostics') call mpas_timer_stop('atm_accumulate_tend') + call mpas_timer_stop('Tendency and PV diagnostics') end if @@ -1231,8 +1231,8 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) exchange_halo_group) end do !$OMP END PARALLEL DO - call mpas_timer_stop('Tendency and PV diagnostics') call mpas_timer_stop('atm_reconstruct_tend') + call mpas_timer_stop('Tendency and PV diagnostics') end if From ae664a18c81d873f1218da24adb5f46a214101f7 Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Mon, 8 Jul 2024 22:43:49 -0600 Subject: [PATCH 06/23] Halo framework for PV diags, calcs of PV and DT - Modified mpas_atm_halos.F to include halo groups for variables used in PV calculations: For ertel_pv: -- diagnostics:pv_diag For DT identification: -- diagnostics:inStrato (integer fields currently unsupported for mpas_halo_exch_group) -- diagnostics:inTropo (integer fields currently unsupported for mpas_halo_exch_group) -- diagnostics:iLev_DT (integer fields currently unsupported for mpas_halo_exch_group) For PV tendencies: -- diagnostics:dpv_prev -- diagnostics:dpv_th_tend -- diagnostics:dpv_mom_tend -- diagnostics:dpv_mom_curl For microphysics PV tendencies: -- diagnostics:dpv_mp_tend - Starting from scratch, recreated mpas_pv_diagnostics.F and implemented subroutines to calculate ertel_pv, identify the dynamic tropopause, and interpolate static fields to the DT - Adapted relevant subroutines in mpas_pv_diagnostics.F to use new halo communication groups. The approach I took was modeled after the few scripts in core_atmosphere that had already done this is and is possibly an overly complicated way of calling the needed arguments (like domain), which are ultimately passed down to the PV code from mpas_atm_core.F. Thus, code changes propagate up to that script and include modifications to the following: -- atm_compute_pv_diagnostics in mpas_pv_diagnostics.F -- pv_diagnostics_update and pv_diagnostics_compute in mpas_pv_diagnostics.F, called by mpas_atm_diagnostics_manager.F -- mpas_atm_diagnostics_manager.F to support changes to the PV subroutine calls and include input arguments to mpas_atm_diag_update and mpas_atm_diag_compute -- mpas_atm_core.F to support the new arguments called in mpas_atm_diag_update and mpas_atm_diag_compute Note that the DT identification routines in mpas_pv_diagnositcs.F require halo communication, but the communicated fields are integers and are thus currently incompatable with the new MPAS halo groups. I left these as-is. --- .../mpas_atm_diagnostics_manager.F | 48 +- .../diagnostics/mpas_pv_diagnostics.F | 3299 +++++++++-------- src/core_atmosphere/mpas_atm_core.F | 13 +- src/core_atmosphere/mpas_atm_halos.F | 205 + 4 files changed, 2096 insertions(+), 1469 deletions(-) diff --git a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F index fb57411d1d..e90b2dca90 100644 --- a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F +++ b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F @@ -7,6 +7,30 @@ ! module mpas_atm_diagnostics_manager + use mpas_timer + + ! MC: added new halo communication interface here for updated PV diagnostics + ! not sure if this is necessary or is the best approach to using those + ! routines in the PV code, but I didn't know how else to do it. This + ! approach essentially propagates modifications to all PV calculation + ! calls up to the mpas_atm_core.F code. + ! + ! 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 + + private public :: mpas_atm_diag_setup, & @@ -57,9 +81,12 @@ subroutine mpas_atm_diag_setup(stream_mgr, configs, structs, clock, dminfo) call isobaric_diagnostics_setup(structs, clock) call cloud_diagnostics_setup(structs, clock) call convective_diagnostics_setup(structs, clock) - call pv_diagnostics_setup(structs, clock) call soundings_setup(configs, structs, clock, dminfo) + call mpas_timer_start('Tendency and PV diagnostics') + call pv_diagnostics_setup(configs, structs, clock) + call mpas_timer_stop('Tendency and PV diagnostics') + end subroutine mpas_atm_diag_setup @@ -73,17 +100,24 @@ end subroutine mpas_atm_diag_setup !> MPAS_atm_diag_update. ! !----------------------------------------------------------------------- - subroutine mpas_atm_diag_update() + subroutine mpas_atm_diag_update(domain, exchange_halo_group) use mpas_diagnostic_template, only : diagnostic_template_update use mpas_convective_diagnostics, only : convective_diagnostics_update + use mpas_pv_diagnostics, only : pv_diagnostics_update implicit none + type (domain_type), intent(inout) :: domain + procedure (halo_exchange_routine) :: exchange_halo_group call diagnostic_template_update() call convective_diagnostics_update() + call mpas_timer_start('Tendency and PV diagnostics') + call pv_diagnostics_update(domain, exchange_halo_group) + call mpas_timer_stop('Tendency and PV diagnostics') + end subroutine mpas_atm_diag_update @@ -97,7 +131,7 @@ end subroutine mpas_atm_diag_update !> MPAS_atm_diag_compute. ! !----------------------------------------------------------------------- - subroutine mpas_atm_diag_compute() + subroutine mpas_atm_diag_compute(domain, exchange_halo_group) use mpas_diagnostic_template, only : diagnostic_template_compute use mpas_isobaric_diagnostics, only : isobaric_diagnostics_compute @@ -108,14 +142,20 @@ subroutine mpas_atm_diag_compute() implicit none + type (domain_type), intent(inout) :: domain ! MC added + procedure (halo_exchange_routine) :: exchange_halo_group ! MC added + call diagnostic_template_compute() call isobaric_diagnostics_compute() call cloud_diagnostics_compute() call convective_diagnostics_compute() - call pv_diagnostics_compute() call soundings_compute() + call mpas_timer_start('Tendency and PV diagnostics') + call pv_diagnostics_compute(domain, exchange_halo_group) + call mpas_timer_stop('Tendency and PV diagnostics') + end subroutine mpas_atm_diag_compute diff --git a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F index d21061b0fb..c0ea8e9c86 100644 --- a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F @@ -2,1649 +2,2026 @@ ! and the University Corporation for Atmospheric Research (UCAR). ! ! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! +! Additional copyright and license information can be found in the +! LICENSE file +! distributed with this code, or at +! http://mpas-dev.github.com/license.html +!================================================================================================================= + module mpas_pv_diagnostics - use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type - use mpas_kind_types, only : RKIND + use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type, domain_type + use mpas_kind_types, only : RKIND, StrKIND + use mpas_log, only : mpas_log_write type (MPAS_pool_type), pointer :: mesh type (MPAS_pool_type), pointer :: state type (MPAS_pool_type), pointer :: diag -#ifdef DO_PHYSICS type (MPAS_pool_type), pointer :: tend type (MPAS_pool_type), pointer :: tend_physics -#endif + type (MPAS_pool_type), pointer :: diag_physics + type (MPAS_pool_type), pointer :: configs type (MPAS_clock_type), pointer :: clock + type (domain_type), pointer :: domain - public :: pv_diagnostics_setup, & - pv_diagnostics_compute + ! + ! Abstract interface for routine used to communicate halos of fields + ! in a named group + ! + abstract interface + subroutine halo_exchange_routine(domain, halo_group, ierr) - private + use mpas_derived_types, only : domain_type - logical :: need_ertel_pv, need_u_pv, need_v_pv, need_theta_pv, need_vort_pv, need_iLev_DT, & - need_tend_lw, need_tend_sw, need_tend_bl, need_tend_cu, need_tend_mix, need_tend_mp, & - need_tend_diab, need_tend_fric, need_tend_diab_pv, need_tend_fric_pv, need_dtheta_mp + type (domain_type), intent(inout) :: domain + character(len=*), intent(in) :: halo_group + integer, intent(out), optional :: ierr + end subroutine halo_exchange_routine + end interface - contains + public :: pv_diagnostics_setup, & + pv_diagnostics_compute, & + pv_diagnostics_update + private - !----------------------------------------------------------------------- - ! routine pv_diagnostics_setup + !===================================================================================================================== + ! MPAS code to compute Ertel's potential vorticity and tendency contributions to the Eulerian PV budget + !===================================================================================================================== + ! Original diagnostics code was written by Nick Szapiro - 2016 + ! Significant changes to the code were made by Manda Chasteen (chasteen@ucar.edu) and May Wong (mwong@ucar.edu) - 2023 + ! + ! Reference: Chasteen et al. 2024: "A potential vorticity diagnostics package for MPAS-Atmosphere", Journal of Advances + ! in Modeling Earth Systems (JAMES) + ! + ! -------------------------------------------------------------------------------------------------------------------- + ! + ! Note: this revised PV diagnostics package is heavily reliant upon tendency calculations associated with the ITM + ! tendency package. Thus, config_pv_tend and all dependencies require config_tend to be active. + ! + ! Added namelist options for ease of toggling on PV diagnostics calculations + ! -- config_pv_diag : flag for whether the 3D PV field and fields interpolated to dynamic tropopause are desired + ! -- config_pv_tend : flag for whether PV tendency diagnostics are desired (required for config_pv_microphys, + ! config_pv_isobaric) + ! -- config_pv_scalar : flag for whether pv_scalar is initialized as PV and then transported as passive scalar + ! throughout the model integration + ! -- config_pv_microphys : flag for whether specific microphysics process PV tendencies are desired (Thompson only) + ! -- config_pv_isobaric : flag for whether isobaric interpolation of PV diagnostics variables is desired + ! (requires mods to mpas_isobaric_diagnostics.F) + ! + ! -------------------------------------------------------------------------------------------------------------------- + ! Subroutines contained in fully updated mpas_pv_diagnostics.F: + ! ------------------------------------------------------------ + ! pv_diagnostics_setup : setup diagnostics package and performs initial check of PV config flags + ! pv_diagnostics_reset : calls store_previous_vars to save previous timestep variables and pv_diagnostics_dyn_init + ! : to initialize and reset the computed theta and momentum tendencies as zeros + ! pv_diagnostics_update : calls atm_compute_pv_diagnostics and atm_compute_pvBudget_diagnostics to compute PV, all + ! PV tendency variables, and interpolation of variables onto identified dynamic tropopause + ! pv_diagnostics_init : initializes PV scalar variable if desired and not a restart run. called in a + ! new subroutine mpas_atm_diag_pv_init() that is then explicitly called in mpas_atm_core.F + ! pv_diagnostics_compute : calls ertel_pv and DT interpolation calculations if PV tendencies are disabled; this allows + ! PV to be calculated prior to writing an outfile instead of every time step + ! + ! Order that subroutines are called in mpas_atm_core: + ! -- At model initialziation: pv_diagnostics_reset, pv_diagnostics_update, pv_diagnostics_init, pv_diagnostics_compute, + ! pv_diagnostics_reset + ! + ! -- During time step integration: pv_diagnostics_update, pv_diagnostics_compute, pv_diagnostics_reset + ! ******************************************************************************************************************** ! - !> \brief Initialize the diagnostic - !> \author - !> \date - !> \details - !> Initialize the diagnostic + ! Changes made from the original PV diagnostics code include: + ! ----------------------------------------------------------- + ! * Different formulation for calculation of horizontal gradients on native MPAS grid. The updated method is based on + ! Eq. 22 in Ringler et al. (2010) and is more robust than the previous method implemented by NS + ! * Reconstruction of horizontal gradients on each cell's edges to the cell center following the same method as the + ! horizontal wind reconstruction in mpas_vector_reconstruction.F + ! * Changes to the calculation of the PV tendency terms to ensure that the correct time levels are used for the + ! coefficients, as determined by discretizing the equation for PV. We employ consistent time levels for all relevant + ! PV tendencies computed in MPAS: + ! -- in diabatic PV tendencies, the 3D absolute vorticity vector from time level t + ! -- in frictional PV tendencies, the 3D potential temperature gradient from time level t+dt + ! -- density from t+dt is used in all relevant calculations + ! This important change requires storing fields from the beginning of the time step to be used in the PV tendency + ! calculations because the model state and diagnostic fields are updated and assigned to time level 1 before the + ! PV diagnostics are called at the end of the time step in mpas_atm_core.F. Thus, before this change was + ! implemented, the updated variables from the end of the time step were incorrectly used alongside all these + ! tendencies. + ! * Update required to mpas_atm_core.F to ensure that diagnostic quantities theta and rho are updated at each time + ! step. Previously, these were only calculated if alarm bell for writing an outfile was activated + ! * Split frictional tendencies into components from explicit mixing, PBL+GWD schemes, and cumulus schemes, which + ! are then summed to produce the full frictional tendency depv_dt_fric. This required the introduction of individual + ! momentum tendency variables and renders the original tend_u_phys term obsolute, which has therefore been removed. + ! These tendencies are derived from the coupled momentum tendencies rather than taking the uncoupled tendencies + ! directly from physics. + ! * Corrections were made to the diffusion friction tendency terms, which had previously called tend_u_euler and + ! tend_w_euler variables that comprised other momentum tendencies in addition to diffusion. These required calculating + ! additional variables, u_tend_diff and w_tend_diff, in mpas_atm_time_integration.F that contain only the tendency + ! contributions from diffusion. + ! * The potential temperature tendency (dtheta_dt_mix) that is input into the diabatic diffusion tendency calculation + ! was initially coupled to mass, which needed to be fixed. The tendency now is computed by decoupling the theta_m + ! tendency associated with mixing from moisture (calculated in mpas_atm_time_integration), which is more accurate + ! and enables closing the theta and PV budgets. + ! * All physics diabatic tendencies have been modified to use the derived theta tendencies by decoupling the associated + ! theta_m tendencies from moisture, rather than the theta tendencies output directly from the physics schemes. Doing so + ! is more accurate and enables closing the theta and PV budgets. + ! * Modified interpolation of PV tendencies to dynamic tropopause routine to interpolate to the DT identified at the + ! beginning of the time step rather than at the end. This provides a better depiction of how processes may alter the + ! height of the DT over the time step + ! * Modified floodFill_tropo routine to better identify the dynamic tropopause in regions with low and/or negative + ! PV values aloft. + ! * Modified the DT interpolation routine (interp_pv) to mitigate prior issues of interpolating values to a falsely + ! identified DT point where the bounding levels didn't change from (sign(f)*PV) < 2 PVU to (sign(f)*PV) >= 2 PVU. + ! Interpolation weights assume this is true, leading to erroneous values of interpolated fields. ! - !----------------------------------------------------------------------- - subroutine pv_diagnostics_setup(all_pools, simulation_clock) + ! New additions include: + ! ------------------------------------------ + ! * Inclusion of dynamics tendencies for all relevant variables, enabling the dynamics (advective) contributions to the PV + ! budget to be accurately evaluated. The PV tendencies from dynamics do not include the effects of explicit diffusion, + ! which are included as diabatic and frictional PV tendencies. + ! * Incorporation of a PV passive scalar variable to advect initial PV field via the dynamics scalar transport routine + ! throughout the model integration. Requires config_pv_scalar = .true. + ! Note: using the PV scalar variable is a proxy for adiabatic PV transport and is not an adequate substitution + ! for the dynamics tendencies (i.e., the PV budget will not close if scalar transport is used in lieu of the + ! PV dynamics tendencies). + ! * Accumulated PV tendencies were added to permit the evaluation of the net PV tendencies without outputting the model + ! variables at each time step. + ! * Added PV tendencies for specific microphysical processes in the Thompson scheme: net condensation/evaporation of cloud + ! water, evaporation of rain water, net deposition/sublimation, melting, and freezing. Requires config_pv_microphys = .true. + ! Note: these tendencies use the theta tendencies from the microphysics scheme directly, whereas depv_dt_mp is calculated + ! using the derived theta tendency from the theta_m and qv tendencies. The differences in these approaches can be + ! ascertained by comparing depv_dt_mp to depv_dt_mp_allproc + ! * Incorporation of routine to interpolate PV diagnostics to isobaric levels (code also modified in isobaric_diagnostics.F) + ! and then accumulate the interpolated tendencies to isobaric levels. Requires config_pv_isobaric = .true. + ! Note: changes to this procedure requires making changes to mpas_isobaric_diagnostics.F and Registry_isobaric.xml + !===================================================================================================================== + contains + + !********************************************************************************************************************* + ! pv_diagnostics_setup: initialize the PV diagnostics when called in mpas_atm_diagnostics_manager.F + !********************************************************************************************************************* + + subroutine pv_diagnostics_setup(configs_in, all_pools, simulation_clock) use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type, MPAS_STREAM_OUTPUT, MPAS_STREAM_INPUT, & - MPAS_STREAM_INPUT_OUTPUT - use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type - use mpas_pool_routines, only : mpas_pool_get_subpool + MPAS_STREAM_INPUT_OUTPUT, MPAS_LOG_WARN + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_config + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array implicit none + type (MPAS_pool_type), pointer :: configs_in type (MPAS_pool_type), pointer :: all_pools type (MPAS_clock_type), pointer :: simulation_clock + logical, pointer :: config_pv_diag, config_pv_tend, config_pv_scalar, & + config_pv_microphys, config_pv_isobaric + + ! for zgrid_cell initialization + integer, pointer :: nCells, nVertLevels + real(kind=RKIND), dimension(:,:), pointer :: zgrid, zCell call mpas_pool_get_subpool(all_pools, 'mesh', mesh) call mpas_pool_get_subpool(all_pools, 'state', state) call mpas_pool_get_subpool(all_pools, 'diag', diag) -#ifdef DO_PHYSICS call mpas_pool_get_subpool(all_pools, 'tend', tend) call mpas_pool_get_subpool(all_pools, 'tend_physics', tend_physics) -#endif + call mpas_pool_get_subpool(all_pools, 'diag_physics', diag_physics) clock => simulation_clock - + configs => configs_in + + ! check configs (actual check is now done in mpas_atm_diagnostics_packages.F) + call mpas_pool_get_config(configs, 'config_pv_diag', config_pv_diag) + call mpas_pool_get_config(configs, 'config_pv_tend', config_pv_tend) + call mpas_pool_get_config(configs, 'config_pv_scalar', config_pv_scalar) + call mpas_pool_get_config(configs, 'config_pv_microphys', config_pv_microphys) + call mpas_pool_get_config(configs, 'config_pv_isobaric', config_pv_isobaric) + + call mpas_log_write(' ') + call mpas_log_write(' config_pv_diag is: $l', logicArgs=(/config_pv_diag/)) + call mpas_log_write(' config_pv_tend is: $l', logicArgs=(/config_pv_tend/)) + call mpas_log_write(' config_pv_microphys is: $l', logicArgs=(/config_pv_microphys/)) + call mpas_log_write(' config_pv_scalar is: $l', logicArgs=(/config_pv_scalar/)) + call mpas_log_write(' config_pv_isobaric is: $l', logicArgs=(/config_pv_isobaric/)) + call mpas_log_write(' ') + + ! If doing PV, need to initialize zCell array for vertical derivative calculations + if (config_pv_diag) then + call mpas_log_write(' ') + call mpas_log_write(' ----- Setting up PV diagnostics ----- ') + call mpas_log_write(' ') + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(diag, 'zgrid_cell', zCell) + + call interp_wLev_thetaLev(zgrid, nCells, nVertLevels, zCell) + call mpas_log_write("Initialized zgrid_cell array in PV diagnosics setup.") + call mpas_log_write(' ') + + end if + end subroutine pv_diagnostics_setup - !----------------------------------------------------------------------- - ! routine pv_diagnostics_compute - ! - !> \brief Compute diagnostic before model output is written - !> \author - !> \date - !> \details - !> Compute diagnostic before model output is written - ! - !----------------------------------------------------------------------- - subroutine pv_diagnostics_compute() - - use mpas_atm_diagnostics_utils, only : MPAS_field_will_be_written + !********************************************************************************************************************* + ! pv_diagnostics_update: compute the PV diagnostics over each time step when called in mpas_atm_diagnostics_manager.F + ! only if config_pv_tend is true. Else, compute PV field prior to writing outfile + !********************************************************************************************************************* + + subroutine pv_diagnostics_update(domain, exchange_halo_group) ! MC: modified with inputs for new halo exchange + use mpas_pool_routines, only: mpas_pool_get_config implicit none - logical :: need_any_diags, need_any_budget - - need_any_diags = .false. - need_any_budget = .false. - - - need_ertel_pv = MPAS_field_will_be_written('ertel_pv') - need_any_diags = need_any_diags .or. need_ertel_pv - need_u_pv = MPAS_field_will_be_written('u_pv') - need_any_diags = need_any_diags .or. need_u_pv - need_v_pv = MPAS_field_will_be_written('v_pv') - need_any_diags = need_any_diags .or. need_v_pv - need_theta_pv = MPAS_field_will_be_written('theta_pv') - need_any_diags = need_any_diags .or. need_theta_pv - need_vort_pv = MPAS_field_will_be_written('vort_pv') - need_any_diags = need_any_diags .or. need_vort_pv - need_iLev_DT = MPAS_field_will_be_written('iLev_DT') - need_any_diags = need_any_diags .or. need_iLev_DT - -#ifdef DO_PHYSICS - need_tend_lw = MPAS_field_will_be_written('depv_dt_lw') - need_any_diags = need_any_diags .or. need_tend_lw - need_any_budget = need_any_budget .or. need_tend_lw - need_tend_sw = MPAS_field_will_be_written('depv_dt_sw') - need_any_diags = need_any_diags .or. need_tend_sw - need_any_budget = need_any_budget .or. need_tend_sw - need_tend_bl = MPAS_field_will_be_written('depv_dt_bl') - need_any_diags = need_any_diags .or. need_tend_bl - need_any_budget = need_any_budget .or. need_tend_bl - need_tend_cu = MPAS_field_will_be_written('depv_dt_cu') - need_any_diags = need_any_diags .or. need_tend_cu - need_any_budget = need_any_budget .or. need_tend_cu - need_tend_mix = MPAS_field_will_be_written('depv_dt_mix') - need_any_diags = need_any_diags .or. need_tend_mix - need_any_budget = need_any_budget .or. need_tend_mix - need_dtheta_mp = MPAS_field_will_be_written('dtheta_dt_mp') - need_any_diags = need_any_diags .or. need_dtheta_mp - need_any_budget = need_any_budget .or. need_dtheta_mp - need_tend_mp = MPAS_field_will_be_written('depv_dt_mp') - need_any_diags = need_any_diags .or. need_tend_mp - need_any_budget = need_any_budget .or. need_tend_mp - need_tend_diab = MPAS_field_will_be_written('depv_dt_diab') - need_any_diags = need_any_diags .or. need_tend_diab - need_any_budget = need_any_budget .or. need_tend_diab - need_tend_fric = MPAS_field_will_be_written('depv_dt_fric') - need_any_diags = need_any_diags .or. need_tend_fric - need_any_budget = need_any_budget .or. need_tend_fric - need_tend_diab_pv = MPAS_field_will_be_written('depv_dt_diab_pv') - need_any_diags = need_any_diags .or. need_tend_diab_pv - need_any_budget = need_any_budget .or. need_tend_diab_pv - need_tend_fric_pv = MPAS_field_will_be_written('depv_dt_fric_pv') - need_any_diags = need_any_diags .or. need_tend_fric_pv - need_any_budget = need_any_budget .or. need_tend_fric_pv -#endif - - if (need_any_diags) then - call atm_compute_pv_diagnostics(state, 1, diag, mesh) - end if -#ifdef DO_PHYSICS - if (need_any_budget) then - call atm_compute_pvBudget_diagnostics(state, 1, diag, mesh, tend, tend_physics) - end if -#endif - - end subroutine pv_diagnostics_compute + type (domain_type), intent(inout) :: domain + procedure (halo_exchange_routine) :: exchange_halo_group + logical, pointer :: config_pv_diag, config_pv_tend + call mpas_pool_get_config(configs, 'config_pv_diag', config_pv_diag) + call mpas_pool_get_config(configs, 'config_pv_tend', config_pv_tend) - real(kind=RKIND) function dotProduct(a, b, sz) - implicit none + ! If config_pv_tend is true, compute PV and PV tendencies at each time step. + if (config_pv_tend) then + call mpas_log_write("Computing Ertel's PV.") + call atm_compute_pv_diagnostics(domain, configs, state, diag, mesh, exchange_halo_group) - real(kind=RKIND), dimension(:), intent(in) :: a, b - integer, intent(in) :: sz + end if - integer :: i - real(kind=RKIND) :: rsum + end subroutine pv_diagnostics_update - rsum = 0.0_RKIND - do i=1,sz - rsum = rsum + a(i)*b(i) - end do + !********************************************************************************************************************* + ! pv_diagnostics_compute: compute subroutine is only called prior to writing fields to outfile. + ! if config_pv_tend is false but config_pv_diag is true, compute PV prior to writing file. + !********************************************************************************************************************* + + subroutine pv_diagnostics_compute(domain, exchange_halo_group) ! MC: modified with inputs for new halo exchange + use mpas_pool_routines, only: mpas_pool_get_config + + implicit none + + type (domain_type), intent(inout) :: domain + procedure (halo_exchange_routine) :: exchange_halo_group + logical, pointer :: config_pv_diag, config_pv_tend - dotProduct = rsum - end function dotProduct + call mpas_pool_get_config(configs, 'config_pv_diag', config_pv_diag) + call mpas_pool_get_config(configs, 'config_pv_tend', config_pv_tend) - integer function elementIndexInArray(val, array, sz) + ! If config_pv_diag is true but config_pv_tend is false, compute PV before writing file. + if ((config_pv_diag) .and. (.not. config_pv_tend)) then + call mpas_log_write("Computing Ertel's PV prior to writing outfile.") + call atm_compute_pv_diagnostics(domain, configs, state, diag, mesh, exchange_halo_group) + end if - implicit none + end subroutine pv_diagnostics_compute - integer, intent(in) :: val - integer, dimension(:), intent(in) :: array - integer, intent(in) :: sz - - integer :: i, ind - ind = -1 - do i=1,sz - if (array(i)==val) then - ind = i - elementIndexInArray = ind !This returns, right? - exit !just in case :) + + !********************************************************************************************************************* + ! NS: Below are two subroutines (floodFill_strato and floodFill_tropo), designed to determine the first model level + ! above the dynamic tropopause, iLev_DT, which is designated as the 2-PVU isosurface. Only one of these subroutines + ! is used (toggled with "call floodFill_strato(mesh, diag, pvuVal, stratoPV)" and "call floodFill_tropo(mesh,diag,pvuVal)" + ! in the atm_compute_pv_diagnostics subroutine below. The routines *should* produce equivalent estimates for iLev_DT. + ! + ! MC - 2023: floodFill_tropo was updated to better ID the dynamic tropopause and should be used in lieu of + ! floodFill_strato. The two procedures should no longer be expected to produce equivalent iLev_DT estimates. + ! + ! MC Note - 05/30/2024: halo communication routine hasn't been updated due to mpas_halo_exch_group currently not + ! supporting integers. + !********************************************************************************************************************* + + subroutine floodFill_strato(mesh, diag, pvuVal, stratoPV) + !To find model level of dynamic tropopause: + !Simply searching down from TOA within each column to find first + !instance of 2-PVU surface (i.e., where the PV drops below values + !characteristic of the stratosphere) + !is buggy due to stratospheric wave breaking, which may induce + !regions of low PV (i.e., PV < 2 PVU) within the stratosphere and + !thus yield artifically + !high estimations of the tropopause height. This seems to be more + !problematic as the mesh gets finer and the vertical vorticity + !field exhibits greater variability + !or jumps. + !Note that these low-PV anomalies in the stratosphere may persist + !for long times w/ slow mixing downstream of mountains or deep + !convection. + !A few quicker fixes (e.g., make sure PV < 2 PVU for a number of + !layers; search down from 10 PVU instead of TOA) are hacky and not + !robust. + + !To (hopefully) alleviate the problems resulting from wave + !breaking, we can flood fill from a known + !stratosphere region (e.g., where the model top > 2 PVU) and + !filter down and around any problematic regions. + !The problem w/ using only the flood fill is that strong surface + !PV anomalies can connect to the 2-PVU surface aloft, + !and the resulting "flood-filled 2 PVU" region can have sizeable + !areas that are located just at/near the surface, while there is + !clearly a + !tropopause above (i.e., as evident in a vertical cross-section). + !To address the large near-surface blobs of PV > 2 PVU, will take + !the flood fill mask and try to move upward from near the surface + !to 10 PVU within a vertical column. + !If this can be done, then the low-level PV anomaly extends to the + !stratosphere. Else, remove the stratospheric designation to + !disconnect the "surface blob". + + !The "output" is iLev_DT, which is the vertical index for the + !model level just above the dynamic tropopause (i.e., where PV >= + !pvuVal, which is set below in atm_compute_pv_diagnostics to 2 + !PVU). + !If iLev_DT > nVertLevels, then pvuVal is found only above the + !column (i.e., entire column is in troposphere). If iLev_DT < 1, + !PV >= pvuVal extends vertically through the entire column + !(i.e., the entire column is within the stratosphere). + !Communication between blocks during the flood fill may be needed + !to treat some edge cases appropriately. + ! ------------------------------------------------------------------------- + + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_field + use mpas_dmpar, only : mpas_dmpar_max_int,mpas_dmpar_exch_halo_field + use mpas_derived_types, only : dm_info, field2DInteger + + implicit none + + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(inout) :: diag + real(kind=RKIND), intent(in) :: pvuVal, stratoPV + + integer :: iCell, k, nChanged, iNbr, iCellNbr, levInd, haloChanged, global_haloChanged !INCORPORATE LEVEL INDEX FOR REMOVING SFC BLOB + integer, pointer :: nCells, nVertLevels + integer, dimension(:), pointer :: nEdgesOnCell, iLev_DT + integer, dimension(:,:), pointer :: cellsOnCell, inStrato ! inStrato wasn't here in original procedure + + type (field2DInteger), pointer :: inStrato_f ! line added to match troposphere procedure workflow + + real(kind=RKIND) :: sgnHemi, sgn + real(kind=RKIND),dimension(:),pointer:: latCell + real(kind=RKIND), dimension(:,:), pointer :: ertel_pv + + type (dm_info), pointer :: dminfo + + integer, dimension(:,:), allocatable :: candInStrato ! whether point is potentially inStrato + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'latCell', latCell) + + call mpas_pool_get_array(diag, 'ertel_pv', ertel_pv) + call mpas_pool_get_array(diag, 'iLev_DT', iLev_DT) + call mpas_pool_get_array(diag, 'inStrato', inStrato) ! was allocated below in original script + + allocate(candInStrato(nVertLevels, nCells+1)) + !allocate(inStrato(nVertLevels, nCells+1)) + candInStrato(:,:) = 0 + inStrato(:,:) = 0 + + !store whether each grid point has |PV| >= pvuVal to avoid + !repeating logic. we'll use candInStrato as a isVisited marker for + !potential stratosphere grid points further below. + do iCell=1,nCells + sgnHemi = sign(1.0_RKIND, latCell(iCell)) !at the equator, sign(0)=0 + if (sgnHemi .EQ. 0.0) sgnHemi = 1.0_RKIND + do k=1,nVertLevels + sgn = ertel_pv(k,iCell)*sgnHemi-pvuVal + if (sgn .GE. 0) candInStrato(k,iCell) = 1 + end do + end do + + !loop over cells and top 5 model levels to seed flood fill with + !model top that's located above DT (i.e., where |PV| >= pvuVal). + !can have model top with PV below 2 PVU (e.g., in tropics) + nChanged = 0 + do iCell=1,nCells + do k=nVertLevels-5,nVertLevels + if (candInStrato(k,iCell) .GT. 0) then + inStrato(k,iCell) = 1 + !candInStrato(k,iCell) = 0 + nChanged = nChanged+1 + end if + end do + end do + + !flood fill from the determined seeds. since I don't know enough + !fortran, + !we'll just brute force a continuing loop rather than queue. + !here is where the changes to account for domain communication are + !needed. + + call mpas_pool_get_field(diag, 'inStrato', inStrato_f) + dminfo => inStrato_f % block % domain % dminfo + global_haloChanged = 1 + + do while(global_haloChanged .GT. 0) !any cell in a halo has changed, to propagate to other domains + global_haloChanged = 0 !aggregate the number of changed cells w/in the loop below + do while(nChanged .GT. 0) + nChanged = 0 + do iCell=1,nCells !should we look for neighbors of halo cells? + do k=nVertLevels,1,-1 ! loop over vertical levels from top down + !update if candidate and neighbor in strato + if ((candInStrato(k,iCell) .GT. 0) .AND. (inStrato(k,iCell).LT.1) ) then ! modified to match trop routine + !nbr above + if (k .LT. nVertLevels) then + if (inStrato(k+1,iCell) .GT. 0) then + inStrato(k,iCell) = 1 + !candInStrato(k,iCell) = 0 ! commented out to be + !consistent with trop routine + nChanged = nChanged+1 + cycle + end if + end if + + !side nbrs + do iNbr = 1, nEdgesOnCell(iCell) + iCellNbr = cellsOnCell(iNbr,iCell) + if (inStrato(k,iCellNbr) .GT. 0) then + inStrato(k,iCell) = 1 + !candInStrato(k,iCell) = 0 ! commented out to be + !consistent with trop routine + nChanged = nChanged+1 + !exit ! was cycle, but tropspheric loop has exit + !here. why? + cycle + end if + end do + + !nbr below + if (k .GT. 1) then + if (inStrato(k-1,iCell) .GT. 0) then + inStrato(k,iCell) = 1 + !candInStrato(k,iCell) = 0 ! commented out to be + !consistent with trop routine + nChanged = nChanged+1 + cycle + end if + end if + + end if !candInStrato + end do !levels + end do !cells + global_haloChanged = global_haloChanged+nChanged + end do !while w/in domain + + !communicate to other domains for edge case where a chunk of a + !block hasn't gotten to fill + nChanged = global_haloChanged + call mpas_dmpar_max_int(dminfo, nChanged, global_haloChanged) + if (global_haloChanged .GT. 0) then !communicate inStrato everywhere + call mpas_dmpar_exch_halo_field(inStrato_f) end if - end do - elementIndexInArray = ind - end function elementIndexInArray - - real(kind=RKIND) function formErtelPV(gradxu, gradtheta, density, unitX, unitY, unitZ) + nChanged = global_haloChanged !so each block will iterate again if anything changed + end do !while haloChanged + deallocate(candInStrato) + + + !Detach high surface PV blobs w/o vertical connection to + !"stratosphere" + do iCell=1,nCells + if (inStrato(1,iCell) .GT. 0) then + !see how high up we can walk in the column + do k=2,nVertLevels + if (inStrato(k,iCell) .LT. 1) then + exit + end if !k is highest connected level to sfc + sgnHemi = sign(1.0_RKIND, latCell(iCell)) !at the equator, sign(0)=0 + if (sgnHemi .EQ. 0.0) sgnHemi = 1.0_RKIND + sgn = ertel_pv(k,iCell)*sgnHemi-stratoPV + if (sgn .LT. 0) then !not actually connected to "stratosphere" + inStrato(1:k,iCell) = 0 + end if + end do !k + end if !inStrato at sfc + end do !iCell + + !Fill iLev_DT with the lowest level above the tropopause (If DT + !above column, iLev>nVertLevels. If DT below column, iLev=0. + nChanged = 0 + do iCell=1,nCells + do k=1,nVertLevels + if (inStrato(k,iCell) .GT. 0) then + nChanged = 1 + exit + end if + end do !k + if (nChanged .GT. 0) then !found lowest level + if (k .EQ. 1) then + sgnHemi = sign(1.0_RKIND, latCell(iCell)) + sgn = ertel_pv(k,iCell)*sgnHemi-pvuVal + if (sgn .GT. 0) then !whole column above DT + iLev_DT(iCell) = 0 + end if + else + iLev_DT(iCell) = k + end if + else !whole column below DT + iLev_DT(iCell) = nVertLevels+2 + end if + end do !iCell + + end subroutine floodFill_strato + + + !********************************************************************************************************************* + ! Preferred alternative approach: + ! MC Note - 05/30/2024: halo communication routine hasn't been updated due to mpas_halo_exch_group currently not + ! supporting integers. + !********************************************************************************************************************* + + subroutine floodFill_tropo(mesh, diag, pvuVal) + !To find model level of dynamic tropopause: + !Simply searching down from TOA within each column to find first + !instance of 2-PVU surface (i.e., where the PV drops below values + !characteristic of the stratosphere) + !is buggy due to stratospheric wave breaking, which may induce + !regions of low PV (i.e., PV < 2 PVU) within the stratosphere and + !thus yield artifically + !high estimations of the tropopause height. This seems to be more + !problematic as the mesh gets finer and the vertical vorticity + !field exhibits greater variability + !or jumps. + !Note that these low-PV anomalies in the stratosphere may persist + !for long times w/ slow mixing downstream of mountains or deep + !convection. + !A few quicker fixes (e.g., make sure PV < 2 PVU for a number of + !layers; search down from 10 PVU instead of TOA) are hacky and not + !robust. + + !Two flood fill subroutine options are to: + ! (1) floodFill_strato: flood fill the stratosphere (PV >= 2 PVU) + ! from stratosphere seeds placed near model top. Strong surface PV + ! anomalies can connect to 2-PVU region aloft, + ! and the resulting "flood-filled 2 PVU" can have sizeable + ! areas that are located just at/near the surface, while there + ! is clearly a tropopause above + ! (i.e., as evident in a vertical cross-section). To address + ! the large near-surface blobs of PV > 2 PVU, will take the + ! flood fill mask and try to move upward from + ! near the surface to 10 PVU within a vertical column. If this + ! can be done, then the low-level PV anomaly extends to the + ! stratosphere. Else, remove the stratospheric + ! designation to disconnect the "surface blob". + ! (2) floodFill_tropo: flood fill the troposphere (PV < 2 PVU) + ! from troposphere seeds placed near the surface. + ! + ! Comparing the two procedures... Somewhat paradoxically, the + ! bottom of the stratosphere is located lower than the top of the + ! troposphere. + + !The "output" is iLev_DT, which is the vertical index for the + !model level just above the dynamic tropopause (i.e., where PV >= + !pvuVal, which is set below in atm_compute_pv_diagnostics to 2 + !PVU). + !If iLev_DT > nVertLevels, then pvuVal is found only above the + !column (i.e., entire column is in troposphere). If iLev_DT < 1, + !PV >= pvuVal extends vertically through the entire column + !(i.e., the entire column is within the stratosphere). + !Communication between blocks during the flood fill may be needed + !to treat some edge cases appropriately. + + !Originally, it was assumed that each (MPI) domain would have > 0 + !cells with "right" DT found by flood filling. + !However, for "small" domains (especially over the poles -- for + !example, in the Arctic say during winter, when the entire surface + !can be capped by high PV), + !this becomes problematic. So, we need to communicate between + !domains during the flood fill procedure or else we will find the + !DT located at/near the surface. + !The extreme limiting case is if we had every cell as its own + !domain; then, it's clear that there has to be communication. + ! ------------------------------------------------------------------------- + + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_field + use mpas_dmpar, only : mpas_dmpar_max_int,mpas_dmpar_exch_halo_field + use mpas_derived_types, only : dm_info, field2DInteger, field1DInteger + + implicit none + + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(inout) :: diag + real(kind=RKIND), intent(in) :: pvuVal + + integer :: nbr_count, intCounts, levUse, tropCounts + integer :: iCell, k, kk, nChanged, iNbr, iCellNbr, levInd, haloChanged, global_haloChanged + integer, pointer :: nCells, nVertLevels + integer, dimension(:), pointer :: nEdgesOnCell, iLev_DT + integer, dimension(:,:), pointer :: cellsOnCell, inTropo, candInTropo, candInStrato + + type (field2DInteger), pointer :: inTropo_f + type (field1DInteger), pointer :: iLev_DT_f + + real(kind=RKIND) :: sgnHemi, sgn_pv + real(kind=RKIND),dimension(:),pointer:: latCell + real(kind=RKIND), dimension(:,:), pointer :: ertel_pv + + type (dm_info), pointer :: dminfo + + real(kind=RKIND), dimension(:,:), allocatable :: sgn, sgn2 + integer, dimension(:,:), allocatable :: oppSignPV, interfaceLev + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'latCell', latCell) + + call mpas_pool_get_array(diag, 'ertel_pv', ertel_pv) + call mpas_pool_get_array(diag, 'iLev_DT', iLev_DT) + call mpas_pool_get_array(diag, 'inTropo', inTropo) + call mpas_pool_get_array(diag, 'candInTropo', candInTropo) + call mpas_pool_get_array(diag, 'candInStrato', candInStrato) + + allocate(oppSignPV(nVertLevels, nCells+1)) + allocate(sgn(nVertLevels, nCells+1)) + allocate(sgn2(nVertLevels, nCells+1)) + allocate(interfaceLev(nVertLevels, nCells+1)) + + candInTropo(:,:) = 0 + candInStrato(:,:) = 0 + inTropo(:,:) = 0 + oppSignPV(:,:) = 0 + interfaceLev(:,:) = 0 + + sgn(:,:) = 0.0 + sgn2(:,:) = 0.0 + + ! Begin by looping over all cells and vertical levels and flagging cells as troposphere or stratosphere candidates + do iCell=1,nCells + sgnHemi = sign(1.0_RKIND, latCell(iCell)) !at the equator, sign(0)=0 + if (sgnHemi .EQ. 0.0) sgnHemi = 1.0_RKIND + do k=1,nVertLevels + sgn(k,iCell) = ertel_pv(k,iCell)*sgnHemi-pvuVal ! quantity will be positive for |PV| > pvuVal + + ! MC: Need to account for pockets of inertial/symmetric instability that develop at upper levels in lee of + ! mountains-- just excluding them as troposphere candidates works well, but this will lead to low estimates + ! of DT height if there's negative PV immediately below where PV drops below threshold + sgn_pv = sign(1.0_RKIND, ertel_pv(k,iCell)) + if (sgn_pv .EQ. 0.0) sgn_pv = sgnHemi ! if sign(PV) = 0, set to sign of latitude + sgn2(k,iCell) = sgnHemi*sgn_pv ! if sgn2 > 0, PV and latitude are of same sign + + ! Add flags for PV interfaces (i.e., where PV switches from < 2 PVU*sgnHemi to >= 2 PVU*sgnHemi + if (k .LT. nVertLevels) then + if ( ((sgnHemi .GT. 0) .AND. ((ertel_pv(k+1,iCell).GE.(pvuVal*sgnHemi)) & + .AND. (ertel_pv(k,iCell).LT.(pvuVal*sgnHemi)))) .OR. ((sgnHemi .LT. 0) & + .AND. ((ertel_pv(k+1,iCell).LE.(pvuVal*sgnHemi)) & + .AND. (ertel_pv(k,iCell).GT.(pvuVal*sgnHemi)))) ) then + + interfaceLev(k+1,iCell) = 1 ! set level above as interface level. these are DT level candidates + end if + end if + + ! Assign as either tropo or strato candidates or cells with opposite-sign PV + if ((sgn2(k,iCell) .GT. 0.0) .AND. (sgn(k,iCell) .LT. 0.0)) then ! latitude and PV are same sign; |PV| < 2 PVU + candInTropo(k,iCell) = 1 + + else if ((sgn2(k,iCell) .GT. 0.0) .AND. (sgn(k,iCell) .GE. 0.0)) then ! latitude and PV are same sign; but |PV| >= 2 PVU + candInStrato(k,iCell) = 1 + + else if (sgn2(k,iCell) .LT. 0.0) then ! latitude and PV are opposite sign + oppSignPV(k,iCell) = 1 + end if + + end do + end do + + ! Seed flood fill with near surface that's below DT (can have surface above 2 PVU from PV anoms). + ! Note that this would be wrong if low PV "stratospheric" blobs are right above the surface + nChanged = 0 + levInd = min(nVertLevels, 3) + do iCell=1,nCells + lev_loop: do k=1,levInd ! Assign points to troposphere in lowest 3 levels if they're tropo candidates + if (candInTropo(k,iCell) .GT. 0) then + inTropo(k,iCell) = 1 + nChanged = nChanged+1 + + ! Do assignment for cells above any low-level inTropo cells until stratospheric PV values are reached. This is partially + ! redundant, but allows assigning negative PV cells as troposphere candidates if above regions of low PV + if (k .EQ. levInd) then + vert_loop: do kk=levInd+1,nVertLevels + if ((candInTropo(kk,iCell) .GT. 0) .AND. ((oppSignPV(kk,iCell) .LT. 1) & ! cell identfied as trop candidate -- + .AND. (sgn(kk,iCell) .LT. 0.0))) then ! PV same sign as latitude; |PV| < 2 PVU + inTropo(kk,iCell) = 1 + nChanged = nChanged+1 + cycle vert_loop + + else if (oppSignPV(kk,iCell) .GT. 0) then ! PV is opposite sign as latitude -- + candInTropo(kk,iCell) = 1 ! assign as troposphere candidate + cycle vert_loop + + else if (candInStrato(kk,iCell) .GT. 0) then ! if stratosphere candidate is reached while + exit vert_loop ! moving upward, exit loop + end if + end do vert_loop + else + cycle lev_loop + end if - use mpas_constants, only : omega_e => omega + ! MC: Add a condition that allows inertially/symmetrically unstable points in the lowest 3 levels to be classified as in the troposphere + else if (oppSignPV(k,iCell) .GT. 0) then ! if opposite sign PV in lowest 3 levels + inTropo(k,iCell) = 1 + candInTropo(k,iCell) = 1 + nChanged = nChanged+1 + + if (k .EQ. levInd) then ! if opposite sign PV extends up to 3rd level, look at points above + vertical_loop: do kk=levInd+1,nVertLevels + if (oppSignPV(kk,iCell) .GT. 0) then ! PV is opposite sign as latitude -- assign as troposphere candidate + candInTropo(kk,iCell) = 1 + cycle vertical_loop + + ! Assign regions with same sign PV as latitude as being in troposphere if above negative low-level PV cell and a stratosphere candidate + ! has not yet been reached + else if ((candInTropo(kk,iCell) .GT. 0) .AND. ((oppSignPV(kk,iCell) .LT. 1) & ! cell identified as troposphere candidate -- + .AND. (sgn(kk,iCell) .LT. 0.0))) then ! PV same sign as latitude; PV < 2 PVU + inTropo(kk,iCell) = 1 + nChanged = nChanged+1 + cycle vertical_loop + + else if (candInStrato(kk,iCell) .GT. 0) then ! if candidate in stratosphere is reached moving upward, exit loop + exit vertical_loop + end if + end do vertical_loop + end if + end if + end do lev_loop + end do + + ! Flood fill from the given seeds. since I don't know enough fortran, + ! we'll just brute force a continuing loop rather than queue. + call mpas_pool_get_field(diag, 'inTropo', inTropo_f) + dminfo => inTropo_f % block % domain % dminfo + global_haloChanged = 1 + + do while(global_haloChanged .GT. 0) ! any cell in a halo has changed, to propagate to other domains + global_haloChanged = 0 ! aggregate the number of changed cells w/in the loop below + do while(nChanged .GT. 0) + nChanged = 0 + + do iCell=1,nCells ! should we look for neighbors of halo cells? + vert_loop_halo: do k=1,nVertLevels + + ! for points that are troposphere candidates and not yet assigned to troposphere: + if ((candInTropo(k,iCell) .GT. 0) .AND. (inTropo(k,iCell) .LT. 1) ) then + ! evaluate whether cell below was identified as in the troposphere or not in stratosphere and not opposite sign PV + + ! neighbor below: + if (k .GT. 1) then + if ((inTropo(k-1,iCell) .GT. 0) .OR. ((candInStrato(k-1,iCell) .LT. 1) .AND. oppSignPV(k-1,iCell) .LT. 1)) then + inTropo(k,iCell) = 1 + nChanged = nChanged+1 + cycle vert_loop_halo ! if so, move onto the next vertical level + end if + end if + + ! side neighbors + nbr_loop: do iNbr = 1, nEdgesOnCell(iCell) + iCellNbr = cellsOnCell(iNbr,iCell) + if (inTropo(k,iCellNbr) .GT. 0) then + ! add constraints that for neighbor to lead to trop classification, must be either bounded above or below by points + ! meeting trop classification + if (k .LT. nVertLevels) then + if (inTropo(k+1,iCell) .GT. 0) then ! try requiring that cell above is already assigned to trop... + inTropo(k,iCell) = 1 ! does this work with iteration? + nChanged = nChanged+1 + cycle vert_loop_halo ! cycle. if just exiting, will still do nbr above loop, inflating nChanged count. + end if + + else if (k .GT. 1) then ! if cell below was not assigned to stratosphere (this likely would've been established + if (candInStrato(k-1,iCell) .LT. 1) then ! by neighbor below loop, but just in case...) + inTropo(k,iCell) = 1 + nChanged = nChanged+1 + cycle vert_loop_halo + end if + end if + end if + end do nbr_loop + + !neighbor above + if (k .LT. nVertLevels) then + if (inTropo(k+1,iCell) .GT. 0) then + inTropo(k,iCell) = 1 + nChanged = nChanged+1 + cycle vert_loop_halo + end if + end if + + end if !candInTropo + end do vert_loop_halo + end do !cells + global_haloChanged = global_haloChanged+nChanged + end do !while w/in domain + + ! communicate to other domains for edge case where a chunk of a block hasn't gotten to fill + nChanged = global_haloChanged + call mpas_dmpar_max_int(dminfo, nChanged, global_haloChanged) + + if (global_haloChanged .GT. 0) then ! communicate inTropo everywhere + call mpas_dmpar_exch_halo_field(inTropo_f) ! MC note: this has not been updated with new mpas_halo group. + end if + nChanged = global_haloChanged ! so each block will iterate again if anything changed + end do !while haloChanged + + ! Moving downward, fill iLev_DT with the lowest level above the tropopause (If DT + ! above column, iLev>nVertLevels. If DT below column, iLev=0. + ! NS -- Note for original floodFill_tropo routine: would find highest tropopause level in scenarios with a double tropopause + do iCell=1,nCells + !Keep a tally + nChanged = 0 + intCounts = 0 + tropCounts = 0 + intCounts = COUNT(interfaceLev(:,iCell)==1) ! Number of interface levels in vertical column + tropCounts = COUNT(inTropo(:,iCell)==1) ! Number of assigned troposphere cells + + ! First, deal with columns that are entirely in troposphere (i.e., in tropics) because many fail these routines... + if (tropCounts .EQ. nVertLevels) then + nChanged = 1 + levUse = nVertLevels+1 + + else + ! Loop over vertical levels beginning at the top + lev_id: do k=nVertLevels,1,-1 + + ! If PV interface exists in column, then look for those interfaces in vertical loop + ! MC note: the code below is very hacky, but overall does a pretty decent job. However, these vertical continuinity + ! thresholds are very much arbitrary + if (intCounts .GT. 0) then + ! if DT candidate level identified + if (interfaceLev(k,iCell) .GT. 0) then + + !Evaluate PV values and vertical continuity around interfaceLev: + if (k .GT. 5) then + ! if next level below was assigned inTropo and following 4 levels don't have PV characteristic of stratosphere + if ((inTropo(k-1,iCell) .GT. 0) .AND. (candInStrato(k-2,iCell) .LT. 1) .AND. (candInStrato(k-3,iCell) .LT. 1) .AND. & + (candInStrato(k-4,iCell) .LT. 1) .AND. (candInStrato(k-5,iCell) .LT. 1)) then + nChanged = 1 + levUse = k + exit lev_id + + ! if next level below was IDed as troposphere candidate, one of following 2 levels is also troposphere candidate, + ! and none of following 4 levels have PV characteristic of stratosphere + else if ((candInTropo(k-1,iCell).GT.0) .AND. (candInStrato(k-2,iCell) .LT. 1) .AND. (candInStrato(k-3,iCell) .LT. 1) .AND. & + (candInStrato(k-4,iCell) .LT. 1) .AND. (candInStrato(k-5,iCell) .LT. 1) .AND. & + ((candInTropo(k-2,iCell).GT.0) .OR. (candInTropo(k-3,iCell).GT.0))) then + nChanged = 1 + levUse = k + exit lev_id + + ! if 5 consecutive levels beneath interface don't have characteristics of stratosphere and at least one of three levels + ! beneath interface has characteristics of troposphere + else if ((candInStrato(k-1,iCell) .LT. 1) .AND. (candInStrato(k-2,iCell) .LT. 1) .AND. (candInStrato(k-3,iCell) .LT. 1) .AND. & + (candInStrato(k-4,iCell) .LT. 1) .AND. (candInStrato(k-5,iCell) .LT. 1) .AND. ((candInTropo(k-1,iCell) .GT. 0) .OR. & + (candInTropo(k-2,iCell) .GT. 0) .OR. (candInTropo(k-3,iCell) .GT. 0))) then + nChanged = 1 + levUse = k + exit lev_id + + end if + end if ! k > 5 + + ! otherwise, if no stratospheric characterstics for at least 8 consecutive levels + if (k .GT. 8) then + if ((candInStrato(k-1,iCell) .LT. 1) .AND. (candInStrato(k-2,iCell) .LT. 1) .AND. (candInStrato(k-3,iCell) .LT. 1) .AND. & + (candInStrato(k-4,iCell) .LT. 1) .AND. (candInStrato(k-5,iCell) .LT. 1) .AND. (candInStrato(k-6,iCell) .LT. 1) .AND. & + (candInStrato(k-7,iCell) .LT. 1) .AND. (candInStrato(k-8,iCell) .LT. 1) ) then + nChanged = 1 + levUse = k + exit lev_id + end if + end if - implicit none + ! account for interfaces near the surface (e.g., in hurricanes) + if ((k .LE. 5) .AND. (k .GT. 1)) then + ! if next level below was assigned inTropo, candInTropo, or oppSignPV + if ((inTropo(k-1,iCell) .GT. 0) .OR. (candInTropo(k-1,iCell) .GT. 0) .OR. (oppSignPV(k-1,iCell) .GT. 0)) then + nChanged = 1 + levUse = k + exit lev_id + end if + end if - real(kind=RKIND), dimension(3), intent(inout) :: gradxu - real(kind=RKIND), dimension(3), intent(in) :: gradtheta - real(kind=RKIND), intent(in) :: density - real(kind=RKIND), dimension(3), intent(in) :: unitX, unitY, unitZ + end if ! interfaceLev > 0 + end if ! intCounts + end do lev_id + end if + + if (nChanged .GT. 0) then ! found troposphere's highest level + iLev_DT(iCell) = levUse ! level above troposphere (>nVertLevels if whole column below 2 PVU; e.g., tropics) + else + iLev_DT(iCell) = 0 ! whole column above DT (e.g., Arctic PV tower) + end if - real(kind=RKIND) :: epv, eVort - real(kind=RKIND), dimension(3) :: eVortDir, eVortComponents + ! Add in correction for locations near the equator with iLev_DT assigned to 0 + if ((iLev_DT(iCell) .EQ. 0) .AND. (abs(latCell(iCell)) .LE. 0.0436)) then ! corresponds to 2.5 deg latitude + iLev_DT(iCell) = nVertLevels+1 + end if + end do !iCell + + ! Do correction pass to change cells that differ significantly from surrounding cells + call mpas_pool_get_field(diag, 'iLev_DT', iLev_DT_f) ! MC note: this hasn't been changed to reflect new mpas_halo procedures + dminfo => iLev_DT_f % block % domain % dminfo + call mpas_dmpar_exch_halo_field(iLev_DT_f) + + cells: do iCell=1,nCells + intCounts = 0 + + nbrloop: do iNbr = 1,nEdgesOnCell(iCell) + iCellNbr = cellsOnCell(iNbr,iCell) + + if (abs(iLev_DT(iCell)-iLev_DT(iCellNbr)) .GT. 5) then ! If adjacent cells have DT vertical index that differs by more than 5 + intCounts = intCounts+1 + cycle nbrloop + end if + end do nbrloop + + if (intCounts .GE. (nEdgesOnCell(iCell)-2)) then ! If cell differs from at least all but 2 neighbors + ! Loop through neighbors again. Need to evaluate whether neighboring DT values are in interfaceLev array. + nbrloop2: do iNbr = 1,nEdgesOnCell(iCell) + iCellNbr = cellsOnCell(iNbr,iCell) + + ! Make sure DT of neighboring cell wasn't set to nVertLevels+1 or 0 + if ((abs(iLev_DT(iCell)-iLev_DT(iCellNbr)) .GT. 5) .AND. (iLev_DT(iCellNbr) .GT. 0) .AND. (iLev_DT(iCellNbr) .LE. nVertLevels)) then + if (interfaceLev(iLev_DT(iCellNbr),iCell) .GT. 0) then ! If neighboring cell's DT index is an interface level of current cell, + iLev_DT(iCell) = iLev_DT(iCellNbr) ! set current cell's DT index to neighbor's + end if + else + cycle nbrloop2 + end if + end do nbrloop2 - !earth vorticity is in +z-direction in global Cartesian space - eVort = 2.0 * omega_e - eVortDir(1) = 0.0_RKIND - eVortDir(2) = 0.0_RKIND - eVortDir(3) = eVort + else + cycle cells + end if - eVortComponents(1) = dotProduct(eVortDir, unitX,3) - eVortComponents(2) = dotProduct(eVortDir, unitY,3) - eVortComponents(3) = dotProduct(eVortDir, unitZ,3) + end do cells + + deallocate(interfaceLev) + deallocate(oppSignPV) + deallocate(sgn) + deallocate(sgn2) + + end subroutine floodFill_tropo + + + !********************************************************************************************************************* + ! NS: Subroutine to compute various fields on 2-PVU surface using the calculated PV field - potential temperature, + ! uZonal, uMeridional, vertical vorticity + ! MC: Modified interpolation of vorticity to cell centers procedure to be consistent with other changes + ! This routine should use PV field at end of time step! + !********************************************************************************************************************* + + subroutine interp_pv_diagnostics(mesh, diag, pvuVal, missingVal) + + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array + use mpas_constants, only: r_earth=>a + + IMPLICIT NONE + + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(inout) :: diag + real(kind=RKIND) :: pvuVal, missingVal + + integer :: iCell, k + integer, pointer :: nCells, nVertLevels + integer, dimension(:), pointer :: nEdgesOnCell, iLev_DT + integer, dimension(:,:), pointer :: cellsOnCell, cellsOnEdge, verticesOnCell, cellsOnVertex + + real(kind=RKIND), dimension(:), pointer:: areaCell, latCell, u_pv, v_pv, theta_pv, vort_pv, pres_pv, height_pv + real(kind=RKIND), dimension(:,:), pointer:: uReconstructZonal, uReconstructMeridional, vorticity, theta, ertel_pv, & + kiteAreasOnVertex, pressure, zgrid + real(kind=RKIND), dimension(:,:), allocatable :: vVort, zCell, zCell_geo + + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(mesh, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + + call mpas_pool_get_array(diag, 'ertel_pv', ertel_pv) + call mpas_pool_get_array(diag, 'theta', theta) + call mpas_pool_get_array(diag, 'pressure', pressure) + call mpas_pool_get_array(diag, 'vorticity', vorticity) + call mpas_pool_get_array(diag, 'uReconstructZonal', uReconstructZonal) + call mpas_pool_get_array(diag, 'uReconstructMeridional', uReconstructMeridional) + call mpas_pool_get_array(diag, 'u_pv', u_pv) + call mpas_pool_get_array(diag, 'v_pv', v_pv) + call mpas_pool_get_array(diag, 'theta_pv', theta_pv) + call mpas_pool_get_array(diag, 'vort_pv', vort_pv) + call mpas_pool_get_array(diag, 'pres_pv', pres_pv) + call mpas_pool_get_array(diag, 'height_pv', height_pv) + call mpas_pool_get_array(diag, 'iLev_DT', iLev_DT) + + allocate(vVort(nVertLevels,nCells)) + allocate(zCell(nVertLevels,nCells)) + allocate(zCell_geo(nVertLevels,nCells)) + + ! Interpolate horizontal winds to pvuVal isosurface + call interp_pv(nCells, nVertLevels, pvuVal, latCell, & + ertel_pv, uReconstructZonal, u_pv, missingVal, iLev_DT) + + call interp_pv(nCells, nVertLevels, pvuVal, latCell, & + ertel_pv, uReconstructMeridional, v_pv, missingVal, iLev_DT) + + ! Interpolate theta + call interp_pv(nCells, nVertLevels, pvuVal, latCell, & + ertel_pv, theta, theta_pv, missingVal, iLev_DT) + + ! Interpolate height of cell center + call interp_wLev_thetaLev(zgrid, nCells, nVertLevels, zCell) + + ! convert geometric to geopotential height: + zCell_geo = (zCell * r_earth)/(zCell + r_earth) + + call interp_pv(nCells, nVertLevels, pvuVal, latCell, & + ertel_pv, zCell_geo, height_pv, missingVal, iLev_DT) + + ! Interpolate pressure + ! MC note: it's probably more appropriate to linearly interpolate the log of pressure, but + ! I'm leaving this as-is + call interp_pv(nCells, nVertLevels, pvuVal, latCell, & + ertel_pv, pressure, pres_pv, missingVal, iLev_DT) + + ! Interpolate absolute vertical vorticity + ! MC note: could just use pv_vertex, but leaving this as-is + call interp_absVertVort(vorticity, nCells, nEdgesOnCell, verticesOnCell, & + cellsOnVertex, areaCell, kiteAreasOnVertex, vVort) + + call interp_pv(nCells, nVertLevels, pvuVal, latCell, ertel_pv, vVort, & + vort_pv, missingVal, iLev_DT) + + deallocate(vVort) + deallocate(zCell) + deallocate(zCell_geo) + + end subroutine interp_pv_diagnostics + + + !********************************************************************************************************************* + ! NS: Subroutine to linearly interpolate columns of field1 to where field0 is interpVal*sign(lat) using level above + ! tropopause already diagnosed + !********************************************************************************************************************* + + subroutine interp_pv(nCells, nLevels, interpVal, latCell, field0, & + field1, field_interp, missingVal, iLev_DT) + + IMPLICIT NONE + + integer :: nCells, nLevels + integer, intent(in) :: iLev_DT(nCells) + real(kind=RKIND) :: interpVal, missingVal + real(kind=RKIND), intent(in) :: latCell(nCells) + real(kind=RKIND), intent(in) :: field0(nLevels,nCells), field1(nLevels,nCells) + real(kind=RKIND), intent(out) :: field_interp(nCells) + + ! local variables + integer :: iCell, iLev, levInd, indlNbr + real(kind=RKIND) :: valh, vall, vallNbr, sgnh, sgnl, sgnlNbr + real(kind=RKIND) :: dv_dl, levFrac, valInterpCell, sgnHemi + + do iCell = 1,nCells + !starting from top, trap val if values on opposite side + levInd = -1 ! what should happen with missing values? + levFrac = 0.0 + sgnHemi = sign(1.0_RKIND, latCell(iCell)) !problem at the equator...is sign(0)=0? + if (sgnHemi .EQ. 0.0) sgnHemi = 1.0 + valInterpCell = interpVal*sgnHemi + + iLev = iLev_DT(iCell) ! lowest vertical level above the tropopause + if (iLev .GT. nLevels) then ! if no identified tropopause in column and all column in troposphere + levInd = -1 + sgnl = -1.0 + else if (iLev .LT. 1) then ! if no identified tropopause in column and all column in stratosphere + levInd = -1 + sgnl = 1.0 + else + valh = field0(iLev,iCell) ! value at the level just above tropopause + vall = field0(iLev-1,iCell) ! value at level just below tropopause + + ! MC: need to ensure that 2 PVU is actually between valh and vall before proceeding to avoid huge erroneous interpolated vals + !if ((abs(valInterpCell) .LE. abs(valh)) .AND. (abs(valInterpCell) .GE. abs(vall))) then + ! below should be more robust in situations where PV changes sign across tropopause + if (((sgnHemi .GT. 0) .AND. ((valInterpCell .LE. valh) .AND. (valInterpCell .GE. vall))) & + .OR. ((sgnHemi .LT. 0) .AND. ((valInterpCell .GE. valh) .AND. (valInterpCell .LE. vall)))) then + + !sandwiched value. equal in case val0 is a vals[l]. + !get linear interpolation: val0 = vals[l]+dvals/dl * dl + !Avoid divide by 0 by just assuming value is + !halfway between... + dv_dl = valh-vall; ! change in PV across vertical levels + if (abs(dv_dl)<1.e-6) then ! if difference between PV values is tiny, set levFrac = 0.5 + levFrac = 0.5; + else + levFrac = (valInterpCell-vall)/dv_dl ! if not tiny, calculate levFrac as difference between interp reference value and + end if ! of tropopause / change in PV across vertical levels + levInd = iLev-1 ! index is level just below tropopause + + ! MC: need to set these incorrectly identified DT points to something... + else + levInd = -1 + sgnl = 0.0 + end if ! bounding 2 PVU + end if !iLev in column + + !find value of field using index we just found + if (levInd < 0) then !didn't trap value + if (sgnl > 0.0) then !column above value, take value at the lowest model level + field_interp(iCell) = field1(1,iCell) + + else if (sgnl < 0.0) then !column below value, take value at highest model level + !field(iCell) = missingVal + field_interp(iCell) = field1(nLevels,iCell) + + else + field_interp(iCell) = missingVal ! MC: set to missing if DT incorrectly identified + end if + + else + valh = field1(levInd+1,iCell) ! value of field we're interpolating at level above tropopause + vall = field1(levInd,iCell) ! value of field at level below tropopause + + dv_dl = valh-vall ! change in field across vertical levels + field_interp(iCell) = vall+dv_dl*levFrac ! interpolated value = value below tropopause + change in value across vertical level + end if - gradxu(:) = gradxu(:) + eVortComponents(:) + end do - epv = dotProduct(gradxu, gradtheta,3) / density + end subroutine interp_pv - epv = epv * 1.0e6 !SI to PVUs - - formErtelPV = epv - end function formErtelPV - - subroutine local2FullVorticity(gradxu, unitX, unitY, unitZ) - !given gradxu, return gradxu+earthVort - - use mpas_constants, only : omega_e => omega + !********************************************************************************************************************* + ! MC: Subroutine to calculate the dot product between two 3D vectors + !********************************************************************************************************************* - implicit none + subroutine calc_dotProduct_3D(vec1, vec2, nCells, nVertLevels, dotResult) - real(kind=RKIND), dimension(3), intent(inout) :: gradxu - real(kind=RKIND), dimension(3), intent(in) :: unitX, unitY, unitZ - - real(kind=RKIND) :: eVort - real(kind=RKIND), dimension(3) :: eVortDir, eVortComponents + IMPLICIT NONE - !earth vorticity is in z-direction in global Cartesian space - eVort = 2.0 * omega_e - eVortDir(1) = 0.0_RKIND - eVortDir(2) = 0.0_RKIND - eVortDir(3) = eVort + integer, intent(in) :: nVertLevels, nCells + real(kind=RKIND), dimension(:,:,:), intent(in) :: vec1, vec2 + real(kind=RKIND), dimension(:,:), intent(out) :: dotResult + integer :: iCell, k - eVortComponents(1) = dotProduct(eVortDir, unitX,3) - eVortComponents(2) = dotProduct(eVortDir, unitY,3) - eVortComponents(3) = dotProduct(eVortDir, unitZ,3) + dotResult(:,:) = 0.0_RKIND - gradxu(:) = gradxu(:) + eVortComponents(:) - end subroutine local2FullVorticity - - real(kind=RKIND) function calc_verticalVorticity_cell(c0, level, nVerticesOnCell, verticesOnCell, cellsOnVertex, & - kiteAreasOnVertex, areaCell, vVortVertex) - !area weighted average of vorticity at vertices to cell center for the specified cell - ! - implicit none + do iCell=1,nCells + do k=1,nVertLevels + dotResult(k,iCell) = vec1(k,iCell,1)*vec2(k,iCell,1) + vec1(k,iCell,2)*vec2(k,iCell,2) + vec1(k,iCell,3)*vec2(k,iCell,3) + end do + end do - real(kind=RKIND), intent(in) :: areaCell - integer, intent(in) :: c0, level, nVerticesOnCell - integer, dimension(:,:), intent(in) :: verticesOnCell, cellsOnVertex - real(kind=RKIND), dimension(:,:), intent(in) :: kiteAreasOnVertex, vVortVertex + end subroutine calc_dotProduct_3D - real(kind=RKIND) :: vVortCell - integer :: i, iVertex, cellIndOnVertex + !********************************************************************************************************************* + ! MC: Subroutine to interpolate the absolute vertical vorticity to cell centers from the absolute + ! vertical vorticity at the vertices (pv_vertex) + !********************************************************************************************************************* - vVortCell = 0.0_RKIND - do i = 1,nVerticesOnCell - iVertex = verticesOnCell(i,c0) - cellIndOnVertex = elementIndexInArray(c0, cellsOnVertex(:,iVertex), 3) - vVortCell = vVortCell + kiteAreasOnVertex(cellIndOnVertex, iVertex)*vVortVertex(level, iVertex)/areaCell - end do + subroutine interp_absVertVort(pv_vertex, nCells, nEdgesOnCell, verticesOnCell, & + cellsOnVertex, areaCell, kiteAreasOnVertex, absVort) - calc_verticalVorticity_cell = vVortCell - end function calc_verticalVorticity_cell + IMPLICIT NONE - subroutine coordinateSystem_cell(cellTangentPlane, localVerticalUnitVectors, c0, xyz) + integer, intent(in) :: nCells + integer, dimension(:), intent(in) :: nEdgesOnCell + integer, dimension(:,:), intent(in) :: verticesOnCell, cellsOnVertex + real(kind=RKIND), dimension(:), intent(in) :: areaCell + real(kind=RKIND), dimension(:,:), intent(in) :: pv_vertex, kiteAreasOnVertex + real(kind=RKIND), dimension(:,:), intent(out) :: absVort + integer :: i, j, cellIndOnVertex, iVertex - implicit none + absVort(:,:) = 0.0_RKIND - real(kind=RKIND), dimension(3,2,*), intent(in) :: cellTangentPlane - real(kind=RKIND), dimension(3,*), intent(in) :: localVerticalUnitVectors - integer, intent(in) :: c0 - real(kind=RKIND), dimension(3,3), intent(out) :: xyz + do i=1,nCells + do j=1,nEdgesOnCell(i) + iVertex = verticesOnCell(j,i) + cellIndOnVertex = FINDLOC(cellsOnVertex(:,iVertex),VALUE=i,DIM=1) + absVort(:,i) = absVort(:,i) + kiteAreasOnVertex(cellIndOnVertex,iVertex) * pv_vertex(:,iVertex) + end do + absVort(:,i) = absVort(:,i) / areaCell(i) + end do - integer :: i + end subroutine interp_absVertVort + + !********************************************************************************************************************* + ! MW: Subroutine that can be used to recompute the absolute vorticity at cell vertices + !********************************************************************************************************************* + subroutine recompute_absVort_vertex(u, nVertices, nVertLevels, vertexDegree, invAreaTriangle, & + dcEdge, edgesOnVertex, edgesOnVertex_sign, fVertex, vort ) - xyz(:,1) = cellTangentPlane(:,1,c0) !are these guaranteed unit vectors? - xyz(:,2) = cellTangentPlane(:,2,c0) - xyz(:,3) = localVerticalUnitVectors(:,c0) - do i=1,2 - call normalizeVector(xyz(:,i), 3) - end do - end subroutine coordinateSystem_cell + IMPLICIT NONE - real(kind=RKIND) function fluxSign(c0, iEdge, cellsOnEdge) - - !For finite volume computations, we'll use a normal pointing out of the cell - implicit none + integer, intent(in) :: nVertices, vertexDegree, nVertLevels + integer, dimension(:,:), intent(in) :: edgesOnVertex + real(kind=RKIND), dimension(:), intent(in) :: invAreaTriangle, fVertex, dcEdge + real(kind=RKIND), dimension(:,:), intent(in) :: u, edgesOnVertex_sign + real(kind=RKIND), dimension(:,:), intent(inout) :: vort - integer, intent(in) :: c0 - integer, intent(in) :: iEdge - integer, dimension(:,:), intent(in) :: cellsOnEdge + ! local variables + integer :: iVertex, iEdge, i, k + real (kind=RKIND) :: s - if (c0 == cellsOnEdge(1,iEdge)) then - fluxSign = 1.0_RKIND - else - fluxSign = -1.0_RKIND - end if - end function fluxSign + do iVertex=1,nVertices + vort(1:nVertLevels,iVertex) = 0.0 + do i=1,vertexDegree + iEdge = edgesOnVertex(i,iVertex) + s = edgesOnVertex_sign(i,iVertex) * dcEdge(iEdge) + do k=1,nVertLevels + vort(k,iVertex) = vort(k,iVertex) + s * u(k,iEdge) + end do + end do + do k=1,nVertLevels + vort(k,iVertex) = vort(k,iVertex) * invAreaTriangle(iVertex) + vort(k,iVertex) = vort(k,iVertex) + fVertex(iVertex) + end do + end do - real(kind=RKIND) function calc_heightCellCenter(c0, level, zgrid) + end subroutine recompute_absVort_vertex - implicit none + !********************************************************************************************************************* + ! MC: Subroutine to calculate the horizontal gradient of a field on the cell edges using field values at the + ! adjacent cell centers as: + ! + ! varGrad(edgeUse,kLev) = (cellVar(cellsOnEdge(edgeUse,2),kLev)-cellVar(cellsOnEdge(edgeUse,1),kLev))/dcEdge(edgeUse) + ! + ! and then assign the correct sign based on its direction (i.e., into or out of the cell), the value of + ! edgesOnCell_sign, and the convention for the u winds: "Positive u (normal) velocity is always defined as + ! flow from cellsOnEdge(1,jEdge) to cellsOnEdge(2,jEdge) for edge iEdge" (MPAS tutorial 2019). + ! + ! The expression for calculating the gradient on each edge comes from Eq. 22 in Ringler et al. (2010) + !********************************************************************************************************************* + + subroutine calc_gradOnEdges(cellVar, nCells, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, varGrad) + + IMPLICIT NONE + + integer, intent(in) :: nCells, nEdges, nVertLevels + integer, dimension(:), intent(in) :: nEdgesOnCell + integer, dimension(:,:), intent(in) :: cellsOnEdge, edgesOnCell + real(kind=RKIND), dimension(:), intent(in) :: dcEdge + real(kind=RKIND), dimension(:,:), intent(in) :: cellVar, edgesOnCell_sign + real(kind=RKIND), dimension(:,:), intent(out) :: varGrad + integer :: iCell, jEdge, kLev, edgeSign, edgeUse, index_j1, index_j2, sign_j1, sign_j2 + + varGrad(:,:) = 0.0_RKIND + + cell_loop: do iCell=1,nCells + edge_loop: do jEdge=1,nEdgesOnCell(iCell) + lev_loop: do kLev=1,nVertLevels + + ! Edges and edge signs for jEdge along parent iCell + edgeSign = edgesOnCell_sign(jEdge,iCell) + edgeUse = edgesOnCell(jEdge,iCell) + + ! The indices of edgeUse likely differ in edgesOnCell array for each + ! cell. Need to find the correct indices and the sign of the normal + ! vector for each edge in edgesOnCell + ! + ! -- if sign_j1 > 0, normal vector points out of cellsOnEdge(edgeUse,1) + ! -- if sign_j2 > 0, normal vector points out of cellsOnEdge(edgeUse,2) + + index_j1 = FINDLOC(edgesOnCell(:,cellsOnEdge(1,edgeUse)),VALUE=edgeUse, DIM=1) + index_j2 = FINDLOC(edgesOnCell(:,cellsOnEdge(2,edgeUse)),VALUE=edgeUse, DIM=1) + sign_j1 = edgesOnCell_sign(index_j1,cellsOnEdge(1,edgeUse)) + sign_j2 = edgesOnCell_sign(index_j2,cellsOnEdge(2,edgeUse)) + + ! Calculate gradient of field by taking the difference of the values + ! at the adjacent cell centers divided by the distance between the + ! cells + + varGrad(kLev,edgeUse) = cellVar(kLev,cellsOnEdge(2,edgeUse)) - cellVar(kLev,cellsOnEdge(1,edgeUse)) + varGrad(kLev,edgeUse) = varGrad(kLev,edgeUse)/dcEdge(edgeUse) + + ! Ensure that the sign of the gradient is consistent with the + ! convention for the u (normal winds). Note: I think the signs are + ! correct without doing this procedure, but I will keep it here just + ! in case. + + IF (varGrad(kLev,edgeUse) .gt. 0) THEN + ! Gradient vector points toward cellsOnEdge(edgeUse,2) -> + ! should be directed inward for cellsOnEdge(edgeUse,2) + + ! What is sign of normal vector along edgeUse for each cell? + IF (sign_j2 .lt. 0) THEN ! Normal vector points inward for cellsOnEdge(edgeUse,2) + ! and outward for cellsOnEdge(edgeUse,1) + varGrad(kLev,edgeUse) = ABS(varGrad(kLev,edgeUse)) + ELSE + varGrad(kLev,edgeUse) = -ABS(varGrad(kLev,edgeUse)) + END IF + + ELSE IF (varGrad(kLev,edgeUse) .lt. 0) THEN + ! Gradient vector points toward cellsOnEdge(edgeUse,1) -> + ! should be directed inward for cellsOnEdge(edgeUse,1) + + ! What is sign of normal vector along edgeUse for each cell? + IF (sign_j1 .lt. 0) THEN ! Normal vector points inward for cellsOnEdge(edgeUse,1) + ! and outward for cellsOnEdge(edgeUse,2) + varGrad(kLev,edgeUse) = ABS(varGrad(kLev,edgeUse)) + ELSE + varGrad(kLev,edgeUse) = -ABS(varGrad(kLev,edgeUse)) + END IF + + END IF + + end do lev_loop + end do edge_loop + end do cell_loop + + end subroutine calc_gradOnEdges + + + !********************************************************************************************************************* + ! MC: Subroutine takes gradient field valid on cell edges and reconstructs the horizontal gradient vectors at the cell + ! center in a manner analogous to the u reconstruction of mpas_reconstruct_2d in mpas_vector_reconstruction.F + !********************************************************************************************************************* + + subroutine mpas_reconstruct_grad(gradEdge, latCell, lonCell, coeffs_reconstruct, nCells, nVertLevels, & + edgesOnCell, nEdgesOnCell, & + gradReconstructZonal, gradReconstructMeridional) + + IMPLICIT NONE + + integer, intent(in) :: nVertLevels, nCells + integer, dimension(:,:), intent(in) :: edgesOnCell + integer, dimension(:), intent(in) :: nEdgesOnCell + + real(kind=RKIND), dimension(:), intent(in) :: latCell, lonCell + real(kind=RKIND), dimension(:,:), intent(in) :: gradEdge + real(kind=RKIND), dimension(:,:,:), intent(in) :: coeffs_reconstruct + real(kind=RKIND), dimension(:,:), intent(out) :: gradReconstructZonal, gradReconstructMeridional + + ! local variables + integer :: iCell, jEdge, edgeUse, kLev + real(kind=RKIND) :: clat, slat, clon, slon + real(kind=RKIND), dimension(:,:), allocatable :: gradReconstructX, gradReconstructY, gradReconstructZ + + allocate(gradReconstructX(nVertLevels,nCells)) + allocate(gradReconstructY(nVertLevels,nCells)) + allocate(gradReconstructZ(nVertLevels,nCells)) + + gradReconstructX(nVertLevels,nCells) = 0.0_RKIND + gradReconstructY(nVertLevels,nCells) = 0.0_RKIND + gradReconstructZ(nVertLevels,nCells) = 0.0_RKIND + gradReconstructZonal(nVertLevels,nCells) = 0.0_RKIND + gradReconstructMeridional(nVertLevels,nCells) = 0.0_RKIND + + cell_loop: do iCell=1,nCells + edge_loop: do jEdge=1,nEdgesOnCell(iCell) + + edgeUse = edgesOnCell(jEdge,iCell) + + gradReconstructX(:,iCell) = gradReconstructX(:,iCell) & + + coeffs_reconstruct(1,jEdge,iCell) * gradEdge(:,edgeUse) + gradReconstructY(:,iCell) = gradReconstructY(:,iCell) & + + coeffs_reconstruct(2,jEdge,iCell) * gradEdge(:,edgeUse) + gradReconstructZ(:,iCell) = gradReconstructZ(:,iCell) & + + coeffs_reconstruct(3,jEdge,iCell) * gradEdge(:,edgeUse) + + end do edge_loop + + clat = COS(latCell(iCell)) + slat = SIN(latCell(iCell)) + clon = COS(lonCell(iCell)) + slon = SIN(lonCell(iCell)) + + gradReconstructZonal(:,iCell) = -gradReconstructX(:,iCell)*slon + & + gradReconstructY(:,iCell)*clon + + + gradReconstructMeridional(:,iCell) = -(gradReconstructX(:,iCell)*clon + & + gradReconstructY(:,iCell)*slon)*slat + & + gradReconstructZ(:,iCell)*clat + + end do cell_loop + + deallocate(gradReconstructX) + deallocate(gradReconstructY) + deallocate(gradReconstructZ) + + end subroutine mpas_reconstruct_grad + + + !********************************************************************************************************************* + ! MC: Combined subroutines to calculate the horizontal gradient of a field on the cell edges using values at + ! the adjacent cell centers + ! + ! varGrad(edgeUse,kLev) = (cellVar(cellsOnEdge(edgeUse,2),kLev) - cellVar(cellsOnEdge(edgeUse,1),kLev)) / dcEdge(edgeUse) + ! + ! and then assign the correct sign based on its direction (i.e., into or out of the cell), the value of + ! edgesOnCell_sign, and the convention for the u winds: "Positive u (normal) velocity is always defined as + ! flow from cellsOnEdge(1,jEdge) to cellsOnEdge(2,jEdge) for edge iEdge" (MPAS tutorial 2019). + ! + ! The expression for calculating the gradient on each edge comes from Eq. 22 in Ringler et al. (2010) + ! + ! Following the gradient on edge calculation, the gradient is then reconstructed to the cell centers in a + ! manner analogous to the u reconstruction of mpas_reconstruct_2d in mpas_vector_reconstruction.F + ! + ! The purpose of combining these into one subroutine is to reduce the number of stored intermediate variables, + ! which are needed for the halo communication to work properly + ! + ! MC 02/2024 -- note this will crash when running with DEBUG=true if using nCells and not nCellsSolve in the + ! calc_epv and diagnostics subroutines + !********************************************************************************************************************* + + subroutine calc_gradOnEdges_reconCellCenter(cellVar, nCells, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, gradReconstructZonal, gradReconstructMeridional) + + IMPLICIT NONE + + integer, intent(in) :: nCells, nEdges, nVertLevels + integer, dimension(:), intent(in) :: nEdgesOnCell + integer, dimension(:,:), intent(in) :: cellsOnEdge, edgesOnCell + + real(kind=RKIND), dimension(:), intent(in) :: dcEdge, latCell, lonCell + real(kind=RKIND), dimension(:,:), intent(in) :: cellVar, edgesOnCell_sign + real(kind=RKIND), dimension(:,:,:), intent(in) :: coeffs_reconstruct + real(kind=RKIND), dimension(:,:), intent(out) :: gradReconstructZonal, gradReconstructMeridional + + ! local variables + real(kind=RKIND) :: clat, slat, clon, slon + real(kind=RKIND), dimension(:,:), allocatable :: varGrad, gradReconstructX, gradReconstructY, gradReconstructZ + integer :: iCell, jEdge, kLev, edgeSign, edgeUse, index_j1, index_j2, sign_j1, sign_j2 + + allocate(varGrad(nVertLevels,nEdges)) + allocate(gradReconstructX(nVertLevels,nCells)) + allocate(gradReconstructY(nVertLevels,nCells)) + allocate(gradReconstructZ(nVertLevels,nCells)) + + varGrad(:,:) = 0.0_RKIND + gradReconstructX(:,:) = 0.0_RKIND + gradReconstructY(:,:) = 0.0_RKIND + gradReconstructZ(:,:) = 0.0_RKIND + gradReconstructZonal(:,:) = 0.0_RKIND + gradReconstructMeridional(:,:) = 0.0_RKIND + + cell_loop: do iCell=1,nCells + edge_loop: do jEdge=1,nEdgesOnCell(iCell) + + ! Edges and edge signs for jEdge along parent iCell + edgeSign = edgesOnCell_sign(jEdge,iCell) + edgeUse = edgesOnCell(jEdge,iCell) + + ! The indices of edgeUse likely differ in edgesOnCell array for each + ! cell. Need to find the correct indices and the sign of the normal + ! vector for each edge in edgesOnCell + ! + ! -- if sign_j1 > 0, normal vector points out of cellsOnEdge(edgeUse,1) + ! -- if sign_j2 > 0, normal vector points out of cellsOnEdge(edgeUse,2) - integer, intent(in) :: c0, level - real(kind=RKIND), dimension(:,:), intent(in) :: zgrid + index_j1 = FINDLOC(edgesOnCell(:,cellsOnEdge(1,edgeUse)),VALUE=edgeUse, DIM=1) + index_j2 = FINDLOC(edgesOnCell(:,cellsOnEdge(2,edgeUse)),VALUE=edgeUse, DIM=1) + sign_j1 = edgesOnCell_sign(index_j1,cellsOnEdge(1,edgeUse)) + sign_j2 = edgesOnCell_sign(index_j2,cellsOnEdge(2,edgeUse)) - calc_heightCellCenter = 0.5*(zgrid(level,c0)+zgrid(level+1,c0)) - end function calc_heightCellCenter + lev_loop: do kLev=1,nVertLevels - real(kind=RKIND) function calc_heightVerticalEdge(c0, c1, level, zgrid) + ! Calculate gradient of field by taking the difference of the values + ! at the adjacent cell centers divided by the distance between the + ! cells - implicit none + varGrad(kLev,edgeUse) = cellVar(kLev,cellsOnEdge(2,edgeUse)) - cellVar(kLev,cellsOnEdge(1,edgeUse)) + varGrad(kLev,edgeUse) = varGrad(kLev,edgeUse)/dcEdge(edgeUse) - integer, intent(in) :: c0, c1, level - real(kind=RKIND), dimension(:,:), intent(in) :: zgrid + ! Ensure that the sign of the gradient is consistent with the + ! convention for the u (normal winds). Note: I think the signs are + ! correct without doing this procedure, but I will keep it here just + ! in case. - real(kind=RKIND) :: hTop, hBottom + IF (varGrad(kLev,edgeUse) .gt. 0) THEN + ! Gradient vector points toward cellsOnEdge(edgeUse,2) -> + ! should be directed inward for cellsOnEdge(edgeUse,2) - hTop = .5*(zgrid(level+1,c0)+zgrid(level+1,c1)) - hBottom = .5*(zgrid(level,c0)+zgrid(level,c1)) + ! What is sign of normal vector along edgeUse for each cell? + IF (sign_j2 .lt. 0) THEN ! Normal vector points inward for cellsOnEdge(edgeUse,2) + ! and outward for cellsOnEdge(edgeUse,1) + varGrad(kLev,edgeUse) = ABS(varGrad(kLev,edgeUse)) + ELSE + varGrad(kLev,edgeUse) = -ABS(varGrad(kLev,edgeUse)) + END IF - calc_heightVerticalEdge = hTop-hBottom - end function calc_heightVerticalEdge + ELSE IF (varGrad(kLev,edgeUse) .lt. 0) THEN + ! Gradient vector points toward cellsOnEdge(edgeUse,1) -> + ! should be directed inward for cellsOnEdge(edgeUse,1) - subroutine normalizeVector(vals, sz) - !normalize a vector to unit magnitude - implicit none + ! What is sign of normal vector along edgeUse for each cell? + IF (sign_j1 .lt. 0) THEN ! Normal vector points inward for cellsOnEdge(edgeUse,1) + ! and outward for cellsOnEdge(edgeUse,2) + varGrad(kLev,edgeUse) = ABS(varGrad(kLev,edgeUse)) + ELSE + varGrad(kLev,edgeUse) = -ABS(varGrad(kLev,edgeUse)) + END IF - real (kind=RKIND), dimension(:), intent(inout) :: vals - integer, intent(in) :: sz + END IF - integer :: i - real (kind=RKIND) :: mag + end do lev_loop - mag = 0.0_RKIND !sqrt(sum(squares)) - do i=1,sz - mag = mag+vals(i)*vals(i) - end do - mag = sqrt(mag) - vals(:) = vals(:)/mag - end subroutine normalizeVector + gradReconstructX(:,iCell) = gradReconstructX(:,iCell) & + + coeffs_reconstruct(1,jEdge,iCell) * varGrad(:,edgeUse) + gradReconstructY(:,iCell) = gradReconstructY(:,iCell) & + + coeffs_reconstruct(2,jEdge,iCell) * varGrad(:,edgeUse) + gradReconstructZ(:,iCell) = gradReconstructZ(:,iCell) & + + coeffs_reconstruct(3,jEdge,iCell) * varGrad(:,edgeUse) - real(kind=RKIND) function calcVolumeCell(areaCell, nEdges, hEdge) + end do edge_loop - implicit none + clat = COS(latCell(iCell)) + slat = SIN(latCell(iCell)) + clon = COS(lonCell(iCell)) + slon = SIN(lonCell(iCell)) - integer, intent(in) :: nEdges - real(kind=RKIND), intent(in) :: areaCell - real(kind=RKIND), dimension(nEdges), intent(in) :: hEdge + gradReconstructZonal(:,iCell) = -gradReconstructX(:,iCell)*slon + & + gradReconstructY(:,iCell)*clon - integer :: i - real(kind=RKIND) :: avgHt, vol - avgHt = 0.0_RKIND - do i=1,nEdges - avgHt = avgHt + hEdge(i) - end do - avgHt = avgHt/nEdges + gradReconstructMeridional(:,iCell) = -(gradReconstructX(:,iCell)*clon + & + gradReconstructY(:,iCell)*slon)*slat + & + gradReconstructZ(:,iCell)*clat - vol = areaCell*avgHt - calcVolumeCell = vol - end function calcVolumeCell + end do cell_loop - real(kind=RKIND) function calc_horizDeriv_fv(valEdges, nNbrs, dvEdge, dhEdge, & - normalEdge, unitDeriv, volumeCell) - !normals to edges point out of cell - implicit none + deallocate(gradReconstructX) + deallocate(gradReconstructY) + deallocate(gradReconstructZ) + deallocate(varGrad) - integer, intent(in) :: nNbrs - real(kind=RKIND), dimension(:), intent(in) :: valEdges, dvEdge, dhEdge - real(kind=RKIND), dimension(3,nNbrs), intent(in) :: normalEdge - real(kind=RKIND), dimension(3), intent(in) :: unitDeriv - real(kind=RKIND), intent(in) :: volumeCell - - integer :: i - real(kind=RKIND) :: vale, rsum, areaFace - real(kind=RKIND), dimension(3) :: unitNormalEdge - - rsum = 0.0_RKIND - do i=1,nNbrs - vale = valEdges(i) !0.5 * (val0 + valNbrs(i)) - areaFace = dvEdge(i) * dhEdge(i) - unitNormalEdge(:) = normalEdge(:,i) - call normalizeVector(unitNormalEdge,3) - areaFace = areaFace*dotProduct(unitNormalEdge, unitDeriv,3) !* abs(dotProduct(unitNormalEdge, unitDeriv,3)) - rsum = rsum + vale * areaFace - end do - rsum = rsum / volumeCell + end subroutine calc_gradOnEdges_reconCellCenter - calc_horizDeriv_fv = rsum - end function calc_horizDeriv_fv + !********************************************************************************************************************* + ! NS: Adapted from computation of circulation and relative vorticity at each vertex in atm_compute_solve_diagnostics() + ! This takes scvt face values and computes finite volume curl at scvt vertices (triangle cell centers) + ! MC: Modified NS's original curl subroutine to include calculation over all vertical levels + !********************************************************************************************************************* - !cell centers are halfway between w faces - real(kind=RKIND) function calc_vertDeriv_center(val0, valp, valm, z0,zp,zm) + subroutine calc_vertical_curl(uEdge, nEdges, nVertices, dcEdge, areaTriangle, verticesOnEdge, curlVert) implicit none - real(kind=RKIND), intent(in) :: val0, valp, valm, z0,zp,zm !center, plus, minus - - real(kind=RKIND) :: dval_dzp, dval_dzm + integer, intent(in) :: nEdges, nVertices + integer, dimension(:,:), intent(in) :: verticesOnEdge + real (kind=RKIND), dimension(:), intent(in) :: dcEdge, areaTriangle + real (kind=RKIND), dimension(:,:), intent(in) :: uEdge + real (kind=RKIND), dimension(:,:), intent(out) :: curlVert - !Average 1 sided differences to below and above since not equally spaced pts - dval_dzp = calc_vertDeriv_one(valp, val0, zp-z0) - dval_dzm = calc_vertDeriv_one(val0, valm, z0-zm) - calc_vertDeriv_center = 0.5*(dval_dzp+dval_dzm) + integer :: jEdge, iVert - end function calc_vertDeriv_center + curlVert(:,:) = 0.0_RKIND - real(kind=RKIND) function calc_vertDeriv_one(valp, valm, dz) - !1 sided finite difference + do jEdge=1,nEdges + curlVert(:,verticesOnEdge(1,jEdge)) = curlVert(:,verticesOnEdge(1,jEdge)) - dcEdge(jEdge) * uEdge(:,jEdge) + curlVert(:,verticesOnEdge(2,jEdge)) = curlVert(:,verticesOnEdge(2,jEdge)) + dcEdge(jEdge) * uEdge(:,jEdge) + end do - implicit none + do iVert=1,nVertices + curlVert(:,iVert) = curlVert(:,iVert) / areaTriangle(iVert) + end do - real(kind=RKIND), intent(in) :: valp, valm, dz + end subroutine calc_vertical_curl - calc_vertDeriv_one = (valp - valm) / dz + !********************************************************************************************************************* + ! MC: Subroutine combining NS's original functions for calculating vertical derivatives, which finds values at adjacent + ! theta/mass levels and then calculates one-sided difference between center level and the levels above and below. + ! For all levels except k=1 and k=nVertLevels, these differences are then averaged to give the center difference at + ! the center level. Else, the one-sided differences are used. + ! 03/20/24: Fix this routine by using difference in zgrid_cell rather than dzu (difference in zeta, not z) + !********************************************************************************************************************* - end function calc_vertDeriv_one - - subroutine floodFill_strato(mesh, diag, pvuVal, stratoPV) - !Searching down each column from TOA to find 2pvu surface is buggy with stratospheric wave breaking, - !since will find 2 pvu at a higher level than "tropopause". This looks to be worse as mesh gets finer and vertical vorticity jumps. - !Note that stratospheric blobs may persist for long times w/ slow mixing downstream of mountains or deep convection. - !A few quicker fixes (make sure <2pvu for a number of layers; search down from 10PVU instead of TOA) are hacky and not robust. - - !To alleviate the (hopefully) pockets of wave breaking, we can flood fill from a known - !stratosphere region (e.g., model top > 2pvu) and hopefully filter down around any trouble regions. - !The problem w/ using only the flood fill is that strong surface PV anomalies can connect to 2pvu, - !and the resulting "flood-filled 2 pvu" can have sizeable areas that are just at the surface while there is clearly a tropopause above (e.g., in a cross-section). - !To address large surface blobs, take the flood fill mask and try to go up from the surface to 10 pvu w/in column. If can, all stratosphere. Else, disconnect "surface blob". - - !The "output" is iLev_DT, which is the vertical index for the level >= pvuVal. If >nVertLevels, pvuVal above column. If <2, pvuVal below column. - !Communication between blocks during the flood fill may be needed to treat some edge cases appropriately. + subroutine calc_vertDeriv(var, nCells, nVertLevels, zCell, dvar_dz) - use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array - - implicit none - - type (mpas_pool_type), intent(in) :: mesh - type (mpas_pool_type), intent(inout) :: diag - real(kind=RKIND), intent(in) :: pvuVal, stratoPV - - integer :: iCell, k, nChanged, iNbr, iCellNbr - integer, pointer :: nCells, nVertLevels - integer, dimension(:), pointer :: nEdgesOnCell, iLev_DT - integer, dimension(:,:), pointer :: cellsOnCell - - real(kind=RKIND) :: sgnHemi, sgn - real(kind=RKIND),dimension(:),pointer:: latCell - real(kind=RKIND), dimension(:,:), pointer :: ertel_pv - - integer, dimension(:,:), allocatable :: candInStrato, inStrato - - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) - call mpas_pool_get_array(mesh, 'latCell', latCell) + IMPLICIT NONE + + integer, intent(in) :: nCells, nVertLevels + real(kind=RKIND), dimension(:,:), intent(in) :: var, zCell + real(kind=RKIND), dimension(:,:), intent(out) :: dvar_dz + integer :: iCell, k + real(kind=RKIND) :: dvar_dz_top, dvar_dz_bot + + dvar_dz(:,:) = 0.0_RKIND - call mpas_pool_get_array(diag, 'ertel_pv', ertel_pv) - call mpas_pool_get_array(diag, 'iLev_DT', iLev_DT) - - allocate(candInStrato(nVertLevels, nCells+1)) - allocate(inStrato(nVertLevels, nCells+1)) - candInStrato(:,:) = 0 - inStrato(:,:) = 0 - !store whether each level above DT to avoid repeating logic. we'll use candInStrato as a isVisited marker further below. do iCell=1,nCells - sgnHemi = sign(1.0_RKIND, latCell(iCell)) !at the equator, sign(0)=0 - if (sgnHemi .EQ. 0.0) sgnHemi = 1.0_RKIND - do k=1,nVertLevels - sgn = ertel_pv(k,iCell)*sgnHemi-pvuVal - if (sgn .GE. 0) candInStrato(k,iCell) = 1 + ! one-sided differences at top and bottom levels + dvar_dz(1,iCell) = (var(2,iCell) - var(1,iCell)) / (zCell(2,iCell) - zCell(1,iCell)) + dvar_dz(nVertLevels,iCell) = (var(nVertLevels,iCell) - var(nVertLevels-1,iCell)) / & + (zCell(nVertLevels,iCell) - zCell(nVertLevels-1,iCell)) + do k=2,nVertLevels-1 + dvar_dz_top = (var(k+1,iCell) - var(k,iCell)) / (zCell(k+1,iCell) - zCell(k,iCell)) + dvar_dz_bot = (var(k,iCell) - var(k-1,iCell)) / (zCell(k,iCell) - zCell(k-1,iCell)) + ! Currently top and bottom gradients are weighted equally by taking simple average + dvar_dz(k,iCell) = 0.5 * (dvar_dz_top + dvar_dz_bot) end do end do - - !seed flood fill with model top that's above DT. - !can have model top below 2pvu (eg, tropics) - nChanged = 0 + + end subroutine calc_vertDeriv + + !********************************************************************************************************************* + ! MC: Alternative method of calculating the vertical derivatives on mass levels, which calculates the vertical gradient + ! at the lowest mass level by first extrapolating fields to the underlying w level and interpolating to the overlying + ! w level, and then calculating the center difference. A one-sided difference is still used at the top model level. + ! For all other mass levels, a weighted average of the one-sided differences is used to + ! calculate the center differences. + !********************************************************************************************************************* + + subroutine calc_vertDeriv_alt(var, nCells, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dvar_dz) + + IMPLICIT NONE + + integer, intent(in) :: nCells, nVertLevels + real(kind=RKIND), intent(in) :: cf1, cf2, cf3 + + real(kind=RKIND), dimension(:), intent(in) :: dzu, rdzw + real(kind=RKIND), dimension(:,:), intent(in) :: var, zgrid, zCell + real(kind=RKIND), dimension(:,:), intent(out) :: dvar_dz + + integer :: iCell, k + real(kind=RKIND) :: dvar_dz_top, dvar_dz_bot, var_w2, var_w1 + real(kind=RKIND), dimension(:), allocatable :: dzw + + allocate(dzw(nVertLevels+1)) + + dzw(:) = 1./rdzw(:) + dvar_dz(:,:) = 0.0_RKIND + do iCell=1,nCells - do k=nVertLevels-5,nVertLevels - if (candInStrato(k,iCell) .GT. 0) then - inStrato(k,iCell) = 1 - candInStrato(k,iCell) = 0 - nChanged = nChanged+1 - end if + ! for bottom mass level, extrapolate to w level below, + ! interpolate to w level above, and then take the center diff. + var_w1 = cf1 * var(1,iCell) + cf2 * var(2,iCell) + cf3 * var(3,iCell) + var_w2 = (0.5/dzu(2)) * (dzw(2)*var(1,iCell) + dzw(1)*var(2,iCell)) + dvar_dz(1,iCell) = (var_w2 - var_w1)/(zgrid(2,iCell) - zgrid(1,iCell)) + + ! one-sided differences at top level + dvar_dz(nVertLevels,iCell) = (var(nVertLevels,iCell) - var(nVertLevels-1,iCell)) / & + (zCell(nVertLevels,iCell) - zCell(nVertLevels-1,iCell)) + do k=2,nVertLevels-1 + dvar_dz_top = (var(k+1,iCell) - var(k,iCell)) / (zCell(k+1,iCell) - zCell(k,iCell)) + dvar_dz_bot = (var(k,iCell) - var(k-1,iCell)) / (zCell(k,iCell) - zCell(k-1,iCell)) + + ! Alter weighting to weight bottom derivative more than top since levels closer together + dvar_dz(k,iCell) = dzu(k+1)/(dzu(k) + dzu(k+1))*dvar_dz_bot + dzu(k)/(dzu(k) + dzu(k+1))*dvar_dz_top end do end do - - !flood fill from the given seeds. since I don't know enough fortran, - !we'll just brute force a continuing loop rather than queue. - do while(nChanged .GT. 0) - nChanged = 0 - do iCell=1,nCells - do k=nVertLevels,1,-1 - !update if candidate and neighbor in strato - if (candInStrato(k,iCell) .GT. 0) then - !nbr above - if (k .LT. nVertLevels) then - if (inStrato(k+1,iCell) .GT. 0) then - inStrato(k,iCell) = 1 - candInStrato(k,iCell) = 0 - nChanged = nChanged+1 - cycle - end if - end if - - !side nbrs - do iNbr = 1, nEdgesOnCell(iCell) - iCellNbr = cellsOnCell(iNbr,iCell) - if (inStrato(k,iCellNbr) .GT. 0) then - inStrato(k,iCell) = 1 - candInStrato(k,iCell) = 0 - nChanged = nChanged+1 - cycle - end if - end do - - !nbr below - if (k .GT. 1) then - if (inStrato(k-1,iCell) .GT. 0) then - inStrato(k,iCell) = 1 - candInStrato(k,iCell) = 0 - nChanged = nChanged+1 - cycle - end if - end if - end if !candInStrato - end do !levels - end do !cells - end do !while - - !Detach high surface PV blobs w/o vertical connection to "stratosphere" - do iCell=1,nCells - if (inStrato(1,iCell) .GT. 0) then - !see how high up we can walk in the column - do k=2,nVertLevels - if (inStrato(k,iCell) .LT. 1) then - exit - end if !k is highest connected level to sfc - sgnHemi = sign(1.0_RKIND, latCell(iCell)) !at the equator, sign(0)=0 - if (sgnHemi .EQ. 0.0) sgnHemi = 1.0_RKIND - sgn = ertel_pv(k,iCell)*sgnHemi-stratoPV - if (sgn .LT. 0) then !not actually connected to "stratosphere" - inStrato(1:k,iCell) = 0 - end if - end do !k - end if !inStrato at sfc - end do !iCell - - !Fill iLev_DT with the lowest level above the tropopause (If DT above column, iLev>nVertLevels. If DT below column, iLev=0. - nChanged = 0 + + deallocate(dzw) + + end subroutine calc_vertDeriv_alt + + !********************************************************************************************************************* + ! MC: Subroutine to interpolate variable from w levels (vertical cell faces) to theta levels (cell centers) + !********************************************************************************************************************* + + subroutine interp_wLev_thetaLev(w, nCells, nVertLevels, wCell) + + IMPLICIT NONE + + integer, intent(in) :: nCells, nVertLevels + real(kind=RKIND), dimension(:,:), intent(in) :: w + real(kind=RKIND), dimension(:,:), intent(out) :: wCell + integer :: iCell, k + do iCell=1,nCells do k=1,nVertLevels - if (inStrato(k,iCell) .GT. 0) then - nChanged = 1 - exit - end if - end do !k - if (nChanged .GT. 0) then !found lowest level - if (k .EQ. 1) then - sgnHemi = sign(1.0_RKIND, latCell(iCell)) - sgn = ertel_pv(k,iCell)*sgnHemi-pvuVal - if (sgn .GT. 0) then !whole column above DT - iLev_DT(iCell) = 0 - end if - else - iLev_DT(iCell) = k - end if - else !whole column below DT - iLev_DT(iCell) = nVertLevels+2 - end if - end do !iCell - - end subroutine floodFill_strato - - subroutine floodFill_tropo(mesh, diag, pvuVal) - !Searching down each column from TOA to find 2pvu surface is buggy with stratospheric wave breaking, - !since will find 2 pvu at a higher level than "tropopause". This looks to be worse as mesh gets finer and vertical vorticity jumps. - !Note that stratospheric blobs may persist for long times w/ slow mixing downstream of mountains or deep convection. - !A few quicker fixes (make sure <2pvu for a number of layers; search down from 10PVU instead of TOA) are hacky and not robust. - - !Two flood fill options are to: - ! (1) flood fill stratosphere (>2pvu) from stratosphere seeds near model top. Strong surface PV anomalies can connect to 2pvu, - ! and the resulting "flood-filled 2 pvu" can have sizeable areas that are just at the surface while there is clearly a tropopause above (e.g., in a cross-section). - ! To address large surface blobs, take the flood fill mask and try to go up from the surface to 10 pvu w/in column. If can, all stratosphere. Else, disconnect "surface blob". - ! (2) flood fill troposphere (<2pvu) from troposphere seeds near surface. - !Somewhat paradoxically, the bottom of the stratosphere is lower than the top of the troposphere. - - !Originally, it was assumed that each (MPI) domain would have >0 cells with "right" DT found by flood filling. - !However, for "small" domains over the Arctic say during winter, the entire surface can be capped by high PV. - !So, we need to communicate between domains during the flood fill or else we find the DT at the surface. - !The extreme limiting case is if we had every cell as its own domain; then, it's clear that there has to be communication. + wCell(k,iCell) = 0.5*(w(k+1,iCell) + w(k,iCell)) + end do + end do - !The "output" is iLev_DT, which is the vertical index for the level >= pvuVal. If >nVertLevels, pvuVal above column. If <2, pvuVal below column. - !Communication between blocks during the flood fill may be needed to treat some edge cases appropriately. + end subroutine interp_wLev_thetaLev + + + !********************************************************************************************************************* + ! MC: Subroutine to store variables from the beginning of the time step to use in next timestep tendency calculations + !********************************************************************************************************************* + + subroutine store_previous_vars(mesh, time_lev, state, diag) + + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array + + IMPLICIT NONE - use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_field - use mpas_dmpar, only : mpas_dmpar_max_int,mpas_dmpar_exch_halo_field - use mpas_derived_types, only : dm_info, field2DInteger - - implicit none - type (mpas_pool_type), intent(in) :: mesh + integer, intent(in) :: time_lev ! 1 = beginning of time step; 2 = end of time step + type (mpas_pool_type), intent(in) :: state type (mpas_pool_type), intent(inout) :: diag - real(kind=RKIND), intent(in) :: pvuVal - integer :: iCell, k, nChanged, iNbr, iCellNbr, levInd, haloChanged, global_haloChanged - integer, pointer :: nCells, nVertLevels, nCellsSolve - integer, dimension(:), pointer :: nEdgesOnCell, iLev_DT - integer, dimension(:,:), pointer :: cellsOnCell, inTropo + integer, pointer :: nCells, nVertLevels, nEdges, nVertices - type (field2DInteger), pointer :: inTropo_f + real(kind=RKIND), dimension(:,:), pointer :: uReconstructZonal, uReconstructMeridional, wCell, theta, rho, & + pv_vertex, ertel_pv + real(kind=RKIND), dimension(:,:), pointer :: uReconstructZonal_prev, uReconstructMeridional_prev, wCell_prev, & + theta_prev, qv_prev, rho_prev, pv_vertex_prev, ertel_pv_prev - real(kind=RKIND) :: sgnHemi, sgn - real(kind=RKIND),dimension(:),pointer:: latCell - real(kind=RKIND), dimension(:,:), pointer :: ertel_pv - - type (dm_info), pointer :: dminfo + integer, pointer :: index_qv + real(kind=RKIND), dimension(:,:,:), pointer :: scalars + + integer, dimension(:), pointer :: iLev_DT, iLev_DT_prev - integer, dimension(:,:), allocatable :: candInTropo !whether in troposphere - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) - call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_array(diag, 'uReconstructZonal', uReconstructZonal) + call mpas_pool_get_array(diag, 'uReconstructMeridional', uReconstructMeridional) + call mpas_pool_get_array(diag, 'wCell', wCell) + call mpas_pool_get_array(diag, 'theta', theta) + call mpas_pool_get_array(state, 'scalars', scalars, 1) + call mpas_pool_get_array(diag, 'rho', rho) + call mpas_pool_get_array(diag, 'pv_vertex', pv_vertex) call mpas_pool_get_array(diag, 'ertel_pv', ertel_pv) - !call mpas_pool_get_array(diag, 'iLev_DT_trop', iLev_DT) call mpas_pool_get_array(diag, 'iLev_DT', iLev_DT) - call mpas_pool_get_array(diag, 'inTropo', inTropo) - - allocate(candInTropo(nVertLevels, nCells+1)) - candInTropo(:,:) = 0 - inTropo(:,:) = 0 - !store whether each level above DT to avoid repeating logic. we'll use cand as a isVisited marker further below. + + call mpas_pool_get_array(diag, 'uReconstructZonal_prev', uReconstructZonal_prev) + call mpas_pool_get_array(diag, 'uReconstructMeridional_prev', uReconstructMeridional_prev) + call mpas_pool_get_array(diag, 'wCell_prev', wCell_prev) + call mpas_pool_get_array(diag, 'theta_prev', theta_prev) + call mpas_pool_get_array(diag, 'qv_prev', qv_prev) + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_array(diag, 'rho_prev', rho_prev) + call mpas_pool_get_array(diag, 'pv_vertex_prev', pv_vertex_prev) + call mpas_pool_get_array(diag, 'ertel_pv_prev', ertel_pv_prev) + call mpas_pool_get_array(diag, 'iLev_DT_prev', iLev_DT_prev) + + uReconstructZonal_prev(:,:) = uReconstructZonal(:,:) + uReconstructMeridional_prev(:,:) = uReconstructMeridional(:,:) + wCell_prev(:,:) = wCell(:,:) + theta_prev(:,:) = theta(:,:) + qv_prev(:,:) = scalars(index_qv,:,:) + rho_prev(:,:) = rho(:,:) + pv_vertex_prev(:,:) = pv_vertex(:,:) + ertel_pv_prev(:,:) = ertel_pv(:,:) + iLev_DT_prev(:) = iLev_DT(:) + + end subroutine store_previous_vars + + + !********************************************************************************************************************* + ! MW: Calculate density tendency term as part of the EPV dynamics tendency + !********************************************************************************************************************* + + subroutine calc_density_term(rho, rho_prev, ertel_pv_prev, nCells, nVertLevels, dt, drho_dt) + + IMPLICIT NONE + + integer, intent(in) :: nCells, nVertLevels + real(kind=RKIND), intent(in) :: dt + real(kind=RKIND), dimension(:,:), intent(in) :: rho, rho_prev, ertel_pv_prev + real(kind=RKIND), dimension(:,:), intent(out) :: drho_dt + + integer :: k, iCell + do iCell=1,nCells - sgnHemi = sign(1.0_RKIND, latCell(iCell)) !at the equator, sign(0)=0 - if (sgnHemi .EQ. 0.0) sgnHemi = 1.0_RKIND do k=1,nVertLevels - sgn = ertel_pv(k,iCell)*sgnHemi-pvuVal - if (sgn .LT. 0) candInTropo(k,iCell) = 1 + drho_dt(k,iCell) = (rho(k,iCell) - rho_prev(k,iCell)) / (rho(k,iCell)*dt) + drho_dt(k,iCell) = ertel_pv_prev(k,iCell) * drho_dt(k,iCell) end do end do - - !seed flood fill with near surface that's below DT (can have surface above 2pvu from pv anoms). - !Note that this would be wrong if low PV "stratospheric" blobs are right above the surface - nChanged = 0 - levInd = min(nVertLevels, 3) - do iCell=1,nCells - do k=1,levInd - if (candInTropo(k,iCell) .GT. 0) then - inTropo(k,iCell) = 1 - !candInTropo(k,iCell) = 0 - nChanged = nChanged+1 - end if - end do - end do - - !flood fill from the given seeds. since I don't know enough fortran, - !we'll just brute force a continuing loop rather than queue. - call mpas_pool_get_field(diag, 'inTropo', inTropo_f) - dminfo => inTropo_f % block % domain % dminfo - global_haloChanged = 1 - do while(global_haloChanged .GT. 0) !any cell in a halo has changed, to propagate to other domains - global_haloChanged = 0 !aggregate the number of changed cells w/in the loop below - do while(nChanged .GT. 0) - nChanged = 0 - do iCell=1,nCells !should we look for neighbors of hallo cells? - !do iCell=1,nCellsSolve !should we look for neighbors of hallo cells? - do k=1,nVertLevels - !update if candidate and neighbor in troposphere - if ((candInTropo(k,iCell) .GT. 0) .AND. (inTropo(k,iCell).LT.1) ) then - !nbr below - if (k .GT. 1) then - if (inTropo(k-1,iCell) .GT. 0) then - inTropo(k,iCell) = 1 - !candInTropo(k,iCell) = 0 - nChanged = nChanged+1 - cycle - end if - end if - - !side nbrs - do iNbr = 1, nEdgesOnCell(iCell) - iCellNbr = cellsOnCell(iNbr,iCell) - if (inTropo(k,iCellNbr) .GT. 0) then - inTropo(k,iCell) = 1 - !candInTropo(k,iCell) = 0 - nChanged = nChanged+1 - exit - end if - end do - - !nbr above - if (k .LT. nVertLevels) then - if (inTropo(k+1,iCell) .GT. 0) then - inTropo(k,iCell) = 1 - !candInTropo(k,iCell) = 0 - nChanged = nChanged+1 - cycle - end if - end if - - end if !candIn - end do !levels - end do !cells - global_haloChanged = global_haloChanged+nChanged - end do !while w/in domain - !communicate to other domains for edge case where a chunk of a block hasn't gotten to fill - nChanged = global_haloChanged - call mpas_dmpar_max_int(dminfo, nChanged, global_haloChanged) - if (global_haloChanged .GT. 0) then !communicate inTropo everywhere - call mpas_dmpar_exch_halo_field(inTropo_f) - end if - nChanged = global_haloChanged !so each block will iterate again if anything changed - end do !while haloChanged - deallocate(candInTropo) - - !Fill iLev_DT with the lowest level above the tropopause (If DT above column, iLev>nVertLevels. If DT below column, iLev=0. - do iCell=1,nCells - nChanged = 0 - do k=nVertLevels,1,-1 - if (inTropo(k,iCell) .GT. 0) then - nChanged = 1 - exit - end if - end do !k - - if (nChanged .GT. 0) then !found troposphere's highest level - iLev_DT(iCell) = k+1 !level above troposphere (>nVertLevels if whole column below 2pvu; e.g., tropics) - else !whole column above DT (e.g., arctic pv tower) - iLev_DT(iCell) = 0 - end if - end do !iCell - - end subroutine floodFill_tropo - - subroutine interp_pv_diagnostics(mesh, diag, pvuVal, missingVal) - !compute various fields on 2pvu surface using calculated PVU field - !potential temperature, uZonal, uMeridional, vertical vorticity + + end subroutine calc_density_term + + + !********************************************************************************************************************* + ! MC: Modified subroutine to calculate Ertel's potential vorticity + ! PV = 1/density * [curl(wind) . grad(theta)] + !********************************************************************************************************************* + + subroutine calc_epv(mesh, state, diag) use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array - - implicit none - - type (mpas_pool_type), intent(in) :: mesh - type (mpas_pool_type), intent(inout) :: diag - real(kind=RKIND) :: pvuVal, missingVal - - integer :: iCell, k - integer, pointer :: nCells, nVertLevels - integer, dimension(:), pointer :: nEdgesOnCell, iLev_DT - integer, dimension(:,:), pointer :: cellsOnCell, cellsOnEdge, edgesOnCell, verticesOnCell, & + + IMPLICIT NONE + + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: state + type (mpas_pool_type), intent(inout) :: diag + + ! Input variables -- mesh + integer, pointer :: nCells, nCellsSolve, nVertLevels, nEdges, R3 + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, verticesOnCell, & cellsOnVertex - - real(kind=RKIND),dimension(:),pointer:: areaCell, latCell, u_pv, v_pv, theta_pv, vort_pv - real(kind=RKIND),dimension(:,:),pointer:: uZonal, uMeridional, vorticity, theta, ertel_pv, & - kiteAreasOnVertex - real(kind=RKIND), dimension(:,:), allocatable :: vVort - + real(kind=RKIND), dimension(:), pointer :: dzu, areaCell, latCell, lonCell, dcEdge + real(kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex, edgesOnCell_sign, zgrid, zCell + real(kind=RKIND), dimension(:,:,:), pointer :: coeffs_reconstruct + + ! Input variables -- state/diagnostic + real(kind=RKIND), dimension(:,:), pointer :: w, wCell, rho, theta, pv_vertex, uReconstructZonal, & + uReconstructMeridional, ertel_pv, dTheta_dz + + ! Local variables + real(kind=RKIND), dimension(:,:), allocatable :: duZonal_dz, duMerid_dz + real(kind=RKIND), dimension(:,:), allocatable :: dTheta_dxZonal, dTheta_dyMerid + real(kind=RKIND), dimension(:,:), allocatable :: dW_dxZonal, dW_dyMerid + real(kind=RKIND), dimension(:,:), allocatable :: absVort + real(kind=RKIND), dimension(:,:,:), allocatable :: absVort3D, gradTheta + + ! Uncomment if using calc_vertDeriv_alt + !real(kind=RKIND), pointer :: cf1, cf2, cf3 + !real(kind=RKIND), dimension(:), pointer :: rdzw + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCells) - + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'R3', R3) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) call mpas_pool_get_array(mesh, 'verticesOnCell', verticesOnCell) - call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) call mpas_pool_get_array(mesh, 'cellsOnVertex', cellsOnVertex) - call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'dzu', dzu) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) call mpas_pool_get_array(mesh, 'latCell', latCell) - - call mpas_pool_get_array(diag, 'ertel_pv', ertel_pv) - call mpas_pool_get_array(diag, 'theta', theta) - call mpas_pool_get_array(diag, 'vorticity', vorticity) - call mpas_pool_get_array(diag, 'uReconstructZonal', uZonal) - call mpas_pool_get_array(diag, 'uReconstructMeridional', uMeridional) - call mpas_pool_get_array(diag, 'u_pv', u_pv) - call mpas_pool_get_array(diag, 'v_pv', v_pv) - call mpas_pool_get_array(diag, 'theta_pv', theta_pv) - call mpas_pool_get_array(diag, 'vort_pv', vort_pv) - call mpas_pool_get_array(diag, 'iLev_DT', iLev_DT) - - !call mpas_log_write('Interpolating u,v,theta,vort to pv ') - - call interp_pv(nCells, nVertLevels, pvuVal, latCell, & - ertel_pv, uZonal, u_pv, missingVal, iLev_DT) - call interp_pv(nCells, nVertLevels, pvuVal, latCell, & - ertel_pv, uMeridional, v_pv, missingVal, iLev_DT) - call interp_pv(nCells, nVertLevels, pvuVal, latCell, & - ertel_pv, theta, theta_pv, missingVal, iLev_DT) - - allocate(vVort(nVertLevels, nCells+1)) - do iCell=1,nCells - do k=1,nVertLevels - vVort(k,iCell) = calc_verticalVorticity_cell(iCell, k, nEdgesOnCell(iCell), verticesOnCell, cellsOnVertex, & - kiteAreasOnVertex, areaCell(iCell), vorticity) - end do - end do - call interp_pv(nCells, nVertLevels, pvuVal, latCell, & - ertel_pv, vVort, vort_pv, missingVal, iLev_DT) - deallocate(vVort) - !call mpas_log_write('Done interpolating ') - end subroutine interp_pv_diagnostics - - subroutine interp_pvBudget_diagnostics(mesh, diag, pvuVal, missingVal) - !compute various fields on 2pvu surface using calculated PVU field - !tend_diab, tend_fric + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'coeffs_reconstruct', coeffs_reconstruct) - use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array - - implicit none - - type (mpas_pool_type), intent(in) :: mesh - type (mpas_pool_type), intent(inout) :: diag - real(kind=RKIND) :: pvuVal, missingVal - - integer :: iCell, k - integer, pointer :: nCells, nVertLevels - integer, dimension(:), pointer :: iLev_DT - - real(kind=RKIND),dimension(:),pointer:: latCell, depv_dt_diab_pv, depv_dt_fric_pv - real(kind=RKIND),dimension(:,:),pointer:: depv_dt_diab, depv_dt_fric, ertel_pv - - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCells) - - call mpas_pool_get_array(mesh, 'latCell', latCell) - + call mpas_pool_get_array(diag, 'zgrid_cell', zCell) + call mpas_pool_get_array(state, 'w', w, 1) + call mpas_pool_get_array(diag, 'wCell', wCell) + call mpas_pool_get_array(diag, 'rho', rho) + call mpas_pool_get_array(diag, 'theta', theta) + call mpas_pool_get_array(diag, 'pv_vertex', pv_vertex) + call mpas_pool_get_array(diag, 'uReconstructZonal', uReconstructZonal) + call mpas_pool_get_array(diag, 'uReconstructMeridional', uReconstructMeridional) call mpas_pool_get_array(diag, 'ertel_pv', ertel_pv) - call mpas_pool_get_array(diag, 'depv_dt_diab', depv_dt_diab) - call mpas_pool_get_array(diag, 'depv_dt_fric', depv_dt_fric) - call mpas_pool_get_array(diag, 'depv_dt_diab_pv', depv_dt_diab_pv) - call mpas_pool_get_array(diag, 'depv_dt_fric_pv', depv_dt_fric_pv) - call mpas_pool_get_array(diag, 'iLev_DT', iLev_DT) - - !call mpas_log_write('Interpolating u,v,theta,vort to pv ') - - call interp_pv(nCells, nVertLevels, pvuVal, latCell, & - ertel_pv, depv_dt_diab, depv_dt_diab_pv, missingVal, iLev_DT) - call interp_pv(nCells, nVertLevels, pvuVal, latCell, & - ertel_pv, depv_dt_fric, depv_dt_fric_pv, missingVal, iLev_DT) - !call mpas_log_write('Done interpolating ') - end subroutine interp_pvBudget_diagnostics - - subroutine interp_pv( nCells, nLevels, interpVal, & - latCell, field0, field1,field, & - missingVal, iLev_DT) + call mpas_pool_get_array(diag, 'dtheta_dz', dTheta_dz) + + ! Uncomment if using calc_vertDeriv_alt + !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(mesh, 'rdzw', rdzw) + + ! Allocate memory to intermediate vars + allocate(absVort(nVertLevels,nCells+1)) + allocate(duZonal_dz(nVertLevels,nCells+1)) + allocate(duMerid_dz(nVertLevels,nCells+1)) + allocate(dTheta_dxZonal(nVertLevels,nCells+1)) + allocate(dTheta_dyMerid(nVertLevels,nCells+1)) + allocate(dW_dxZonal(nVertLevels,nCells+1)) + allocate(dW_dyMerid(nVertLevels,nCells+1)) + allocate(absVort3D(nVertLevels,nCells+1,3)) + allocate(gradTheta(nVertLevels,nCells+1,3)) + + ertel_pv(:,:) = 0.0_RKIND + gradTheta(:,:,:) = 0.0_RKIND + absVort3D(:,:,:) = 0.0_RKIND + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Calculate the 3D potential temperature gradient + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! (1) Calculate and reconstruct horizontal potential temperature gradient to get zonal and meridional + ! gradients at cell centers: dth_dx, dth_dy + + call calc_gradOnEdges_reconCellCenter(theta, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dTheta_dxZonal, dTheta_dyMerid) + + ! (2) Calculate the vertical potential temperature gradient: dth_dz + + call calc_vertDeriv(theta, nCellsSolve, nVertLevels, zCell, dTheta_dz) + + ! For alternative method, comment out above and uncomment below (and in all locations where vertical + ! derivatve is calculated). Note: the PV budget residual is lower when using the default method. + ! + ! call calc_vertDeriv_alt(theta, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dTheta_dz) - implicit none - !linear-in-PV interpolate columns of field1 to where field0 is interpVal*sign(lat) - !using level above tropopause already diagnosed - - ! input + ! (3) Combine theta derivatives into 3D vector - integer :: nCells, nLevels - integer, intent(in) :: iLev_DT(nCells) - real(kind=RKIND) :: interpVal, missingVal - real(kind=RKIND), intent(in) ::latCell(nCells) - real(kind=RKIND), intent(in) :: field0(nLevels,nCells), field1(nLevels,nCells) - real(kind=RKIND), intent(out) :: field(nCells) + gradTheta(:,:,1) = dTheta_dxZonal + gradTheta(:,:,2) = dTheta_dyMerid + gradTheta(:,:,3) = dTheta_dz - ! local - - integer :: iCell, iLev, levInd, indlNbr - real(kind=RKIND) :: valh, vall, vallNbr, sgnh, sgnl, sgnlNbr - real(kind=RKIND) :: dv_dl, levFrac, valInterpCell, sgnHemi - - do iCell = 1, nCells - !starting from top, trap val if values on opposite side - levInd = -1 !what should happen with missing values? - levFrac = 0.0 - sgnHemi = sign(1.0_RKIND, latCell(iCell)) !problem at the equator...is sign(0)=0? - if (sgnHemi .EQ. 0.0) sgnHemi = 1.0 - valInterpCell = interpVal*sgnHemi - - iLev = iLev_DT(iCell) - if (iLev .GT. nLevels) then - levInd = -1 - sgnl = -1.0 - else if (iLev .LT. 1) then - levInd = -1 - sgnl = 1.0 - else - valh = field0(iLev,iCell) - vall = field0(iLev-1,iCell) - !sandwiched value. equal in case val0 is a vals[l]. - !get linear interpolation: val0 = vals[l]+dvals/dl * dl - !Avoid divide by 0 by just assuming value is - !halfway between... - - dv_dl = valh-vall; - if (abs(dv_dl)<1.e-6) then - levFrac = 0.5; - else - levFrac = (valInterpCell-vall)/dv_dl - end if - - levInd = iLev-1 - end if !iLev in column - - !find value of field using index we just found - if (levInd<0) then !didn't trap value - if (sgnl>0.0) then !column above value, take surface - field(iCell) = field1(1,iCell) - else !column below value, take top - !field(iCell) = missingVal - field(iCell) = field1(nLevels,iCell) - end if - else - valh = field1(levInd+1,iCell) - vall = field1(levInd,iCell) - - dv_dl = valh-vall - field(iCell) = vall+dv_dl*levFrac - end if - end do - - end subroutine interp_pv - - subroutine calc_gradxu_cell(gradxu, addEarthVort, & - iCell, level, nVertLevels, nEdgesCell0, verticesOnCell, kiteAreasOnVertex, & - cellsOnCell, edgesOnCell, cellsOnEdge, dvEdge, edgeNormalVectors, & - cellsOnVertex, & - cellTangentPlane, localVerticalUnitVectors, zgrid, areaCell0, & - uReconstructX, uReconstructY, uReconstructZ, w,vorticity) - implicit none - - real(kind=RKIND), dimension(3), intent(out) :: gradxu - integer, intent(in) :: addEarthVort, iCell, level, nVertLevels, nEdgesCell0 - real(kind=RKIND), intent(in) :: areaCell0 - real(kind=RKIND), dimension(:), intent(in) :: dvEdge - real(kind=RKIND), dimension(3,2,*), intent(in) :: cellTangentPlane - real(kind=RKIND), dimension(3,*), intent(in) :: localVerticalUnitVectors, edgeNormalVectors - real(kind=RKIND), dimension(:,:), intent(in) :: zgrid,uReconstructX, uReconstructY, uReconstructZ, & - w, vorticity, kiteAreasOnVertex - integer, dimension(:,:), intent(in) :: cellsOnCell, edgesOnCell, cellsOnEdge, verticesOnCell, cellsOnVertex - - integer :: i, iNbr, iEdge - real(kind=RKIND) :: val0, valNbr, volumeCell, areaFactor, z0, zp, zm, valp, valm, dw_dx, dw_dy, du_dz, dv_dz - real(kind=RKIND), dimension(3) :: unitDeriv, velCell0, velCellp, velCellm - real(kind=RKIND), dimension(3,3) :: xyzLocal - real(kind=RKIND), dimension(nEdgesCell0) :: valEdges, dvEdgeCell, dhEdge - real(kind=RKIND), dimension(3,nEdgesCell0) :: normalEdgeCell - - !local coordinate system - call coordinateSystem_cell(cellTangentPlane, localVerticalUnitVectors, iCell, xyzLocal) - !normal vectors at voronoi polygon edges pointing out of cell - do i=1,nEdgesCell0 - iNbr = cellsOnCell(i, iCell) - !dhEdge(i) = calc_heightVerticalEdge(iCell, iNbr, level, zgrid) !vertical thickness of that face - !if don't want to consider 3d cell since we haven't calculated the cell - !volume well, set all thicknesses to be the same - dhEdge(i) = 100.0_RKIND - - iEdge = edgesOnCell(i,iCell) - dvEdgeCell(i) = dvEdge(iEdge) - val0 = fluxSign(iCell, iEdge, cellsOnEdge) - normalEdgeCell(:,i) = edgeNormalVectors(:,iEdge) - call normalizeVector(normalEdgeCell(:,i),3) - normalEdgeCell(:,i) = normalEdgeCell(:,i)*val0 - end do + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Calculate the 3D absolute vorticity vector + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - volumeCell = calcVolumeCell(areaCell0, nEdgesCell0, dhEdge) - - !w - val0 = .5*(w(level+1, iCell)+w(level, iCell)) - do i=1,nEdgesCell0 - iNbr = cellsOnCell(i, iCell) - valNbr = .5*(w(level+1, iNbr)+w(level, iNbr)) - valEdges(i) = 0.5*(valNbr+val0) - end do - unitDeriv(:) = xyzLocal(:,1) - dw_dx = calc_horizDeriv_fv(valEdges, nEdgesCell0, dvEdgeCell, dhEdge, normalEdgeCell, unitDeriv, volumeCell) - unitDeriv(:) = xyzLocal(:,2) - dw_dy = calc_horizDeriv_fv(valEdges, nEdgesCell0, dvEdgeCell, dhEdge, normalEdgeCell, unitDeriv, volumeCell) - - !vertical derivatives - !calc_heightCellCenter(c0, level, zgrid) calc_vertDeriv_center(val0, valp, valm, z0,zp,zm) - !du/dz and dv/dz - velCell0(1) = uReconstructX(level,iCell) - velCell0(2) = uReconstructY(level,iCell) - velCell0(3) = uReconstructZ(level,iCell) - z0 = calc_heightCellCenter(iCell, level, zgrid) - if (level>1) then - !have cell beneath - velCellm(1) = uReconstructX(level-1,iCell) - velCellm(2) = uReconstructY(level-1,iCell) - velCellm(3) = uReconstructZ(level-1,iCell) - zm = calc_heightCellCenter(iCell, level-1, zgrid) - end if - if (level0) then - call local2FullVorticity(gradxu, xyzLocal(:,1), xyzLocal(:,2), xyzLocal(:,3)) - end if - - end subroutine calc_gradxu_cell - - subroutine calc_grad_cell(gradtheta, & - iCell, level, nVertLevels, nEdgesCell0, verticesOnCell, kiteAreasOnVertex, & - cellsOnCell, edgesOnCell, cellsOnEdge, dvEdge, edgeNormalVectors, & - cellsOnVertex, & - cellTangentPlane, localVerticalUnitVectors, zgrid, areaCell0, & - theta) + ! (1) Calculate the vertical shear of uReconstructZonal and uReconstructMeridional: du_dz and dv_dz + + call calc_vertDeriv(uReconstructZonal, nCellsSolve, nVertLevels, zCell, duZonal_dz) + call calc_vertDeriv(uReconstructMeridional, nCellsSolve, nVertLevels, zCell, duMerid_dz) + + ! For alternative method, comment out above and uncomment below (and in all locations where vertical + ! derivatve is calculated). Note: the PV budget residual is lower when using the default method. ! - implicit none - - real(kind=RKIND), dimension(3), intent(out) :: gradtheta - real(kind=RKIND), intent(in) :: areaCell0 - real(kind=RKIND), dimension(:), intent(in) :: dvEdge - real(kind=RKIND), dimension(3,2,*), intent(in) :: cellTangentPlane - real(kind=RKIND), dimension(3,*), intent(in) :: localVerticalUnitVectors, edgeNormalVectors - real(kind=RKIND), dimension(:,:), intent(in) :: zgrid, theta, kiteAreasOnVertex - integer, intent(in) :: iCell, level, nVertLevels, nEdgesCell0 - integer, dimension(:,:), intent(in) :: cellsOnCell, edgesOnCell, cellsOnEdge, verticesOnCell, cellsOnVertex - - integer :: i, iNbr, iEdge - real(kind=RKIND) :: val0, valNbr, volumeCell, areaFactor, z0, zp, zm, valp, valm - real(kind=RKIND), dimension(3) :: unitDeriv, velCell0, velCellp, velCellm - real(kind=RKIND), dimension(3,3) :: xyzLocal - real(kind=RKIND), dimension(nEdgesCell0) :: valEdges, dvEdgeCell, dhEdge - real(kind=RKIND), dimension(3,nEdgesCell0) :: normalEdgeCell - - !local coordinate system - call coordinateSystem_cell(cellTangentPlane, localVerticalUnitVectors, iCell, xyzLocal) - !normal vectors at voronoi polygon edges pointing out of cell - do i=1,nEdgesCell0 - iNbr = cellsOnCell(i, iCell) - !dhEdge(i) = calc_heightVerticalEdge(iCell, iNbr, level, zgrid) !vertical thickness of that face - !if don't want to consider 3d cell since we haven't calculated the cell - !volume well, set all thicknesses to be the same - dhEdge(i) = 100.0_RKIND - - iEdge = edgesOnCell(i,iCell) - dvEdgeCell(i) = dvEdge(iEdge) - val0 = fluxSign(iCell, iEdge, cellsOnEdge) - normalEdgeCell(:,i) = edgeNormalVectors(:,iEdge) - call normalizeVector(normalEdgeCell(:,i),3) - normalEdgeCell(:,i) = normalEdgeCell(:,i)*val0 - end do + ! call calc_vertDeriv_alt(uReconstructZonal, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, duZonal_dz) + ! call calc_vertDeriv_alt(uReconstructMeridional, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, duMerid_dz) - volumeCell = calcVolumeCell(areaCell0, nEdgesCell0, dhEdge) - - !Need to get 3d curl and grad theta - !horizontal derivatives - !calc_horizDeriv_fv(valEdges, nNbrs, dvEdge, dhEdge, & - ! normalEdge, unitDeriv, volumeCell) - !theta - val0 = theta(level, iCell) - do i=1,nEdgesCell0 - iNbr = cellsOnCell(i, iCell) - valNbr = theta(level,iNbr) - valEdges(i) = 0.5*(valNbr+val0) - end do - unitDeriv(:) = xyzLocal(:,1) - gradtheta(1) = calc_horizDeriv_fv(valEdges, nEdgesCell0, dvEdgeCell, dhEdge, normalEdgeCell, unitDeriv, volumeCell) - unitDeriv(:) = xyzLocal(:,2) - gradtheta(2) = calc_horizDeriv_fv(valEdges, nEdgesCell0, dvEdgeCell, dhEdge, normalEdgeCell, unitDeriv, volumeCell) - - !vertical derivatives - !calc_heightCellCenter(c0, level, zgrid) calc_vertDeriv_center(val0, valp, valm, z0,zp,zm) - !theta - gradtheta(3) = 0.0_RKIND - z0 = calc_heightCellCenter(iCell, level, zgrid) - val0 = theta(level, iCell) - if (level>1) then - !have cell beneath - valm = theta(level-1, iCell) - zm = calc_heightCellCenter(iCell, level-1, zgrid) - end if - if (level Date: Mon, 8 Jul 2024 23:26:47 -0600 Subject: [PATCH 07/23] For tendency package: update mpas_atmphys_todynamics.F Added calculation of rucuten_tend for tendency diagnostics package, which was missing. --- src/core_atmosphere/physics/mpas_atmphys_todynamics.F | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index 5f81727471..7476f850a4 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -467,7 +467,7 @@ subroutine physics_get_tend_work( & do i = 1, nEdgesSolve do k = 1, nVertLevels - tend_u(k,i)=tend_u(k,i)+rublten_Edge(k,i)*mass_edge(k,i) + tend_u(k,i) = tend_u(k,i) + rublten_Edge(k,i)*mass_edge(k,i) rublten_tend(k,i) = rublten_Edge(k,i)*mass_edge(k,i) ! MW on ITM enddo enddo @@ -535,7 +535,8 @@ subroutine physics_get_tend_work( & endif do i = 1, nEdgesSolve do k = 1, nVertLevels - tend_u(k,i)=tend_u(k,i)+rucuten_Edge(k,i)*mass_edge(k,i) + tend_u(k,i) = tend_u(k,i) + rucuten_Edge(k,i)*mass_edge(k,i) + rucuten_tend(k,i) = rucuten_Edge(k,i)*mass_edge(k,i) ! MW on ITM enddo enddo From 64b09cd0b3f29298ca584ad1f4bfc001aa4f0f4e Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Tue, 9 Jul 2024 16:21:25 -0600 Subject: [PATCH 08/23] Implemented new PV tendency diagnostics - Added relevant subroutines to mpas_pv_diagnostics.F to store variables from the beginning of the time step and compute PV tendencies for all fundamental diabatic, dynamic, and frictional processes. Added subroutine to interpolate PV tendencies to DT identified at the beginning of the time step. Added subroutine to accumulate tendencies over successive time steps. - Added call to pv_diagnostics_reset in mpas_atm_diagnostics_manager.F - Modified mpas_atmphys_interface.F to add calculations of thmmpten and qvmppten and remove calculations of dtheta_dt_mp, which is now calculated in the PV script. Note: v8.2.0 now contains calculations of rthmpten and rqvmpten for some microphysics schemes. rqvmpten is equal to qvmmpten, but rthmpten (theta tendency, not theta-m tendency) will not exactly equal the theta tendency derived from thmmpten and qvmppten that results in a closed theta budget (dtheta_dt_mp). - Added outstanding tendency calculations used for PV tendencies to mpas_atm_time_integration.F and initialized du_dt_dyn as 0. Also added missing calculation for ru_tend_diff that is needed for the ITM package but was omitted in a prior commit. - Modified mpas_atm_todynamics.F to remove calculations of tend_u_phys, which is no longer used in the PV tendency calculations. - Modified mpas_atm_core.F to add a config_pv_tend flag for calculation of diagnostic variables, rho and theta. Previously these were only calculated prior to writing an output file. If config_pv_tend is set to true, these will now be calculated at each time step. --- .../mpas_atm_diagnostics_manager.F | 6 +- .../diagnostics/mpas_pv_diagnostics.F | 1243 ++++++++++++++++- .../dynamics/mpas_atm_time_integration.F | 26 +- src/core_atmosphere/mpas_atm_core.F | 15 +- .../physics/mpas_atmphys_interface.F | 54 +- .../physics/mpas_atmphys_todynamics.F | 28 +- 6 files changed, 1308 insertions(+), 64 deletions(-) diff --git a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F index e90b2dca90..4d093f6079 100644 --- a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F +++ b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F @@ -173,13 +173,17 @@ subroutine mpas_atm_diag_reset() use mpas_diagnostic_template, only : diagnostic_template_reset use mpas_convective_diagnostics, only : convective_diagnostics_reset + use mpas_pv_diagnostics, only : pv_diagnostics_reset implicit none - call diagnostic_template_reset() call convective_diagnostics_reset() + call mpas_timer_start('Tendency and PV diagnostics') + call pv_diagnostics_reset() + call mpas_timer_stop('Tendency and PV diagnostics') + end subroutine mpas_atm_diag_reset diff --git a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F index c0ea8e9c86..9088962fab 100644 --- a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F @@ -43,6 +43,7 @@ end subroutine halo_exchange_routine public :: pv_diagnostics_setup, & pv_diagnostics_compute, & + pv_diagnostics_reset, & pv_diagnostics_update private @@ -75,8 +76,7 @@ end subroutine halo_exchange_routine ! Subroutines contained in fully updated mpas_pv_diagnostics.F: ! ------------------------------------------------------------ ! pv_diagnostics_setup : setup diagnostics package and performs initial check of PV config flags - ! pv_diagnostics_reset : calls store_previous_vars to save previous timestep variables and pv_diagnostics_dyn_init - ! : to initialize and reset the computed theta and momentum tendencies as zeros + ! pv_diagnostics_reset : calls store_previous_vars to save previous timestep variables ! pv_diagnostics_update : calls atm_compute_pv_diagnostics and atm_compute_pvBudget_diagnostics to compute PV, all ! PV tendency variables, and interpolation of variables onto identified dynamic tropopause ! pv_diagnostics_init : initializes PV scalar variable if desired and not a restart run. called in a @@ -251,6 +251,8 @@ subroutine pv_diagnostics_update(domain, exchange_halo_group) ! MC: modifi call mpas_log_write("Computing Ertel's PV.") call atm_compute_pv_diagnostics(domain, configs, state, diag, mesh, exchange_halo_group) + call mpas_log_write('Computing PV tendency diagnostics.') + call atm_compute_pvBudget_diagnostics(domain, configs, state, diag, mesh, tend, tend_physics, diag_physics, exchange_halo_group) end if end subroutine pv_diagnostics_update @@ -282,6 +284,48 @@ subroutine pv_diagnostics_compute(domain, exchange_halo_group) ! MC: modif end subroutine pv_diagnostics_compute + !********************************************************************************************************************* + ! pv_diagnostics_reset: Update beginning of time step fields after they have been written to outfile for use in next + ! time step PV tendency calculations when called in mpas_atm_diagnostics_manager.F + !********************************************************************************************************************* + + subroutine pv_diagnostics_reset() + use mpas_atm_diagnostics_utils, only : MPAS_field_will_be_written + use mpas_pool_routines, only: mpas_pool_get_config, mpas_pool_get_dimension, mpas_pool_get_array + + implicit none + + logical, pointer :: config_pv_diag, config_pv_tend + integer, pointer :: nCells, nVertLevels + real(kind=RKIND), dimension(:,:), pointer :: rho + integer :: k + + call mpas_pool_get_config(configs, 'config_pv_diag', config_pv_diag) + call mpas_pool_get_config(configs, 'config_pv_tend', config_pv_tend) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_array(diag, 'rho', rho) + + if (config_pv_diag) then + ! Avoid FP errors caused by a potential division by zero below by + ! initializing the "garbage cell" of rho to a non-zero value + do k=1,nVertLevels + rho(k,nCells+1) = 1.0 + end do + + if (config_pv_tend) then + ! Called immediately after diagnostics have been written + ! Update previous variables for next timestep calculation + call mpas_log_write('Updating previous time step fields for PV tendency calculations.') + call mpas_log_write(' ') + call store_previous_vars(mesh, state, diag) + end if + end if + + end subroutine pv_diagnostics_reset + + !********************************************************************************************************************* ! NS: Below are two subroutines (floodFill_strato and floodFill_tropo), designed to determine the first model level ! above the dynamic tropopause, iLev_DT, which is designated as the 2-PVU isosurface. Only one of these subroutines @@ -1066,6 +1110,56 @@ subroutine interp_pv_diagnostics(mesh, diag, pvuVal, missingVal) end subroutine interp_pv_diagnostics + !********************************************************************************************************************* + ! NS: Subroutine to compute various tendency fields on 2-PVU surface using the calculated PV field + ! MC: This routine should use PV field and dynamic tropopause from beginning of time step, so this has been modified + ! accordingly. + !********************************************************************************************************************* + + subroutine interp_pvBudget_diagnostics(mesh, diag, pvuVal, missingVal) + + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array + + IMPLICIT NONE + + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(inout) :: diag + real(kind=RKIND) :: pvuVal, missingVal + + integer :: iCell, k + integer, pointer :: nCells, nVertLevels + integer, dimension(:), pointer :: iLev_DT_prev + + real(kind=RKIND), dimension(:),pointer :: latCell, depv_dt_diab_pv, depv_dt_fric_pv, depv_dt_dyn_pv + real(kind=RKIND), dimension(:,:),pointer :: depv_dt_diab, depv_dt_fric, depv_dt_dyn, & + ertel_pv_prev ! MC changed + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(diag, 'ertel_pv_prev', ertel_pv_prev) + call mpas_pool_get_array(diag, 'iLev_DT_prev', iLev_DT_prev) + call mpas_pool_get_array(diag, 'depv_dt_diab', depv_dt_diab) + call mpas_pool_get_array(diag, 'depv_dt_fric', depv_dt_fric) + call mpas_pool_get_array(diag, 'depv_dt_dyn', depv_dt_dyn) + + call mpas_pool_get_array(diag, 'depv_dt_diab_pv', depv_dt_diab_pv) + call mpas_pool_get_array(diag, 'depv_dt_fric_pv', depv_dt_fric_pv) + call mpas_pool_get_array(diag, 'depv_dt_dyn_pv', depv_dt_dyn_pv) + + call interp_pv(nCells, nVertLevels, pvuVal, latCell, & + ertel_pv_prev, depv_dt_diab, depv_dt_diab_pv, missingVal, iLev_DT_prev) + + call interp_pv(nCells, nVertLevels, pvuVal, latCell, & + ertel_pv_prev, depv_dt_fric, depv_dt_fric_pv, missingVal, iLev_DT_prev) + + call interp_pv(nCells, nVertLevels, pvuVal, latCell, & + ertel_pv_prev, depv_dt_dyn, depv_dt_dyn_pv, missingVal, iLev_DT_prev) + + end subroutine interp_pvBudget_diagnostics + + !********************************************************************************************************************* ! NS: Subroutine to linearly interpolate columns of field1 to where field0 is interpVal*sign(lat) using level above ! tropopause already diagnosed @@ -1699,14 +1793,13 @@ end subroutine interp_wLev_thetaLev ! MC: Subroutine to store variables from the beginning of the time step to use in next timestep tendency calculations !********************************************************************************************************************* - subroutine store_previous_vars(mesh, time_lev, state, diag) + subroutine store_previous_vars(mesh, state, diag) use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array IMPLICIT NONE type (mpas_pool_type), intent(in) :: mesh - integer, intent(in) :: time_lev ! 1 = beginning of time step; 2 = end of time step type (mpas_pool_type), intent(in) :: state type (mpas_pool_type), intent(inout) :: diag @@ -1972,8 +2065,7 @@ end subroutine calc_epv subroutine atm_compute_pv_diagnostics(domain, configs, state, diag, mesh, exchange_halo_group) use mpas_constants - use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_field - use mpas_derived_types, only : field2DReal + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array use mpas_dmpar, only : mpas_dmpar_exch_halo_field implicit none @@ -2020,6 +2112,1145 @@ subroutine atm_compute_pv_diagnostics(domain, configs, state, diag, mesh, exchan end subroutine atm_compute_pv_diagnostics + !********************************************************************************************************************* + ! MC: Modified subroutine to calculate Ertel's potential vorticity tendency using state and diagnostic variables at + ! the BEGINNING of the previous time step (i.e., before they are updated by the tendencies from dynamics and physics) + ! and the tendencies from dynamics and physics over the previous time step. This is necessary via product rule: + ! + ! dPV/dt = 1/density * [curl(wind) . grad(theta_tendency) + curl(wind_tendency) . grad(theta)] + ! + ! and differs from the original formulation, which incorrectly used the updated state and diagnostic variables + ! at the end of the time step and the tendencies responsible for updating them! + !********************************************************************************************************************* + + subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_physics) + + use mpas_vector_reconstruction + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_config + + implicit none + + type (mpas_pool_type), intent(in) :: configs + type (mpas_pool_type), intent(in) :: state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: tend_physics + type (mpas_pool_type), intent(in) :: diag_physics + type (mpas_pool_type), intent(inout) :: tend + + ! mesh / configuration variables + real(kind=RKIND), pointer :: config_dt + logical, pointer :: config_pv_microphys + + integer, pointer :: nCells, nVertLevels, nEdges, R3, nVertices, nCellsSolve + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, verticesOnCell, & + cellsOnVertex, verticesOnEdge + + real(kind=RKIND), dimension(:), pointer :: dzu, areaCell, latCell, lonCell, dcEdge, areaTriangle + real(kind=RKIND), dimension(:,:), pointer :: zgrid, zCell, kiteAreasOnVertex, edgesOnCell_sign + real(kind=RKIND), dimension(:,:,:), pointer :: coeffs_reconstruct + + ! need to call stored variables from beginning of previous time step + real(kind=RKIND), dimension(:,:), pointer :: rho_prev, pv_vertex_prev, uReconstructZonal_prev, & + uReconstructMeridional_prev, wCell_prev, ertel_pv_prev, qv_prev + ! t+dt variables + real(kind=RKIND), dimension(:,:), pointer :: rho, theta + + ! diabatic PV tendencies + real(kind=RKIND), dimension(:,:), pointer :: depv_dt_lw, depv_dt_sw, depv_dt_bl, depv_dt_cu, depv_dt_mp, & + depv_dt_mix, depv_dt_diab + ! friction PV tendencies + real(kind=RKIND), dimension(:,:), pointer :: depv_dt_fric, depv_dt_fric_bl, depv_dt_fric_mix, depv_dt_fric_cu + + ! dynamics PV tendency + real(kind=RKIND), dimension(:,:), pointer :: depv_dt_dyn + + ! process tendencies -- friction + real(kind=RKIND), dimension(:,:), pointer :: u_tend_diff, w_tend_diff, tend_wCell_diff, tend_u_pbl, tend_u_cu + real(kind=RKIND), dimension(:,:), pointer :: uTend_curl_diff, uTend_curl_pbl, uTend_curl_cu + + ! process tendencies -- diabatic + real(kind=RKIND), dimension(:,:), pointer :: dtheta_dt_mp, dtheta_dt_mix, dtheta_dt_pbl, dtheta_dt_cu, dtheta_dt_sw, & ! MC: calculated in atm_compute_pvBudget_diagnostics + dtheta_dt_lw + + ! process tendencies -- dynamics + real(kind=RKIND), dimension(:,:), pointer :: dtheta_dt_dyn, du_dt_dyn, dw_dt_dyn, tenddyn_wCell + real(kind=RKIND), dimension(:,:), pointer :: uTend_curl_dyn + + ! local static variables + real(kind=RKIND), dimension(:,:), allocatable :: duZonal_dz, duMerid_dz + real(kind=RKIND), dimension(:,:), allocatable :: dTheta_dxZonal, dTheta_dyMerid, dTheta_dz ! note: dTheta_dz can be stored if changed to a pointer var + real(kind=RKIND), dimension(:,:), allocatable :: dW_dxZonal, dW_dyMerid + real(kind=RKIND), dimension(:,:), allocatable :: absVort + real(kind=RKIND), dimension(:,:,:), allocatable :: absVort3D, gradTheta + ! diabatic tendency variables + real(kind=RKIND), dimension(:,:), allocatable :: dLWtend_dxZonal, dLWtend_dyMerid, dLWtend_dz ! Gradients of theta tendencies from LW radiation + real(kind=RKIND), dimension(:,:), allocatable :: dSWtend_dxZonal, dSWtend_dyMerid, dSWtend_dz ! Gradients of theta tendencies from SW radiation + real(kind=RKIND), dimension(:,:), allocatable :: dBLtend_dxZonal, dBLtend_dyMerid, dBLtend_dz ! Gradients of theta tendencies from PBL scheme + real(kind=RKIND), dimension(:,:), allocatable :: dCUtend_dxZonal, dCUtend_dyMerid, dCUtend_dz ! Gradients of theta tendencies from cumulus scheme + real(kind=RKIND), dimension(:,:), allocatable :: dMPtend_dxZonal, dMPtend_dyMerid, dMPtend_dz ! Gradients of theta tendencies from microphysics + real(kind=RKIND), dimension(:,:), allocatable :: dMXtend_dxZonal, dMXtend_dyMerid, dMXtend_dz ! Gradients of theta tendencies from explicit horiz mixing + real(kind=RKIND), dimension(:,:,:), allocatable :: grad_diabatic_LW, grad_diabatic_SW, grad_diabatic_BL, & + grad_diabatic_CU, grad_diabatic_MP, grad_diabatic_MX + + ! friction tendency vars + real(kind=RKIND), dimension(:,:), allocatable :: dWtend_dxZonal, dWtend_dyMerid, duZonalTend_dz_mix, duMeridTend_dz_mix, & + vertVortTend_mix, tenduX_mix, tenduY_mix, tenduZ_mix, tend_uZonal_mix, tend_uMerid_mix + real(kind=RKIND), dimension(:,:), allocatable :: duZonalTend_dz_pbl, duMeridTend_dz_pbl, & + vertVortTend_pbl, tenduX_pbl, tenduY_pbl, tenduZ_pbl, tend_uZonal_pbl, tend_uMerid_pbl + real(kind=RKIND), dimension(:,:), allocatable :: duZonalTend_dz_cu, duMeridTend_dz_cu, & + vertVortTend_cu, tenduX_cu, tenduY_cu, tenduZ_cu, tend_uZonal_cu, tend_uMerid_cu + real(kind=RKIND), dimension(:,:), allocatable :: dWtend_dxZonal_phys, dWtend_dyMerid_phys + real(kind=RKIND), dimension(:,:,:), allocatable :: vortTend3D_mix, vortTend3D_pbl, vortTend3D_cu + + ! dynamics vars + real(kind=RKIND), dimension(:,:), allocatable :: depv_dt_graddyn, depv_dt_vortdyn, drho_dt_term, tenduX_dyn, tenduY_dyn, tenduZ_dyn + real(kind=RKIND), dimension(:,:), allocatable :: tend_uZonal_dyn, tend_uMerid_dyn, dDYNtend_dxZonal, dDYNtend_dyMerid, & + dDYNtend_dz, vertVortTend_dyn, duZonalTend_dz, duMeridTend_dz + real(kind=RKIND), dimension(:,:,:), allocatable :: grad_DYN, vortTend3D_DYN + + ! needed for alternative vertical derivative calculation + !real(kind=RKIND), pointer :: cf1, cf2, cf3 + !real(kind=RKIND), dimension(:), pointer :: rdzw + + + ! mesh / config vars + call mpas_pool_get_config(configs,'config_dt',config_dt) + call mpas_pool_get_config(configs, 'config_pv_microphys', config_pv_microphys) + + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'R3', R3) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + 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, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnVertex', cellsOnVertex) + call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) + call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'dzu', dzu) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + call mpas_pool_get_array(mesh, 'coeffs_reconstruct', coeffs_reconstruct) + call mpas_pool_get_array(diag, 'zgrid_cell', zCell) + + ! time-level t variables + call mpas_pool_get_array(diag, 'rho_prev', rho_prev) + call mpas_pool_get_array(diag, 'pv_vertex_prev', pv_vertex_prev) + call mpas_pool_get_array(diag, 'ertel_pv_prev', ertel_pv_prev) + call mpas_pool_get_array(diag, 'uReconstructZonal_prev', uReconstructZonal_prev) + call mpas_pool_get_array(diag, 'uReconstructMeridional_prev', uReconstructMeridional_prev) + call mpas_pool_get_array(diag, 'wCell_prev', wCell_prev) + + ! time-level t+dt variables + call mpas_pool_get_array(diag, 'rho', rho) + call mpas_pool_get_array(diag, 'theta', theta) + + ! diabatic PV tendencies + call mpas_pool_get_array(diag, 'depv_dt_lw', depv_dt_lw) ! diabatic PV tendency from longwave radiation + call mpas_pool_get_array(diag, 'depv_dt_sw', depv_dt_sw) ! diabatic PV tendency from shortwave radiation + call mpas_pool_get_array(diag, 'depv_dt_bl', depv_dt_bl) ! diabatic PV tendency from PBL scheme + call mpas_pool_get_array(diag, 'depv_dt_cu', depv_dt_cu) ! diabatic PV tendency from cumulus scheme + call mpas_pool_get_array(diag, 'depv_dt_mp', depv_dt_mp) ! diabatic PV tendency from microphysics scheme + call mpas_pool_get_array(diag, 'depv_dt_mix', depv_dt_mix) ! diabatic PV tendency from explict mixing + call mpas_pool_get_array(diag, 'depv_dt_diab', depv_dt_diab) ! total diabatic PV tendency + + ! frictional PV tendencies + call mpas_pool_get_array(diag, 'depv_dt_fric_bl', depv_dt_fric_bl) ! frictional PV tendency from PBL + GWD schemes + call mpas_pool_get_array(diag, 'depv_dt_fric_cu', depv_dt_fric_cu) ! frictional PV tendency from cumulus scheme (only nonzero if scheme modifies winds) + call mpas_pool_get_array(diag, 'depv_dt_fric_mix', depv_dt_fric_mix) ! frictional PV tendency from explicit mixing + call mpas_pool_get_array(diag, 'depv_dt_fric', depv_dt_fric) ! total frictional PV tendency + + ! dynamics PV tendency + call mpas_pool_get_array(diag,'depv_dt_dyn',depv_dt_dyn) ! total PV tendency from dynamics (includes transport, decoupling, rho tendency) + ! process tendencies -- friction: + call mpas_pool_get_array(diag, 'u_tend_diff', u_tend_diff) ! Normal wind tendency from explicit mixing on cell edges + call mpas_pool_get_array(diag, 'w_tend_diff', w_tend_diff) ! Vertical wind tendency from explicit mixing + call mpas_pool_get_array(diag, 'tend_wCell_diff', tend_wCell_diff) ! w_tend_diff interpolated to mass levels + call mpas_pool_get_array(diag, 'tend_u_pbl', tend_u_pbl) ! Normal wind tendency from PBL + GWD on cell edges + call mpas_pool_get_array(diag, 'tend_u_cu', tend_u_cu) ! Normal wind tendency from cumulus scheme (only nonzero if scheme modifies winds) + call mpas_pool_get_array(diag, 'uTend_curl_diff', uTend_curl_diff) ! Vertical curl of u_tend_diff at cell vertices + call mpas_pool_get_array(diag, 'uTend_curl_pbl', uTend_curl_pbl) ! Vertical curl of tend_u_pbl at cell vertices + call mpas_pool_get_array(diag, 'uTend_curl_cu', uTend_curl_cu) ! Vertical curl of tend_u_cu at cell vertices + + ! process tendencies -- diabatic: + call mpas_pool_get_array(diag, 'dtheta_dt_mix', dtheta_dt_mix) ! Derived potential temperature tendency from explicit horizontal mixing + call mpas_pool_get_array(diag, 'dtheta_dt_cu', dtheta_dt_cu) ! Derived potential temperature tendency from cumulus + call mpas_pool_get_array(diag, 'dtheta_dt_pbl', dtheta_dt_pbl) ! Derived potential temperature tendency from PBL + call mpas_pool_get_array(diag, 'dtheta_dt_sw', dtheta_dt_sw) ! Derived potential temperature tendency from SW radiation + call mpas_pool_get_array(diag, 'dtheta_dt_lw', dtheta_dt_lw) ! Derived potential temperature tendency from LW radiation + call mpas_pool_get_array(diag, 'dtheta_dt_mp', dtheta_dt_mp) ! Derived potential temperature tendency from microphysics + + ! process tendencies -- dynamics: + call mpas_pool_get_array(diag, 'dtheta_dt_dyn', dtheta_dt_dyn) ! Derived potential temperature tendency from dynamics + call mpas_pool_get_array(diag, 'du_dt_dyn', du_dt_dyn) ! Normal wind tendency from dynamics on cell edges + call mpas_pool_get_array(diag, 'dw_dt_dyn', dw_dt_dyn) ! Vertical wind tendency from dynamics + call mpas_pool_get_array(diag, 'tenddyn_wCell', tenddyn_wCell) ! dw_dt_dyn interpolated to mass levels + call mpas_pool_get_array(diag, 'uTend_curl_dyn', uTend_curl_dyn) ! Vertical curl of du_dt_dyn at cell vertices + + ! needed for alternative vertical derivative calculation + !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(mesh, 'rdzw', rdzw) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Allocate Variables + + ! local static vars + allocate(duZonal_dz(nVertLevels,nCells+1)) + allocate(duMerid_dz(nVertLevels,nCells+1)) + allocate(dTheta_dxZonal(nVertLevels,nCells+1)) + allocate(dTheta_dyMerid(nVertLevels,nCells+1)) + allocate(dTheta_dz(nVertLevels,nCells+1)) + allocate(dW_dxZonal(nVertLevels,nCells+1)) + allocate(dW_dyMerid(nVertLevels,nCells+1)) + allocate(absVort(nVertLevels,nCells+1)) + ! 3D static vectors + allocate(absVort3D(nVertLevels,nCells+1,R3)) + allocate(gradTheta(nVertLevels,nCells+1,R3)) + + ! allocate diabatic tendency variables + allocate(dLWtend_dxZonal(nVertLevels,nCells+1)) + allocate(dLWtend_dyMerid(nVertLevels,nCells+1)) + allocate(dLWtend_dz(nVertLevels,nCells+1)) + allocate(dSWtend_dxZonal(nVertLevels,nCells+1)) + allocate(dSWtend_dyMerid(nVertLevels,nCells+1)) + allocate(dSWtend_dz(nVertLevels,nCells+1)) + allocate(dBLtend_dxZonal(nVertLevels,nCells+1)) + allocate(dBLtend_dyMerid(nVertLevels,nCells+1)) + allocate(dBLtend_dz(nVertLevels,nCells+1)) + allocate(dCUtend_dxZonal(nVertLevels,nCells+1)) + allocate(dCUtend_dyMerid(nVertLevels,nCells+1)) + allocate(dCUtend_dz(nVertLevels,nCells+1)) + allocate(dMPtend_dxZonal(nVertLevels,nCells+1)) + allocate(dMPtend_dyMerid(nVertLevels,nCells+1)) + allocate(dMPtend_dz(nVertLevels,nCells+1)) + allocate(dMXtend_dxZonal(nVertLevels,nCells+1)) + allocate(dMXtend_dyMerid(nVertLevels,nCells+1)) + allocate(dMXtend_dz(nVertLevels,nCells+1)) + ! 3D tendency vectors + allocate(grad_diabatic_LW(nVertLevels,nCells+1,R3)) + allocate(grad_diabatic_SW(nVertLevels,nCells+1,R3)) + allocate(grad_diabatic_BL(nVertLevels,nCells+1,R3)) + allocate(grad_diabatic_CU(nVertLevels,nCells+1,R3)) + allocate(grad_diabatic_MX(nVertLevels,nCells+1,R3)) + allocate(grad_diabatic_MP(nVertLevels,nCells+1,R3)) + + ! allocate friction tendency variables + ! mixing + allocate(dWtend_dxZonal(nVertLevels,nCells+1)) ! also used for dynamics + allocate(dWtend_dyMerid(nVertLevels,nCells+1)) ! also used for dynamics + allocate(duZonalTend_dz_mix(nVertLevels,nCells+1)) + allocate(duMeridTend_dz_mix(nVertLevels,nCells+1)) + allocate(tend_uZonal_mix(nVertLevels,nCells+1)) ! reconstructing in tend subroutines + allocate(tend_uMerid_mix(nVertLevels,nCells+1)) ! reconstructing in tend subroutines + allocate(vertVortTend_mix(nVertLevels,nCells+1)) + allocate(tenduX_mix(nVertLevels,nCells+1)) + allocate(tenduY_mix(nVertLevels,nCells+1)) + allocate(tenduZ_mix(nVertLevels,nCells+1)) + ! PBL + allocate(duZonalTend_dz_pbl(nVertLevels,nCells+1)) + allocate(duMeridTend_dz_pbl(nVertLevels,nCells+1)) + allocate(tend_uZonal_pbl(nVertLevels,nCells+1)) ! reconstructing in tend subroutines + allocate(tend_uMerid_pbl(nVertLevels,nCells+1)) ! reconstructing in tend subroutines + allocate(vertVortTend_pbl(nVertLevels,nCells+1)) + allocate(tenduX_pbl(nVertLevels,nCells+1)) + allocate(tenduY_pbl(nVertLevels,nCells+1)) + allocate(tenduZ_pbl(nVertLevels,nCells+1)) + ! cumulus + allocate(duZonalTend_dz_cu(nVertLevels,nCells+1)) + allocate(duMeridTend_dz_cu(nVertLevels,nCells+1)) + allocate(tend_uZonal_cu(nVertLevels,nCells+1)) ! reconstructing in tend subroutines + allocate(tend_uMerid_cu(nVertLevels,nCells+1)) ! reconstructing in tend subroutines + allocate(vertVortTend_cu(nVertLevels,nCells+1)) + allocate(tenduX_cu(nVertLevels,nCells+1)) + allocate(tenduY_cu(nVertLevels,nCells+1)) + allocate(tenduZ_cu(nVertLevels,nCells+1)) + ! zeroed variables for w tendency from phys + allocate(dWtend_dxZonal_phys(nVertLevels,nCells+1)) + allocate(dWtend_dyMerid_phys(nVertLevels,nCells+1)) + ! 3D tendency vectors + allocate(vortTend3D_mix(nVertLevels,nCells+1,R3)) + allocate(vortTend3D_pbl(nVertLevels,nCells+1,R3)) + allocate(vortTend3D_cu(nVertLevels,nCells+1,R3)) + + ! allocate dynamics tendency variables + allocate(duZonalTend_dz(nVertLevels,nCells+1)) + allocate(duMeridTend_dz(nVertLevels,nCells+1)) + allocate(tend_uZonal_dyn(nVertLevels,nCells+1)) + allocate(tend_uMerid_dyn(nVertLevels,nCells+1)) + allocate(vertVortTend_dyn(nVertLevels,nCells+1)) + allocate(tenduX_dyn(nVertLevels,nCells+1)) + allocate(tenduY_dyn(nVertLevels,nCells+1)) + allocate(tenduZ_dyn(nVertLevels,nCells+1)) + allocate(vortTend3D_DYN(nVertLevels,nCells+1,R3)) + allocate(dDYNtend_dxZonal(nVertLevels,nCells+1)) ! used for dyn theta tendency + allocate(dDYNtend_dyMerid(nVertLevels,nCells+1)) ! used for dyn theta tendency + allocate(dDYNtend_dz(nVertLevels,nCells+1)) ! used for dyn theta tendency + allocate(grad_DYN(nVertLevels,nCells+1,R3)) + allocate(depv_dt_graddyn(nVertLevels,nCells+1)) + allocate(depv_dt_vortdyn(nVertLevels,nCells+1)) + allocate(drho_dt_term(nVertLevels,nCells+1)) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Initialize vars + depv_dt_lw(:,:) = 0.0_RKIND + depv_dt_sw(:,:) = 0.0_RKIND + depv_dt_bl(:,:) = 0.0_RKIND + depv_dt_cu(:,:) = 0.0_RKIND + depv_dt_mp(:,:) = 0.0_RKIND + depv_dt_mix(:,:) = 0.0_RKIND + depv_dt_diab(:,:) = 0.0_RKIND + depv_dt_fric(:,:) = 0.0_RKIND + depv_dt_fric_bl(:,:) = 0.0_RKIND + depv_dt_fric_mix(:,:) = 0.0_RKIND + depv_dt_fric_cu(:,:) = 0.0_RKIND + depv_dt_dyn(:,:) = 0.0_RKIND + depv_dt_graddyn(:,:) = 0.0_RKIND + depv_dt_vortdyn(:,:) = 0.0_RKIND + drho_dt_term(:,:) = 0.0_RKIND + + ! Gradient of w tendency from phys (remains 0) + dWtend_dxZonal_phys(:,:) = 0.0_RKIND + dWtend_dyMerid_phys(:,:) = 0.0_RKIND + + + !*********************************************************************************************** + ! Calculate terms needed for PV tendency equation + !*********************************************************************************************** + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Calculate the 3D potential temperature gradient using theta at end of time step + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! (1) Calculate and reconstruct horizontal potential temperature gradient to get zonal and meridional + ! gradients at cell centers: dth_dx, dth_dy + call calc_gradOnEdges_reconCellCenter(theta, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dTheta_dxZonal, dTheta_dyMerid) + + ! (2) Calculate the vertical potential temperature gradient: dth_dz + call calc_vertDeriv(theta, nCellsSolve, nVertLevels, zCell, dTheta_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(theta, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dTheta_dz) + + ! (3) Combine theta derivatives into 3D vector + gradTheta(:,:,1) = dTheta_dxZonal + gradTheta(:,:,2) = dTheta_dyMerid + gradTheta(:,:,3) = dTheta_dz + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Calculate the 3D absolute vorticity vector using winds at beginning of time step + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! (1) Calculate the vertical shear of uReconstructZonal and uReconstructMeridional: du_dz and dv_dz + call calc_vertDeriv(uReconstructZonal_prev, nCellsSolve, nVertLevels, zCell, duZonal_dz) + call calc_vertDeriv(uReconstructMeridional_prev, nCellsSolve, nVertLevels, zCell, duMerid_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(uReconstructZonal_prev, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, duZonal_dz) + ! call calc_vertDeriv_alt(uReconstructMeridional_prev, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, duMerid_dz) + + ! (2) Interpolate w to cell centers, calculate gradient of w on edges, and then reconstruct to get + ! zonal and meridional gradients at cell centers: dw_dx, dw_dy + call calc_gradOnEdges_reconCellCenter(wCell_prev, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dW_dxZonal, dW_dyMerid) + + ! (3) Reconstruct absolute vertical vorticity at vertices pv_vertex to cell centers + ! Note: currently, pv_vertex is the absolute vertical vorticity on the cell vertices. If this + ! variable changes at some point, then the absolute vertical vorticity on the vertices needs + ! to be computed as follows: + ! do iVert=1,nVertices + ! vorticity(:,iVert) = vorticity(:,iVert) + fVertex(iVert) + ! end do + call interp_absVertVort(pv_vertex_prev, nCellsSolve, nEdgesOnCell, verticesOnCell, & + cellsOnVertex, areaCell, kiteAreasOnVertex, absVort) + + ! (4) Combine three components into vorticity vector + absVort3D(:,:,1) = dW_dyMerid - duMerid_dz ! dw/dy - dv/dz + absVort3D(:,:,2) = duZonal_dz - dW_dxZonal ! du/dz - dw/dx + absVort3D(:,:,3) = absVort ! dv/dy - du/dx + f + + !*********************************************************************************************** + ! Calculate diabatic PV tendency terms: + !*********************************************************************************************** + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Longwave radiation tendency: depv_dt_lw + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (associated(dtheta_dt_lw)) then + + ! (1) Calculate and reconstruct horizontal gradients of theta tendency + call calc_gradOnEdges_reconCellCenter(dtheta_dt_lw, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dLWtend_dxZonal, & + dLWtend_dyMerid) + + ! (2) Calculate vertical gradient of theta tendency + call calc_vertDeriv(dtheta_dt_lw, nCellsSolve, nVertLevels, zCell, dLWtend_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(dtheta_dt_lw, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dLWtend_dz) + + ! (3) Combine into 3D theta tendency gradient vector + grad_diabatic_LW(:,:,1) = dLWtend_dxZonal + grad_diabatic_LW(:,:,2) = dLWtend_dyMerid + grad_diabatic_LW(:,:,3) = dLWtend_dz + + ! (4) Take dot product between 3D theta tendency vector and absolute vorticity / density + call calc_dotProduct_3D(grad_diabatic_LW, absVort3D, nCellsSolve, nVertLevels, depv_dt_lw) + + depv_dt_lw = depv_dt_lw / rho * 1.0e6 + else + depv_dt_lw = 0.0_RKIND + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Shortwave radiation tendency: depv_dt_sw + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (associated(dtheta_dt_sw)) then + + ! (1) Calculate and reconstruct horizontal gradients of theta tendency + call calc_gradOnEdges_reconCellCenter(dtheta_dt_sw, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dSWtend_dxZonal, & + dSWtend_dyMerid) + + ! (2) Calculate vertical gradient of theta tendency + call calc_vertDeriv(dtheta_dt_sw, nCellsSolve, nVertLevels, zCell, dSWtend_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(dtheta_dt_sw, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dSWtend_dz) + + ! (3) Combine into 3D theta tendency gradient vector + grad_diabatic_SW(:,:,1) = dSWtend_dxZonal + grad_diabatic_SW(:,:,2) = dSWtend_dyMerid + grad_diabatic_SW(:,:,3) = dSWtend_dz + + ! (4) Take dot product between 3D theta tendency vector and absolute vorticity / density + call calc_dotProduct_3D(grad_diabatic_SW, absVort3D, nCellsSolve, nVertLevels, depv_dt_sw) + + depv_dt_sw = depv_dt_sw / rho * 1.0e6 + else + depv_dt_sw = 0.0_RKIND + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! PBL diabatic tendency: depv_dt_bl + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (associated(dtheta_dt_pbl)) then + + ! (1) Calculate and reconstruct horizontal gradients of theta tendency + call calc_gradOnEdges_reconCellCenter(dtheta_dt_pbl, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dBLtend_dxZonal, & + dBLtend_dyMerid) + + ! (2) Calculate vertical gradient of theta tendency + call calc_vertDeriv(dtheta_dt_pbl, nCellsSolve, nVertLevels, zCell, dBLtend_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(dtheta_dt_pbl, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dBLtend_dz) + + ! (3) Combine into 3D theta tendency gradient vector + grad_diabatic_BL(:,:,1) = dBLtend_dxZonal + grad_diabatic_BL(:,:,2) = dBLtend_dyMerid + grad_diabatic_BL(:,:,3) = dBLtend_dz + + ! (4) Take dot product between 3D theta tendency vector and absolute vorticity / density + call calc_dotProduct_3D(grad_diabatic_BL, absVort3D, nCellsSolve, nVertLevels, depv_dt_bl) + + depv_dt_bl = depv_dt_bl / rho * 1.0e6 + else + depv_dt_bl = 0.0_RKIND + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Cumulus diabatic tendency: depv_dt_cu + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (associated(dtheta_dt_cu)) then + + ! (1) Calculate and reconstruct horizontal gradients of theta tendency + call calc_gradOnEdges_reconCellCenter(dtheta_dt_cu, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dCUtend_dxZonal, & + dCUtend_dyMerid) + + ! (2) Calculate vertical gradient of theta tendency + call calc_vertDeriv(dtheta_dt_cu, nCellsSolve, nVertLevels, zCell, dCUtend_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(dtheta_dt_cu, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dCUtend_dz) + + ! (3) Combine into 3D theta tendency gradient vector + grad_diabatic_CU(:,:,1) = dCUtend_dxZonal + grad_diabatic_CU(:,:,2) = dCUtend_dyMerid + grad_diabatic_CU(:,:,3) = dCUtend_dz + + ! (4) Take dot product between 3D theta tendency vector and absolute vorticity / density + call calc_dotProduct_3D(grad_diabatic_CU, absVort3D, nCellsSolve, nVertLevels, depv_dt_cu) + + depv_dt_cu = depv_dt_cu / rho * 1.0e6 + else + depv_dt_cu = 0.0_RKIND + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Microphysics diabatic tendency: depv_dt_mp + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (associated(dtheta_dt_mp)) then + + ! (1) Calculate and reconstruct horizontal gradients of theta tendency + call calc_gradOnEdges_reconCellCenter(dtheta_dt_mp, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dMPtend_dxZonal, & + dMPtend_dyMerid) + + ! (2) Calculate vertical gradient of theta tendency + call calc_vertDeriv(dtheta_dt_mp, nCellsSolve, nVertLevels, zCell, dMPtend_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(dtheta_dt_mp, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dMPtend_dz) + + ! (3) Combine into 3D theta tendency gradient vector + grad_diabatic_MP(:,:,1) = dMPtend_dxZonal + grad_diabatic_MP(:,:,2) = dMPtend_dyMerid + grad_diabatic_MP(:,:,3) = dMPtend_dz + + ! (4) Take dot product between 3D theta tendency vector and absolute vorticity / density + call calc_dotProduct_3D(grad_diabatic_MP, absVort3D, nCellsSolve, nVertLevels, depv_dt_mp) + + depv_dt_mp = depv_dt_mp / rho * 1.0e6 + else + depv_dt_mp = 0.0_RKIND + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Diabatic tendency from explicit mixing: depv_dt_mix + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (associated(dtheta_dt_mix)) then + + ! (1) Calculate and reconstruct horizontal gradients of theta tendency + call calc_gradOnEdges_reconCellCenter(dtheta_dt_mix, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dMXtend_dxZonal, & + dMXtend_dyMerid) + + ! (2) Calculate vertical gradient of theta tendency + call calc_vertDeriv(dtheta_dt_mix, nCellsSolve, nVertLevels, zCell, dMXtend_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(dtheta_dt_mix, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dMXtend_dz) + + ! (3) Combine into 3D theta tendency gradient vector + grad_diabatic_MX(:,:,1) = dMXtend_dxZonal + grad_diabatic_MX(:,:,2) = dMXtend_dyMerid + grad_diabatic_MX(:,:,3) = dMXtend_dz + + ! (4) Take dot product between 3D theta tendency vector and absolute vorticity / density + call calc_dotProduct_3D(grad_diabatic_MX, absVort3D, nCellsSolve, nVertLevels, depv_dt_mix) + + depv_dt_mix = depv_dt_mix / rho * 1.0e6 + else + depv_dt_mix = 0.0_RKIND + end if + + ! Sum of all diabatic contributions to PV through potential temperature tendencies + depv_dt_diab = depv_dt_mix + depv_dt_lw + depv_dt_sw + depv_dt_bl + depv_dt_cu + depv_dt_mp + + !*********************************************************************************************** + ! Calculate frictional tendency terms: + ! + ! Friction terms are essentially the vorticity tendency due to friction. Need to use the u, v, w + ! tendencies + !*********************************************************************************************** + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Frictional tendency from explicit mixing: depv_dt_fric_mix + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if ((associated(u_tend_diff)) .and. (associated(w_tend_diff))) then + + ! (1) Reconstruct u tendency from diffusion to cell center + call mpas_reconstruct(mesh, u_tend_diff, tenduX_mix, tenduY_mix, tenduZ_mix, & + tend_uZonal_mix, tend_uMerid_mix) + + ! (2) Calculate vertical derivative of tend_uZonal_mix, tend_uMerid_mix + call calc_vertDeriv(tend_uZonal_mix, nCellsSolve, nVertLevels, zCell, duZonalTend_dz_mix) + call calc_vertDeriv(tend_uMerid_mix, nCellsSolve, nVertLevels, zCell, duMeridTend_dz_mix) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(tend_uZonal_mix, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, duZonalTend_dz_mix) + ! call calc_vertDeriv_alt(tend_uMerid_mix, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, duMeridTend_dz_mix) + + ! (3) Interpolate w tendency from diffusion to cell center, calclulate gradient of tend_wCell_diff on edges, + ! and then reconstruct to get zonal and meridional gradients at cell center: + ! dWtend_dxZonal, dWtend_dyMerid + call interp_wLev_thetaLev(w_tend_diff, nCellsSolve, nVertLevels, tend_wCell_diff) + + call calc_gradOnEdges_reconCellCenter(tend_wCell_diff, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dWtend_dxZonal, dWtend_dyMerid) + + ! (4) Calculate vertical vorticity tendency on vertices and reconstruct to cell center + ! Note: the analogy of this procedure in the ertel_pv calculation is missing because vertical vorticity + ! is already computed and output in MPAS + call calc_vertical_curl(u_tend_diff, nEdges, nVertices, dcEdge, areaTriangle, verticesOnEdge, uTend_curl_diff) + + call interp_absVertVort(uTend_curl_diff, nCellsSolve, nEdgesOnCell, verticesOnCell, & + cellsOnVertex, areaCell, kiteAreasOnVertex, vertVortTend_mix) + + ! (5) Combine three components into vorticity tendency vector + vortTend3D_mix(:,:,1) = dWtend_dyMerid - duMeridTend_dz_mix ! dFz/dy - dFy/dz + vortTend3D_mix(:,:,2) = duZonalTend_dz_mix - dWtend_dxZonal ! dFx/dz - dFz/dx + vortTend3D_mix(:,:,3) = vertVortTend_mix ! dFy/dy - dFx/dx + + ! (6) Take dot product between 3D theta gradient and absolute vorticity tendency vector / density + call calc_dotProduct_3D(gradTheta, vortTend3D_mix, nCellsSolve, nVertLevels, depv_dt_fric_mix) + + depv_dt_fric_mix = depv_dt_fric_mix / rho * 1.0e6 + else + depv_dt_fric_mix = 0.0_RKIND + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Frictional tendency from PBL and GWD schemes: depv_dt_fric_bl + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (associated(tend_u_pbl)) then + + ! (1) Reconstruct u tendency from PBL to cell center + call mpas_reconstruct(mesh, tend_u_pbl, tenduX_pbl, tenduY_pbl, tenduZ_pbl, tend_uZonal_pbl, tend_uMerid_pbl) + + ! (2) Calculate vertical derivative of tend_uZonal_pbl, tend_uMerid_pbl + call calc_vertDeriv(tend_uZonal_pbl, nCellsSolve, nVertLevels, zCell, duZonalTend_dz_pbl) + call calc_vertDeriv(tend_uMerid_pbl, nCellsSolve, nVertLevels, zCell, duMeridTend_dz_pbl) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(tend_uZonal_pbl, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, duZonalTend_dz_pbl) + ! call calc_vertDeriv_alt(tend_uMerid_pbl, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, duMeridTend_dz_pbl) + + ! (3) Since w tendency from PBL scheme is zero, just set dWtend_dxZonal_phys, dWtend_dyMerid_phys = 0.0 (done above) + ! If model is ever updated to include a cumulus scheme that alters w, will need to modify this. + + ! (4) Calculate vertical vorticity tendency on vertices and reconstruct to cell center + ! Note: the analogy of this procedure in the ertel_pv calculation is missing because vertical vorticity + ! is already computed and output in MPAS + call calc_vertical_curl(tend_u_pbl, nEdges, nVertices, dcEdge, areaTriangle, verticesOnEdge, uTend_curl_pbl) + + call interp_absVertVort(uTend_curl_pbl, nCellsSolve, nEdgesOnCell, verticesOnCell, & + cellsOnVertex, areaCell, kiteAreasOnVertex, vertVortTend_pbl) + + ! (5) Combine three components into vorticity tendency vector + vortTend3D_pbl(:,:,1) = dWtend_dyMerid_phys - duMeridTend_dz_pbl ! dFz/dy - dFy/dz + vortTend3D_pbl(:,:,2) = duZonalTend_dz_pbl - dWtend_dxZonal_phys ! dFx/dz - dFz/dx + vortTend3D_pbl(:,:,3) = vertVortTend_pbl ! dFy/dy - dFx/dx + + ! (6) Take dot product between 3D theta gradient and absolute vorticity tendency vector / density + call calc_dotProduct_3D(gradTheta, vortTend3D_pbl, nCellsSolve, nVertLevels, depv_dt_fric_bl) + + depv_dt_fric_bl = depv_dt_fric_bl / rho * 1.0e6 + else + depv_dt_fric_bl = 0.0_RKIND + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Cumulus scheme + if (associated(tend_u_cu)) then + + ! (1) Reconstruct u tendency from cumulus to cell center and calculate vertical derivative of + ! tend_uZonal, tend_uMerid + call mpas_reconstruct(mesh, tend_u_cu, tenduX_cu, tenduY_cu, tenduZ_cu, tend_uZonal_cu, tend_uMerid_cu) + + ! (2) Calculate vertical derivative of tend_uZonal_pbl, tend_uMerid_pbl + call calc_vertDeriv(tend_uZonal_cu, nCellsSolve, nVertLevels, zCell, duZonalTend_dz_cu) + call calc_vertDeriv(tend_uMerid_cu, nCellsSolve, nVertLevels, zCell, duMeridTend_dz_cu) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(tend_uZonal_cu, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, duZonalTend_dz_cu) + ! call calc_vertDeriv_alt(tend_uMerid_cu, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, duMeridTend_dz_cu) + + ! (3) Since w tendency from PBL scheme is zero, just set dWtend_dxZonal_phys, dWtend_dyMerid_phys = 0.0 (done above) + ! If model is ever updated to include a cumulus scheme that alters w, will need to modify this. + + ! (4) Calculate vertical vorticity tendency on vertices and reconstruct to cell center + ! Note: the analogy of this procedure in the ertel_pv calculation is missing because vertical vorticity + ! is already computed and output in MPAS + call calc_vertical_curl(tend_u_cu, nEdges, nVertices, dcEdge, areaTriangle, verticesOnEdge, uTend_curl_cu) + + call interp_absVertVort(uTend_curl_cu, nCellsSolve, nEdgesOnCell, verticesOnCell, & + cellsOnVertex, areaCell, kiteAreasOnVertex, vertVortTend_cu) + + ! (5) Combine three components into vorticity tendency vector + vortTend3D_cu(:,:,1) = dWtend_dyMerid_phys - duMeridTend_dz_cu ! dFz/dy - dFy/dz + vortTend3D_cu(:,:,2) = duZonalTend_dz_cu - dWtend_dxZonal_phys ! dFx/dz - dFz/dx + vortTend3D_cu(:,:,3) = vertVortTend_cu ! dFy/dy - dFx/dx + + ! (6) Take dot product between 3D theta gradient and absolute vorticity tendency vector / density + call calc_dotProduct_3D(gradTheta, vortTend3D_cu, nCellsSolve, nVertLevels, depv_dt_fric_cu) + + depv_dt_fric_cu = depv_dt_fric_cu / rho * 1.0e6 + else + depv_dt_fric_cu = 0.0_RKIND + end if + + + ! Sum of all frictional contributions to PV through momentum tendencies + depv_dt_fric = depv_dt_fric_mix + depv_dt_fric_bl + depv_dt_fric_cu + + + !*********************************************************************************************** + ! Calculate dynamics tendency term : depv_dt_dyn + !*********************************************************************************************** + ! -------------------------------------------- + ! The theta gradient dynamics tendency piece + ! -------------------------------------------- + if (associated(dtheta_dt_dyn)) then + + ! (1) Calculate and reconstruct horizontal gradients of theta tendency + call calc_gradOnEdges_reconCellCenter(dtheta_dt_dyn, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dDYNtend_dxZonal, & + dDYNtend_dyMerid) + + ! (2) Calculate vertical gradient of theta tendency + call calc_vertDeriv(dtheta_dt_dyn, nCellsSolve, nVertLevels, zCell, dDYNtend_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(dtheta_dt_dyn, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dDYNtend_dz) + + ! (3) Combine into 3D theta tendency gradient vector + grad_DYN(:,:,1) = dDYNtend_dxZonal + grad_DYN(:,:,2) = dDYNtend_dyMerid + grad_DYN(:,:,3) = dDYNtend_dz + + ! (4) Take dot product between 3D theta tendency and absolute vorticity vector / density + call calc_dotProduct_3D(grad_DYN, absVort3D, nCellsSolve, nVertLevels, depv_dt_graddyn) + + depv_dt_graddyn = depv_dt_graddyn / rho * 1.0e6 + else + depv_dt_graddyn = 0.0_RKIND + end if + + ! -------------------------------------------- + ! The vorticity dynamics tendency piece + ! -------------------------------------------- + if (associated(du_dt_dyn)) then + + ! (1) Reconstruct du_dt_dyn to cell center and + call mpas_reconstruct(mesh, du_dt_dyn, tenduX_dyn, tenduY_dyn, tenduZ_dyn, tend_uZonal_dyn, tend_uMerid_dyn) + + ! (2) Calculate vertical derivative of tend_uZonal_dyn and tend_uMerid_dyn + call calc_vertDeriv(tend_uZonal_dyn, nCellsSolve, nVertLevels, zCell, duZonalTend_dz) + call calc_vertDeriv(tend_uMerid_dyn, nCellsSolve, nVertLevels, zCell, duMeridTend_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(tend_uZonal_dyn, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, duZonalTend_dz) + ! call calc_vertDeriv_alt(tend_uMerid_dyn, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, duMeridTend_dz) + + ! (3) Interpolate w tendency from dynamics to cell center, uncouple from density, calclulate gradient + ! of tend_wCell on edges, and then reconstruct to get zonal and meridional gradients at cell center: + ! dWtend_dxZonal, dWtend_dyMerid + ! + ! Note: NS's procedure interpolated density to w levels before uncoupling, but this method + ! is consistent with the procedure in the vorticity calculation + call interp_wLev_thetaLev(dw_dt_dyn, nCellsSolve, nVertLevels, tenddyn_wCell) + + call calc_gradOnEdges_reconCellCenter(tenddyn_wCell, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dWtend_dxZonal, dWtend_dyMerid) + + ! (4) Calculate vertical vorticity tendency on vertices and reconstruct to cell center + ! Note: the analogy of this procedure in the ertel_pv calculation is missing because vertical vorticity + ! is already computed and output in MPAS + call calc_vertical_curl(du_dt_dyn, nEdges, nVertices, dcEdge, areaTriangle, verticesOnEdge, uTend_curl_dyn) + + call interp_absVertVort(uTend_curl_dyn, nCellsSolve, nEdgesOnCell, verticesOnCell, & + cellsOnVertex, areaCell, kiteAreasOnVertex, vertVortTend_dyn) + + ! (5) Combine three components into vorticity tendency vector + vortTend3D_DYN(:,:,1)= dWtend_dyMerid - duMeridTend_dz ! dFz/dy - dFy/dz + vortTend3D_DYN(:,:,2)= duZonalTend_dz - dWtend_dxZonal ! dFx/dz - dFz/dx + vortTend3D_DYN(:,:,3)= vertVortTend_dyn ! dFy/dy - dFx/dx + + ! (6) Take dot product between 3D theta gradient and absolute vorticity tendency vector / density + call calc_dotProduct_3D(gradTheta, vortTend3D_DYN, nCellsSolve, nVertLevels, depv_dt_vortdyn) + + depv_dt_vortdyn = depv_dt_vortdyn / rho * 1.0e6 + else + depv_dt_vortdyn = 0.0_RKIND + end if + + ! -------------------------------------------- + ! The density tendency piece + ! -------------------------------------------- + + call calc_density_term(rho, rho_prev, ertel_pv_prev, nCellsSolve, nVertLevels, config_dt, drho_dt_term) + + ! -------------------------------------------- + ! Combine all pieces into full dynamics tendency + ! -------------------------------------------- + + depv_dt_dyn = depv_dt_graddyn + depv_dt_vortdyn - drho_dt_term + + ! -------------------------------------------------------------------------------------------------- + ! deallocate local static variables + deallocate(duZonal_dz) + deallocate(duMerid_dz) + deallocate(dTheta_dxZonal) + deallocate(dTheta_dyMerid) + deallocate(dTheta_dz) + deallocate(dW_dxZonal) + deallocate(dW_dyMerid) + deallocate(absVort) + deallocate(absVort3D) + deallocate(gradTheta) + + ! deallocate diabatic tendency variables + deallocate(dLWtend_dxZonal) + deallocate(dLWtend_dyMerid) + deallocate(dLWtend_dz) + deallocate(dSWtend_dxZonal) + deallocate(dSWtend_dyMerid) + deallocate(dSWtend_dz) + deallocate(dBLtend_dxZonal) + deallocate(dBLtend_dyMerid) + deallocate(dBLtend_dz) + deallocate(dCUtend_dxZonal) + deallocate(dCUtend_dyMerid) + deallocate(dCUtend_dz) + deallocate(dMPtend_dxZonal) + deallocate(dMPtend_dyMerid) + deallocate(dMPtend_dz) + deallocate(dMXtend_dxZonal) + deallocate(dMXtend_dyMerid) + deallocate(dMXtend_dz) + deallocate(grad_diabatic_LW) + deallocate(grad_diabatic_SW) + deallocate(grad_diabatic_BL) + deallocate(grad_diabatic_CU) + deallocate(grad_diabatic_MX) + deallocate(grad_diabatic_MP) + + ! deallocate friction tendency variables + ! mixing + deallocate(dWtend_dxZonal) + deallocate(dWtend_dyMerid) + deallocate(duZonalTend_dz_mix) + deallocate(duMeridTend_dz_mix) + deallocate(tend_uZonal_mix) + deallocate(tend_uMerid_mix) + deallocate(vertVortTend_mix) + deallocate(tenduX_mix) + deallocate(tenduY_mix) + deallocate(tenduZ_mix) + ! pbl + deallocate(duZonalTend_dz_pbl) + deallocate(duMeridTend_dz_pbl) + deallocate(vertVortTend_pbl) + deallocate(tenduX_pbl) + deallocate(tenduY_pbl) + deallocate(tenduZ_pbl) + deallocate(tend_uZonal_pbl) + deallocate(tend_uMerid_pbl) + !cumulus + deallocate(duZonalTend_dz_cu) + deallocate(duMeridTend_dz_cu) + deallocate(vertVortTend_cu) + deallocate(tenduX_cu) + deallocate(tenduY_cu) + deallocate(tenduZ_cu) + deallocate(tend_uZonal_cu) + deallocate(tend_uMerid_cu) + ! zeroed variables for w tendency from phys + deallocate(dWtend_dxZonal_phys) + deallocate(dWtend_dyMerid_phys) + ! 3D tendency vectors + deallocate(vortTend3D_mix) + deallocate(vortTend3D_pbl) + deallocate(vortTend3D_cu) + + ! deallocate dynamics tendency variables + deallocate(duZonalTend_dz) + deallocate(duMeridTend_dz) + deallocate(tend_uZonal_dyn) + deallocate(tend_uMerid_dyn) + deallocate(vertVortTend_dyn) + deallocate(tenduX_dyn) + deallocate(tenduY_dyn) + deallocate(tenduZ_dyn) + deallocate(vortTend3D_DYN) + deallocate(dDYNtend_dxZonal) + deallocate(dDYNtend_dyMerid) + deallocate(dDYNtend_dz) + deallocate(grad_DYN) + deallocate(depv_dt_graddyn) + deallocate(depv_dt_vortdyn) + deallocate(drho_dt_term) + + end subroutine calc_pvBudget + + + !********************************************************************************************************************* + ! MC: Modified subroutine to call variables at the correct time levels for PV tendency calculations and interpolate + ! fields to the DT identified at the beginning of the time step. Additionally, this subroutine now contains + ! calculations of the derived theta tendencies from physical processes and mixing from the corresponding tendencies + ! for theta_m and qv (if applicable), consistent with the discretized equations for these variables. Doing this + ! calculation rather than using the theta tendencies from the physics schemes directly enables us to close the + ! theta and PV budgets. + !********************************************************************************************************************* + + subroutine atm_compute_pvBudget_diagnostics(domain, configs, state, diag, mesh, tend, tend_physics, diag_physics, exchange_halo_group) + + use mpas_constants + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_config + use mpas_dmpar, only : mpas_dmpar_exch_halo_field + + implicit none + + type (domain_type), intent(inout) :: domain ! MC - new halo + type (mpas_pool_type), intent(in) :: configs + type (mpas_pool_type), intent(in) :: state, mesh, tend_physics, diag_physics + type (mpas_pool_type), intent(inout) :: diag, tend + procedure (halo_exchange_routine) :: exchange_halo_group ! MC - new halo + + logical, pointer :: config_pv_isobaric, config_pv_microphys + integer :: iCell, k + integer, pointer :: nCells, nVertLevels, index_qv + real (kind=RKIND) :: pvuVal, missingVal + + ! For calculating theta tendencies from theta_m tendencies + ! Note: this is more accurate than using theta tendencies directly from physics schemes, which + ! will lead to residuals in the theta and PV budgets owing to coupling between theta and qv via theta_m + real (kind=RKIND), dimension(:,:), pointer :: theta, qv_prev + real (kind=RKIND), dimension(:,:), pointer :: dthetam_dt_dyn, dtheta_dt_dyn, dqv_dt_dyn + real (kind=RKIND), dimension(:,:), pointer :: dthetam_dt_mix, dtheta_dt_mix + real (kind=RKIND), dimension(:,:), pointer :: thmblten, qvblten, dtheta_dt_pbl + real (kind=RKIND), dimension(:,:), pointer :: thmcuten, qvcuten, dtheta_dt_cu + real (kind=RKIND), dimension(:,:), pointer :: thmswten, dtheta_dt_sw, thmlwten, dtheta_dt_lw + real (kind=RKIND), dimension(:,:), pointer :: thmmpten, qvmpten, dtheta_dt_mp + + + ! ----------------------------------------------------------- + ! Calculate theta tendencies from theta_m tendencies + ! ----------------------------------------------------------- + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + ! Dynamics + call mpas_pool_get_array(diag, 'qv_prev', qv_prev) + call mpas_pool_get_array(diag, 'dqv_dt_dyn', dqv_dt_dyn) + call mpas_pool_get_array(diag, 'dthetam_dt_dyn', dthetam_dt_dyn) + call mpas_pool_get_array(diag, 'dtheta_dt_dyn', dtheta_dt_dyn) + + ! Horizontal mixing + call mpas_pool_get_array(diag, 'dthetam_dt_mix', dthetam_dt_mix) + call mpas_pool_get_array(diag, 'dtheta_dt_mix', dtheta_dt_mix) + + ! PBL heating + call mpas_pool_get_array(diag, 'thmblten', thmblten) + call mpas_pool_get_array(diag, 'qvblten', qvblten) + call mpas_pool_get_array(diag, 'theta', theta) + call mpas_pool_get_array(diag, 'dtheta_dt_pbl', dtheta_dt_pbl) + + ! cumulus heating + call mpas_pool_get_array(diag, 'thmcuten', thmcuten) + call mpas_pool_get_array(diag, 'qvcuten', qvcuten) + call mpas_pool_get_array(diag, 'dtheta_dt_cu', dtheta_dt_cu) + + ! radiation + call mpas_pool_get_array(diag, 'thmswten', thmswten) + call mpas_pool_get_array(diag, 'thmlwten', thmlwten) + call mpas_pool_get_array(diag, 'dtheta_dt_sw', dtheta_dt_sw) + call mpas_pool_get_array(diag, 'dtheta_dt_lw', dtheta_dt_lw) + + ! microphysics + call mpas_pool_get_array(diag, 'dtheta_dt_mp', dtheta_dt_mp) + call mpas_pool_get_array(diag, 'qvmpten', qvmpten) + call mpas_pool_get_array(diag, 'thmmpten', thmmpten) + + dtheta_dt_dyn(:,:) = 0.0_RKIND + dtheta_dt_mix(:,:) = 0.0_RKIND + dtheta_dt_pbl(:,:) = 0.0_RKIND + dtheta_dt_cu(:,:) = 0.0_RKIND + dtheta_dt_lw(:,:) = 0.0_RKIND + dtheta_dt_sw(:,:) = 0.0_RKIND + dtheta_dt_mp(:,:) = 0.0_RKIND + + + ! MC: Modified the diabatic tendency terms used in the PV diagnostics tendency calculations, which are derived here from the theta_m + ! diabatic process tendencies. These modifications are necessary to conserve theta and PV + do iCell = 1,nCells + do k = 1,nVertLevels + ! processes that also modify qv + dtheta_dt_dyn(k,iCell) = (dthetam_dt_dyn(k,iCell) - rvord*theta(k,iCell)*dqv_dt_dyn(k,iCell)) / (1._RKIND + rvord*qv_prev(k,iCell)) + dtheta_dt_pbl(k,iCell) = (thmblten(k,iCell) - rvord*theta(k,iCell)*qvblten(k,iCell)) / (1._RKIND + rvord*qv_prev(k,iCell)) + dtheta_dt_cu(k,iCell) = (thmcuten(k,iCell) - rvord*theta(k,iCell)*qvcuten(k,iCell)) / (1._RKIND + rvord*qv_prev(k,iCell)) + dtheta_dt_mp(k,iCell) = (thmmpten(k,iCell) - rvord*theta(k,iCell)*qvmpten(k,iCell)) / (1._RKIND + rvord*qv_prev(k,iCell)) + + ! processes that do not modify qv + dtheta_dt_mix(k,iCell) = dthetam_dt_mix(k,iCell) / (1._RKIND + rvord * qv_prev(k,iCell)) + dtheta_dt_lw(k,iCell) = thmlwten(k,iCell) / (1._RKIND + rvord * qv_prev(k,iCell)) + dtheta_dt_sw(k,iCell) = thmswten(k,iCell) / (1._RKIND + rvord * qv_prev(k,iCell)) + end do + end do + + + ! ----------------------------------------------------------- + ! Do halo communication + ! ----------------------------------------------------------- + + ! Previous timestep variables + call exchange_halo_group(domain, 'diagnostics:dpv_prev') + + ! Potential temperature tendencies + call exchange_halo_group(domain, 'diagnostics:dpv_th_tend') + + ! Momentum tendencies and curls + call exchange_halo_group(domain, 'diagnostics:dpv_mom_tend') + call exchange_halo_group(domain, 'diagnostics:dpv_mom_curl') + + + ! ----------------------------------------------------------- + ! Call subroutines: + ! ----------------------------------------------------------- + + ! Calculating PV budget: + call mpas_log_write("Calling calc_pvBudget:") + call calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_physics) + + ! Interpolate fields to DT: + pvuVal = 2.0_RKIND + missingVal = -99999.0_RKIND + + call mpas_log_write("Calling interp_pvBudget_diagnostics") + call interp_pvBudget_diagnostics(mesh, diag, pvuVal, missingVal) + + ! Accumulate tendencies over multiple time steps: + call mpas_log_write("Calling acc_pvBudget:") + call acc_pvBudget(mesh, diag, tend_physics) + + end subroutine atm_compute_pvBudget_diagnostics + + + !********************************************************************************************************************* + ! MW: Adding a subroutine to accumulate the PV budget tendency terms at each time step. Accumulated values are output + ! at the user-specific diagnostic output interval, which determines the time-averaging window of the tendencies. + !********************************************************************************************************************* + + subroutine acc_pvBudget(mesh, diag, tend_physics) + + use mpas_vector_reconstruction + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array + use mpas_pool_routines, only: mpas_pool_get_config + + implicit none + + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(in) :: tend_physics + + logical, pointer :: config_pv_tend + + integer, pointer :: nCells, nVertLevels + integer :: iCell, k + + ! Instantaneous and accumulated PV tendencies + real(kind=RKIND), dimension(:,:), pointer :: depv_dt_lw, depv_dt_sw, depv_dt_bl, depv_dt_cu, depv_dt_mp, depv_dt_mix + real(kind=RKIND), dimension(:,:), pointer :: acc_depv_dt_lw, acc_depv_dt_sw, acc_depv_dt_bl, acc_depv_dt_cu, acc_depv_dt_mp, acc_depv_dt_mix + real(kind=RKIND), dimension(:,:), pointer :: depv_dt_fric_mix, depv_dt_fric_bl, depv_dt_fric_cu + real(kind=RKIND), dimension(:,:), pointer :: acc_depv_dt_fric_mix, acc_depv_dt_fric_bl, acc_depv_dt_fric_cu + real(kind=RKIND), dimension(:,:), pointer :: depv_dt_diab, depv_dt_fric, depv_dt_dyn + real(kind=RKIND), dimension(:,:), pointer :: acc_depv_dt_diab, acc_depv_dt_fric, acc_depv_dt_dyn + real(kind=RKIND), dimension(:), pointer :: depv_dt_diab_pv, depv_dt_fric_pv, depv_dt_dyn_pv + real(kind=RKIND), dimension(:), pointer :: acc_depv_dt_diab_pv, acc_depv_dt_fric_pv, acc_depv_dt_dyn_pv + + ! Latent heating tendencies + real(kind=RKIND), dimension(:,:), pointer :: dtheta_dt_cu, dtheta_dt_mp + real(kind=RKIND), dimension(:,:), pointer :: acc_dtheta_dt_cu, acc_dtheta_dt_mp + + call mpas_pool_get_config(configs, 'config_pv_tend', config_pv_tend) + + ! Instantaneous and accumulated PV tendencies + call mpas_pool_get_array(diag, 'depv_dt_lw', depv_dt_lw) + call mpas_pool_get_array(diag, 'depv_dt_sw', depv_dt_sw) + call mpas_pool_get_array(diag, 'depv_dt_bl', depv_dt_bl) + call mpas_pool_get_array(diag, 'depv_dt_cu', depv_dt_cu) + call mpas_pool_get_array(diag, 'depv_dt_mp', depv_dt_mp) + call mpas_pool_get_array(diag, 'depv_dt_mix', depv_dt_mix) + call mpas_pool_get_array(diag, 'depv_dt_fric_mix', depv_dt_fric_mix) + call mpas_pool_get_array(diag, 'depv_dt_fric_bl', depv_dt_fric_bl) + call mpas_pool_get_array(diag, 'depv_dt_fric_cu', depv_dt_fric_cu) + call mpas_pool_get_array(diag, 'depv_dt_diab', depv_dt_diab) + call mpas_pool_get_array(diag, 'depv_dt_fric', depv_dt_fric) + call mpas_pool_get_array(diag, 'depv_dt_dyn', depv_dt_dyn) + call mpas_pool_get_array(diag, 'depv_dt_diab_pv', depv_dt_diab_pv) + call mpas_pool_get_array(diag, 'depv_dt_fric_pv', depv_dt_fric_pv) + call mpas_pool_get_array(diag, 'depv_dt_dyn_pv', depv_dt_dyn_pv) + + call mpas_pool_get_array(diag, 'acc_depv_dt_lw', acc_depv_dt_lw) + call mpas_pool_get_array(diag, 'acc_depv_dt_sw', acc_depv_dt_sw) + call mpas_pool_get_array(diag, 'acc_depv_dt_bl', acc_depv_dt_bl) + call mpas_pool_get_array(diag, 'acc_depv_dt_cu', acc_depv_dt_cu) + call mpas_pool_get_array(diag, 'acc_depv_dt_mp', acc_depv_dt_mp) + call mpas_pool_get_array(diag, 'acc_depv_dt_mix', acc_depv_dt_mix) + call mpas_pool_get_array(diag, 'acc_depv_dt_diab', acc_depv_dt_diab) + call mpas_pool_get_array(diag, 'acc_depv_dt_fric_mix', acc_depv_dt_fric_mix) + call mpas_pool_get_array(diag, 'acc_depv_dt_fric_bl', acc_depv_dt_fric_bl) + call mpas_pool_get_array(diag, 'acc_depv_dt_fric_cu', acc_depv_dt_fric_cu) + call mpas_pool_get_array(diag, 'acc_depv_dt_fric', acc_depv_dt_fric) + call mpas_pool_get_array(diag, 'acc_depv_dt_dyn', acc_depv_dt_dyn) + call mpas_pool_get_array(diag, 'acc_depv_dt_diab_pv', acc_depv_dt_diab_pv) + call mpas_pool_get_array(diag, 'acc_depv_dt_fric_pv', acc_depv_dt_fric_pv) + call mpas_pool_get_array(diag, 'acc_depv_dt_dyn_pv', acc_depv_dt_dyn_pv) + + ! Latent heating tendencies + call mpas_pool_get_array(diag, 'dtheta_dt_cu', dtheta_dt_cu) + call mpas_pool_get_array(diag, 'dtheta_dt_mp', dtheta_dt_mp) + + call mpas_pool_get_array(diag, 'acc_dtheta_dt_cu', acc_dtheta_dt_cu) + call mpas_pool_get_array(diag, 'acc_dtheta_dt_mp', acc_dtheta_dt_mp) + + ! Accumulate tendencies + acc_depv_dt_lw(:,:) = acc_depv_dt_lw(:,:) + depv_dt_lw(:,:) + acc_depv_dt_sw(:,:) = acc_depv_dt_sw(:,:) + depv_dt_sw(:,:) + acc_depv_dt_bl(:,:) = acc_depv_dt_bl(:,:) + depv_dt_bl(:,:) + acc_depv_dt_cu(:,:) = acc_depv_dt_cu(:,:) + depv_dt_cu(:,:) + acc_depv_dt_mp(:,:) = acc_depv_dt_mp(:,:) + depv_dt_mp(:,:) + acc_depv_dt_mix(:,:) = acc_depv_dt_mix(:,:) + depv_dt_mix(:,:) + acc_depv_dt_fric_bl(:,:) = acc_depv_dt_fric_bl(:,:) + depv_dt_fric_bl(:,:) + acc_depv_dt_fric_cu(:,:) = acc_depv_dt_fric_cu(:,:) + depv_dt_fric_cu(:,:) + acc_depv_dt_fric_mix(:,:) = acc_depv_dt_fric_mix(:,:) + depv_dt_fric_mix(:,:) + acc_depv_dt_diab(:,:) = acc_depv_dt_diab(:,:) + depv_dt_diab(:,:) + acc_depv_dt_fric(:,:) = acc_depv_dt_fric(:,:) + depv_dt_fric(:,:) + acc_depv_dt_dyn(:,:) = acc_depv_dt_dyn(:,:) + depv_dt_dyn(:,:) + acc_depv_dt_diab_pv(:) = acc_depv_dt_diab_pv(:) + depv_dt_diab_pv(:) + acc_depv_dt_fric_pv(:) = acc_depv_dt_fric_pv(:) + depv_dt_fric_pv(:) + acc_depv_dt_dyn_pv(:) = acc_depv_dt_dyn_pv(:) + depv_dt_dyn_pv(:) + + ! Accumulate heating tendencies from microphysics and cumulus schemes + if (associated(dtheta_dt_mp)) then + acc_dtheta_dt_mp(:,:) = acc_dtheta_dt_mp(:,:) + dtheta_dt_mp(:,:) + end if + + if (associated(dtheta_dt_cu)) then + acc_dtheta_dt_cu(:,:) = acc_dtheta_dt_cu(:,:) + dtheta_dt_cu(:,:) + end if + + end subroutine acc_pvBudget + !================================================================================================================= end module mpas_pv_diagnostics diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 8ba48bd4b1..d0e0d37d68 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -523,8 +523,8 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) type (field2DReal), pointer :: tend_ru_physicsField, tend_rtheta_physicsField, tend_rho_physicsField #endif - ! MW for ITM - logical, pointer :: config_tend + ! For ITM and PV tendency diagnostics + logical, pointer :: config_tend, config_pv_tend real (kind=RKIND), dimension(:,:), pointer :: acc_u_tend_dyn_small, acc_u_tend_dyn_small_ReconstructZonal, & acc_u_tend_dyn_small_ReconstructMeridional, & acc_u_tend_dyn_small_ReconstructX, acc_u_tend_dyn_small_ReconstructY, & @@ -555,7 +555,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_pool_get_config(block % configs, 'config_convection_scheme', config_convection_scheme) #endif call mpas_pool_get_config(block % configs, 'config_tend', config_tend) ! MW: for tendency diagnostics - + call mpas_pool_get_config(block % configs, 'config_pv_tend', config_pv_tend) ! MC: for PV tendency diagnostics ! ! Retrieve field structures @@ -1389,9 +1389,14 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call mpas_timer_start('Tendency and PV diagnostics') call mpas_pool_get_array(diag, 'acc_qv_tend_dyn_large', acc_qv_tend_dyn_large) acc_qv_tend_dyn_large(:,:) = acc_qv_tend_dyn_large(:,:) + ( scalars_2(index_qv,:,:) - scalars_1(index_qv,:,:) ) / config_dt - - call mpas_timer_stop('Tendency and PV diagnostics') + if ( config_pv_tend ) then + call mpas_pool_get_array(diag, 'dqv_dt_dyn', dqv_dt_dyn) + dqv_dt_dyn(:,:) = 0.0 + dqv_dt_dyn(:,:) = ( scalars_2(index_qv,:,:) - scalars_1(index_qv,:,:) ) / config_dt ! MW: added for PV + end if + + call mpas_timer_stop('Tendency and PV diagnostics') endif !----- @@ -5190,6 +5195,9 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & + rho_edge(k,iEdge)* kdiffu * u_diffusion * meshScalingDel2(iEdge) + if (config_tend) then + ru_tend_diff(k,iEdge) = rho_edge(k,iEdge)* kdiffu * u_diffusion * meshScalingDel2(iEdge) ! MW + end if end do end do @@ -5580,6 +5588,13 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm do iCell = cellSolveStart,cellSolveEnd !DIR$ IVDEP do k=2,nVertLevels + + ! MW added for PV tendencies + if ( rk_step == 3 .and. config_pv_tend ) then + rw_tend_dyn_large(k,iCell) = dt_rk*(tend_w(k,iCell) + tend_w_euler(k,iCell) - rw_tend_diff(k,iCell)) + rw_tend_diff(k,iCell) = dt_rk*rw_tend_diff(k,iCell) + end if + tend_w(k,iCell) = tend_w(k,iCell) + tend_w_euler(k,iCell) end do end do @@ -7693,6 +7708,7 @@ subroutine atm_accumulate_tend_work(nCells, nEdges, nCellsSolve, cellStart, cell u_tend_diff(k,iEdge) = 0.0 tend_u_pbl(k,iEdge) = 0.0 ! MC added MC_TODO: check if these are needed here... tend_u_cu(k,iEdge) = 0.0 ! MC added + du_dt_dyn(k,iEdge) = 0.0 ! MC initializing this here instead of in PV code enddo end if end do diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index 7127a5984d..17f24ef60d 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -624,7 +624,9 @@ function atm_core_run(domain) result(ierr) real (kind=R8KIND) :: diag_start_time, diag_stop_time real (kind=R8KIND) :: input_start_time, input_stop_time real (kind=R8KIND) :: output_start_time, output_stop_time - + + ! MC: Adding config flags for PV tendencies to enable model diags to be calculated at each time step + logical, pointer :: config_pv_tend ierr = 0 clock => domain % clock @@ -808,8 +810,17 @@ function atm_core_run(domain) result(ierr) ! Write any output streams that have alarms ringing, after computing diagnostics fields ! call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr) - if (MPAS_stream_mgr_ringing_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=ierr)) then + + ! MC: adding PV tendency config flag here to ensure that theta and rho are updated every time step for + ! computing the PV tendencies + call mpas_pool_get_config(domain % blocklist % configs, 'config_pv_tend', config_pv_tend) + call mpas_log_write(' ') + call mpas_log_write('config_pv_tend is $l', logicArgs=(/config_pv_tend/)) + + if (config_pv_tend .or. (MPAS_stream_mgr_ringing_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=ierr))) then block_ptr => domain % blocklist + call mpas_log_write('Calling output diagnostic calculations') + call mpas_log_write(' ') do while (associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'state', state) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index 29b540da7e..0f1e510792 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -64,7 +64,9 @@ 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. - +! * Manda Chasteen / 2024-05-28 -- added calculations for ITM initial tendency package +! * Manda Chasteen / 2024-05-31 -- removed dtheta_dt_mp calculation for PV diagnostics; added calculations of +! thmmpten and qvmpten contains @@ -564,7 +566,7 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, real(kind=RKIND),dimension(:,:),pointer :: rncmpten,rnimpten,rnrmpten,rnifampten,rnwfampten real(kind=RKIND),dimension(:,:,:),pointer:: scalars -! MW added for ITM +! MW: for ITM package logical, pointer :: config_tend real(kind=RKIND), dimension(:,:), pointer :: qv_mp_tend @@ -594,10 +596,10 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, qc => scalars(index_qc,:,:) qr => scalars(index_qr,:,:) -! MW on ITM -- MC added +! MW on ITM call mpas_pool_get_config(configs, 'config_tend', config_tend) - if (config_tend) then ! MC added! + if (config_tend) then call mpas_pool_get_array(diag, 'qv_mp_tend', qv_mp_tend) end if @@ -619,7 +621,7 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, dz_p(i,k,j) = zgrid(k+1,i) - zgrid(k,i) w_p(i,k,j) = w(k,i) - ! MW on ITM -- MC added + ! MW on ITM if (config_tend) then qv_mp_tend(k,i) = qv(k,i) ! save qv before call to microphysics endif @@ -804,7 +806,6 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te real(kind=RKIND),dimension(:,:),pointer :: zz,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 :: rt_diabatic_tend - real(kind=RKIND),dimension(:,:),pointer :: dtheta_dt_mp ! MC note: this eventually should be removed real(kind=RKIND),dimension(:,:),pointer :: qv,qc,qr,qi,qs,qg real(kind=RKIND),dimension(:,:),pointer :: nc,ni,nr,nifa,nwfa real(kind=RKIND),dimension(:,:),pointer :: rainprod,evapprod @@ -813,11 +814,15 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te real(kind=RKIND),dimension(:,:),pointer :: rncmpten,rnimpten,rnrmpten,rnifampten,rnwfampten real(kind=RKIND),dimension(:,:,:),pointer:: scalars -! MW on ITM: accumulating theta diabatic tendency term MC added - logical, pointer :: config_tend, config_pv_tend +! MW on ITM: accumulating theta diabatic tendency term + logical, pointer :: config_tend real(kind=RKIND),dimension(:,:),pointer :: acc_th_tend_diabatic real(kind=RKIND),dimension(:,:),pointer :: qv_mp_tend, acc_qv_mp_tend +! MC - for PV tendencies + logical, pointer :: config_pv_tend + real(kind=RKIND), dimension(:,:), pointer :: thmmpten, qvmpten + !local variables: integer:: icount integer:: i,k,j @@ -837,7 +842,6 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te 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(diag,'surface_pressure',surface_pressure) - call mpas_pool_get_array(diag,'dtheta_dt_mp' ,dtheta_dt_mp ) call mpas_pool_get_array(tend,'tend_sfc_pressure',tend_sfc_pressure) @@ -854,7 +858,7 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te call mpas_pool_get_array(tend,'rt_diabatic_tend',rt_diabatic_tend) -! MW on ITM MC ADDED +! MW on ITM call mpas_pool_get_config(configs, 'config_tend', config_tend) if (config_tend) then @@ -867,13 +871,15 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te allocate(acc_qv_mp_tend, MOLD=rt_diabatic_tend) end if - ! MC -- adding config here so code won't break before other mods; dtheta_dt_mp will be removed from this section eventually +! MC adding for PV microphysics tendency call mpas_pool_get_config(configs, 'config_pv_tend', config_pv_tend) if (config_pv_tend) then - call mpas_pool_get_array(diag,'dtheta_dt_mp', dtheta_dt_mp) ! MC note -- this eventually should be removed - else - allocate(dtheta_dt_mp, MOLD=rt_diabatic_tend) + call mpas_pool_get_array(diag,'thmmpten', thmmpten) + call mpas_pool_get_array(diag,'qvmpten',qvmpten) + + thmmpten(:,:) = 0.0 + qvmpten(:,:) = 0.0 end if @@ -882,12 +888,8 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te do k = kts,kte do i = its,ite - !initializes tendency of coupled potential temperature potential temperature, and - !potential temperature heating rate from microphysics: + !initializes tendency of coupled potential temperature heating rate from microphysics: rt_diabatic_tend(k,i) = theta_m(k,i) - dtheta_dt_mp(k,i) = theta_m(k,i)/(1._RKIND+rvord*qv(k,i)) ! MC note -- this was changed in my code and ultimately removed; - ! should eventually be removed - !updates water vapor, cloud liquid water, rain mixing ratios, modified potential temperature, !tendency of coupled potential temperature, and potential temperature heating rate from microphysics: @@ -897,8 +899,6 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te theta_m(k,i) = th_p(i,k,j) * (1._RKIND+rvord*qv_p(i,k,j)) rt_diabatic_tend(k,i) = (theta_m(k,i) - rt_diabatic_tend(k,i))/dt_dyn - dtheta_dt_mp(k,i) = (theta_m(k,i)/(1._RKIND+rvord*qv(k,i))-dtheta_dt_mp(k,i))/(dt_dyn) ! MC note -- this was changed in my code and ultimately removed; - ! should eventually be removed !density-weighted perturbation potential temperature: rtheta_p(k,i) = rho_zz(k,i) * theta_m(k,i) - rtheta_b(k,i) @@ -917,6 +917,12 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te acc_qv_mp_tend(k,i) = acc_qv_mp_tend(k,i) + ( qv(k,i) - qv_mp_tend(k,i))/dt_dyn end if + ! MC: for PV + if (config_pv_tend) then + thmmpten(k,i) = rt_diabatic_tend(k,i) + qvmpten(k,i) = (qv(k,i) - qv_mp_tend(k,i))/dt_dyn + end if + enddo enddo enddo @@ -1085,12 +1091,6 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te deallocate(acc_qv_mp_tend) end if -! MC adding for now - if (.not. config_pv_tend) then - deallocate(dtheta_dt_mp) - end if - - end subroutine microphysics_to_MPAS !================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index 7476f850a4..eabe48c2a9 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -59,6 +59,8 @@ module mpas_atmphys_todynamics ! Laura D. Fowler (laura@ucar.edu) / 2024-05-16. ! * Added support for initial tendency diagnostics package variables and timers ! May Wong (mwong@ucar.edu) and Manda Chasteen (chasteen@ucar.edu) / 2024-05-29 +! * Removed tend_u_phys calculation since it's no longer needed for PV tendency calculations +! Manda Chasteen (chasteen@ucar.edu) / 2024-05-31 ! ! Abstract interface for routine used to communicate halos of fields @@ -125,7 +127,7 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, diag_ real(kind=RKIND),dimension(:,:),pointer:: rthblten,rqvblten,rqcblten, & rqiblten,rqsblten,rublten,rvblten real(kind=RKIND),dimension(:,:),pointer:: rncblten,rniblten,rnifablten,rnwfablten - real(kind=RKIND),dimension(:,:),pointer:: rubldiff, rvbldiff ! MW on ITM: GWDO; MC added + real(kind=RKIND),dimension(:,:),pointer:: rubldiff, rvbldiff ! MW on ITM: GWDO real(kind=RKIND),dimension(:,:),pointer:: rthcuten,rqvcuten,rqccuten, & rqrcuten,rqicuten,rqscuten, & @@ -138,9 +140,6 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, diag_ real(kind=RKIND),dimension(:,:),allocatable:: tend_th -! MC: will no longer be needed for PV and removed in subsequent commit - real(kind=RKIND),dimension(:,:),pointer:: tend_u_phys - ! MW: for ITM real(kind=RKIND),dimension(:,:),pointer:: rucuten_tend, rublten_tend, rugwdo_tend real(kind=RKIND),dimension(:,:),pointer:: rthcuten_tend, rthblten_tend, rthratenlw_tend, rthratensw_tend @@ -159,15 +158,13 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, diag_ 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_gwdo_scheme' ,gwdo_scheme ) ! MW on ITM: GWDO - call mpas_pool_get_config(configs,'config_tend', config_tend) ! MC: for tendency diagnostics + call mpas_pool_get_config(configs,'config_tend' ,config_tend ) ! MC: for tendency diagnostics 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) ! MC - for PV; will be removed in subsequent commits - 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_qr',index_qr) @@ -230,9 +227,6 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, diag_ tend_ru_physics(:,:) = 0._RKIND tend_rtheta_physics(:,:) = 0._RKIND tend_rho_physics(:,:) = 0._RKIND - - tend_u_phys(:,:) = 0._RKIND ! MC: this fix was needed because tend_u_phys and tend_u_diff accumulate in PV code; - ! will no longer be necessary once this var is removed ! ! 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 @@ -288,11 +282,9 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, diag_ qvblten_tend, qvcuten_tend, & ! tend_th, tend_rtheta_physics, tend_scalars, tend_ru_physics, & - tend_u_phys, & ! MC - will be removed exchange_halo_group) - !clean up any pointers that were allocated with zero size before the call to physics_get_tend_work: if(size(rucuten) == 0 ) deallocate(rucuten ) if(size(rvcuten) == 0 ) deallocate(rvcuten ) @@ -351,7 +343,6 @@ subroutine physics_get_tend_work( & qvblten_tend, qvcuten_tend, & ! tend_th, tend_theta, tend_scalars, tend_u, & - tend_u_phys, & ! MC - will be removed exchange_halo_group) !================================================================================================================= !input arguments: @@ -410,8 +401,6 @@ subroutine physics_get_tend_work( & real(kind=RKIND),intent(inout),dimension(nVertLevels,nCells+1):: tend_theta real(kind=RKIND),intent(inout),dimension(num_scalars,nVertLevels,nCells+1):: tend_scalars -! For diagnostics packages - real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: tend_u_phys ! MC - eventually remove ! MW on ITM real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rubldiff @@ -450,7 +439,6 @@ subroutine physics_get_tend_work( & rugwdo_tend(k,i) = rubldiff_Edge(k,i)*mass_edge(k,i) end do end do - end if call mpas_timer_stop('Tendency and PV diagnostics') ! end GWDO @@ -461,8 +449,6 @@ subroutine physics_get_tend_work( & if (rk_step == 1 .and. dynamics_substep == 1) then call exchange_halo_group(block%domain,'physics:blten') call tend_toEdges(block,mesh,rublten,rvblten,rublten_Edge) - - tend_u_phys(1:nVertLevels,1:nEdges) = rublten_Edge(1:nVertLevels,1:nEdges) ! MC -- will be removed end if do i = 1, nEdgesSolve @@ -479,7 +465,6 @@ subroutine physics_get_tend_work( & tend_scalars(index_qc,k,i) = tend_scalars(index_qc,k,i) + rqcblten(k,i)*mass(k,i) tend_scalars(index_qi,k,i) = tend_scalars(index_qi,k,i) + rqiblten(k,i)*mass(k,i) - rthblten_tend(k,i) = rthblten(k,i)*mass(k,i) ! MW on ITM qvblten_tend(k,i) = rqvblten(k,i) ! MW on ITM; decoupled using mass at time t in advance_scalar_mono enddo @@ -529,14 +514,11 @@ subroutine physics_get_tend_work( & if(rk_step == 1 .and. dynamics_substep == 1) then call exchange_halo_group(block%domain,'physics:cuten') call tend_toEdges(block,mesh,rucuten,rvcuten,rucuten_Edge) - - tend_u_phys(1:nVertLevels,1:nEdges) = tend_u_phys(1:nVertLevels,1:nEdges) & ! MC -- will be removed - + rucuten_Edge(1:nVertLevels,1:nEdges) endif do i = 1, nEdgesSolve do k = 1, nVertLevels tend_u(k,i) = tend_u(k,i) + rucuten_Edge(k,i)*mass_edge(k,i) - rucuten_tend(k,i) = rucuten_Edge(k,i)*mass_edge(k,i) ! MW on ITM + rucuten_tend(k,i) = rucuten_Edge(k,i)*mass_edge(k,i) ! MW on ITM enddo enddo From 6eb006de26151cb85b1a943eaf9af98f68d595b5 Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Tue, 9 Jul 2024 16:22:02 -0600 Subject: [PATCH 09/23] Remove tend_u_phys from Registry_pv.xml - This commit removes tend_u_phys from Registry_pv.xml. This variable is no longer used to compute the frictional PV tendency. --- src/core_atmosphere/diagnostics/Registry_pv.xml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/core_atmosphere/diagnostics/Registry_pv.xml b/src/core_atmosphere/diagnostics/Registry_pv.xml index e42292a023..bc720a0927 100644 --- a/src/core_atmosphere/diagnostics/Registry_pv.xml +++ b/src/core_atmosphere/diagnostics/Registry_pv.xml @@ -420,9 +420,5 @@ packages="pv_diagnostics"/> - - - From bc2357c698bf1591ac89f313671f8cd0f88f3f21 Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Tue, 9 Jul 2024 16:22:24 -0600 Subject: [PATCH 10/23] Prevent writing pvbudget stream on restart --- src/core_atmosphere/mpas_atm_core.F | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index 17f24ef60d..83570922c3 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -641,9 +641,11 @@ function atm_core_run(domain) result(ierr) call MPAS_stream_mgr_reset_alarms(domain % streamManager, streamID='restart', direction=MPAS_STREAM_OUTPUT, ierr=ierr) ! Also, for restart runs, avoid writing the initial history or diagnostics fields to avoid overwriting those from the preceding run + ! MC: added pvbudget stream here if (config_do_restart) then call MPAS_stream_mgr_reset_alarms(domain % streamManager, streamID='output', direction=MPAS_STREAM_OUTPUT, ierr=ierr) call MPAS_stream_mgr_reset_alarms(domain % streamManager, streamID='diagnostics', direction=MPAS_STREAM_OUTPUT, ierr=ierr) + call MPAS_stream_mgr_reset_alarms(domain % streamManager, streamID='pvbudget', direction=MPAS_STREAM_OUTPUT, ierr=ierr) end if call mpas_dmpar_get_time(diag_start_time) @@ -667,7 +669,7 @@ function atm_core_run(domain) result(ierr) !call mpas_atm_diag_update() call mpas_atm_diag_update(domain, exchange_halo_group) ! MC -- modified with halo inputs !call mpas_atm_diag_compute() - call mpas_atm_diag_compute(domain, exchange_halo_group) ! MC -- modified with halo inputs + call mpas_atm_diag_compute(domain, exchange_halo_group) ! MC -- modified with halo inputs call mpas_timer_stop('diagnostic_fields') call mpas_dmpar_get_time(diag_stop_time) From a32423c23de8cd43abe1f18a7b0739016e372570 Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Tue, 9 Jul 2024 16:22:47 -0600 Subject: [PATCH 11/23] Add pvbudget stream to defaults in Registry.xml - Removed PV diagnostics variables from preexisting history output stream and created default pvbudget stream containing relevant variables --- src/core_atmosphere/Registry.xml | 80 ++++++++++++++++++++++++-------- 1 file changed, 60 insertions(+), 20 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index d92bb38c2f..d083da6650 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -918,27 +918,7 @@ - - - - - - - #ifdef DO_PHYSICS - - - - - - - - - - - - - @@ -980,6 +960,66 @@ #endif + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Date: Tue, 9 Jul 2024 16:23:16 -0600 Subject: [PATCH 12/23] Disable PV tend calcs at init; housekeeping items - Added pv_callCounter to Registry_pv.xml - Added pv_callCounter tracking in mpas_pv_diagnostics.F to activate calculations of PV tendencies during runtime, not at model initialization. This is really only relevant for when the model is restarted and the derived parent tendencies used in the PV tendency calculations are inaccurate because (1) they are not included in restart streams and (2) mpas_atm_time_integration.F hasn't been called. This prevents the inaccurate tendencies from being included in the accumulated PV tendency variables - Removed declaration of _dyn variables from mpas_atm_time_integration.F --- .../diagnostics/Registry_pv.xml | 10 +++++++ .../diagnostics/mpas_pv_diagnostics.F | 30 ++++++++++++++++--- .../dynamics/mpas_atm_time_integration.F | 3 -- 3 files changed, 36 insertions(+), 7 deletions(-) diff --git a/src/core_atmosphere/diagnostics/Registry_pv.xml b/src/core_atmosphere/diagnostics/Registry_pv.xml index bc720a0927..dec2070300 100644 --- a/src/core_atmosphere/diagnostics/Registry_pv.xml +++ b/src/core_atmosphere/diagnostics/Registry_pv.xml @@ -3,6 +3,12 @@ + + + + + @@ -420,5 +426,9 @@ packages="pv_diagnostics"/> + + + diff --git a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F index 9088962fab..7f0a9f693a 100644 --- a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F @@ -182,6 +182,9 @@ subroutine pv_diagnostics_setup(configs_in, all_pools, simulation_clock) integer, pointer :: nCells, nVertLevels real(kind=RKIND), dimension(:,:), pointer :: zgrid, zCell + ! for counter init + integer, dimension(:), pointer :: pv_callCounter + call mpas_pool_get_subpool(all_pools, 'mesh', mesh) call mpas_pool_get_subpool(all_pools, 'state', state) call mpas_pool_get_subpool(all_pools, 'diag', diag) @@ -224,7 +227,16 @@ subroutine pv_diagnostics_setup(configs_in, all_pools, simulation_clock) call mpas_log_write(' ') end if - + + if (config_pv_tend) then + ! Initialize counter -- used to prevent update of tendencies at initialization time + ! This is relevant for restart runs because derived parent tendencies used in PV tendency calculations and _prev + ! variables aren't stored in restart files. Prevents inaccurate tendency calculations that propagate into + ! accumulate tendency variables + call mpas_pool_get_array(diag, 'pv_callCounter', pv_callCounter) + pv_callCounter(:) = 0 + end if + end subroutine pv_diagnostics_setup @@ -234,7 +246,7 @@ end subroutine pv_diagnostics_setup !********************************************************************************************************************* subroutine pv_diagnostics_update(domain, exchange_halo_group) ! MC: modified with inputs for new halo exchange - use mpas_pool_routines, only: mpas_pool_get_config + use mpas_pool_routines, only: mpas_pool_get_config, mpas_pool_get_array implicit none @@ -242,6 +254,8 @@ subroutine pv_diagnostics_update(domain, exchange_halo_group) ! MC: modifi procedure (halo_exchange_routine) :: exchange_halo_group logical, pointer :: config_pv_diag, config_pv_tend + integer, dimension(:), pointer :: pv_callCounter + call mpas_pool_get_config(configs, 'config_pv_diag', config_pv_diag) call mpas_pool_get_config(configs, 'config_pv_tend', config_pv_tend) @@ -251,8 +265,16 @@ subroutine pv_diagnostics_update(domain, exchange_halo_group) ! MC: modifi call mpas_log_write("Computing Ertel's PV.") call atm_compute_pv_diagnostics(domain, configs, state, diag, mesh, exchange_halo_group) - call mpas_log_write('Computing PV tendency diagnostics.') - call atm_compute_pvBudget_diagnostics(domain, configs, state, diag, mesh, tend, tend_physics, diag_physics, exchange_halo_group) + ! Only call PV tendency calculations during model integration, not at initialization time + ! Track this via counter for number of calls to this subroutine + call mpas_pool_get_array(diag, 'pv_callCounter', pv_callCounter) + + if (pv_callCounter(1) .gt. 0) then + call mpas_log_write('Computing PV tendency diagnostics.') + call atm_compute_pvBudget_diagnostics(domain, configs, state, diag, mesh, tend, tend_physics, diag_physics, exchange_halo_group) ! MC halo mod + end if + + pv_callCounter(:) = pv_callCounter(:) + 1 end if end subroutine pv_diagnostics_update diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index d0e0d37d68..e83cb7d502 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -7905,9 +7905,6 @@ subroutine atm_reconstruct_tend(domain, diag, mesh, configs, nCells, nVertLevels acc_u_tend_dcpl_ReconstructZ, & acc_u_tend_dcpl_ReconstructZonal, acc_u_tend_dcpl_ReconstructMeridional - ! Added for PV - real (kind=RKIND), dimension(:,:), pointer :: uReconstructX_dyn, uReconstructY_dyn, uReconstructZ_dyn, & - uReconstructZonal_dyn, uReconstructMeridional_dyn integer, pointer :: nCellsSolve, nEdges integer, dimension(:,:), pointer :: cellsOnEdge From 522452fb77231034c2d8ba245e37fc3f41faaeb7 Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Tue, 9 Jul 2024 18:43:32 -0600 Subject: [PATCH 13/23] Add theta, PV tendencies for specific Thompson microphysical processes - Added mpas_halo_exch_group_complete for microphysics process tendencies (was previously missing) - Added tend_theta_mp_* variables to Registry.xml that track potential temperature tendencies for the following processes in the Thompson microphysics scheme: net condensation/evaporation of cloud water, evaporation of rain water, net deposition/sublimation, melting, and freezing. These variables are only computed for config_pv_microphys = .true. and are used in the calculation of PV tendencies for each respective process - Added variable declarations to mpas_atmphys_vars.F for calculations of temperature tendencies from the Thompson scheme - Added calculations of temperature and potential temperature tendencies to module_mp_thompson.F, mpas_atmphys_driver_microphys.F, and mpas_atmphys_interface.F - Added calculations of PV tendencies associated with these specific microphysical processes to mpas_pv_diagnostics.F - Added compatability with 'mp_thompson_aerosols' in Registry.xml and mpas_atm_diagnostics_packages.F --- src/core_atmosphere/Registry.xml | 22 ++ .../mpas_atm_diagnostics_packages.F | 4 +- .../diagnostics/mpas_pv_diagnostics.F | 349 +++++++++++++++++- src/core_atmosphere/mpas_atm_halos.F | 1 + .../mpas_atmphys_driver_microphysics.F | 54 ++- .../physics/mpas_atmphys_interface.F | 56 ++- .../physics/mpas_atmphys_vars.F | 11 +- .../physics/physics_wrf/module_mp_thompson.F | 133 ++++++- 8 files changed, 605 insertions(+), 25 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index d083da6650..7945cfbda9 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -2506,6 +2506,28 @@ description="precipitable water"/> + + + + + + + + + + + + diff --git a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_packages.F b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_packages.F index 08edbdb333..c1876eb859 100644 --- a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_packages.F +++ b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_packages.F @@ -156,8 +156,8 @@ function diagnostics_setup_packages(configs, packages, iocontext) result(ierr) call mpas_log_write('config_pv_tend is not activated; deactivated all dependent PV configs.', MPAS_LOG_WARN) end if - ! Ensure Thompson scheme is enabled for microphysics PV tendencies - if ((config_pv_microphys) .and. (config_microp_scheme /= 'mp_thompson')) then + ! Ensure either Thompson or Thompson-aerosol scheme is enabled for microphysics PV tendencies + if ((config_pv_microphys) .and. ((trim(config_microp_scheme) /= 'mp_thompson') .and. (trim(config_microp_scheme) /= 'mp_thompson_aerosols'))) then call mpas_log_write('config_pv_microphys is not compatible with = '''//trim(config_microp_scheme)//''' -- disabling', MPAS_LOG_WARN) config_pv_microphys = .false. end if diff --git a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F index 7f0a9f693a..5b1fab3b24 100644 --- a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F @@ -68,7 +68,7 @@ end subroutine halo_exchange_routine ! config_pv_isobaric) ! -- config_pv_scalar : flag for whether pv_scalar is initialized as PV and then transported as passive scalar ! throughout the model integration - ! -- config_pv_microphys : flag for whether specific microphysics process PV tendencies are desired (Thompson only) + ! -- config_pv_microphys : flag for whether specific microphysics process PV tendencies are desired (Thompson schemes only) ! -- config_pv_isobaric : flag for whether isobaric interpolation of PV diagnostics variables is desired ! (requires mods to mpas_isobaric_diagnostics.F) ! @@ -147,7 +147,7 @@ end subroutine halo_exchange_routine ! PV dynamics tendencies). ! * Accumulated PV tendencies were added to permit the evaluation of the net PV tendencies without outputting the model ! variables at each time step. - ! * Added PV tendencies for specific microphysical processes in the Thompson scheme: net condensation/evaporation of cloud + ! * Added PV tendencies for specific microphysical processes in the Thompson schemes: net condensation/evaporation of cloud ! water, evaporation of rain water, net deposition/sublimation, melting, and freezing. Requires config_pv_microphys = .true. ! Note: these tendencies use the theta tendencies from the microphysics scheme directly, whereas depv_dt_mp is calculated ! using the derived theta tendency from the theta_m and qv tendencies. The differences in these approaches can be @@ -2188,6 +2188,10 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph ! dynamics PV tendency real(kind=RKIND), dimension(:,:), pointer :: depv_dt_dyn + ! specific microphysics PV tendencies + real(kind=RKIND), dimension(:,:), pointer :: depv_dt_mp_evap_cw, depv_dt_mp_evap_rw, depv_dt_mp_depo_ice, & + depv_dt_mp_melt_ice, depv_dt_mp_frez_ice, depv_dt_mp_allproc + ! process tendencies -- friction real(kind=RKIND), dimension(:,:), pointer :: u_tend_diff, w_tend_diff, tend_wCell_diff, tend_u_pbl, tend_u_cu real(kind=RKIND), dimension(:,:), pointer :: uTend_curl_diff, uTend_curl_pbl, uTend_curl_cu @@ -2195,6 +2199,8 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph ! process tendencies -- diabatic real(kind=RKIND), dimension(:,:), pointer :: dtheta_dt_mp, dtheta_dt_mix, dtheta_dt_pbl, dtheta_dt_cu, dtheta_dt_sw, & ! MC: calculated in atm_compute_pvBudget_diagnostics dtheta_dt_lw + real(kind=RKIND), dimension(:,:), pointer :: tend_theta_mp_evap_cw, tend_theta_mp_evap_rw, tend_theta_mp_depo_ice, & + tend_theta_mp_melt_ice, tend_theta_mp_frez_ice ! process tendencies -- dynamics real(kind=RKIND), dimension(:,:), pointer :: dtheta_dt_dyn, du_dt_dyn, dw_dt_dyn, tenddyn_wCell @@ -2206,6 +2212,7 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph real(kind=RKIND), dimension(:,:), allocatable :: dW_dxZonal, dW_dyMerid real(kind=RKIND), dimension(:,:), allocatable :: absVort real(kind=RKIND), dimension(:,:,:), allocatable :: absVort3D, gradTheta + ! diabatic tendency variables real(kind=RKIND), dimension(:,:), allocatable :: dLWtend_dxZonal, dLWtend_dyMerid, dLWtend_dz ! Gradients of theta tendencies from LW radiation real(kind=RKIND), dimension(:,:), allocatable :: dSWtend_dxZonal, dSWtend_dyMerid, dSWtend_dz ! Gradients of theta tendencies from SW radiation @@ -2216,6 +2223,23 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph real(kind=RKIND), dimension(:,:,:), allocatable :: grad_diabatic_LW, grad_diabatic_SW, grad_diabatic_BL, & grad_diabatic_CU, grad_diabatic_MP, grad_diabatic_MX + ! diabatic tendency variables -- specific microphysical processes + real(kind=RKIND), dimension(:,:), allocatable :: tend_theta_mp_sum + real(kind=RKIND), dimension(:,:), allocatable :: dMPevapcwtend_dxZonal, dMPevapcwtend_dyMerid, & ! Gradients of theta tendencies from specific microphysical processes + dMPevapcwtend_dz, & + dMPevaprwtend_dxZonal, dMPevaprwtend_dyMerid, & + dMPevaprwtend_dz, & + dMPdepotend_dxZonal, dMPdepotend_dyMerid, & + dMPdepotend_dz, & + dMPmelttend_dxZonal, dMPmelttend_dyMerid, & + dMPmelttend_dz, & + dMPfreztend_dxZonal, dMPfreztend_dyMerid, & + dMPfreztend_dz, & + dMPsumtend_dxZonal, dMPsumtend_dyMerid, & + dMPsumtend_dz + real(kind=RKIND), dimension(:,:,:), allocatable :: grad_diabatic_MP_evap_cw, grad_diabatic_MP_evap_rw, grad_diabatic_MP_depo, & + grad_diabatic_MP_melt, grad_diabatic_MP_frez, grad_diabatic_MP_sum + ! friction tendency vars real(kind=RKIND), dimension(:,:), allocatable :: dWtend_dxZonal, dWtend_dyMerid, duZonalTend_dz_mix, duMeridTend_dz_mix, & vertVortTend_mix, tenduX_mix, tenduY_mix, tenduZ_mix, tend_uZonal_mix, tend_uMerid_mix @@ -2236,7 +2260,6 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph !real(kind=RKIND), pointer :: cf1, cf2, cf3 !real(kind=RKIND), dimension(:), pointer :: rdzw - ! mesh / config vars call mpas_pool_get_config(configs,'config_dt',config_dt) call mpas_pool_get_config(configs, 'config_pv_microphys', config_pv_microphys) @@ -2294,6 +2317,17 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph ! dynamics PV tendency call mpas_pool_get_array(diag,'depv_dt_dyn',depv_dt_dyn) ! total PV tendency from dynamics (includes transport, decoupling, rho tendency) + + ! specific microphysics PV tendencies (Thompson only) + if (config_pv_microphys) then + call mpas_pool_get_array(diag, 'depv_dt_mp_evap_cw', depv_dt_mp_evap_cw) ! diabatic PV tendency from net condensation/evaporation of cloud water + call mpas_pool_get_array(diag, 'depv_dt_mp_evap_rw', depv_dt_mp_evap_rw) ! diabatic PV tendency from evaporation of rain water + call mpas_pool_get_array(diag, 'depv_dt_mp_depo_ice', depv_dt_mp_depo_ice) ! diabatic PV tendency from net deposition/sublimation of all ice hydrometeors + call mpas_pool_get_array(diag, 'depv_dt_mp_melt_ice', depv_dt_mp_melt_ice) ! diabatic PV tendency from melting of all ice hydrometeors + call mpas_pool_get_array(diag, 'depv_dt_mp_frez_ice', depv_dt_mp_frez_ice) ! diabatic PV tendency from freezing of all ice hydrometeors + call mpas_pool_get_array(diag, 'depv_dt_mp_allproc', depv_dt_mp_allproc) ! total diabatic PV tendency from all specific processes + end if + ! process tendencies -- friction: call mpas_pool_get_array(diag, 'u_tend_diff', u_tend_diff) ! Normal wind tendency from explicit mixing on cell edges call mpas_pool_get_array(diag, 'w_tend_diff', w_tend_diff) ! Vertical wind tendency from explicit mixing @@ -2319,7 +2353,19 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph call mpas_pool_get_array(diag, 'tenddyn_wCell', tenddyn_wCell) ! dw_dt_dyn interpolated to mass levels call mpas_pool_get_array(diag, 'uTend_curl_dyn', uTend_curl_dyn) ! Vertical curl of du_dt_dyn at cell vertices - ! needed for alternative vertical derivative calculation + ! specific microphysics process potential temperature tendencies + ! MC note: unlike dtheta_dt_mp, which is derived from theta_m tendency and is more precise, + ! these tendencies are directly obtained from the theta rates in the Thompson + ! scheme. thus, the sum of these will not exactly equal dtheta_dt_mp. + if (config_pv_microphys) then + call mpas_pool_get_array(diag_physics, 'tend_theta_mp_evap_cw', tend_theta_mp_evap_cw) + call mpas_pool_get_array(diag_physics, 'tend_theta_mp_evap_rw', tend_theta_mp_evap_rw) + call mpas_pool_get_array(diag_physics, 'tend_theta_mp_depo_ice', tend_theta_mp_depo_ice) + call mpas_pool_get_array(diag_physics, 'tend_theta_mp_melt_ice', tend_theta_mp_melt_ice) + call mpas_pool_get_array(diag_physics, 'tend_theta_mp_frez_ice', tend_theta_mp_frez_ice) + end if + + ! needed for alternative vertical derivative calculation (not recommended) !call mpas_pool_get_array(mesh, 'cf1', cf1) !call mpas_pool_get_array(mesh, 'cf2', cf2) !call mpas_pool_get_array(mesh, 'cf3', cf3) @@ -2368,6 +2414,36 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph allocate(grad_diabatic_MX(nVertLevels,nCells+1,R3)) allocate(grad_diabatic_MP(nVertLevels,nCells+1,R3)) + ! allocate diabatic tendency variables from specific microphys processes + if (config_pv_microphys) then + allocate(dMPevapcwtend_dxZonal(nVertLevels,nCells+1)) + allocate(dMPevapcwtend_dyMerid(nVertLevels,nCells+1)) + allocate(dMPevapcwtend_dz(nVertLevels,nCells+1)) + allocate(dMPevaprwtend_dxZonal(nVertLevels,nCells+1)) + allocate(dMPevaprwtend_dyMerid(nVertLevels,nCells+1)) + allocate(dMPevaprwtend_dz(nVertLevels,nCells+1)) + allocate(dMPdepotend_dxZonal(nVertLevels,nCells+1)) + allocate(dMPdepotend_dyMerid(nVertLevels,nCells+1)) + allocate(dMPdepotend_dz(nVertLevels,nCells+1)) + allocate(dMPmelttend_dxZonal(nVertLevels,nCells+1)) + allocate(dMPmelttend_dyMerid(nVertLevels,nCells+1)) + allocate(dMPmelttend_dz(nVertLevels,nCells+1)) + allocate(dMPfreztend_dxZonal(nVertLevels,nCells+1)) + allocate(dMPfreztend_dyMerid(nVertLevels,nCells+1)) + allocate(dMPfreztend_dz(nVertLevels,nCells+1)) + allocate(dMPsumtend_dxZonal(nVertLevels,nCells+1)) + allocate(dMPsumtend_dyMerid(nVertLevels,nCells+1)) + allocate(dMPsumtend_dz(nVertLevels,nCells+1)) + allocate(tend_theta_mp_sum(nVertLevels,nCells+1)) + ! 3D tendency vectors + allocate(grad_diabatic_MP_evap_cw(nVertLevels,nCells+1,R3)) + allocate(grad_diabatic_MP_evap_rw(nVertLevels,nCells+1,R3)) + allocate(grad_diabatic_MP_depo(nVertLevels,nCells+1,R3)) + allocate(grad_diabatic_MP_melt(nVertLevels,nCells+1,R3)) + allocate(grad_diabatic_MP_frez(nVertLevels,nCells+1,R3)) + allocate(grad_diabatic_MP_sum(nVertLevels,nCells+1,R3)) + end if + ! allocate friction tendency variables ! mixing allocate(dWtend_dxZonal(nVertLevels,nCells+1)) ! also used for dynamics @@ -2446,6 +2522,15 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph dWtend_dxZonal_phys(:,:) = 0.0_RKIND dWtend_dyMerid_phys(:,:) = 0.0_RKIND + if (config_pv_microphys) then + depv_dt_mp_evap_cw(:,:) = 0.0_RKIND + depv_dt_mp_evap_rw(:,:) = 0.0_RKIND + depv_dt_mp_depo_ice(:,:) = 0.0_RKIND + depv_dt_mp_melt_ice(:,:) = 0.0_RKIND + depv_dt_mp_frez_ice(:,:) = 0.0_RKIND + depv_dt_mp_allproc(:,:) = 0.0_RKIND + tend_theta_mp_sum(:,:) = 0.0_RKIND + end if !*********************************************************************************************** ! Calculate terms needed for PV tendency equation @@ -2691,7 +2776,191 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph end if ! Sum of all diabatic contributions to PV through potential temperature tendencies - depv_dt_diab = depv_dt_mix + depv_dt_lw + depv_dt_sw + depv_dt_bl + depv_dt_cu + depv_dt_mp + depv_dt_diab = depv_dt_mix + depv_dt_lw + depv_dt_sw + depv_dt_bl + depv_dt_cu + depv_dt_mp + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Individual diabatic tendencies from specific microphysical processes (not included in budget) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! Net cloud water condensation and evaporation + if ((config_pv_microphys) .and. (associated(tend_theta_mp_evap_cw))) then + + ! (1) Calculate and reconstruct horizontal gradients of theta tendency + call calc_gradOnEdges_reconCellCenter(tend_theta_mp_evap_cw, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dMPevapcwtend_dxZonal, & + dMPevapcwtend_dyMerid) + + ! (2) Calculate vertical gradient of theta tendency + call calc_vertDeriv(tend_theta_mp_evap_cw, nCellsSolve, nVertLevels, zCell, dMPevapcwtend_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(tend_theta_mp_evap_cw, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dMPevapcwtend_dz) + + ! (3) Combine into 3D theta tendency gradient vector + grad_diabatic_MP_evap_cw(:,:,1) = dMPevapcwtend_dxZonal + grad_diabatic_MP_evap_cw(:,:,2) = dMPevapcwtend_dyMerid + grad_diabatic_MP_evap_cw(:,:,3) = dMPevapcwtend_dz + + ! (4) Take dot product between 3D theta tendency vector and absolute vorticity / density + call calc_dotProduct_3D(grad_diabatic_MP_evap_cw, absVort3D, nCellsSolve, nVertLevels, depv_dt_mp_evap_cw) + + depv_dt_mp_evap_cw = depv_dt_mp_evap_cw / rho * 1.0e6 + else + depv_dt_mp_evap_cw = 0.0_RKIND + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Rain water evaporation + if ((config_pv_microphys) .and. (associated(tend_theta_mp_evap_rw))) then + + ! (1) Calculate and reconstruct horizontal gradients of theta tendency + call calc_gradOnEdges_reconCellCenter(tend_theta_mp_evap_rw, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dMPevaprwtend_dxZonal, & + dMPevaprwtend_dyMerid) + + ! (2) Calculate vertical gradient of theta tendency + call calc_vertDeriv(tend_theta_mp_evap_rw, nCellsSolve, nVertLevels, zCell, dMPevaprwtend_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(tend_theta_mp_evap_rw, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dMPevaprwtend_dz) + + ! (3) Combine into 3D theta tendency gradient vector + grad_diabatic_MP_evap_rw(:,:,1) = dMPevaprwtend_dxZonal + grad_diabatic_MP_evap_rw(:,:,2) = dMPevaprwtend_dyMerid + grad_diabatic_MP_evap_rw(:,:,3) = dMPevaprwtend_dz + + ! (4) Take dot product between 3D theta tendency vector and absolute vorticity / density + call calc_dotProduct_3D(grad_diabatic_MP_evap_rw, absVort3D, nCellsSolve, nVertLevels, depv_dt_mp_evap_rw) + + depv_dt_mp_evap_rw = depv_dt_mp_evap_rw / rho * 1.0e6 + else + depv_dt_mp_evap_rw = 0.0_RKIND + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Net sublimation/deposition + if ((config_pv_microphys) .and. (associated(tend_theta_mp_depo_ice))) then + + ! (1) Calculate and reconstruct horizontal gradients of theta tendency + call calc_gradOnEdges_reconCellCenter(tend_theta_mp_depo_ice, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dMPdepotend_dxZonal, & + dMPdepotend_dyMerid) + + ! (2) Calculate vertical gradient of theta tendency + call calc_vertDeriv(tend_theta_mp_depo_ice, nCellsSolve, nVertLevels, zCell, dMPdepotend_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(tend_theta_mp_depo_ice, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dMPdepotend_dz) + + ! (3) Combine into 3D theta tendency gradient vector + grad_diabatic_MP_depo(:,:,1) = dMPdepotend_dxZonal + grad_diabatic_MP_depo(:,:,2) = dMPdepotend_dyMerid + grad_diabatic_MP_depo(:,:,3) = dMPdepotend_dz + + ! (4) Take dot product between 3D theta tendency vector and absolute vorticity / density + call calc_dotProduct_3D(grad_diabatic_MP_depo, absVort3D, nCellsSolve, nVertLevels, depv_dt_mp_depo_ice) + + depv_dt_mp_depo_ice = depv_dt_mp_depo_ice / rho * 1.0e6 + + else + depv_dt_mp_depo_ice = 0.0_RKIND + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Melting + if ((config_pv_microphys) .and. (associated(tend_theta_mp_melt_ice))) then + + ! (1) Calculate and reconstruct horizontal gradients of theta tendency + call calc_gradOnEdges_reconCellCenter(tend_theta_mp_melt_ice, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dMPmelttend_dxZonal, & + dMPmelttend_dyMerid) + + ! (2) Calculate vertical gradient of theta tendency + call calc_vertDeriv(tend_theta_mp_melt_ice, nCellsSolve, nVertLevels, zCell, dMPmelttend_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(tend_theta_mp_melt_ice, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dMPmelttend_dz) + + ! (3) Combine into 3D theta tendency gradient vector + grad_diabatic_MP_melt(:,:,1) = dMPmelttend_dxZonal + grad_diabatic_MP_melt(:,:,2) = dMPmelttend_dyMerid + grad_diabatic_MP_melt(:,:,3) = dMPmelttend_dz + + ! (4) Take dot product between 3D theta tendency vector and absolute vorticity / density + call calc_dotProduct_3D(grad_diabatic_MP_melt, absVort3D, nCellsSolve, nVertLevels, depv_dt_mp_melt_ice) + + depv_dt_mp_melt_ice = depv_dt_mp_melt_ice / rho * 1.0e6 + else + depv_dt_mp_melt_ice = 0.0_RKIND + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Freezing + if ((config_pv_microphys) .and. (associated(tend_theta_mp_frez_ice))) then + + ! (1) Calculate and reconstruct horizontal gradients of theta tendency + call calc_gradOnEdges_reconCellCenter(tend_theta_mp_frez_ice, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dMPfreztend_dxZonal, & + dMPfreztend_dyMerid) + + ! (2) Calculate vertical gradient of theta tendency + call calc_vertDeriv(tend_theta_mp_frez_ice, nCellsSolve, nVertLevels, zCell, dMPfreztend_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(tend_theta_mp_frez_ice, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dMPfreztend_dz) + + ! (3) Combine into 3D theta tendency gradient vector + grad_diabatic_MP_frez(:,:,1) = dMPfreztend_dxZonal + grad_diabatic_MP_frez(:,:,2) = dMPfreztend_dyMerid + grad_diabatic_MP_frez(:,:,3) = dMPfreztend_dz + + ! (4) Take dot product between 3D theta tendency vector and absolute vorticity / density + call calc_dotProduct_3D(grad_diabatic_MP_frez, absVort3D, nCellsSolve, nVertLevels, depv_dt_mp_frez_ice) + + depv_dt_mp_frez_ice = depv_dt_mp_frez_ice / rho * 1.0e6 + else + depv_dt_mp_frez_ice = 0.0_RKIND + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Sum all processes together to find combined PV tendency from microphysics. Compare to depv_dt_mp + if ((config_pv_microphys) .and. (associated(tend_theta_mp_frez_ice))) then + + ! (1) Sum individual process tendencies + tend_theta_mp_sum = tend_theta_mp_frez_ice + tend_theta_mp_melt_ice + tend_theta_mp_depo_ice + & + tend_theta_mp_evap_rw + tend_theta_mp_evap_cw + + ! (2) Calculate and reconstruct horizontal gradients of theta tendency + call calc_gradOnEdges_reconCellCenter(tend_theta_mp_sum, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & + edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & + latCell, lonCell, dMPsumtend_dxZonal, & + dMPsumtend_dyMerid) + + ! (3) Calculate vertical gradient of theta tendency + call calc_vertDeriv(tend_theta_mp_sum, nCellsSolve, nVertLevels, zCell, dMPsumtend_dz) + + ! For alternative method, comment out above and uncomment below. + ! call calc_vertDeriv_alt(tend_theta_mp_sum, nCellsSolve, nVertLevels, dzu, cf1, cf2, cf3, rdzw, zgrid, zCell, dMPsumtend_dz) + + ! (4) Combine into 3D theta tendency gradient vector + grad_diabatic_MP_sum(:,:,1) = dMPsumtend_dxZonal + grad_diabatic_MP_sum(:,:,2) = dMPsumtend_dyMerid + grad_diabatic_MP_sum(:,:,3) = dMPsumtend_dz + + ! (5) Take dot product between 3D theta tendency vector and absolute vorticity / density + call calc_dotProduct_3D(grad_diabatic_MP_sum, absVort3D, nCellsSolve, nVertLevels, depv_dt_mp_allproc) + + depv_dt_mp_allproc = depv_dt_mp_allproc / rho * 1.0e6 + else + depv_dt_mp_allproc = 0.0_RKIND + end if + !*********************************************************************************************** ! Calculate frictional tendency terms: @@ -2965,6 +3234,35 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph deallocate(grad_diabatic_MX) deallocate(grad_diabatic_MP) + ! deallocate diabatic tendency variables from specific microphys processes + if (config_pv_microphys) then + deallocate(dMPevapcwtend_dxZonal) + deallocate(dMPevapcwtend_dyMerid) + deallocate(dMPevapcwtend_dz) + deallocate(dMPevaprwtend_dxZonal) + deallocate(dMPevaprwtend_dyMerid) + deallocate(dMPevaprwtend_dz) + deallocate(dMPdepotend_dxZonal) + deallocate(dMPdepotend_dyMerid) + deallocate(dMPdepotend_dz) + deallocate(dMPmelttend_dxZonal) + deallocate(dMPmelttend_dyMerid) + deallocate(dMPmelttend_dz) + deallocate(dMPfreztend_dxZonal) + deallocate(dMPfreztend_dyMerid) + deallocate(dMPfreztend_dz) + deallocate(dMPsumtend_dxZonal) + deallocate(dMPsumtend_dyMerid) + deallocate(dMPsumtend_dz) + deallocate(tend_theta_mp_sum) + deallocate(grad_diabatic_MP_evap_cw) + deallocate(grad_diabatic_MP_evap_rw) + deallocate(grad_diabatic_MP_depo) + deallocate(grad_diabatic_MP_melt) + deallocate(grad_diabatic_MP_frez) + deallocate(grad_diabatic_MP_sum) + end if + ! deallocate friction tendency variables ! mixing deallocate(dWtend_dxZonal) @@ -3144,6 +3442,9 @@ subroutine atm_compute_pvBudget_diagnostics(domain, configs, state, diag, mesh, call exchange_halo_group(domain, 'diagnostics:dpv_mom_tend') call exchange_halo_group(domain, 'diagnostics:dpv_mom_curl') + if (config_pv_microphys) then + call exchange_halo_group(domain, 'diagnostics:dpv_mp_tend') + end if ! ----------------------------------------------------------- ! Call subroutines: @@ -3184,7 +3485,7 @@ subroutine acc_pvBudget(mesh, diag, tend_physics) type (mpas_pool_type), intent(inout) :: diag type (mpas_pool_type), intent(in) :: tend_physics - logical, pointer :: config_pv_tend + logical, pointer :: config_pv_tend, config_pv_microphys integer, pointer :: nCells, nVertLevels integer :: iCell, k @@ -3199,11 +3500,18 @@ subroutine acc_pvBudget(mesh, diag, tend_physics) real(kind=RKIND), dimension(:), pointer :: depv_dt_diab_pv, depv_dt_fric_pv, depv_dt_dyn_pv real(kind=RKIND), dimension(:), pointer :: acc_depv_dt_diab_pv, acc_depv_dt_fric_pv, acc_depv_dt_dyn_pv + ! Specific microphysics process tendencies + real(kind=RKIND), dimension(:,:), pointer :: depv_dt_mp_evap_cw, depv_dt_mp_evap_rw, depv_dt_mp_depo_ice, depv_dt_mp_melt_ice + real(kind=RKIND), dimension(:,:), pointer :: acc_depv_dt_mp_evap_cw, acc_depv_dt_mp_evap_rw, acc_depv_dt_mp_depo_ice, acc_depv_dt_mp_melt_ice + real(kind=RKIND), dimension(:,:), pointer :: depv_dt_mp_frez_ice, depv_dt_mp_allproc + real(kind=RKIND), dimension(:,:), pointer :: acc_depv_dt_mp_frez_ice, acc_depv_dt_mp_allproc + ! Latent heating tendencies real(kind=RKIND), dimension(:,:), pointer :: dtheta_dt_cu, dtheta_dt_mp real(kind=RKIND), dimension(:,:), pointer :: acc_dtheta_dt_cu, acc_dtheta_dt_mp call mpas_pool_get_config(configs, 'config_pv_tend', config_pv_tend) + call mpas_pool_get_config(configs, 'config_pv_microphys', config_pv_microphys) ! Instantaneous and accumulated PV tendencies call mpas_pool_get_array(diag, 'depv_dt_lw', depv_dt_lw) @@ -3237,6 +3545,23 @@ subroutine acc_pvBudget(mesh, diag, tend_physics) call mpas_pool_get_array(diag, 'acc_depv_dt_diab_pv', acc_depv_dt_diab_pv) call mpas_pool_get_array(diag, 'acc_depv_dt_fric_pv', acc_depv_dt_fric_pv) call mpas_pool_get_array(diag, 'acc_depv_dt_dyn_pv', acc_depv_dt_dyn_pv) + + ! Specific microphysics process tendencies + if (config_pv_microphys) then + call mpas_pool_get_array(diag, 'depv_dt_mp_evap_cw', depv_dt_mp_evap_cw) + call mpas_pool_get_array(diag, 'depv_dt_mp_evap_rw', depv_dt_mp_evap_rw) + call mpas_pool_get_array(diag, 'depv_dt_mp_depo_ice', depv_dt_mp_depo_ice) + call mpas_pool_get_array(diag, 'depv_dt_mp_melt_ice', depv_dt_mp_melt_ice) + call mpas_pool_get_array(diag, 'depv_dt_mp_frez_ice', depv_dt_mp_frez_ice) + call mpas_pool_get_array(diag, 'depv_dt_mp_allproc', depv_dt_mp_allproc) + + call mpas_pool_get_array(diag, 'acc_depv_dt_mp_evap_cw', acc_depv_dt_mp_evap_cw) + call mpas_pool_get_array(diag, 'acc_depv_dt_mp_evap_rw', acc_depv_dt_mp_evap_rw) + call mpas_pool_get_array(diag, 'acc_depv_dt_mp_depo_ice', acc_depv_dt_mp_depo_ice) + call mpas_pool_get_array(diag, 'acc_depv_dt_mp_melt_ice', acc_depv_dt_mp_melt_ice) + call mpas_pool_get_array(diag, 'acc_depv_dt_mp_frez_ice', acc_depv_dt_mp_frez_ice) + call mpas_pool_get_array(diag, 'acc_depv_dt_mp_allproc', acc_depv_dt_mp_allproc) + end if ! Latent heating tendencies call mpas_pool_get_array(diag, 'dtheta_dt_cu', dtheta_dt_cu) @@ -3271,6 +3596,18 @@ subroutine acc_pvBudget(mesh, diag, tend_physics) acc_dtheta_dt_cu(:,:) = acc_dtheta_dt_cu(:,:) + dtheta_dt_cu(:,:) end if + ! If specific microphysics process tendencies are requested, accumulate + if (config_pv_microphys) then + acc_depv_dt_mp_evap_cw(:,:) = acc_depv_dt_mp_evap_cw(:,:) + depv_dt_mp_evap_cw(:,:) + acc_depv_dt_mp_evap_rw(:,:) = acc_depv_dt_mp_evap_rw(:,:) + depv_dt_mp_evap_rw(:,:) + acc_depv_dt_mp_depo_ice(:,:) = acc_depv_dt_mp_depo_ice(:,:) + depv_dt_mp_depo_ice(:,:) + acc_depv_dt_mp_melt_ice(:,:) = acc_depv_dt_mp_melt_ice(:,:) + depv_dt_mp_melt_ice(:,:) + acc_depv_dt_mp_frez_ice(:,:) = acc_depv_dt_mp_frez_ice(:,:) + depv_dt_mp_frez_ice(:,:) + acc_depv_dt_mp_allproc(:,:) = acc_depv_dt_mp_allproc(:,:) + depv_dt_mp_allproc(:,:) + end if + + + end subroutine acc_pvBudget diff --git a/src/core_atmosphere/mpas_atm_halos.F b/src/core_atmosphere/mpas_atm_halos.F index b4b94aa312..2512c53bf7 100644 --- a/src/core_atmosphere/mpas_atm_halos.F +++ b/src/core_atmosphere/mpas_atm_halos.F @@ -523,6 +523,7 @@ subroutine atm_build_halo_groups(domain, ierr) call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mp_tend', 'tend_theta_mp_depo_ice', timeLevel=1, haloLayers=(/1,2/)) call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mp_tend', 'tend_theta_mp_melt_ice', timeLevel=1, haloLayers=(/1,2/)) call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mp_tend', 'tend_theta_mp_frez_ice', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'diagnostics:dpv_mp_tend') end if diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F index 90b4d9292f..45b228ba1f 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F @@ -86,6 +86,9 @@ module mpas_atmphys_driver_microphysics ! * since we removed the local variable microp_scheme from mpas_atmphys_vars.F, now defines microp_scheme as a ! pointer to config_microp_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. +! * allocated variables for microphysics process heating tendencies for PV diagnostics and included them in +! mp_gt_driver call +! Manda Chasteen (chasteen@ucar.edu) / 2024-06-01 !--- initialization option for WSM6 from WRF version 3.8.1. this option could also be set as a namelist parameter. integer,parameter:: hail_opt = 0 @@ -156,6 +159,13 @@ subroutine allocate_microphysics(configs) if(.not.allocated(ni_p) ) allocate(ni_p(ims:ime,kms:kme,jms:jme)) if(.not.allocated(nr_p) ) allocate(nr_p(ims:ime,kms:kme,jms:jme)) + ! individual heating tends for PV - MC added + if(.not.allocated(tend_theta_mp_evap_cw_p)) allocate(tend_theta_mp_evap_cw_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(tend_theta_mp_evap_rw_p)) allocate(tend_theta_mp_evap_rw_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(tend_theta_mp_depo_ice_p)) allocate(tend_theta_mp_depo_ice_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(tend_theta_mp_melt_ice_p)) allocate(tend_theta_mp_melt_ice_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(tend_theta_mp_frez_ice_p)) allocate(tend_theta_mp_frez_ice_p(ims:ime,kms:kme,jms:jme)) + microp3_select: select case(trim(microp_scheme)) case("mp_thompson_aerosols") if(.not.allocated(nifa2d_p)) allocate(nifa2d_p(ims:ime,jms:jme)) @@ -237,6 +247,13 @@ subroutine deallocate_microphysics(configs) if(allocated(ni_p) ) deallocate(ni_p ) if(allocated(nr_p) ) deallocate(nr_p ) + ! individual heating tends for PV - MC added + if(allocated(tend_theta_mp_evap_cw_p)) deallocate(tend_theta_mp_evap_cw_p) + if(allocated(tend_theta_mp_evap_rw_p)) deallocate(tend_theta_mp_evap_rw_p) + if(allocated(tend_theta_mp_depo_ice_p)) deallocate(tend_theta_mp_depo_ice_p) + if(allocated(tend_theta_mp_melt_ice_p)) deallocate(tend_theta_mp_melt_ice_p) + if(allocated(tend_theta_mp_frez_ice_p)) deallocate(tend_theta_mp_frez_ice_p) + microp3_select: select case(trim(microp_scheme)) case("mp_thompson_aerosols") if(allocated(nifa2d_p)) deallocate(nifa2d_p) @@ -400,12 +417,27 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten re_cloud = recloud_p , re_ice = reice_p , re_snow = resnow_p , & has_reqc = has_reqc , has_reqi = has_reqi , has_reqs = has_reqs , & ntc = ntc_p , muc = muc_p , & + tend_theta_mp_evap_cw = tend_theta_mp_evap_cw_p, tend_theta_mp_evap_rw = tend_theta_mp_evap_rw_p , & ! MC added + tend_theta_mp_depo_ice = tend_theta_mp_depo_ice_p, tend_theta_mp_melt_ice = tend_theta_mp_melt_ice_p , & ! MC added + tend_theta_mp_frez_ice = tend_theta_mp_frez_ice_p , & ! MC added + istep = istep , & ! MC added ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) istep = istep + 1 enddo + + ! MC added for microphysics process tendencies for PV diagnostics + ! Need to correct for possibility of n_microp != 1 by averaging the potential temperature + ! tendencies. In the Thompson code, t1d is updated with tten*DT, where DT is dt_dyn/n_microp + ! Thus, the individual process tendencies need to be equivalently scaled + tend_theta_mp_evap_cw_p(:,:,:) = tend_theta_mp_evap_cw_p(:,:,:) / (n_microp * 1.0_RKIND) + tend_theta_mp_evap_rw_p(:,:,:) = tend_theta_mp_evap_rw_p(:,:,:) / (n_microp * 1.0_RKIND) + tend_theta_mp_depo_ice_p(:,:,:) = tend_theta_mp_depo_ice_p(:,:,:) / (n_microp * 1.0_RKIND) + tend_theta_mp_melt_ice_p(:,:,:) = tend_theta_mp_melt_ice_p(:,:,:) / (n_microp * 1.0_RKIND) + tend_theta_mp_frez_ice_p(:,:,:) = tend_theta_mp_frez_ice_p(:,:,:) / (n_microp * 1.0_RKIND) + call mpas_timer_stop('mp_thompson') case ("mp_thompson_aerosols") @@ -426,13 +458,29 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten nc = nc_p , nifa = nifa_p , nwfa = nwfa_p , & nifa2d = nifa2d_p , nwfa2d = nwfa2d_p , ntc = ntc_p , & muc = muc_p , & + tend_theta_mp_evap_cw = tend_theta_mp_evap_cw_p, tend_theta_mp_evap_rw = tend_theta_mp_evap_rw_p , & ! MC added + tend_theta_mp_depo_ice = tend_theta_mp_depo_ice_p, tend_theta_mp_melt_ice = tend_theta_mp_melt_ice_p , & ! MC added + tend_theta_mp_frez_ice = tend_theta_mp_frez_ice_p , & ! MC added + istep = istep , & ! MC added ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) - istep = istep + 1 - enddo - call mpas_timer_stop('mp_thompson_aerosols') + istep = istep + 1 + enddo + + ! MC added for microphysics process tendencies for PV diagnostics + ! Need to correct for possibility of n_microp != 1 by averaging the potential temperature + ! tendencies. In the Thompson code, t1d is updated with tten*DT, where DT is dt_dyn/n_microp + ! Thus, the individual process tendencies need to be equivalently scaled + tend_theta_mp_evap_cw_p(:,:,:) = tend_theta_mp_evap_cw_p(:,:,:) / (n_microp * 1.0_RKIND) + tend_theta_mp_evap_rw_p(:,:,:) = tend_theta_mp_evap_rw_p(:,:,:) / (n_microp * 1.0_RKIND) + tend_theta_mp_depo_ice_p(:,:,:) = tend_theta_mp_depo_ice_p(:,:,:) / (n_microp * 1.0_RKIND) + tend_theta_mp_melt_ice_p(:,:,:) = tend_theta_mp_melt_ice_p(:,:,:) / (n_microp * 1.0_RKIND) + tend_theta_mp_frez_ice_p(:,:,:) = tend_theta_mp_frez_ice_p(:,:,:) / (n_microp * 1.0_RKIND) + + call mpas_timer_stop('mp_thompson_aerosols') + case ("mp_wsm6") call mpas_timer_start('mp_wsm6') diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index 0f1e510792..714b2e9ea2 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -568,8 +568,13 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, ! MW: for ITM package logical, pointer :: config_tend - real(kind=RKIND), dimension(:,:), pointer :: qv_mp_tend + real(kind=RKIND), dimension(:,:), pointer :: qv_mp_tend + ! MC added for PV + logical, pointer :: config_pv_microphys + real(kind=RKIND), dimension(:,:), pointer :: tend_theta_mp_evap_cw,tend_theta_mp_evap_rw, & + tend_theta_mp_depo_ice,tend_theta_mp_melt_ice, & + tend_theta_mp_frez_ice !local variables: integer:: i,k,j @@ -603,6 +608,19 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, call mpas_pool_get_array(diag, 'qv_mp_tend', qv_mp_tend) end if + ! MC - PV microphysics tendencies for Thompson scheme + call mpas_pool_get_config(configs, 'config_pv_microphys', config_pv_microphys) + call mpas_log_write('atmphys_interface: called config_pv_microphys') + + if (config_pv_microphys) then + call mpas_log_write('atmphys_interface: calling get arrays') + call mpas_pool_get_array(diag_physics,'tend_theta_mp_evap_cw' ,tend_theta_mp_evap_cw ) ! MC added + call mpas_pool_get_array(diag_physics,'tend_theta_mp_evap_rw' ,tend_theta_mp_evap_rw ) ! MC added + call mpas_pool_get_array(diag_physics,'tend_theta_mp_depo_ice',tend_theta_mp_depo_ice) ! MC added + call mpas_pool_get_array(diag_physics,'tend_theta_mp_melt_ice',tend_theta_mp_melt_ice) ! MC added + call mpas_pool_get_array(diag_physics,'tend_theta_mp_frez_ice',tend_theta_mp_frez_ice) ! MC added + end if + !initialize variables needed in the cloud microphysics schemes: do j = jts, jte do k = kts, kte @@ -820,9 +838,11 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te real(kind=RKIND),dimension(:,:),pointer :: qv_mp_tend, acc_qv_mp_tend ! MC - for PV tendencies - logical, pointer :: config_pv_tend + logical, pointer :: config_pv_tend, config_pv_microphys real(kind=RKIND), dimension(:,:), pointer :: thmmpten, qvmpten - + real(kind=RKIND), dimension(:,:), pointer :: tend_theta_mp_evap_cw,tend_theta_mp_evap_rw, & + tend_theta_mp_depo_ice,tend_theta_mp_melt_ice, & + tend_theta_mp_frez_ice !local variables: integer:: icount integer:: i,k,j @@ -882,6 +902,17 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te qvmpten(:,:) = 0.0 end if + ! Adding for Thompson PV process tendencies + call mpas_pool_get_config(configs, 'config_pv_microphys', config_pv_microphys) + + if (config_pv_microphys) then + call mpas_pool_get_array(diag_physics,'tend_theta_mp_evap_cw' ,tend_theta_mp_evap_cw ) ! MC added + call mpas_pool_get_array(diag_physics,'tend_theta_mp_evap_rw' ,tend_theta_mp_evap_rw ) ! MC added + call mpas_pool_get_array(diag_physics,'tend_theta_mp_depo_ice',tend_theta_mp_depo_ice) ! MC added + call mpas_pool_get_array(diag_physics,'tend_theta_mp_melt_ice',tend_theta_mp_melt_ice) ! MC added + call mpas_pool_get_array(diag_physics,'tend_theta_mp_frez_ice',tend_theta_mp_frez_ice) ! MC added + end if + !update variables needed in the dynamical core: do j = jts,jte @@ -910,19 +941,32 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te pressure_p(k,i) = zz(k,i)*R_d*(exner(k,i)*rtheta_p(k,i) & + (exner(k,i)-exner_b(k,i))*rtheta_b(k,i)) - - ! MW on ITM: flux version MC ADDED + + ! ------------------------------ + ! For diagnostics packages: + ! ------------------------------ + ! MW on ITM: flux version if (config_tend) then acc_th_tend_diabatic(k,i) = acc_th_tend_diabatic(k,i) + rt_diabatic_tend(k,i) acc_qv_mp_tend(k,i) = acc_qv_mp_tend(k,i) + ( qv(k,i) - qv_mp_tend(k,i))/dt_dyn end if - ! MC: for PV + ! MC for PV tendencies: if (config_pv_tend) then thmmpten(k,i) = rt_diabatic_tend(k,i) qvmpten(k,i) = (qv(k,i) - qv_mp_tend(k,i))/dt_dyn end if + ! MC for PV microphysics process tendencies: + if (config_pv_microphys) then + tend_theta_mp_evap_cw(k,i) = tend_theta_mp_evap_cw_p(i,k,j) + tend_theta_mp_evap_rw(k,i) = tend_theta_mp_evap_rw_p(i,k,j) + tend_theta_mp_depo_ice(k,i) = tend_theta_mp_depo_ice_p(i,k,j) + tend_theta_mp_melt_ice(k,i) = tend_theta_mp_melt_ice_p(i,k,j) + tend_theta_mp_frez_ice(k,i) = tend_theta_mp_frez_ice_p(i,k,j) + end if + + enddo enddo enddo diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index 5485f8fef8..2ba08d9dc4 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -134,7 +134,8 @@ module mpas_atmphys_vars ! Laura D. Fowler (laura@ucar.edu) / 2024-02-14. ! * added and modified variables needed to run the MYNN PBL scheme using the sourcecode from WRF version 4.6. ! Laura D. Fowler (laura@ucar.edu) / 2024-02-18. - +! * added temporary variables for Thompson process tendencies for PV microphysics tendency diagnostics +! Manda Chasteen (chasteen@ucar.edu) / 2024-06-01 !================================================================================================================= !wrf-variables:these variables are needed to keep calls to different physics parameterizations @@ -285,7 +286,13 @@ module mpas_atmphys_vars recloud_p, &! reice_p, &! resnow_p, &! - refl10cm_p ! + refl10cm_p, &! + tend_theta_mp_evap_cw_p, &! MC added for PV microphysics process tendencies (K/s) + tend_theta_mp_evap_rw_p, &! MC added for PV microphysics process tendencies (K/s) + tend_theta_mp_depo_ice_p, &! MC added for PV microphysics process tendencies (K/s) + tend_theta_mp_frez_ice_p, &! MC added for PV microphysics process tendencies (K/s) + tend_theta_mp_melt_ice_p ! MC added for PV microphysics process tendencies (K/s) + !... for Thompson cloud microphysics parameterization, including aerosol-aware option: real(kind=RKIND),dimension(:,:),allocatable:: & diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F index 8e24340501..43d1616437 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F @@ -26,8 +26,17 @@ ! from (kts:kte) to (kts:kte+1) to match the dimensions of arrays vtgk, vtik, vtsk, and vtrk, in ! subroutine mp_thompson. ! Laura D. Fowler (laura@ucar.edu) / 2017-08-31. - - +! +! * Added the following variables to store the microphysics heating tendencies +! for individual processes to be used with the mpas_pv_diagnostics.F code +! Manda Chasteen (chasteen@ucar.edu) / 7 March 2023 +! +! tend_theta_mp_evap_cw: Net potential temperature heating rate from cloud water condensation and evaporation +! tend_theta_mp_evap_rw: Potential temperature heating rate from rain water evaporation +! tend_theta_mp_depo_ice: Net potential temperature heating rate from deposition and sublimation of all ice hydrometeors +! tend_theta_mp_melt_ice: Potential temperature heating rate from melting of all ice hydrometeors +! tend_theta_mp_frez_ice: Potential temperature heating rate from freezing/riming of all ice hydrometeors +! !+---+-----------------------------------------------------------------+ !.. This subroutine computes the moisture tendencies of water vapor, !.. cloud droplets, rain, cloud ice (pristine), snow, and graupel. @@ -1009,8 +1018,12 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & re_cloud, re_ice, re_snow, & has_reqc, has_reqi, has_reqs, & #if defined(mpas) - ntc,muc, & -#endif + ntc, muc, & + tend_theta_mp_evap_cw, tend_theta_mp_evap_rw, & ! MC added + tend_theta_mp_depo_ice, tend_theta_mp_melt_ice, & ! MC added + tend_theta_mp_frez_ice, & ! MC added + istep, & ! MC added +#endif ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte) ! tile dims @@ -1040,6 +1053,14 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & #if defined(mpas) REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN):: & ntc,muc + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & ! MC added + tend_theta_mp_evap_cw, tend_theta_mp_evap_rw, & ! MC added + tend_theta_mp_depo_ice, tend_theta_mp_melt_ice, & ! MC added + tend_theta_mp_frez_ice ! MC added + + INTEGER, INTENT(IN):: istep + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT), OPTIONAL:: & refl_10cm #else @@ -1056,6 +1077,12 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & t1d, p1d, w1d, dz1d, rho, dBZ REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d REAL, DIMENSION(kts:kte):: rainprod1d, evapprod1d +#if defined(mpas) + REAL, DIMENSION(kts:kte):: & + tend_temp_mp_evap_cw_1d, tend_temp_mp_evap_rw_1d, & ! MC added + tend_temp_mp_depo_ice_1d, tend_temp_mp_melt_ice_1d, & ! MC added + tend_temp_mp_frez_ice_1d ! MC added +#endif REAL, DIMENSION(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic REAL:: dt, pptrain, pptsnow, pptgraul, pptice REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max @@ -1119,6 +1146,17 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ! mp_debug(i:i) = char(0) ! enddo +#if defined(mpas) + ! MC -- if istep = 1, initialize tendencies as zero + if (istep .eq. 1) then + tend_theta_mp_evap_cw(:,:,:) = 0.0 + tend_theta_mp_evap_rw(:,:,:) = 0.0 + tend_theta_mp_depo_ice(:,:,:) = 0.0 + tend_theta_mp_frez_ice(:,:,:) = 0.0 + tend_theta_mp_melt_ice(:,:,:) = 0.0 + end if +#endif + ! if (.NOT. is_aerosol_aware .AND. PRESENT(nc) .AND. PRESENT(nwfa) & ! .AND. PRESENT(nifa) .AND. PRESENT(nwfa2d)) then ! write(mp_debug,*) 'WARNING, nc-nwfa-nifa-nwfa2d present but is_aerosol_aware is FALSE' @@ -1185,6 +1223,11 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dz1d, & pptrain, pptsnow, pptgraul, pptice, & rainprod1d, evapprod1d, & +#if defined(mpas) + tend_temp_mp_evap_cw_1d, tend_temp_mp_evap_rw_1d, & ! MC added + tend_temp_mp_depo_ice_1d, tend_temp_mp_melt_ice_1d, & ! MC added + tend_temp_mp_frez_ice_1d, & ! MC added +#endif kts, kte, dt, i, j) pcp_ra(i,j) = pptrain @@ -1233,6 +1276,15 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & #if defined(mpas) rainprod(i,k,j) = rainprod1d(k) evapprod(i,k,j) = evapprod1d(k) + + ! MC added below. Tendencies calculated in mp_thompson are temperature tendencies, so + ! need to convert to potential temperature tendency by dividing by exner function + ! and add to potential temperature tendencies already calculated in the case of n_microp > 1 + tend_theta_mp_evap_cw(i,k,j) = tend_theta_mp_evap_cw(i,k,j) + tend_temp_mp_evap_cw_1d(k)/pii(i,k,j) + tend_theta_mp_evap_rw(i,k,j) = tend_theta_mp_evap_rw(i,k,j) + tend_temp_mp_evap_rw_1d(k)/pii(i,k,j) + tend_theta_mp_depo_ice(i,k,j) = tend_theta_mp_depo_ice(i,k,j) + tend_temp_mp_depo_ice_1d(k)/pii(i,k,j) + tend_theta_mp_melt_ice(i,k,j) = tend_theta_mp_melt_ice(i,k,j) + tend_temp_mp_melt_ice_1d(k)/pii(i,k,j) + tend_theta_mp_frez_ice(i,k,j) = tend_theta_mp_frez_ice(i,k,j) + tend_temp_mp_frez_ice_1d(k)/pii(i,k,j) #endif if (qc1d(k) .gt. qc_max) then imax_qc = i @@ -1401,6 +1453,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dzq, & pptrain, pptsnow, pptgraul, pptice, & rainprod, evapprod, & +#if defined(mpas) + tend_temp_mp_evap_cw_1d,tend_temp_mp_evap_rw_1d, & ! MC added + tend_temp_mp_depo_ice_1d,tend_temp_mp_melt_ice_1d, & ! MC added + tend_temp_mp_frez_ice_1d, & +#endif kts, kte, dt, ii, jj) implicit none @@ -1415,6 +1472,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL, INTENT(IN):: dt REAL, DIMENSION(kts:kte), INTENT(INOUT):: & rainprod, evapprod +#if defined(mpas) + REAL, DIMENSION(kts:kte), INTENT(INOUT):: & + tend_temp_mp_evap_cw_1d,tend_temp_mp_evap_rw_1d, & ! MC added + tend_temp_mp_depo_ice_1d,tend_temp_mp_melt_ice_1d, & ! MC added + tend_temp_mp_frez_ice_1d ! MC added +#endif !..Local variables REAL, DIMENSION(kts:kte):: tten, qvten, qcten, qiten, & @@ -1623,6 +1686,15 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & do k = kts, kte rainprod(k) = 0. evapprod(k) = 0. + + ! MC added: MP scheme is an adjustment process that incrementally updates state variables over n_microp steps + ! need to zero these out at beginning of each step + tend_temp_mp_evap_cw_1d(k) = 0. + tend_temp_mp_evap_rw_1d(k) = 0. + tend_temp_mp_depo_ice_1d(k) = 0. + tend_temp_mp_melt_ice_1d(k) = 0. + tend_temp_mp_frez_ice_1d(k) = 0. + enddo !.. initialize the logicals L_nifa and L_nwfa used to detect instances of the cloud !.. ice and cloud liquid water mixing ratios being greater than R1 but their number @@ -2825,13 +2897,40 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + prg_rcs(k) + prs_rcs(k) & + prr_rci(k) + prg_rcg(k)) & )*orho * (1-IFDRY) +#if defined(mpas) + tend_temp_mp_depo_ice_1d(k) = tend_temp_mp_depo_ice_1d(k) & ! MC added: individual temperature tendency from sublimation/deposition of cloud ice, snow, and graupel + + (lsub*ocp(k)*(pri_inu(k) + pri_ide(k) & + + prs_ide(k) + prs_sde(k) & + + prg_gde(k) + pri_iha(k)) & + )*orho * (1-IFDRY) + + tend_temp_mp_frez_ice_1d(k) = tend_temp_mp_frez_ice_1d(k) & ! MC added: individual temperature tendency from freezing/riming + + (lfus2*ocp(k)*(pri_wfz(k) + pri_rfz(k) & + + prg_rfz(k) + prs_scw(k) & + + prg_scw(k) + prg_gcw(k) & + + prg_rcs(k) + prs_rcs(k) & + + prr_rci(k) + prg_rcg(k)) & + )*orho * (1-IFDRY) +#endif + else tten(k) = tten(k) & + ( lfus*ocp(k)*(-prr_sml(k) - prr_gml(k) & - prr_rcg(k) - prr_rcs(k)) & - + lsub*ocp(k)*(prs_sde(k) + prg_gde(k)) & + + lsub*ocp(k)*(prs_sde(k) + prg_gde(k)) & ! temperature tendency from sublimation/deposition )*orho * (1-IFDRY) - endif + +#if defined(mpas) + tend_temp_mp_melt_ice_1d(k) = tend_temp_mp_melt_ice_1d(k) & ! MC added: individual temperature tendency from melting + + (lfus*ocp(k)*(-prr_sml(k) - prr_gml(k) & + - prr_rcg(k) - prr_rcs(k)) & + )*orho * (1-IFDRY) + + tend_temp_mp_depo_ice_1d(k) = tend_temp_mp_depo_ice_1d(k) & ! MC added: individual temperature tendency from sublimation/deposition of snow and graupel + + (lsub*ocp(k)*(prs_sde(k) + prg_gde(k)) & + )*orho * (1-IFDRY) +#endif + endif enddo @@ -3118,6 +3217,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ncten(k) = ncten(k) + pnc_wcd(k) nwfaten(k) = nwfaten(k) - pnc_wcd(k) tten(k) = tten(k) + lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY) + +#if defined(mpas) + tend_temp_mp_evap_cw_1d(k) = tend_temp_mp_evap_cw_1d(k) & ! MC added: individual temperature tendency from evap/cond of cloud droplets + + (lvap(k)*ocp(k)*prw_vcd(k))*(1-IFDRY) ! Note: no orho factor here because it's incorporated into prw_vcd above +#endif + rc(k) = MAX(R1, (qc1d(k) + DT*qcten(k))*rho(k)) if (rc(k).eq.R1) L_qc(k) = .false. nc(k) = MAX(2., MIN((nc1d(k)+ncten(k)*DT)*rho(k), Nt_c_max)) @@ -3201,6 +3306,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nrten(k) = nrten(k) - pnr_rev(k) nwfaten(k) = nwfaten(k) + pnr_rev(k) tten(k) = tten(k) - lvap(k)*ocp(k)*prv_rev(k)*(1-IFDRY) + +#if defined(mpas) + tend_temp_mp_evap_rw_1d(k) = tend_temp_mp_evap_rw_1d(k) & ! MC added: individual temperature tendency from rain evaporation + - lvap(k)*ocp(k)*prv_rev(k)*(1-IFDRY) ! note: no orho factor here because it's included in prv_rev above +#endif rr(k) = MAX(R1, (qr1d(k) + DT*qrten(k))*rho(k)) qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k)) @@ -3556,6 +3666,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qiten(k) = qiten(k) - xri*odt niten(k) = -ni1d(k)*odt tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-IFDRY) + +#if defined(mpas) + tend_temp_mp_melt_ice_1d(k) = tend_temp_mp_melt_ice_1d(k) & ! MC added: individual temperature tendency from melting cloud ice + - lfus*ocp(k)*xri*odt*(1-IFDRY) ! note: xri includes 1/rho factor through qi1d(k) + qiten(k)*DT +#endif endif xrc = MAX(0.0, qc1d(k) + qcten(k)*DT) @@ -3567,6 +3682,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qcten(k) = qcten(k) - xrc*odt ncten(k) = ncten(k) - xnc*odt tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-IFDRY) + +#if defined(mpas) + tend_temp_mp_frez_ice_1d(k) = tend_temp_mp_frez_ice_1d(k) & ! MC added: individual temperature tendency from freezing cloud drops + + lfus2*ocp(k)*xrc*odt*(1-IFDRY) ! note: xrc includes 1/rho factor + +#endif endif enddo endif From c3f55d66d1315341e2ce90559f0e03b40e6b5cad Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Tue, 9 Jul 2024 18:44:07 -0600 Subject: [PATCH 14/23] MP var allocation if config_pv_microphys = .false. --- .../diagnostics/mpas_pv_diagnostics.F | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F index 5b1fab3b24..754d6b5cc9 100644 --- a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F @@ -2530,6 +2530,15 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph depv_dt_mp_frez_ice(:,:) = 0.0_RKIND depv_dt_mp_allproc(:,:) = 0.0_RKIND tend_theta_mp_sum(:,:) = 0.0_RKIND + depv_dt_mp_allproc(:,:) = 0.0_RKIND + else + allocate(depv_dt_mp_evap_cw(nVertLevels,nCells)) + allocate(depv_dt_mp_evap_rw(nVertLevels,nCells)) + allocate(depv_dt_mp_depo_ice(nVertLevels,nCells)) + allocate(depv_dt_mp_melt_ice(nVertLevels,nCells)) + allocate(depv_dt_mp_frez_ice(nVertLevels,nCells)) + allocate(depv_dt_mp_allproc(nVertLevels,nCells)) + allocate(tend_theta_mp_sum(nVertLevels,nCells)) end if !*********************************************************************************************** @@ -3261,6 +3270,14 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph deallocate(grad_diabatic_MP_melt) deallocate(grad_diabatic_MP_frez) deallocate(grad_diabatic_MP_sum) + else + deallocate(depv_dt_mp_evap_cw) + deallocate(depv_dt_mp_evap_rw) + deallocate(depv_dt_mp_depo_ice) + deallocate(depv_dt_mp_melt_ice) + deallocate(depv_dt_mp_frez_ice) + deallocate(depv_dt_mp_allproc) + deallocate(tend_theta_mp_sum) end if ! deallocate friction tendency variables From 4c8ce8921ed813cb8c2990432642beb650fa9130 Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Tue, 9 Jul 2024 18:44:36 -0600 Subject: [PATCH 15/23] Bug fix: add missing call to config_pv_microphys --- src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F index 754d6b5cc9..55902d8c27 100644 --- a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F @@ -3459,6 +3459,7 @@ subroutine atm_compute_pvBudget_diagnostics(domain, configs, state, diag, mesh, call exchange_halo_group(domain, 'diagnostics:dpv_mom_tend') call exchange_halo_group(domain, 'diagnostics:dpv_mom_curl') + call mpas_pool_get_config(configs, 'config_pv_microphys', config_pv_microphys) if (config_pv_microphys) then call exchange_halo_group(domain, 'diagnostics:dpv_mp_tend') end if From c3fb0f8f923bda06dc62182a1bdc4fb7c4590da2 Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Tue, 9 Jul 2024 18:58:45 -0600 Subject: [PATCH 16/23] Cleaned up mpas_isobaric_diagnostics.F This commit pertains to a series of modifications that clean up to currently existing isobaric diagnostics interpolation. The existing diagnostics comprise a number of variables at individual pressure levels (e.g., temperature_200hPa) and thus require a significant amount of hard-coding. This modified version reduces (but does not eliminate) the need for hard-coding by prescribing a list of isobaric levels to which the variables are commonly interpolated, leading to variables of the form e.g., temperature_isobaric. These variables are also connected to a diagnostic package and namelist config option (config_isobaric = .true.) to make it easier for users to toggle on their calculation at runtime. The specific changes include: - Adding an isobaric package to Registry.xml - Adding the config_isobaric namelist option to Registry_diagnostics.xml - Connecting the package variables to the namelist option in mpas_atm_diagnostics_packages.F - Updating Registry_isobaric.xml to remove the highly specific variables and replace them with more generalizable variables, such as temperature_isobaric - Updating Registry.xml to change the default diagnostics stream variables - Updating mpas_isobaric_diagnostics.F with the interpolation of the new generalizable variables and removal of the old variables. Subroutines are also added to clean up the code. - Adding halo groups 'isobaric:pressure_p' and 'isobaric:vorticity' to mpas_atm_halos.F and removing the previous halo field exchanges from mpas_isobaric_diagnostics.F - Updating mpas_atm_diagnostics_manager.F to include the halo exchange and config input arguments to the isobaric subroutine calls --- src/core_atmosphere/Registry.xml | 84 +- .../diagnostics/Registry_diagnostics.xml | 3 +- .../diagnostics/Registry_isobaric.xml | 252 +-- .../mpas_atm_diagnostics_manager.F | 6 +- .../mpas_atm_diagnostics_packages.F | 30 + .../diagnostics/mpas_isobaric_diagnostics.F | 1562 +++++++---------- src/core_atmosphere/mpas_atm_halos.F | 30 +- 7 files changed, 804 insertions(+), 1163 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 7945cfbda9..beec5245e9 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -411,6 +411,7 @@ + @@ -1031,76 +1032,19 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + #ifdef DO_PHYSICS diff --git a/src/core_atmosphere/diagnostics/Registry_diagnostics.xml b/src/core_atmosphere/diagnostics/Registry_diagnostics.xml index fb6d55badf..f7ab530dfb 100644 --- a/src/core_atmosphere/diagnostics/Registry_diagnostics.xml +++ b/src/core_atmosphere/diagnostics/Registry_diagnostics.xml @@ -28,8 +28,9 @@ + - diff --git a/src/core_atmosphere/diagnostics/Registry_isobaric.xml b/src/core_atmosphere/diagnostics/Registry_isobaric.xml index 853be6cde3..ce533d45d3 100644 --- a/src/core_atmosphere/diagnostics/Registry_isobaric.xml +++ b/src/core_atmosphere/diagnostics/Registry_isobaric.xml @@ -3,224 +3,74 @@ - - - + + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + - + + - + - + - + - + - + - + - + - + - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + - - - - + description="Mean temperature in the 500-300 hPa layer" + packages="isobaric"/> diff --git a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F index 4d093f6079..7fe2b51590 100644 --- a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F +++ b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F @@ -78,7 +78,7 @@ subroutine mpas_atm_diag_setup(stream_mgr, configs, structs, clock, dminfo) call mpas_atm_diag_utils_init(stream_mgr) call diagnostic_template_setup(configs, structs, clock) - call isobaric_diagnostics_setup(structs, clock) + call isobaric_diagnostics_setup(configs, structs, clock) ! MC modified with configs arg call cloud_diagnostics_setup(structs, clock) call convective_diagnostics_setup(structs, clock) call soundings_setup(configs, structs, clock, dminfo) @@ -147,11 +147,11 @@ subroutine mpas_atm_diag_compute(domain, exchange_halo_group) call diagnostic_template_compute() - call isobaric_diagnostics_compute() call cloud_diagnostics_compute() call convective_diagnostics_compute() call soundings_compute() - + !call isobaric_diagnostics_compute() + call isobaric_diagnostics_compute(domain, exchange_halo_group) ! MC modified for new halo call mpas_timer_start('Tendency and PV diagnostics') call pv_diagnostics_compute(domain, exchange_halo_group) call mpas_timer_stop('Tendency and PV diagnostics') diff --git a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_packages.F b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_packages.F index c1876eb859..2d1d08e615 100644 --- a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_packages.F +++ b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_packages.F @@ -59,6 +59,12 @@ function diagnostics_setup_packages(configs, packages, iocontext) result(ierr) logical, pointer :: pv_diagnosticsActive, pv_tendenciesActive, pv_scalarActive, & pv_microphysicsActive, pv_isobaricActive + ! Isobaric diagnostics config: + logical, pointer :: config_isobaric + + ! Isobaric diagnostics package: + logical, pointer :: isobaricActive + integer :: ierr !----------------------------------------------------------------------------------------------------------------- @@ -68,6 +74,30 @@ function diagnostics_setup_packages(configs, packages, iocontext) result(ierr) ierr = 0 +!----------------------------------------------------------------------------------------------------------------- +!--- initialization of package of isobaric diagnostics +!----------------------------------------------------------------------------------------------------------------- + + call mpas_log_write('----- Setting up isobaric diagnostics variables -----') + call mpas_log_write('') + + nullify(config_isobaric) + call mpas_pool_get_config(configs, 'config_isobaric', config_isobaric) + + nullify(isobaricActive) + call mpas_pool_get_package(packages, 'isobaricActive', isobaricActive) + + if (associated(config_isobaric) .and. associated(isobaricActive)) then + isobaricActive = config_isobaric + call mpas_log_write(' isobaricActive = $l', logicArgs=(/isobaricActive/)) + else + ierr = ierr + 1 + call mpas_log_write('Package setup failed for ''isobaric''. '// & + 'Either ''isobaric'' is not a package, or ''config_isobaric'' is not a namelist option.', & + messageType=MPAS_LOG_ERR) + end if + + !----------------------------------------------------------------------------------------------------------------- !--- initialization of package for model tendency diagnostics: !----------------------------------------------------------------------------------------------------------------- diff --git a/src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F index e52c71b125..00c7adc242 100644 --- a/src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F @@ -11,32 +11,44 @@ module mpas_isobaric_diagnostics use mpas_kind_types use mpas_derived_types use mpas_pool_routines - use mpas_constants + use mpas_constants, only: rvord, r_earth=>a use mpas_log, only : mpas_log_write type (MPAS_pool_type), pointer :: mesh type (MPAS_pool_type), pointer :: state type (MPAS_pool_type), pointer :: diag + type (MPAS_pool_type), pointer :: configs type (MPAS_clock_type), pointer :: clock + type (domain_type), pointer :: domain + + ! + ! 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 + public :: isobaric_diagnostics_setup, & isobaric_diagnostics_compute private - logical :: need_mslp, & - need_relhum_50, need_relhum_100, need_relhum_200, need_relhum_250, need_relhum_500, need_relhum_700, need_relhum_850, need_relhum_925, & - need_dewpoint_50, need_dewpoint_100, need_dewpoint_200, need_dewpoint_250, need_dewpoint_500, need_dewpoint_700, need_dewpoint_850, need_dewpoint_925, & - need_temp_50, need_temp_100, need_temp_200, need_temp_250, need_temp_500, need_temp_700, need_temp_850, need_temp_925, & - need_height_50, need_height_100, need_height_200, need_height_250, need_height_500, need_height_700, need_height_850, need_height_925, & - need_uzonal_50, need_uzonal_100, need_uzonal_200, need_uzonal_250, need_uzonal_500, need_uzonal_700, need_uzonal_850, need_uzonal_925, & - need_umeridional_50, need_umeridional_100, need_umeridional_200, need_umeridional_250, need_umeridional_500, need_umeridional_700, need_umeridional_850, need_umeridional_925, & - need_w_50, need_w_100, need_w_200, need_w_250, need_w_500, need_w_700, need_w_850, need_w_925, & - need_vorticity_50, need_vorticity_100, need_vorticity_200, need_vorticity_250, need_vorticity_500, need_vorticity_700, need_vorticity_850, need_vorticity_925, & - need_t_isobaric, need_z_isobaric, need_meanT_500_300 - logical :: need_temp, need_relhum, need_dewpoint, need_w, need_uzonal, need_umeridional, need_vorticity, need_height + logical :: need_mslp, need_meanT_500_300, & + need_temp_isobaric, need_theta_isobaric, need_dewp_isobaric, need_relhum_isobaric, need_qv_isobaric, & + need_uzonal_isobaric, need_umerid_isobaric, & + need_hgt_isobaric, need_geohgt_isobaric, need_w_isobaric, need_vort_isobaric contains @@ -50,24 +62,59 @@ module mpas_isobaric_diagnostics !> \details !> This routine sets up the isobaric diagnostics module, principally by !> saving pointers to pools that are used in the computation of diagnostics. - ! + !> + !> MC: added specification of isobaric levels to this subroutine !----------------------------------------------------------------------- - subroutine isobaric_diagnostics_setup(all_pools, simulation_clock) + subroutine isobaric_diagnostics_setup(configs_in, all_pools, simulation_clock) use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type - use mpas_pool_routines, only : mpas_pool_get_subpool + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_config + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array implicit none - + + type (MPAS_pool_type), pointer :: configs_in type (MPAS_pool_type), pointer :: all_pools type (MPAS_clock_type), pointer :: simulation_clock - clock => simulation_clock + logical, pointer :: config_isobaric + + ! Isobaric levels for interpolation + integer, pointer :: nIsoLevels + real (kind=RKIND), dimension(:), pointer :: iso_levels call mpas_pool_get_subpool(all_pools, 'mesh', mesh) call mpas_pool_get_subpool(all_pools, 'state', state) call mpas_pool_get_subpool(all_pools, 'diag', diag) - + + clock => simulation_clock + configs => configs_in + + ! check config_isobaric: + call mpas_pool_get_config(configs, 'config_isobaric', config_isobaric) + + call mpas_log_write(' ') + call mpas_log_write(' config_isobaric is: $l', logicArgs=(/config_isobaric/)) + call mpas_log_write(' ') + + if (config_isobaric) then + call mpas_log_write(' ') + call mpas_log_write(' ----- Setting up isobaric diagnostics ----- ') + call mpas_log_write(' ') + + call mpas_pool_get_dimension(mesh, 'nIsoLevels', nIsoLevels) + call mpas_pool_get_array(diag, 'iso_levels', iso_levels) + + call mpas_log_write(' Number of isobaric levels: $i', intArgs=(/nIsoLevels/)) + iso_levels = 0.0 + + ! Define isobaric levels. + iso_levels(:) = (/10000.0, 12500.0, 15000.0, 17500.0, 20000.0, 22500.0, 25000.0, 27500.0, 30000.0, & + 32500.0, 35000.0, 40000.0, 45000.0, 50000.0, 55000.0, 60000.0, 65000.0, 70000.0, & + 75000.0, 77500.0, 80000.0, 82500.0, 85000.0, 87500.0, 90000.0, 92500.0, 95000.0, 100000.0/) + + end if + end subroutine isobaric_diagnostics_setup @@ -82,924 +129,324 @@ end subroutine isobaric_diagnostics_setup !> from here was previously in mpas_atm_interp_diagnostics.F. ! !----------------------------------------------------------------------- - subroutine isobaric_diagnostics_compute() + subroutine isobaric_diagnostics_compute(domain, exchange_halo_group) use mpas_atm_diagnostics_utils, only : MPAS_field_will_be_written + use mpas_pool_routines, only: mpas_pool_get_config implicit none + type (domain_type), intent(inout) :: domain ! MC: halo exchange + procedure (halo_exchange_routine) :: exchange_halo_group ! MC: halo exchange + logical :: need_any_diags + logical, pointer :: config_isobaric need_any_diags = .false. - need_temp = .false. - need_dewpoint = .false. - need_relhum = .false. - need_w = .false. - need_uzonal = .false. - need_umeridional = .false. - need_vorticity = .false. - need_height = .false. - - need_mslp = MPAS_field_will_be_written('mslp') - need_any_diags = need_any_diags .or. need_mslp - need_relhum_50 = MPAS_field_will_be_written('relhum_50hPa') - need_relhum = need_relhum .or. need_relhum_50 - need_any_diags = need_any_diags .or. need_relhum_50 - need_relhum_100 = MPAS_field_will_be_written('relhum_100hPa') - need_relhum = need_relhum .or. need_relhum_100 - need_any_diags = need_any_diags .or. need_relhum_100 - need_relhum_200 = MPAS_field_will_be_written('relhum_200hPa') - need_relhum = need_relhum .or. need_relhum_200 - need_any_diags = need_any_diags .or. need_relhum_200 - need_relhum_250 = MPAS_field_will_be_written('relhum_250hPa') - need_relhum = need_relhum .or. need_relhum_250 - need_any_diags = need_any_diags .or. need_relhum_250 - need_relhum_500 = MPAS_field_will_be_written('relhum_500hPa') - need_relhum = need_relhum .or. need_relhum_500 - need_any_diags = need_any_diags .or. need_relhum_500 - need_relhum_700 = MPAS_field_will_be_written('relhum_700hPa') - need_relhum = need_relhum .or. need_relhum_700 - need_any_diags = need_any_diags .or. need_relhum_700 - need_relhum_850 = MPAS_field_will_be_written('relhum_850hPa') - need_relhum = need_relhum .or. need_relhum_850 - need_any_diags = need_any_diags .or. need_relhum_850 - need_relhum_925 = MPAS_field_will_be_written('relhum_925hPa') - need_relhum = need_relhum .or. need_relhum_925 - need_any_diags = need_any_diags .or. need_relhum_925 - need_dewpoint_50 = MPAS_field_will_be_written('dewpoint_50hPa') - need_dewpoint = need_dewpoint .or. need_dewpoint_50 - need_any_diags = need_any_diags .or. need_dewpoint_50 - need_dewpoint_100 = MPAS_field_will_be_written('dewpoint_100hPa') - need_dewpoint = need_dewpoint .or. need_dewpoint_100 - need_any_diags = need_any_diags .or. need_dewpoint_100 - need_dewpoint_200 = MPAS_field_will_be_written('dewpoint_200hPa') - need_dewpoint = need_dewpoint .or. need_dewpoint_200 - need_any_diags = need_any_diags .or. need_dewpoint_200 - need_dewpoint_250 = MPAS_field_will_be_written('dewpoint_250hPa') - need_dewpoint = need_dewpoint .or. need_dewpoint_250 - need_any_diags = need_any_diags .or. need_dewpoint_250 - need_dewpoint_500 = MPAS_field_will_be_written('dewpoint_500hPa') - need_dewpoint = need_dewpoint .or. need_dewpoint_500 - need_any_diags = need_any_diags .or. need_dewpoint_500 - need_dewpoint_700 = MPAS_field_will_be_written('dewpoint_700hPa') - need_dewpoint = need_dewpoint .or. need_dewpoint_700 - need_any_diags = need_any_diags .or. need_dewpoint_700 - need_dewpoint_850 = MPAS_field_will_be_written('dewpoint_850hPa') - need_dewpoint = need_dewpoint .or. need_dewpoint_850 - need_any_diags = need_any_diags .or. need_dewpoint_850 - need_dewpoint_925 = MPAS_field_will_be_written('dewpoint_925hPa') - need_dewpoint = need_dewpoint .or. need_dewpoint_925 - need_any_diags = need_any_diags .or. need_dewpoint_925 - need_temp_50 = MPAS_field_will_be_written('temperature_50hPa') - need_temp = need_temp .or. need_temp_50 - need_any_diags = need_any_diags .or. need_temp_50 - need_temp_100 = MPAS_field_will_be_written('temperature_100hPa') - need_temp = need_temp .or. need_temp_100 - need_any_diags = need_any_diags .or. need_temp_100 - need_temp_200 = MPAS_field_will_be_written('temperature_200hPa') - need_temp = need_temp .or. need_temp_200 - need_any_diags = need_any_diags .or. need_temp_200 - need_temp_250 = MPAS_field_will_be_written('temperature_250hPa') - need_temp = need_temp .or. need_temp_250 - need_any_diags = need_any_diags .or. need_temp_250 - need_temp_500 = MPAS_field_will_be_written('temperature_500hPa') - need_temp = need_temp .or. need_temp_500 - need_any_diags = need_any_diags .or. need_temp_500 - need_temp_700 = MPAS_field_will_be_written('temperature_700hPa') - need_temp = need_temp .or. need_temp_700 - need_any_diags = need_any_diags .or. need_temp_700 - need_temp_850 = MPAS_field_will_be_written('temperature_850hPa') - need_temp = need_temp .or. need_temp_850 - need_any_diags = need_any_diags .or. need_temp_850 - need_temp_925 = MPAS_field_will_be_written('temperature_925hPa') - need_temp = need_temp .or. need_temp_925 - need_any_diags = need_any_diags .or. need_temp_925 - need_height_50 = MPAS_field_will_be_written('height_50hPa') - need_height = need_height .or. need_height_50 - need_any_diags = need_any_diags .or. need_height_50 - need_height_100 = MPAS_field_will_be_written('height_100hPa') - need_height = need_height .or. need_height_100 - need_any_diags = need_any_diags .or. need_height_100 - need_height_200 = MPAS_field_will_be_written('height_200hPa') - need_height = need_height .or. need_height_200 - need_any_diags = need_any_diags .or. need_height_200 - need_height_250 = MPAS_field_will_be_written('height_250hPa') - need_height = need_height .or. need_height_250 - need_any_diags = need_any_diags .or. need_height_250 - need_height_500 = MPAS_field_will_be_written('height_500hPa') - need_height = need_height .or. need_height_500 - need_any_diags = need_any_diags .or. need_height_500 - need_height_700 = MPAS_field_will_be_written('height_700hPa') - need_height = need_height .or. need_height_700 - need_any_diags = need_any_diags .or. need_height_700 - need_height_850 = MPAS_field_will_be_written('height_850hPa') - need_height = need_height .or. need_height_850 - need_any_diags = need_any_diags .or. need_height_850 - need_height_925 = MPAS_field_will_be_written('height_925hPa') - need_height = need_height .or. need_height_925 - need_any_diags = need_any_diags .or. need_height_925 - need_uzonal_50 = MPAS_field_will_be_written('uzonal_50hPa') - need_uzonal = need_uzonal .or. need_uzonal_50 - need_any_diags = need_any_diags .or. need_uzonal_50 - need_uzonal_100 = MPAS_field_will_be_written('uzonal_100hPa') - need_uzonal = need_uzonal .or. need_uzonal_100 - need_any_diags = need_any_diags .or. need_uzonal_100 - need_uzonal_200 = MPAS_field_will_be_written('uzonal_200hPa') - need_uzonal = need_uzonal .or. need_uzonal_200 - need_any_diags = need_any_diags .or. need_uzonal_200 - need_uzonal_250 = MPAS_field_will_be_written('uzonal_250hPa') - need_uzonal = need_uzonal .or. need_uzonal_250 - need_any_diags = need_any_diags .or. need_uzonal_250 - need_uzonal_500 = MPAS_field_will_be_written('uzonal_500hPa') - need_uzonal = need_uzonal .or. need_uzonal_500 - need_any_diags = need_any_diags .or. need_uzonal_500 - need_uzonal_700 = MPAS_field_will_be_written('uzonal_700hPa') - need_uzonal = need_uzonal .or. need_uzonal_700 - need_any_diags = need_any_diags .or. need_uzonal_700 - need_uzonal_850 = MPAS_field_will_be_written('uzonal_850hPa') - need_uzonal = need_uzonal .or. need_uzonal_850 - need_any_diags = need_any_diags .or. need_uzonal_850 - need_uzonal_925 = MPAS_field_will_be_written('uzonal_925hPa') - need_uzonal = need_uzonal .or. need_uzonal_925 - need_any_diags = need_any_diags .or. need_uzonal_925 - need_umeridional_50 = MPAS_field_will_be_written('umeridional_50hPa') - need_umeridional = need_umeridional .or. need_umeridional_50 - need_any_diags = need_any_diags .or. need_umeridional_50 - need_umeridional_100 = MPAS_field_will_be_written('umeridional_100hPa') - need_umeridional = need_umeridional .or. need_umeridional_100 - need_any_diags = need_any_diags .or. need_umeridional_100 - need_umeridional_200 = MPAS_field_will_be_written('umeridional_200hPa') - need_umeridional = need_umeridional .or. need_umeridional_200 - need_any_diags = need_any_diags .or. need_umeridional_200 - need_umeridional_250 = MPAS_field_will_be_written('umeridional_250hPa') - need_umeridional = need_umeridional .or. need_umeridional_250 - need_any_diags = need_any_diags .or. need_umeridional_250 - need_umeridional_500 = MPAS_field_will_be_written('umeridional_500hPa') - need_umeridional = need_umeridional .or. need_umeridional_500 - need_any_diags = need_any_diags .or. need_umeridional_500 - need_umeridional_700 = MPAS_field_will_be_written('umeridional_700hPa') - need_umeridional = need_umeridional .or. need_umeridional_700 - need_any_diags = need_any_diags .or. need_umeridional_700 - need_umeridional_850 = MPAS_field_will_be_written('umeridional_850hPa') - need_umeridional = need_umeridional .or. need_umeridional_850 - need_any_diags = need_any_diags .or. need_umeridional_850 - need_umeridional_925 = MPAS_field_will_be_written('umeridional_925hPa') - need_umeridional = need_umeridional .or. need_umeridional_925 - need_any_diags = need_any_diags .or. need_umeridional_925 - need_w_50 = MPAS_field_will_be_written('w_50hPa') - need_w = need_w .or. need_w_50 - need_any_diags = need_any_diags .or. need_w_50 - need_w_100 = MPAS_field_will_be_written('w_100hPa') - need_w = need_w .or. need_w_100 - need_any_diags = need_any_diags .or. need_w_100 - need_w_200 = MPAS_field_will_be_written('w_200hPa') - need_w = need_w .or. need_w_200 - need_any_diags = need_any_diags .or. need_w_200 - need_w_250 = MPAS_field_will_be_written('w_250hPa') - need_w = need_w .or. need_w_250 - need_any_diags = need_any_diags .or. need_w_250 - need_w_500 = MPAS_field_will_be_written('w_500hPa') - need_w = need_w .or. need_w_500 - need_any_diags = need_any_diags .or. need_w_500 - need_w_700 = MPAS_field_will_be_written('w_700hPa') - need_w = need_w .or. need_w_700 - need_any_diags = need_any_diags .or. need_w_700 - need_w_850 = MPAS_field_will_be_written('w_850hPa') - need_w = need_w .or. need_w_850 - need_any_diags = need_any_diags .or. need_w_850 - need_w_925 = MPAS_field_will_be_written('w_925hPa') - need_w = need_w .or. need_w_925 - need_any_diags = need_any_diags .or. need_w_925 - need_vorticity_50 = MPAS_field_will_be_written('vorticity_50hPa') - need_vorticity = need_vorticity .or. need_vorticity_50 - need_any_diags = need_any_diags .or. need_vorticity_50 - need_vorticity_100 = MPAS_field_will_be_written('vorticity_100hPa') - need_vorticity = need_vorticity .or. need_vorticity_100 - need_any_diags = need_any_diags .or. need_vorticity_100 - need_vorticity_200 = MPAS_field_will_be_written('vorticity_200hPa') - need_vorticity = need_vorticity .or. need_vorticity_200 - need_any_diags = need_any_diags .or. need_vorticity_200 - need_vorticity_250 = MPAS_field_will_be_written('vorticity_250hPa') - need_vorticity = need_vorticity .or. need_vorticity_250 - need_any_diags = need_any_diags .or. need_vorticity_250 - need_vorticity_500 = MPAS_field_will_be_written('vorticity_500hPa') - need_vorticity = need_vorticity .or. need_vorticity_500 - need_any_diags = need_any_diags .or. need_vorticity_500 - need_vorticity_700 = MPAS_field_will_be_written('vorticity_700hPa') - need_vorticity = need_vorticity .or. need_vorticity_700 - need_any_diags = need_any_diags .or. need_vorticity_700 - need_vorticity_850 = MPAS_field_will_be_written('vorticity_850hPa') - need_vorticity = need_vorticity .or. need_vorticity_850 - need_any_diags = need_any_diags .or. need_vorticity_850 - need_vorticity_925 = MPAS_field_will_be_written('vorticity_925hPa') - need_vorticity = need_vorticity .or. need_vorticity_925 - need_any_diags = need_any_diags .or. need_vorticity_925 - need_t_isobaric = MPAS_field_will_be_written('t_isobaric') - need_any_diags = need_any_diags .or. need_t_isobaric - need_z_isobaric = MPAS_field_will_be_written('z_isobaric') - need_any_diags = need_any_diags .or. need_z_isobaric - need_meanT_500_300 = MPAS_field_will_be_written('meanT_500_300') - need_any_diags = need_any_diags .or. need_meanT_500_300 - - if (need_any_diags) then - call interp_diagnostics(mesh, state, 1, diag) - end if - + need_mslp = .false. + need_meanT_500_300 = .false. + + need_temp_isobaric = .false. + need_theta_isobaric = .false. + need_dewp_isobaric = .false. + need_relhum_isobaric = .false. + need_qv_isobaric = .false. + need_uzonal_isobaric = .false. + need_umerid_isobaric = .false. + need_hgt_isobaric = .false. + need_geohgt_isobaric = .false. + need_w_isobaric = .false. + need_vort_isobaric = .false. + + call mpas_pool_get_config(configs, 'config_isobaric', config_isobaric) + + if (config_isobaric) then + need_mslp = MPAS_field_will_be_written('mslp') + need_meanT_500_300 = MPAS_field_will_be_written('meanT_500_300') + + need_temp_isobaric = MPAS_field_will_be_written('temperature_isobaric') + need_temp_isobaric = need_temp_isobaric .or. need_meanT_500_300 + + need_theta_isobaric = MPAS_field_will_be_written('theta_isobaric') + need_dewp_isobaric = MPAS_field_will_be_written('dewpoint_isobaric') + need_relhum_isobaric = MPAS_field_will_be_written('relhum_isobaric') + need_qv_isobaric = MPAS_field_will_be_written('qvapor_isobaric') + need_uzonal_isobaric = MPAS_field_will_be_written('uzonal_isobaric') + need_umerid_isobaric = MPAS_field_will_be_written('umeridional_isobaric') + need_hgt_isobaric = MPAS_field_will_be_written('height_isobaric') + need_geohgt_isobaric = MPAS_field_will_be_written('geoheight_isobaric') + need_w_isobaric = MPAS_field_will_be_written('w_isobaric') + need_vort_isobaric = MPAS_field_will_be_written('vorticity_isobaric') + + need_any_diags = need_any_diags .or. need_mslp .or. need_meanT_500_300 .or. & + need_temp_isobaric .or. need_theta_isobaric .or. need_dewp_isobaric .or. & + need_relhum_isobaric .or. need_qv_isobaric .or. need_uzonal_isobaric .or. & + need_umerid_isobaric .or. need_hgt_isobaric .or. need_geohgt_isobaric .or. & + need_w_isobaric .or. need_vort_isobaric + + if (need_any_diags) then + call mpas_log_write('Calling isobaric interpolation subroutine.') + call interp_diagnostics(domain, mesh, state, 1, diag, exchange_halo_group) + end if + end if + end subroutine isobaric_diagnostics_compute !================================================================================================== - subroutine interp_diagnostics(mesh, state, time_lev, diag) + subroutine interp_diagnostics(domain, mesh, state, time_lev, diag, exchange_halo_group) + ! + !> MC: Interpolates conventional model fields (e.g., potential temperature) to array of prescribed + ! isobaric levels !================================================================================================== - !input arguments: + implicit none + + ! Input arguments: type (mpas_pool_type), intent(in) :: mesh + type (domain_type), intent(inout) :: domain ! MC: halo exchange type (mpas_pool_type), intent(in) :: state - integer, intent(in) :: time_lev ! which time level to use from state - - !inout arguments: + integer, intent(in) :: time_lev ! which time level to use from state type (mpas_pool_type), intent(inout) :: diag - - !local variables: - integer :: iCell,iVert,iVertD,k,kk - integer, pointer :: nCells, nCellsSolve, nVertLevels, nVertices, vertexDegree, nIsoLevelsT, nIsoLevelsZ - integer :: nVertLevelsP1 + procedure (halo_exchange_routine) :: exchange_halo_group ! MC: halo exchange + + ! Local variables + integer :: iCell, k, kk + + ! Mesh variables and dimensions integer, pointer :: index_qv, num_scalars - integer, dimension(:,:), pointer :: cellsOnVertex - - type (field2DReal), pointer:: pressure_p_field - - real (kind=RKIND), dimension(:), pointer :: areaTriangle + integer, pointer :: nCells, nVertLevels + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: verticesOnCell, cellsOnVertex + real (kind=RKIND), dimension(:), pointer :: areaCell real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex - real (kind=RKIND), dimension(:,:), pointer :: exner, height - real (kind=RKIND), dimension(:,:), pointer :: pressure_b, pressure_p - real (kind=RKIND), dimension(:,:), pointer :: relhum, theta_m, vorticity - real (kind=RKIND), dimension(:,:), pointer :: umeridional, uzonal, vvel - real (kind=RKIND), dimension(:,:,:), pointer :: scalars - - real (kind=RKIND), dimension(:), pointer :: t_iso_levels - real (kind=RKIND), dimension(:), pointer :: z_iso_levels - real (kind=RKIND), dimension(:,:), pointer :: t_isobaric - real (kind=RKIND), dimension(:,:), pointer :: z_isobaric - real (kind=RKIND), dimension(:), pointer :: meanT_500_300 - - real (kind=RKIND), dimension(:), pointer :: temperature_50hPa - real (kind=RKIND), dimension(:), pointer :: temperature_100hPa - real (kind=RKIND), dimension(:), pointer :: temperature_200hPa - real (kind=RKIND), dimension(:), pointer :: temperature_250hPa - real (kind=RKIND), dimension(:), pointer :: temperature_500hPa - real (kind=RKIND), dimension(:), pointer :: temperature_700hPa - real (kind=RKIND), dimension(:), pointer :: temperature_850hPa - real (kind=RKIND), dimension(:), pointer :: temperature_925hPa - - real (kind=RKIND), dimension(:), pointer :: relhum_50hPa - real (kind=RKIND), dimension(:), pointer :: relhum_100hPa - real (kind=RKIND), dimension(:), pointer :: relhum_200hPa - real (kind=RKIND), dimension(:), pointer :: relhum_250hPa - real (kind=RKIND), dimension(:), pointer :: relhum_500hPa - real (kind=RKIND), dimension(:), pointer :: relhum_700hPa - real (kind=RKIND), dimension(:), pointer :: relhum_850hPa - real (kind=RKIND), dimension(:), pointer :: relhum_925hPa - - real (kind=RKIND), dimension(:), pointer :: dewpoint_50hPa - real (kind=RKIND), dimension(:), pointer :: dewpoint_100hPa - real (kind=RKIND), dimension(:), pointer :: dewpoint_200hPa - real (kind=RKIND), dimension(:), pointer :: dewpoint_250hPa - real (kind=RKIND), dimension(:), pointer :: dewpoint_500hPa - real (kind=RKIND), dimension(:), pointer :: dewpoint_700hPa - real (kind=RKIND), dimension(:), pointer :: dewpoint_850hPa - real (kind=RKIND), dimension(:), pointer :: dewpoint_925hPa - - real (kind=RKIND), dimension(:), pointer :: uzonal_50hPa - real (kind=RKIND), dimension(:), pointer :: uzonal_100hPa - real (kind=RKIND), dimension(:), pointer :: uzonal_200hPa - real (kind=RKIND), dimension(:), pointer :: uzonal_250hPa - real (kind=RKIND), dimension(:), pointer :: uzonal_500hPa - real (kind=RKIND), dimension(:), pointer :: uzonal_700hPa - real (kind=RKIND), dimension(:), pointer :: uzonal_850hPa - real (kind=RKIND), dimension(:), pointer :: uzonal_925hPa - - real (kind=RKIND), dimension(:), pointer :: umeridional_50hPa - real (kind=RKIND), dimension(:), pointer :: umeridional_100hPa - real (kind=RKIND), dimension(:), pointer :: umeridional_200hPa - real (kind=RKIND), dimension(:), pointer :: umeridional_250hPa - real (kind=RKIND), dimension(:), pointer :: umeridional_500hPa - real (kind=RKIND), dimension(:), pointer :: umeridional_700hPa - real (kind=RKIND), dimension(:), pointer :: umeridional_850hPa - real (kind=RKIND), dimension(:), pointer :: umeridional_925hPa - - real (kind=RKIND), dimension(:), pointer :: height_50hPa - real (kind=RKIND), dimension(:), pointer :: height_100hPa - real (kind=RKIND), dimension(:), pointer :: height_200hPa - real (kind=RKIND), dimension(:), pointer :: height_250hPa - real (kind=RKIND), dimension(:), pointer :: height_500hPa - real (kind=RKIND), dimension(:), pointer :: height_700hPa - real (kind=RKIND), dimension(:), pointer :: height_850hPa - real (kind=RKIND), dimension(:), pointer :: height_925hPa - - real (kind=RKIND), dimension(:), pointer :: w_50hPa - real (kind=RKIND), dimension(:), pointer :: w_100hPa - real (kind=RKIND), dimension(:), pointer :: w_200hPa - real (kind=RKIND), dimension(:), pointer :: w_250hPa - real (kind=RKIND), dimension(:), pointer :: w_500hPa - real (kind=RKIND), dimension(:), pointer :: w_700hPa - real (kind=RKIND), dimension(:), pointer :: w_850hPa - real (kind=RKIND), dimension(:), pointer :: w_925hPa - - real (kind=RKIND), dimension(:), pointer :: vorticity_50hPa - real (kind=RKIND), dimension(:), pointer :: vorticity_100hPa - real (kind=RKIND), dimension(:), pointer :: vorticity_200hPa - real (kind=RKIND), dimension(:), pointer :: vorticity_250hPa - real (kind=RKIND), dimension(:), pointer :: vorticity_500hPa - real (kind=RKIND), dimension(:), pointer :: vorticity_700hPa - real (kind=RKIND), dimension(:), pointer :: vorticity_850hPa - real (kind=RKIND), dimension(:), pointer :: vorticity_925hPa - + ! Isobaric levels for interpolation + integer, pointer :: nIsoLevels + + ! Isolevels for all fields + real (kind=RKIND), dimension(:), pointer :: iso_levels + + ! Pressure variables + real (kind=RKIND), dimension(:,:), pointer :: pressure_b, pressure_p + real (kind=RKIND), dimension(:,:), allocatable :: pressure + + ! Fields to be interpolated (or from which fields are derived) real (kind=RKIND) :: evp - - !-------------------- - - real (kind=RKIND), dimension(:), pointer :: mslp - - real (kind=RKIND), dimension(:,:), allocatable :: pressure, pressureCp1, pressure2, pressure_v, temperature - real (kind=RKIND), dimension(:,:), allocatable :: dewpoint - - !local interpolated fields: - integer :: nIntP - real (kind=RKIND) :: w1,w2,z0,z1,z2 - real (kind=RKIND), dimension(:,:), allocatable :: field_in,press_in - real (kind=RKIND), dimension(:,:), allocatable :: field_interp,press_interp + real (kind=RKIND), dimension(:,:), pointer :: exner, height, theta, relhum, vvel + real (kind=RKIND), dimension(:,:), pointer :: qv, uzonal, umeridional, vorticity + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + + real (kind=RKIND), dimension(:,:), allocatable :: temperature, dewpoint, vorticity_cell + + ! Isobaric interpolated fields + real (kind=RKIND), dimension(:,:), pointer :: temperature_isobaric, theta_isobaric, & + dewpoint_isobaric, relhum_isobaric, & + qvapor_isobaric, height_isobaric, & + geoheight_isobaric, w_isobaric, & + uzonal_isobaric, umeridional_isobaric, & + vorticity_isobaric + + ! Additional fields + real (kind=RKIND), dimension(:), pointer :: mslp, meanT_500_300 - !-------------------------------------------------------------------------------------------------- - - ! call mpas_log_write('') - ! call mpas_log_write('--- enter subroutine interp_diagnostics:') - + ! For mean-layer calculations + real (kind=RKIND), dimension(:,:), allocatable :: press_in, field_in + + ! Mesh variables call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) - call mpas_pool_get_dimension(mesh, 'vertexDegree', vertexDegree) - call mpas_pool_get_dimension(mesh, 'nIsoLevelsT', nIsoLevelsT) - call mpas_pool_get_dimension(mesh, 'nIsoLevelsZ', nIsoLevelsZ) - call mpas_pool_get_dimension(state, 'index_qv', index_qv) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - - nVertLevelsP1 = nVertLevels + 1 - + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'verticesOnCell', verticesOnCell) call mpas_pool_get_array(mesh, 'cellsOnVertex', cellsOnVertex) - call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) - - call mpas_pool_get_array(mesh, 'zgrid', height) - call mpas_pool_get_array(state, 'w', vvel, 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_field(diag, 'pressure_p', pressure_p_field) - call mpas_dmpar_exch_halo_field(pressure_p_field) - - call mpas_pool_get_array(diag, 'exner', exner) + + ! Isobaric levels -- need to amend if additonal level dims are used + call mpas_pool_get_dimension(mesh, 'nIsoLevels', nIsoLevels) + call mpas_pool_get_array(diag, 'iso_levels', iso_levels) + + ! Pressure variables + call exchange_halo_group(domain, 'isobaric:pressure_p') 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, 'vorticity', vorticity) - call mpas_pool_get_array(diag, 'uReconstructMeridional', umeridional) - call mpas_pool_get_array(diag, 'uReconstructZonal', uzonal) + + ! Fields to be interpolated (or from which fields are derived): + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_array(mesh, 'zgrid', height) + call mpas_pool_get_array(diag, 'theta', theta, time_lev) + call mpas_pool_get_array(diag, 'exner', exner) + call mpas_pool_get_array(state, 'scalars', scalars, 1) call mpas_pool_get_array(diag, 'relhum', relhum) - - call mpas_pool_get_array(diag, 't_iso_levels', t_iso_levels) - call mpas_pool_get_array(diag, 'z_iso_levels', z_iso_levels) - call mpas_pool_get_array(diag, 't_isobaric', t_isobaric) - call mpas_pool_get_array(diag, 'z_isobaric', z_isobaric) - call mpas_pool_get_array(diag, 'meanT_500_300', meanT_500_300) - - call mpas_pool_get_array(diag, 'temperature_50hPa', temperature_50hPa) - call mpas_pool_get_array(diag, 'temperature_100hPa', temperature_100hPa) - call mpas_pool_get_array(diag, 'temperature_200hPa', temperature_200hPa) - call mpas_pool_get_array(diag, 'temperature_250hPa', temperature_250hPa) - call mpas_pool_get_array(diag, 'temperature_500hPa', temperature_500hPa) - call mpas_pool_get_array(diag, 'temperature_700hPa', temperature_700hPa) - call mpas_pool_get_array(diag, 'temperature_850hPa', temperature_850hPa) - call mpas_pool_get_array(diag, 'temperature_925hPa', temperature_925hPa) - - call mpas_pool_get_array(diag, 'relhum_50hPa', relhum_50hPa) - call mpas_pool_get_array(diag, 'relhum_100hPa', relhum_100hPa) - call mpas_pool_get_array(diag, 'relhum_200hPa', relhum_200hPa) - call mpas_pool_get_array(diag, 'relhum_250hPa', relhum_250hPa) - call mpas_pool_get_array(diag, 'relhum_500hPa', relhum_500hPa) - call mpas_pool_get_array(diag, 'relhum_700hPa', relhum_700hPa) - call mpas_pool_get_array(diag, 'relhum_850hPa', relhum_850hPa) - call mpas_pool_get_array(diag, 'relhum_925hPa', relhum_925hPa) - - call mpas_pool_get_array(diag, 'dewpoint_50hPa', dewpoint_50hPa) - call mpas_pool_get_array(diag, 'dewpoint_100hPa', dewpoint_100hPa) - call mpas_pool_get_array(diag, 'dewpoint_200hPa', dewpoint_200hPa) - call mpas_pool_get_array(diag, 'dewpoint_250hPa', dewpoint_250hPa) - call mpas_pool_get_array(diag, 'dewpoint_500hPa', dewpoint_500hPa) - call mpas_pool_get_array(diag, 'dewpoint_700hPa', dewpoint_700hPa) - call mpas_pool_get_array(diag, 'dewpoint_850hPa', dewpoint_850hPa) - call mpas_pool_get_array(diag, 'dewpoint_925hPa', dewpoint_925hPa) - - call mpas_pool_get_array(diag, 'uzonal_50hPa', uzonal_50hPa) - call mpas_pool_get_array(diag, 'uzonal_100hPa', uzonal_100hPa) - call mpas_pool_get_array(diag, 'uzonal_200hPa', uzonal_200hPa) - call mpas_pool_get_array(diag, 'uzonal_250hPa', uzonal_250hPa) - call mpas_pool_get_array(diag, 'uzonal_500hPa', uzonal_500hPa) - call mpas_pool_get_array(diag, 'uzonal_700hPa', uzonal_700hPa) - call mpas_pool_get_array(diag, 'uzonal_850hPa', uzonal_850hPa) - call mpas_pool_get_array(diag, 'uzonal_925hPa', uzonal_925hPa) - - call mpas_pool_get_array(diag, 'umeridional_50hPa', umeridional_50hPa) - call mpas_pool_get_array(diag, 'umeridional_100hPa', umeridional_100hPa) - call mpas_pool_get_array(diag, 'umeridional_200hPa', umeridional_200hPa) - call mpas_pool_get_array(diag, 'umeridional_250hPa', umeridional_250hPa) - call mpas_pool_get_array(diag, 'umeridional_500hPa', umeridional_500hPa) - call mpas_pool_get_array(diag, 'umeridional_700hPa', umeridional_700hPa) - call mpas_pool_get_array(diag, 'umeridional_850hPa', umeridional_850hPa) - call mpas_pool_get_array(diag, 'umeridional_925hPa', umeridional_925hPa) - - call mpas_pool_get_array(diag, 'height_50hPa', height_50hPa) - call mpas_pool_get_array(diag, 'height_100hPa', height_100hPa) - call mpas_pool_get_array(diag, 'height_200hPa', height_200hPa) - call mpas_pool_get_array(diag, 'height_250hPa', height_250hPa) - call mpas_pool_get_array(diag, 'height_500hPa', height_500hPa) - call mpas_pool_get_array(diag, 'height_700hPa', height_700hPa) - call mpas_pool_get_array(diag, 'height_850hPa', height_850hPa) - call mpas_pool_get_array(diag, 'height_925hPa', height_925hPa) - - call mpas_pool_get_array(diag, 'w_50hPa', w_50hPa) - call mpas_pool_get_array(diag, 'w_100hPa', w_100hPa) - call mpas_pool_get_array(diag, 'w_200hPa', w_200hPa) - call mpas_pool_get_array(diag, 'w_250hPa', w_250hPa) - call mpas_pool_get_array(diag, 'w_500hPa', w_500hPa) - call mpas_pool_get_array(diag, 'w_700hPa', w_700hPa) - call mpas_pool_get_array(diag, 'w_850hPa', w_850hPa) - call mpas_pool_get_array(diag, 'w_925hPa', w_925hPa) - - call mpas_pool_get_array(diag, 'vorticity_50hPa', vorticity_50hPa) - call mpas_pool_get_array(diag, 'vorticity_100hPa', vorticity_100hPa) - call mpas_pool_get_array(diag, 'vorticity_200hPa', vorticity_200hPa) - call mpas_pool_get_array(diag, 'vorticity_250hPa', vorticity_250hPa) - call mpas_pool_get_array(diag, 'vorticity_500hPa', vorticity_500hPa) - call mpas_pool_get_array(diag, 'vorticity_700hPa', vorticity_700hPa) - call mpas_pool_get_array(diag, 'vorticity_850hPa', vorticity_850hPa) - call mpas_pool_get_array(diag, 'vorticity_925hPa', vorticity_925hPa) - + call mpas_pool_get_array(diag, 'uReconstructZonal', uzonal) + call mpas_pool_get_array(diag, 'uReconstructMeridional', umeridional) + call mpas_pool_get_array(state, 'w', vvel, time_lev) + + ! Fields to interpolate: + call mpas_pool_get_array(diag, 'temperature_isobaric', temperature_isobaric) + call mpas_pool_get_array(diag, 'theta_isobaric', theta_isobaric) + call mpas_pool_get_array(diag, 'dewpoint_isobaric', dewpoint_isobaric) + call mpas_pool_get_array(diag, 'relhum_isobaric', relhum_isobaric) + call mpas_pool_get_array(diag, 'qvapor_isobaric', qvapor_isobaric) + call mpas_pool_get_array(diag, 'uzonal_isobaric', uzonal_isobaric) + call mpas_pool_get_array(diag, 'umeridional_isobaric', umeridional_isobaric) + call mpas_pool_get_array(diag, 'height_isobaric', height_isobaric) + call mpas_pool_get_array(diag, 'geoheight_isobaric', geoheight_isobaric) + call mpas_pool_get_array(diag, 'w_isobaric', w_isobaric) + call mpas_pool_get_array(diag, 'vorticity_isobaric', vorticity_isobaric) + + call exchange_halo_group(domain, 'isobaric:vorticity') + call mpas_pool_get_array(diag, 'vorticity', vorticity) + + ! Additional fields call mpas_pool_get_array(diag, 'mslp', mslp) - - if(.not.allocated(pressure) ) allocate(pressure(nVertLevels,nCells) ) - if(.not.allocated(pressureCp1) ) allocate(pressureCp1(nVertLevels,nCells+1) ) - if(.not.allocated(pressure2) ) allocate(pressure2(nVertLevelsP1,nCells) ) - if(.not.allocated(pressure_v) ) allocate(pressure_v(nVertLevels,nVertices) ) - if(.not.allocated(temperature) ) allocate(temperature(nVertLevels,nCells) ) - if(.not.allocated(dewpoint) ) allocate(dewpoint(nVertLevels,nCells) ) - - if (need_t_isobaric) then - t_iso_levels(1) = 30000.0 - t_iso_levels(2) = 35000.0 - t_iso_levels(3) = 40000.0 - t_iso_levels(4) = 45000.0 - t_iso_levels(5) = 50000.0 - end if - - if (need_z_isobaric) then - z_iso_levels(1) = 30000.0 - z_iso_levels(2) = 35000.0 - z_iso_levels(3) = 40000.0 - z_iso_levels(4) = 45000.0 - z_iso_levels(5) = 50000.0 - z_iso_levels(6) = 55000.0 - z_iso_levels(7) = 60000.0 - z_iso_levels(8) = 65000.0 - z_iso_levels(9) = 70000.0 - z_iso_levels(10) = 75000.0 - z_iso_levels(11) = 80000.0 - z_iso_levels(12) = 85000.0 - z_iso_levels(13) = 90000.0 - end if - - !calculation of total pressure at cell centers (at mass points): - do iCell = 1, nCells - do k = 1, nVertLevels - pressure(k,iCell) = (pressure_p(k,iCell) + pressure_b(k,iCell)) / 100._RKIND - pressureCp1(k,iCell) = pressure(k,iCell) - enddo - enddo - do iCell = nCells+1, nCells+1 - do k = 1, nVertLevels - pressureCp1(k,iCell) = (pressure_p(k,iCell) + pressure_b(k,iCell)) / 100._RKIND - enddo - enddo - - !calculation of total pressure at cell centers (at vertical velocity points): - k = nVertLevelsP1 - do iCell = 1, nCells - z0 = height(k,iCell) - z1 = 0.5*(height(k,iCell)+height(k-1,iCell)) - z2 = 0.5*(height(k-1,iCell)+height(k-2,iCell)) - w1 = (z0-z2)/(z1-z2) - w2 = 1.-w1 - !use log of pressure to avoid occurrences of negative top-of-the-model pressure. - pressure2(k,iCell) = exp(w1*log(pressure(k-1,iCell))+w2*log(pressure(k-2,iCell))) - enddo - do k = 2, nVertLevels - do iCell = 1, nCells - w1 = (height(k,iCell)-height(k-1,iCell)) / (height(k+1,iCell)-height(k-1,iCell)) - w2 = (height(k+1,iCell)-height(k,iCell)) / (height(k+1,iCell)-height(k-1,iCell)) - ! pressure2(k,iCell) = w1*pressure(k,iCell) + w2*pressure(k-1,iCell) - ! - ! switch to use ln(pressure) for more accurate vertical interpolation, WCS 20230407 - pressure2(k,iCell) = exp(w1*log(pressure(k,iCell))+w2*log(pressure(k-1,iCell))) - enddo - enddo - k = 1 - do iCell = 1, nCells - z0 = height(k,iCell) - z1 = 0.5*(height(k,iCell)+height(k+1,iCell)) - z2 = 0.5*(height(k+1,iCell)+height(k+2,iCell)) - w1 = (z0-z2)/(z1-z2) - w2 = 1.-w1 - ! pressure2(k,iCell) = w1*pressure(k,iCell)+w2*pressure(k+1,iCell) - ! - ! switch to use ln(pressure) for more accurate vertical interpolation, WCS 20230407 - pressure2(k,iCell) = exp(w1*log(pressure(k,iCell))+w2*log(pressure(k+1,iCell))) - enddo - - !calculation of total pressure at cell vertices (at mass points): - do iVert = 1, nVertices - pressure_v(:,iVert) = 0._RKIND - - do k = 1, nVertLevels - do iVertD = 1, vertexDegree - pressure_v(k,iVert) = pressure_v(k,iVert) & - + kiteAreasOnVertex(iVertD,iVert)*pressureCp1(k,cellsOnVertex(iVertD,iVert)) - enddo - pressure_v(k,iVert) = pressure_v(k,iVert) / areaTriangle(iVert) - enddo - enddo - - if (NEED_TEMP .or. NEED_RELHUM .or. NEED_DEWPOINT .or. need_mslp) then - !calculation of temperature at cell centers: - do iCell = 1,nCells - do k = 1,nVertLevels - temperature(k,iCell) = (theta_m(k,iCell)/(1._RKIND+rvord*scalars(index_qv,k,iCell)))*exner(k,iCell) + call mpas_pool_get_array(diag, 'meanT_500_300', meanT_500_300) + + ! Initialize qv + qv => scalars(index_qv,:,:) - ! Vapor pressure (NB: pressure here is already in hPa) - evp = pressure(k,iCell) * scalars(index_qv,k,iCell) / (scalars(index_qv,k,iCell) + 0.622_RKIND) - evp = max(evp, 1.0e-8_RKIND) + if(.not.allocated(pressure)) allocate(pressure(nVertLevels,nCells+1)) + if(.not.allocated(temperature)) allocate(temperature(nVertLevels,nCells)) + if(.not.allocated(dewpoint)) allocate(dewpoint(nVertLevels,nCells)) - ! Dewpoint temperature following Bolton (1980) - dewpoint(k,iCell) = (243.5_RKIND * log(evp/6.112_RKIND)) / (17.67_RKIND - log(evp/6.112_RKIND)) - dewpoint(k,iCell) = dewpoint(k,iCell) + 273.15 - enddo - enddo + temperature(:,:) = 0.0 + dewpoint(:,:) = 0.0 + + ! ----------------------------------------------------------------- + ! Calculate total pressure at mass points: + do iCell = 1,nCells + do k = 1,nVertLevels + pressure(k,iCell) = (pressure_p(k,iCell) + pressure_b(k,iCell)) / 100._RKIND + end do + end do + + ! ----------------------------------------------------------------- + ! Calculate temperature and dewpoint: + if (need_temp_isobaric .or. need_dewp_isobaric .or. need_mslp .or. need_meanT_500_300) then + call calc_temperature_dewpoint(nCells, nVertLevels, qv, exner, theta, pressure, temperature, dewpoint) end if - - !interpolation to fixed pressure levels for fields located at cells centers and at mass points: - nIntP = 8 - if(.not.allocated(field_interp)) allocate(field_interp(nCells,nIntP) ) - if(.not.allocated(press_interp)) allocate(press_interp(nCells,nIntP) ) - do iCell = 1, nCells - press_interp(iCell,1) = 50.0_RKIND - press_interp(iCell,2) = 100.0_RKIND - press_interp(iCell,3) = 200.0_RKIND - press_interp(iCell,4) = 250.0_RKIND - press_interp(iCell,5) = 500.0_RKIND - press_interp(iCell,6) = 700.0_RKIND - press_interp(iCell,7) = 850.0_RKIND - press_interp(iCell,8) = 925.0_RKIND - enddo - - if(.not.allocated(press_in)) allocate(press_in(nCells,nVertLevels)) - do iCell = 1, nCells - do k = 1, nVertLevels - kk = nVertLevels+1-k - press_in(iCell,kk) = pressure(k,iCell) - enddo - enddo - - if(.not.allocated(field_in)) allocate(field_in(nCells,nVertLevels)) - if (NEED_TEMP) then - !... temperature: - do iCell = 1, nCells - do k = 1, nVertLevels - kk = nVertLevels+1-k - field_in(iCell,kk) = temperature(k,iCell) - enddo - enddo - call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - temperature_50hPa(1:nCells) = field_interp(1:nCells,1) - temperature_100hPa(1:nCells) = field_interp(1:nCells,2) - temperature_200hPa(1:nCells) = field_interp(1:nCells,3) - temperature_250hPa(1:nCells) = field_interp(1:nCells,4) - temperature_500hPa(1:nCells) = field_interp(1:nCells,5) - temperature_700hPa(1:nCells) = field_interp(1:nCells,6) - temperature_850hPa(1:nCells) = field_interp(1:nCells,7) - temperature_925hPa(1:nCells) = field_interp(1:nCells,8) - ! call mpas_log_write('--- end interpolate temperature:') + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!! Interpolate fields to array of pressure levels !!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !-------------------------------------------------------------------- + ! Interpolate temperature: + if (need_temp_isobaric) then + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, temperature, nIsoLevels, iso_levels, temperature_isobaric) end if - - - if (NEED_RELHUM) then - !... relative humidity: - do iCell = 1, nCells - do k = 1, nVertLevels - kk = nVertLevels+1-k - field_in(iCell,kk) = relhum(k,iCell) - enddo - enddo - call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - relhum_50hPa(1:nCells) = field_interp(1:nCells,1) - relhum_100hPa(1:nCells) = field_interp(1:nCells,2) - relhum_200hPa(1:nCells) = field_interp(1:nCells,3) - relhum_250hPa(1:nCells) = field_interp(1:nCells,4) - relhum_500hPa(1:nCells) = field_interp(1:nCells,5) - relhum_700hPa(1:nCells) = field_interp(1:nCells,6) - relhum_850hPa(1:nCells) = field_interp(1:nCells,7) - relhum_925hPa(1:nCells) = field_interp(1:nCells,8) - ! call mpas_log_write('--- end interpolate relative humidity:') + + !-------------------------------------------------------------------- + ! Interpolate theta: + if (need_theta_isobaric) then + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, theta, nIsoLevels, iso_levels, theta_isobaric) end if - - if (NEED_DEWPOINT) then - !... dewpoint - do iCell = 1, nCells - do k = 1, nVertLevels - kk = nVertLevels+1-k - field_in(iCell,kk) = dewpoint(k,iCell) - enddo - enddo - call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - dewpoint_50hPa(1:nCells) = field_interp(1:nCells,1) - dewpoint_100hPa(1:nCells) = field_interp(1:nCells,2) - dewpoint_200hPa(1:nCells) = field_interp(1:nCells,3) - dewpoint_250hPa(1:nCells) = field_interp(1:nCells,4) - dewpoint_500hPa(1:nCells) = field_interp(1:nCells,5) - dewpoint_700hPa(1:nCells) = field_interp(1:nCells,6) - dewpoint_850hPa(1:nCells) = field_interp(1:nCells,7) - dewpoint_925hPa(1:nCells) = field_interp(1:nCells,8) - ! call mpas_log_write('--- end interpolate relative humidity:') + + !-------------------------------------------------------------------- + ! Interpolate dewpoint: + if (need_dewp_isobaric) then + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, dewpoint, nIsoLevels, iso_levels, dewpoint_isobaric) end if - - if (NEED_UZONAL) then - !... u zonal wind: - do iCell = 1, nCells - do k = 1, nVertLevels - kk = nVertLevels+1-k - field_in(iCell,kk) = uzonal(k,iCell) - enddo - enddo - call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - uzonal_50hPa(1:nCells) = field_interp(1:nCells,1) - uzonal_100hPa(1:nCells) = field_interp(1:nCells,2) - uzonal_200hPa(1:nCells) = field_interp(1:nCells,3) - uzonal_250hPa(1:nCells) = field_interp(1:nCells,4) - uzonal_500hPa(1:nCells) = field_interp(1:nCells,5) - uzonal_700hPa(1:nCells) = field_interp(1:nCells,6) - uzonal_850hPa(1:nCells) = field_interp(1:nCells,7) - uzonal_925hPa(1:nCells) = field_interp(1:nCells,8) - ! call mpas_log_write('--- end interpolate zonal wind:') + + !-------------------------------------------------------------------- + ! Interpolate relative humidity: + if (need_relhum_isobaric) then + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, relhum, nIsoLevels, iso_levels, relhum_isobaric) end if - - if (NEED_UMERIDIONAL) then - !... u meridional wind: - do iCell = 1, nCells - do k = 1, nVertLevels - kk = nVertLevels+1-k - field_in(iCell,kk) = umeridional(k,iCell) - enddo - enddo - call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - umeridional_50hPa(1:nCells) = field_interp(1:nCells,1) - umeridional_100hPa(1:nCells) = field_interp(1:nCells,2) - umeridional_200hPa(1:nCells) = field_interp(1:nCells,3) - umeridional_250hPa(1:nCells) = field_interp(1:nCells,4) - umeridional_500hPa(1:nCells) = field_interp(1:nCells,5) - umeridional_700hPa(1:nCells) = field_interp(1:nCells,6) - umeridional_850hPa(1:nCells) = field_interp(1:nCells,7) - umeridional_925hPa(1:nCells) = field_interp(1:nCells,8) - ! call mpas_log_write('--- end interpolate meridional wind:') + + !-------------------------------------------------------------------- + ! Interpolate qv (water vapor mixing ratio): + if (need_qv_isobaric) then + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, qv, nIsoLevels, iso_levels, qvapor_isobaric) end if - - if(allocated(field_in)) deallocate(field_in) - if(allocated(press_in)) deallocate(press_in) - - if (NEED_W .or. NEED_HEIGHT) then - !interpolation to fixed pressure levels for fields located at cells centers and at vertical - !velocity points: - if(.not.allocated(press_in)) allocate(press_in(nCells,nVertLevelsP1)) - do iCell = 1, nCells - do k = 1, nVertLevelsP1 - kk = nVertLevelsP1+1-k - press_in(iCell,kk) = pressure2(k,iCell) - enddo - enddo - - if(.not.allocated(field_in)) allocate(field_in(nCells,nVertLevelsP1)) - !... height: - do iCell = 1, nCells - do k = 1, nVertLevelsP1 - kk = nVertLevelsP1+1-k - field_in(iCell,kk) = height(k,iCell) - enddo - enddo - call interp_tofixed_pressure(nCells,nVertLevelsP1,nIntP,press_in,field_in,press_interp,field_interp) - height_50hPa(1:nCells) = field_interp(1:nCells,1) - height_100hPa(1:nCells) = field_interp(1:nCells,2) - height_200hPa(1:nCells) = field_interp(1:nCells,3) - height_250hPa(1:nCells) = field_interp(1:nCells,4) - height_500hPa(1:nCells) = field_interp(1:nCells,5) - height_700hPa(1:nCells) = field_interp(1:nCells,6) - height_850hPa(1:nCells) = field_interp(1:nCells,7) - height_925hPa(1:nCells) = field_interp(1:nCells,8) - ! call mpas_log_write('--- end interpolate height:') - - !... vertical velocity - do iCell = 1, nCells - do k = 1, nVertLevelsP1 - kk = nVertLevelsP1+1-k - field_in(iCell,kk) = vvel(k,iCell) - enddo - enddo - call interp_tofixed_pressure(nCells,nVertLevelsP1,nIntP,press_in,field_in,press_interp,field_interp) - w_50hPa(1:nCells) = field_interp(1:nCells,1) - w_100hPa(1:nCells) = field_interp(1:nCells,2) - w_200hPa(1:nCells) = field_interp(1:nCells,3) - w_250hPa(1:nCells) = field_interp(1:nCells,4) - w_500hPa(1:nCells) = field_interp(1:nCells,5) - w_700hPa(1:nCells) = field_interp(1:nCells,6) - w_850hPa(1:nCells) = field_interp(1:nCells,7) - w_925hPa(1:nCells) = field_interp(1:nCells,8) - - if(allocated(field_in)) deallocate(field_in) - if(allocated(press_in)) deallocate(press_in) - ! call mpas_log_write('--- end interpolate vertical velocity:') + + !-------------------------------------------------------------------- + ! Interpolate geometric height and convert to geopotential height: + if (need_hgt_isobaric .or. need_geohgt_isobaric) then + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, height, nIsoLevels, iso_levels, height_isobaric) + + if (need_geohgt_isobaric) then + geoheight_isobaric(:,:) = (r_earth * height_isobaric(:,:)) / (r_earth + height_isobaric(:,:)) + end if + end if + + !-------------------------------------------------------------------- + ! Interpolate uReconstructZonal: + if (need_uzonal_isobaric) then + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, uzonal, nIsoLevels, iso_levels, uzonal_isobaric) end if - if(allocated(field_interp)) deallocate(field_interp) - if(allocated(press_interp)) deallocate(press_interp) - - if (NEED_VORTICITY) then - !interpolation to fixed pressure levels for fields located at cell vertices and at mass points: - nIntP = 8 - if(.not.allocated(field_interp)) allocate(field_interp(nVertices,nIntP) ) - if(.not.allocated(press_interp)) allocate(press_interp(nVertices,nIntP) ) - do iVert = 1, nVertices - press_interp(iVert,1) = 50.0_RKIND - press_interp(iVert,2) = 100.0_RKIND - press_interp(iVert,3) = 200.0_RKIND - press_interp(iVert,4) = 250.0_RKIND - press_interp(iVert,5) = 500.0_RKIND - press_interp(iVert,6) = 700.0_RKIND - press_interp(iVert,7) = 850.0_RKIND - press_interp(iVert,8) = 925.0_RKIND - enddo - - if(.not.allocated(press_in)) allocate(press_in(nVertices,nVertLevels)) - do iVert = 1, nVertices - do k = 1, nVertLevels - kk = nVertLevels+1-k - press_in(iVert,kk) = pressure_v(k,iVert) - enddo - enddo - - if(.not.allocated(field_in)) allocate(field_in(nVertices,nVertLevels)) - !... relative vorticity: - do iVert = 1, nVertices - do k = 1, nVertLevels - kk = nVertLevels+1-k - field_in(iVert,kk) = vorticity(k,iVert) - enddo - enddo - call interp_tofixed_pressure(nVertices,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - vorticity_50hPa(1:nVertices) = field_interp(1:nVertices,1) - vorticity_100hPa(1:nVertices) = field_interp(1:nVertices,2) - vorticity_200hPa(1:nVertices) = field_interp(1:nVertices,3) - vorticity_250hPa(1:nVertices) = field_interp(1:nVertices,4) - vorticity_500hPa(1:nVertices) = field_interp(1:nVertices,5) - vorticity_700hPa(1:nVertices) = field_interp(1:nVertices,6) - vorticity_850hPa(1:nVertices) = field_interp(1:nVertices,7) - vorticity_925hPa(1:nVertices) = field_interp(1:nVertices,8) - ! call mpas_log_write('--- end interpolate relative vorticity:') - - if(allocated(field_interp)) deallocate(field_interp) - if(allocated(press_interp)) deallocate(press_interp) - - if(allocated(field_in )) deallocate(field_in) - if(allocated(press_in )) deallocate(press_in) + !-------------------------------------------------------------------- + ! Interpolate uReconstructMeridional: + if (need_umerid_isobaric) then + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, umeridional, nIsoLevels, iso_levels, umeridional_isobaric) + end if + + !-------------------------------------------------------------------- + ! Interpolate vertical vorticity: + if (need_vort_isobaric) then + if(.not.allocated(vorticity_cell)) allocate(vorticity_cell(nVertLevels,nCells)) + vorticity_cell(:,:) = 0.0 + + ! first, reconstruct vorticity to cell center (decreases number of points by roughly half) + call interp_absVertVort(vorticity, nCells, nEdgesOnCell, verticesOnCell, & + cellsOnVertex, areaCell, kiteAreasOnVertex, vorticity_cell) + + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, vorticity_cell, nIsoLevels, iso_levels, vorticity_isobaric) + if (allocated(vorticity_cell)) deallocate(vorticity_cell) end if - if(allocated(pressureCp1) ) deallocate(pressureCp1 ) - if(allocated(pressure_v) ) deallocate(pressure_v ) - + !-------------------------------------------------------------------- + ! Interpolate vertical velocity: + if (need_w_isobaric) then + call interp_field_cell_w_levels(nCells, nVertLevels, pressure, height, vvel, nIsoLevels, iso_levels, w_isobaric) + end if + + !-------------------------------------------------------------------- + ! Calculate layer-mean quantities + + if (need_meanT_500_300) then + if(.not.allocated(field_in)) allocate(field_in(nCells,nVertLevels)) + if(.not.allocated(press_in)) allocate(press_in(nCells,nVertLevels)) + + !reverse the vertical axis of pressure and quantity being averaged + do iCell=1,nCells + do k=1,nVertLevels + kk = nVertLevels+1-k + press_in(iCell,kk) = pressure(k,iCell) * 100. + field_in(iCell,kk) = temperature(k,iCell) + end do + end do + + call compute_layer_mean(meanT_500_300, 50000.0_RKIND, 30000.0_RKIND, field_in, press_in) + + if(allocated(field_in)) deallocate(field_in) + if(allocated(press_in)) deallocate(press_in) + end if + + !-------------------------------------------------------------------- + ! Calculate SLP field: if (need_mslp) then - !... compute SLP (requires temp, height, pressure, qvapor) - call compute_slp(nCells, nVertLevels, num_scalars, temperature, height, pressure, index_qv, scalars, mslp) - mslp(:) = mslp(:) * 100.0 ! Convert from hPa to Pa - !... alternative way - !do iCell = 1, nCells + !... compute SLP (requires temp, height, pressure, qvapor) + call compute_slp(nCells, nVertLevels, num_scalars, temperature, height, pressure, index_qv, scalars, mslp) + mslp(:) = mslp(:) * 100.0 ! Convert from hPa to Pa + !... alternative way + !do iCell = 1, nCells ! mslp(iCell) = diag % surface_pressure % array(iCell) + 11.38*height(1,iCell) ! mslp(iCell) = mslp(iCell)/100. - !enddo - end if - - - !!!!!!!!!!! Additional temperature levels for vortex tracking !!!!!!!!!!! - if (need_t_isobaric .or. need_meanT_500_300) then - - allocate(field_in(nCells, nVertLevels)) - allocate(press_in(nCells, nVertLevels)) - allocate(field_interp(nCells, nIsoLevelsT)) - allocate(press_interp(nCells, nIsoLevelsT)) - - do k=1,nIsoLevelsT - press_interp(:,k) = t_iso_levels(k) - end do - - ! Additional temperature levels for vortex tracking - do iCell=1,nCells - do k=1,nVertLevels - kk = nVertLevels+1-k - field_in(iCell,kk) = temperature(k,iCell) - end do - end do - - do iCell=1,nCells - do k=1,nVertLevels - kk = nVertLevels+1-k - press_in(iCell,kk) = pressure(k,iCell) * 100.0 - end do - end do - - if (need_t_isobaric) then - call interp_tofixed_pressure(nCells, nVertLevels, nIsoLevelsT, press_in, field_in, press_interp, field_interp) - - do k=1,nIsoLevelsT - t_isobaric(k,1:nCells) = field_interp(1:nCells,k) - end do - end if - - - !!!!!!!!!!! Calculate mean temperature in 500 hPa - 300 hPa layer !!!!!!!!!!! - - if (need_meanT_500_300) then - call compute_layer_mean(meanT_500_300, 50000.0_RKIND, 30000.0_RKIND, field_in, press_in) - end if - - - deallocate(field_in) - deallocate(field_interp) - deallocate(press_in) - deallocate(press_interp) + !enddo end if - - - !!!!!!!!!!! Additional height levels for vortex tracking !!!!!!!!!!! - if (need_z_isobaric) then - allocate(field_in(nCells, nVertLevelsP1)) - allocate(press_in(nCells, nVertLevelsP1)) - allocate(field_interp(nCells, nIsoLevelsZ)) - allocate(press_interp(nCells, nIsoLevelsZ)) - - do k=1,nIsoLevelsZ - press_interp(:,k) = z_iso_levels(k) - end do - - do iCell=1,nCells - do k=1,nVertLevelsP1 - kk = nVertLevelsP1+1-k - field_in(iCell,kk) = height(k,iCell) - end do - end do - - do iCell=1,nCells - do k=1,nVertLevelsP1 - kk = nVertLevelsP1+1-k - press_in(iCell,kk) = pressure2(k,iCell) * 100.0 - end do - end do - - call interp_tofixed_pressure(nCells, nVertLevelsP1, nIsoLevelsZ, press_in, field_in, press_interp, field_interp) - - do k=1,nIsoLevelsZ - z_isobaric(k,1:nCells) = field_interp(1:nCells,k) - end do - - deallocate(field_in) - deallocate(field_interp) - deallocate(press_in) - deallocate(press_interp) - end if - - if(allocated(temperature) ) deallocate(temperature ) - if(allocated(pressure2) ) deallocate(pressure2 ) - if(allocated(pressure) ) deallocate(pressure ) - if(allocated(dewpoint) ) deallocate(dewpoint ) - - end subroutine interp_diagnostics + call mpas_log_write('did mean and slp') + + if (allocated(pressure)) deallocate(pressure) + if (allocated(temperature)) deallocate(temperature) + if (allocated(dewpoint)) deallocate(dewpoint) + + end subroutine interp_diagnostics + !================================================================================================== subroutine interp_tofixed_pressure(ncol,nlev_in,nlev_out,pres_in,field_in,pres_out,field_out) @@ -1089,9 +536,319 @@ subroutine interp_tofixed_pressure(ncol,nlev_in,nlev_out,pres_in,field_in,pres_o enddo end subroutine interp_tofixed_pressure + + !================================================================================================== + subroutine interp_field_cell_mass_levels(nCells, nVertLevels, pressure, field, num_iso_levels, & + iso_levels, field_iso) + !================================================================================================== + implicit none + + integer, intent(in) :: nCells, nVertLevels + real (kind=RKIND), dimension(:,:), intent(in) :: pressure + real (kind=RKIND), dimension(:,:), intent(in) :: field + integer, intent(in) :: num_iso_levels + real (kind=RKIND), dimension(:), intent(in) :: iso_levels + real (kind=RKIND), dimension(:,:), intent(inout) :: field_iso + + ! Local index variables + integer :: iCell, k, kk + + ! Pressure variables + real (kind=RKIND), dimension(:,:), allocatable :: pressureCp1 + + !local interpolated fields: + real (kind=RKIND), dimension(:,:), allocatable :: field_in, press_in, press_in2 + real (kind=RKIND), dimension(:,:), allocatable :: field_interp, press_interp + + if(.not.allocated(pressureCp1) ) allocate(pressureCp1(nVertLevels,nCells+1) ) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !calculation of total pressure at cell centers (at mass points): + do iCell = 1, nCells + do k = 1, nVertLevels + pressureCp1(k,iCell) = pressure(k,iCell) + end do + end do + do iCell = nCells+1,nCells+1 + do k =1,nVertLevels + pressureCp1(k,iCell) = pressure(k,iCell) + end do + end do + + if(.not.allocated(press_interp)) allocate(press_interp(nCells, num_iso_levels)) + + ! populate array with pressure levels for interpolation [in Pa] + do k=1,num_iso_levels + press_interp(:,k) = iso_levels(k) + end do + + !-------------------------------------------------------------------- + ! Interpolate field: + if(.not.allocated(field_in)) allocate(field_in(nCells,nVertLevels)) + if(.not.allocated(press_in)) allocate(press_in(nCells,nVertLevels)) + if(.not.allocated(field_interp)) allocate(field_interp(nCells, num_iso_levels)) + + !reverse the vertical axis of array + do iCell=1,nCells + do k=1,nVertLevels + kk = nVertLevels+1-k + press_in(iCell,kk) = pressure(k,iCell) * 100. + field_in(iCell,kk) = field(k,iCell) + end do + end do + + call interp_tofixed_pressure(nCells, nVertLevels, num_iso_levels, press_in, field_in, press_interp, field_interp) + + do k=1,num_iso_levels + field_iso(k,1:nCells) = field_interp(1:nCells,k) + end do + + if(allocated(press_in)) deallocate(press_in) + if(allocated(field_in)) deallocate(field_in) + if(allocated(field_interp)) deallocate(field_interp) + + if(allocated(pressureCp1)) deallocate(pressureCp1) + + end subroutine interp_field_cell_mass_levels + + + !================================================================================================== + subroutine interp_field_vertex_mass_levels(nCells, nVertLevels, nVertices, vertexDegree, cellsOnVertex, & + kiteAreasOnVertex, areaTriangle, pressure, field, & + num_iso_levels, iso_levels, field_iso) + !================================================================================================== + + implicit none + + integer, intent(in) :: nCells, nVertLevels, nVertices, vertexDegree + integer, dimension(:,:), intent(in) :: cellsOnVertex + real (kind=RKIND), dimension(:,:), intent(in) :: kiteAreasOnVertex + real (kind=RKIND), dimension(:), intent(in) :: areaTriangle + real (kind=RKIND), dimension(:,:), intent(in) :: pressure ! in hPa + real (kind=RKIND), dimension(:,:), intent(in) :: field + integer, intent(in) :: num_iso_levels + real (kind=RKIND), dimension(:), intent(in) :: iso_levels + real (kind=RKIND), dimension(:,:), intent(inout) :: field_iso + + ! Local index variables + integer :: iCell, k, kk, iVert, iVertD + + ! Pressure variables + real (kind=RKIND), dimension(:,:), allocatable :: pressureCp1, pressure_v + + !local interpolated fields: + real (kind=RKIND), dimension(:,:), allocatable :: field_in, press_in, press_in2 + real (kind=RKIND), dimension(:,:), allocatable :: field_interp, press_interp + + if(.not.allocated(pressureCp1)) allocate(pressureCp1(nVertLevels,nCells+1) ) + if(.not.allocated(pressure_v)) allocate(pressure_v(nVertLevels,nVertices)) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !calculation of total pressure at cell centers (at mass points): + do iCell = 1, nCells + do k = 1, nVertLevels + pressureCp1(k,iCell) = pressure(k,iCell) + end do + end do + do iCell = nCells+1,nCells+1 + do k =1,nVertLevels + pressureCp1(k,iCell) = pressure(k,iCell) + end do + end do + !calculation of total pressure at cell vertices (at mass points): + do iVert = 1, nVertices + pressure_v(:,iVert) = 0._RKIND + + do k=1,nVertLevels + do iVertD = 1, vertexDegree + pressure_v(k,iVert) = pressure_v(k,iVert) & + + kiteAreasOnVertex(iVertD,iVert)*pressureCp1(k,cellsOnVertex(iVertD,iVert)) + end do + pressure_v(k,iVert) = pressure_v(k,iVert) / areaTriangle(iVert) + end do + end do + + if(.not.allocated(press_interp)) allocate(press_interp(nVertices, num_iso_levels)) + + ! populate array with pressure levels for interpolation [in Pa] + do k=1,num_iso_levels + press_interp(:,k) = iso_levels(k) + end do + + !-------------------------------------------------------------------- + ! Interpolate field: + if(.not.allocated(field_in)) allocate(field_in(nVertices,nVertLevels)) + if(.not.allocated(press_in)) allocate(press_in(nVertices,nVertLevels)) + if(.not.allocated(field_interp)) allocate(field_interp(nVertices, num_iso_levels)) + + !reverse the vertical axis of array + do iVert=1,nVertices + do k=1,nVertLevels + kk = nVertLevels+1-k + press_in(iVert,kk) = pressure_v(k,iVert) * 100. + field_in(iVert,kk) = field(k,iVert) + end do + end do + + call interp_tofixed_pressure(nVertices, nVertLevels, num_iso_levels, press_in, field_in, press_interp, field_interp) + + do k=1,num_iso_levels + field_iso(k,1:nVertices) = field_interp(1:nVertices,k) + end do + + if(allocated(press_in)) deallocate(press_in) + if(allocated(field_in)) deallocate(field_in) + if(allocated(field_interp)) deallocate(field_interp) + + if(allocated(pressureCp1)) deallocate(pressureCp1) + if(allocated(pressure_v)) deallocate(pressure_v) + + end subroutine interp_field_vertex_mass_levels + + !================================================================================================== + subroutine interp_field_cell_w_levels(nCells, nVertLevels, pressure, height, field, num_iso_levels, & + iso_levels, field_iso) + !================================================================================================== + + implicit none + + integer, intent(in) :: nCells, nVertLevels + real (kind=RKIND), dimension(:,:), intent(in) :: pressure + real (kind=RKIND), dimension(:,:), intent(in) :: height + real (kind=RKIND), dimension(:,:), intent(in) :: field + integer, intent(in) :: num_iso_levels + real (kind=RKIND), dimension(:), intent(in) :: iso_levels + real (kind=RKIND), dimension(:,:), intent(inout) :: field_iso + + ! Local index variables + integer :: iCell, k, kk + integer :: nVertLevelsP1 + + ! Pressure variables + real (kind=RKIND), dimension(:,:), allocatable :: pressure2 + + !local interpolated fields: + real (kind=RKIND) :: w1,w2,z0,z1,z2 + real (kind=RKIND), dimension(:,:), allocatable :: field_in, press_in, press_in2 + real (kind=RKIND), dimension(:,:), allocatable :: field_interp, press_interp + + nVertLevelsP1 = nVertLevels + 1 + + if(.not.allocated(pressure2)) allocate(pressure2(nVertLevelsP1,nCells+1)) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !calculation of total pressure at cell centers (at vertical velocity points): + k = nVertLevelsP1 + do iCell=1,nCells + z0 = height(k,iCell) + z1 = 0.5*(height(k,iCell)+height(k-1,iCell)) + z2 = 0.5*(height(k-1,iCell)+height(k-2,iCell)) + w1 = (z0-z2)/(z1-z2) + w2 = 1.-w1 + ! use log of pressure to avoid occurrences of negative top-of-the-model pressure. + pressure2(k,iCell) = exp(w1*log(pressure(k-1,iCell))+w2*log(pressure(k-2,iCell))) + end do + + do k=2,nVertLevels + do iCell=1,nCells + w1 = (height(k,iCell)-height(k-1,iCell)) / (height(k+1,iCell)-height(k-1,iCell)) + w2 = (height(k+1,iCell)-height(k,iCell)) / (height(k+1,iCell)-height(k-1,iCell)) + ! switch to use ln(pressure) for more accurate vertical interpolation, WCS 20230407 + pressure2(k,iCell) = exp(w1*log(pressure(k,iCell)) + w2*log(pressure(k-1,iCell))) + end do + end do + + k = 1 + do iCell=1,nCells + z0 = height(k,iCell) + z1 = 0.5*(height(k,iCell)+height(k+1,iCell)) + z2 = 0.5*(height(k+1,iCell)+height(k+2,iCell)) + w1 = (z0-z2)/(z1-z2) + w2 = 1.-w1 + ! switch to use ln(pressure) for more accurate vertical interpolation, WCS 20230407 + pressure2(k,iCell) = exp(w1*log(pressure(k,iCell))+w2*log(pressure(k+1,iCell))) + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!! Interpolate fields to array of pressure levels !!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if(.not.allocated(press_interp)) allocate(press_interp(nCells, num_iso_levels)) + + ! populate array with pressure levels for interpolation [in Pa] + do k=1,num_iso_levels + press_interp(:,k) = iso_levels(k) + end do + + !-------------------------------------------------------------------- + ! Interpolate field: + if(.not.allocated(field_in)) allocate(field_in(nCells,nVertLevelsP1)) + if(.not.allocated(press_in)) allocate(press_in(nCells,nVertLevelsP1)) + if(.not.allocated(field_interp)) allocate(field_interp(nCells, num_iso_levels)) + + !reverse the vertical axis of array + do iCell=1,nCells + do k=1,nVertLevelsP1 + kk = nVertLevelsP1+1-k + press_in(iCell,kk) = pressure2(k,iCell) * 100. + field_in(iCell,kk) = field(k,iCell) + end do + end do + + call interp_tofixed_pressure(nCells, nVertLevelsP1, num_iso_levels, press_in, field_in, press_interp, field_interp) + + do k=1,num_iso_levels + field_iso(k,1:nCells) = field_interp(1:nCells,k) + end do + + if(allocated(press_in)) deallocate(press_in) + if(allocated(field_in)) deallocate(field_in) + if(allocated(field_interp)) deallocate(field_interp) + + if(allocated(pressure2)) deallocate(pressure2) + + end subroutine interp_field_cell_w_levels + + + !================================================================================================== + subroutine calc_temperature_dewpoint(nCells, nVertLevels, qv, exner, theta, pressure, temperature, dewpoint) + !================================================================================================== + + implicit none + + integer, intent(in) :: nCells, nVertLevels + real (kind=RKIND), dimension(:,:), intent(in) :: qv, theta + real (kind=RKIND), dimension(:,:), intent(in) :: exner, pressure + real (kind=RKIND), dimension(:,:), intent(inout) :: temperature, dewpoint + + ! Local variables + integer :: iCell, k + real :: evp + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !calculation of temperature and dewpoint + do iCell=1,nCells + do k=1,nVertLevels + temperature(k,iCell) = theta(k,iCell)*exner(k,iCell) + + ! Vapor pressure (NB: pressure here is already in hPa) + evp = pressure(k,iCell) * qv(k,iCell) / (qv(k,iCell) + 0.622_RKIND) + evp = max(evp, 1.0e-8_RKIND) + + ! Dewpoint temperature following Bolton (1980) + dewpoint(k,iCell) = (243.5_RKIND * log(evp/6.112_RKIND)) / (17.67_RKIND - log(evp/6.112_RKIND)) + dewpoint(k,iCell) = dewpoint(k,iCell) + 273.15 + end do + end do + + end subroutine calc_temperature_dewpoint + + + !================================================================================================== subroutine compute_slp(ncol,nlev_in,nscalars,t,height,p,index_qv,scalars,slp) + !================================================================================================== implicit none @@ -1227,6 +984,37 @@ subroutine compute_slp(ncol,nlev_in,nscalars,t,height,p,index_qv,scalars,slp) end subroutine compute_slp + !================================================================================================== + subroutine interp_absVertVort(vorticity_vertex, nCells, nEdgesOnCell, verticesOnCell, & + cellsOnVertex, areaCell, kiteAreasOnVertex, vorticity_cell) + ! + ! MC added: Subroutine to interpolate vertical vorticity to cell centers from the vertical vorticity at vertices + !================================================================================================== + + IMPLICIT NONE + + integer, intent(in) :: nCells + integer, dimension(:), intent(in) :: nEdgesOnCell + integer, dimension(:,:), intent(in) :: verticesOnCell, cellsOnVertex + real(kind=RKIND), dimension(:), intent(in) :: areaCell + real(kind=RKIND), dimension(:,:), intent(in) :: vorticity_vertex, kiteAreasOnVertex + real(kind=RKIND), dimension(:,:), intent(out) :: vorticity_cell + integer :: i, j, cellIndOnVertex, iVertex + + vorticity_cell(:,:) = 0.0_RKIND + + do i=1,nCells + do j=1,nEdgesOnCell(i) + iVertex = verticesOnCell(j,i) + cellIndOnVertex = FINDLOC(cellsOnVertex(:,iVertex),VALUE=i,DIM=1) + vorticity_cell(:,i) = vorticity_cell(:,i) + kiteAreasOnVertex(cellIndOnVertex,iVertex) * vorticity_vertex(:,iVertex) + end do + vorticity_cell(:,i) = vorticity_cell(:,i) / areaCell(i) + end do + + end subroutine interp_absVertVort + + !*********************************************************************** ! ! routine compute_layer_mean diff --git a/src/core_atmosphere/mpas_atm_halos.F b/src/core_atmosphere/mpas_atm_halos.F index 2512c53bf7..0c283e1f8d 100644 --- a/src/core_atmosphere/mpas_atm_halos.F +++ b/src/core_atmosphere/mpas_atm_halos.F @@ -29,7 +29,7 @@ end subroutine halo_exchange_routine procedure (halo_exchange_routine), pointer :: exchange_halo_group ! MC: added logicals for diagnostics packages - logical, pointer :: config_tend + logical, pointer :: config_tend, config_isobaric logical, pointer :: config_pv_diag, config_pv_tend, config_pv_scalar, & config_pv_microphys @@ -71,6 +71,7 @@ subroutine atm_build_halo_groups(domain, ierr) call mpas_pool_get_config(domain % blocklist % configs, 'config_pv_diag', config_pv_diag) call mpas_pool_get_config(domain % blocklist % configs, 'config_pv_tend', config_pv_tend) call mpas_pool_get_config(domain % blocklist % configs, 'config_pv_microphys', config_pv_microphys) + call mpas_pool_get_config(domain % blocklist % configs, 'config_isobaric', config_isobaric) ! ! Determine from the namelist option config_halo_exch_method which halo exchange method to employ @@ -282,6 +283,15 @@ subroutine atm_build_halo_groups(domain, ierr) call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mp_tend', 'tend_theta_mp_frez_ice', timeLevel=1, haloLayers=(/1,2/)) end if + ! Isobaric interpolation + if (config_isobaric) then + call mpas_dmpar_exch_group_create(domain, 'isobaric:pressure_p') + call mpas_dmpar_exch_group_add_field(domain, 'isobaric:pressure_p', 'pressure_p', timeLevel=1, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'isobaric:vorticity') + call mpas_dmpar_exch_group_add_field(domain, 'isobaric:vorticity', 'vorticity', timeLevel=1, haloLayers=(/1,2/)) + end if + ! ! Set routine to exchange a halo group @@ -526,6 +536,16 @@ subroutine atm_build_halo_groups(domain, ierr) call mpas_halo_exch_group_complete(domain, 'diagnostics:dpv_mp_tend') end if + ! Isobaric interpolation + if (config_isobaric) then + call mpas_halo_exch_group_create(domain, 'isobaric:pressure_p') + call mpas_halo_exch_group_add_field(domain, 'isobaric:pressure_p', 'pressure_p', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'isobaric:pressure_p') + + call mpas_halo_exch_group_create(domain, 'isobaric:vorticity') + call mpas_halo_exch_group_add_field(domain, 'isobaric:vorticity', 'vorticity', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'isobaric:vorticity') + end if ! ! Set routine to exchange a halo group @@ -640,6 +660,10 @@ subroutine atm_destroy_halo_groups(domain, ierr) call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:dpv_mp_tend') end if + if (config_isobaric) then + call mpas_dmpar_exch_group_destroy(domain, 'isobaric:pressure_p') + call mpas_dmpar_exch_group_destroy(domain, 'isobaric:vorticity') + end if else if (trim(config_halo_exch_method) == 'mpas_halo') then @@ -705,6 +729,10 @@ subroutine atm_destroy_halo_groups(domain, ierr) call mpas_halo_exch_group_destroy(domain, 'diagnostics:dpv_mp_tend') end if + if (config_isobaric) then + call mpas_halo_exch_group_destroy(domain, 'isobaric:pressure_p') + call mpas_halo_exch_group_destroy(domain, 'isobaric:vorticity') + end if call mpas_halo_finalize(domain) From 5f53d239df7d053a1617f59281d84ca17ca2e40a Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Tue, 9 Jul 2024 18:59:14 -0600 Subject: [PATCH 17/23] Change diagnostics namelist option to default - Changed diagnostics option and config_isobaric to be in the default namelist configuration. --- src/core_atmosphere/diagnostics/Registry_diagnostics.xml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/core_atmosphere/diagnostics/Registry_diagnostics.xml b/src/core_atmosphere/diagnostics/Registry_diagnostics.xml index f7ab530dfb..fb6d55badf 100644 --- a/src/core_atmosphere/diagnostics/Registry_diagnostics.xml +++ b/src/core_atmosphere/diagnostics/Registry_diagnostics.xml @@ -28,9 +28,8 @@ - - From bfddf5ed33137b1fa28d9f907c9a8712dc7ead5c Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Tue, 9 Jul 2024 22:06:51 -0600 Subject: [PATCH 18/23] Added initialization and advection of pv_scalar - Added intialization of pv_scalar field as ertel_pv to mpas_pv_diagnostics.F - Added calls to initialize pv_scalar field to mpas_atm_diagnostics_manager.F and mpas_atm_core.F - Added call to advect_scalars subroutine for pv_scalars in mpas_atm_time_integration.F if config_pv_scalar = True --- .../mpas_atm_diagnostics_manager.F | 29 +++++++- .../diagnostics/mpas_pv_diagnostics.F | 71 ++++++++++++++++++- .../dynamics/mpas_atm_time_integration.F | 21 +++++- src/core_atmosphere/mpas_atm_core.F | 6 +- 4 files changed, 120 insertions(+), 7 deletions(-) diff --git a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F index 7fe2b51590..3e5854f175 100644 --- a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F +++ b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F @@ -37,7 +37,8 @@ end subroutine halo_exchange_routine mpas_atm_diag_update, & mpas_atm_diag_compute, & mpas_atm_diag_reset, & - mpas_atm_diag_cleanup + mpas_atm_diag_cleanup , & + mpas_atm_diag_pv_init ! MC added contains @@ -89,6 +90,32 @@ subroutine mpas_atm_diag_setup(stream_mgr, configs, structs, clock, dminfo) end subroutine mpas_atm_diag_setup + !----------------------------------------------------------------------- + ! routine MPAS_atm_diag_pv_init + ! + !> \brief Subroutine to initialize pv_scalar as ertel_pv at first + !> time step if activated + !> \author Manda Chasteen + !> \date 15 January 2023 + !> \details + !> This subroutine is called in mpas_atm_core.F to initialize PV field + !> to be advected by the scalar transport scheme + ! + !----------------------------------------------------------------------- + subroutine mpas_atm_diag_pv_init(domain, exchange_halo_group) + + use mpas_pv_diagnostics, only : pv_diagnostics_init + + implicit none + + type (domain_type), intent(inout) :: domain + procedure (halo_exchange_routine) :: exchange_halo_group + + call mpas_timer_start('Tendency and PV diagnostics') + call pv_diagnostics_init(domain, exchange_halo_group) + call mpas_timer_stop('Tendency and PV diagnostics') + + end subroutine mpas_atm_diag_pv_init !----------------------------------------------------------------------- ! routine MPAS_atm_diag_update diff --git a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F index 55902d8c27..84e0535017 100644 --- a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F @@ -44,7 +44,8 @@ end subroutine halo_exchange_routine public :: pv_diagnostics_setup, & pv_diagnostics_compute, & pv_diagnostics_reset, & - pv_diagnostics_update + pv_diagnostics_update, & + pv_diagnostics_init ! If config_pv_scalar, need to initialize as initial PV field private @@ -240,6 +241,74 @@ subroutine pv_diagnostics_setup(configs_in, all_pools, simulation_clock) end subroutine pv_diagnostics_setup + !********************************************************************************************************************* + ! pv_diagnostics_init: A subroutine was created in mpas_atm_diagnostics_manager.F that calls this subroutine and + ! is then called explicitly in mpas_atm_core.F during the first time step so that initial PV + ! field is populated for scalar advection, if desired. Config flag set here to disable + ! the re-initialization of pv_scalar if restart run. + !********************************************************************************************************************* + + subroutine pv_diagnostics_init(domain, exchange_halo_group) + use mpas_pool_routines, only : mpas_pool_get_array, mpas_pool_get_config + + implicit none + + type (domain_type), intent(inout) :: domain + procedure (halo_exchange_routine) :: exchange_halo_group + + logical, pointer :: config_pv_scalar, config_do_restart + real(kind=RKIND), dimension(:,:,:), pointer :: pv_scalars + + call mpas_pool_get_config(configs, 'config_pv_scalar', config_pv_scalar) + call mpas_pool_get_config(configs, 'config_do_restart', config_do_restart) + + if ((.not. config_do_restart) .and. config_pv_scalar) then + ! Initialize PV scalar field + call mpas_log_write("Calling pv_diagnostics_scalar_init().") + call pv_diagnostics_scalar_init(domain, exchange_halo_group) + else if (config_do_restart .and. config_pv_scalar) then + call mpas_log_write('config_do_restart = $l', logicArgs=(/config_do_restart/)) + call mpas_log_write('--- skipping pv_scalar initialization.') + call mpas_pool_get_array(state, 'pv_scalars', pv_scalars) ! MC: don't think this is necessary + return + end if + + end subroutine pv_diagnostics_init + + + !********************************************************************************************************************* + ! pv_diagnostics_scalar_init: initialize PV scalar field to be advected by model's transport scheme, if desired + !********************************************************************************************************************* + + subroutine pv_diagnostics_scalar_init(domain, exchange_halo_group) + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_config + + implicit none + + type (domain_type), intent(inout) :: domain + procedure (halo_exchange_routine) :: exchange_halo_group + + logical, pointer :: config_pv_diag, config_pv_scalar + integer, pointer :: index_pv_scalar + + real(kind=RKIND), dimension(:,:), pointer :: ertel_pv + real(kind=RKIND), dimension(:,:,:), pointer :: pv_scalars + + call mpas_pool_get_dimension(state, 'index_pv_scalar', index_pv_scalar) + call mpas_pool_get_array(state, 'pv_scalars', pv_scalars) + call mpas_pool_get_array(diag, 'ertel_pv', ertel_pv) + + call exchange_halo_group(domain, 'diagnostics:pv_diag') + + ! Calculate PV and initialize PV scalar variable as initial PV field + call calc_epv(mesh, state, diag) + + call mpas_log_write('Initializing pv_scalar as the initial PV field.') + pv_scalars(index_pv_scalar,:,:) = ertel_pv(:,:) + + end subroutine pv_diagnostics_scalar_init + + !********************************************************************************************************************* ! pv_diagnostics_update: compute the PV diagnostics over each time step when called in mpas_atm_diagnostics_manager.F ! only if config_pv_tend is true. Else, compute PV field prior to writing outfile diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index e83cb7d502..3e9aa6d0bf 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -524,7 +524,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) #endif ! For ITM and PV tendency diagnostics - logical, pointer :: config_tend, config_pv_tend + logical, pointer :: config_tend, config_pv_tend, config_pv_scalar real (kind=RKIND), dimension(:,:), pointer :: acc_u_tend_dyn_small, acc_u_tend_dyn_small_ReconstructZonal, & acc_u_tend_dyn_small_ReconstructMeridional, & acc_u_tend_dyn_small_ReconstructX, acc_u_tend_dyn_small_ReconstructY, & @@ -532,6 +532,11 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) real (kind=RKIND), dimension(:,:), pointer :: acc_qv_tend_dyn_large, dqv_dt_dyn !end MW + ! MC -- options for pv_scalar transport + logical, parameter :: config_monotonic_pv = .false. + logical, parameter :: config_positive_definite_pv = .false. + logical, parameter :: advance_density_pv = .false. + real (kind=RKIND) :: time_dyn_step logical, parameter :: debug = .false. @@ -554,8 +559,9 @@ 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_tend', config_tend) ! MW: for tendency diagnostics - call mpas_pool_get_config(block % configs, 'config_pv_tend', config_pv_tend) ! MC: for PV tendency diagnostics + call mpas_pool_get_config(block % configs, 'config_tend', config_tend) ! MW: for tendency diagnostics + call mpas_pool_get_config(block % configs, 'config_pv_tend', config_pv_tend) ! MC: for PV tendency diagnostics + call mpas_pool_get_config(block % configs, 'config_pv_scalar', config_pv_scalar) ! MC: for advection of a PV scalar field ! ! Retrieve field structures @@ -1263,6 +1269,15 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) call advance_scalars('scalars', domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & config_time_integration_order, config_split_dynamics_transport, exchange_halo_group) + + ! MC -- adding PV scalar advection + if (config_pv_scalar .and. (rk_step == 3)) then + call mpas_timer_start('Tendency and PV diagnostics') + call advance_scalars('pv_scalars', domain, rk_step, rk_timestep, config_monotonic_pv, config_positive_definite_pv, & + config_time_integration_order, advance_density_pv, exchange_halo_group) + call mpas_timer_stop('Tendency and PV diagnostics') + end if + if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS scalar transport ! need to fill halo for horizontal filter diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index 83570922c3..cbb5838ad2 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -596,7 +596,8 @@ function atm_core_run(domain) result(ierr) use mpas_derived_types, only : MPAS_STREAM_LATEST_BEFORE, MPAS_STREAM_INPUT, MPAS_STREAM_INPUT_OUTPUT 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_diagnostics_manager, only : mpas_atm_diag_update, mpas_atm_diag_compute, mpas_atm_diag_reset, & + mpas_atm_diag_pv_init ! MC added for PV implicit none @@ -667,7 +668,8 @@ function atm_core_run(domain) result(ierr) call mpas_timer_start('diagnostic_fields') call mpas_atm_diag_reset() !call mpas_atm_diag_update() - call mpas_atm_diag_update(domain, exchange_halo_group) ! MC -- modified with halo inputs + call mpas_atm_diag_update(domain, exchange_halo_group) ! MC -- modified with halo inputs + call mpas_atm_diag_pv_init(domain, exchange_halo_group) ! MC added -- call to initialize pv_scalar if activated !call mpas_atm_diag_compute() call mpas_atm_diag_compute(domain, exchange_halo_group) ! MC -- modified with halo inputs call mpas_timer_stop('diagnostic_fields') From 08b417c56e21b87454df831e9ee767bf3e4262dd Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Tue, 9 Jul 2024 22:44:18 -0600 Subject: [PATCH 19/23] Add isobaric interpolation of PV and PV tendencies - Add isobaric PV variables to Registry_isobaric.xml - Add isobaric interpolation of PV and PV tendencies to mpas_isobaric_diagnostics.F - Add calls to isobaric interpolation subroutines and accumulation of isobaric PV tendencies to mpas_pv_diagnostics.F - Add config_pv_isobaric flag dependence on halo group for 'isobaric:pressure_p' --- .../diagnostics/Registry_isobaric.xml | 188 +++++++++- .../diagnostics/mpas_isobaric_diagnostics.F | 354 +++++++++++++++++- .../diagnostics/mpas_pv_diagnostics.F | 138 ++++++- src/core_atmosphere/mpas_atm_halos.F | 46 +-- 4 files changed, 683 insertions(+), 43 deletions(-) diff --git a/src/core_atmosphere/diagnostics/Registry_isobaric.xml b/src/core_atmosphere/diagnostics/Registry_isobaric.xml index ce533d45d3..e39611b70a 100644 --- a/src/core_atmosphere/diagnostics/Registry_isobaric.xml +++ b/src/core_atmosphere/diagnostics/Registry_isobaric.xml @@ -16,7 +16,7 @@ + packages="isobaric;pv_isobaric"/> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - + + + packages="isobaric"/> diff --git a/src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F index 00c7adc242..0c9070ddcb 100644 --- a/src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F @@ -17,7 +17,9 @@ module mpas_isobaric_diagnostics type (MPAS_pool_type), pointer :: mesh type (MPAS_pool_type), pointer :: state type (MPAS_pool_type), pointer :: diag - type (MPAS_pool_type), pointer :: configs + type (MPAS_pool_type), pointer :: diag_physics + type (MPAS_pool_type), pointer :: tend_physics + type (MPAS_pool_type), pointer :: configs type (MPAS_clock_type), pointer :: clock type (domain_type), pointer :: domain @@ -40,7 +42,8 @@ end subroutine halo_exchange_routine public :: isobaric_diagnostics_setup, & - isobaric_diagnostics_compute + isobaric_diagnostics_compute, & + isobaric_pv, isobaric_pv_tendencies private @@ -48,7 +51,16 @@ end subroutine halo_exchange_routine logical :: need_mslp, need_meanT_500_300, & need_temp_isobaric, need_theta_isobaric, need_dewp_isobaric, need_relhum_isobaric, need_qv_isobaric, & need_uzonal_isobaric, need_umerid_isobaric, & - need_hgt_isobaric, need_geohgt_isobaric, need_w_isobaric, need_vort_isobaric + need_hgt_isobaric, need_geohgt_isobaric, need_w_isobaric, need_vort_isobaric, & + ! PV variables + need_ertelpv, & + need_lw, need_sw, need_bl, need_cu, need_mp, need_mix, & + need_fric_mix, need_fric_bl, need_fric_cu, & + need_diab, need_fric, need_dyn, & + need_evap_rw, need_evap_cw, need_depo, need_melt, need_frez, need_mp_all, & + need_pvtend_isobaric, need_mptend_isobaric, & + ! Latent heating rates + need_dtheta_dt_cu, need_dtheta_dt_mp, need_thtend_isobaric contains @@ -77,7 +89,7 @@ subroutine isobaric_diagnostics_setup(configs_in, all_pools, simulation_clock) type (MPAS_pool_type), pointer :: all_pools type (MPAS_clock_type), pointer :: simulation_clock - logical, pointer :: config_isobaric + logical, pointer :: config_isobaric, config_pv_isobaric ! Isobaric levels for interpolation integer, pointer :: nIsoLevels @@ -92,12 +104,14 @@ subroutine isobaric_diagnostics_setup(configs_in, all_pools, simulation_clock) ! check config_isobaric: call mpas_pool_get_config(configs, 'config_isobaric', config_isobaric) + call mpas_pool_get_config(configs, 'config_pv_isobaric', config_pv_isobaric) call mpas_log_write(' ') call mpas_log_write(' config_isobaric is: $l', logicArgs=(/config_isobaric/)) + call mpas_log_write(' config_pv_isobaric is: $l', logicArgs=(/config_pv_isobaric/)) call mpas_log_write(' ') - if (config_isobaric) then + if (config_isobaric .or. config_pv_isobaric) then call mpas_log_write(' ') call mpas_log_write(' ----- Setting up isobaric diagnostics ----- ') call mpas_log_write(' ') @@ -140,7 +154,7 @@ subroutine isobaric_diagnostics_compute(domain, exchange_halo_group) procedure (halo_exchange_routine) :: exchange_halo_group ! MC: halo exchange logical :: need_any_diags - logical, pointer :: config_isobaric + logical, pointer :: config_isobaric, config_pv_diag need_any_diags = .false. @@ -160,6 +174,7 @@ subroutine isobaric_diagnostics_compute(domain, exchange_halo_group) need_vort_isobaric = .false. call mpas_pool_get_config(configs, 'config_isobaric', config_isobaric) + call mpas_pool_get_config(configs, 'config_pv_diag', config_pv_diag) if (config_isobaric) then need_mslp = MPAS_field_will_be_written('mslp') @@ -194,6 +209,49 @@ subroutine isobaric_diagnostics_compute(domain, exchange_halo_group) end subroutine isobaric_diagnostics_compute + !================================================================================================== + subroutine isobaric_pv(domain, exchange_halo_group) + ! + ! > MC: subroutine is called by mpas_pv_diagnostics.F to interpolate PV to isobaric levels. + ! unlike for PV tendencies, only need to do this before writing file. this will be + ! determined in mpas_pv_diagnostics.F. + !================================================================================================== + + use mpas_atm_diagnostics_utils, only : MPAS_field_will_be_written + + implicit none + + type (domain_type), intent(inout) :: domain ! MC: halo exchange + procedure (halo_exchange_routine) :: exchange_halo_group ! MC: halo exchange + + need_ertelpv = .false. + need_ertelpv = MPAS_field_will_be_written('ertel_pv_isobaric') + + if (need_ertelpv) then + call mpas_log_write('Calling isobaric interpolation subroutine for ertel_pv.') + call interp_diagnostics_pv(domain, mesh, state, 1, diag, exchange_halo_group) + end if + + end subroutine isobaric_pv + + !================================================================================================== + subroutine isobaric_pv_tendencies(domain, exchange_halo_group) + ! + ! > MC: subroutine is called by mpas_pv_diagnostics.F to interpolate PV tendencies to isobaric levels. + ! If config_pv_tend is activated, need to do this at each time step. this is determined in + ! mpas_pv_diagnostics.F. + !================================================================================================== + + implicit none + + type (domain_type), intent(inout) :: domain ! MC: halo exchange + procedure (halo_exchange_routine) :: exchange_halo_group ! MC: halo exchange + + call mpas_log_write('Calling interp_diagnostics_pv_tend.') + call interp_diagnostics_pv_tend(domain, mesh, state, 1, diag, exchange_halo_group) + + end subroutine isobaric_pv_tendencies + !================================================================================================== subroutine interp_diagnostics(domain, mesh, state, time_lev, diag, exchange_halo_group) ! @@ -439,7 +497,6 @@ subroutine interp_diagnostics(domain, mesh, state, time_lev, diag, exchange_halo !enddo end if - call mpas_log_write('did mean and slp') if (allocated(pressure)) deallocate(pressure) if (allocated(temperature)) deallocate(temperature) @@ -447,6 +504,289 @@ subroutine interp_diagnostics(domain, mesh, state, time_lev, diag, exchange_halo end subroutine interp_diagnostics + !================================================================================================== + subroutine interp_diagnostics_pv(domain, mesh, state, time_lev, diag, exchange_halo_group) + !> MC: Interpolates ertel_pv to array of prescribed isobaric levels + !================================================================================================== + + implicit none + + ! Input arguments: + type (mpas_pool_type), intent(in) :: mesh + type (domain_type), intent(inout) :: domain ! MC: halo exchange + type (mpas_pool_type), intent(in) :: state + integer, intent(in) :: time_lev ! which time level to use from state + type (mpas_pool_type), intent(inout) :: diag + procedure (halo_exchange_routine) :: exchange_halo_group ! MC: halo exchange + + ! Local variables + integer :: iCell, k, kk + + ! Mesh variables and dimensions + integer, pointer :: nCells, nVertLevels + + ! Isobaric levels for interpolation + integer, pointer :: nIsoLevels + + ! Isolevels for all fields + real (kind=RKIND), dimension(:), pointer :: iso_levels + + ! Pressure variables + real (kind=RKIND), dimension(:,:), pointer :: pressure_b, pressure_p + real (kind=RKIND), dimension(:,:), allocatable :: pressure + + ! Fields to be interpolated (or from which fields are derived) + real (kind=RKIND), dimension(:,:), pointer :: ertel_pv + + ! Fields to interpolate: + real (kind=RKIND), dimension(:,:), pointer :: ertel_pv_isobaric + + ! Mesh variables + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + ! Isobaric levels -- need to amend if additonal level dims are used + call mpas_pool_get_dimension(mesh, 'nIsoLevels', nIsoLevels) + call mpas_pool_get_array(diag, 'iso_levels', iso_levels) + + ! Pressure variables + call exchange_halo_group(domain, 'isobaric:pressure_p') + call mpas_pool_get_array(diag, 'pressure_base', pressure_b) + call mpas_pool_get_array(diag, 'pressure_p', pressure_p) + + ! Fields to be interpolated + call mpas_pool_get_array(diag, 'ertel_pv', ertel_pv) + + ! Fields to interpolate: + call mpas_pool_get_array(diag, 'ertel_pv_isobaric', ertel_pv_isobaric) + + if(.not.allocated(pressure)) allocate(pressure(nVertLevels,nCells+1)) + + ! ----------------------------------------------------------------- + ! Calculate total pressure at mass points: + do iCell = 1,nCells + do k = 1,nVertLevels + pressure(k,iCell) = (pressure_p(k,iCell) + pressure_b(k,iCell)) / 100._RKIND + end do + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!! Interpolate fields to array of pressure levels !!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !-------------------------------------------------------------------- + ! Interpolate PV: + + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, ertel_pv, nIsoLevels, iso_levels, ertel_pv_isobaric) + + if (allocated(pressure)) deallocate(pressure) + + end subroutine interp_diagnostics_pv + + + !================================================================================================== + subroutine interp_diagnostics_pv_tend(domain, mesh, state, time_lev, diag, exchange_halo_group) + !================================================================================================== + + use mpas_pool_routines, only: mpas_pool_get_config + + implicit none + + ! Input arguments: + type (mpas_pool_type), intent(in) :: mesh + type (domain_type), intent(inout) :: domain ! MC: halo exchange + type (mpas_pool_type), intent(in) :: state + integer, intent(in) :: time_lev ! which time level to use from state + type (mpas_pool_type), intent(inout) :: diag + procedure (halo_exchange_routine) :: exchange_halo_group ! MC: halo exchange + + logical, pointer :: config_pv_microphys + + ! Local variables + integer :: iCell, k, kk + + ! Mesh variables and dimensions + integer, pointer :: nCells, nVertLevels + + ! Isobaric levels for interpolation + integer, pointer :: nIsoLevels + + ! Isolevels for all fields + real (kind=RKIND), dimension(:), pointer :: iso_levels + + ! Pressure variables + real (kind=RKIND), dimension(:,:), pointer :: pressure_b, pressure_p + real (kind=RKIND), dimension(:,:), allocatable :: pressure + + ! Fields to be interpolated (or from which fields are derived) + real (kind=RKIND), dimension(:,:), pointer :: depv_dt_lw, depv_dt_sw, depv_dt_bl, & + depv_dt_cu, depv_dt_mp, & + depv_dt_mix, & + depv_dt_fric_bl, depv_dt_fric_cu, depv_dt_fric_mix, & + depv_dt_diab, depv_dt_fric, depv_dt_dyn, & + dtheta_dt_cu, dtheta_dt_mp, & + depv_dt_mp_evap_rw, depv_dt_mp_evap_cw, & + depv_dt_mp_depo_ice, depv_dt_mp_melt_ice, & + depv_dt_mp_frez_ice, depv_dt_mp_allproc + + ! Fields to interpolate: + real (kind=RKIND), dimension(:,:), pointer :: depv_dt_lw_isobaric, depv_dt_sw_isobaric, & + depv_dt_bl_isobaric, depv_dt_cu_isobaric, & + depv_dt_mp_isobaric, depv_dt_mix_isobaric, & + depv_dt_fric_bl_isobaric, depv_dt_fric_cu_isobaric, & + depv_dt_fric_mix_isobaric, & + depv_dt_diab_isobaric, depv_dt_fric_isobaric, & + depv_dt_dyn_isobaric, & + dtheta_dt_cu_isobaric, dtheta_dt_mp_isobaric, & + depv_dt_mp_evap_rw_isobaric, depv_dt_mp_evap_cw_isobaric, & + depv_dt_mp_depo_ice_isobaric, depv_dt_mp_melt_ice_isobaric, & + depv_dt_mp_frez_ice_isobaric, depv_dt_mp_allproc_isobaric + + ! Mesh variables + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + ! Isobaric levels -- need to amend if additonal level dims are used + call mpas_pool_get_dimension(mesh, 'nIsoLevels', nIsoLevels) + call mpas_pool_get_array(diag, 'iso_levels', iso_levels) + + ! Pressure variables + call exchange_halo_group(domain, 'isobaric:pressure_p') + call mpas_pool_get_array(diag, 'pressure_base', pressure_b) + call mpas_pool_get_array(diag, 'pressure_p', pressure_p) + + ! Tendency variables to be interpolated + call mpas_pool_get_array(diag, 'depv_dt_lw', depv_dt_lw) + call mpas_pool_get_array(diag, 'depv_dt_sw', depv_dt_sw) + call mpas_pool_get_array(diag, 'depv_dt_bl', depv_dt_bl) + call mpas_pool_get_array(diag, 'depv_dt_cu', depv_dt_cu) + call mpas_pool_get_array(diag, 'depv_dt_mp', depv_dt_mp) + call mpas_pool_get_array(diag, 'depv_dt_mix', depv_dt_mix) + call mpas_pool_get_array(diag, 'depv_dt_fric_bl', depv_dt_fric_bl) + call mpas_pool_get_array(diag, 'depv_dt_fric_cu', depv_dt_fric_cu) + call mpas_pool_get_array(diag, 'depv_dt_fric_mix', depv_dt_fric_mix) + call mpas_pool_get_array(diag, 'depv_dt_diab', depv_dt_diab) + call mpas_pool_get_array(diag, 'depv_dt_fric', depv_dt_fric) + call mpas_pool_get_array(diag, 'depv_dt_dyn', depv_dt_dyn) + call mpas_pool_get_array(diag, 'dtheta_dt_cu', dtheta_dt_cu) + call mpas_pool_get_array(diag, 'dtheta_dt_mp', dtheta_dt_mp) + + ! Tendency variables to interpolate + call mpas_pool_get_array(diag, 'depv_dt_lw_isobaric', depv_dt_lw_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_sw_isobaric', depv_dt_sw_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_bl_isobaric', depv_dt_bl_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_cu_isobaric', depv_dt_cu_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_mp_isobaric', depv_dt_mp_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_mix_isobaric', depv_dt_mix_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_fric_bl_isobaric', depv_dt_fric_bl_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_fric_cu_isobaric', depv_dt_fric_cu_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_fric_mix_isobaric', depv_dt_fric_mix_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_diab_isobaric', depv_dt_diab_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_fric_isobaric', depv_dt_fric_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_dyn_isobaric', depv_dt_dyn_isobaric) + call mpas_pool_get_array(diag, 'dtheta_dt_cu_isobaric', dtheta_dt_cu_isobaric) + call mpas_pool_get_array(diag, 'dtheta_dt_mp_isobaric', dtheta_dt_mp_isobaric) + + ! Thompson microphysics process tendencies: + call mpas_pool_get_config(configs, 'config_pv_microphys', config_pv_microphys) + + if (config_pv_microphys) then + call mpas_pool_get_array(diag, 'depv_dt_mp_evap_rw', depv_dt_mp_evap_rw) + call mpas_pool_get_array(diag, 'depv_dt_mp_evap_cw', depv_dt_mp_evap_cw) + call mpas_pool_get_array(diag, 'depv_dt_mp_depo_ice', depv_dt_mp_depo_ice) + call mpas_pool_get_array(diag, 'depv_dt_mp_melt_ice', depv_dt_mp_melt_ice) + call mpas_pool_get_array(diag, 'depv_dt_mp_frez_ice', depv_dt_mp_frez_ice) + call mpas_pool_get_array(diag, 'depv_dt_mp_allproc', depv_dt_mp_allproc) + + call mpas_pool_get_array(diag, 'depv_dt_mp_evap_rw_isobaric', depv_dt_mp_evap_rw_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_mp_evap_cw_isobaric', depv_dt_mp_evap_cw_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_mp_depo_ice_isobaric', depv_dt_mp_depo_ice_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_mp_melt_ice_isobaric', depv_dt_mp_melt_ice_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_mp_frez_ice_isobaric', depv_dt_mp_frez_ice_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_mp_allproc_isobaric', depv_dt_mp_allproc_isobaric) + end if + + if(.not.allocated(pressure)) allocate(pressure(nVertLevels,nCells+1)) + + ! ----------------------------------------------------------------- + ! Calculate total pressure at mass points: + do iCell = 1,nCells + do k = 1,nVertLevels + pressure(k,iCell) = (pressure_p(k,iCell) + pressure_b(k,iCell)) / 100._RKIND + end do + end do + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!! Interpolate fields to array of pressure levels !!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !-------------------------------------------------------------------- + ! Interpolate PV tendencies: + + ! Longwave radiation: + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_lw, nIsoLevels, iso_levels, depv_dt_lw_isobaric) + + ! Shortwave radiation: + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_sw, nIsoLevels, iso_levels, depv_dt_sw_isobaric) + + ! PBL: + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_bl, nIsoLevels, iso_levels, depv_dt_bl_isobaric) + + ! Cumulus: + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_cu, nIsoLevels, iso_levels, depv_dt_cu_isobaric) + + ! Microphysics: + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_mp, nIsoLevels, iso_levels, depv_dt_mp_isobaric) + + ! Mixing: + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_mix, nIsoLevels, iso_levels, depv_dt_mix_isobaric) + + ! Friction - PBL: + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_fric_bl, nIsoLevels, iso_levels, depv_dt_fric_bl_isobaric) + + ! Friction - Cumulus: + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_fric_cu, nIsoLevels, iso_levels, depv_dt_fric_cu_isobaric) + + ! Friction - Mixing: + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_fric_mix, nIsoLevels, iso_levels, depv_dt_fric_mix_isobaric) + + ! Diabatic: + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_diab, nIsoLevels, iso_levels, depv_dt_diab_isobaric) + + ! Friction: + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_fric, nIsoLevels, iso_levels, depv_dt_fric_isobaric) + + ! Dynamics: + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_dyn, nIsoLevels, iso_levels, depv_dt_dyn_isobaric) + + !-------------------------------------------------------------------- + ! Interpolate potential temperature tendencies from latent heating: + + if (associated(dtheta_dt_cu)) then + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, dtheta_dt_cu, nIsoLevels, iso_levels, dtheta_dt_cu_isobaric) + end if + + if (associated(dtheta_dt_mp)) then + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, dtheta_dt_mp, nIsoLevels, iso_levels, dtheta_dt_mp_isobaric) + end if + + !-------------------------------------------------------------------- + ! Interpolate PV tendencies from specific microphysical processes: + if (config_pv_microphys) then + + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_mp_evap_rw, nIsoLevels, iso_levels, depv_dt_mp_evap_rw_isobaric) + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_mp_evap_cw, nIsoLevels, iso_levels, depv_dt_mp_evap_cw_isobaric) + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_mp_depo_ice, nIsoLevels, iso_levels, depv_dt_mp_depo_ice_isobaric) + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_mp_melt_ice, nIsoLevels, iso_levels, depv_dt_mp_melt_ice_isobaric) + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_mp_frez_ice, nIsoLevels, iso_levels, depv_dt_mp_frez_ice_isobaric) + call interp_field_cell_mass_levels(nCells, nVertLevels, pressure, depv_dt_mp_allproc, nIsoLevels, iso_levels, depv_dt_mp_allproc_isobaric) + end if + + if (allocated(pressure)) deallocate(pressure) + + end subroutine interp_diagnostics_pv_tend + !================================================================================================== subroutine interp_tofixed_pressure(ncol,nlev_in,nlev_out,pres_in,field_in,pres_out,field_out) diff --git a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F index 84e0535017..6ba74c90f4 100644 --- a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F @@ -70,8 +70,9 @@ end subroutine halo_exchange_routine ! -- config_pv_scalar : flag for whether pv_scalar is initialized as PV and then transported as passive scalar ! throughout the model integration ! -- config_pv_microphys : flag for whether specific microphysics process PV tendencies are desired (Thompson schemes only) - ! -- config_pv_isobaric : flag for whether isobaric interpolation of PV diagnostics variables is desired - ! (requires mods to mpas_isobaric_diagnostics.F) + ! -- config_pv_isobaric : flag for whether isobaric interpolation of PV tendency variables is desired + ! (requires mods to mpas_isobaric_diagnostics.F). if only ertel_pv_isobaric is desired, this + ! field may be computed with config_isobaric = .true. ! ! -------------------------------------------------------------------------------------------------------------------- ! Subroutines contained in fully updated mpas_pv_diagnostics.F: @@ -153,7 +154,7 @@ end subroutine halo_exchange_routine ! Note: these tendencies use the theta tendencies from the microphysics scheme directly, whereas depv_dt_mp is calculated ! using the derived theta tendency from the theta_m and qv tendencies. The differences in these approaches can be ! ascertained by comparing depv_dt_mp to depv_dt_mp_allproc - ! * Incorporation of routine to interpolate PV diagnostics to isobaric levels (code also modified in isobaric_diagnostics.F) + ! * Incorporation of routine to interpolate PV diagnostics to isobaric levels (code also modified in mpas_isobaric_diagnostics.F) ! and then accumulate the interpolated tendencies to isobaric levels. Requires config_pv_isobaric = .true. ! Note: changes to this procedure requires making changes to mpas_isobaric_diagnostics.F and Registry_isobaric.xml !===================================================================================================================== @@ -266,6 +267,7 @@ subroutine pv_diagnostics_init(domain, exchange_halo_group) ! Initialize PV scalar field call mpas_log_write("Calling pv_diagnostics_scalar_init().") call pv_diagnostics_scalar_init(domain, exchange_halo_group) + else if (config_do_restart .and. config_pv_scalar) then call mpas_log_write('config_do_restart = $l', logicArgs=(/config_do_restart/)) call mpas_log_write('--- skipping pv_scalar initialization.') @@ -294,8 +296,8 @@ subroutine pv_diagnostics_scalar_init(domain, exchange_halo_group) real(kind=RKIND), dimension(:,:), pointer :: ertel_pv real(kind=RKIND), dimension(:,:,:), pointer :: pv_scalars - call mpas_pool_get_dimension(state, 'index_pv_scalar', index_pv_scalar) - call mpas_pool_get_array(state, 'pv_scalars', pv_scalars) + call mpas_pool_get_dimension(state, 'index_pv_scalar', index_pv_scalar) + call mpas_pool_get_array(state, 'pv_scalars', pv_scalars, 1) call mpas_pool_get_array(diag, 'ertel_pv', ertel_pv) call exchange_halo_group(domain, 'diagnostics:pv_diag') @@ -2156,8 +2158,9 @@ end subroutine calc_epv subroutine atm_compute_pv_diagnostics(domain, configs, state, diag, mesh, exchange_halo_group) use mpas_constants - use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_config use mpas_dmpar, only : mpas_dmpar_exch_halo_field + use mpas_isobaric_diagnostics, only : isobaric_pv implicit none @@ -2173,6 +2176,7 @@ subroutine atm_compute_pv_diagnostics(domain, configs, state, diag, mesh, exchan integer, pointer :: nCells, nVertLevels, index_qv real (kind=RKIND) :: pvuVal, missingVal, stratoPV + logical, pointer :: config_isobaric, config_pv_isobaric ! MC - new halo communication procedure call exchange_halo_group(domain, 'diagnostics:pv_diag') @@ -2200,6 +2204,16 @@ subroutine atm_compute_pv_diagnostics(domain, configs, state, diag, mesh, exchan ! Call interp_pv_diagnostics subroutine to interpolate fields to dynamic tropopause call interp_pv_diagnostics(mesh, diag, pvuVal, missingVal) + ! Call ertel_pv isobaric interpolation here + call mpas_pool_get_config(configs, 'config_pv_isobaric', config_pv_isobaric) + call mpas_pool_get_config(configs, 'config_isobaric', config_isobaric) + + if (config_pv_isobaric .or. config_isobaric) then + call mpas_log_write("Calling isobaric_diagnostics_pv from atm_compute_pv_diagnostics") + call isobaric_pv(domain, exchange_halo_group) + end if + + end subroutine atm_compute_pv_diagnostics @@ -3422,6 +3436,7 @@ subroutine atm_compute_pvBudget_diagnostics(domain, configs, state, diag, mesh, use mpas_constants use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_config use mpas_dmpar, only : mpas_dmpar_exch_halo_field + use mpas_isobaric_diagnostics, only : isobaric_pv_tendencies implicit none @@ -3548,6 +3563,14 @@ subroutine atm_compute_pvBudget_diagnostics(domain, configs, state, diag, mesh, call mpas_log_write("Calling interp_pvBudget_diagnostics") call interp_pvBudget_diagnostics(mesh, diag, pvuVal, missingVal) + ! Interpolate fields to isobaric levels if desired: + call mpas_pool_get_config(configs, 'config_pv_isobaric', config_pv_isobaric) + + if (config_pv_isobaric) then + call mpas_log_write("Calling isobaric_pv_tend:") + call isobaric_pv_tendencies(domain,exchange_halo_group) + end if + ! Accumulate tendencies over multiple time steps: call mpas_log_write("Calling acc_pvBudget:") call acc_pvBudget(mesh, diag, tend_physics) @@ -3572,7 +3595,7 @@ subroutine acc_pvBudget(mesh, diag, tend_physics) type (mpas_pool_type), intent(inout) :: diag type (mpas_pool_type), intent(in) :: tend_physics - logical, pointer :: config_pv_tend, config_pv_microphys + logical, pointer :: config_pv_tend, config_pv_isobaric, config_pv_microphys integer, pointer :: nCells, nVertLevels integer :: iCell, k @@ -3597,8 +3620,31 @@ subroutine acc_pvBudget(mesh, diag, tend_physics) real(kind=RKIND), dimension(:,:), pointer :: dtheta_dt_cu, dtheta_dt_mp real(kind=RKIND), dimension(:,:), pointer :: acc_dtheta_dt_cu, acc_dtheta_dt_mp + ! Tendencies interpolated to isobaric levels + ! Note: all PV isobaric variables are defined in Registry_isobaric.xml + ! Isobaric interpolation occurs in mpas_isobaric_diagnostics.F + real(kind=RKIND), dimension(:,:), pointer :: depv_dt_lw_isobaric, depv_dt_sw_isobaric, depv_dt_bl_isobaric + real(kind=RKIND), dimension(:,:), pointer :: depv_dt_cu_isobaric, depv_dt_mp_isobaric, depv_dt_mix_isobaric + real(kind=RKIND), dimension(:,:), pointer :: depv_dt_fric_cu_isobaric, depv_dt_fric_bl_isobaric, depv_dt_fric_mix_isobaric + real(kind=RKIND), dimension(:,:), pointer :: depv_dt_diab_isobaric, depv_dt_fric_isobaric, depv_dt_dyn_isobaric + real(kind=RKIND), dimension(:,:), pointer :: depv_dt_mp_evap_rw_isobaric, depv_dt_mp_evap_cw_isobaric, & + depv_dt_mp_depo_ice_isobaric, depv_dt_mp_melt_ice_isobaric, & + depv_dt_mp_frez_ice_isobaric, depv_dt_mp_allproc_isobaric + real(kind=RKIND), dimension(:,:), pointer :: dtheta_dt_cu_isobaric, dtheta_dt_mp_isobaric + + ! Accumulated tendencies on isobaric levels + real(kind=RKIND), dimension(:,:), pointer :: acc_depv_dt_lw_isobaric, acc_depv_dt_sw_isobaric, acc_depv_dt_bl_isobaric + real(kind=RKIND), dimension(:,:), pointer :: acc_depv_dt_cu_isobaric, acc_depv_dt_mp_isobaric, acc_depv_dt_mix_isobaric + real(kind=RKIND), dimension(:,:), pointer :: acc_depv_dt_fric_bl_isobaric, acc_depv_dt_fric_cu_isobaric, acc_depv_dt_fric_mix_isobaric + real(kind=RKIND), dimension(:,:), pointer :: acc_depv_dt_diab_isobaric, acc_depv_dt_fric_isobaric, acc_depv_dt_dyn_isobaric + real(kind=RKIND), dimension(:,:), pointer :: acc_depv_dt_mp_evap_rw_isobaric, acc_depv_dt_mp_evap_cw_isobaric, & + acc_depv_dt_mp_depo_ice_isobaric, acc_depv_dt_mp_melt_ice_isobaric, & + acc_depv_dt_mp_frez_ice_isobaric, acc_depv_dt_mp_allproc_isobaric + real(kind=RKIND), dimension(:,:), pointer :: acc_dtheta_dt_cu_isobaric, acc_dtheta_dt_mp_isobaric + call mpas_pool_get_config(configs, 'config_pv_tend', config_pv_tend) call mpas_pool_get_config(configs, 'config_pv_microphys', config_pv_microphys) + call mpas_pool_get_config(configs, 'config_pv_isobaric', config_pv_isobaric) ! Instantaneous and accumulated PV tendencies call mpas_pool_get_array(diag, 'depv_dt_lw', depv_dt_lw) @@ -3657,7 +3703,51 @@ subroutine acc_pvBudget(mesh, diag, tend_physics) call mpas_pool_get_array(diag, 'acc_dtheta_dt_cu', acc_dtheta_dt_cu) call mpas_pool_get_array(diag, 'acc_dtheta_dt_mp', acc_dtheta_dt_mp) - ! Accumulate tendencies + ! Isobaric tendencies -- interpolate prior to accumulating + call mpas_pool_get_array(diag, 'depv_dt_lw_isobaric', depv_dt_lw_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_sw_isobaric', depv_dt_sw_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_bl_isobaric', depv_dt_bl_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_cu_isobaric', depv_dt_cu_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_mp_isobaric', depv_dt_mp_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_mix_isobaric', depv_dt_mix_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_fric_cu_isobaric', depv_dt_fric_cu_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_fric_bl_isobaric', depv_dt_fric_bl_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_fric_mix_isobaric', depv_dt_fric_mix_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_diab_isobaric', depv_dt_diab_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_fric_isobaric', depv_dt_fric_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_dyn_isobaric', depv_dt_dyn_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_mp_evap_rw_isobaric', depv_dt_mp_evap_rw_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_mp_evap_cw_isobaric', depv_dt_mp_evap_cw_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_mp_depo_ice_isobaric', depv_dt_mp_depo_ice_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_mp_melt_ice_isobaric', depv_dt_mp_melt_ice_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_mp_frez_ice_isobaric', depv_dt_mp_frez_ice_isobaric) + call mpas_pool_get_array(diag, 'depv_dt_mp_allproc_isobaric', depv_dt_mp_allproc_isobaric) + call mpas_pool_get_array(diag, 'dtheta_dt_cu_isobaric', dtheta_dt_cu_isobaric) + call mpas_pool_get_array(diag, 'dtheta_dt_mp_isobaric', dtheta_dt_mp_isobaric) + + ! Accumulated isobaric tendencies + call mpas_pool_get_array(diag, 'acc_depv_dt_lw_isobaric', acc_depv_dt_lw_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_sw_isobaric', acc_depv_dt_sw_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_bl_isobaric', acc_depv_dt_bl_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_cu_isobaric', acc_depv_dt_cu_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_mp_isobaric', acc_depv_dt_mp_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_mix_isobaric', acc_depv_dt_mix_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_fric_cu_isobaric', acc_depv_dt_fric_cu_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_fric_bl_isobaric', acc_depv_dt_fric_bl_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_fric_mix_isobaric', acc_depv_dt_fric_mix_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_diab_isobaric', acc_depv_dt_diab_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_fric_isobaric', acc_depv_dt_fric_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_dyn_isobaric', acc_depv_dt_dyn_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_mp_evap_rw_isobaric', acc_depv_dt_mp_evap_rw_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_mp_evap_cw_isobaric', acc_depv_dt_mp_evap_cw_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_mp_depo_ice_isobaric', acc_depv_dt_mp_depo_ice_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_mp_melt_ice_isobaric', acc_depv_dt_mp_melt_ice_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_mp_frez_ice_isobaric', acc_depv_dt_mp_frez_ice_isobaric) + call mpas_pool_get_array(diag, 'acc_depv_dt_mp_allproc_isobaric', acc_depv_dt_mp_allproc_isobaric) + call mpas_pool_get_array(diag, 'acc_dtheta_dt_cu_isobaric', acc_dtheta_dt_cu_isobaric) + call mpas_pool_get_array(diag, 'acc_dtheta_dt_mp_isobaric', acc_dtheta_dt_mp_isobaric) + + ! Accumulate tendencies acc_depv_dt_lw(:,:) = acc_depv_dt_lw(:,:) + depv_dt_lw(:,:) acc_depv_dt_sw(:,:) = acc_depv_dt_sw(:,:) + depv_dt_sw(:,:) acc_depv_dt_bl(:,:) = acc_depv_dt_bl(:,:) + depv_dt_bl(:,:) @@ -3693,6 +3783,38 @@ subroutine acc_pvBudget(mesh, diag, tend_physics) acc_depv_dt_mp_allproc(:,:) = acc_depv_dt_mp_allproc(:,:) + depv_dt_mp_allproc(:,:) end if + ! If PV variables on isobaric levels are requested, accumulate the isobaric tendencies + if (config_pv_isobaric) then + acc_depv_dt_lw_isobaric(:,:) = acc_depv_dt_lw_isobaric(:,:) + depv_dt_lw_isobaric(:,:) + acc_depv_dt_sw_isobaric(:,:) = acc_depv_dt_sw_isobaric(:,:) + depv_dt_sw_isobaric(:,:) + acc_depv_dt_bl_isobaric(:,:) = acc_depv_dt_bl_isobaric(:,:) + depv_dt_bl_isobaric(:,:) + acc_depv_dt_cu_isobaric(:,:) = acc_depv_dt_cu_isobaric(:,:) + depv_dt_cu_isobaric(:,:) + acc_depv_dt_mp_isobaric(:,:) = acc_depv_dt_mp_isobaric(:,:) + depv_dt_mp_isobaric(:,:) + acc_depv_dt_mix_isobaric(:,:) = acc_depv_dt_mix_isobaric(:,:) + depv_dt_mix_isobaric(:,:) + acc_depv_dt_fric_bl_isobaric(:,:) = acc_depv_dt_fric_bl_isobaric(:,:) + depv_dt_fric_bl_isobaric(:,:) + acc_depv_dt_fric_cu_isobaric(:,:) = acc_depv_dt_fric_cu_isobaric(:,:) + depv_dt_fric_cu_isobaric(:,:) + acc_depv_dt_fric_mix_isobaric(:,:) = acc_depv_dt_fric_mix_isobaric(:,:) + depv_dt_fric_mix_isobaric(:,:) + acc_depv_dt_diab_isobaric(:,:) = acc_depv_dt_diab_isobaric(:,:) + depv_dt_diab_isobaric(:,:) + acc_depv_dt_fric_isobaric(:,:) = acc_depv_dt_fric_isobaric(:,:) + depv_dt_fric_isobaric(:,:) + acc_depv_dt_dyn_isobaric(:,:) = acc_depv_dt_dyn_isobaric(:,:) + depv_dt_dyn_isobaric(:,:) + + if (associated(dtheta_dt_cu_isobaric)) then + acc_dtheta_dt_cu_isobaric(:,:) = acc_dtheta_dt_cu_isobaric(:,:) + dtheta_dt_cu_isobaric(:,:) + end if + if (associated(dtheta_dt_mp_isobaric)) then + acc_dtheta_dt_mp_isobaric(:,:) = acc_dtheta_dt_mp_isobaric(:,:) + dtheta_dt_mp_isobaric(:,:) + end if + + ! If specific microphysics process tendencies are requested, accumulate the isobaric tendencies + if (config_pv_microphys) then + acc_depv_dt_mp_evap_cw_isobaric(:,:) = acc_depv_dt_mp_evap_cw_isobaric(:,:) + depv_dt_mp_evap_cw_isobaric(:,:) + acc_depv_dt_mp_evap_rw_isobaric(:,:) = acc_depv_dt_mp_evap_rw_isobaric(:,:) + depv_dt_mp_evap_rw_isobaric(:,:) + acc_depv_dt_mp_depo_ice_isobaric(:,:) = acc_depv_dt_mp_depo_ice_isobaric(:,:) + depv_dt_mp_depo_ice_isobaric(:,:) + acc_depv_dt_mp_melt_ice_isobaric(:,:) = acc_depv_dt_mp_melt_ice_isobaric(:,:) + depv_dt_mp_melt_ice_isobaric(:,:) + acc_depv_dt_mp_frez_ice_isobaric(:,:) = acc_depv_dt_mp_frez_ice_isobaric(:,:) + depv_dt_mp_frez_ice_isobaric(:,:) + acc_depv_dt_mp_allproc_isobaric(:,:) = acc_depv_dt_mp_allproc_isobaric(:,:) + depv_dt_mp_allproc_isobaric(:,:) + end if + end if end subroutine acc_pvBudget diff --git a/src/core_atmosphere/mpas_atm_halos.F b/src/core_atmosphere/mpas_atm_halos.F index 0c283e1f8d..6a10f0a8e5 100644 --- a/src/core_atmosphere/mpas_atm_halos.F +++ b/src/core_atmosphere/mpas_atm_halos.F @@ -26,10 +26,11 @@ subroutine halo_exchange_routine(domain, halo_group, ierr) end subroutine halo_exchange_routine end interface + character(len=StrKIND), pointer, private :: config_halo_exch_method procedure (halo_exchange_routine), pointer :: exchange_halo_group ! MC: added logicals for diagnostics packages - logical, pointer :: config_tend, config_isobaric + logical, pointer :: config_tend, config_isobaric, config_pv_isobaric logical, pointer :: config_pv_diag, config_pv_tend, config_pv_scalar, & config_pv_microphys @@ -59,19 +60,16 @@ subroutine atm_build_halo_groups(domain, ierr) use mpas_halo, only : mpas_halo_init, mpas_halo_exch_group_create, mpas_halo_exch_group_add_field, & mpas_halo_exch_group_complete, mpas_halo_exch_group_full_halo_exch - ! Arguments type (domain_type), intent(inout) :: domain integer, intent(inout) :: ierr - ! Local variables - character(len=StrKIND), pointer :: config_halo_exch_method - ! MC: check for diagnostics packages call mpas_pool_get_config(domain % blocklist % configs, 'config_tend', config_tend) call mpas_pool_get_config(domain % blocklist % configs, 'config_pv_diag', config_pv_diag) call mpas_pool_get_config(domain % blocklist % configs, 'config_pv_tend', config_pv_tend) call mpas_pool_get_config(domain % blocklist % configs, 'config_pv_microphys', config_pv_microphys) call mpas_pool_get_config(domain % blocklist % configs, 'config_isobaric', config_isobaric) + call mpas_pool_get_config(domain % blocklist % configs, 'config_pv_isobaric', config_pv_isobaric) ! ! Determine from the namelist option config_halo_exch_method which halo exchange method to employ @@ -284,12 +282,14 @@ subroutine atm_build_halo_groups(domain, ierr) end if ! Isobaric interpolation - if (config_isobaric) then + if (config_isobaric .or. config_pv_isobaric) then call mpas_dmpar_exch_group_create(domain, 'isobaric:pressure_p') call mpas_dmpar_exch_group_add_field(domain, 'isobaric:pressure_p', 'pressure_p', timeLevel=1, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_create(domain, 'isobaric:vorticity') - call mpas_dmpar_exch_group_add_field(domain, 'isobaric:vorticity', 'vorticity', timeLevel=1, haloLayers=(/1,2/)) + if (config_isobaric) then + call mpas_dmpar_exch_group_create(domain, 'isobaric:vorticity') + call mpas_dmpar_exch_group_add_field(domain, 'isobaric:vorticity', 'vorticity', timeLevel=1, haloLayers=(/1,2/)) + end if end if @@ -537,14 +537,16 @@ subroutine atm_build_halo_groups(domain, ierr) end if ! Isobaric interpolation - if (config_isobaric) then + if (config_isobaric .or. config_pv_isobaric) then call mpas_halo_exch_group_create(domain, 'isobaric:pressure_p') call mpas_halo_exch_group_add_field(domain, 'isobaric:pressure_p', 'pressure_p', timeLevel=1, haloLayers=(/1,2/)) call mpas_halo_exch_group_complete(domain, 'isobaric:pressure_p') - call mpas_halo_exch_group_create(domain, 'isobaric:vorticity') - call mpas_halo_exch_group_add_field(domain, 'isobaric:vorticity', 'vorticity', timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_complete(domain, 'isobaric:vorticity') + if (config_isobaric) then + call mpas_halo_exch_group_create(domain, 'isobaric:vorticity') + call mpas_halo_exch_group_add_field(domain, 'isobaric:vorticity', 'vorticity', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'isobaric:vorticity') + end if end if ! @@ -589,15 +591,9 @@ subroutine atm_destroy_halo_groups(domain, ierr) use mpas_dmpar, only : mpas_dmpar_exch_group_destroy use mpas_halo, only : mpas_halo_exch_group_destroy, mpas_halo_finalize - ! Arguments type (domain_type), intent(inout) :: domain integer, intent(inout) :: ierr - ! Local variables - character(len=StrKIND), pointer :: config_halo_exch_method - - - call mpas_pool_get_config(domain % blocklist % configs, 'config_halo_exch_method', config_halo_exch_method) if (trim(config_halo_exch_method) == 'mpas_dmpar') then ! @@ -660,9 +656,11 @@ subroutine atm_destroy_halo_groups(domain, ierr) call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:dpv_mp_tend') end if - if (config_isobaric) then + if (config_isobaric .or. config_pv_isobaric) then call mpas_dmpar_exch_group_destroy(domain, 'isobaric:pressure_p') - call mpas_dmpar_exch_group_destroy(domain, 'isobaric:vorticity') + if (config_isobaric) then + call mpas_dmpar_exch_group_destroy(domain, 'isobaric:vorticity') + end if end if else if (trim(config_halo_exch_method) == 'mpas_halo') then @@ -729,10 +727,12 @@ subroutine atm_destroy_halo_groups(domain, ierr) call mpas_halo_exch_group_destroy(domain, 'diagnostics:dpv_mp_tend') end if - if (config_isobaric) then + if (config_isobaric .or. config_pv_isobaric) then call mpas_halo_exch_group_destroy(domain, 'isobaric:pressure_p') - call mpas_halo_exch_group_destroy(domain, 'isobaric:vorticity') - end if + if (config_isobaric) then + call mpas_halo_exch_group_destroy(domain, 'isobaric:vorticity') + end if + end if call mpas_halo_finalize(domain) From bea55b659d7dcfc1d9b4e3830820be8eca240343 Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Fri, 12 Jul 2024 20:00:24 -0600 Subject: [PATCH 20/23] Add missing inStrato variable --- src/core_atmosphere/diagnostics/Registry_pv.xml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/core_atmosphere/diagnostics/Registry_pv.xml b/src/core_atmosphere/diagnostics/Registry_pv.xml index dec2070300..89056959f8 100644 --- a/src/core_atmosphere/diagnostics/Registry_pv.xml +++ b/src/core_atmosphere/diagnostics/Registry_pv.xml @@ -425,6 +425,10 @@ description="1 if candidate of stratosphere" packages="pv_diagnostics"/> + + Date: Fri, 12 Jul 2024 22:50:55 -0600 Subject: [PATCH 21/23] Bug fix: add halo group for wCell;call in calc_epv - Code previously did halo exchange of wCell before it was calculated, leading to erroneous values of ertel_pv along halo region boundaries when nCellsSolve is used in mpas_pv_diagnostics.F subroutines rather than nCells. - Commit adds a separate halo group for wCell and calls this group in the calc_epv subroutine in mpas_pv_diagnostics.F --- .../diagnostics/mpas_pv_diagnostics.F | 10 +++++++--- src/core_atmosphere/mpas_atm_halos.F | 13 +++++++++++-- 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F index 6ba74c90f4..2cd28275bd 100644 --- a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F @@ -303,7 +303,7 @@ subroutine pv_diagnostics_scalar_init(domain, exchange_halo_group) call exchange_halo_group(domain, 'diagnostics:pv_diag') ! Calculate PV and initialize PV scalar variable as initial PV field - call calc_epv(mesh, state, diag) + call calc_epv(domain, mesh, state, diag, exchange_halo_group) call mpas_log_write('Initializing pv_scalar as the initial PV field.') pv_scalars(index_pv_scalar,:,:) = ertel_pv(:,:) @@ -1977,15 +1977,17 @@ end subroutine calc_density_term ! PV = 1/density * [curl(wind) . grad(theta)] !********************************************************************************************************************* - subroutine calc_epv(mesh, state, diag) + subroutine calc_epv(domain, mesh, state, diag, exchange_halo_group) use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array IMPLICIT NONE + type (domain_type), intent(inout) :: domain ! MC added -- test for new halo type (mpas_pool_type), intent(in) :: mesh type (mpas_pool_type), intent(in) :: state type (mpas_pool_type), intent(inout) :: diag + procedure (halo_exchange_routine) :: exchange_halo_group ! MC added for new halo ! Input variables -- mesh integer, pointer :: nCells, nCellsSolve, nVertLevels, nEdges, R3 @@ -2109,6 +2111,8 @@ subroutine calc_epv(mesh, state, diag) call interp_wLev_thetaLev(w, nCellsSolve, nVertLevels, wCell) + call exchange_halo_group(domain, 'diagnostics:pv_diag_wCell') ! MC -- exchange intermediate variable + call calc_gradOnEdges_reconCellCenter(wCell, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & latCell, lonCell, dW_dxZonal, dW_dyMerid) @@ -2181,7 +2185,7 @@ subroutine atm_compute_pv_diagnostics(domain, configs, state, diag, mesh, exchan call exchange_halo_group(domain, 'diagnostics:pv_diag') ! Call calc_epv subroutine - call calc_epv(mesh, state, diag) + call calc_epv(domain, mesh, state, diag, exchange_halo_group) ! Halo cells need to be valid for flood fill routines called below call exchange_halo_group(domain, 'diagnostics:ertel_pv') diff --git a/src/core_atmosphere/mpas_atm_halos.F b/src/core_atmosphere/mpas_atm_halos.F index 6a10f0a8e5..865c806d53 100644 --- a/src/core_atmosphere/mpas_atm_halos.F +++ b/src/core_atmosphere/mpas_atm_halos.F @@ -215,10 +215,13 @@ subroutine atm_build_halo_groups(domain, ierr) call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:pv_diag', 'uReconstructZonal', timeLevel=1, haloLayers=(/1,2/)) call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:pv_diag', 'uReconstructMeridional', timeLevel=1, haloLayers=(/1,2/)) call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:pv_diag', 'w', timeLevel=1, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:pv_diag', 'wCell', timeLevel=1, haloLayers=(/1,2/)) + !call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:pv_diag', 'wCell', timeLevel=1, haloLayers=(/1,2/)) call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:pv_diag', 'rho', timeLevel=1, haloLayers=(/1,2/)) call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:pv_diag', 'pv_vertex', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_create(domain, 'diagnostics:pv_diag_wCell') + call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:pv_diag_wCell', 'wCell', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_create(domain, 'diagnostics:inStrato') call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:inStrato', 'inStrato', timeLevel=1, haloLayers=(/1,2/)) @@ -458,11 +461,15 @@ subroutine atm_build_halo_groups(domain, ierr) call mpas_halo_exch_group_add_field(domain, 'diagnostics:pv_diag', 'uReconstructZonal', timeLevel=1, haloLayers=(/1,2/)) call mpas_halo_exch_group_add_field(domain, 'diagnostics:pv_diag', 'uReconstructMeridional', timeLevel=1, haloLayers=(/1,2/)) call mpas_halo_exch_group_add_field(domain, 'diagnostics:pv_diag', 'w', timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'diagnostics:pv_diag', 'wCell', timeLevel=1, haloLayers=(/1,2/)) + !call mpas_halo_exch_group_add_field(domain, 'diagnostics:pv_diag', 'wCell', timeLevel=1, haloLayers=(/1,2/)) call mpas_halo_exch_group_add_field(domain, 'diagnostics:pv_diag', 'rho', timeLevel=1, haloLayers=(/1,2/)) call mpas_halo_exch_group_add_field(domain, 'diagnostics:pv_diag', 'pv_vertex', timeLevel=1, haloLayers=(/1,2/)) call mpas_halo_exch_group_complete(domain, 'diagnostics:pv_diag') + call mpas_halo_exch_group_create(domain, 'diagnostics:pv_diag_wCell') + call mpas_halo_exch_group_add_field(domain, 'diagnostics:pv_diag_wCell', 'wCell', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'diagnostics:pv_diag_wCell') + ! MC note: these currently are not supported because they're integer fields !call mpas_halo_exch_group_create(domain, 'diagnostics:inStrato') !call mpas_halo_exch_group_add_field(domain, 'diagnostics:inStrato', 'inStrato', timeLevel=1, haloLayers=(/1,2/)) @@ -643,6 +650,7 @@ subroutine atm_destroy_halo_groups(domain, ierr) call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:inTropo') call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:iLev_DT') call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:ertel_pv') + call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:pv_diag_wCell') end if if (config_pv_tend) then @@ -713,6 +721,7 @@ subroutine atm_destroy_halo_groups(domain, ierr) !call mpas_halo_exch_group_destroy(domain, 'diagnostics:inTropo') !call mpas_halo_exch_group_destroy(domain, 'diagnostics:iLev_DT') call mpas_halo_exch_group_destroy(domain, 'diagnostics:ertel_pv') + call mpas_halo_exch_group_destroy(domain, 'diagnostics:pv_diag_wCell') end if From b9c3ec44aed09e8f7857abc4f3fcd0d30df2b16d Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Fri, 12 Jul 2024 22:51:30 -0600 Subject: [PATCH 22/23] Bug fix: halos for intermediate wCell tend vars - Code previously did halo exchanges of intermediate wCell tendency variables before they were calculated, leading to erroneous values of depv_dt_fric and depv_dt_dyn along halo region boundaries when nCellsSolve is used in mpas_pv_diagnostics.F subroutines rather than nCells. - Commit adds separate halo groups for the wCell tendencies and calls these groups in the calc_pvBudget subroutine in mpas_pv_diagnostics.F --- .../diagnostics/mpas_pv_diagnostics.F | 10 +++++++-- src/core_atmosphere/mpas_atm_halos.F | 22 +++++++++++++++---- 2 files changed, 26 insertions(+), 6 deletions(-) diff --git a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F index 2cd28275bd..e8407fda0b 100644 --- a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F @@ -2232,13 +2232,14 @@ end subroutine atm_compute_pv_diagnostics ! at the end of the time step and the tendencies responsible for updating them! !********************************************************************************************************************* - subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_physics) + subroutine calc_pvBudget(domain, configs, state, diag, mesh, tend, tend_physics, diag_physics, exchange_halo_group) use mpas_vector_reconstruction use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_config implicit none + type (domain_type), intent(inout) :: domain type (mpas_pool_type), intent(in) :: configs type (mpas_pool_type), intent(in) :: state type (mpas_pool_type), intent(inout) :: diag @@ -2246,6 +2247,7 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph type (mpas_pool_type), intent(in) :: tend_physics type (mpas_pool_type), intent(in) :: diag_physics type (mpas_pool_type), intent(inout) :: tend + procedure (halo_exchange_routine) :: exchange_halo_group ! MC - new halo ! mesh / configuration variables real(kind=RKIND), pointer :: config_dt @@ -3087,6 +3089,8 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph ! dWtend_dxZonal, dWtend_dyMerid call interp_wLev_thetaLev(w_tend_diff, nCellsSolve, nVertLevels, tend_wCell_diff) + call exchange_halo_group(domain, 'diagnostics:dpv_diff_wCell') + call calc_gradOnEdges_reconCellCenter(tend_wCell_diff, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & latCell, lonCell, dWtend_dxZonal, dWtend_dyMerid) @@ -3254,6 +3258,8 @@ subroutine calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_ph ! is consistent with the procedure in the vorticity calculation call interp_wLev_thetaLev(dw_dt_dyn, nCellsSolve, nVertLevels, tenddyn_wCell) + call exchange_halo_group(domain, 'diagnostics:dpv_dyn_wCell') + call calc_gradOnEdges_reconCellCenter(tenddyn_wCell, nCellsSolve, nEdges, nVertLevels, nEdgesOnCell, & edgesOnCell, edgesOnCell_sign, cellsOnEdge, dcEdge, coeffs_reconstruct, & latCell, lonCell, dWtend_dxZonal, dWtend_dyMerid) @@ -3558,7 +3564,7 @@ subroutine atm_compute_pvBudget_diagnostics(domain, configs, state, diag, mesh, ! Calculating PV budget: call mpas_log_write("Calling calc_pvBudget:") - call calc_pvBudget(configs, state, diag, mesh, tend, tend_physics, diag_physics) + call calc_pvBudget(domain, configs, state, diag, mesh, tend, tend_physics, diag_physics, exchange_halo_group) ! Interpolate fields to DT: pvuVal = 2.0_RKIND diff --git a/src/core_atmosphere/mpas_atm_halos.F b/src/core_atmosphere/mpas_atm_halos.F index 865c806d53..78690514de 100644 --- a/src/core_atmosphere/mpas_atm_halos.F +++ b/src/core_atmosphere/mpas_atm_halos.F @@ -260,13 +260,17 @@ subroutine atm_build_halo_groups(domain, ierr) call mpas_dmpar_exch_group_create(domain, 'diagnostics:dpv_mom_tend') call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'du_dt_dyn', timeLevel=1, haloLayers=(/1,2/)) call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'dw_dt_dyn', timeLevel=1, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'tenddyn_wCell', timeLevel=1, haloLayers=(/1,2/)) call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'u_tend_diff', timeLevel=1, haloLayers=(/1,2/)) call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'w_tend_diff', timeLevel=1, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'tend_wCell_diff', timeLevel=1, haloLayers=(/1,2/)) call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'tend_u_pbl', timeLevel=1, haloLayers=(/1,2/)) call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'tend_u_cu', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_create(domain, 'diagnostics:dpv_dyn_wCell') + call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_dyn_wCell', 'tenddyn_wCell', timeLevel=1, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'diagnostics:dpv_diff_wCell') + call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_diff_wCell', 'tend_wCell_diff', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_create(domain, 'diagnostics:dpv_mom_curl') call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mom_curl', 'uTend_curl_dyn', timeLevel=1, haloLayers=(/1,2/)) call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mom_curl', 'uTend_curl_diff', timeLevel=1, haloLayers=(/1,2/)) @@ -515,14 +519,20 @@ subroutine atm_build_halo_groups(domain, ierr) call mpas_halo_exch_group_create(domain, 'diagnostics:dpv_mom_tend') call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'du_dt_dyn', timeLevel=1, haloLayers=(/1,2/)) call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'dw_dt_dyn', timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'tenddyn_wCell', timeLevel=1, haloLayers=(/1,2/)) call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'u_tend_diff', timeLevel=1, haloLayers=(/1,2/)) call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'w_tend_diff', timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'tend_wCell_diff', timeLevel=1, haloLayers=(/1,2/)) call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'tend_u_pbl', timeLevel=1, haloLayers=(/1,2/)) call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mom_tend', 'tend_u_cu', timeLevel=1, haloLayers=(/1,2/)) call mpas_halo_exch_group_complete(domain, 'diagnostics:dpv_mom_tend') + call mpas_halo_exch_group_create(domain, 'diagnostics:dpv_dyn_wCell') + call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_dyn_wCell', 'tenddyn_wCell', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'diagnostics:dpv_dyn_wCell') + + call mpas_halo_exch_group_create(domain, 'diagnostics:dpv_diff_wCell') + call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_diff_wCell', 'tend_wCell_diff', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'diagnostics:dpv_diff_wCell') + call mpas_halo_exch_group_create(domain, 'diagnostics:dpv_mom_curl') call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mom_curl', 'uTend_curl_dyn', timeLevel=1, haloLayers=(/1,2/)) call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mom_curl', 'uTend_curl_diff', timeLevel=1, haloLayers=(/1,2/)) @@ -657,6 +667,8 @@ subroutine atm_destroy_halo_groups(domain, ierr) call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:dpv_prev') call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:dpv_th_tend') call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:dpv_mom_tend') + call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:dpv_dyn_wCell') + call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:dpv_diff_wCell') call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:dpv_mom_curl') end if @@ -729,6 +741,8 @@ subroutine atm_destroy_halo_groups(domain, ierr) call mpas_halo_exch_group_destroy(domain, 'diagnostics:dpv_prev') call mpas_halo_exch_group_destroy(domain, 'diagnostics:dpv_th_tend') call mpas_halo_exch_group_destroy(domain, 'diagnostics:dpv_mom_tend') + call mpas_halo_exch_group_destroy(domain, 'diagnostics:dpv_dyn_wCell') + call mpas_halo_exch_group_destroy(domain, 'diagnostics:dpv_diff_wCell') call mpas_halo_exch_group_destroy(domain, 'diagnostics:dpv_mom_curl') end if From 0a252daf4068c53b3c357dac02e18fd5e9acd106 Mon Sep 17 00:00:00 2001 From: Manda Chasteen Date: Wed, 2 Oct 2024 16:08:30 -0600 Subject: [PATCH 23/23] Bug fixes for pv_scalars, add depv_dt_scalar_adv Additions: - Add pv_scalar_dt variable to Registry.xml, which will be reset to the updated ertel_pv field at the end of each time step - Add depv_dt_scalar_adv, acc_depv_dt_scalar_adv to track the PV tendencies from advecting PV as a scalar variable through pv_scalar_dt Bug fixes: - Add halo groups for pv_scalars at time levels 1 and 2 to mpas_atm_halos.F - Add halo exchanges for pv_scalars to mpas_atm_time_integration.F - Add advance_scalars option for pv_scalars when split scalar transport isn't selected - Removed rk_step == 3 dependence on advance_scalars for pv_scalars - Modified the dqv_dt_dyn, acc_dqv_dt_dyn calculations to be consistent with qv dynamics tendency for both monotonic and non-monotonic scalar transport --- src/core_atmosphere/Registry.xml | 15 +++- .../diagnostics/Registry_pv.xml | 11 +++ .../diagnostics/mpas_pv_diagnostics.F | 72 ++++++++++++++++--- .../dynamics/mpas_atm_time_integration.F | 41 +++++++++-- src/core_atmosphere/mpas_atm_halos.F | 33 ++++++++- 5 files changed, 156 insertions(+), 16 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index beec5245e9..cfabf78f47 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1622,9 +1622,15 @@ + + + @@ -1929,8 +1935,13 @@ + + + diff --git a/src/core_atmosphere/diagnostics/Registry_pv.xml b/src/core_atmosphere/diagnostics/Registry_pv.xml index 89056959f8..cb478fb68c 100644 --- a/src/core_atmosphere/diagnostics/Registry_pv.xml +++ b/src/core_atmosphere/diagnostics/Registry_pv.xml @@ -207,6 +207,17 @@ streams="restart"/> + + + + + +