diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml
index 10cfbca3ea..cfabf78f47 100644
--- a/src/core_atmosphere/Registry.xml
+++ b/src/core_atmosphere/Registry.xml
@@ -410,6 +410,14 @@
+
+
+
+
+
+
+
+
@@ -911,27 +919,7 @@
-
-
-
-
-
-
-
#ifdef DO_PHYSICS
-
-
-
-
-
-
-
-
-
-
-
-
-
@@ -973,6 +961,66 @@
#endif
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
#ifdef DO_PHYSICS
@@ -1628,8 +1619,22 @@
#endif
-
+
+
+
+
+
+
+
+
+
@@ -1715,9 +1720,6 @@
-
-
@@ -1929,6 +1931,19 @@
packages="mp_thompson_aers_in"/>
#endif
+
+
+
+
+
+
+
+
+
@@ -2446,6 +2461,28 @@
description="precipitable water"/>
+
+
+
+
+
+
+
+
+
+
+
+
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/Registry_diagnostics.xml b/src/core_atmosphere/diagnostics/Registry_diagnostics.xml
index b9e7dc5682..fb6d55badf 100644
--- a/src/core_atmosphere/diagnostics/Registry_diagnostics.xml
+++ b/src/core_atmosphere/diagnostics/Registry_diagnostics.xml
@@ -19,6 +19,59 @@
#include "Registry_soundings.xml"
+
+#include "Registry_tendencies.xml"
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/core_atmosphere/diagnostics/Registry_isobaric.xml b/src/core_atmosphere/diagnostics/Registry_isobaric.xml
index 853be6cde3..e39611b70a 100644
--- a/src/core_atmosphere/diagnostics/Registry_isobaric.xml
+++ b/src/core_atmosphere/diagnostics/Registry_isobaric.xml
@@ -3,224 +3,252 @@
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+ description="Mean sea-level pressure"
+ packages="isobaric"/>
-
+
diff --git a/src/core_atmosphere/diagnostics/Registry_pv.xml b/src/core_atmosphere/diagnostics/Registry_pv.xml
index d776ec2a15..cb478fb68c 100644
--- a/src/core_atmosphere/diagnostics/Registry_pv.xml
+++ b/src/core_atmosphere/diagnostics/Registry_pv.xml
@@ -1,68 +1,449 @@
-
-
+
+
+
-
+
+
+
+
+
+
-
-
-
-
+ 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..9631fe949a
--- /dev/null
+++ b/src/core_atmosphere/diagnostics/Registry_tendencies.xml
@@ -0,0 +1,444 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F
index fb57411d1d..3e5854f175 100644
--- a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F
+++ b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F
@@ -7,13 +7,38 @@
!
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, &
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
@@ -54,14 +79,43 @@ 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 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
+ !-----------------------------------------------------------------------
+ ! 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
@@ -73,17 +127,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 +158,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,13 +169,19 @@ 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 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')
end subroutine mpas_atm_diag_compute
@@ -133,13 +200,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_atm_diagnostics_packages.F b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_packages.F
new file mode 100644
index 0000000000..2d1d08e615
--- /dev/null
+++ b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_packages.F
@@ -0,0 +1,280 @@
+! 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
+
+ ! Isobaric diagnostics config:
+ logical, pointer :: config_isobaric
+
+ ! Isobaric diagnostics package:
+ logical, pointer :: isobaricActive
+
+ integer :: ierr
+
+!-----------------------------------------------------------------------------------------------------------------
+
+! call mpas_log_write('')
+! call mpas_log_write('--- enter subroutine diagnostics_setup_packages:')
+
+ 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:
+!-----------------------------------------------------------------------------------------------------------------
+
+ 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 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
+
+
+ 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/diagnostics/mpas_isobaric_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F
index e52c71b125..0c9070ddcb 100644
--- a/src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F
+++ b/src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F
@@ -11,32 +11,56 @@ 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 :: 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
+
+ !
+ ! 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
+ isobaric_diagnostics_compute, &
+ isobaric_pv, isobaric_pv_tendencies
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, &
+ ! 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
@@ -50,24 +74,61 @@ 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, config_pv_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_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 .or. config_pv_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 +143,650 @@ 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, config_pv_diag
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)
+ call mpas_pool_get_config(configs, 'config_pv_diag', config_pv_diag)
+
+ 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 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.
!==================================================================================================
- !input arguments:
+ 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)
+ !
+ !> MC: Interpolates conventional model fields (e.g., potential temperature) 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
-
- !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,:,:)
+
+ 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))
+
+ temperature(:,:) = 0.0
+ dewpoint(:,:) = 0.0
- ! 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)
+ ! -----------------------------------------------------------------
+ ! 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
- ! 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
+ ! -----------------------------------------------------------------
+ ! 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
+ !enddo
end if
+
+
+ if (allocated(pressure)) deallocate(pressure)
+ if (allocated(temperature)) deallocate(temperature)
+ if (allocated(dewpoint)) deallocate(dewpoint)
+
+ end subroutine interp_diagnostics
-
- !!!!!!!!!!! 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)
- 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
+ !==================================================================================================
+ 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
-
- 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
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !!!!!!!!!!! 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
-
- deallocate(field_in)
- deallocate(field_interp)
- deallocate(press_in)
- deallocate(press_interp)
- end if
+ 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)
- if(allocated(temperature) ) deallocate(temperature )
- if(allocated(pressure2) ) deallocate(pressure2 )
- if(allocated(pressure) ) deallocate(pressure )
- if(allocated(dewpoint) ) deallocate(dewpoint )
-
- end subroutine interp_diagnostics
+ ! 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)
@@ -1089,9 +876,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 +1324,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/diagnostics/mpas_pv_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F
index d21061b0fb..301e3a68c2 100644
--- a/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F
+++ b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F
@@ -2,1649 +2,3891 @@
! 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_reset, &
+ pv_diagnostics_update, &
+ pv_diagnostics_init ! If config_pv_scalar, need to initialize as initial PV field
+ 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 schemes only)
+ ! -- 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.
!
- !> \brief Initialize the diagnostic
- !> \author
- !> \date
- !> \details
- !> Initialize the diagnostic
+ ! --------------------------------------------------------------------------------------------------------------------
+ ! 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
+ ! 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
!
- !-----------------------------------------------------------------------
- subroutine pv_diagnostics_setup(all_pools, simulation_clock)
+ ! 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
+ ! ********************************************************************************************************************
+ !
+ ! 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.
+ !
+ ! 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 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
+ ! 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 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
+ !=====================================================================================================================
+
+ 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
+
+ ! 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)
-#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
+
+ 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
- !-----------------------------------------------------------------------
- ! 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()
+ !*********************************************************************************************************************
+ ! 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.
+ !*********************************************************************************************************************
- use mpas_atm_diagnostics_utils, only : MPAS_field_will_be_written
+ subroutine pv_diagnostics_init(domain, exchange_halo_group)
+ use mpas_pool_routines, only : mpas_pool_get_array, 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_scalar, config_do_restart
+ real(kind=RKIND), dimension(:,:,:), pointer :: pv_scalars
- real(kind=RKIND) function dotProduct(a, b, sz)
+ call mpas_pool_get_config(configs, 'config_pv_scalar', config_pv_scalar)
+ call mpas_pool_get_config(configs, 'config_do_restart', config_do_restart)
- implicit none
+ 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)
- real(kind=RKIND), dimension(:), intent(in) :: a, b
- integer, intent(in) :: sz
+ 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
- integer :: i
- real(kind=RKIND) :: rsum
+ end subroutine pv_diagnostics_init
- rsum = 0.0_RKIND
- do i=1,sz
- rsum = rsum + a(i)*b(i)
- end do
+ !*********************************************************************************************************************
+ ! 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
- dotProduct = rsum
- end function dotProduct
+ implicit none
- integer function elementIndexInArray(val, array, sz)
+ type (domain_type), intent(inout) :: domain
+ procedure (halo_exchange_routine) :: exchange_halo_group
- implicit none
+ logical, pointer :: config_pv_diag, config_pv_scalar
+ integer, pointer :: index_pv_scalar
- 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 :)
- end if
- end do
- elementIndexInArray = ind
- end function elementIndexInArray
+ real(kind=RKIND), dimension(:,:), pointer :: ertel_pv
+ real(kind=RKIND), dimension(:,:,:), pointer :: pv_scalars_1, pv_scalars_2
+
+ call mpas_pool_get_dimension(state, 'index_pv_scalar', index_pv_scalar)
+ call mpas_pool_get_array(state, 'pv_scalars', pv_scalars_1, 1)
+ call mpas_pool_get_array(state, 'pv_scalars', pv_scalars_2, 2)
+ 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(domain, mesh, state, diag, exchange_halo_group)
+
+ call mpas_log_write('Initializing pv_scalar as the initial PV field.')
+ pv_scalars_1(index_pv_scalar,:,:) = ertel_pv(:,:)
+ pv_scalars_2(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
+ !*********************************************************************************************************************
- real(kind=RKIND) function formErtelPV(gradxu, gradtheta, density, unitX, unitY, unitZ)
+ 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, mpas_pool_get_array
+
+ implicit none
- use mpas_constants, only : omega_e => omega
+ type (domain_type), intent(inout) :: domain
+ procedure (halo_exchange_routine) :: exchange_halo_group
+ logical, pointer :: config_pv_diag, config_pv_tend
- implicit none
+ 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)
+
+
+ ! 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)
+
+ ! 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
+
+
+ !*********************************************************************************************************************
+ ! 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
+
+ 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), 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
+ ! 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
- real(kind=RKIND) :: epv, eVort
- real(kind=RKIND), dimension(3) :: eVortDir, eVortComponents
+ end subroutine pv_diagnostics_compute
- !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
- eVortComponents(1) = dotProduct(eVortDir, unitX,3)
- eVortComponents(2) = dotProduct(eVortDir, unitY,3)
- eVortComponents(3) = dotProduct(eVortDir, unitZ,3)
+ !*********************************************************************************************************************
+ ! 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
+ !*********************************************************************************************************************
- gradxu(:) = gradxu(:) + eVortComponents(:)
+ 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
- epv = dotProduct(gradxu, gradtheta,3) / density
+ implicit none
- epv = epv * 1.0e6 !SI to PVUs
+ logical, pointer :: config_pv_diag, config_pv_tend, config_pv_scalar
+ integer, pointer :: nCells, nVertLevels
+ integer, pointer :: index_pv_scalar_dt
+ real(kind=RKIND), dimension(:,:), pointer :: rho, ertel_pv
+ real(kind=RKIND), dimension(:,:,:), pointer :: pv_scalars_1, pv_scalars_2
+ 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_config(configs, 'config_pv_scalar', config_pv_scalar)
+
+ 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
+
+ ! Reset pv_scalar_dt to updated PV field
+ ! Note: this variable is updated at each timestep, whereas pv_scalar is not
+ if (config_pv_scalar) then
+ call mpas_pool_get_dimension(state, 'index_pv_scalar_dt', index_pv_scalar_dt)
+ call mpas_pool_get_array(state, 'pv_scalars', pv_scalars_1, 1)
+ call mpas_pool_get_array(state, 'pv_scalars', pv_scalars_2, 2)
+ call mpas_pool_get_array(diag, 'ertel_pv', ertel_pv)
+
+ call mpas_log_write('Resetting pv_scalar_dt to the updated PV field.')
+ pv_scalars_1(index_pv_scalar_dt,:,:) = ertel_pv(:,:)
+ pv_scalars_2(index_pv_scalar_dt,:,:) = ertel_pv(:,:)
+ 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
+ ! 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.
+ !*********************************************************************************************************************
- formErtelPV = epv
- end function formErtelPV
-
- subroutine local2FullVorticity(gradxu, unitX, unitY, unitZ)
- !given gradxu, return gradxu+earthVort
-
- use mpas_constants, only : omega_e => omega
+ 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
+ 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
- implicit none
+ ! 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
- 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
+ ! 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
- !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
+ end if ! interfaceLev > 0
+ end if ! intCounts
+ end do lev_id
+ end if
- eVortComponents(1) = dotProduct(eVortDir, unitX,3)
- eVortComponents(2) = dotProduct(eVortDir, unitY,3)
- eVortComponents(3) = dotProduct(eVortDir, unitZ,3)
+ 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
- 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
+ ! 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
- 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
+ else
+ cycle cells
+ end if
- real(kind=RKIND) :: vVortCell
- integer :: i, iVertex, cellIndOnVertex
+ 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
- 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
+ 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
- calc_verticalVorticity_cell = vVortCell
- end function calc_verticalVorticity_cell
+ 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
- subroutine coordinateSystem_cell(cellTangentPlane, localVerticalUnitVectors, c0, xyz)
+ 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)
- implicit none
+ 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)
- 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
+ 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)
- integer :: i
+ call interp_pv(nCells, nVertLevels, pvuVal, latCell, &
+ ertel_pv, uReconstructMeridional, v_pv, missingVal, iLev_DT)
- 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
+ ! Interpolate theta
+ call interp_pv(nCells, nVertLevels, pvuVal, latCell, &
+ ertel_pv, theta, theta_pv, missingVal, iLev_DT)
- real(kind=RKIND) function fluxSign(c0, iEdge, cellsOnEdge)
-
- !For finite volume computations, we'll use a normal pointing out of the cell
- implicit none
+ ! Interpolate height of cell center
+ call interp_wLev_thetaLev(zgrid, nCells, nVertLevels, zCell)
- integer, intent(in) :: c0
- integer, intent(in) :: iEdge
- integer, dimension(:,:), intent(in) :: cellsOnEdge
+ ! convert geometric to geopotential height:
+ zCell_geo = (zCell * r_earth)/(zCell + r_earth)
- if (c0 == cellsOnEdge(1,iEdge)) then
- fluxSign = 1.0_RKIND
- else
- fluxSign = -1.0_RKIND
- end if
- end function fluxSign
+ 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 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
+ !*********************************************************************************************************************
+
+ 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
- real(kind=RKIND) function calc_heightCellCenter(c0, level, zgrid)
+ end do
- implicit none
+ end subroutine interp_pv
- integer, intent(in) :: c0, level
- real(kind=RKIND), dimension(:,:), intent(in) :: zgrid
+ !*********************************************************************************************************************
+ ! MC: Subroutine to calculate the dot product between two 3D vectors
+ !*********************************************************************************************************************
- calc_heightCellCenter = 0.5*(zgrid(level,c0)+zgrid(level+1,c0))
- end function calc_heightCellCenter
+ subroutine calc_dotProduct_3D(vec1, vec2, nCells, nVertLevels, dotResult)
- real(kind=RKIND) function calc_heightVerticalEdge(c0, c1, level, zgrid)
+ IMPLICIT NONE
- implicit none
+ integer, intent(in) :: nVertLevels, nCells
+ real(kind=RKIND), dimension(:,:,:), intent(in) :: vec1, vec2
+ real(kind=RKIND), dimension(:,:), intent(out) :: dotResult
+ integer :: iCell, k
- integer, intent(in) :: c0, c1, level
- real(kind=RKIND), dimension(:,:), intent(in) :: zgrid
+ dotResult(:,:) = 0.0_RKIND
- real(kind=RKIND) :: hTop, hBottom
+ 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
- hTop = .5*(zgrid(level+1,c0)+zgrid(level+1,c1))
- hBottom = .5*(zgrid(level,c0)+zgrid(level,c1))
+ end subroutine calc_dotProduct_3D
- calc_heightVerticalEdge = hTop-hBottom
- end function calc_heightVerticalEdge
+ !*********************************************************************************************************************
+ ! MC: Subroutine to interpolate the absolute vertical vorticity to cell centers from the absolute
+ ! vertical vorticity at the vertices (pv_vertex)
+ !*********************************************************************************************************************
- subroutine normalizeVector(vals, sz)
- !normalize a vector to unit magnitude
- implicit none
+ subroutine interp_absVertVort(pv_vertex, nCells, nEdgesOnCell, verticesOnCell, &
+ cellsOnVertex, areaCell, kiteAreasOnVertex, absVort)
- real (kind=RKIND), dimension(:), intent(inout) :: vals
- integer, intent(in) :: sz
+ IMPLICIT NONE
- integer :: i
- real (kind=RKIND) :: mag
+ 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
- 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
+ absVort(:,:) = 0.0_RKIND
- real(kind=RKIND) function calcVolumeCell(areaCell, nEdges, hEdge)
+ 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
- implicit none
+ 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 )
- integer, intent(in) :: nEdges
- real(kind=RKIND), intent(in) :: areaCell
- real(kind=RKIND), dimension(nEdges), intent(in) :: hEdge
+ IMPLICIT NONE
- integer :: i
- real(kind=RKIND) :: avgHt, vol
+ 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
- avgHt = 0.0_RKIND
- do i=1,nEdges
- avgHt = avgHt + hEdge(i)
+ ! local variables
+ integer :: iVertex, iEdge, i, k
+ real (kind=RKIND) :: s
+
+ 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
- avgHt = avgHt/nEdges
- vol = areaCell*avgHt
- calcVolumeCell = vol
- end function calcVolumeCell
+ end subroutine recompute_absVort_vertex
- real(kind=RKIND) function calc_horizDeriv_fv(valEdges, nNbrs, dvEdge, dhEdge, &
- normalEdge, unitDeriv, volumeCell)
- !normals to edges point out of cell
- 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) :: 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
+ 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_horizDeriv_fv = rsum
- end function calc_horizDeriv_fv
+ lev_loop: do kLev=1,nVertLevels
- !cell centers are halfway between w faces
- real(kind=RKIND) function calc_vertDeriv_center(val0, valp, valm, z0,zp,zm)
+ ! 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)
- real(kind=RKIND), intent(in) :: val0, valp, valm, z0,zp,zm !center, plus, minus
-
- real(kind=RKIND) :: dval_dzp, dval_dzm
+ ! 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.
- !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)
+ IF (varGrad(kLev,edgeUse) .gt. 0) THEN
+ ! Gradient vector points toward cellsOnEdge(edgeUse,2) ->
+ ! should be directed inward for cellsOnEdge(edgeUse,2)
- end function calc_vertDeriv_center
+ ! 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
- real(kind=RKIND) function calc_vertDeriv_one(valp, valm, dz)
- !1 sided finite difference
+ ELSE IF (varGrad(kLev,edgeUse) .lt. 0) THEN
+ ! Gradient vector points toward cellsOnEdge(edgeUse,1) ->
+ ! should be directed inward for cellsOnEdge(edgeUse,1)
- 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), intent(in) :: valp, valm, dz
+ END IF
- calc_vertDeriv_one = (valp - valm) / dz
+ end do lev_loop
- 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.
+ 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)
+
+ 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)
+ deallocate(varGrad)
+
+ end subroutine calc_gradOnEdges_reconCellCenter
+
+ !*********************************************************************************************************************
+ ! 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
+ !*********************************************************************************************************************
+
+ subroutine calc_vertical_curl(uEdge, nEdges, nVertices, dcEdge, areaTriangle, verticesOnEdge, curlVert)
- 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)
- 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.
+ 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
+
+ integer :: jEdge, iVert
+
+ curlVert(:,:) = 0.0_RKIND
+
+ 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
+
+ do iVert=1,nVertices
+ curlVert(:,iVert) = curlVert(:,iVert) / areaTriangle(iVert)
+ end do
+
+ end subroutine calc_vertical_curl
+
+ !*********************************************************************************************************************
+ ! 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)
+ !*********************************************************************************************************************
+
+ subroutine calc_vertDeriv(var, nCells, nVertLevels, zCell, dvar_dz)
+
+ 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
+
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, 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
+ 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
- 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
+ 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
-
- !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(domain, mesh, state, diag, exchange_halo_group)
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 (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
+ 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)
-
- implicit none
- !linear-in-PV interpolate columns of field1 to where field0 is interpVal*sign(lat)
- !using level above tropopause already diagnosed
-
- ! input
+ 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)
- 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)
+ ! (3) Combine theta derivatives into 3D vector
- ! 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
+ gradTheta(:,:,1) = dTheta_dxZonal
+ gradTheta(:,:,2) = dTheta_dyMerid
+ gradTheta(:,:,3) = dTheta_dz
- 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)
+ ! 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 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 +4508,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 +4538,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 +4604,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 +4739,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 +4972,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 +5207,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.
@@ -4858,6 +5241,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
@@ -4916,7 +5302,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 +5337,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 +5376,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 +5417,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 +5521,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 +5546,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 +5614,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
@@ -5197,6 +5634,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
@@ -5327,6 +5771,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 +5838,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 +7438,672 @@ 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
+ du_dt_dyn(k,iEdge) = 0.0 ! MC initializing this here instead of in PV code
+ 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
+
+
+ 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.F b/src/core_atmosphere/mpas_atm_core.F
index 997d7ca8ba..cbb5838ad2 100644
--- a/src/core_atmosphere/mpas_atm_core.F
+++ b/src/core_atmosphere/mpas_atm_core.F
@@ -13,6 +13,7 @@ module atm_core
use mpas_log, only : mpas_log_write, mpas_log_info
use mpas_io_units, only : mpas_new_unit, mpas_release_unit
+ use mpas_atm_halos, only: exchange_halo_group
!
! Abstract interface for routine used to communicate halos of fields
! in a named group
@@ -595,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
@@ -623,7 +625,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
@@ -638,9 +642,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)
@@ -661,8 +667,11 @@ function atm_core_run(domain) result(ierr)
end if
call mpas_timer_start('diagnostic_fields')
call mpas_atm_diag_reset()
- call mpas_atm_diag_update()
- call mpas_atm_diag_compute()
+ !call mpas_atm_diag_update()
+ 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')
call mpas_dmpar_get_time(diag_stop_time)
@@ -805,8 +814,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)
@@ -823,8 +841,10 @@ function atm_core_run(domain) result(ierr)
end if
call mpas_timer_start('diagnostic_fields')
- call mpas_atm_diag_update()
- call mpas_atm_diag_compute()
+ !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_timer_stop('diagnostic_fields')
call mpas_dmpar_get_time(diag_stop_time)
diff --git a/src/core_atmosphere/mpas_atm_core_interface.F b/src/core_atmosphere/mpas_atm_core_interface.F
index c8db24ceac..502d254ec2 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
+
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
diff --git a/src/core_atmosphere/mpas_atm_halos.F b/src/core_atmosphere/mpas_atm_halos.F
index df02ee30a2..9861a80d1c 100644
--- a/src/core_atmosphere/mpas_atm_halos.F
+++ b/src/core_atmosphere/mpas_atm_halos.F
@@ -26,8 +26,13 @@ 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, config_pv_isobaric
+ logical, pointer :: config_pv_diag, config_pv_tend, config_pv_scalar, &
+ config_pv_microphys
contains
@@ -55,13 +60,17 @@ 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_scalar', config_pv_scalar)
+ 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
@@ -177,7 +186,129 @@ 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
+
+ ! PV diagnostics
+ if (config_pv_diag) then
+ call mpas_dmpar_exch_group_create(domain, 'diagnostics:pv_diag')
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:pv_diag', 'theta', timeLevel=1, haloLayers=(/1,2/))
+ 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', '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/))
+
+ call mpas_dmpar_exch_group_create(domain, 'diagnostics:inTropo')
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:inTropo', 'inTropo', timeLevel=1, haloLayers=(/1,2/))
+
+ call mpas_dmpar_exch_group_create(domain, 'diagnostics:iLev_DT')
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:iLev_DT', 'iLev_DT', timeLevel=1, haloLayers=(/1,2/))
+
+ call mpas_dmpar_exch_group_create(domain, 'diagnostics:ertel_pv')
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:ertel_pv', 'ertel_pv', timeLevel=1, haloLayers=(/1,2/))
+ end if
+
+ ! PV scalar
+ if (config_pv_scalar) then
+ call mpas_dmpar_exch_group_create(domain, 'diagnostics:pv_scalars_1')
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:pv_scalars_1', 'pv_scalars', timeLevel=1, haloLayers=(/1,2/))
+
+ call mpas_dmpar_exch_group_create(domain, 'diagnostics:pv_scalars_2')
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:pv_scalars_2', 'pv_scalars', timeLevel=2, haloLayers=(/1,2/))
+ end if
+
+ ! PV tendencies
+ if (config_pv_tend) then
+ call mpas_dmpar_exch_group_create(domain, 'diagnostics:dpv_prev')
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'theta_prev', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'uReconstructZonal_prev', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'uReconstructMeridional_prev', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'wCell_prev', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'rho_prev', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'rho', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'pv_vertex_prev', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'qv_prev', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'ertel_pv_prev', timeLevel=1, haloLayers=(/1,2/))
+
+ call mpas_dmpar_exch_group_create(domain, 'diagnostics:dpv_th_tend')
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_th_tend', 'dtheta_dt_dyn', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_th_tend', 'dtheta_dt_mix', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_th_tend', 'dtheta_dt_pbl', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_th_tend', 'dtheta_dt_cu', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_th_tend', 'dtheta_dt_sw', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_th_tend', 'dtheta_dt_lw', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_th_tend', 'dtheta_dt_mp', timeLevel=1, haloLayers=(/1,2/))
+
+ 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', '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_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/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mom_curl', 'uTend_curl_pbl', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mom_curl', 'uTend_curl_cu', timeLevel=1, haloLayers=(/1,2/))
+ end if
+
+ ! PV microphysics process tendencies
+ if (config_pv_microphys) then
+ call mpas_dmpar_exch_group_create(domain, 'diagnostics:dpv_mp_tend')
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mp_tend', 'tend_theta_mp_evap_cw', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mp_tend', 'tend_theta_mp_evap_rw', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mp_tend', 'tend_theta_mp_depo_ice', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_dmpar_exch_group_add_field(domain, 'diagnostics:dpv_mp_tend', 'tend_theta_mp_melt_ice', timeLevel=1, haloLayers=(/1,2/))
+ 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 .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/))
+
+ 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
+
!
! Set routine to exchange a halo group
@@ -312,6 +443,151 @@ 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
+
+
+ ! MC note -- why do dmpar groups have "mpas_halo_exch_group_complete" but not halo groups?
+ ! PV diagnostics
+ if (config_pv_diag) then
+ call mpas_halo_exch_group_create(domain, 'diagnostics:pv_diag')
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:pv_diag', 'theta', timeLevel=1, haloLayers=(/1,2/))
+ 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', '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/))
+ !call mpas_halo_exch_group_complete(domain, 'diagnostics:inStrato')
+
+ !call mpas_halo_exch_group_create(domain, 'diagnostics:inTropo')
+ !call mpas_halo_exch_group_add_field(domain, 'diagnostics:inTropo', 'inTropo', timeLevel=1, haloLayers=(/1,2/))
+ !call mpas_halo_exch_group_complete(domain, 'diagnostics:inTropo')
+
+ !call mpas_halo_exch_group_create(domain, 'diagnostics:iLev_DT')
+ !call mpas_halo_exch_group_add_field(domain, 'diagnostics:iLev_DT', 'iLev_DT', timeLevel=1, haloLayers=(/1,2/))
+ !call mpas_halo_exch_group_complete(domain, 'diagnostics:iLev_DT')
+
+ call mpas_halo_exch_group_create(domain, 'diagnostics:ertel_pv')
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:ertel_pv', 'ertel_pv', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_complete(domain, 'diagnostics:ertel_pv')
+ end if
+
+ ! PV scalars
+ if (config_pv_scalar) then
+ call mpas_halo_exch_group_create(domain, 'diagnostics:pv_scalars_1')
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:pv_scalars_1', 'pv_scalars', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_complete(domain, 'diagnostics:pv_scalars_1')
+
+ call mpas_halo_exch_group_create(domain, 'diagnostics:pv_scalars_2')
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:pv_scalars_2', 'pv_scalars', timeLevel=2, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_complete(domain, 'diagnostics:pv_scalars_2')
+ end if
+
+
+ ! PV tendencies
+ if (config_pv_tend) then
+ call mpas_halo_exch_group_create(domain, 'diagnostics:dpv_prev')
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'theta_prev', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'uReconstructZonal_prev', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'uReconstructMeridional_prev', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'wCell_prev', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'rho_prev', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'rho', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'pv_vertex_prev', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'qv_prev', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_prev', 'ertel_pv_prev', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_complete(domain, 'diagnostics:dpv_prev')
+
+ call mpas_halo_exch_group_create(domain, 'diagnostics:dpv_th_tend')
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_th_tend', 'dtheta_dt_dyn', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_th_tend', 'dtheta_dt_mix', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_th_tend', 'dtheta_dt_pbl', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_th_tend', 'dtheta_dt_cu', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_th_tend', 'dtheta_dt_sw', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_th_tend', 'dtheta_dt_lw', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_th_tend', 'dtheta_dt_mp', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_complete(domain, 'diagnostics:dpv_th_tend')
+
+ 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', '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_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/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mom_curl', 'uTend_curl_pbl', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mom_curl', 'uTend_curl_cu', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_complete(domain, 'diagnostics:dpv_mom_curl')
+
+ end if
+
+ ! PV microphysics process tendencies
+ if (config_pv_microphys) then
+ call mpas_halo_exch_group_create(domain, 'diagnostics:dpv_mp_tend')
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mp_tend', 'tend_theta_mp_evap_cw', timeLevel=1, haloLayers=(/1,2/))
+ call mpas_halo_exch_group_add_field(domain, 'diagnostics:dpv_mp_tend', 'tend_theta_mp_evap_rw', timeLevel=1, haloLayers=(/1,2/))
+ 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
+
+ ! Isobaric interpolation
+ 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')
+
+ 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
+
!
! Set routine to exchange a halo group
!
@@ -354,15 +630,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
!
@@ -398,6 +668,47 @@ 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
+
+ if (config_pv_diag) then
+ call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:pv_diag')
+ call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:inStrato')
+ 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_scalar) then
+ call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:pv_scalars_1')
+ call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:pv_scalars_2')
+ end if
+
+ if (config_pv_tend) then
+ 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
+
+ if (config_pv_microphys) then
+ call mpas_dmpar_exch_group_destroy(domain, 'diagnostics:dpv_mp_tend')
+ end if
+
+ if (config_isobaric .or. config_pv_isobaric) then
+ call mpas_dmpar_exch_group_destroy(domain, 'isobaric:pressure_p')
+ 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
@@ -435,6 +746,48 @@ 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
+
+ if (config_pv_diag) then
+ call mpas_halo_exch_group_destroy(domain, 'diagnostics:pv_diag')
+ !call mpas_halo_exch_group_destroy(domain, 'diagnostics:inStrato')
+ !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
+
+ if (config_pv_scalar) then
+ call mpas_halo_exch_group_destroy(domain, 'diagnostics:pv_scalars_1')
+ call mpas_halo_exch_group_destroy(domain, 'diagnostics:pv_scalars_2')
+ end if
+
+ if (config_pv_tend) then
+ 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
+
+ if (config_pv_microphys) then
+ call mpas_halo_exch_group_destroy(domain, 'diagnostics:dpv_mp_tend')
+ end if
+
+ if (config_isobaric .or. config_pv_isobaric) then
+ call mpas_halo_exch_group_destroy(domain, 'isobaric:pressure_p')
+ if (config_isobaric) then
+ call mpas_halo_exch_group_destroy(domain, 'isobaric:vorticity')
+ end if
+ end if
+
call mpas_halo_finalize(domain)
else
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 b467bb09b8..714b2e9ea2 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,6 +566,15 @@ 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: for ITM package
+ logical, pointer :: config_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
@@ -590,6 +601,26 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics,
qc => scalars(index_qc,:,:)
qr => scalars(index_qr,:,:)
+! MW on ITM
+ call mpas_pool_get_config(configs, 'config_tend', config_tend)
+
+ if (config_tend) then
+ 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
@@ -607,6 +638,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
+ if (config_tend) then
+ qv_mp_tend(k,i) = qv(k,i) ! save qv before call to microphysics
+ endif
enddo
enddo
enddo
@@ -788,7 +824,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
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 +832,17 @@ 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
+ 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, 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
@@ -816,7 +862,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)
@@ -833,15 +878,49 @@ 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
+ 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 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,'thmmpten', thmmpten)
+ call mpas_pool_get_array(diag,'qvmpten',qvmpten)
+
+ thmmpten(:,:) = 0.0
+ 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
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))
!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 +930,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)
!density-weighted perturbation potential temperature:
rtheta_p(k,i) = rho_zz(k,i) * theta_m(k,i) - rtheta_b(k,i)
@@ -863,6 +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))
+
+ ! ------------------------------
+ ! 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 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
@@ -1025,6 +1129,12 @@ 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
+
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..eabe48c2a9 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,10 @@ 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
+! * 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
@@ -62,8 +83,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 +100,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 +109,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 +127,24 @@ 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
+
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
+! 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 +157,13 @@ 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_dimension(state,'index_qv',index_qv)
call mpas_pool_get_dimension(state,'index_qc',index_qc)
@@ -171,6 +203,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:
@@ -181,43 +227,63 @@ subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_s
tend_ru_physics(:,:) = 0._RKIND
tend_rtheta_physics(:,:) = 0._RKIND
tend_rho_physics(:,:) = 0._RKIND
+ !
+ ! In case some variables are not allocated due to their associated packages,
+ ! we need to make their pointers associated here to avoid triggering run-time
+ ! checks when calling physics_get_tend_work
+ if (.not. associated(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, &
+ 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 +307,44 @@ 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, &
exchange_halo_group)
!=================================================================================================================
-
!input arguments:
procedure(halo_exchange_routine):: exchange_halo_group
@@ -271,6 +356,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 +397,64 @@ 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
+
+! 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)
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)
+ 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 +464,9 @@ 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 +487,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
@@ -388,13 +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) &
- + 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)
+ 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
@@ -403,31 +527,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
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