From 02c8015ec21f181b499239ef1316b0a1985be9ea Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 27 Sep 2016 17:22:48 -0600 Subject: [PATCH 001/737] Add new var_struct in atmosphere Registry to store LBC fields The new structure holds two "time levels" of data for prognostic variables: time-level 1 will hold the tendencies for prognostics, while time-level 2 will hold the prognostic state at the end of the boundary interval. --- src/core_atmosphere/Registry.xml | 45 ++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 5da22adcdb..63c7048079 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1913,6 +1913,51 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + From 340c6d5d4b86c727b35b2c66eb9d09ddee31220c Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 27 Sep 2016 17:26:26 -0600 Subject: [PATCH 002/737] Define new immutable stream, "lbc_in", for reading LBC data --- src/core_atmosphere/Registry.xml | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 63c7048079..90c98735b3 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1021,6 +1021,19 @@ + + + + + + + From d7f0406e80c96ce1d5abd76d405070f4cc99ead0 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 27 Sep 2016 18:21:34 -0600 Subject: [PATCH 003/737] Add new module mpas_atm_boundaries This commit adds a new module, mpas_atm_boundaries, in the src/core_atmosphere/dynamics directory. The initial version of the module contains two routines for applying boundary conditions provided by an input stream: mpas_atm_update_bdy_tend and mpas_atm_get_bdy_tend. --- src/core_atmosphere/dynamics/Makefile | 7 +- .../dynamics/mpas_atm_boundaries.F | 211 ++++++++++++++++++ 2 files changed, 216 insertions(+), 2 deletions(-) create mode 100644 src/core_atmosphere/dynamics/mpas_atm_boundaries.F diff --git a/src/core_atmosphere/dynamics/Makefile b/src/core_atmosphere/dynamics/Makefile index 3a103573c2..8a08de7194 100644 --- a/src/core_atmosphere/dynamics/Makefile +++ b/src/core_atmosphere/dynamics/Makefile @@ -1,10 +1,13 @@ .SUFFIXES: .F .o -OBJS = mpas_atm_time_integration.o +OBJS = mpas_atm_time_integration.o \ + mpas_atm_boundaries.o all: $(OBJS) -mpas_atm_time_integration.o: +mpas_atm_time_integration.o: mpas_atm_boundaries.o + +mpas_atm_boundaries.o: clean: diff --git a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F new file mode 100644 index 0000000000..b45034243a --- /dev/null +++ b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F @@ -0,0 +1,211 @@ +! Copyright (c) 2016, 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_boundaries + + use mpas_derived_types, only : mpas_pool_type, mpas_clock_type, block_type, mpas_time_type, mpas_timeInterval_type, MPAS_NOW, & + MPAS_STREAM_LATEST_BEFORE, MPAS_STREAM_EARLIEST_STRICTLY_AFTER, & + MPAS_streamManager_type + use mpas_pool_routines, only : mpas_pool_get_array, mpas_pool_get_subpool, mpas_pool_shift_time_levels + use mpas_kind_types, only : RKIND, StrKIND + use mpas_timekeeping, only : mpas_get_clock_time, mpas_get_timeInterval, mpas_set_time, operator(-) + use mpas_stream_manager, only : mpas_stream_mgr_read + + public :: mpas_atm_update_bdy_tend, & + mpas_atm_get_bdy_tend + + private + + type (MPAS_Time_Type) :: LBC_intv_end + + + contains + + + !*********************************************************************** + ! + ! routine mpas_atm_update_bdy_tend + ! + !> \brief Reads new boundary data and updates the LBC tendencies + !> \author Michael Duda + !> \date 27 September 2016 + !> \details + !> This routine reads from the 'lbc_in' stream all variables in the 'lbc' + !> pool. When called with firstCall=.true., the latest time before the + !> present is read into time level 2 of the lbc pool; otherwise, the + !> contents of time level 2 are shifted to time level 1, the earliest + !> time strictly later than the present is read into time level 2, and + !> the tendencies for all fields in the lbc pool are computed and stored + !> in time level 1. + ! + !----------------------------------------------------------------------- + subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) + + implicit none + + type (mpas_clock_type), intent(in) :: clock + type (MPAS_streamManager_type), intent(inout) :: streamManager + type (block_type), intent(inout) :: block + logical, intent(in) :: firstCall + + type (mpas_pool_type), pointer :: mesh + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: lbc + real (kind=RKIND) :: dt + + real (kind=RKIND), dimension(:,:), pointer :: u + real (kind=RKIND), dimension(:,:), pointer :: w + real (kind=RKIND), dimension(:,:), pointer :: theta_m + real (kind=RKIND), dimension(:,:), pointer :: rho_zz + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_u + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_w + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_theta_m + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho_zz + real (kind=RKIND), dimension(:,:,:), pointer :: lbc_tend_scalars + + integer :: ierr + integer :: dd_intv, s_intv, sn_intv, sd_intv + type (MPAS_Time_Type) :: currTime + type (MPAS_TimeInterval_Type) :: lbc_interval + character(len=StrKIND) :: read_time + + + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'lbc', lbc) + + if (firstCall) then + call MPAS_stream_mgr_read(streamManager, streamID='lbc_in', timeLevel=2, whence=MPAS_STREAM_LATEST_BEFORE, & + actualWhen=read_time, ierr=ierr) + else + call mpas_pool_shift_time_levels(lbc) + call MPAS_stream_mgr_read(streamManager, streamID='lbc_in', timeLevel=2, whence=MPAS_STREAM_EARLIEST_STRICTLY_AFTER, & + actualWhen=read_time, ierr=ierr) + end if + call mpas_set_time(currTime, dateTimeString=trim(read_time)) + + if (.not. firstCall) then + lbc_interval = currTime - LBC_intv_end + call mpas_get_timeInterval(interval=lbc_interval, DD=dd_intv, S=s_intv, S_n=sn_intv, S_d=sd_intv, ierr=ierr) + dt = 86400.0_RKIND * real(dd_intv, kind=RKIND) + real(s_intv, kind=RKIND) & + + (real(sn_intv, kind=RKIND) / real(sd_intv, kind=RKIND)) + + call mpas_pool_get_array(lbc, 'lbc_u', u, 2) + call mpas_pool_get_array(lbc, 'lbc_w', w, 2) + call mpas_pool_get_array(lbc, 'lbc_theta_m', theta_m, 2) + call mpas_pool_get_array(lbc, 'lbc_rho_zz', rho_zz, 2) + call mpas_pool_get_array(lbc, 'lbc_scalars', scalars, 2) + + call mpas_pool_get_array(lbc, 'lbc_u', lbc_tend_u, 1) + call mpas_pool_get_array(lbc, 'lbc_w', lbc_tend_w, 1) + call mpas_pool_get_array(lbc, 'lbc_theta_m', lbc_tend_theta_m, 1) + call mpas_pool_get_array(lbc, 'lbc_rho_zz', lbc_tend_rho_zz, 1) + call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_tend_scalars, 1) + + dt = 1.0_RKIND / dt + lbc_tend_u(:,:) = (u(:,:) - lbc_tend_u(:,:)) * dt + lbc_tend_w(:,:) = (w(:,:) - lbc_tend_w(:,:)) * dt + lbc_tend_theta_m(:,:) = (theta_m(:,:) - lbc_tend_theta_m(:,:)) * dt + lbc_tend_rho_zz(:,:) = (rho_zz(:,:) - lbc_tend_rho_zz(:,:)) * dt + lbc_tend_scalars(:,:,:) = (scalars(:,:,:) - lbc_tend_scalars(:,:,:)) * dt + end if + + LBC_intv_end = currTime + + end subroutine mpas_atm_update_bdy_tend + + + !*********************************************************************** + ! + ! routine mpas_atm_get_bdy_tend + ! + !> \brief Retrieves LBC tendencies or state at a specified delta-t in the future + !> \author Michael Duda + !> \date 27 September 2016 + !> \details + !> This routine provides example code to obtain tendencies for all fields + !> in the lbc pool, or to obtain the state valid at the specified delta-t in + !> the future for all fields in the lbc pool. + ! + !----------------------------------------------------------------------- + subroutine mpas_atm_get_bdy_tend(clock, block, delta_t) + + implicit none + + type (mpas_clock_type), intent(in) :: clock + type (block_type), intent(inout) :: block + real (kind=RKIND), intent(in) :: delta_t + + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: lbc + + + real (kind=RKIND), dimension(:,:), pointer :: u + real (kind=RKIND), dimension(:,:), pointer :: w + real (kind=RKIND), dimension(:,:), pointer :: theta_m + real (kind=RKIND), dimension(:,:), pointer :: rho_zz + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + real (kind=RKIND), dimension(:,:), pointer :: lbc_u + real (kind=RKIND), dimension(:,:), pointer :: lbc_w + real (kind=RKIND), dimension(:,:), pointer :: lbc_theta_m + real (kind=RKIND), dimension(:,:), pointer :: lbc_rho_zz + real (kind=RKIND), dimension(:,:,:), pointer :: lbc_scalars + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_u + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_w + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_theta_m + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho_zz + real (kind=RKIND), dimension(:,:,:), pointer :: lbc_tend_scalars + + type (MPAS_Time_Type) :: currTime + type (MPAS_TimeInterval_Type) :: lbc_interval + + integer :: dd_intv, s_intv, sn_intv, sd_intv + real (kind=RKIND) :: dt + integer :: ierr + + + currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) + + lbc_interval = LBC_intv_end - currTime + + call mpas_get_timeInterval(interval=lbc_interval, DD=dd_intv, S=s_intv, S_n=sn_intv, S_d=sd_intv, ierr=ierr) + dt = 86400.0_RKIND * real(dd_intv, kind=RKIND) + real(s_intv, kind=RKIND) & + + (real(sn_intv, kind=RKIND) / real(sd_intv, kind=RKIND)) + + dt = dt - delta_t + + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'lbc', lbc) + + call mpas_pool_get_array(state, 'u', u, 1) + call mpas_pool_get_array(state, 'w', w, 1) + call mpas_pool_get_array(state, 'theta_m', theta_m, 1) + call mpas_pool_get_array(state, 'rho_zz', rho_zz, 1) + call mpas_pool_get_array(state, 'scalars', scalars, 1) + + call mpas_pool_get_array(lbc, 'lbc_u', lbc_tend_u, 1) + call mpas_pool_get_array(lbc, 'lbc_w', lbc_tend_w, 1) + call mpas_pool_get_array(lbc, 'lbc_theta_m', lbc_tend_theta_m, 1) + call mpas_pool_get_array(lbc, 'lbc_rho_zz', lbc_tend_rho_zz, 1) + call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_tend_scalars, 1) + + call mpas_pool_get_array(lbc, 'lbc_u', lbc_u, 2) + call mpas_pool_get_array(lbc, 'lbc_w', lbc_w, 2) + call mpas_pool_get_array(lbc, 'lbc_theta_m', lbc_theta_m, 2) + call mpas_pool_get_array(lbc, 'lbc_rho_zz', lbc_rho_zz, 2) + call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_scalars, 2) + + u(:,:) = lbc_u(:,:) - dt * lbc_tend_u(:,:) + w(:,:) = lbc_w(:,:) - dt * lbc_tend_w(:,:) + theta_m(:,:) = lbc_theta_m(:,:) - dt * lbc_tend_theta_m(:,:) + rho_zz(:,:) = lbc_rho_zz(:,:) - dt * lbc_tend_rho_zz(:,:) + scalars(:,:,:) = lbc_scalars(:,:,:) - dt * lbc_tend_scalars(:,:,:) + + end subroutine mpas_atm_get_bdy_tend + +end module mpas_atm_boundaries From 33428da489830644d9e421ee6cfe727b1977b56d Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 27 Sep 2016 18:29:14 -0600 Subject: [PATCH 004/737] Add calls to mpas_atm_update_bdy_tend in the main atmosphere run routine There are two places where we need to call mpas_atm_update_bdy_tend: 1) Before entering the time integration loop, so that the boundary data valid not later than the present can be read, and 2) at the start of each timestep, so future boundary data can be read and tendencies computed. --- src/core_atmosphere/mpas_atm_core.F | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index d0a645d67d..7d20ddb636 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -411,6 +411,7 @@ 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 use mpas_atm_soundings, only : mpas_atm_soundings_write + use mpas_atm_boundaries, only : mpas_atm_update_bdy_tend implicit none @@ -497,6 +498,17 @@ function atm_core_run(domain) result(ierr) call mpas_atm_soundings_write(mesh, state, diag, diag_physics) call mpas_timer_stop('write_soundings') + ! + ! Read initial boundary state + ! + if (MPAS_stream_mgr_ringing_alarms(domain % streamManager, streamID='lbc_in', direction=MPAS_STREAM_INPUT, ierr=ierr)) then + block_ptr => domain % blocklist + do while (associated(block_ptr)) + call mpas_atm_update_bdy_tend(clock, domain % streamManager, block_ptr, .true.) + block_ptr => block_ptr % next + end do + end if + ! During integration, time level 1 stores the model state at the beginning of the ! time step, and time level 2 stores the state advanced dt in time by timestep(...) itimestep = 1 @@ -508,6 +520,19 @@ function atm_core_run(domain) result(ierr) write(0,*) ' ' write(0,*) 'Begin timestep ', trim(timeStamp) + ! + ! Read future boundary state and compute boundary tendencies + ! + if (MPAS_stream_mgr_ringing_alarms(domain % streamManager, streamID='lbc_in', direction=MPAS_STREAM_INPUT, ierr=ierr)) then + block_ptr => domain % blocklist + do while (associated(block_ptr)) + call mpas_atm_update_bdy_tend(clock, domain % streamManager, block_ptr, .false.) + block_ptr => block_ptr % next + end do + end if + call MPAS_stream_mgr_reset_alarms(domain % streamManager, streamID='lbc_in', direction=MPAS_STREAM_INPUT, ierr=ierr) + + ! ! Read external field updates ! From a9d69e69e1737e5da24eb9aea7810590c9c768e7 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 28 Sep 2016 11:31:40 -0600 Subject: [PATCH 005/737] Add bdyMask{Cell,Edge,Vertex} fields in Registry These three fields are defined in the "mesh" var_struct, and are added to the "input" and "restart" streams. --- src/core_atmosphere/Registry.xml | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 90c98735b3..807366e300 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -398,6 +398,9 @@ + + + @@ -527,6 +530,9 @@ + + + @@ -1303,6 +1309,16 @@ + + + + + + + From 17c0fd5764fdb8401f67dbc1c07b844c7e5a7f86 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 28 Sep 2016 11:58:35 -0600 Subject: [PATCH 006/737] Define new field 'specifiedZoneMask' This commit adds the definition of a new real-valued field, specifiedZoneMask, to the Registry.xml file, and it provides a new routine, mpas_atm_setup_bdy_masks, in the mpas_atm_boundaries module; this routine is called from atm_mpas_init_block to derive the mask field at model start-up. --- src/core_atmosphere/Registry.xml | 3 ++ .../dynamics/mpas_atm_boundaries.F | 39 ++++++++++++++++++- src/core_atmosphere/mpas_atm_core.F | 6 +++ 3 files changed, 47 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 807366e300..2a6830e751 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1319,6 +1319,9 @@ + + diff --git a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F index b45034243a..a6bbc583c3 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F +++ b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F @@ -16,7 +16,8 @@ module mpas_atm_boundaries use mpas_stream_manager, only : mpas_stream_mgr_read public :: mpas_atm_update_bdy_tend, & - mpas_atm_get_bdy_tend + mpas_atm_get_bdy_tend, & + mpas_atm_setup_bdy_masks private @@ -208,4 +209,40 @@ subroutine mpas_atm_get_bdy_tend(clock, block, delta_t) end subroutine mpas_atm_get_bdy_tend + + !*********************************************************************** + ! + ! routine mpas_atm_setup_bdy_masks + ! + !> \brief Prepares mask fields for boundaries of limited-area + !> \author Michael Duda + !> \date 28 September 2016 + !> \details + !> This routine prepares mask fields needed to distinguish cells in + !> the specified zone from those in the relaxation zone. + ! + !----------------------------------------------------------------------- + subroutine mpas_atm_setup_bdy_masks(mesh, configs) + + implicit none + + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: configs + + integer, dimension(:), pointer :: bdyMaskCell + real (kind=RKIND), dimension(:), pointer :: specifiedZoneMask + + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'specifiedZoneMask', specifiedZoneMask) + + ! + ! For now, hard-code mask based on assumption that we have 7 layers, the first + ! two of which are the specified zone + ! + specifiedZoneMask(:) = 0.0_RKIND + where (bdyMaskCell(:) == 7) specifiedZoneMask(:) = 1.0_RKIND + where (bdyMaskCell(:) == 6) specifiedZoneMask(:) = 1.0_RKIND + + end subroutine mpas_atm_setup_bdy_masks + end module mpas_atm_boundaries diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index 7d20ddb636..458c9e2d5f 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -226,6 +226,7 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) use mpas_rbf_interpolation use mpas_vector_reconstruction use mpas_stream_manager + use mpas_atm_boundaries, only : mpas_atm_setup_bdy_masks #ifdef DO_PHYSICS ! use mpas_atmphys_aquaplanet use mpas_atmphys_control @@ -389,6 +390,11 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) call atm_compute_pgf_coefs(mesh, block % configs) + ! + ! Set up mask fields used in limited-area simulations + ! + call mpas_atm_setup_bdy_masks(mesh, block % configs) + call mpas_pool_get_dimension(mesh, 'nEdgesSolve', nEdgesSolve) call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) From 2cd7a388bf17fcf87bf5193fa7453395a5631f24 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 28 Sep 2016 14:16:33 -0600 Subject: [PATCH 007/737] Define new field 'nearestRelaxationCell' This commit adds a new field, nearestRelaxationCell, to the mesh var_struct. For any non-specified zone cells, the field contains the value nCells+1, and for any specified zone cells, the field contains the local index of the nearest cell in the relaxation zone. --- src/core_atmosphere/Registry.xml | 3 + .../dynamics/mpas_atm_boundaries.F | 77 ++++++++++++++++++- 2 files changed, 76 insertions(+), 4 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 2a6830e751..bc23c94683 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1322,6 +1322,9 @@ + + diff --git a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F index a6bbc583c3..c0bb3e7973 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F +++ b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F @@ -10,7 +10,7 @@ module mpas_atm_boundaries use mpas_derived_types, only : mpas_pool_type, mpas_clock_type, block_type, mpas_time_type, mpas_timeInterval_type, MPAS_NOW, & MPAS_STREAM_LATEST_BEFORE, MPAS_STREAM_EARLIEST_STRICTLY_AFTER, & MPAS_streamManager_type - use mpas_pool_routines, only : mpas_pool_get_array, mpas_pool_get_subpool, mpas_pool_shift_time_levels + use mpas_pool_routines, only : mpas_pool_get_array, mpas_pool_get_dimension, mpas_pool_get_subpool, mpas_pool_shift_time_levels use mpas_kind_types, only : RKIND, StrKIND use mpas_timekeeping, only : mpas_get_clock_time, mpas_get_timeInterval, mpas_set_time, operator(-) use mpas_stream_manager, only : mpas_stream_mgr_read @@ -214,12 +214,14 @@ end subroutine mpas_atm_get_bdy_tend ! ! routine mpas_atm_setup_bdy_masks ! - !> \brief Prepares mask fields for boundaries of limited-area + !> \brief Prepares various fields for boundaries of limited-area !> \author Michael Duda !> \date 28 September 2016 !> \details - !> This routine prepares mask fields needed to distinguish cells in - !> the specified zone from those in the relaxation zone. + !> This routine prepares (1) the mask field needed to distinguish cells in + !> the specified zone from those in the relaxation zone, and (2) a field + !> of indices identifying the closest relaxation cell to each cell in + !> the specified zone.. ! !----------------------------------------------------------------------- subroutine mpas_atm_setup_bdy_masks(mesh, configs) @@ -229,11 +231,27 @@ subroutine mpas_atm_setup_bdy_masks(mesh, configs) type (mpas_pool_type), intent(inout) :: mesh type (mpas_pool_type), intent(in) :: configs + integer :: iCell, i, j, ii, jj + real (kind=RKIND) :: d, dmin + + integer, pointer :: nCells integer, dimension(:), pointer :: bdyMaskCell + integer, dimension(:), pointer :: nearestRelaxationCell + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnCell real (kind=RKIND), dimension(:), pointer :: specifiedZoneMask + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) call mpas_pool_get_array(mesh, 'specifiedZoneMask', specifiedZoneMask) + call mpas_pool_get_array(mesh, 'nearestRelaxationCell', nearestRelaxationCell) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'xCell', xCell) + call mpas_pool_get_array(mesh, 'yCell', yCell) + call mpas_pool_get_array(mesh, 'zCell', zCell) ! ! For now, hard-code mask based on assumption that we have 7 layers, the first @@ -243,6 +261,57 @@ subroutine mpas_atm_setup_bdy_masks(mesh, configs) where (bdyMaskCell(:) == 7) specifiedZoneMask(:) = 1.0_RKIND where (bdyMaskCell(:) == 6) specifiedZoneMask(:) = 1.0_RKIND + nearestRelaxationCell(:) = nCells+1 + + ! + ! For nearest relaxation cell to inner specified zone (6), just search + ! all cellsOnCell with bdyMaskCell == 5 + ! + do iCell=1,nCells + if (bdyMaskCell(iCell) == 6) then + dmin = 1.0e36 + do j=1,nEdgesOnCell(iCell) + i = cellsOnCell(j,iCell) + if (bdyMaskCell(i) == 5) then + d = (xCell(i) - xCell(iCell))**2 + (yCell(i) - yCell(iCell))**2 + (zCell(i) - zCell(iCell))**2 + if (d < dmin) then + dmin = d + nearestRelaxationCell(iCell) = i + end if + end if + end do + end if + end do + + ! + ! For nearest relaxation cell to outer specified zone (7), search + ! all cellsOnCell of cellsOnCell + ! + do iCell=1,nCells + if (bdyMaskCell(iCell) == 7) then + dmin = 1.0e36 + do j=1,nEdgesOnCell(iCell) + i = cellsOnCell(j,iCell) + if (bdyMaskCell(i) == 6) then + + do jj=1,nEdgesOnCell(i) + ii = cellsOnCell(jj,i) + if (bdyMaskCell(ii) == 5) then + + d = (xCell(ii) - xCell(iCell))**2 + (yCell(ii) - yCell(iCell))**2 + (zCell(ii) - zCell(iCell))**2 + if (d < dmin) then + dmin = d + nearestRelaxationCell(iCell) = ii + end if + + end if + end do + + end if + end do + end if + end do + end subroutine mpas_atm_setup_bdy_masks end module mpas_atm_boundaries From 5adfa944eb803760b4154b45b6d44705951057a4 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 28 Sep 2016 14:57:37 -0600 Subject: [PATCH 008/737] Replace subroutine mpas_atm_get_bdy_tend with functions for getting tendency and state The mpas_atm_boundaries module previously had an example subroutine, mpas_atm_get_bdy_tend, for obtaining both the tendency and the state for boundary variables. This commit replaces this subroutine with two separate functions, mpas_atm_get_bdy_tend and mpas_atm_get_bdy_state, which return as an array the tendency for the specified boundary variable or the state of the specified boundary variable. --- .../dynamics/mpas_atm_boundaries.F | 167 +++++++++++++----- 1 file changed, 118 insertions(+), 49 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F index c0bb3e7973..d6ddfacdbb 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F +++ b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F @@ -17,6 +17,7 @@ module mpas_atm_boundaries public :: mpas_atm_update_bdy_tend, & mpas_atm_get_bdy_tend, & + mpas_atm_get_bdy_state, & mpas_atm_setup_bdy_masks private @@ -125,46 +126,124 @@ end subroutine mpas_atm_update_bdy_tend ! ! routine mpas_atm_get_bdy_tend ! - !> \brief Retrieves LBC tendencies or state at a specified delta-t in the future + !> \brief Returns LBC tendencies a specified delta-t in the future !> \author Michael Duda - !> \date 27 September 2016 + !> \date 28 September 2016 !> \details - !> This routine provides example code to obtain tendencies for all fields - !> in the lbc pool, or to obtain the state valid at the specified delta-t in - !> the future for all fields in the lbc pool. + !> This function returns an array providing the tendency for the requested + !> progostic variable delta_t in the future from the current time known + !> by the simulation clock (which is typically the time at the start of + !> the current timestep). + !> + !> The vertDim and horizDim should match the nominal block dimensions of + !> the field to be returned by the call; for example, a call to retrieve + !> the tendency for the 'u' field would set vertDim=nVertLevels and + !> horizDim=nEdges. This function internally adds 1 to the horizontal + !> dimension to account for the "garbage" element. + !> + !> The field is identified by the 'field' argument, and this argument is + !> prefixed with 'lbc_' before attempting to retrieve the field from + !> the 'lbc' pool. For scalars, the field argument should give the name + !> of the constituent, e.g., 'qv'. + !> + !> Example calls to this function: + !> + !> tend_u(:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels, nEdges, 'u', 0.0_RKIND) + !> tend_w(:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels+1, nCells, 'w', 0.0_RKIND) + !> tend_rho_zz(:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', 0.0_RKIND) + !> tend_theta_m(:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels, nCells, 'theta_m', 0.0_RKIND) + !> tend_scalars(1,:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels, nCells, 'qv', 0.0_RKIND) ! !----------------------------------------------------------------------- - subroutine mpas_atm_get_bdy_tend(clock, block, delta_t) + function mpas_atm_get_bdy_tend(clock, block, vertDim, horizDim, field, delta_t) result(return_tend) implicit none type (mpas_clock_type), intent(in) :: clock type (block_type), intent(inout) :: block + integer, intent(in) :: vertDim, horizDim + character(len=*), intent(in) :: field real (kind=RKIND), intent(in) :: delta_t - type (mpas_pool_type), pointer :: state + real (kind=RKIND), dimension(vertDim,horizDim+1) :: return_tend + type (mpas_pool_type), pointer :: lbc + integer, pointer :: idx + real (kind=RKIND), dimension(:,:), pointer :: tend + real (kind=RKIND), dimension(:,:,:), pointer :: tend_scalars + integer :: ierr - real (kind=RKIND), dimension(:,:), pointer :: u - real (kind=RKIND), dimension(:,:), pointer :: w - real (kind=RKIND), dimension(:,:), pointer :: theta_m - real (kind=RKIND), dimension(:,:), pointer :: rho_zz - real (kind=RKIND), dimension(:,:,:), pointer :: scalars - real (kind=RKIND), dimension(:,:), pointer :: lbc_u - real (kind=RKIND), dimension(:,:), pointer :: lbc_w - real (kind=RKIND), dimension(:,:), pointer :: lbc_theta_m - real (kind=RKIND), dimension(:,:), pointer :: lbc_rho_zz - real (kind=RKIND), dimension(:,:,:), pointer :: lbc_scalars - real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_u - real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_w - real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_theta_m - real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho_zz - real (kind=RKIND), dimension(:,:,:), pointer :: lbc_tend_scalars + call mpas_pool_get_subpool(block % structs, 'lbc', lbc) + + nullify(tend) + call mpas_pool_get_array(lbc, 'lbc_'//trim(field), tend, 1) + + if (associated(tend)) then + return_tend(:,:) = tend(:,:) + else + call mpas_pool_get_array(lbc, 'lbc_scalars', tend_scalars, 1) + call mpas_pool_get_dimension(lbc, 'index_'//trim(field), idx) + + return_tend(:,:) = tend_scalars(idx,:,:) + end if + end function mpas_atm_get_bdy_tend + + + !*********************************************************************** + ! + ! routine mpas_atm_get_bdy_state + ! + !> \brief Returns LBC state at a specified delta-t in the future + !> \author Michael Duda + !> \date 28 September 2016 + !> \details + !> This function returns an array providing the state for the requested + !> progostic variable delta_t in the future from the current time known + !> by the simulation clock (which is typically the time at the start of + !> the current timestep). + !> + !> The vertDim and horizDim should match the nominal block dimensions of + !> the field to be returned by the call; for example, a call to retrieve + !> the state of the 'u' field would set vertDim=nVertLevels and + !> horizDim=nEdges. This function internally adds 1 to the horizontal + !> dimension to account for the "garbage" element. + !> + !> The field is identified by the 'field' argument, and this argument is + !> prefixed with 'lbc_' before attempting to retrieve the field from + !> the 'lbc' pool. For scalars, the field argument should give the name + !> of the constituent, e.g., 'qv'. + !> + !> Example calls to this function: + !> + !> u(:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels, nEdges, 'u', 0.0_RKIND) + !> w(:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels+1, nCells, 'w', 0.0_RKIND) + !> rho_zz(:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', 0.0_RKIND) + !> theta_m(:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels, nCells, 'theta_m', 0.0_RKIND) + !> scalars(1,:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels, nCells, 'qv', 0.0_RKIND) + ! + !----------------------------------------------------------------------- + function mpas_atm_get_bdy_state(clock, block, vertDim, horizDim, field, delta_t) result(return_state) + + implicit none + + type (mpas_clock_type), intent(in) :: clock + type (block_type), intent(inout) :: block + integer, intent(in) :: vertDim, horizDim + character(len=*), intent(in) :: field + real (kind=RKIND), intent(in) :: delta_t + + real (kind=RKIND), dimension(vertDim,horizDim+1) :: return_state + + type (mpas_pool_type), pointer :: lbc + integer, pointer :: idx + real (kind=RKIND), dimension(:,:), pointer :: tend + real (kind=RKIND), dimension(:,:), pointer :: state + real (kind=RKIND), dimension(:,:,:), pointer :: tend_scalars + real (kind=RKIND), dimension(:,:,:), pointer :: state_scalars type (MPAS_Time_Type) :: currTime type (MPAS_TimeInterval_Type) :: lbc_interval - integer :: dd_intv, s_intv, sn_intv, sd_intv real (kind=RKIND) :: dt integer :: ierr @@ -180,34 +259,24 @@ subroutine mpas_atm_get_bdy_tend(clock, block, delta_t) dt = dt - delta_t - call mpas_pool_get_subpool(block % structs, 'state', state) call mpas_pool_get_subpool(block % structs, 'lbc', lbc) - call mpas_pool_get_array(state, 'u', u, 1) - call mpas_pool_get_array(state, 'w', w, 1) - call mpas_pool_get_array(state, 'theta_m', theta_m, 1) - call mpas_pool_get_array(state, 'rho_zz', rho_zz, 1) - call mpas_pool_get_array(state, 'scalars', scalars, 1) - - call mpas_pool_get_array(lbc, 'lbc_u', lbc_tend_u, 1) - call mpas_pool_get_array(lbc, 'lbc_w', lbc_tend_w, 1) - call mpas_pool_get_array(lbc, 'lbc_theta_m', lbc_tend_theta_m, 1) - call mpas_pool_get_array(lbc, 'lbc_rho_zz', lbc_tend_rho_zz, 1) - call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_tend_scalars, 1) - - call mpas_pool_get_array(lbc, 'lbc_u', lbc_u, 2) - call mpas_pool_get_array(lbc, 'lbc_w', lbc_w, 2) - call mpas_pool_get_array(lbc, 'lbc_theta_m', lbc_theta_m, 2) - call mpas_pool_get_array(lbc, 'lbc_rho_zz', lbc_rho_zz, 2) - call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_scalars, 2) - - u(:,:) = lbc_u(:,:) - dt * lbc_tend_u(:,:) - w(:,:) = lbc_w(:,:) - dt * lbc_tend_w(:,:) - theta_m(:,:) = lbc_theta_m(:,:) - dt * lbc_tend_theta_m(:,:) - rho_zz(:,:) = lbc_rho_zz(:,:) - dt * lbc_tend_rho_zz(:,:) - scalars(:,:,:) = lbc_scalars(:,:,:) - dt * lbc_tend_scalars(:,:,:) - - end subroutine mpas_atm_get_bdy_tend + nullify(tend) + nullify(state) + call mpas_pool_get_array(lbc, 'lbc_'//trim(field), tend, 1) + call mpas_pool_get_array(lbc, 'lbc_'//trim(field), state, 2) + + if (associated(tend) .and. associated(state)) then + return_state(:,:) = state(:,:) - dt * tend(:,:) + else + call mpas_pool_get_array(lbc, 'lbc_scalars', tend_scalars, 1) + call mpas_pool_get_array(lbc, 'lbc_scalars', state_scalars, 2) + call mpas_pool_get_dimension(lbc, 'index_'//trim(field), idx) + + return_state(:,:) = state_scalars(idx,:,:) - dt * tend_scalars(idx,:,:) + end if + + end function mpas_atm_get_bdy_state !*********************************************************************** From 4357229a0609aca2eef3d154bb143e22e03ee5f9 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 28 Sep 2016 17:31:48 -0600 Subject: [PATCH 009/737] Add parameters nSpecZone, nRelaxZone, and nBdyZone to mpas_atm_boundaries module These parameters are module variables that provide the number of layers in the specified zone, relaxation zone, and entire boundary zone (specified + relaxation). Current values for these parameters are: nSpecZone = 2 nRelaxZone = 5 nBdyZone = nSpecZone + nRelaxZone --- .../dynamics/mpas_atm_boundaries.F | 37 ++++++++++++------- 1 file changed, 24 insertions(+), 13 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F index d6ddfacdbb..20e5b62b44 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F +++ b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F @@ -15,11 +15,19 @@ module mpas_atm_boundaries use mpas_timekeeping, only : mpas_get_clock_time, mpas_get_timeInterval, mpas_set_time, operator(-) use mpas_stream_manager, only : mpas_stream_mgr_read + ! Important note: At present, the code in mpas_atm_setup_bdy_masks for + ! deriving the nearestRelaxationCell field assumes that nSpecZone == 2 + integer, parameter :: nSpecZone = 2 + integer, parameter :: nRelaxZone = 5 + integer, parameter :: nBdyZone = nSpecZone + nRelaxZone + public :: mpas_atm_update_bdy_tend, & mpas_atm_get_bdy_tend, & mpas_atm_get_bdy_state, & mpas_atm_setup_bdy_masks + public :: nBdyZone, nSpecZone, nRelaxZone + private type (MPAS_Time_Type) :: LBC_intv_end @@ -323,25 +331,28 @@ subroutine mpas_atm_setup_bdy_masks(mesh, configs) call mpas_pool_get_array(mesh, 'zCell', zCell) ! - ! For now, hard-code mask based on assumption that we have 7 layers, the first - ! two of which are the specified zone + ! Setup mask identifying cells in the specified zone ! - specifiedZoneMask(:) = 0.0_RKIND - where (bdyMaskCell(:) == 7) specifiedZoneMask(:) = 1.0_RKIND - where (bdyMaskCell(:) == 6) specifiedZoneMask(:) = 1.0_RKIND + do iCell=1,nCells + if (bdyMaskCell(iCell) > nRelaxZone) then + specifiedZoneMask(iCell) = 1.0_RKIND + else + specifiedZoneMask(iCell) = 0.0_RKIND + end if + end do nearestRelaxationCell(:) = nCells+1 ! - ! For nearest relaxation cell to inner specified zone (6), just search - ! all cellsOnCell with bdyMaskCell == 5 + ! For nearest relaxation cell to inner specified zone, just search + ! all cellsOnCell with bdyMaskCell == nRelaxZone ! do iCell=1,nCells - if (bdyMaskCell(iCell) == 6) then + if (bdyMaskCell(iCell) == (nRelaxZone+1)) then dmin = 1.0e36 do j=1,nEdgesOnCell(iCell) i = cellsOnCell(j,iCell) - if (bdyMaskCell(i) == 5) then + if (bdyMaskCell(i) == nRelaxZone) then d = (xCell(i) - xCell(iCell))**2 + (yCell(i) - yCell(iCell))**2 + (zCell(i) - zCell(iCell))**2 if (d < dmin) then dmin = d @@ -353,19 +364,19 @@ subroutine mpas_atm_setup_bdy_masks(mesh, configs) end do ! - ! For nearest relaxation cell to outer specified zone (7), search + ! For nearest relaxation cell to outer specified zone, search ! all cellsOnCell of cellsOnCell ! do iCell=1,nCells - if (bdyMaskCell(iCell) == 7) then + if (bdyMaskCell(iCell) == (nRelaxZone+2)) then dmin = 1.0e36 do j=1,nEdgesOnCell(iCell) i = cellsOnCell(j,iCell) - if (bdyMaskCell(i) == 6) then + if (bdyMaskCell(i) == (nRelaxZone+1)) then do jj=1,nEdgesOnCell(i) ii = cellsOnCell(jj,i) - if (bdyMaskCell(ii) == 5) then + if (bdyMaskCell(ii) == nRelaxZone) then d = (xCell(ii) - xCell(iCell))**2 + (yCell(ii) - yCell(iCell))**2 + (zCell(ii) - zCell(iCell))**2 if (d < dmin) then From 7168c1702320741644383b9ad190acaaadf94a2e Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 29 Sep 2016 11:54:08 -0600 Subject: [PATCH 010/737] Retain private module pointers to 'clock' and 'blocklist' in atm_time_integration module At the beginning of the atm_timestep routine, we set pointers to domain % clock and domain % blocklist so that we don't need to pass domain, clock, etc. to any subroutine that needs these in, e.g., calls to mpas_atm_get_bdy_state. Note that routines in atm_time_integration not called below the call to atm_timestep in the call tree will not have access to these pointers until the first call to atm_timestep. This can affect routines such as atm_compute_solve_diagnostics. --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index dc1d1d985a..77d2ebe4d6 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -71,6 +71,10 @@ module atm_time_integration real (kind=RKIND), allocatable, dimension(:,:) :: ke_vertex real (kind=RKIND), allocatable, dimension(:,:) :: ke_edge + type (MPAS_Clock_type), pointer, private :: clock + type (block_type), pointer, private :: blocklist + + contains @@ -101,6 +105,9 @@ subroutine atm_timestep(domain, dt, timeStamp, itimestep) character (len=StrKIND), pointer :: config_time_integration + clock => domain % clock + blocklist => domain % blocklist + call mpas_pool_get_config(domain % blocklist % configs, 'config_time_integration', config_time_integration) if (trim(config_time_integration) == 'SRK3') then From ee9ee5f41643e4332a634b9d014da3726fc18acc Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 29 Sep 2016 16:36:13 -0600 Subject: [PATCH 011/737] Add specified zone 0/1 masks for edges and vertices The specified zone mask for cells was previously named 'specifiedZoneMask'. In order to distinguish masks for cells, edges, and vertices without overly long field names, the masks for these elements are: specZoneMaskCell, specZoneMaskEdge, and specZoneMaskVertex, respectively. --- src/core_atmosphere/Registry.xml | 8 +++++- .../dynamics/mpas_atm_boundaries.F | 28 +++++++++++-------- 2 files changed, 24 insertions(+), 12 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index bc23c94683..399475cb44 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1319,9 +1319,15 @@ - + + + + diff --git a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F index 20e5b62b44..2f3f1d9db8 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F +++ b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F @@ -312,17 +312,21 @@ subroutine mpas_atm_setup_bdy_masks(mesh, configs) real (kind=RKIND) :: d, dmin integer, pointer :: nCells - integer, dimension(:), pointer :: bdyMaskCell + integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge, bdyMaskVertex integer, dimension(:), pointer :: nearestRelaxationCell integer, dimension(:), pointer :: nEdgesOnCell integer, dimension(:,:), pointer :: cellsOnCell - real (kind=RKIND), dimension(:), pointer :: specifiedZoneMask + real (kind=RKIND), dimension(:), pointer :: specZoneMaskCell, specZoneMaskEdge, specZoneMaskVertex real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) - call mpas_pool_get_array(mesh, 'specifiedZoneMask', specifiedZoneMask) + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) + call mpas_pool_get_array(mesh, 'bdyMaskVertex', bdyMaskVertex) + call mpas_pool_get_array(mesh, 'specZoneMaskCell', specZoneMaskCell) + call mpas_pool_get_array(mesh, 'specZoneMaskEdge', specZoneMaskEdge) + call mpas_pool_get_array(mesh, 'specZoneMaskVertex', specZoneMaskVertex) call mpas_pool_get_array(mesh, 'nearestRelaxationCell', nearestRelaxationCell) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) @@ -331,15 +335,17 @@ subroutine mpas_atm_setup_bdy_masks(mesh, configs) call mpas_pool_get_array(mesh, 'zCell', zCell) ! - ! Setup mask identifying cells in the specified zone + ! Setup mask identifying cells/edges/vertices in the specified zone ! - do iCell=1,nCells - if (bdyMaskCell(iCell) > nRelaxZone) then - specifiedZoneMask(iCell) = 1.0_RKIND - else - specifiedZoneMask(iCell) = 0.0_RKIND - end if - end do + specZoneMaskCell(:) = 0.0_RKIND + where (bdyMaskCell(:) > nRelaxZone) specZoneMaskCell(:) = 1.0_RKIND + + specZoneMaskEdge(:) = 0.0_RKIND + where (bdyMaskEdge(:) > nRelaxZone) specZoneMaskEdge(:) = 1.0_RKIND + + specZoneMaskVertex(:) = 0.0_RKIND + where (bdyMaskVertex(:) > nRelaxZone) specZoneMaskVertex(:) = 1.0_RKIND + nearestRelaxationCell(:) = nCells+1 From a61f1bd8167f2d2803a003002ad14d8cc78f1f25 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 5 Oct 2016 18:52:31 -0600 Subject: [PATCH 012/737] Add new field 'lbc_rho_edge' to the lbc pool This new field will allow us to compute a coupled 'u' tendency field for all edges, including the outermost specified zone edges. --- src/core_atmosphere/Registry.xml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 399475cb44..14ea907d68 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1969,6 +1969,9 @@ + + From 9acb12c315dadd783a3e9ba10eec844690fe854d Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 5 Oct 2016 19:02:43 -0600 Subject: [PATCH 013/737] Add new field 'lbc_ru' to the lbc pool This new field is not expected to be read from input files, but will be computed from 'u' and 'rho_edge' when reading boundary data. --- src/core_atmosphere/Registry.xml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 14ea907d68..9ff52e4f2c 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1963,6 +1963,9 @@ + + From e57b39cbce40bc1d1e0ddabee0210d5b9c09ac05 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 5 Oct 2016 19:20:07 -0600 Subject: [PATCH 014/737] Process 'ru' and 'rho_edge' in mpas_atm_update_bdy_tend This commit includes changes in the mpas_atm_boundaries module to: * compute ru = u * rho_edge immediately after reading in u and rho_edge from boundary files * computes tendencies for ru and rho_edge --- .../dynamics/mpas_atm_boundaries.F | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F index 2f3f1d9db8..44b5bd9887 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F +++ b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F @@ -68,11 +68,15 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) real (kind=RKIND) :: dt real (kind=RKIND), dimension(:,:), pointer :: u + real (kind=RKIND), dimension(:,:), pointer :: ru + real (kind=RKIND), dimension(:,:), pointer :: rho_edge real (kind=RKIND), dimension(:,:), pointer :: w real (kind=RKIND), dimension(:,:), pointer :: theta_m real (kind=RKIND), dimension(:,:), pointer :: rho_zz real (kind=RKIND), dimension(:,:,:), pointer :: scalars real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_u + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_ru + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho_edge real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_w real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_theta_m real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho_zz @@ -99,6 +103,14 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) end if call mpas_set_time(currTime, dateTimeString=trim(read_time)) + ! + ! Compute any derived fields from those that were read from the lbc_in stream + ! + call mpas_pool_get_array(lbc, 'lbc_u', u, 2) + call mpas_pool_get_array(lbc, 'lbc_ru', ru, 2) + call mpas_pool_get_array(lbc, 'lbc_rho_edge', rho_edge, 2) + ru(:,:) = u(:,:) * rho_edge(:,:) + if (.not. firstCall) then lbc_interval = currTime - LBC_intv_end call mpas_get_timeInterval(interval=lbc_interval, DD=dd_intv, S=s_intv, S_n=sn_intv, S_d=sd_intv, ierr=ierr) @@ -106,19 +118,26 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) + (real(sn_intv, kind=RKIND) / real(sd_intv, kind=RKIND)) call mpas_pool_get_array(lbc, 'lbc_u', u, 2) + call mpas_pool_get_array(lbc, 'lbc_ru', ru, 2) + call mpas_pool_get_array(lbc, 'lbc_rho_edge', rho_edge, 2) call mpas_pool_get_array(lbc, 'lbc_w', w, 2) call mpas_pool_get_array(lbc, 'lbc_theta_m', theta_m, 2) call mpas_pool_get_array(lbc, 'lbc_rho_zz', rho_zz, 2) call mpas_pool_get_array(lbc, 'lbc_scalars', scalars, 2) call mpas_pool_get_array(lbc, 'lbc_u', lbc_tend_u, 1) + call mpas_pool_get_array(lbc, 'lbc_ru', lbc_tend_ru, 1) + call mpas_pool_get_array(lbc, 'lbc_rho_edge', lbc_tend_rho_edge, 1) call mpas_pool_get_array(lbc, 'lbc_w', lbc_tend_w, 1) call mpas_pool_get_array(lbc, 'lbc_theta_m', lbc_tend_theta_m, 1) call mpas_pool_get_array(lbc, 'lbc_rho_zz', lbc_tend_rho_zz, 1) call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_tend_scalars, 1) + dt = 1.0_RKIND / dt lbc_tend_u(:,:) = (u(:,:) - lbc_tend_u(:,:)) * dt + lbc_tend_ru(:,:) = (ru(:,:) - lbc_tend_ru(:,:)) * dt + lbc_tend_rho_edge(:,:) = (rho_edge(:,:) - lbc_tend_rho_edge(:,:)) * dt lbc_tend_w(:,:) = (w(:,:) - lbc_tend_w(:,:)) * dt lbc_tend_theta_m(:,:) = (theta_m(:,:) - lbc_tend_theta_m(:,:)) * dt lbc_tend_rho_zz(:,:) = (rho_zz(:,:) - lbc_tend_rho_zz(:,:)) * dt From 334892cd7c33031928c8ac8bee11ce5c96913181 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 6 Oct 2016 14:46:30 -0600 Subject: [PATCH 015/737] Add new field 'lbc_rtheta_m' to the lbc pool This new field is not expected to be read from input files, but will be computed from 'theta_m' and 'rho_zz' when reading boundary data. --- src/core_atmosphere/Registry.xml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 9ff52e4f2c..eccd69f60d 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1978,6 +1978,9 @@ + + From 3de0ab8c4925eaf01ecd7541f261305e7c14fbb2 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 6 Oct 2016 14:53:39 -0600 Subject: [PATCH 016/737] Process 'rtheta_m' in mpas_atm_update_bdy_tend This commit includes changes in the mpas_atm_boundaries module to: * compute rtheta_m = theta_m * rho_zz immediately after reading in theta_m and rho_zz from boundary files * computes tendencies for rtheta_m --- src/core_atmosphere/dynamics/mpas_atm_boundaries.F | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F index 44b5bd9887..6052b5ed56 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F +++ b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F @@ -72,6 +72,7 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) real (kind=RKIND), dimension(:,:), pointer :: rho_edge real (kind=RKIND), dimension(:,:), pointer :: w real (kind=RKIND), dimension(:,:), pointer :: theta_m + real (kind=RKIND), dimension(:,:), pointer :: rtheta_m real (kind=RKIND), dimension(:,:), pointer :: rho_zz real (kind=RKIND), dimension(:,:,:), pointer :: scalars real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_u @@ -79,6 +80,7 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho_edge real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_w real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_theta_m + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rtheta_m real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho_zz real (kind=RKIND), dimension(:,:,:), pointer :: lbc_tend_scalars @@ -109,7 +111,11 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) call mpas_pool_get_array(lbc, 'lbc_u', u, 2) call mpas_pool_get_array(lbc, 'lbc_ru', ru, 2) call mpas_pool_get_array(lbc, 'lbc_rho_edge', rho_edge, 2) + call mpas_pool_get_array(lbc, 'lbc_theta_m', theta_m, 2) + call mpas_pool_get_array(lbc, 'lbc_rtheta_m', rtheta_m, 2) + call mpas_pool_get_array(lbc, 'lbc_rho_zz', rho_zz, 2) ru(:,:) = u(:,:) * rho_edge(:,:) + rtheta_m(:,:) = theta_m(:,:) * rho_zz(:,:) if (.not. firstCall) then lbc_interval = currTime - LBC_intv_end @@ -122,6 +128,7 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) call mpas_pool_get_array(lbc, 'lbc_rho_edge', rho_edge, 2) call mpas_pool_get_array(lbc, 'lbc_w', w, 2) call mpas_pool_get_array(lbc, 'lbc_theta_m', theta_m, 2) + call mpas_pool_get_array(lbc, 'lbc_rtheta_m', rtheta_m, 2) call mpas_pool_get_array(lbc, 'lbc_rho_zz', rho_zz, 2) call mpas_pool_get_array(lbc, 'lbc_scalars', scalars, 2) @@ -130,6 +137,7 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) call mpas_pool_get_array(lbc, 'lbc_rho_edge', lbc_tend_rho_edge, 1) call mpas_pool_get_array(lbc, 'lbc_w', lbc_tend_w, 1) call mpas_pool_get_array(lbc, 'lbc_theta_m', lbc_tend_theta_m, 1) + call mpas_pool_get_array(lbc, 'lbc_rtheta_m', lbc_tend_rtheta_m, 1) call mpas_pool_get_array(lbc, 'lbc_rho_zz', lbc_tend_rho_zz, 1) call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_tend_scalars, 1) @@ -140,6 +148,7 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) lbc_tend_rho_edge(:,:) = (rho_edge(:,:) - lbc_tend_rho_edge(:,:)) * dt lbc_tend_w(:,:) = (w(:,:) - lbc_tend_w(:,:)) * dt lbc_tend_theta_m(:,:) = (theta_m(:,:) - lbc_tend_theta_m(:,:)) * dt + lbc_tend_rtheta_m(:,:) = (rtheta_m(:,:) - lbc_tend_rtheta_m(:,:)) * dt lbc_tend_rho_zz(:,:) = (rho_zz(:,:) - lbc_tend_rho_zz(:,:)) * dt lbc_tend_scalars(:,:,:) = (scalars(:,:,:) - lbc_tend_scalars(:,:,:)) * dt end if From 3c73150b726e8c5eaa415a94b7ce9fd49843c182 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 4 Oct 2016 13:23:36 -0600 Subject: [PATCH 017/737] additions to solver to accomodate regional mpas solution: (1) zero-gradient condition on w (2) mask out the operations transforming w to omega, and omega to w. code compiles but not yet ready to run. --- .../dynamics/mpas_atm_time_integration.F | 118 +++++++++++++++++- 1 file changed, 115 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 77d2ebe4d6..500a661f1f 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -36,6 +36,8 @@ module atm_time_integration use mpas_atmphys_utilities #endif + use mpas_atm_boundaries, only : nSpecZone, nRelaxZone, nBdyZone ! regional_MPAS addition + integer :: timerid, secs, u_secs ! Used to store physics tendencies for dynamics variables @@ -218,7 +220,9 @@ subroutine atm_srk3(domain, dt, itimestep) real (kind=RKIND), dimension(:,:), pointer :: rqvdynten + logical, parameter :: regional_mpas = .true. + ! ! Retrieve configuration options ! @@ -827,6 +831,25 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_dmpar_exch_halo_field(scalars_field) end if + ! set the zero-gradient condition on w for regional_MPAS + + if ( regional_mpas ) then ! regional_MPAS addition + block => domain % blocklist + do while (associated(block)) + + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'state', state) +!$OMP PARALLEL DO + do thread=1,block % nThreads + call atm_zero_gradient_w_bdy( state, mesh, & + block % cellSolveThreadStart(thread), block % cellSolveThreadEnd(thread) ) + end do +!$OMP END PARALLEL DO + + block => block % next + end do + end if ! end of regional_MPAS addition + end do RK3_DYNAMICS if (dynamics_substep < dynamics_split) then @@ -1529,12 +1552,18 @@ subroutine atm_set_smlstep_pert_variables( tend, diag, mesh, configs, & real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign + integer, dimension(:), pointer :: bdyMaskCell ! regional_MPAS + + call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) +! regional_MPAS: get specified zone cell mask + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'zz', zz) call mpas_pool_get_array(mesh, 'zb', zb) call mpas_pool_get_array(mesh, 'zb3', zb3) @@ -1573,7 +1602,9 @@ subroutine atm_set_smlstep_pert_variables( tend, diag, mesh, configs, & call atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, coef_3rd_order, & nEdgesOnCell, cellsOnEdge, edgesOnCell, fzm, fzp, ruAvg, wwAvg, zb, zb3, zb_cell, zb3_cell, & zz, w_tend, u_tend, rho_pp, rho_p_save, rho_p, ru_p, ru, ru_save, & - rtheta_pp, rtheta_p_save, rtheta_p, zz_rtheta_pp_old, rw_p, rw_save, rw, edgesOnCell_sign, & + rtheta_pp, rtheta_p_save, rtheta_p, zz_rtheta_pp_old, rw_p, rw_save, rw, & + bdyMaskCell, & ! added for regional_MPAS + edgesOnCell_sign, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -1584,7 +1615,9 @@ end subroutine atm_set_smlstep_pert_variables subroutine atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, coef_3rd_order, & nEdgesOnCell, cellsOnEdge, edgesOnCell, fzm, fzp, ruAvg, wwAvg, zb, zb3, zb_cell, zb3_cell, & zz, w_tend, u_tend, rho_pp, rho_p_save, rho_p, ru_p, ru, ru_save, & - rtheta_pp, rtheta_p_save, rtheta_p, zz_rtheta_pp_old, rw_p, rw_save, rw, edgesOnCell_sign, & + rtheta_pp, rtheta_p_save, rtheta_p, zz_rtheta_pp_old, rw_p, rw_save, rw, & + bdyMaskCell, & ! added for regional_MPAS + edgesOnCell_sign, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -1631,6 +1664,8 @@ subroutine atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, coef real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign + integer, dimension(nCells+1), intent(in) :: bdyMaskCell ! added for regional_MPAS + ! ! Local variables ! @@ -1645,6 +1680,8 @@ subroutine atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, coef !! do iCell=cellStart,cellEnd do iCell=cellSolveStart,cellSolveEnd + + if (bdyMaskCell(iCell) <= nRelaxZone) then ! no conversion in specified zone, regional_MPAS do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) !DIR$ IVDEP @@ -1658,6 +1695,7 @@ subroutine atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, coef do k = 2, nVertLevels w_tend(k,iCell) = ( fzm(k) * zz(k,iCell) + fzp(k) * zz(k-1,iCell) ) * w_tend(k,iCell) end do + end if ! no conversion in specified zone end do end subroutine atm_set_smlstep_pert_variables_work @@ -2115,6 +2153,7 @@ subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, d real (kind=RKIND) :: invNs, rcv, p0, flux real (kind=RKIND), pointer :: cf1, cf2, cf3, coef_3rd_order + integer, dimension(:), pointer :: bdyMaskCell ! MPAS_regional addition call mpas_pool_get_array(diag, 'wwAvg', wwAvg) call mpas_pool_get_array(diag, 'rw_save', rw_save) @@ -2148,6 +2187,8 @@ subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, d call mpas_pool_get_array(diag, 'pressure_p', pressure_p) call mpas_pool_get_array(diag, 'pressure_base', pressure_b) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) ! addition for regional_MPAS + call mpas_pool_get_array(mesh, 'zz', zz) call mpas_pool_get_array(mesh, 'zb', zb) call mpas_pool_get_array(mesh, 'zb3', zb3) @@ -2178,6 +2219,7 @@ subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, d rtheta_base, pressure_p, zz, theta_m, pressure_b, scalars, fzm, fzp, & zb, zb3, zb_cell, zb3_cell, edgesOnCell_sign, cellsOnEdge, edgesOnCell, nEdgesOnCell, & cf1, cf2, cf3, coef_3rd_order, & + bdyMaskCell, & ! addition for regional_MPAS cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -2190,6 +2232,7 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE rtheta_base, pressure_p, zz, theta_m, pressure_b, scalars, fzm, fzp, & zb, zb3, zb_cell, zb3_cell, edgesOnCell_sign, cellsOnEdge, edgesOnCell, nEdgesOnCell, & cf1, cf2, cf3, coef_3rd_order, & + bdyMaskCell, & ! addition for regional_MPAS cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -2205,6 +2248,8 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE integer, intent(in) :: ns, rk_step real (kind=RKIND), intent(in) :: dt + integer, dimension(nCells+1), intent(in) :: bdyMaskCell + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: wwAvg real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw_save real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: w @@ -2341,6 +2386,8 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE ! to use the same flux-divergence operator as is used for the horizontal theta transport ! (See Klemp et al 2003). + if (bdyMaskCell(iCell) <= nRelaxZone) then ! addition for regional_MPAS, no spec zone update + do i=1,nEdgesOnCell(iCell) iEdge=edgesOnCell(i,iCell) @@ -2358,11 +2405,15 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE end do w(1,iCell) = w(1,iCell)/(cf1*rho_zz(1,iCell)+cf2*rho_zz(2,iCell)+cf3*rho_zz(3,iCell)) -!DIR$ IVDEP + + + !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 + end if ! addition for regional_MPAS, no spec zone update + end do end subroutine atm_recover_large_step_variables_work @@ -5350,6 +5401,67 @@ subroutine atm_rk_dynamics_substep_finish( state, diag, dynamics_substep, dynami end subroutine atm_rk_dynamics_substep_finish +!------------------------------------------------------------------------- +! +! these next 2 routines set an approximate zero gradient boundary condition for w for regional_MPAS +! + subroutine atm_zero_gradient_w_bdy( state, mesh, cellSolveStart, cellSolveEnd ) + + ! reconstitute state variables from acoustic-step perturbation variables + ! after the acoustic steps. The perturbation variables were originally set in + ! subroutine atm_set_smlstep_pert_variables prior to their acoustic-steps update. + ! we are also computing a few other state-derived variables here. + + implicit none + + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: mesh + integer, intent(in) :: cellSolveStart, cellSolveEnd + + real (kind=RKIND), dimension(:,:), pointer :: w + + integer, dimension(:), pointer :: bdyMaskCell, nearestRelaxationCell + integer, pointer :: nCells + + call mpas_pool_get_array(state, 'w', w, 2) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'nearestRelaxationCell', nearestRelaxationCell) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + + call atm_zero_gradient_w_bdy_work( w, bdyMaskCell, nearestRelaxationCell, nCells, cellSolveStart, cellSolveEnd ) + + end subroutine atm_zero_gradient_w_bdy + +!------------------------------------------------------------------------- + + subroutine atm_zero_gradient_w_bdy_work( w, bdyMaskCell, nearestRelaxationCell, nCells, cellSolveStart, cellSolveEnd ) + + use mpas_atm_dimensions + + implicit none + + ! + ! Dummy arguments + ! + integer, intent(in) :: cellSolveStart, cellSolveEnd, nCells + integer, dimension(nCells+1), intent(in) :: bdyMaskCell, nearestRelaxationCell + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: w + + ! local variables + + integer :: iCell, k + + do iCell=cellSolveStart,cellSolveEnd + if (bdyMaskCell(iCell) > nRelaxZone) then ! no conversion in specified zone, regional_MPAS +!DIR$ IVDEP + do k = 2, nVertLevels + w(k,iCell) = w(k,nearestRelaxationCell(iCell)) + end do + end if + end do + + end subroutine atm_zero_gradient_w_bdy_work + !------------------------------------------------------------------------- subroutine atm_compute_convective_diagnostics( dims, mesh, state, diag ) From 572bf2e40ed582457399d6e2d91bd86132bae743 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 4 Oct 2016 14:08:53 -0600 Subject: [PATCH 018/737] additions to solver to accomodate regional mpas solution: (1) scalar update after each split transport step, including call and routines that do the work. The code compiles, but it is notyet ready to run. --- .../dynamics/mpas_atm_time_integration.F | 253 +++++++++++++++++- 1 file changed, 250 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 500a661f1f..9e643e9620 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -36,7 +36,7 @@ module atm_time_integration use mpas_atmphys_utilities #endif - use mpas_atm_boundaries, only : nSpecZone, nRelaxZone, nBdyZone ! regional_MPAS addition + use mpas_atm_boundaries, only : nSpecZone, nRelaxZone, nBdyZone, mpas_atm_get_bdy_state ! regional_MPAS addition integer :: timerid, secs, u_secs @@ -69,6 +69,8 @@ module atm_time_integration real (kind=RKIND), dimension(:,:), allocatable :: rho_zz_int real (kind=RKIND), dimension(:,:,:), allocatable :: scalar_tend_array + real (kind=RKIND), dimension(:,:,:), allocatable :: scalars_driving ! regional_MPAS addition + ! Used in compute_solve_diagnostics real (kind=RKIND), allocatable, dimension(:,:) :: ke_vertex real (kind=RKIND), allocatable, dimension(:,:) :: ke_edge @@ -191,13 +193,15 @@ subroutine atm_srk3(domain, dt, itimestep) character (len=StrKIND), pointer :: config_convection_scheme integer, pointer :: num_scalars, index_qv, nCells, nCellsSolve, nEdges, nEdgesSolve, nVertices, nVerticesSolve, nVertLevels - + integer, pointer :: index_qc, index_qr, index_qi, index_qs, index_qg, index_nr, index_ni + type (mpas_pool_type), pointer :: state type (mpas_pool_type), pointer :: diag type (mpas_pool_type), pointer :: diag_physics type (mpas_pool_type), pointer :: mesh type (mpas_pool_type), pointer :: tend type (mpas_pool_type), pointer :: tend_physics + type (mpas_pool_type), pointer :: lbc ! regional_MPAS addition type (field2DReal), pointer :: theta_m_field type (field3DReal), pointer :: scalars_field @@ -576,6 +580,38 @@ subroutine atm_srk3(domain, dt, itimestep) end do call mpas_timer_stop('small_step_prep') + +!------------------------------------------------------------------------------------------------------------------------ + + if (regional_mpas) then ! adjust boundary tendencies for regional_MPAS dry dynamics + + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'tend', tend) + call mpas_pool_get_subpool(block % structs, 'lbc', lbc) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + +!$OMP PARALLEL DO + do thread=1,block % nThreads +! call atm_bdy_adjust_dynamics_tend( tend, state, diag, mesh, lbc, block % configs, nVertLevels, rk_step, dt, & ! which dt belongs in here - i.e. should we damp to new (end of full timestep) value? +! block % cellThreadStart(thread), block % cellThreadEnd(thread), & +! block % vertexThreadStart(thread), block % vertexThreadEnd(thread), & +! block % edgeThreadStart(thread), block % edgeThreadEnd(thread), & +! block % cellSolveThreadStart(thread), block % cellSolveThreadEnd(thread), & +! block % vertexSolveThreadStart(thread), block % vertexSolveThreadEnd(thread), & +! block % edgeSolveThreadStart(thread), block % edgeSolveThreadEnd(thread) ) + end do +!$OMP END PARALLEL DO + + end if ! regional_MPAS addition + +!------------------------------------------------------------------------------------------------------------------------ + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! begin acoustic steps loop !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1006,6 +1042,63 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_timer_stop('atm_advance_scalars_mono') end if +!------------------------------------------------------------------------------------------------------------------------ + + if (regional_mpas) then ! adjust boundary tendencies for regional_MPAS scalar transport + + block => domain % blocklist + do while (associated(block)) + + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(mesh, 'num_scalars', num_scalars) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) + + + ! get the scalar values driving the regional boundary conditions + ! + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_dimension(state, 'index_qc', index_qc) + call mpas_pool_get_dimension(state, 'index_qr', index_qr) + call mpas_pool_get_dimension(state, 'index_qi', index_qi) + call mpas_pool_get_dimension(state, 'index_qs', index_qs) + call mpas_pool_get_dimension(state, 'index_qy', index_qg) + call mpas_pool_get_dimension(state, 'index_nr', index_nr) + call mpas_pool_get_dimension(state, 'index_ni', index_ni) + scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qv', rk_timestep(rk_step) ) + scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qc', rk_timestep(rk_step) ) + scalars_driving(index_qr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qr', rk_timestep(rk_step) ) + scalars_driving(index_qi,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qi', rk_timestep(rk_step) ) + scalars_driving(index_qs,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qs', rk_timestep(rk_step) ) + scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qg', rk_timestep(rk_step) ) + scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'nr', rk_timestep(rk_step) ) + scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) + +!$OMP PARALLEL DO + do thread=1,block % nThreads + call atm_bdy_adjust_scalars( state, diag, mesh, block % configs, scalars_driving, nVertLevels, dt, rk_timestep(rk_step), & + block % cellThreadStart(thread), block % cellThreadEnd(thread), & + block % vertexThreadStart(thread), block % vertexThreadEnd(thread), & + block % edgeThreadStart(thread), block % edgeThreadEnd(thread), & + block % cellSolveThreadStart(thread), block % cellSolveThreadEnd(thread), & + block % vertexSolveThreadStart(thread), block % vertexSolveThreadEnd(thread), & + block % edgeSolveThreadStart(thread), block % edgeSolveThreadEnd(thread) ) + end do +!$OMP END PARALLEL DO + + deallocate(scalars_driving) + + block => block % next + end do + + end if ! regional_MPAS addition + +!------------------------------------------------------------------------------------------------------------------------ + if (rk_step < 3) then call mpas_pool_get_field(state, 'scalars', scalars_field, 2) call mpas_dmpar_exch_halo_field(scalars_field) @@ -5452,7 +5545,7 @@ subroutine atm_zero_gradient_w_bdy_work( w, bdyMaskCell, nearestRelaxationCell, integer :: iCell, k do iCell=cellSolveStart,cellSolveEnd - if (bdyMaskCell(iCell) > nRelaxZone) then ! no conversion in specified zone, regional_MPAS + if (bdyMaskCell(iCell) > nRelaxZone) then !DIR$ IVDEP do k = 2, nVertLevels w(k,iCell) = w(k,nearestRelaxationCell(iCell)) @@ -5462,6 +5555,160 @@ subroutine atm_zero_gradient_w_bdy_work( w, bdyMaskCell, nearestRelaxationCell, end subroutine atm_zero_gradient_w_bdy_work +!------------------------------------------------------------------------- + + subroutine atm_bdy_adjust_scalars( state, diag, mesh, config, scalars_driving, nVertLevels, dt, dt_rk, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + + implicit none + + ! this routine resets the dry dynamics variables at the end of an rk3 substep for the case + ! where the dry dynamics is split from the scalar transport (i.e. where the dry dynamics is + ! using a different, usually smaller, timestep. + ! + ! WCS 18 November 2014 + + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(in) :: diag + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: config + integer, intent(in) :: nVertLevels + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + + real (kind=RKIND), intent(in) :: dt, dt_rk + real (kind=RKIND), dimension(:,:,:), intent(in) :: scalars_driving + real (kind=RKIND), dimension(:,:,:), pointer :: scalars_new + real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign + + real (kind=RKIND), dimension(:), pointer :: invDcEdge, dvEdge + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: edgesOnCell, cellsOnEdge + integer, pointer :: nCells, nEdges, maxEdges, num_scalars + integer, dimension(:), pointer :: bdyMaskCell + + call mpas_pool_get_array(state, 'scalars', scalars_new, 2) + + call mpas_pool_get_array(mesh, 'invDcEdge', invDcEdge ) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge ) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'maxEdges', maxEdges) + + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + + call atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, & + nVertLevels, nCells, nEdges, num_scalars, & + nEdgesOnCell, edgesOnCell, EdgesOnCell_sign, cellsOnEdge, dvEdge, invDcEdge, bdyMaskCell, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) + + end subroutine atm_bdy_adjust_scalars + +!------------------------------------------------------------------------- + + subroutine atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, & + nVertLevels, nCells, nEdges, num_scalars, & + nEdgesOnCell, edgesOnCell, EdgesOnCell_sign, cellsOnEdge, dvEdge, invDcEdge, bdyMaskCell, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) + + use mpas_atm_dimensions + + implicit none + + real (kind=RKIND), dimension(:,:,:), intent(in) :: scalars_driving + real (kind=RKIND), dimension(:,:,:), intent(inout) :: scalars_new + real (kind=RKIND), dimension(:,:), intent(in) :: edgesOnCell_sign + integer, intent(in) :: nVertLevels, nCells, nEdges, num_scalars + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, dimension(:), intent(in) :: nEdgesOnCell, bdyMaskCell + integer, dimension(:,:), intent(in) :: edgesOnCell, cellsOnEdge + real (kind=RKIND), dimension(:), intent(in) :: dvEdge, invDcEdge + real (kind=RKIND), intent(in) :: dt, dt_rk + + ! local varoiables + + real (kind=RKIND), dimension(1:num_scalars,1:nVertLevels, cellSolveStart:cellSolveEnd) :: scalars_tmp + real (kind=RKIND) :: edge_sign, laplacian_filter_coef, rayleigh_damping_coef, filter_flux + integer :: iCell, iEdge, iScalar, i, k, cell1, cell2 + + !--- + + do iCell = cellSolveStart, cellSolveEnd ! threaded over cells + + if ( (bdyMaskCell(iCell) > 1) .and. (bdyMaskCell(iCell) <= nRelaxZone) ) then ! relaxation zone + + laplacian_filter_coef = dt_rk*(real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(10.*dt) + rayleigh_damping_coef = laplacian_filter_coef/5.0 + scalars_tmp(1:num_scalars,1:nVertLevels,iCell) = scalars_new(1:num_scalars,1:nVertLevels,iCell) + + ! first, we compute the 2nd-order laplacian filter + ! + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + ! edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) * laplacian_filter_coef + ! this is a dimensionless laplacian, so we leave out the r_areaCell + edge_sign = edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) * laplacian_filter_coef + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) +!DIR$ IVDEP + do k=1,nVertLevels + do iScalar = 1, num_scalars + filter_flux = edge_sign*( (scalars_new(iScalar,k,cell2)-scalars_driving(iScalar,k,cell2)) & + - (scalars_new(iScalar,k,cell1)-scalars_driving(iScalar,k,cell1)) ) + scalars_tmp(iScalar,k,iCell) = scalars_tmp(iScalar,k,iCell) + filter_flux + end do + end do + end do + + ! second, we compute the Rayleigh damping component + ! +!DIR$ IVDEP + do k=1,nVertLevels + do iScalar = 1, num_scalars + scalars_tmp(iScalar,k,iCell) =scalars_tmp(iScalar,k,iCell) - rayleigh_damping_coef * (scalars_new(iScalar,k,iCell)-scalars_driving(iScalar,k,iCell)) + end do + end do + + else if ( bdyMaskCell(iCell) > nRelaxZone) then ! specified zone + + ! update the specified-zone values + ! +!DIR$ IVDEP + do k=1,nVertLevels + do iScalar = 1, num_scalars + scalars_tmp(iScalar,k,iCell) = scalars_driving(iScalar,k,iCell) + end do + end do + + end if + + end do ! updates now in temp storage + +!OMP BARRIER + + do iCell = cellSolveStart, cellSolveEnd ! threaded over cells + if (bdyMaskCell(iCell) > 1) then ! update values +!DIR$ IVDEP + do k=1,nVertLevels + do iScalar = 1, num_scalars + scalars_new(iScalar,k,iCell) = scalars_tmp(iScalar,k,iCell) + end do + end do + end if + end do + + end subroutine atm_bdy_adjust_scalars_work + !------------------------------------------------------------------------- subroutine atm_compute_convective_diagnostics( dims, mesh, state, diag ) From b9aaa739bfd27866a689862676025176535e96c3 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 4 Oct 2016 14:50:52 -0600 Subject: [PATCH 019/737] additions to solver to accomodate regional mpas solution: (1) added masking in atm_advance_acoustic_step code compiles, but it is not yet ready to run. --- .../dynamics/mpas_atm_time_integration.F | 35 ++++++++++++++++--- 1 file changed, 30 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 9e643e9620..a223b3014e 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1840,6 +1840,7 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, real (kind=RKIND), dimension(:,:), pointer :: pzp, pzm integer, dimension(:), pointer :: nEdgesOnCell + real (kind=RKIND), dimension(:), pointer :: specifiedZoneMaskCell, specifiedZoneMaskEdge integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign @@ -1853,6 +1854,8 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array(mesh, 'specifiedZoneMaskEdge', specifiedZoneMaskEdge) + call mpas_pool_get_array(mesh, 'specifiedZoneMaskCell', specifiedZoneMaskCell) call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) ! call mpas_pool_get_array(state, 'theta_m', theta_m, 2) @@ -1926,7 +1929,8 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, rho_pp, cofwt, coftz, zxu, a_tri, alpha_tri, gamma_tri, dss, tend_ru, tend_rho, tend_rt, & tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, divergence_3d, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, pzp, pzm, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & - dts, small_step, epssm, smdiv, smdiv_p_forward, cf1, cf2, cf3 & + dts, small_step, epssm, smdiv, smdiv_p_forward, cf1, cf2, cf3, & + specifiedZoneMaskEdge, specifiedZoneMaskCell & ) end subroutine atm_advance_acoustic_step @@ -1938,7 +1942,8 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart rho_pp, cofwt, coftz, zxu, a_tri, alpha_tri, gamma_tri, dss, tend_ru, tend_rho, tend_rt, & tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, divergence_3d, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, pzp, pzm, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & - dts, small_step, epssm, smdiv, smdiv_p_forward, cf1, cf2, cf3 & + dts, small_step, epssm, smdiv, smdiv_p_forward, cf1, cf2, cf3, & + specifiedZoneMaskEdge, specifiedZoneMaskCell & ) use mpas_atm_dimensions @@ -2006,6 +2011,10 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart integer, dimension(maxEdges,nCells+1) :: edgesOnCell real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1) :: specifiedZoneMaskCell + real (kind=RKIND), dimension(nEdges+1) :: specifiedZoneMaskEdge + + integer, intent(in) :: small_step real (kind=RKIND), intent(in) :: dts, epssm, smdiv, smdiv_p_forward, cf1, cf2, cf3 @@ -2060,8 +2069,10 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart pgrad = ((rtheta_pp(k,cell2)-rtheta_pp(k,cell1))*invDcEdge(iEdge) )/(.5*(zz(k,cell2)+zz(k,cell1))) pgrad = cqu(k,iEdge)*0.5*c2*(exner(k,cell1)+exner(k,cell2))*pgrad pgrad = pgrad + 0.5*zxu(k,iEdge)*gravity*(rho_pp(k,cell1)+rho_pp(k,cell2)) - ru_p(k,iEdge) = ru_p(k,iEdge) + dts*(tend_ru(k,iEdge) - pgrad) & - - smdiv*dcEdge(iEdge)*(divergence_3d(k,cell2)-divergence_3d(k,cell1)) +!!! ru_p(k,iEdge) = ru_p(k,iEdge) + dts*(tend_ru(k,iEdge) - pgrad) & +!!! - smdiv*dcEdge(iEdge)*(divergence_3d(k,cell2)-divergence_3d(k,cell1)) + ru_p(k,iEdge) = ru_p(k,iEdge) + dts*tend_ru(k,iEdge) & + - specifiedZoneMaskEdge(iEdge)*( dts*pgrad + smdiv*dcEdge(iEdge)*(divergence_3d(k,cell2)-divergence_3d(k,cell1)) ) end do ! accumulate ru_p for use later in scalar transport @@ -2086,7 +2097,8 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP do k=1,nVertLevels - ru_p(k,iEdge) = dts*tend_ru(k,iEdge) - smdiv*dcEdge(iEdge)*(tend_rho(k,cell2)-tend_rho(k,cell1)) +!!! ru_p(k,iEdge) = dts*tend_ru(k,iEdge) - smdiv*dcEdge(iEdge)*(tend_rho(k,cell2)-tend_rho(k,cell1)) + ru_p(k,iEdge) = dts*tend_ru(k,iEdge) - specifiedZoneMaskEdge(iEdge)*smdiv*dcEdge(iEdge)*(tend_rho(k,cell2)-tend_rho(k,cell1)) end do !DIR$ IVDEP do k=1,nVertLevels @@ -2095,6 +2107,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart end do end if ! end test for block-owned cells + end do ! end loop over edges end if ! test for first acoustic step @@ -2103,6 +2116,8 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart do iCell=cellSolveStart,cellSolveEnd ! loop over all owned cells to solve + if(specifiedZoneMaskCell(iCell) == 0.0) then ! not specified zone, compute... + ts(:,iCell) = 0.0 rs(:,iCell) = 0.0 @@ -2202,6 +2217,16 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart divergence_3d(k,iCell) = (rho_pp(k,iCell) - divergence_3d(k,iCell))*rdts end do + else ! specifed zone in regional_MPAS + + do k=1,nVertLevels + rho_pp(k,iCell) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) + rtheta_pp(k,iCell) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) + rw_p(k,iCell) = rw_p(k,iCell) + dts*tend_rw(k,iCell) + wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) + end do + end if + end do ! end of loop over cells end subroutine atm_advance_acoustic_step_work From dfac98fd29cd797c57944e6414872e42dad9dcc9 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Wed, 5 Oct 2016 10:10:53 -0600 Subject: [PATCH 020/737] additions to solver to accomodate regional mpas solution: (1) masking added to atm_advance_scalars to block update in specified zone (2) masking added to atm_advance_scalars_mono to block update in specified zone. In both cases most or all of the update is calculated in the transport routine but not applied in the specified zone. The code compiles, but is not yet ready to run/test. --- .../dynamics/mpas_atm_time_integration.F | 30 +++++++++++++++++-- 1 file changed, 27 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index a223b3014e..75b610a26d 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -2591,6 +2591,8 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4 real (kind=RKIND), pointer :: coef_3rd_order + integer, dimension(:), pointer :: bdyMaskCell ! regional_MPAS addition + logical :: local_advance_density if (present(advance_density)) then @@ -2619,6 +2621,8 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend_save) + call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend_save) ! regional_MPAS addition + call mpas_pool_get_array(mesh, 'fzm', fnm) call mpas_pool_get_array(mesh, 'fzp', fnp) call mpas_pool_get_array(mesh, 'rdzw', rdnw) @@ -2637,6 +2641,8 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + if (local_advance_density) then ! call atm_advance_scalars_work(num_scalars, nCells, nVertLevels, dt, & ! cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & @@ -2655,6 +2661,7 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n uhAvg, wwAvg, deriv_two, dvEdge, & cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & + bdyMaskCell, & nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & local_advance_density, scalar_tend, rho_zz_int) @@ -2676,6 +2683,7 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n uhAvg, wwAvg, deriv_two, dvEdge, & cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & + bdyMaskCell, & nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & local_advance_density) @@ -2962,6 +2970,7 @@ subroutine atm_advance_scalars_work_new( num_scalars_dummy, nCells, nVertLevels_ uhAvg, wwAvg, deriv_two, dvEdge, & cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & + bdyMaskCell, & nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & advance_density, scalar_tend, rho_zz_int) @@ -3020,6 +3029,7 @@ subroutine atm_advance_scalars_work_new( num_scalars_dummy, nCells, nVertLevels_ real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout), optional :: scalar_tend real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout), optional :: rho_zz_int real (kind=RKIND), dimension(:), intent(in) :: invAreaCell + integer, dimension(:), intent(in) :: bdyMaskCell ! regional_MPAS addition integer, intent(in) :: nCellsSolve, nEdges integer :: i, j, iCell, iAdvCell, iEdge, k, iScalar, cell1, cell2 @@ -3128,6 +3138,9 @@ subroutine atm_advance_scalars_work_new( num_scalars_dummy, nCells, nVertLevels_ do iCell=cellSolveStart,cellSolveEnd + + if(bdyMaskCell(iCell) <= nRelaxZone) then ! specified zone for regional_MPAS is not updated in this routine + #ifndef DO_PHYSICS scalar_tend_save(:,:,iCell) = 0.0 ! testing purposes - we have no sources or sinks #endif @@ -3193,6 +3206,8 @@ subroutine atm_advance_scalars_work_new( num_scalars_dummy, nCells, nVertLevels_ end do end do + end if ! specified zone regional_MPAS test + end do end subroutine atm_advance_scalars_work_new @@ -3247,6 +3262,8 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_3rd real (kind=RKIND), dimension(:,:,:), pointer :: scalars_old, scalars_new + integer, dimension(:), pointer :: bdyMaskCell ! regional_MPAS addition + integer, pointer :: nCellsSolve real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw @@ -3282,6 +3299,8 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) ! MPAS_regional addition + call atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLevels, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & @@ -3290,6 +3309,7 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe edgesOnCell, edgesOnCell_sign, nEdgesOnCell, fnm, fnp, rdnw, nAdvCellsForEdge, & advCellsForEdge, adv_coefs, adv_coefs_3rd, scalar_old, scalar_new, s_max, s_min, & wdtn, scale_arr, flux_arr, flux_upwind_tmp, flux_tmp, & + bdyMaskCell, & advance_density, rho_zz_int) end subroutine atm_advance_scalars_mono @@ -3303,6 +3323,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve edgesOnCell, edgesOnCell_sign, nEdgesOnCell, fnm, fnp, rdnw, nAdvCellsForEdge, & advCellsForEdge, adv_coefs, adv_coefs_3rd, scalar_old, scalar_new, s_max, s_min, & wdtn, scale_arr, flux_arr, flux_upwind_tmp, flux_tmp, & + bdyMaskCell, & advance_density, rho_zz_int) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! @@ -3361,6 +3382,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: wwAvg real (kind=RKIND), dimension(:), intent(in) :: dvEdge, invAreaCell integer, dimension(:,:), intent(in) :: cellsOnEdge, cellsOnCell, edgesOnCell + integer, dimension(:) :: bdyMaskCell real (kind=RKIND), dimension(:,:), intent(in) :: edgesOnCell_sign integer, dimension(:,:), intent(in) :: advCellsForEdge @@ -3870,9 +3892,11 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve !$OMP BARRIER do iCell=cellStart,cellEnd - do k=1, nVertLevels - scalars_new(iScalar,k,iCell) = max(0.0_RKIND,scalar_new(k,iCell)) - end do + if(bdyMaskCell(iCell) <= nSpecZone) then ! regional_MPAS does spec zone update after transport. + do k=1, nVertLevels + scalars_new(iScalar,k,iCell) = max(0.0_RKIND,scalar_new(k,iCell)) + end do + end if end do end do ! loop over scalars From 77bd1e75811afde9291a25f1ad6b5022bb1965a3 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Wed, 5 Oct 2016 11:28:54 -0600 Subject: [PATCH 021/737] additions to solver to accomodate regional mpas solution: (1) added subroutine and call to set specified zone tendencies for the dynamics variables. The new code compiles, but is not ready to run/test. --- .../dynamics/mpas_atm_time_integration.F | 78 +++++++++++++++++-- 1 file changed, 70 insertions(+), 8 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 75b610a26d..4d79d947f8 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -70,6 +70,9 @@ module atm_time_integration real (kind=RKIND), dimension(:,:,:), allocatable :: scalar_tend_array real (kind=RKIND), dimension(:,:,:), allocatable :: scalars_driving ! regional_MPAS addition + real (kind=RKIND), dimension(:,:), allocatable :: ru_driving_tend ! regional_MPAS addition + real (kind=RKIND), dimension(:,:), allocatable :: rt_driving_tend ! regional_MPAS addition + real (kind=RKIND), dimension(:,:), allocatable :: rho_driving_tend ! regional_MPAS addition ! Used in compute_solve_diagnostics real (kind=RKIND), allocatable, dimension(:,:) :: ke_vertex @@ -589,22 +592,26 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_subpool(block % structs, 'diag', diag) call mpas_pool_get_subpool(block % structs, 'mesh', mesh) call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_subpool(block % structs, 'lbc', lbc) call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + allocate(ru_driving_tend(nVertLevels,nEdges+1)) + allocate(rt_driving_tend(nVertLevels,nCells+1)) + allocate(rho_driving_tend(nVertLevels,nCells+1)) + ru_driving_tend(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'u', 0.0_RKIND ) + rt_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'theta_m', 0.0_RKIND ) + rho_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', 0.0_RKIND ) + ! are the theta_m and u tendencies coupled? + !$OMP PARALLEL DO do thread=1,block % nThreads -! call atm_bdy_adjust_dynamics_tend( tend, state, diag, mesh, lbc, block % configs, nVertLevels, rk_step, dt, & ! which dt belongs in here - i.e. should we damp to new (end of full timestep) value? -! block % cellThreadStart(thread), block % cellThreadEnd(thread), & -! block % vertexThreadStart(thread), block % vertexThreadEnd(thread), & -! block % edgeThreadStart(thread), block % edgeThreadEnd(thread), & -! block % cellSolveThreadStart(thread), block % cellSolveThreadEnd(thread), & -! block % vertexSolveThreadStart(thread), block % vertexSolveThreadEnd(thread), & -! block % edgeSolveThreadStart(thread), block % edgeSolveThreadEnd(thread) ) + call atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, block % configs, nVertLevels, & + ru_driving_tend, rt_driving_tend, rho_driving_tend, & + block % cellThreadStart(thread), block % cellThreadEnd(thread), & + block % edgeThreadStart(thread), block % edgeThreadEnd(thread) ) end do !$OMP END PARALLEL DO @@ -5606,6 +5613,61 @@ end subroutine atm_zero_gradient_w_bdy_work !------------------------------------------------------------------------- + subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, config, nVertLevels, & + ru_driving_tend, rt_driving_tend, rho_driving_tend, & + cellStart, cellEnd, edgeStart, edgeEnd ) + + implicit none + + ! this routine resets the dry dynamics variables at the end of an rk3 substep for the case + ! where the dry dynamics is split from the scalar transport (i.e. where the dry dynamics is + ! using a different, usually smaller, timestep. + ! + ! WCS 18 November 2014 + + type (mpas_pool_type), intent(in) :: state + type (mpas_pool_type), intent(inout) :: tend + type (mpas_pool_type), intent(in) :: diag + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: config + integer, intent(in) :: nVertLevels + integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd + + real (kind=RKIND), dimension(:,:), intent(in) :: ru_driving_tend, rt_driving_tend, rho_driving_tend + real (kind=RKIND), dimension(:,:), pointer :: tend_ru, tend_rt, tend_rho, tend_rw + integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge + + integer :: iCell, iEdge, k + + call mpas_pool_get_array(tend, 'u', tend_ru) + call mpas_pool_get_array(tend, 'rho_zz', tend_rho) + call mpas_pool_get_array(tend, 'theta_m', tend_rt) + call mpas_pool_get_array(tend, 'w', tend_rw) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) + + do iCell = cellStart, cellEnd + if(bdyMaskCell(iCell) > nRelaxZone) then + do k=1, nVertLevels + tend_rho(k,iCell) = rho_driving_tend(k,iCell) + tend_rt(k,iCell) = rt_driving_tend(k,iCell) + tend_rw(k,iCell) = 0. + end do + end if + end do + + do iEdge = edgeStart, edgeEnd + if(bdyMaskEdge(iEdge) > nRelaxZone) then + do k=1, nVertLevels + tend_ru(k,iEdge) = ru_driving_tend(k,iCell) + end do + end if + end do + + end subroutine atm_bdy_adjust_dynamics_speczone_tend + + !------------------------------------------------------------------------- + subroutine atm_bdy_adjust_scalars( state, diag, mesh, config, scalars_driving, nVertLevels, dt, dt_rk, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) From b215b0294fa8b4d66171ed9497d0273a651776d1 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Thu, 6 Oct 2016 16:02:34 -0600 Subject: [PATCH 022/737] additions to solver to accomodate regional mpas solution: (1) relaxation-zone additions for dynamics variables. (2) reset for u and ru after acoustics step somplete and large-step variables set. (3) some cleanup and fixes of the previous regional solver commits. With these six commits, the solver is now ready for testing. It compiles, but has not yet been debugged. --- .../dynamics/mpas_atm_time_integration.F | 362 ++++++++++++++++-- 1 file changed, 331 insertions(+), 31 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 4d79d947f8..a4f2472c6b 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -36,7 +36,7 @@ module atm_time_integration use mpas_atmphys_utilities #endif - use mpas_atm_boundaries, only : nSpecZone, nRelaxZone, nBdyZone, mpas_atm_get_bdy_state ! regional_MPAS addition + use mpas_atm_boundaries, only : nSpecZone, nRelaxZone, nBdyZone, mpas_atm_get_bdy_state, mpas_atm_get_bdy_tend ! regional_MPAS addition integer :: timerid, secs, u_secs @@ -73,6 +73,10 @@ module atm_time_integration real (kind=RKIND), dimension(:,:), allocatable :: ru_driving_tend ! regional_MPAS addition real (kind=RKIND), dimension(:,:), allocatable :: rt_driving_tend ! regional_MPAS addition real (kind=RKIND), dimension(:,:), allocatable :: rho_driving_tend ! regional_MPAS addition + real (kind=RKIND), dimension(:,:), allocatable :: ru_driving_values ! regional_MPAS addition + real (kind=RKIND), dimension(:,:), allocatable :: rt_driving_values ! regional_MPAS addition + real (kind=RKIND), dimension(:,:), allocatable :: rho_driving_values ! regional_MPAS addition + integer, dimension(:), pointer :: bdyMaskEdge ! regional_MPAS addition ! Used in compute_solve_diagnostics real (kind=RKIND), allocatable, dimension(:,:) :: ke_vertex @@ -586,35 +590,85 @@ subroutine atm_srk3(domain, dt, itimestep) !------------------------------------------------------------------------------------------------------------------------ - if (regional_mpas) then ! adjust boundary tendencies for regional_MPAS dry dynamics + if (regional_mpas) then ! adjust boundary tendencies for regional_MPAS dry dynamics in the specified zone - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'tend', tend) + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - allocate(ru_driving_tend(nVertLevels,nEdges+1)) - allocate(rt_driving_tend(nVertLevels,nCells+1)) - allocate(rho_driving_tend(nVertLevels,nCells+1)) - ru_driving_tend(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'u', 0.0_RKIND ) - rt_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'theta_m', 0.0_RKIND ) - rho_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', 0.0_RKIND ) - ! are the theta_m and u tendencies coupled? + allocate(ru_driving_tend(nVertLevels,nEdges+1)) + allocate(rt_driving_tend(nVertLevels,nCells+1)) + allocate(rho_driving_tend(nVertLevels,nCells+1)) + ru_driving_tend(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_tend( clock, domain % blocklist, nVertLevels, nEdges, 'ru', 0.0_RKIND ) + rt_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_tend( clock, domain % blocklist, nVertLevels, nCells, 'rtheta_m', 0.0_RKIND ) + rho_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_tend( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', 0.0_RKIND ) !$OMP PARALLEL DO - do thread=1,block % nThreads - call atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, block % configs, nVertLevels, & - ru_driving_tend, rt_driving_tend, rho_driving_tend, & - block % cellThreadStart(thread), block % cellThreadEnd(thread), & - block % edgeThreadStart(thread), block % edgeThreadEnd(thread) ) + do thread=1,block % nThreads + call atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, block % configs, nVertLevels, & + ru_driving_tend, rt_driving_tend, rho_driving_tend, & + block % cellThreadStart(thread), block % cellThreadEnd(thread), & + block % edgeThreadStart(thread), block % edgeThreadEnd(thread), & + block % cellSolveThreadStart(thread), block % cellSolveThreadEnd(thread), & + block % edgeSolveThreadStart(thread), block % edgeSolveThreadEnd(thread) ) + end do +!$OMP END PARALLEL DO + + deallocate(ru_driving_tend) + deallocate(rt_driving_tend) + deallocate(rho_driving_tend) + block => block % next end do + +! -------- next, add in the tendencies for the horizontal filters and Rayleigh damping. We will keep the spec zone and relax zone adjustments separate for now... + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'tend', tend) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + allocate(ru_driving_values(nVertLevels,nEdges+1)) + allocate(rt_driving_values(nVertLevels,nCells+1)) + allocate(rho_driving_values(nVertLevels,nCells+1)) + ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'ru', rk_timestep(rk_step) ) + rt_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rtheta_m', rk_timestep(rk_step) ) + rho_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', rk_timestep(rk_step) ) + +!$OMP PARALLEL DO + do thread=1,block % nThreads + call atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, block % configs, nVertLevels, dt, & + ru_driving_values, rt_driving_values, rho_driving_values, & + block % cellThreadStart(thread), block % cellThreadEnd(thread), & + block % vertexThreadStart(thread), block % vertexThreadEnd(thread), & + block % edgeThreadStart(thread), block % edgeThreadEnd(thread), & + block % cellSolveThreadStart(thread), block % cellSolveThreadEnd(thread), & + block % vertexSolveThreadStart(thread), block % vertexSolveThreadEnd(thread), & + block % edgeSolveThreadStart(thread), block % edgeSolveThreadEnd(thread) ) + end do !$OMP END PARALLEL DO + deallocate(ru_driving_values) + deallocate(rt_driving_values) + deallocate(rho_driving_values) + block => block % next + end do + + end if ! regional_MPAS addition !------------------------------------------------------------------------------------------------------------------------ @@ -721,6 +775,55 @@ subroutine atm_srk3(domain, dt, itimestep) end do call mpas_timer_stop('atm_recover_large_step_variables') +!------------------------------------------------------------------- + + if (regional_mpas) then + + ! First, (re)set the value of u and ru in the specified zone at the outermost edge (we will reset all for now). + ! atm_recover_large_step_variables will not have set outermost edge velocities correctly. + + block => domain % blocklist + do while (associated(block)) + + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_array(state, 'u', u, 2) + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) + + allocate(ru_driving_values(nVertLevels,nEdges+1)) + + ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'u', rk_timestep(rk_step) ) + ! do this inline at present - it is simple enough + do iEdge = 1, nEdgesSolve + if(bdyMaskEdge(iEdge) > nRelaxZone) then + do k = 1, nVertLevels + u(k,iEdge) = ru_driving_values(k,iEdge) + end do + end if + end do + + ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'ru', rk_timestep(rk_step) ) + call mpas_pool_get_array(diag, 'ru', u) + ! do this inline at present - it is simple enough + do iEdge = 1, nEdgesSolve + if(bdyMaskEdge(iEdge) > nRelaxZone) then + do k = 1, nVertLevels + u(k,iEdge) = ru_driving_values(k,iEdge) + end do + end if + end do + + block => block % next + end do + deallocate(ru_driving_values) + + end if ! regional_MPAS addition + +!------------------------------------------------------------------- + ! u !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % state % time_levs(2) % state % u, (/ 3 /)) call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) @@ -1053,6 +1156,9 @@ subroutine atm_srk3(domain, dt, itimestep) if (regional_mpas) then ! adjust boundary tendencies for regional_MPAS scalar transport + call mpas_pool_get_field(state, 'scalars', scalars_field, 2) ! need to fill halo for horizontal filter + call mpas_dmpar_exch_halo_field(scalars_field) + block => domain % blocklist do while (associated(block)) @@ -4537,6 +4643,9 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end do end do + + + !$OMP BARRIER do iEdge=edgeSolveStart,edgeSolveEnd @@ -5613,9 +5722,10 @@ end subroutine atm_zero_gradient_w_bdy_work !------------------------------------------------------------------------- - subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, config, nVertLevels, & - ru_driving_tend, rt_driving_tend, rho_driving_tend, & - cellStart, cellEnd, edgeStart, edgeEnd ) + subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, config, nVertLevels, & + ru_driving_tend, rt_driving_tend, rho_driving_tend, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd ) implicit none @@ -5632,6 +5742,7 @@ subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, confi type (mpas_pool_type), intent(in) :: config integer, intent(in) :: nVertLevels integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd real (kind=RKIND), dimension(:,:), intent(in) :: ru_driving_tend, rt_driving_tend, rho_driving_tend real (kind=RKIND), dimension(:,:), pointer :: tend_ru, tend_rt, tend_rho, tend_rw @@ -5646,7 +5757,7 @@ subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, confi call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) - do iCell = cellStart, cellEnd + do iCell = cellSolveStart, cellSolveEnd if(bdyMaskCell(iCell) > nRelaxZone) then do k=1, nVertLevels tend_rho(k,iCell) = rho_driving_tend(k,iCell) @@ -5656,7 +5767,7 @@ subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, confi end if end do - do iEdge = edgeStart, edgeEnd + do iEdge = edgeSolveStart, edgeSolveEnd if(bdyMaskEdge(iEdge) > nRelaxZone) then do k=1, nVertLevels tend_ru(k,iEdge) = ru_driving_tend(k,iCell) @@ -5666,7 +5777,198 @@ subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, confi end subroutine atm_bdy_adjust_dynamics_speczone_tend - !------------------------------------------------------------------------- +!------------------------------------------------------------------------- + + subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, config, nVertLevels, dt, & + ru_driving_values, rt_driving_values, rho_driving_values, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) + + implicit none + + ! this routine resets the dry dynamics variables at the end of an rk3 substep for the case + ! where the dry dynamics is split from the scalar transport (i.e. where the dry dynamics is + ! using a different, usually smaller, timestep. + ! + ! WCS 18 November 2014 + + type (mpas_pool_type), intent(in) :: state + type (mpas_pool_type), intent(inout) :: tend + type (mpas_pool_type), intent(in) :: diag + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: config + integer, intent(in) :: nVertLevels + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + + real (kind=RKIND), intent(in) :: dt + + real (kind=RKIND), dimension(:,:), intent(in) :: ru_driving_values, rt_driving_values, rho_driving_values + + real (kind=RKIND), dimension(:,:), pointer :: tend_ru, tend_rt, tend_rho, tend_rw, ru, rtheta_m, rho_zz + real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle + real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign, edgesOnVertex_sign + integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge, nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex + integer, pointer :: vertexDegree + + + real (kind=RKIND) :: edge_sign, laplacian_filter_coef, rayleigh_damping_coef, r_dc, r_dv, invArea + real (kind=RKIND), dimension(nVertLevels) :: divergence1, divergence2, vorticity1, vorticity2 + integer :: iCell, iEdge, i, k, cell1, cell2, iEdge_vort, iEdge_div + integer :: vertex1, vertex2, iVertex + + call mpas_pool_get_array(tend, 'u', tend_ru) + call mpas_pool_get_array(tend, 'rho_zz', tend_rho) + call mpas_pool_get_array(tend, 'theta_m', tend_rt) + call mpas_pool_get_array(tend, 'w', tend_rw) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) + + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(diag, 'rtheta_m', rtheta_m) + call mpas_pool_get_array(diag, 'rho_zz', rho_zz) + + call mpas_pool_get_dimension(mesh, 'vertexDegree', vertexDegree) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'invDcEdge', invDcEdge) + call mpas_pool_get_array(mesh, 'invDvEdge', invDvEdge) + call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) + call mpas_pool_get_array(mesh, 'invAreaTriangle', invAreaTriangle) + call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array(mesh, 'edgesOnVertex_sign', edgesOnVertex_sign) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array(mesh, 'nEdgesOnCell',nEdgesOnCell) + call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) + + + + laplacian_filter_coef = (real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(10.*dt) + rayleigh_damping_coef = laplacian_filter_coef/5.0 + + ! First, Rayleigh damping terms for ru, rtheta_m and rho_zz + + do iCell = cellSolveStart, cellSolveEnd + if( (bdyMaskCell(iCell) > 1) .and. (bdyMaskCell(iCell) <= nRelaxZone) ) then + rayleigh_damping_coef = (real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(50.*dt) + do k=1, nVertLevels + tend_rho(k,iCell) = tend_rho(k,iCell) - rayleigh_damping_coef * (rho_driving_values(k,iCell) - rho_zz(k,iCell)) + tend_rt(k,iCell) = tend_rt(k,iCell) - rayleigh_damping_coef * (rt_driving_values(k,iCell) - rtheta_m(k,iCell)) + end do + end if + end do + + do iEdge = edgeSolveStart, edgeSolveEnd + if( (bdyMaskEdge(iEdge) > 1) .and. (bdyMaskEdge(iEdge) <= nRelaxZone) ) then + rayleigh_damping_coef = (real(bdyMaskEdge(iEdge)) - 1.)/real(nRelaxZone)/(50.*dt) + do k=1, nVertLevels + tend_ru(k,iEdge) = tend_ru(k,iEdge) - rayleigh_damping_coef * (ru_driving_values(k,iCell) - ru(k,iCell)) + end do + end if + end do + + ! Second, the horizontal filter for rtheta_m and rho_zz + + do iCell = cellSolveStart, cellSolveEnd ! threaded over cells + + if ( (bdyMaskCell(iCell) > 1) .and. (bdyMaskCell(iCell) <= nRelaxZone) ) then ! relaxation zone + + laplacian_filter_coef = (real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(10.*dt) + ! + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + ! edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) * laplacian_filter_coef + ! this is a dimensionless laplacian, so we leave out the r_areaCell + edge_sign = edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) * laplacian_filter_coef + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) +!DIR$ IVDEP + do k=1,nVertLevels + tend_rt(k,iCell) = tend_rt(k,iCell) + edge_sign*( (rtheta_m(k,cell2)-rt_driving_values(k,cell2)) & + - (rtheta_m(k,cell1)-rt_driving_values(k,cell1)) ) + tend_rho(k,iCell) = tend_rho(k,iCell) + edge_sign*( (rho_zz(k,cell2)-rho_driving_values(k,cell2)) & + - (rho_zz(k,cell1)-rho_driving_values(k,cell1)) ) + end do + end do + + end if + + end do + + ! Third (and last), the horizontal filter for ru + + do iEdge = edgeSolveStart, edgeSolveEnd + + if ( (bdyMaskEdge(iEdge) > 1) .and. (bdyMaskEdge(iEdge) <= nRelaxZone) ) then ! relaxation zone + + laplacian_filter_coef = dcEdge(iEdge)**2 * (real(bdyMaskEdge(iEdge)) - 1.)/real(nRelaxZone)/(10.*dt) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + vertex1 = verticesOnEdge(1,iEdge) + vertex2 = verticesOnEdge(2,iEdge) + r_dc = invDcEdge(iEdge) + r_dv = min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) + + iCell = cell1 + invArea = invAreaCell(iCell) + divergence1(1:nVertLevels) = 0. + do i=1,nEdgesOnCell(iCell) + iEdge_div = edgesOnCell(i,iCell) + edge_sign = invArea * dvEdge(iEdge_div) * edgesOnCell_sign(i,iCell) + do k=1,nVertLevels + divergence1(k) = divergence1(k) + edge_sign * (ru(k,iEdge_div) - ru_driving_values(k,iEdge_div)) + end do + end do + + iCell = cell2 + invArea = invAreaCell(iCell) + divergence2(1:nVertLevels) = 0. + do i=1,nEdgesOnCell(iCell) + iEdge_div = edgesOnCell(i,iCell) + edge_sign = invArea * dvEdge(iEdge_div) * edgesOnCell_sign(i,iCell) + do k=1,nVertLevels + divergence2(k) = divergence2(k) + edge_sign * (ru(k,iEdge_div) - ru_driving_values(k,iEdge_div)) + end do + end do + + iVertex = vertex1 + vorticity1(1:nVertLevels) = 0. + iEdge_vort = edgesOnVertex(i,iVertex) + edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge_vort) * edgesOnVertex_sign(i,iVertex) + do i=1,vertexDegree + do k=1,nVertLevels + vorticity1(k) = vorticity1(k) + edge_sign * (ru(k,iEdge_vort) - ru_driving_values(k,iEdge_vort)) + end do + end do + + iVertex = vertex2 + vorticity2(1:nVertLevels) = 0. + iEdge_vort = edgesOnVertex(i,iVertex) + edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge_vort) * edgesOnVertex_sign(i,iVertex) + do i=1,vertexDegree + do k=1,nVertLevels + vorticity2(k) = vorticity2(k) + edge_sign * (ru(k,iEdge_vort) - ru_driving_values(k,iEdge_vort)) + end do + end do + + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! + do k=1,nVertLevels + tend_ru(k,iEdge) = tend_ru(k,iEdge) + laplacian_filter_coef * ( ( divergence2(k) - divergence1(k) ) * r_dc & + -( vorticity2(k) - vorticity1(k) ) * r_dv ) + end do + + end if ! end test for relaxation-zone edge + + end do ! end of loop over edges + + end subroutine atm_bdy_adjust_dynamics_relaxzone_tend + +!------------------------------------------------------------------------- subroutine atm_bdy_adjust_scalars( state, diag, mesh, config, scalars_driving, nVertLevels, dt, dt_rk, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & @@ -5731,8 +6033,6 @@ subroutine atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) - use mpas_atm_dimensions - implicit none real (kind=RKIND), dimension(:,:,:), intent(in) :: scalars_driving @@ -5746,7 +6046,7 @@ subroutine atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, real (kind=RKIND), dimension(:), intent(in) :: dvEdge, invDcEdge real (kind=RKIND), intent(in) :: dt, dt_rk - ! local varoiables + ! local variables real (kind=RKIND), dimension(1:num_scalars,1:nVertLevels, cellSolveStart:cellSolveEnd) :: scalars_tmp real (kind=RKIND) :: edge_sign, laplacian_filter_coef, rayleigh_damping_coef, filter_flux From 3bbdda97f76d9dec14aed09cbf04bca0c05a4256 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 11 Oct 2016 11:24:47 -0600 Subject: [PATCH 023/737] bug fixes for the previous regional mpas commits. --- .../dynamics/mpas_atm_time_integration.F | 61 +++++++++++-------- 1 file changed, 34 insertions(+), 27 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index a4f2472c6b..65a6de6ac0 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -592,8 +592,10 @@ subroutine atm_srk3(domain, dt, itimestep) if (regional_mpas) then ! adjust boundary tendencies for regional_MPAS dry dynamics in the specified zone + write(0,*) ' begin spec zone tendencies for dynamics ' block => domain % blocklist do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', state) call mpas_pool_get_subpool(block % structs, 'diag', diag) call mpas_pool_get_subpool(block % structs, 'mesh', mesh) @@ -607,9 +609,11 @@ subroutine atm_srk3(domain, dt, itimestep) allocate(ru_driving_tend(nVertLevels,nEdges+1)) allocate(rt_driving_tend(nVertLevels,nCells+1)) allocate(rho_driving_tend(nVertLevels,nCells+1)) + write(0,*) ' getting tendencies ' ru_driving_tend(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_tend( clock, domain % blocklist, nVertLevels, nEdges, 'ru', 0.0_RKIND ) rt_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_tend( clock, domain % blocklist, nVertLevels, nCells, 'rtheta_m', 0.0_RKIND ) rho_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_tend( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', 0.0_RKIND ) + write(0,*) ' tendencies retrieved ' !$OMP PARALLEL DO do thread=1,block % nThreads @@ -627,6 +631,7 @@ subroutine atm_srk3(domain, dt, itimestep) deallocate(rho_driving_tend) block => block % next end do + write(0,*) ' end spec zone tendencies for dynamics ' ! -------- next, add in the tendencies for the horizontal filters and Rayleigh damping. We will keep the spec zone and relax zone adjustments separate for now... @@ -789,6 +794,7 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_subpool(block % structs, 'mesh', mesh) call mpas_pool_get_subpool(block % structs, 'diag', diag) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(state, 'nEdgesSolve', nEdgesSolve) call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) call mpas_pool_get_array(state, 'u', u, 2) call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) @@ -1156,6 +1162,7 @@ subroutine atm_srk3(domain, dt, itimestep) if (regional_mpas) then ! adjust boundary tendencies for regional_MPAS scalar transport + write(0,*) ' resetting spec zone and relax zone scalars ' call mpas_pool_get_field(state, 'scalars', scalars_field, 2) ! need to fill halo for horizontal filter call mpas_dmpar_exch_halo_field(scalars_field) @@ -1167,8 +1174,8 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_subpool(block % structs, 'mesh', mesh) call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(mesh, 'num_scalars', num_scalars) call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) @@ -1179,9 +1186,11 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_dimension(state, 'index_qr', index_qr) call mpas_pool_get_dimension(state, 'index_qi', index_qi) call mpas_pool_get_dimension(state, 'index_qs', index_qs) - call mpas_pool_get_dimension(state, 'index_qy', index_qg) + call mpas_pool_get_dimension(state, 'index_qg', index_qg) call mpas_pool_get_dimension(state, 'index_nr', index_nr) call mpas_pool_get_dimension(state, 'index_ni', index_ni) + + write(0,*) ' getting driving values, ignore error messages ' scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qv', rk_timestep(rk_step) ) scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qc', rk_timestep(rk_step) ) scalars_driving(index_qr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qr', rk_timestep(rk_step) ) @@ -1190,6 +1199,7 @@ subroutine atm_srk3(domain, dt, itimestep) scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qg', rk_timestep(rk_step) ) scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'nr', rk_timestep(rk_step) ) scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) + write(0,*) ' finished accessing driving values, end ignoring error messages ' !$OMP PARALLEL DO do thread=1,block % nThreads @@ -1204,6 +1214,8 @@ subroutine atm_srk3(domain, dt, itimestep) !$OMP END PARALLEL DO deallocate(scalars_driving) + + write(0,*) ' finished resetting scalar values ' block => block % next end do @@ -1953,7 +1965,7 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, real (kind=RKIND), dimension(:,:), pointer :: pzp, pzm integer, dimension(:), pointer :: nEdgesOnCell - real (kind=RKIND), dimension(:), pointer :: specifiedZoneMaskCell, specifiedZoneMaskEdge + real (kind=RKIND), dimension(:), pointer :: specZoneMaskCell, specZoneMaskEdge integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign @@ -1967,8 +1979,8 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) - call mpas_pool_get_array(mesh, 'specifiedZoneMaskEdge', specifiedZoneMaskEdge) - call mpas_pool_get_array(mesh, 'specifiedZoneMaskCell', specifiedZoneMaskCell) + call mpas_pool_get_array(mesh, 'specZoneMaskEdge', specZoneMaskEdge) + call mpas_pool_get_array(mesh, 'specZoneMaskCell', specZoneMaskCell) call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) ! call mpas_pool_get_array(state, 'theta_m', theta_m, 2) @@ -2043,7 +2055,7 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, divergence_3d, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, pzp, pzm, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & dts, small_step, epssm, smdiv, smdiv_p_forward, cf1, cf2, cf3, & - specifiedZoneMaskEdge, specifiedZoneMaskCell & + specZoneMaskEdge, specZoneMaskCell & ) end subroutine atm_advance_acoustic_step @@ -2056,7 +2068,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, divergence_3d, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, pzp, pzm, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & dts, small_step, epssm, smdiv, smdiv_p_forward, cf1, cf2, cf3, & - specifiedZoneMaskEdge, specifiedZoneMaskCell & + specZoneMaskEdge, specZoneMaskCell & ) use mpas_atm_dimensions @@ -2124,8 +2136,8 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart integer, dimension(maxEdges,nCells+1) :: edgesOnCell real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign - real (kind=RKIND), dimension(nCells+1) :: specifiedZoneMaskCell - real (kind=RKIND), dimension(nEdges+1) :: specifiedZoneMaskEdge + real (kind=RKIND), dimension(nCells+1) :: specZoneMaskCell + real (kind=RKIND), dimension(nEdges+1) :: specZoneMaskEdge integer, intent(in) :: small_step @@ -2185,7 +2197,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !!! ru_p(k,iEdge) = ru_p(k,iEdge) + dts*(tend_ru(k,iEdge) - pgrad) & !!! - smdiv*dcEdge(iEdge)*(divergence_3d(k,cell2)-divergence_3d(k,cell1)) ru_p(k,iEdge) = ru_p(k,iEdge) + dts*tend_ru(k,iEdge) & - - specifiedZoneMaskEdge(iEdge)*( dts*pgrad + smdiv*dcEdge(iEdge)*(divergence_3d(k,cell2)-divergence_3d(k,cell1)) ) + - specZoneMaskEdge(iEdge)*( dts*pgrad + smdiv*dcEdge(iEdge)*(divergence_3d(k,cell2)-divergence_3d(k,cell1)) ) end do ! accumulate ru_p for use later in scalar transport @@ -2211,7 +2223,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP do k=1,nVertLevels !!! ru_p(k,iEdge) = dts*tend_ru(k,iEdge) - smdiv*dcEdge(iEdge)*(tend_rho(k,cell2)-tend_rho(k,cell1)) - ru_p(k,iEdge) = dts*tend_ru(k,iEdge) - specifiedZoneMaskEdge(iEdge)*smdiv*dcEdge(iEdge)*(tend_rho(k,cell2)-tend_rho(k,cell1)) + ru_p(k,iEdge) = dts*tend_ru(k,iEdge) - specZoneMaskEdge(iEdge)*smdiv*dcEdge(iEdge)*(tend_rho(k,cell2)-tend_rho(k,cell1)) end do !DIR$ IVDEP do k=1,nVertLevels @@ -2229,7 +2241,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart do iCell=cellSolveStart,cellSolveEnd ! loop over all owned cells to solve - if(specifiedZoneMaskCell(iCell) == 0.0) then ! not specified zone, compute... + if(specZoneMaskCell(iCell) == 0.0) then ! not specified zone, compute... ts(:,iCell) = 0.0 rs(:,iCell) = 0.0 @@ -5805,7 +5817,7 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf real (kind=RKIND), dimension(:,:), intent(in) :: ru_driving_values, rt_driving_values, rho_driving_values - real (kind=RKIND), dimension(:,:), pointer :: tend_ru, tend_rt, tend_rho, tend_rw, ru, rtheta_m, rho_zz + real (kind=RKIND), dimension(:,:), pointer :: tend_ru, tend_rt, tend_rho, tend_rw, ru, theta_m, rho_zz real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign, edgesOnVertex_sign integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge, nEdgesOnCell @@ -5826,8 +5838,8 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) call mpas_pool_get_array(diag, 'ru', ru) - call mpas_pool_get_array(diag, 'rtheta_m', rtheta_m) - call mpas_pool_get_array(diag, 'rho_zz', rho_zz) + call mpas_pool_get_array(state, 'theta_m', theta_m, 2) + call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) call mpas_pool_get_dimension(mesh, 'vertexDegree', vertexDegree) call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) @@ -5844,11 +5856,6 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf call mpas_pool_get_array(mesh, 'nEdgesOnCell',nEdgesOnCell) call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) - - - laplacian_filter_coef = (real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(10.*dt) - rayleigh_damping_coef = laplacian_filter_coef/5.0 - ! First, Rayleigh damping terms for ru, rtheta_m and rho_zz do iCell = cellSolveStart, cellSolveEnd @@ -5856,7 +5863,7 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf rayleigh_damping_coef = (real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(50.*dt) do k=1, nVertLevels tend_rho(k,iCell) = tend_rho(k,iCell) - rayleigh_damping_coef * (rho_driving_values(k,iCell) - rho_zz(k,iCell)) - tend_rt(k,iCell) = tend_rt(k,iCell) - rayleigh_damping_coef * (rt_driving_values(k,iCell) - rtheta_m(k,iCell)) + tend_rt(k,iCell) = tend_rt(k,iCell) - rayleigh_damping_coef * (rt_driving_values(k,iCell) - rho_zz(k,iCell)*theta_m(k,iCell)) end do end if end do @@ -5887,8 +5894,8 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf cell2 = cellsOnEdge(2,iEdge) !DIR$ IVDEP do k=1,nVertLevels - tend_rt(k,iCell) = tend_rt(k,iCell) + edge_sign*( (rtheta_m(k,cell2)-rt_driving_values(k,cell2)) & - - (rtheta_m(k,cell1)-rt_driving_values(k,cell1)) ) + tend_rt(k,iCell) = tend_rt(k,iCell) + edge_sign*( (rho_zz(k,cell2)*theta_m(k,cell2)-rt_driving_values(k,cell2)) & + - (rho_zz(k,cell1)*theta_m(k,cell1)-rt_driving_values(k,cell1)) ) tend_rho(k,iCell) = tend_rho(k,iCell) + edge_sign*( (rho_zz(k,cell2)-rho_driving_values(k,cell2)) & - (rho_zz(k,cell1)-rho_driving_values(k,cell1)) ) end do @@ -5937,9 +5944,9 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf iVertex = vertex1 vorticity1(1:nVertLevels) = 0. - iEdge_vort = edgesOnVertex(i,iVertex) - edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge_vort) * edgesOnVertex_sign(i,iVertex) do i=1,vertexDegree + iEdge_vort = edgesOnVertex(i,iVertex) + edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge_vort) * edgesOnVertex_sign(i,iVertex) do k=1,nVertLevels vorticity1(k) = vorticity1(k) + edge_sign * (ru(k,iEdge_vort) - ru_driving_values(k,iEdge_vort)) end do @@ -5947,9 +5954,9 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf iVertex = vertex2 vorticity2(1:nVertLevels) = 0. - iEdge_vort = edgesOnVertex(i,iVertex) - edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge_vort) * edgesOnVertex_sign(i,iVertex) do i=1,vertexDegree + iEdge_vort = edgesOnVertex(i,iVertex) + edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge_vort) * edgesOnVertex_sign(i,iVertex) do k=1,nVertLevels vorticity2(k) = vorticity2(k) + edge_sign * (ru(k,iEdge_vort) - ru_driving_values(k,iEdge_vort)) end do From 7385f7bd50ac43bff1b0806d0a72b18ab4c5ee0e Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Thu, 13 Oct 2016 15:00:41 -0600 Subject: [PATCH 024/737] debug print statements. communication of w after zer-gradient boundary condition call - this change needs to stay. --- .../dynamics/mpas_atm_time_integration.F | 51 ++++++++++++++++++- 1 file changed, 49 insertions(+), 2 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index a642818a78..a8de397cd2 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -445,6 +445,8 @@ subroutine atm_srk3(domain, dt, itimestep) RK3_DYNAMICS : do rk_step = 1, 3 ! Runge-Kutta loop + write(0,*) ' dynamics rk step ',rk_step + ! recompute vertically implicit coefficients if necessary if( (config_time_integration_order == 3) .and. (rk_step == 2)) then @@ -610,12 +612,14 @@ subroutine atm_srk3(domain, dt, itimestep) !$OMP PARALLEL DO do thread=1,block % nThreads + write(0,*) ' calling spec zone tend adjust ' call atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, block % configs, nVertLevels, & ru_driving_tend, rt_driving_tend, rho_driving_tend, & block % cellThreadStart(thread), block % cellThreadEnd(thread), & block % edgeThreadStart(thread), block % edgeThreadEnd(thread), & block % cellSolveThreadStart(thread), block % cellSolveThreadEnd(thread), & block % edgeSolveThreadStart(thread), block % edgeSolveThreadEnd(thread) ) + write(0,*) ' returned from spec zone tend adjust ' end do !$OMP END PARALLEL DO @@ -643,12 +647,16 @@ subroutine atm_srk3(domain, dt, itimestep) allocate(ru_driving_values(nVertLevels,nEdges+1)) allocate(rt_driving_values(nVertLevels,nCells+1)) allocate(rho_driving_values(nVertLevels,nCells+1)) + + write(0,*) ' getting bdy state values ' ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'ru', rk_timestep(rk_step) ) rt_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rtheta_m', rk_timestep(rk_step) ) rho_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', rk_timestep(rk_step) ) + write(0,*) ' have bdy state values ' !$OMP PARALLEL DO do thread=1,block % nThreads + write(0,*) ' calling relax zone tend adjust ' call atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, block % configs, nVertLevels, dt, & ru_driving_values, rt_driving_values, rho_driving_values, & block % cellThreadStart(thread), block % cellThreadEnd(thread), & @@ -657,6 +665,7 @@ subroutine atm_srk3(domain, dt, itimestep) block % cellSolveThreadStart(thread), block % cellSolveThreadEnd(thread), & block % vertexSolveThreadStart(thread), block % vertexSolveThreadEnd(thread), & block % edgeSolveThreadStart(thread), block % edgeSolveThreadEnd(thread) ) + write(0,*) ' returned from relax zone tend adjust ' end do !$OMP END PARALLEL DO @@ -665,6 +674,8 @@ subroutine atm_srk3(domain, dt, itimestep) deallocate(rho_driving_values) block => block % next end do + + write(0,*) ' end relax zone tendencies for dynamics ' end if ! regional_MPAS addition @@ -677,6 +688,8 @@ subroutine atm_srk3(domain, dt, itimestep) do small_step = 1, number_sub_steps(rk_step) + write(0,*) ' acoustic step ',small_step + call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) call mpas_pool_get_field(diag, 'rho_pp', rho_pp_field) call mpas_dmpar_exch_halo_field(rho_pp_field, (/ 1 /)) @@ -771,6 +784,7 @@ subroutine atm_srk3(domain, dt, itimestep) ! First, (re)set the value of u and ru in the specified zone at the outermost edge (we will reset all for now). ! atm_recover_large_step_variables will not have set outermost edge velocities correctly. + write(0,*) ' resetting u spec zone values after acoustic step ' block => domain % blocklist do while (associated(block)) @@ -809,6 +823,7 @@ subroutine atm_srk3(domain, dt, itimestep) block => block % next end do deallocate(ru_driving_values) + write(0,*) ' finished resetting u spec zone values after acoustic step ' end if ! regional_MPAS addition @@ -970,6 +985,7 @@ subroutine atm_srk3(domain, dt, itimestep) ! set the zero-gradient condition on w for regional_MPAS if ( regional_mpas ) then ! regional_MPAS addition + write(0,*) ' setting zero-gradient bc for w ' block => domain % blocklist do while (associated(block)) @@ -984,6 +1000,13 @@ subroutine atm_srk3(domain, dt, itimestep) block => block % next end do + + ! w halo values needs resetting after regional boundary update + call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) + call mpas_pool_get_field(state, 'w', w_field, 2) + call mpas_dmpar_exch_halo_field(w_field) + + write(0,*) ' finished setting zero-gradient bc for w ' end if ! end of regional_MPAS addition end do RK3_DYNAMICS @@ -1091,6 +1114,7 @@ subroutine atm_srk3(domain, dt, itimestep) !$OMP PARALLEL DO do thread=1,block % nThreads if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + write(0,*) ' calling advance_scalars ' call atm_advance_scalars( tend, state, diag, mesh, block % configs, num_scalars, nCells, nVertLevels, rk_timestep(rk_step), & block % cellThreadStart(thread), block % cellThreadEnd(thread), & block % vertexThreadStart(thread), block % vertexThreadEnd(thread), & @@ -1100,8 +1124,10 @@ subroutine atm_srk3(domain, dt, itimestep) block % edgeSolveThreadStart(thread), block % edgeSolveThreadEnd(thread), & horiz_flux_array, rk_step, config_time_integration_order, & advance_density=.true., scalar_tend=scalar_tend_array, rho_zz_int=rho_zz_int ) + write(0,*) ' returned from advance_scalars ' else + write(0,*) ' calling advance_scalars_mono ' block % domain = domain call atm_advance_scalars_mono( block, tend, state, diag, mesh, block % configs, nCells, nEdges, nVertLevels, rk_timestep(rk_step), & block % cellThreadStart(thread), block % cellThreadEnd(thread), & @@ -1113,6 +1139,7 @@ subroutine atm_srk3(domain, dt, itimestep) scalar_old_arr, scalar_new_arr, s_max_arr, s_min_arr, wdtn_arr, & scale_array, flux_array, flux_upwind_tmp_arr, flux_tmp_arr, & advance_density=.true., rho_zz_int=rho_zz_int) + write(0,*) ' returned from advance_scalars_mono ' end if end do !$OMP END PARALLEL DO @@ -1165,6 +1192,7 @@ subroutine atm_srk3(domain, dt, itimestep) ! get the scalar values driving the regional boundary conditions ! + write(0,*) ' num_scalars = ',num_scalars call mpas_pool_get_dimension(state, 'index_qv', index_qv) call mpas_pool_get_dimension(state, 'index_qc', index_qc) call mpas_pool_get_dimension(state, 'index_qr', index_qr) @@ -1173,6 +1201,7 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_dimension(state, 'index_qg', index_qg) call mpas_pool_get_dimension(state, 'index_nr', index_nr) call mpas_pool_get_dimension(state, 'index_ni', index_ni) + write(0,*) ' scalars indices, qv, qc, qr, qi, qs, qg, nr, ni ',index_qv,index_qc,index_qr,index_qi,index_qs,index_qg,index_nr,index_ni write(0,*) ' getting driving values, ignore error messages ' scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qv', rk_timestep(rk_step) ) @@ -1181,8 +1210,8 @@ subroutine atm_srk3(domain, dt, itimestep) scalars_driving(index_qi,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qi', rk_timestep(rk_step) ) scalars_driving(index_qs,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qs', rk_timestep(rk_step) ) scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qg', rk_timestep(rk_step) ) - scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'nr', rk_timestep(rk_step) ) - scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) + !! scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'nr', rk_timestep(rk_step) ) + !! scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) write(0,*) ' finished accessing driving values, end ignoring error messages ' !$OMP PARALLEL DO @@ -3546,6 +3575,8 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve ! Note, however, that we enforce positive-definiteness in this update. ! The transport will maintain this positive definite solution and optionally, shape preservation (monotonicity). + write(0,*) ' in mono, point 1 ' + do iCell=cellSolveStart,cellSolveEnd !DIR$ IVDEP do k = 1,nVertLevels @@ -3563,6 +3594,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve end do end do + write(0,*) ' in mono, point 2 ' !$OMP BARRIER !$OMP MASTER @@ -3572,6 +3604,9 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve !$OMP END MASTER !$OMP BARRIER + + write(0,*) ' in mono, point 3 ' + ! ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts from scalar_old ! @@ -3606,10 +3641,15 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve !$OMP BARRIER end if + write(0,*) ' in mono, point 4 ' + ! next, do one scalar at a time do iScalar = 1, num_scalars + write(0,*) ' scalar mono ',iScalar + + do iCell=cellStart,cellEnd !DIR$ IVDEP do k=1,nVertLevels @@ -3618,6 +3658,13 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve end do end do +! ***** TEMPORARY TEST ******* WCS 20161012 + do k=1,nVertLevels + scalar_old(k,nCells+1) = 0. + scalar_new(k,nCells+1) = 0. + end do + + !$OMP BARRIER #ifdef DEBUG_TRANSPORT From 1e01f8ba98cd6be7e06c804c6946b236e2c54ecc Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Wed, 8 Feb 2017 14:06:23 -0700 Subject: [PATCH 025/737] bug fixes for regional implmentation - indices for the horizontal momentum boundary zone calculations, and correcting the use of the boundary mask for the horizontal momentum update in the acoustic step --- .../dynamics/mpas_atm_time_integration.F | 34 +++++++++++-------- 1 file changed, 19 insertions(+), 15 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 51be44b344..4f04cb5297 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -726,7 +726,6 @@ subroutine atm_srk3(domain, dt, itimestep) rt_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_tend( clock, domain % blocklist, nVertLevels, nCells, 'rtheta_m', 0.0_RKIND ) rho_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_tend( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', 0.0_RKIND ) write(0,*) ' tendencies retrieved ' - !$OMP PARALLEL DO do thread=1,nThreads write(0,*) ' calling spec zone tend adjust ' @@ -2410,7 +2409,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !!! ru_p(k,iEdge) = ru_p(k,iEdge) + dts*(tend_ru(k,iEdge) - pgrad) & !!! - smdiv*dcEdge(iEdge)*(divergence_3d(k,cell2)-divergence_3d(k,cell1)) ru_p(k,iEdge) = ru_p(k,iEdge) + dts*tend_ru(k,iEdge) & - - specZoneMaskEdge(iEdge)*( dts*pgrad + smdiv*dcEdge(iEdge)*(divergence_3d(k,cell2)-divergence_3d(k,cell1)) ) + - (1.0_RKIND - specZoneMaskEdge(iEdge))*( dts*pgrad + smdiv*dcEdge(iEdge)*(divergence_3d(k,cell2)-divergence_3d(k,cell1)) ) end do ! accumulate ru_p for use later in scalar transport @@ -2436,7 +2435,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP do k=1,nVertLevels !!! ru_p(k,iEdge) = dts*tend_ru(k,iEdge) - smdiv*dcEdge(iEdge)*(tend_rho(k,cell2)-tend_rho(k,cell1)) - ru_p(k,iEdge) = dts*tend_ru(k,iEdge) - specZoneMaskEdge(iEdge)*smdiv*dcEdge(iEdge)*(tend_rho(k,cell2)-tend_rho(k,cell1)) + ru_p(k,iEdge) = dts*tend_ru(k,iEdge) - (1.0_RKIND - specZoneMaskEdge(iEdge))*smdiv*dcEdge(iEdge)*(tend_rho(k,cell2)-tend_rho(k,cell1)) end do !DIR$ IVDEP do k=1,nVertLevels @@ -2462,17 +2461,10 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart do iCell=cellSolveStart,cellSolveEnd ! loop over all owned cells to solve - if(specZoneMaskCell(iCell) == 0.0) then ! not specified zone, compute... - - ts(:) = 0.0 - rs(:) = 0.0 - if(small_step == 1) then ! initialize here on first small timestep. wwAvg(1:nVertLevels+1,iCell) = 0.0 rho_pp(1:nVertLevels,iCell) = 0.0 rtheta_pp(1:nVertLevels,iCell) = 0.0 -!MGD moved to loop above over all cells -! rtheta_pp_old(1:nVertLevels,iCell) = 0.0 rw_p(:,iCell) = 0.0 divergence_3d(1:nVertLevels,iCell) = 0. else ! reset rtheta_pp to input value; @@ -2482,6 +2474,11 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart divergence_3d(1:nVertLevels,iCell) = rho_pp(1:nVertLevels,iCell) end if + if(specZoneMaskCell(iCell) == 0.0) then ! not specified zone, compute... + + ts(:) = 0.0 + rs(:) = 0.0 + do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) cell1 = cellsOnEdge(1,iEdge) @@ -2572,6 +2569,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart rw_p(k,iCell) = rw_p(k,iCell) + dts*tend_rw(k,iCell) wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) end do + end if end do ! end of loop over cells @@ -6154,7 +6152,7 @@ subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, confi ! where the dry dynamics is split from the scalar transport (i.e. where the dry dynamics is ! using a different, usually smaller, timestep. ! - ! WCS 18 November 2014 + ! WCS Fall 2016 type (mpas_pool_type), intent(in) :: state type (mpas_pool_type), intent(inout) :: tend @@ -6166,7 +6164,7 @@ subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, confi integer, intent(in) :: cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd real (kind=RKIND), dimension(:,:), intent(in) :: ru_driving_tend, rt_driving_tend, rho_driving_tend - real (kind=RKIND), dimension(:,:), pointer :: tend_ru, tend_rt, tend_rho, tend_rw + real (kind=RKIND), dimension(:,:), pointer :: tend_ru, tend_rt, tend_rho, tend_rw, rt_diabatic_tend integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge integer :: iCell, iEdge, k @@ -6177,6 +6175,7 @@ subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, confi call mpas_pool_get_array(tend, 'w', tend_rw) call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) + call mpas_pool_get_array(tend, 'rt_diabatic_tend', rt_diabatic_tend) do iCell = cellSolveStart, cellSolveEnd if(bdyMaskCell(iCell) > nRelaxZone) then @@ -6184,6 +6183,7 @@ subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, confi tend_rho(k,iCell) = rho_driving_tend(k,iCell) tend_rt(k,iCell) = rt_driving_tend(k,iCell) tend_rw(k,iCell) = 0. + rt_diabatic_tend(k,iCell) = 0. end do end if end do @@ -6191,7 +6191,9 @@ subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, confi do iEdge = edgeSolveStart, edgeSolveEnd if(bdyMaskEdge(iEdge) > nRelaxZone) then do k=1, nVertLevels - tend_ru(k,iEdge) = ru_driving_tend(k,iCell) +! wcs error_1 +! tend_ru(k,iEdge) = ru_driving_tend(k,iCell) + tend_ru(k,iEdge) = ru_driving_tend(k,iEdge) end do end if end do @@ -6211,7 +6213,7 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf ! where the dry dynamics is split from the scalar transport (i.e. where the dry dynamics is ! using a different, usually smaller, timestep. ! - ! WCS 18 November 2014 + ! WCS Fall 2016 type (mpas_pool_type), intent(in) :: state type (mpas_pool_type), intent(inout) :: tend @@ -6281,7 +6283,9 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf if( (bdyMaskEdge(iEdge) > 1) .and. (bdyMaskEdge(iEdge) <= nRelaxZone) ) then rayleigh_damping_coef = (real(bdyMaskEdge(iEdge)) - 1.)/real(nRelaxZone)/(50.*dt) do k=1, nVertLevels - tend_ru(k,iEdge) = tend_ru(k,iEdge) - rayleigh_damping_coef * (ru_driving_values(k,iCell) - ru(k,iCell)) +! wcs error_1 +! tend_ru(k,iEdge) = tend_ru(k,iEdge) - rayleigh_damping_coef * (ru_driving_values(k,iCell) - ru(k,iCell)) + tend_ru(k,iEdge) = tend_ru(k,iEdge) - rayleigh_damping_coef * (ru_driving_values(k,iEdge) - ru(k,iEdge)) end do end if end do From b8e4faf44acc9403c490ec3a3859f32e7764c2f6 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Fri, 24 Feb 2017 14:57:28 -0700 Subject: [PATCH 026/737] this commit contains bug fixes for the regional mpas code. a number of these fixes are related to incorrect array indices in the computations. new is the addition of code to reset the values for theta and the scalars in the specified zone after the call to microphysics (microphysics works in all columns, hence the need for a reset). --- .../dynamics/mpas_atm_time_integration.F | 535 ++++++++++++++++-- 1 file changed, 483 insertions(+), 52 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 4f04cb5297..54f6ef9a27 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -220,7 +220,8 @@ subroutine atm_srk3(domain, dt, itimestep) real (kind=RKIND), dimension(:,:), pointer :: rqvdynten - logical, parameter :: regional_mpas = .true. + logical, parameter :: regional_mpas = .true., debug_regional =.false. + real (kind=RKIND) :: time_dyn_step logical, parameter :: debug = .false. @@ -617,30 +618,6 @@ subroutine atm_srk3(domain, dt, itimestep) end do call mpas_timer_stop('atm_compute_dyn_tend') -#ifdef DO_PHYSICS -! call mpas_timer_start('physics_addtend') -! block => domain % blocklist -! do while (associated(block)) -! call mpas_pool_get_subpool(block % structs, 'mesh', mesh) -! call mpas_pool_get_subpool(block % structs, 'state', state) -! call mpas_pool_get_subpool(block % structs, 'diag', diag) -! call mpas_pool_get_subpool(block % structs, 'tend', tend) -! call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) -! call physics_addtend( block, & -! mesh, & -! state, & -! diag, & -! tend, & -! tend_physics, & -! block % configs, & -! rk_step, & -! dynamics_substep ) -! block => block % next -! end do -! call mpas_timer_stop('physics_addtend') -#endif - - !*********************************** ! need tendencies at all edges of owned cells - ! we are solving for all edges of owned cells to minimize communications @@ -693,7 +670,7 @@ subroutine atm_srk3(domain, dt, itimestep) if (regional_mpas) then ! adjust boundary tendencies for regional_MPAS dry dynamics in the specified zone - write(0,*) ' begin spec zone tendencies for dynamics ' + if(debug_regional) write(0,*) ' begin spec zone tendencies for dynamics ' block => domain % blocklist do while (associated(block)) @@ -721,21 +698,21 @@ subroutine atm_srk3(domain, dt, itimestep) allocate(ru_driving_tend(nVertLevels,nEdges+1)) allocate(rt_driving_tend(nVertLevels,nCells+1)) allocate(rho_driving_tend(nVertLevels,nCells+1)) - write(0,*) ' getting tendencies ' + if(debug_regional) write(0,*) ' getting tendencies ' ru_driving_tend(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_tend( clock, domain % blocklist, nVertLevels, nEdges, 'ru', 0.0_RKIND ) rt_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_tend( clock, domain % blocklist, nVertLevels, nCells, 'rtheta_m', 0.0_RKIND ) rho_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_tend( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', 0.0_RKIND ) - write(0,*) ' tendencies retrieved ' + if(debug_regional) write(0,*) ' tendencies retrieved ' !$OMP PARALLEL DO do thread=1,nThreads - write(0,*) ' calling spec zone tend adjust ' + if(debug_regional) write(0,*) ' calling spec zone tend adjust ' call atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, block % configs, nVertLevels, & ru_driving_tend, rt_driving_tend, rho_driving_tend, & cellThreadStart(thread), cellThreadEnd(thread), & edgeThreadStart(thread), edgeThreadEnd(thread), & cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) - write(0,*) ' returned from spec zone tend adjust ' + if(debug_regional) write(0,*) ' returned from spec zone tend adjust ' end do !$OMP END PARALLEL DO @@ -744,7 +721,7 @@ subroutine atm_srk3(domain, dt, itimestep) deallocate(rho_driving_tend) block => block % next end do - write(0,*) ' end spec zone tendencies for dynamics ' + if(debug_regional) write(0,*) ' end spec zone tendencies for dynamics ' ! -------- next, add in the tendencies for the horizontal filters and Rayleigh damping. We will keep the spec zone and relax zone adjustments separate for now... @@ -780,15 +757,16 @@ subroutine atm_srk3(domain, dt, itimestep) allocate(rt_driving_values(nVertLevels,nCells+1)) allocate(rho_driving_values(nVertLevels,nCells+1)) - write(0,*) ' getting bdy state values ' - ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'ru', rk_timestep(rk_step) ) - rt_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rtheta_m', rk_timestep(rk_step) ) - rho_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', rk_timestep(rk_step) ) - write(0,*) ' have bdy state values ' + time_dyn_step = dt_dynamics*real(dynamics_substep-1) + rk_timestep(rk_step) + if(debug_regional) write(0,*) ' getting bdy state values ' + ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'ru', time_dyn_step ) + rt_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rtheta_m', time_dyn_step ) + rho_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', time_dyn_step ) + if(debug_regional) write(0,*) ' have bdy state values ' !$OMP PARALLEL DO do thread=1,nThreads - write(0,*) ' calling relax zone tend adjust ' + if(debug_regional) write(0,*) ' calling relax zone tend adjust ' call atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, block % configs, nVertLevels, dt, & ru_driving_values, rt_driving_values, rho_driving_values, & cellThreadStart(thread), cellThreadEnd(thread), & @@ -797,18 +775,43 @@ subroutine atm_srk3(domain, dt, itimestep) cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) - write(0,*) ' returned from relax zone tend adjust ' + if(debug_regional) write(0,*) ' returned from relax zone tend adjust ' + end do +!$OMP END PARALLEL DO + + if(rk_step == 1 .and. debug_regional) then + + time_dyn_step = dt_dynamics*real(dynamics_substep-1) ! checking existing values + if(debug_regional) write(0,*) ' getting bdy state values at current time for check' + ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'ru', time_dyn_step ) + rt_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rtheta_m', time_dyn_step ) + rho_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', time_dyn_step ) + if(debug_regional) write(0,*) ' have bdy state values ' + +!$OMP PARALLEL DO + do thread=1,nThreads + if(debug_regional) write(0,*) ' calling check for spec zone values, rk_step = ',rk_step + call atm_bdy_check_values ( tend, state, diag, mesh, block % configs, nVertLevels, dt, & + ru_driving_values, rt_driving_values, rho_driving_values, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) + if(debug_regional) write(0,*) ' returned from check ' end do !$OMP END PARALLEL DO + end if + deallocate(ru_driving_values) deallocate(rt_driving_values) deallocate(rho_driving_values) block => block % next end do - write(0,*) ' end relax zone tendencies for dynamics ' - + if(debug_regional) write(0,*) ' end relax zone tendencies for dynamics ' end if ! regional_MPAS addition @@ -950,7 +953,7 @@ subroutine atm_srk3(domain, dt, itimestep) ! First, (re)set the value of u and ru in the specified zone at the outermost edge (we will reset all for now). ! atm_recover_large_step_variables will not have set outermost edge velocities correctly. - write(0,*) ' resetting u spec zone values after acoustic step ' + if(debug_regional) write(0,*) ' resetting u spec zone values after acoustic step ' block => domain % blocklist do while (associated(block)) @@ -965,7 +968,9 @@ subroutine atm_srk3(domain, dt, itimestep) allocate(ru_driving_values(nVertLevels,nEdges+1)) - ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'u', rk_timestep(rk_step) ) + time_dyn_step = dt_dynamics*real(dynamics_substep-1) + rk_timestep(rk_step) + + ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'u', time_dyn_step ) ! do this inline at present - it is simple enough do iEdge = 1, nEdgesSolve if(bdyMaskEdge(iEdge) > nRelaxZone) then @@ -975,7 +980,7 @@ subroutine atm_srk3(domain, dt, itimestep) end if end do - ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'ru', rk_timestep(rk_step) ) + ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'ru', time_dyn_step ) call mpas_pool_get_array(diag, 'ru', u) ! do this inline at present - it is simple enough do iEdge = 1, nEdgesSolve @@ -989,7 +994,7 @@ subroutine atm_srk3(domain, dt, itimestep) block => block % next end do deallocate(ru_driving_values) - write(0,*) ' finished resetting u spec zone values after acoustic step ' + if(debug_regional) write(0,*) ' finished resetting u spec zone values after acoustic step ' end if ! regional_MPAS addition @@ -1189,7 +1194,7 @@ subroutine atm_srk3(domain, dt, itimestep) ! set the zero-gradient condition on w for regional_MPAS if ( regional_mpas ) then ! regional_MPAS addition - write(0,*) ' setting zero-gradient bc for w ' + if(debug_regional) write(0,*) ' setting zero-gradient bc for w ' block => domain % blocklist do while (associated(block)) @@ -1214,7 +1219,7 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_field(state, 'w', w_field, 2) call mpas_dmpar_exch_halo_field(w_field) - write(0,*) ' finished setting zero-gradient bc for w ' + if(debug_regional) write(0,*) ' finished setting zero-gradient bc for w ' end if ! end of regional_MPAS addition end do RK3_DYNAMICS @@ -1434,7 +1439,7 @@ subroutine atm_srk3(domain, dt, itimestep) if (regional_mpas) then ! adjust boundary tendencies for regional_MPAS scalar transport - write(0,*) ' resetting spec zone and relax zone scalars ' + if(debug_regional) write(0,*) ' resetting spec zone and relax zone scalars ' call mpas_pool_get_field(state, 'scalars', scalars_field, 2) ! need to fill halo for horizontal filter call mpas_dmpar_exch_halo_field(scalars_field) @@ -1453,7 +1458,7 @@ subroutine atm_srk3(domain, dt, itimestep) ! get the scalar values driving the regional boundary conditions ! - write(0,*) ' num_scalars = ',num_scalars + if(debug_regional) write(0,*) ' num_scalars = ',num_scalars call mpas_pool_get_dimension(state, 'index_qv', index_qv) call mpas_pool_get_dimension(state, 'index_qc', index_qc) call mpas_pool_get_dimension(state, 'index_qr', index_qr) @@ -1462,7 +1467,7 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_dimension(state, 'index_qg', index_qg) call mpas_pool_get_dimension(state, 'index_nr', index_nr) call mpas_pool_get_dimension(state, 'index_ni', index_ni) - write(0,*) ' scalars indices, qv, qc, qr, qi, qs, qg, nr, ni ',index_qv,index_qc,index_qr,index_qi,index_qs,index_qg,index_nr,index_ni + if(debug_regional) write(0,*) ' scalars indices, qv, qc, qr, qi, qs, qg, nr, ni ',index_qv,index_qc,index_qr,index_qi,index_qs,index_qg,index_nr,index_ni call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) @@ -1481,7 +1486,7 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - write(0,*) ' getting driving values, ignore error messages ' + if(debug_regional) write(0,*) ' getting driving values, ignore error messages ' scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qv', rk_timestep(rk_step) ) scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qc', rk_timestep(rk_step) ) scalars_driving(index_qr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qr', rk_timestep(rk_step) ) @@ -1490,7 +1495,7 @@ subroutine atm_srk3(domain, dt, itimestep) scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qg', rk_timestep(rk_step) ) !! scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'nr', rk_timestep(rk_step) ) !! scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) - write(0,*) ' finished accessing driving values, end ignoring error messages ' + if(debug_regional) write(0,*) ' finished accessing driving values, end ignoring error messages ' !$OMP PARALLEL DO do thread=1,nThreads @@ -1618,6 +1623,151 @@ subroutine atm_srk3(domain, dt, itimestep) ! #endif + if (regional_mpas) then ! reset boundary values of rtheta in the specified zone - microphysics has messed with them + + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'tend', tend) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) + + call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) + + call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) + + call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) + + allocate(rt_driving_values(nVertLevels,nCells+1)) + allocate(rho_driving_values(nVertLevels,nCells+1)) + time_dyn_step = dt ! end of full timestep values + + if(debug_regional) write(0,*) ' getting bdy state values at current time for final adjust after microphysics ' + rt_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rtheta_m', time_dyn_step ) + rho_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', time_dyn_step ) + if(debug_regional) write(0,*) ' have bdy state values ' + +!$OMP PARALLEL DO + do thread=1,nThreads + if(debug_regional) write(0,*) ' calling final rtheta_m reset ' + call atm_bdy_reset_speczone_values ( tend, state, diag, mesh, block % configs, nVertLevels, dt, & + rt_driving_values, rho_driving_values, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) + if(debug_regional) write(0,*) ' returned from final rtheta_m reset ' + end do +!$OMP END PARALLEL DO + + deallocate(rt_driving_values) + deallocate(rho_driving_values) + block => block % next + + end do + + if(debug_regional) write(0,*) ' end relax zone tendencies for dynamics ' + + end if ! regional_MPAS addition + + if (regional_mpas) then ! adjust boundary values for regional_MPAS scalar transport + + if(debug_regional) write(0,*) ' resetting spec zone and relax zone scalars ' + call mpas_pool_get_field(state, 'scalars', scalars_field, 2) ! need to fill halo for horizontal filter + call mpas_dmpar_exch_halo_field(scalars_field) + + block => domain % blocklist + do while (associated(block)) + + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) + + + ! get the scalar values driving the regional boundary conditions + ! + if(debug_regional) write(0,*) ' num_scalars = ',num_scalars + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_dimension(state, 'index_qc', index_qc) + call mpas_pool_get_dimension(state, 'index_qr', index_qr) + call mpas_pool_get_dimension(state, 'index_qi', index_qi) + call mpas_pool_get_dimension(state, 'index_qs', index_qs) + call mpas_pool_get_dimension(state, 'index_qg', index_qg) + call mpas_pool_get_dimension(state, 'index_nr', index_nr) + call mpas_pool_get_dimension(state, 'index_ni', index_ni) + if(debug_regional) write(0,*) ' scalars indices, qv, qc, qr, qi, qs, qg, nr, ni ',index_qv,index_qc,index_qr,index_qi,index_qs,index_qg,index_nr,index_ni + + call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) + + call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) + + call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) + + call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) + + if(debug_regional) write(0,*) ' getting driving values, ignore error messages ' + scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qv', dt ) + scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qc', dt ) + scalars_driving(index_qr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qr', dt ) + scalars_driving(index_qi,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qi', dt ) + scalars_driving(index_qs,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qs', dt ) + scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qg', dt ) + !! scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'nr', rk_timestep(rk_step) ) + !! scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) + if(debug_regional) write(0,*) ' finished accessing driving values, end ignoring error messages ' + +!$OMP PARALLEL DO + do thread=1,nThreads + call atm_bdy_set_scalars( state, diag, mesh, block % configs, scalars_driving, nVertLevels, dt, rk_timestep(rk_step), & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) + end do +!$OMP END PARALLEL DO + + deallocate(scalars_driving) + + write(0,*) ' finished resetting scalar values ' + + block => block % next + end do + + end if ! regional_MPAS addition + call summarize_timestep(domain) end subroutine atm_srk3 @@ -6390,6 +6540,183 @@ end subroutine atm_bdy_adjust_dynamics_relaxzone_tend !------------------------------------------------------------------------- + subroutine atm_bdy_check_values( tend, state, diag, mesh, config, nVertLevels, dt, & + ru_driving_values, rt_driving_values, rho_driving_values, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) + + implicit none + + ! this routine resets the dry dynamics variables at the end of an rk3 substep for the case + ! where the dry dynamics is split from the scalar transport (i.e. where the dry dynamics is + ! using a different, usually smaller, timestep. + ! + ! WCS Fall 2016 + + type (mpas_pool_type), intent(in) :: state + type (mpas_pool_type), intent(inout) :: tend + type (mpas_pool_type), intent(in) :: diag + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: config + integer, intent(in) :: nVertLevels + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + + real (kind=RKIND), intent(in) :: dt + + real (kind=RKIND), dimension(:,:), intent(in) :: ru_driving_values, rt_driving_values, rho_driving_values + + real (kind=RKIND), dimension(:,:), pointer :: tend_ru, tend_rt, tend_rho, tend_rw, ru, theta_m, rho_zz + real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle + real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign, edgesOnVertex_sign + integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge, nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex + integer, pointer :: vertexDegree + + + real (kind=RKIND) :: edge_sign, laplacian_filter_coef, rayleigh_damping_coef, r_dc, r_dv, invArea + real (kind=RKIND), dimension(nVertLevels) :: divergence1, divergence2, vorticity1, vorticity2 + integer :: iCell, iEdge, i, k, cell1, cell2, iEdge_vort, iEdge_div + integer :: vertex1, vertex2, iVertex + integer :: ncheck, nerr + real (kind=RKIND) :: epsilon, vdiff, errormax + + call mpas_pool_get_array(tend, 'u', tend_ru) + call mpas_pool_get_array(tend, 'rho_zz', tend_rho) + call mpas_pool_get_array(tend, 'theta_m', tend_rt) + call mpas_pool_get_array(tend, 'w', tend_rw) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) + + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(state, 'theta_m', theta_m, 2) + call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) + + call mpas_pool_get_dimension(mesh, 'vertexDegree', vertexDegree) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'invDcEdge', invDcEdge) + call mpas_pool_get_array(mesh, 'invDvEdge', invDvEdge) + call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) + call mpas_pool_get_array(mesh, 'invAreaTriangle', invAreaTriangle) + call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array(mesh, 'edgesOnVertex_sign', edgesOnVertex_sign) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array(mesh, 'nEdgesOnCell',nEdgesOnCell) + call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) + + ! First, check values + + ncheck = 0 + nerr = 0 + epsilon = 0.0001 + errormax = 0. + do iCell = cellSolveStart, cellSolveEnd + if( bdyMaskCell(iCell) > nRelaxZone) then + do k=1, 3 + ncheck = ncheck + 1 + vdiff = abs((rt_driving_values(k,iCell)-rho_zz(k,iCell)*theta_m(k,iCell))) + errormax = max(vdiff, errormax) + vdiff = abs((rt_driving_values(k,iCell)-rho_zz(k,iCell)*theta_m(k,iCell))/rt_driving_values(k,iCell)) + if(vdiff .gt. 1e-04) then + write(0,*) ' spec zone check, k, iCell, bdyzone, rt_drive, rt ',k,iCell,bdyMaskCell(iCell),rt_driving_values(k,iCell), rho_zz(k,iCell)*theta_m(k,iCell) + nerr = nerr + 1 + end if + !! write(0,*) ' spec zone check, k, iCell, bdyzone, rho_drive, rho_zz ',k,iCell,bdyMaskCell(iCell),rho_driving_values(k,iCell), rho_zz(k,iCell) + end do + end if + end do + + write(0,*) ' rtheta ncheck, nerr, max error = ',ncheck, nerr, errormax + + ncheck = 0 + nerr = 0 + errormax = 0. + do iCell = cellSolveStart, cellSolveEnd + if( bdyMaskCell(iCell) > nRelaxZone) then + do k=1, 3 + ncheck = ncheck + 1 + vdiff = abs(rho_driving_values(k,iCell)-rho_zz(k,iCell)) + errormax = max(vdiff, errormax) + vdiff = abs((rho_driving_values(k,iCell)-rho_zz(k,iCell))/rho_driving_values(k,iCell)) + if(vdiff .gt. 1e-04) then + write(0,*) ' spec zone check, k, iCell, bdyzone, rho_drive, rt ',k,iCell,bdyMaskCell(iCell),rho_driving_values(k,iCell), rho_zz(k,iCell) + nerr = nerr + 1 + end if + !! write(0,*) ' spec zone check, k, iCell, bdyzone, rho_drive, rho_zz ',k,iCell,bdyMaskCell(iCell),rho_driving_values(k,iCell), rho_zz(k,iCell) + end do + end if + end do + write(0,*) ' rho ncheck, nerr, max error = ',ncheck, nerr, errormax + +! do iEdge = edgeSolveStart, edgeSolveEnd +! if(bdyMaskEdge(iEdge) > nRelaxZone) then +! do k=1, 3 +! ncheck = ncheck + 1 +! vdiff = abs((ru_driving_values(k,iEdge)-ru(k,iEdge))/(abs(ru(k,iEdge))+epsilon)) +! errormax = max(vdiff, errormax) +! if(vdiff .gt. 1.e-04) then +! nerr = nerr + 1 +! write(0,*) ' spec zone check, k, iEdge, bdyzone, ru_drive, ru ',k,iEdge,bdyMaskEdge(iEdge),ru_driving_values(k,iEdge), ru(k,iEdge) +! end if +! end do +! end if +! end do + +! write(0,*) ' ru ncheck, nerr, max error = ',ncheck, nerr, errormax + + end subroutine atm_bdy_check_values + +!------------------------------------------------------------------------- + + subroutine atm_bdy_reset_speczone_values ( tend, state, diag, mesh, config, nVertLevels, dt, & + rt_driving_values, rho_driving_values, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) + + implicit none + + ! this routine resets theta_m and rtheta_m after the microphysics, i.e. at the very end of the timestep + ! + ! WCS 24 February 2017 + + type (mpas_pool_type), intent(in) :: state + type (mpas_pool_type), intent(inout) :: tend + type (mpas_pool_type), intent(in) :: diag + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: config + integer, intent(in) :: nVertLevels + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + + real (kind=RKIND), intent(in) :: dt + + real (kind=RKIND), dimension(:,:), intent(in) :: rt_driving_values, rho_driving_values + + real (kind=RKIND), dimension(:,:), pointer :: theta_m, rtheta_p, rtheta_base + integer, dimension(:), pointer :: bdyMaskCell + + integer :: iCell, k + + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(state, 'theta_m', theta_m, 2) + call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array(diag, 'rtheta_base', rtheta_base) + + do iCell = cellSolveStart, cellSolveEnd + if( bdyMaskCell(iCell) > nRelaxZone) then + do k=1, nVertLevels + theta_m(k,iCell) = rt_driving_values(k,iCell)/rho_driving_values(k,iCell) + rtheta_p(k,iCell) = rt_driving_values(k,iCell) - rtheta_base(k,iCell) + end do + end if + end do + + end subroutine atm_bdy_reset_speczone_values + +!------------------------------------------------------------------------- subroutine atm_bdy_adjust_scalars( state, diag, mesh, config, scalars_driving, nVertLevels, dt, dt_rk, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -6400,7 +6727,7 @@ subroutine atm_bdy_adjust_scalars( state, diag, mesh, config, scalars_driving, n ! where the dry dynamics is split from the scalar transport (i.e. where the dry dynamics is ! using a different, usually smaller, timestep. ! - ! WCS 18 November 2014 + ! WCS 24 February 2017 type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(in) :: diag @@ -6540,6 +6867,110 @@ subroutine atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, end subroutine atm_bdy_adjust_scalars_work +!------------------------------------------------------------------------- + subroutine atm_bdy_set_scalars( state, diag, mesh, config, scalars_driving, nVertLevels, dt, dt_rk, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + + implicit none + + ! this routine resets the dry dynamics variables at the end of an rk3 substep for the case + ! where the dry dynamics is split from the scalar transport (i.e. where the dry dynamics is + ! using a different, usually smaller, timestep. + ! + ! WCS 24 February 2017 + + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(in) :: diag + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: config + integer, intent(in) :: nVertLevels + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + + real (kind=RKIND), intent(in) :: dt, dt_rk + real (kind=RKIND), dimension(:,:,:), intent(in) :: scalars_driving + real (kind=RKIND), dimension(:,:,:), pointer :: scalars_new + real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign + + real (kind=RKIND), dimension(:), pointer :: invDcEdge, dvEdge + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: edgesOnCell, cellsOnEdge + integer, pointer :: nCells, nEdges, maxEdges, num_scalars + integer, dimension(:), pointer :: bdyMaskCell + + call mpas_pool_get_array(state, 'scalars', scalars_new, 2) + + call mpas_pool_get_array(mesh, 'invDcEdge', invDcEdge ) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge ) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'maxEdges', maxEdges) + + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + + call atm_bdy_set_scalars_work( scalars_new, scalars_driving, dt, dt_rk, & + nVertLevels, nCells, nEdges, num_scalars, & + nEdgesOnCell, edgesOnCell, EdgesOnCell_sign, cellsOnEdge, dvEdge, invDcEdge, bdyMaskCell, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) + + end subroutine atm_bdy_set_scalars + +!------------------------------------------------------------------------- + + subroutine atm_bdy_set_scalars_work( scalars_new, scalars_driving, dt, dt_rk, & + nVertLevels, nCells, nEdges, num_scalars, & + nEdgesOnCell, edgesOnCell, EdgesOnCell_sign, cellsOnEdge, dvEdge, invDcEdge, bdyMaskCell, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) + + implicit none + + real (kind=RKIND), dimension(:,:,:), intent(in) :: scalars_driving + real (kind=RKIND), dimension(:,:,:), intent(inout) :: scalars_new + real (kind=RKIND), dimension(:,:), intent(in) :: edgesOnCell_sign + integer, intent(in) :: nVertLevels, nCells, nEdges, num_scalars + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, dimension(:), intent(in) :: nEdgesOnCell, bdyMaskCell + integer, dimension(:,:), intent(in) :: edgesOnCell, cellsOnEdge + real (kind=RKIND), dimension(:), intent(in) :: dvEdge, invDcEdge + real (kind=RKIND), intent(in) :: dt, dt_rk + + ! local variables + + real (kind=RKIND), dimension(1:num_scalars,1:nVertLevels, cellSolveStart:cellSolveEnd) :: scalars_tmp + real (kind=RKIND) :: edge_sign, laplacian_filter_coef, rayleigh_damping_coef, filter_flux + integer :: iCell, iEdge, iScalar, i, k, cell1, cell2 + + !--- + + do iCell = cellSolveStart, cellSolveEnd ! threaded over cells + + if ( bdyMaskCell(iCell) > nRelaxZone) then ! specified zone + + ! update the specified-zone values + ! +!DIR$ IVDEP + do k=1,nVertLevels + do iScalar = 1, num_scalars + scalars_tmp(iScalar,k,iCell) = scalars_driving(iScalar,k,iCell) + end do + end do + + end if + + end do ! updates now in temp storage + + end subroutine atm_bdy_set_scalars_work + !------------------------------------------------------------------------- subroutine summarize_timestep(domain) From 8502d3df145419d0d57d3855c80b6098c85d6502 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Fri, 18 Aug 2017 14:21:46 -0600 Subject: [PATCH 027/737] added masking for the 3d divergence damping term in the horizontal momentum equation --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index ac3d9e5206..e3305d21ec 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -2736,6 +2736,7 @@ subroutine atm_divergence_damping_3d( state, diag, mesh, configs, dts, edgeStart real (kind=RKIND), dimension(:,:), pointer :: theta_m, ru_p, rtheta_pp, rtheta_pp_old ! real (kind=RKIND), dimension(:), pointer :: dcEdge real (kind=RKIND), pointer :: smdiv, config_len_disp + real (kind=RKIND), dimension(:), pointer :: specZoneMaskEdge integer, dimension(:,:), pointer :: cellsOnEdge integer, pointer :: nCellsSolve @@ -2745,6 +2746,7 @@ subroutine atm_divergence_damping_3d( state, diag, mesh, configs, dts, edgeStart integer :: cell1, cell2, iEdge, k call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'specZoneMaskEdge', specZoneMaskEdge) ! call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) call mpas_pool_get_array(state, 'theta_m', theta_m, 1) call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) @@ -2780,7 +2782,7 @@ subroutine atm_divergence_damping_3d( state, diag, mesh, configs, dts, edgeStart !! scaled 3d divergence damping divCell1 = -(rtheta_pp(k,cell1)-rtheta_pp_old(k,cell1)) divCell2 = -(rtheta_pp(k,cell2)-rtheta_pp_old(k,cell2)) - ru_p(k,iEdge) = ru_p(k,iEdge) + coef_divdamp*(divCell2-divCell1) & + ru_p(k,iEdge) = ru_p(k,iEdge) + coef_divdamp*(divCell2-divCell1)*(1.0_RKIND - specZoneMaskEdge(iEdge)) & /(theta_m(k,cell1)+theta_m(k,cell2)) end do From f077b7e259b8cddeda4915e64f8e6bdced6d8f05 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 18 Sep 2017 08:17:28 -0600 Subject: [PATCH 028/737] added arrays for scaling the relaxation zone operators in regional MPAS for variable-resolution meshes. we are keeping these scaling parameters distinct from the del2 and del4 operators in case we wish to scale them differently. --- src/core_atmosphere/Registry.xml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 634583f836..8da6ea7d69 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -535,6 +535,8 @@ + + @@ -1215,6 +1217,12 @@ + + + + From 8429ad110b249b7d70d21cedbcf0bff563d91d0b Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 18 Sep 2017 08:20:26 -0600 Subject: [PATCH 029/737] introduced initialization code for the mesh scaling needed for the relaxation-zone operators in regional MPAS. --- src/core_atmosphere/mpas_atm_core.F | 26 ++++++++++++++++++++++++-- 1 file changed, 24 insertions(+), 2 deletions(-) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index b0baac3f8a..d73506ed2d 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -273,6 +273,7 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) real (kind=RKIND), dimension(:,:), pointer :: u, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional real (kind=RKIND), dimension(:), pointer :: meshScalingDel2, meshScalingDel4 + real (kind=RKIND), dimension(:), pointer :: meshScalingRegionalCell, meshScalingRegionalEdge real (kind=RKIND), dimension(:), pointer :: areaCell, invAreaCell real (kind=RKIND), dimension(:), pointer :: dvEdge, invDvEdge real (kind=RKIND), dimension(:), pointer :: dcEdge, invDcEdge @@ -959,18 +960,22 @@ subroutine atm_compute_mesh_scaling(mesh, configs) type (mpas_pool_type), intent(inout) :: mesh type (mpas_pool_type), intent(in) :: configs - integer :: iEdge, cell1, cell2 - integer, pointer :: nEdges + integer :: iCell,iEdge, cell1, cell2 + integer, pointer :: nEdges, nCells integer, dimension(:,:), pointer :: cellsOnEdge real (kind=RKIND), dimension(:), pointer :: meshDensity, meshScalingDel2, meshScalingDel4 + real (kind=RKIND), dimension(:), pointer :: meshScalingRegionalCell, meshScalingRegionalEdge logical, pointer :: config_h_ScaleWithMesh call mpas_pool_get_array(mesh, 'meshDensity', meshDensity) call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) + call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingRegionalCell) + call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingRegionalEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_config(configs, 'config_h_ScaleWithMesh', config_h_ScaleWithMesh) @@ -988,6 +993,23 @@ subroutine atm_compute_mesh_scaling(mesh, configs) end do end if + ! + ! Compute the scaling factors to be used in relaxation zone of regional configuration + ! + meshScalingRegionalCell(:) = 1.0 + meshScalingRegionalEdge(:) = 1.0 + if (config_h_ScaleWithMesh) then + do iEdge=1,nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + meshScalingRegionalEdge(iEdge) = 1.0 / ( (meshDensity(cell1) + meshDensity(cell2) )/2.0)**0.25 + end do + + do iCell=1,nCells + meshScalingRegionalCell(iCell) = 1.0 / (meshDensity(iCell))**0.25 + end do + end if + end subroutine atm_compute_mesh_scaling From 6df796b7478c73da067eb790474472c87702a89d Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 18 Sep 2017 08:21:57 -0600 Subject: [PATCH 030/737] enabled mesh scaling of the relaxation-zone operators in regional MPAS --- .../dynamics/mpas_atm_time_integration.F | 23 +++++++++++++------ 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index e3305d21ec..ff9006a4de 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -6457,6 +6457,8 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf integer :: iCell, iEdge, i, k, cell1, cell2, iEdge_vort, iEdge_div integer :: vertex1, vertex2, iVertex + real (kind=RKIND), dimension(:), pointer :: meshScalingRegionalCell, meshScalingRegionalEdge + call mpas_pool_get_array(tend, 'u', tend_ru) call mpas_pool_get_array(tend, 'rho_zz', tend_rho) call mpas_pool_get_array(tend, 'theta_m', tend_rt) @@ -6464,6 +6466,9 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) + call mpas_pool_get_array(mesh, 'meshScalingRegionalCell', meshScalingRegionalCell) + call mpas_pool_get_array(mesh, 'meshScalingRegionalEdge', meshScalingRegionalEdge) + call mpas_pool_get_array(diag, 'ru', ru) call mpas_pool_get_array(state, 'theta_m', theta_m, 2) call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) @@ -6487,7 +6492,7 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf do iCell = cellSolveStart, cellSolveEnd if( (bdyMaskCell(iCell) > 1) .and. (bdyMaskCell(iCell) <= nRelaxZone) ) then - rayleigh_damping_coef = (real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(50.*dt) + rayleigh_damping_coef = (real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(50.*dt*meshScalingRegionalCell(iCell)) do k=1, nVertLevels tend_rho(k,iCell) = tend_rho(k,iCell) - rayleigh_damping_coef * (rho_driving_values(k,iCell) - rho_zz(k,iCell)) tend_rt(k,iCell) = tend_rt(k,iCell) - rayleigh_damping_coef * (rt_driving_values(k,iCell) - rho_zz(k,iCell)*theta_m(k,iCell)) @@ -6497,7 +6502,7 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf do iEdge = edgeSolveStart, edgeSolveEnd if( (bdyMaskEdge(iEdge) > 1) .and. (bdyMaskEdge(iEdge) <= nRelaxZone) ) then - rayleigh_damping_coef = (real(bdyMaskEdge(iEdge)) - 1.)/real(nRelaxZone)/(50.*dt) + rayleigh_damping_coef = (real(bdyMaskEdge(iEdge)) - 1.)/real(nRelaxZone)/(50.*dt*meshScalingRegionalEdge(iEdge)) do k=1, nVertLevels ! wcs error_1 ! tend_ru(k,iEdge) = tend_ru(k,iEdge) - rayleigh_damping_coef * (ru_driving_values(k,iCell) - ru(k,iCell)) @@ -6512,7 +6517,7 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf if ( (bdyMaskCell(iCell) > 1) .and. (bdyMaskCell(iCell) <= nRelaxZone) ) then ! relaxation zone - laplacian_filter_coef = (real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(10.*dt) + laplacian_filter_coef = (real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(10.*dt*meshScalingRegionalCell(iCell)) ! do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) @@ -6540,7 +6545,8 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf if ( (bdyMaskEdge(iEdge) > 1) .and. (bdyMaskEdge(iEdge) <= nRelaxZone) ) then ! relaxation zone - laplacian_filter_coef = dcEdge(iEdge)**2 * (real(bdyMaskEdge(iEdge)) - 1.)/real(nRelaxZone)/(10.*dt) + laplacian_filter_coef = dcEdge(iEdge)**2 * (real(bdyMaskEdge(iEdge)) - 1.)/ & + real(nRelaxZone)/(10.*dt*meshScalingRegionalEdge(iEdge)) cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -6808,7 +6814,7 @@ subroutine atm_bdy_adjust_scalars( state, diag, mesh, config, scalars_driving, n real (kind=RKIND), dimension(:,:,:), pointer :: scalars_new real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign - real (kind=RKIND), dimension(:), pointer :: invDcEdge, dvEdge + real (kind=RKIND), dimension(:), pointer :: invDcEdge, dvEdge, meshScalingRegionalCell integer, dimension(:), pointer :: nEdgesOnCell integer, dimension(:,:), pointer :: edgesOnCell, cellsOnEdge integer, pointer :: nCells, nEdges, maxEdges, num_scalars @@ -6822,6 +6828,7 @@ subroutine atm_bdy_adjust_scalars( state, diag, mesh, config, scalars_driving, n call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'meshScalingRegionalCell', meshScalingRegionalCell) call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) call mpas_pool_get_dimension(mesh, 'nCells', nCells) @@ -6833,6 +6840,7 @@ subroutine atm_bdy_adjust_scalars( state, diag, mesh, config, scalars_driving, n call atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, & nVertLevels, nCells, nEdges, num_scalars, & nEdgesOnCell, edgesOnCell, EdgesOnCell_sign, cellsOnEdge, dvEdge, invDcEdge, bdyMaskCell, & + meshScalingRegionalCell, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) @@ -6843,6 +6851,7 @@ end subroutine atm_bdy_adjust_scalars subroutine atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, & nVertLevels, nCells, nEdges, num_scalars, & nEdgesOnCell, edgesOnCell, EdgesOnCell_sign, cellsOnEdge, dvEdge, invDcEdge, bdyMaskCell, & + meshScalingRegionalCell, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) @@ -6856,7 +6865,7 @@ subroutine atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd integer, dimension(:), intent(in) :: nEdgesOnCell, bdyMaskCell integer, dimension(:,:), intent(in) :: edgesOnCell, cellsOnEdge - real (kind=RKIND), dimension(:), intent(in) :: dvEdge, invDcEdge + real (kind=RKIND), dimension(:), intent(in) :: dvEdge, invDcEdge, meshScalingRegionalCell real (kind=RKIND), intent(in) :: dt, dt_rk ! local variables @@ -6871,7 +6880,7 @@ subroutine atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, if ( (bdyMaskCell(iCell) > 1) .and. (bdyMaskCell(iCell) <= nRelaxZone) ) then ! relaxation zone - laplacian_filter_coef = dt_rk*(real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(10.*dt) + laplacian_filter_coef = dt_rk*(real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(10.*dt*meshScalingRegionalCell(iCell)) rayleigh_damping_coef = laplacian_filter_coef/5.0 scalars_tmp(1:num_scalars,1:nVertLevels,iCell) = scalars_new(1:num_scalars,1:nVertLevels,iCell) From 277003c293012453090b1d3d9df0a20d8f00bc4d Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 18 Sep 2017 19:39:04 -0600 Subject: [PATCH 031/737] fixed strings in calls to get pointers to the mesh scaling parameters for the regional relaxation zone --- src/core_atmosphere/mpas_atm_core.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index d73506ed2d..700f7957e5 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -970,8 +970,8 @@ subroutine atm_compute_mesh_scaling(mesh, configs) call mpas_pool_get_array(mesh, 'meshDensity', meshDensity) call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) - call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingRegionalCell) - call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingRegionalEdge) + call mpas_pool_get_array(mesh, 'meshScalingRegionalCell', meshScalingRegionalCell) + call mpas_pool_get_array(mesh, 'meshScalingRegionalEdge', meshScalingRegionalEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) From f62d5050f7fea7ae243087cc6bf990bddf1bd712 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 28 Sep 2017 23:15:27 -0600 Subject: [PATCH 032/737] Clean up atm_bdy_set_scalars( ) This commit removes unused variables and subroutine arguments of the atm_bdy_set_scalars routine. --- .../dynamics/mpas_atm_time_integration.F | 81 ++++++------------- 1 file changed, 24 insertions(+), 57 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index ff9006a4de..ecdbfeca23 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1717,7 +1717,6 @@ subroutine atm_srk3(domain, dt, itimestep) do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) call mpas_pool_get_subpool(block % structs, 'mesh', mesh) call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) @@ -1751,11 +1750,6 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - if(debug_regional) write(0,*) ' getting driving values, ignore error messages ' scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qv', dt ) scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qc', dt ) @@ -1769,13 +1763,9 @@ subroutine atm_srk3(domain, dt, itimestep) !$OMP PARALLEL DO do thread=1,nThreads - call atm_bdy_set_scalars( state, diag, mesh, block % configs, scalars_driving, nVertLevels, dt, rk_timestep(rk_step), & + call atm_bdy_set_scalars( state, mesh, scalars_driving, nVertLevels, & cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) + cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) end do !$OMP END PARALLEL DO @@ -6943,9 +6933,9 @@ subroutine atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, end subroutine atm_bdy_adjust_scalars_work !------------------------------------------------------------------------- - subroutine atm_bdy_set_scalars( state, diag, mesh, config, scalars_driving, nVertLevels, dt, dt_rk, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + subroutine atm_bdy_set_scalars( state, mesh, scalars_driving, nVertLevels, & + cellStart, cellEnd, & + cellSolveStart, cellSolveEnd ) implicit none @@ -6956,74 +6946,51 @@ subroutine atm_bdy_set_scalars( state, diag, mesh, config, scalars_driving, nVer ! WCS 24 February 2017 type (mpas_pool_type), intent(inout) :: state - type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh - type (mpas_pool_type), intent(in) :: config integer, intent(in) :: nVertLevels - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd - real (kind=RKIND), intent(in) :: dt, dt_rk real (kind=RKIND), dimension(:,:,:), intent(in) :: scalars_driving - real (kind=RKIND), dimension(:,:,:), pointer :: scalars_new - real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign - real (kind=RKIND), dimension(:), pointer :: invDcEdge, dvEdge - integer, dimension(:), pointer :: nEdgesOnCell - integer, dimension(:,:), pointer :: edgesOnCell, cellsOnEdge - integer, pointer :: nCells, nEdges, maxEdges, num_scalars + integer, pointer :: nCells, num_scalars integer, dimension(:), pointer :: bdyMaskCell - call mpas_pool_get_array(state, 'scalars', scalars_new, 2) - - call mpas_pool_get_array(mesh, 'invDcEdge', invDcEdge ) - call mpas_pool_get_array(mesh, 'dvEdge', dvEdge ) - call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) - call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'maxEdges', maxEdges) call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - call atm_bdy_set_scalars_work( scalars_new, scalars_driving, dt, dt_rk, & - nVertLevels, nCells, nEdges, num_scalars, & - nEdgesOnCell, edgesOnCell, EdgesOnCell_sign, cellsOnEdge, dvEdge, invDcEdge, bdyMaskCell, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) + call atm_bdy_set_scalars_work( scalars_driving, & + nVertLevels, nCells, num_scalars, & + bdyMaskCell, & + cellStart, cellEnd, & + cellSolveStart, cellSolveEnd ) end subroutine atm_bdy_set_scalars !------------------------------------------------------------------------- - subroutine atm_bdy_set_scalars_work( scalars_new, scalars_driving, dt, dt_rk, & - nVertLevels, nCells, nEdges, num_scalars, & - nEdgesOnCell, edgesOnCell, EdgesOnCell_sign, cellsOnEdge, dvEdge, invDcEdge, bdyMaskCell, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) + subroutine atm_bdy_set_scalars_work( scalars_driving, & + nVertLevels, nCells, num_scalars, & + bdyMaskCell, & + cellStart, cellEnd, & + cellSolveStart, cellSolveEnd ) implicit none real (kind=RKIND), dimension(:,:,:), intent(in) :: scalars_driving - real (kind=RKIND), dimension(:,:,:), intent(inout) :: scalars_new - real (kind=RKIND), dimension(:,:), intent(in) :: edgesOnCell_sign - integer, intent(in) :: nVertLevels, nCells, nEdges, num_scalars - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd - integer, dimension(:), intent(in) :: nEdgesOnCell, bdyMaskCell - integer, dimension(:,:), intent(in) :: edgesOnCell, cellsOnEdge - real (kind=RKIND), dimension(:), intent(in) :: dvEdge, invDcEdge - real (kind=RKIND), intent(in) :: dt, dt_rk + integer, intent(in) :: nVertLevels, nCells, num_scalars + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, dimension(:), intent(in) :: bdyMaskCell ! local variables real (kind=RKIND), dimension(1:num_scalars,1:nVertLevels, cellSolveStart:cellSolveEnd) :: scalars_tmp - real (kind=RKIND) :: edge_sign, laplacian_filter_coef, rayleigh_damping_coef, filter_flux - integer :: iCell, iEdge, iScalar, i, k, cell1, cell2 + real (kind=RKIND) :: laplacian_filter_coef, rayleigh_damping_coef, filter_flux + integer :: iCell, iScalar, i, k, cell1, cell2 !--- From e8f6f9309380e13da34385b30b99ed68a17e72cf Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 28 Sep 2017 23:36:19 -0600 Subject: [PATCH 033/737] Clean up atm_bdy_adjust_scalars( ) --- .../dynamics/mpas_atm_time_integration.F | 45 +++++++------------ 1 file changed, 15 insertions(+), 30 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index ecdbfeca23..8a57d1660e 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1496,16 +1496,6 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - if(debug_regional) write(0,*) ' getting driving values, ignore error messages ' scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qv', rk_timestep(rk_step) ) scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qc', rk_timestep(rk_step) ) @@ -1521,11 +1511,7 @@ subroutine atm_srk3(domain, dt, itimestep) do thread=1,nThreads call atm_bdy_adjust_scalars( state, diag, mesh, block % configs, scalars_driving, nVertLevels, dt, rk_timestep(rk_step), & cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) + cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) end do !$OMP END PARALLEL DO @@ -6780,8 +6766,8 @@ end subroutine atm_bdy_reset_speczone_values !------------------------------------------------------------------------- subroutine atm_bdy_adjust_scalars( state, diag, mesh, config, scalars_driving, nVertLevels, dt, dt_rk, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + cellStart, cellEnd, & + cellSolveStart, cellSolveEnd ) implicit none @@ -6796,8 +6782,8 @@ subroutine atm_bdy_adjust_scalars( state, diag, mesh, config, scalars_driving, n type (mpas_pool_type), intent(in) :: mesh type (mpas_pool_type), intent(in) :: config integer, intent(in) :: nVertLevels - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd real (kind=RKIND), intent(in) :: dt, dt_rk real (kind=RKIND), dimension(:,:,:), intent(in) :: scalars_driving @@ -6807,7 +6793,7 @@ subroutine atm_bdy_adjust_scalars( state, diag, mesh, config, scalars_driving, n real (kind=RKIND), dimension(:), pointer :: invDcEdge, dvEdge, meshScalingRegionalCell integer, dimension(:), pointer :: nEdgesOnCell integer, dimension(:,:), pointer :: edgesOnCell, cellsOnEdge - integer, pointer :: nCells, nEdges, maxEdges, num_scalars + integer, pointer :: nCells, maxEdges, num_scalars integer, dimension(:), pointer :: bdyMaskCell call mpas_pool_get_array(state, 'scalars', scalars_new, 2) @@ -6822,37 +6808,36 @@ subroutine atm_bdy_adjust_scalars( state, diag, mesh, config, scalars_driving, n call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) call mpas_pool_get_dimension(mesh, 'maxEdges', maxEdges) call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) call atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, & - nVertLevels, nCells, nEdges, num_scalars, & + nVertLevels, nCells, num_scalars, & nEdgesOnCell, edgesOnCell, EdgesOnCell_sign, cellsOnEdge, dvEdge, invDcEdge, bdyMaskCell, & meshScalingRegionalCell, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) + cellStart, cellEnd, & + cellSolveStart, cellSolveEnd ) end subroutine atm_bdy_adjust_scalars !------------------------------------------------------------------------- subroutine atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, & - nVertLevels, nCells, nEdges, num_scalars, & + nVertLevels, nCells, num_scalars, & nEdgesOnCell, edgesOnCell, EdgesOnCell_sign, cellsOnEdge, dvEdge, invDcEdge, bdyMaskCell, & meshScalingRegionalCell, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) + cellStart, cellEnd, & + cellSolveStart, cellSolveEnd ) implicit none real (kind=RKIND), dimension(:,:,:), intent(in) :: scalars_driving real (kind=RKIND), dimension(:,:,:), intent(inout) :: scalars_new real (kind=RKIND), dimension(:,:), intent(in) :: edgesOnCell_sign - integer, intent(in) :: nVertLevels, nCells, nEdges, num_scalars - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: nVertLevels, nCells, num_scalars + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd integer, dimension(:), intent(in) :: nEdgesOnCell, bdyMaskCell integer, dimension(:,:), intent(in) :: edgesOnCell, cellsOnEdge real (kind=RKIND), dimension(:), intent(in) :: dvEdge, invDcEdge, meshScalingRegionalCell From c2a43c5cf3490c1a9a9fa2a8c1732dd2638d2268 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 28 Sep 2017 23:50:51 -0600 Subject: [PATCH 034/737] Clean up atm_bdy_reset_speczone_values( ) --- .../dynamics/mpas_atm_time_integration.F | 213 ++++++++---------- 1 file changed, 96 insertions(+), 117 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 8a57d1660e..61f35d778e 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1629,140 +1629,123 @@ subroutine atm_srk3(domain, dt, itimestep) ! #endif - if (regional_mpas) then ! reset boundary values of rtheta in the specified zone - microphysics has messed with them + if (regional_mpas) then ! reset boundary values of rtheta in the specified zone - microphysics has messed with them - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) + block => domain % blocklist + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - allocate(rt_driving_values(nVertLevels,nCells+1)) - allocate(rho_driving_values(nVertLevels,nCells+1)) - time_dyn_step = dt ! end of full timestep values + allocate(rt_driving_values(nVertLevels,nCells+1)) + allocate(rho_driving_values(nVertLevels,nCells+1)) + time_dyn_step = dt ! end of full timestep values - if(debug_regional) write(0,*) ' getting bdy state values at current time for final adjust after microphysics ' - rt_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rtheta_m', time_dyn_step ) - rho_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', time_dyn_step ) - if(debug_regional) write(0,*) ' have bdy state values ' + if(debug_regional) write(0,*) ' getting bdy state values at current time for final adjust after microphysics ' + rt_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rtheta_m', time_dyn_step ) + rho_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', time_dyn_step ) + if(debug_regional) write(0,*) ' have bdy state values ' !$OMP PARALLEL DO - do thread=1,nThreads - if(debug_regional) write(0,*) ' calling final rtheta_m reset ' - call atm_bdy_reset_speczone_values ( tend, state, diag, mesh, block % configs, nVertLevels, dt, & - rt_driving_values, rho_driving_values, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) - if(debug_regional) write(0,*) ' returned from final rtheta_m reset ' - end do + do thread=1,nThreads + if(debug_regional) write(0,*) ' calling final rtheta_m reset ' + call atm_bdy_reset_speczone_values( state, diag, mesh, nVertLevels, & + rt_driving_values, rho_driving_values, & + cellThreadStart(thread), cellThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) + if(debug_regional) write(0,*) ' returned from final rtheta_m reset ' + end do !$OMP END PARALLEL DO - deallocate(rt_driving_values) - deallocate(rho_driving_values) - block => block % next + deallocate(rt_driving_values) + deallocate(rho_driving_values) + block => block % next - end do + end do - if(debug_regional) write(0,*) ' end relax zone tendencies for dynamics ' + if(debug_regional) write(0,*) ' end relax zone tendencies for dynamics ' - end if ! regional_MPAS addition + end if ! regional_MPAS addition - if (regional_mpas) then ! adjust boundary values for regional_MPAS scalar transport + if (regional_mpas) then ! adjust boundary values for regional_MPAS scalar transport - if(debug_regional) write(0,*) ' resetting spec zone and relax zone scalars ' - call mpas_pool_get_field(state, 'scalars', scalars_field, 2) ! need to fill halo for horizontal filter - call mpas_dmpar_exch_halo_field(scalars_field) + if(debug_regional) write(0,*) ' resetting spec zone and relax zone scalars ' + call mpas_pool_get_field(state, 'scalars', scalars_field, 2) ! need to fill halo for horizontal filter + call mpas_dmpar_exch_halo_field(scalars_field) - block => domain % blocklist - do while (associated(block)) + block => domain % blocklist + do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) - ! get the scalar values driving the regional boundary conditions - ! - if(debug_regional) write(0,*) ' num_scalars = ',num_scalars - call mpas_pool_get_dimension(state, 'index_qv', index_qv) - call mpas_pool_get_dimension(state, 'index_qc', index_qc) - call mpas_pool_get_dimension(state, 'index_qr', index_qr) - call mpas_pool_get_dimension(state, 'index_qi', index_qi) - call mpas_pool_get_dimension(state, 'index_qs', index_qs) - call mpas_pool_get_dimension(state, 'index_qg', index_qg) - call mpas_pool_get_dimension(state, 'index_nr', index_nr) - call mpas_pool_get_dimension(state, 'index_ni', index_ni) - if(debug_regional) write(0,*) ' scalars indices, qv, qc, qr, qi, qs, qg, nr, ni ',index_qv,index_qc,index_qr,index_qi,index_qs,index_qg,index_nr,index_ni + ! get the scalar values driving the regional boundary conditions + ! + if(debug_regional) write(0,*) ' num_scalars = ',num_scalars + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_dimension(state, 'index_qc', index_qc) + call mpas_pool_get_dimension(state, 'index_qr', index_qr) + call mpas_pool_get_dimension(state, 'index_qi', index_qi) + call mpas_pool_get_dimension(state, 'index_qs', index_qs) + call mpas_pool_get_dimension(state, 'index_qg', index_qg) + call mpas_pool_get_dimension(state, 'index_nr', index_nr) + call mpas_pool_get_dimension(state, 'index_ni', index_ni) + if(debug_regional) write(0,*) ' scalars indices, qv, qc, qr, qi, qs, qg, nr, ni ',index_qv,index_qc,index_qr,index_qi,index_qs,index_qg,index_nr,index_ni - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) + call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - if(debug_regional) write(0,*) ' getting driving values, ignore error messages ' - scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qv', dt ) - scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qc', dt ) - scalars_driving(index_qr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qr', dt ) - scalars_driving(index_qi,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qi', dt ) - scalars_driving(index_qs,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qs', dt ) - scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qg', dt ) - !! scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'nr', rk_timestep(rk_step) ) - !! scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) - if(debug_regional) write(0,*) ' finished accessing driving values, end ignoring error messages ' - + if(debug_regional) write(0,*) ' getting driving values, ignore error messages ' + scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qv', dt ) + scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qc', dt ) + scalars_driving(index_qr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qr', dt ) + scalars_driving(index_qi,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qi', dt ) + scalars_driving(index_qs,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qs', dt ) + scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qg', dt ) + !! scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'nr', rk_timestep(rk_step) ) + !! scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) + if(debug_regional) write(0,*) ' finished accessing driving values, end ignoring error messages ' + !$OMP PARALLEL DO - do thread=1,nThreads - call atm_bdy_set_scalars( state, mesh, scalars_driving, nVertLevels, & - cellThreadStart(thread), cellThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) - end do + do thread=1,nThreads + call atm_bdy_set_scalars( state, mesh, scalars_driving, nVertLevels, & + cellThreadStart(thread), cellThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) + end do !$OMP END PARALLEL DO - deallocate(scalars_driving) + deallocate(scalars_driving) - write(0,*) ' finished resetting scalar values ' - - block => block % next - end do + write(0,*) ' finished resetting scalar values ' + + block => block % next + end do - end if ! regional_MPAS addition + end if ! regional_MPAS addition call summarize_timestep(domain) @@ -6719,10 +6702,10 @@ end subroutine atm_bdy_check_values !------------------------------------------------------------------------- - subroutine atm_bdy_reset_speczone_values ( tend, state, diag, mesh, config, nVertLevels, dt, & - rt_driving_values, rho_driving_values, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) + subroutine atm_bdy_reset_speczone_values( state, diag, mesh, nVertLevels, & + rt_driving_values, rho_driving_values, & + cellStart, cellEnd, & + cellSolveStart, cellSolveEnd ) implicit none @@ -6731,15 +6714,11 @@ subroutine atm_bdy_reset_speczone_values ( tend, state, diag, mesh, conf ! WCS 24 February 2017 type (mpas_pool_type), intent(in) :: state - type (mpas_pool_type), intent(inout) :: tend type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh - type (mpas_pool_type), intent(in) :: config integer, intent(in) :: nVertLevels - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd - - real (kind=RKIND), intent(in) :: dt + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd real (kind=RKIND), dimension(:,:), intent(in) :: rt_driving_values, rho_driving_values @@ -6762,7 +6741,7 @@ subroutine atm_bdy_reset_speczone_values ( tend, state, diag, mesh, conf end if end do - end subroutine atm_bdy_reset_speczone_values + end subroutine atm_bdy_reset_speczone_values !------------------------------------------------------------------------- subroutine atm_bdy_adjust_scalars( state, diag, mesh, config, scalars_driving, nVertLevels, dt, dt_rk, & From 951370198ddfe2f7b561ba9496cdfe8b6f667251 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 29 Sep 2017 12:05:39 -0600 Subject: [PATCH 035/737] Fix up indentation in new boundary code in mpas_atm_time_integration.F --- .../dynamics/mpas_atm_time_integration.F | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 61f35d778e..b494f46c4f 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -790,14 +790,14 @@ subroutine atm_srk3(domain, dt, itimestep) !$OMP PARALLEL DO do thread=1,nThreads if(debug_regional) write(0,*) ' calling check for spec zone values, rk_step = ',rk_step - call atm_bdy_check_values ( tend, state, diag, mesh, block % configs, nVertLevels, dt, & - ru_driving_values, rt_driving_values, rho_driving_values, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) + call atm_bdy_check_values( tend, state, diag, mesh, block % configs, nVertLevels, dt, & + ru_driving_values, rt_driving_values, rho_driving_values, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) if(debug_regional) write(0,*) ' returned from check ' end do !$OMP END PARALLEL DO @@ -6373,7 +6373,7 @@ subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, confi end if end do - end subroutine atm_bdy_adjust_dynamics_speczone_tend + end subroutine atm_bdy_adjust_dynamics_speczone_tend !------------------------------------------------------------------------- @@ -6567,7 +6567,7 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf end do ! end of loop over edges - end subroutine atm_bdy_adjust_dynamics_relaxzone_tend + end subroutine atm_bdy_adjust_dynamics_relaxzone_tend !------------------------------------------------------------------------- @@ -6698,7 +6698,7 @@ subroutine atm_bdy_check_values( tend, state, diag, mesh, config, nVertLevels, d ! write(0,*) ' ru ncheck, nerr, max error = ',ncheck, nerr, errormax - end subroutine atm_bdy_check_values + end subroutine atm_bdy_check_values !------------------------------------------------------------------------- From b291e8ab8ac684c8c99e9807c45abc31b3958410 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 29 Sep 2017 12:23:38 -0600 Subject: [PATCH 036/737] Remove unused arguments from atm_bdy_adjust_dynamics_{spec,relax}zone_tend --- .../dynamics/mpas_atm_time_integration.F | 44 ++++++------------- 1 file changed, 13 insertions(+), 31 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index b494f46c4f..2e53a066f9 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -673,14 +673,11 @@ subroutine atm_srk3(domain, dt, itimestep) block => domain % blocklist do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) call mpas_pool_get_subpool(block % structs, 'mesh', mesh) call mpas_pool_get_subpool(block % structs, 'tend', tend) call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) @@ -705,8 +702,8 @@ subroutine atm_srk3(domain, dt, itimestep) !$OMP PARALLEL DO do thread=1,nThreads if(debug_regional) write(0,*) ' calling spec zone tend adjust ' - call atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, block % configs, nVertLevels, & - ru_driving_tend, rt_driving_tend, rho_driving_tend, & + call atm_bdy_adjust_dynamics_speczone_tend( tend, mesh, block % configs, nVertLevels, & + ru_driving_tend, rt_driving_tend, rho_driving_tend, & cellThreadStart(thread), cellThreadEnd(thread), & edgeThreadStart(thread), edgeThreadEnd(thread), & cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & @@ -733,7 +730,6 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) @@ -747,11 +743,6 @@ subroutine atm_srk3(domain, dt, itimestep) call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - allocate(ru_driving_values(nVertLevels,nEdges+1)) allocate(rt_driving_values(nVertLevels,nCells+1)) allocate(rho_driving_values(nVertLevels,nCells+1)) @@ -766,13 +757,11 @@ subroutine atm_srk3(domain, dt, itimestep) !$OMP PARALLEL DO do thread=1,nThreads if(debug_regional) write(0,*) ' calling relax zone tend adjust ' - call atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, block % configs, nVertLevels, dt, & - ru_driving_values, rt_driving_values, rho_driving_values, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + call atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, nVertLevels, dt, & + ru_driving_values, rt_driving_values, rho_driving_values, & + cellThreadStart(thread), cellThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) if(debug_regional) write(0,*) ' returned from relax zone tend adjust ' end do @@ -6316,7 +6305,7 @@ end subroutine atm_zero_gradient_w_bdy_work !------------------------------------------------------------------------- - subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, config, nVertLevels, & + subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, mesh, config, nVertLevels, & ru_driving_tend, rt_driving_tend, rho_driving_tend, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd ) @@ -6329,9 +6318,7 @@ subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, confi ! ! WCS Fall 2016 - type (mpas_pool_type), intent(in) :: state type (mpas_pool_type), intent(inout) :: tend - type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh type (mpas_pool_type), intent(in) :: config integer, intent(in) :: nVertLevels @@ -6366,8 +6353,6 @@ subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, state, diag, mesh, confi do iEdge = edgeSolveStart, edgeSolveEnd if(bdyMaskEdge(iEdge) > nRelaxZone) then do k=1, nVertLevels -! wcs error_1 -! tend_ru(k,iEdge) = ru_driving_tend(k,iCell) tend_ru(k,iEdge) = ru_driving_tend(k,iEdge) end do end if @@ -6377,10 +6362,10 @@ end subroutine atm_bdy_adjust_dynamics_speczone_tend !------------------------------------------------------------------------- - subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, config, nVertLevels, dt, & + subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, nVertLevels, dt, & ru_driving_values, rt_driving_values, rho_driving_values, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd ) + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd ) implicit none @@ -6394,10 +6379,9 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf type (mpas_pool_type), intent(inout) :: tend type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh - type (mpas_pool_type), intent(in) :: config integer, intent(in) :: nVertLevels - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd real (kind=RKIND), intent(in) :: dt @@ -6463,8 +6447,6 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, conf if( (bdyMaskEdge(iEdge) > 1) .and. (bdyMaskEdge(iEdge) <= nRelaxZone) ) then rayleigh_damping_coef = (real(bdyMaskEdge(iEdge)) - 1.)/real(nRelaxZone)/(50.*dt*meshScalingRegionalEdge(iEdge)) do k=1, nVertLevels -! wcs error_1 -! tend_ru(k,iEdge) = tend_ru(k,iEdge) - rayleigh_damping_coef * (ru_driving_values(k,iCell) - ru(k,iCell)) tend_ru(k,iEdge) = tend_ru(k,iEdge) - rayleigh_damping_coef * (ru_driving_values(k,iEdge) - ru(k,iEdge)) end do end if From dfc7f04fe4b3f704e4b2e2697804b566508b7f6b Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 19 Jan 2018 17:54:34 -0700 Subject: [PATCH 037/737] Fix incorrect sign in boundary relaxation terms for rho, rt, and ru The sign of the contribution to the tendendies for rho, rt, and ru due to relaxation towards driving values along the domain boundaries was incorrect due to the reversal of the terms in difference between the model values and the driving data values. This commit corrects the sign of these terms by swapping the order of the terms in the difference computation. --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 2e53a066f9..fd253e051d 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -6437,8 +6437,8 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, nVer if( (bdyMaskCell(iCell) > 1) .and. (bdyMaskCell(iCell) <= nRelaxZone) ) then rayleigh_damping_coef = (real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(50.*dt*meshScalingRegionalCell(iCell)) do k=1, nVertLevels - tend_rho(k,iCell) = tend_rho(k,iCell) - rayleigh_damping_coef * (rho_driving_values(k,iCell) - rho_zz(k,iCell)) - tend_rt(k,iCell) = tend_rt(k,iCell) - rayleigh_damping_coef * (rt_driving_values(k,iCell) - rho_zz(k,iCell)*theta_m(k,iCell)) + tend_rho(k,iCell) = tend_rho(k,iCell) - rayleigh_damping_coef * (rho_zz(k,iCell) - rho_driving_values(k,iCell)) + tend_rt(k,iCell) = tend_rt(k,iCell) - rayleigh_damping_coef * (rho_zz(k,iCell)*theta_m(k,iCell) - rt_driving_values(k,iCell)) end do end if end do @@ -6447,7 +6447,7 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, nVer if( (bdyMaskEdge(iEdge) > 1) .and. (bdyMaskEdge(iEdge) <= nRelaxZone) ) then rayleigh_damping_coef = (real(bdyMaskEdge(iEdge)) - 1.)/real(nRelaxZone)/(50.*dt*meshScalingRegionalEdge(iEdge)) do k=1, nVertLevels - tend_ru(k,iEdge) = tend_ru(k,iEdge) - rayleigh_damping_coef * (ru_driving_values(k,iEdge) - ru(k,iEdge)) + tend_ru(k,iEdge) = tend_ru(k,iEdge) - rayleigh_damping_coef * (ru(k,iEdge) - ru_driving_values(k,iEdge)) end do end if end do From e9e3576fdabedb1dc742221b5afe4e5940668c4a Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 31 Jan 2018 16:50:52 -0700 Subject: [PATCH 038/737] Remove lbc_rho_edge from LBC forcing files, and compute this field internally The 'lbc_rho_edge' field is not needed on the outermost edges of a limited-area domain, so we can compute this internally by averaging lbc_rho_zz to edges. The results when averaging lbc_rho_zz to edges in the mpas_atm_boundaries module will differ from those when reading lbc_rho_edge from the LBC forcing files, since the value of lbc_rho_edge in those forcing files is not averaged from the cells on either side of an edge, but rather is interpolated directly to edge locations from the cell-centered rho_zz field in the driving model mesh. --- src/core_atmosphere/Registry.xml | 7 ++++++- .../dynamics/mpas_atm_boundaries.F | 19 +++++++++++++++++++ 2 files changed, 25 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 8da6ea7d69..56e63d154e 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1064,7 +1064,12 @@ immutable="true"> - + + + + + + diff --git a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F index 6052b5ed56..32b81cae9f 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F +++ b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F @@ -67,6 +67,8 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) type (mpas_pool_type), pointer :: lbc real (kind=RKIND) :: dt + integer, pointer :: nEdges + real (kind=RKIND), dimension(:,:), pointer :: u real (kind=RKIND), dimension(:,:), pointer :: ru real (kind=RKIND), dimension(:,:), pointer :: rho_edge @@ -84,11 +86,15 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho_zz real (kind=RKIND), dimension(:,:,:), pointer :: lbc_tend_scalars + integer, dimension(:,:), pointer :: cellsOnEdge + integer :: ierr integer :: dd_intv, s_intv, sn_intv, sd_intv type (MPAS_Time_Type) :: currTime type (MPAS_TimeInterval_Type) :: lbc_interval character(len=StrKIND) :: read_time + integer :: iEdge + integer :: cell1, cell2 call mpas_pool_get_subpool(block % structs, 'mesh', mesh) @@ -114,6 +120,19 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) call mpas_pool_get_array(lbc, 'lbc_theta_m', theta_m, 2) call mpas_pool_get_array(lbc, 'lbc_rtheta_m', rtheta_m, 2) call mpas_pool_get_array(lbc, 'lbc_rho_zz', rho_zz, 2) + + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + + ! Average lbc_rho_zz to edges + do iEdge=1,nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + if (cell1 > 0 .and. cell2 > 0) then + rho_edge(:,iEdge) = 0.5_RKIND * (rho_zz(:,cell1) + rho_zz(:,cell2)) + end if + end do + ru(:,:) = u(:,:) * rho_edge(:,:) rtheta_m(:,:) = theta_m(:,:) * rho_zz(:,:) From 6823846039239149d5e7b908a919ffe69627974e Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 31 Jan 2018 19:31:39 -0700 Subject: [PATCH 039/737] Switch from 'lbc_theta_m' to 'lbc_theta' in LBC forcing files We now read 'lbc_theta' from the LBC forcing files and use this internally to compute lbc_rtheta_m using lbc_rho_zz and lbc_scalars(qv). The lbc_theta_m field is apparently not used anywhere in the solver, so there is no need to retain this field in addition to lbc_rtheta_m. --- src/core_atmosphere/Registry.xml | 6 ++--- .../dynamics/mpas_atm_boundaries.F | 23 +++++++++++-------- 2 files changed, 17 insertions(+), 12 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 56e63d154e..c6e08188a0 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1067,7 +1067,7 @@ - + @@ -1740,8 +1740,8 @@ - + diff --git a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F index 32b81cae9f..f130515cba 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F +++ b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F @@ -55,6 +55,8 @@ module mpas_atm_boundaries !----------------------------------------------------------------------- subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) + use mpas_constants, only : rvord + implicit none type (mpas_clock_type), intent(in) :: clock @@ -68,12 +70,13 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) real (kind=RKIND) :: dt integer, pointer :: nEdges + integer, pointer :: index_qv real (kind=RKIND), dimension(:,:), pointer :: u real (kind=RKIND), dimension(:,:), pointer :: ru real (kind=RKIND), dimension(:,:), pointer :: rho_edge real (kind=RKIND), dimension(:,:), pointer :: w - real (kind=RKIND), dimension(:,:), pointer :: theta_m + real (kind=RKIND), dimension(:,:), pointer :: theta real (kind=RKIND), dimension(:,:), pointer :: rtheta_m real (kind=RKIND), dimension(:,:), pointer :: rho_zz real (kind=RKIND), dimension(:,:,:), pointer :: scalars @@ -81,7 +84,7 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_ru real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho_edge real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_w - real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_theta_m + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_theta real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rtheta_m real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho_zz real (kind=RKIND), dimension(:,:,:), pointer :: lbc_tend_scalars @@ -117,12 +120,14 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) call mpas_pool_get_array(lbc, 'lbc_u', u, 2) call mpas_pool_get_array(lbc, 'lbc_ru', ru, 2) call mpas_pool_get_array(lbc, 'lbc_rho_edge', rho_edge, 2) - call mpas_pool_get_array(lbc, 'lbc_theta_m', theta_m, 2) + call mpas_pool_get_array(lbc, 'lbc_theta', theta, 2) call mpas_pool_get_array(lbc, 'lbc_rtheta_m', rtheta_m, 2) call mpas_pool_get_array(lbc, 'lbc_rho_zz', rho_zz, 2) + call mpas_pool_get_array(lbc, 'lbc_scalars', scalars, 2) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(lbc, 'index_qv', index_qv) ! Average lbc_rho_zz to edges do iEdge=1,nEdges @@ -134,7 +139,7 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) end do ru(:,:) = u(:,:) * rho_edge(:,:) - rtheta_m(:,:) = theta_m(:,:) * rho_zz(:,:) + rtheta_m(:,:) = theta(:,:) * rho_zz(:,:) * (1.0_RKIND + rvord * scalars(index_qv,:,:)) if (.not. firstCall) then lbc_interval = currTime - LBC_intv_end @@ -146,7 +151,7 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) call mpas_pool_get_array(lbc, 'lbc_ru', ru, 2) call mpas_pool_get_array(lbc, 'lbc_rho_edge', rho_edge, 2) call mpas_pool_get_array(lbc, 'lbc_w', w, 2) - call mpas_pool_get_array(lbc, 'lbc_theta_m', theta_m, 2) + call mpas_pool_get_array(lbc, 'lbc_theta', theta, 2) call mpas_pool_get_array(lbc, 'lbc_rtheta_m', rtheta_m, 2) call mpas_pool_get_array(lbc, 'lbc_rho_zz', rho_zz, 2) call mpas_pool_get_array(lbc, 'lbc_scalars', scalars, 2) @@ -155,7 +160,7 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) call mpas_pool_get_array(lbc, 'lbc_ru', lbc_tend_ru, 1) call mpas_pool_get_array(lbc, 'lbc_rho_edge', lbc_tend_rho_edge, 1) call mpas_pool_get_array(lbc, 'lbc_w', lbc_tend_w, 1) - call mpas_pool_get_array(lbc, 'lbc_theta_m', lbc_tend_theta_m, 1) + call mpas_pool_get_array(lbc, 'lbc_theta', lbc_tend_theta, 1) call mpas_pool_get_array(lbc, 'lbc_rtheta_m', lbc_tend_rtheta_m, 1) call mpas_pool_get_array(lbc, 'lbc_rho_zz', lbc_tend_rho_zz, 1) call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_tend_scalars, 1) @@ -166,7 +171,7 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) lbc_tend_ru(:,:) = (ru(:,:) - lbc_tend_ru(:,:)) * dt lbc_tend_rho_edge(:,:) = (rho_edge(:,:) - lbc_tend_rho_edge(:,:)) * dt lbc_tend_w(:,:) = (w(:,:) - lbc_tend_w(:,:)) * dt - lbc_tend_theta_m(:,:) = (theta_m(:,:) - lbc_tend_theta_m(:,:)) * dt + lbc_tend_theta(:,:) = (theta(:,:) - lbc_tend_theta(:,:)) * dt lbc_tend_rtheta_m(:,:) = (rtheta_m(:,:) - lbc_tend_rtheta_m(:,:)) * dt lbc_tend_rho_zz(:,:) = (rho_zz(:,:) - lbc_tend_rho_zz(:,:)) * dt lbc_tend_scalars(:,:,:) = (scalars(:,:,:) - lbc_tend_scalars(:,:,:)) * dt @@ -206,7 +211,7 @@ end subroutine mpas_atm_update_bdy_tend !> tend_u(:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels, nEdges, 'u', 0.0_RKIND) !> tend_w(:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels+1, nCells, 'w', 0.0_RKIND) !> tend_rho_zz(:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', 0.0_RKIND) - !> tend_theta_m(:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels, nCells, 'theta_m', 0.0_RKIND) + !> tend_theta(:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels, nCells, 'theta', 0.0_RKIND) !> tend_scalars(1,:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels, nCells, 'qv', 0.0_RKIND) ! !----------------------------------------------------------------------- @@ -275,7 +280,7 @@ end function mpas_atm_get_bdy_tend !> u(:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels, nEdges, 'u', 0.0_RKIND) !> w(:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels+1, nCells, 'w', 0.0_RKIND) !> rho_zz(:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', 0.0_RKIND) - !> theta_m(:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels, nCells, 'theta_m', 0.0_RKIND) + !> theta(:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels, nCells, 'theta', 0.0_RKIND) !> scalars(1,:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels, nCells, 'qv', 0.0_RKIND) ! !----------------------------------------------------------------------- From 52bac8b22b9b03e75a0131478be4937707932e1f Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 1 Feb 2018 11:54:06 -0700 Subject: [PATCH 040/737] Switch from 'lbc_rho_zz' to 'lbc_rho' in LBC forcing files Now, we read simple dry density from the LBC forcing files as 'lbc_rho', rather than density coupled with zz. The 'lbc_rho' field has been added to the Registry.xml file in addition to 'lbc_rho_zz', since the latter is still used in the model solver, while the former needs to be read from LBC files. --- src/core_atmosphere/Registry.xml | 5 ++++- src/core_atmosphere/dynamics/mpas_atm_boundaries.F | 11 +++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index c6e08188a0..1900bdf5ee 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1066,7 +1066,7 @@ - + @@ -1734,6 +1734,9 @@ + + diff --git a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F index f130515cba..ca808e9849 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F +++ b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F @@ -79,6 +79,7 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) real (kind=RKIND), dimension(:,:), pointer :: theta real (kind=RKIND), dimension(:,:), pointer :: rtheta_m real (kind=RKIND), dimension(:,:), pointer :: rho_zz + real (kind=RKIND), dimension(:,:), pointer :: rho real (kind=RKIND), dimension(:,:,:), pointer :: scalars real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_u real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_ru @@ -87,9 +88,11 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_theta real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rtheta_m real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho_zz + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho real (kind=RKIND), dimension(:,:,:), pointer :: lbc_tend_scalars integer, dimension(:,:), pointer :: cellsOnEdge + real (kind=RKIND), dimension(:,:), pointer :: zz integer :: ierr integer :: dd_intv, s_intv, sn_intv, sd_intv @@ -123,11 +126,16 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) call mpas_pool_get_array(lbc, 'lbc_theta', theta, 2) call mpas_pool_get_array(lbc, 'lbc_rtheta_m', rtheta_m, 2) call mpas_pool_get_array(lbc, 'lbc_rho_zz', rho_zz, 2) + call mpas_pool_get_array(lbc, 'lbc_rho', rho, 2) call mpas_pool_get_array(lbc, 'lbc_scalars', scalars, 2) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) call mpas_pool_get_dimension(lbc, 'index_qv', index_qv) + call mpas_pool_get_array(mesh, 'zz', zz) + + ! Compute lbc_rho_zz + rho_zz(:,:) = rho(:,:) / zz(:,:) ! Average lbc_rho_zz to edges do iEdge=1,nEdges @@ -154,6 +162,7 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) call mpas_pool_get_array(lbc, 'lbc_theta', theta, 2) call mpas_pool_get_array(lbc, 'lbc_rtheta_m', rtheta_m, 2) call mpas_pool_get_array(lbc, 'lbc_rho_zz', rho_zz, 2) + call mpas_pool_get_array(lbc, 'lbc_rho', rho, 2) call mpas_pool_get_array(lbc, 'lbc_scalars', scalars, 2) call mpas_pool_get_array(lbc, 'lbc_u', lbc_tend_u, 1) @@ -163,6 +172,7 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) call mpas_pool_get_array(lbc, 'lbc_theta', lbc_tend_theta, 1) call mpas_pool_get_array(lbc, 'lbc_rtheta_m', lbc_tend_rtheta_m, 1) call mpas_pool_get_array(lbc, 'lbc_rho_zz', lbc_tend_rho_zz, 1) + call mpas_pool_get_array(lbc, 'lbc_rho', lbc_tend_rho, 1) call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_tend_scalars, 1) @@ -174,6 +184,7 @@ subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall) lbc_tend_theta(:,:) = (theta(:,:) - lbc_tend_theta(:,:)) * dt lbc_tend_rtheta_m(:,:) = (rtheta_m(:,:) - lbc_tend_rtheta_m(:,:)) * dt lbc_tend_rho_zz(:,:) = (rho_zz(:,:) - lbc_tend_rho_zz(:,:)) * dt + lbc_tend_rho(:,:) = (rho(:,:) - lbc_tend_rho(:,:)) * dt lbc_tend_scalars(:,:,:) = (scalars(:,:,:) - lbc_tend_scalars(:,:,:)) * dt end if From 48364711ebbc7649526b7bff11061e25f5c316d7 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Fri, 2 Feb 2018 16:28:13 -0700 Subject: [PATCH 041/737] bug fix for final specification of scalar values in the specified zone of a regional mesh boundary --- .../dynamics/mpas_atm_time_integration.F | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index fd253e051d..39b9b9c313 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -6879,6 +6879,7 @@ subroutine atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, end subroutine atm_bdy_adjust_scalars_work !------------------------------------------------------------------------- + subroutine atm_bdy_set_scalars( state, mesh, scalars_driving, nVertLevels, & cellStart, cellEnd, & cellSolveStart, cellSolveEnd ) @@ -6899,6 +6900,7 @@ subroutine atm_bdy_set_scalars( state, mesh, scalars_driving, nVertLevels, & real (kind=RKIND), dimension(:,:,:), intent(in) :: scalars_driving + real (kind=RKIND), dimension(:,:,:), pointer :: scalars_new integer, pointer :: nCells, num_scalars integer, dimension(:), pointer :: bdyMaskCell @@ -6908,7 +6910,9 @@ subroutine atm_bdy_set_scalars( state, mesh, scalars_driving, nVertLevels, & call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - call atm_bdy_set_scalars_work( scalars_driving, & + call mpas_pool_get_array(state, 'scalars', scalars_new, 2) + + call atm_bdy_set_scalars_work( scalars_driving, scalars_new, & nVertLevels, nCells, num_scalars, & bdyMaskCell, & cellStart, cellEnd, & @@ -6918,7 +6922,7 @@ end subroutine atm_bdy_set_scalars !------------------------------------------------------------------------- - subroutine atm_bdy_set_scalars_work( scalars_driving, & + subroutine atm_bdy_set_scalars_work( scalars_driving, scalars_new, & nVertLevels, nCells, num_scalars, & bdyMaskCell, & cellStart, cellEnd, & @@ -6927,6 +6931,7 @@ subroutine atm_bdy_set_scalars_work( scalars_driving, & implicit none real (kind=RKIND), dimension(:,:,:), intent(in) :: scalars_driving + real (kind=RKIND), dimension(:,:,:), intent(inout) :: scalars_new integer, intent(in) :: nVertLevels, nCells, num_scalars integer, intent(in) :: cellStart, cellEnd integer, intent(in) :: cellSolveStart, cellSolveEnd @@ -6934,7 +6939,6 @@ subroutine atm_bdy_set_scalars_work( scalars_driving, & ! local variables - real (kind=RKIND), dimension(1:num_scalars,1:nVertLevels, cellSolveStart:cellSolveEnd) :: scalars_tmp real (kind=RKIND) :: laplacian_filter_coef, rayleigh_damping_coef, filter_flux integer :: iCell, iScalar, i, k, cell1, cell2 @@ -6949,7 +6953,7 @@ subroutine atm_bdy_set_scalars_work( scalars_driving, & !DIR$ IVDEP do k=1,nVertLevels do iScalar = 1, num_scalars - scalars_tmp(iScalar,k,iCell) = scalars_driving(iScalar,k,iCell) + scalars_new(iScalar,k,iCell) = scalars_driving(iScalar,k,iCell) end do end do From c940f982e952b53eb6c566f4dd8318b737144706 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Fri, 2 Feb 2018 16:59:06 -0700 Subject: [PATCH 042/737] implemented upstream flux evaluation for 2 levels of edges closest to the specified zone for scalar transport. This will result in the correct inflow and outflow conditions applied to scalar transport in the event the driving analysis does not contain values for that scalar. It will also work when scalar values are specified from the driving analysis. The regional_mpas logical has been pushed to the top of the module so it is accessible to all routines. --- .../dynamics/mpas_atm_time_integration.F | 75 +++++++++++-------- 1 file changed, 44 insertions(+), 31 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 39b9b9c313..5b3ae68cee 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -64,6 +64,7 @@ module atm_time_integration real (kind=RKIND), dimension(:,:), allocatable :: rt_driving_values ! regional_MPAS addition real (kind=RKIND), dimension(:,:), allocatable :: rho_driving_values ! regional_MPAS addition integer, dimension(:), pointer :: bdyMaskEdge ! regional_MPAS addition + logical, parameter :: regional_mpas = .true., debug_regional =.false. ! regional_MPAS addition ! Used in compute_solve_diagnostics real (kind=RKIND), allocatable, dimension(:,:) :: ke_vertex @@ -219,7 +220,6 @@ subroutine atm_srk3(domain, dt, itimestep) real (kind=RKIND), dimension(:,:), pointer :: rqvdynten - logical, parameter :: regional_mpas = .true., debug_regional =.false. real (kind=RKIND) :: time_dyn_step logical, parameter :: debug = .false. @@ -3098,7 +3098,7 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4 real (kind=RKIND), pointer :: coef_3rd_order - integer, dimension(:), pointer :: bdyMaskCell ! regional_MPAS addition + integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge ! regional_MPAS addition logical :: local_advance_density @@ -3149,18 +3149,9 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) if (local_advance_density) then -! call atm_advance_scalars_work(num_scalars, nCells, nVertLevels, dt, & -! cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & -! cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & -! coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & -! uhAvg, wwAvg, deriv_two, dvEdge, & -! cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & -! scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & -! nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & -! nCellsSolve, nEdges, horiz_flux_arr, & -! local_advance_density, scalar_tend, rho_zz_int) call atm_advance_scalars_work_new(num_scalars, nCells, nVertLevels, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & @@ -3168,21 +3159,11 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n uhAvg, wwAvg, deriv_two, dvEdge, & cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & - bdyMaskCell, & + bdyMaskCell, bdyMaskEdge, & nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & local_advance_density, scalar_tend, rho_zz_int) else -! call atm_advance_scalars_work(num_scalars, nCells, nVertLevels, dt, & -! cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & -! cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & -! coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & -! uhAvg, wwAvg, deriv_two, dvEdge, & -! cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & -! scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & -! nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & -! nCellsSolve, nEdges, horiz_flux_arr, & -! local_advance_density) call atm_advance_scalars_work_new(num_scalars, nCells, nVertLevels, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & @@ -3190,7 +3171,7 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n uhAvg, wwAvg, deriv_two, dvEdge, & cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & - bdyMaskCell, & + bdyMaskCell, bdyMaskEdge, & nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & local_advance_density) @@ -3198,7 +3179,6 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n end subroutine atm_advance_scalars - subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dummy, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & @@ -3477,7 +3457,7 @@ subroutine atm_advance_scalars_work_new( num_scalars_dummy, nCells, nVertLevels_ uhAvg, wwAvg, deriv_two, dvEdge, & cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & - bdyMaskCell, & + bdyMaskCell, bdyMaskEdge, & nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & advance_density, scalar_tend, rho_zz_int) @@ -3536,7 +3516,7 @@ subroutine atm_advance_scalars_work_new( num_scalars_dummy, nCells, nVertLevels_ real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout), optional :: scalar_tend real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout), optional :: rho_zz_int real (kind=RKIND), dimension(:), intent(in) :: invAreaCell - integer, dimension(:), intent(in) :: bdyMaskCell ! regional_MPAS addition + integer, dimension(:), intent(in) :: bdyMaskCell, bdyMaskEdge ! regional_MPAS addition integer, intent(in) :: nCellsSolve, nEdges integer :: i, j, iCell, iAdvCell, iEdge, k, iScalar, cell1, cell2 @@ -3556,6 +3536,7 @@ subroutine atm_advance_scalars_work_new( num_scalars_dummy, nCells, nVertLevels_ real (kind=RKIND) :: weight_time_old, weight_time_new real (kind=RKIND), dimension(num_scalars,nVertLevels) :: scalar_tend_column ! local storage to accumulate tendency + real (kind=RKIND) :: u_direction, u_positive, u_negative flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ua*( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 @@ -3590,6 +3571,8 @@ subroutine atm_advance_scalars_work_new( num_scalars_dummy, nCells, nVertLevels_ do iEdge=edgeStart,edgeEnd + if( (.not.regional_mpas) .or. (bdyMaskEdge(iEdge) .lt. nRelaxZone-1) ) then ! full flux calculation + select case(nAdvCellsForEdge(iEdge)) case(10) @@ -3637,6 +3620,24 @@ subroutine atm_advance_scalars_work_new( num_scalars_dummy, nCells, nVertLevels_ end do end select + + else if(regional_mpas .and. (bdyMaskEdge(iEdge) .ge. nRelaxZone-1) .and. (bdyMaskEdge(iEdge) .le. nRelaxZone) ) then + ! upwind flux evaluation for outermost 2 edges in specified zone + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) +!DIR$ IVDEP + do k=1,nVertLevels + u_direction = sign(0.5_RKIND,uhAvg(k,iEdge)) + u_positive = dvEdge(iEdge)*abs(u_direction + 0.5_RKIND) + u_negative = dvEdge(iEdge)*abs(u_direction - 0.5_RKIND) +!DIR$ IVDEP + do iScalar=1,num_scalars + horiz_flux_arr(iScalar,k,iEdge) = u_positive*scalar_new(iScalar,k,cell1) + u_negative*scalar_new(iScalar,k,cell2) + end do + end do + + end if ! end of regional MPAS test + end do !$OMP BARRIER @@ -3769,7 +3770,7 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_3rd real (kind=RKIND), dimension(:,:,:), pointer :: scalars_old, scalars_new - integer, dimension(:), pointer :: bdyMaskCell ! regional_MPAS addition + integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge ! regional_MPAS addition integer, pointer :: nCellsSolve @@ -3807,6 +3808,7 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) ! MPAS_regional addition + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) ! MPAS_regional addition call atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLevels, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & @@ -3816,7 +3818,7 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe edgesOnCell, edgesOnCell_sign, nEdgesOnCell, fnm, fnp, rdnw, nAdvCellsForEdge, & advCellsForEdge, adv_coefs, adv_coefs_3rd, scalar_old, scalar_new, s_max, s_min, & wdtn, scale_arr, flux_arr, flux_upwind_tmp, flux_tmp, & - bdyMaskCell, & + bdyMaskCell, bdyMaskEdge, & advance_density, rho_zz_int) end subroutine atm_advance_scalars_mono @@ -3830,7 +3832,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve edgesOnCell, edgesOnCell_sign, nEdgesOnCell, fnm, fnp, rdnw, nAdvCellsForEdge, & advCellsForEdge, adv_coefs, adv_coefs_3rd, scalar_old, scalar_new, s_max, s_min, & wdtn, scale_arr, flux_arr, flux_upwind_tmp, flux_tmp, & - bdyMaskCell, & + bdyMaskCell, bdyMaskEdge, & advance_density, rho_zz_int) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! @@ -3889,7 +3891,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: wwAvg real (kind=RKIND), dimension(:), intent(in) :: dvEdge, invAreaCell integer, dimension(:,:), intent(in) :: cellsOnEdge, cellsOnCell, edgesOnCell - integer, dimension(:) :: bdyMaskCell + integer, dimension(:) :: bdyMaskCell, bdyMaskEdge real (kind=RKIND), dimension(:,:), intent(in) :: edgesOnCell_sign integer, dimension(:,:), intent(in) :: advCellsForEdge @@ -4236,6 +4238,12 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve (max(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell1) + min(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell2)) flux_tmp(k,iEdge) = dt * flux_arr(k,iEdge) - flux_upwind_tmp(k,iEdge) end do + + if( regional_mpas .and. (bdyMaskEdge(iEdge) == nRelaxZone) .or. (bdyMaskEdge(iEdge) == nRelaxZone-1) ) then + flux_tmp(:,iEdge) = 0. + flux_arr(:,iEdge) = flux_upwind_tmp(:,iEdge) + end if + end do !$OMP BARRIER do iCell=cellSolveStart,cellSolveEnd @@ -4326,6 +4334,11 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve (max(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell1) + min(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell2)) flux_arr(k,iEdge) = dt*flux_arr(k,iEdge) - flux_upwind end do + + if( regional_mpas .and. (bdyMaskEdge(iEdge) == nRelaxZone) .or. (bdyMaskEdge(iEdge) == nRelaxZone-1) ) then + flux_arr(:,iEdge) = 0. + end if + end if end do From 377e7dfb27141b342f4bd566e03a542aa6f49680 Mon Sep 17 00:00:00 2001 From: Kelly Werner Date: Mon, 17 Sep 2018 14:57:26 -0600 Subject: [PATCH 043/737] Modifications made to YSU PBL physics to unify with WRF YSU code Toward the effort to unify physics schemes between the MPAS and WRF models, the YSU PBL scheme (module_bl_ysu.F) was modified to include changes necessary to allow it to run in both models. In areas where the models differ (e.g., in their handling of 'dx'), there are if-defs put around the code to ensure that it's handled correctly for the model in which it is running. Results before and after are NOT bit-for-bit, however, as this update includes some updates to the actual physics - in order to bring MPAS physics up-to-date with recently modified WRF physics. --- .../physics/physics_wrf/module_bl_ysu.F | 279 +++++++++++++----- 1 file changed, 203 insertions(+), 76 deletions(-) diff --git a/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F b/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F index 9061651398..241b0f0a60 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F +++ b/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F @@ -1,12 +1,7 @@ !================================================================================================================= -!module_bl_ysu.F was originally copied from ./phys/module_bl_ysu.F from WRF version 3.8.1. -!Laura D. Fowler (laura@ucar.edu) / 2016-10-26. - -!modifications to sourcecode for MPAS: -! * calculated the dry hydrostatic pressure using the dry air density. -! * added outputs of the vertical diffusivity coefficients. -! Laura D. Fowler (laura@ucar.edu) / 2016-10-26. - +!module_bl_ysu.F was modified to integrate MPAS-specific code +!integration took place between WRF Master Repository (from 28Feb2018) and MPAS HWT Repository (from 27Feb2018) +!WRF version is >V3.9.1.1 and MPAS module_bl_ysu.F was originally modified from WRFV3.8.1 !================================================================================================================= !WRF:model_layer:physics ! @@ -27,7 +22,7 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & rqvblten,rqcblten,rqiblten,flag_qi, & cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, & dz8w,psfc, & - znu,znw,mut,p_top, & + znu,znw,p_top, & znt,ust,hpbl,psim,psih, & xland,hfx,qfx,wspd,br, & dt,kpbl2d, & @@ -42,10 +37,7 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & its,ite, jts,jte, kts,kte, & !optional regime & -#if defined(mpas) - !MPAS specific optional arguments for additional diagnostics: ,rho,kzhout,kzmout,kzqout & -#endif ) !------------------------------------------------------------------------------- implicit none @@ -207,9 +199,6 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & intent(in ) :: znu, & znw ! - real, dimension( ims:ime, jms:jme ) , & - optional , & - intent(in ) :: mut ! real, optional, intent(in ) :: p_top ! @@ -228,65 +217,52 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & dvsfc, & dtsfc, & dqsfc -#if defined(mpas) -!MPAS specific optional arguments for additional diagnostics: real,intent(in),dimension(ims:ime,kms:kme,jms:jme),optional:: rho real:: rho_d real,intent(out),dimension(ims:ime,kms:kme,jms:jme),optional:: kzhout,kzmout,kzqout - do j = jts,jte - do k = kts,kte - do i = its,ite - kzhout(i,k,j) = 0. - kzmout(i,k,j) = 0. - kzqout(i,k,j) = 0. - enddo - enddo - enddo -!MPAS specific end. -#endif - + if(present(kzhout) .and. present(kzmout) .and. present(kzqout)) then + do j = jts,jte + do k = kts,kte + do i = its,ite + kzhout(i,k,j) = 0. + kzmout(i,k,j) = 0. + kzqout(i,k,j) = 0. + enddo + enddo + enddo + endif ! qv2d(its:ite,:) = 0.0 ! do j = jts,jte - if(present(mut))then -! -! For ARW we will replace p and p8w with dry hydrostatic pressure -! - do k = kts,kte+1 - do i = its,ite - if(k.le.kte)pdh(i,k) = mut(i,j)*znu(k) + p_top - pdhi(i,k) = mut(i,j)*znw(k) + p_top - enddo + do k = kts,kte+1 + do i = its,ite + if(k.le.kte)pdh(i,k) = p3d(i,k,j) + pdhi(i,k) = p3di(i,k,j) enddo - elseif(present(rho)) then - 203 format(1x,i4,1x,i2,10(1x,e15.8)) + enddo !For MPAS, we replace the hydrostatic pressures defined at theta and w points by !the dry hydrostatic pressures (Laura D. Fowler): + if(present(rho)) then + 203 format(1x,i4,1x,i2,10(1x,e15.8)) k = kte+1 do i = its,ite - pdhi(i,k) = p3di(i,k,j) + pdhi(i,k) = p3di(i,k,j) enddo do k = kte,kts,-1 do i = its,ite rho_d = rho(i,k,j) / (1. + qv3d(i,k,j)) if(k.le.kte) pdhi(i,k) = pdhi(i,k+1) + g*rho_d*dz8w(i,k,j) enddo - enddo + enddo do k = kts,kte do i = its,ite pdh(i,k) = 0.5*(pdhi(i,k) + pdhi(i,k+1)) enddo enddo -!MPAS specific end. - else - do k = kts,kte+1 - do i = its,ite - if(k.le.kte)pdh(i,k) = p3d(i,k,j) - pdhi(i,k) = p3di(i,k,j) - enddo - enddo endif +!MPAS specific end. + do k = kts,kte do i = its,ite qv2d(i,k) = qv3d(i,k,j) @@ -323,7 +299,6 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & ,ysu_topdown_pblmix=ysu_topdown_pblmix & ,ctopo=ctopo(ims,j),ctopo2=ctopo2(ims,j) & #if defined(mpas) -!MPAS specific optional arguments for additional diagnostics: ,kzh=kzhout(ims,kms,j) & ,kzm=kzmout(ims,kms,j) & ,kzq=kzqout(ims,kms,j) & @@ -367,10 +342,7 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & its,ite, jts,jte, kts,kte, & !optional regime & -#if defined(mpas) - !MPAS specific optional arguments for additional diagnostics: ,kzh,kzm,kzq & -#endif ) !------------------------------------------------------------------------------- implicit none @@ -411,10 +383,10 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ! revised thermal, shin et al. mon. wea. rev. , songyou hong, aug 2011 ! ==> reduce the thermal strength when z1 < 0.1 h ! revised prandtl number for free convection, dudhia, mar 2012 -! ==> pr0 = 1 + bke (=0.272) when newtral, kh is reduced +! ==> pr0 = 1 + bke (=0.272) when neutral, kh is reduced ! minimum kzo = 0.01, lo = min (30m,delz), hong, mar 2012 ! ==> weaker mixing when stable, and les resolution in vertical -! gz1oz0 is removed, and phim phih are ln(z1/z0)-phim,h, hong, mar 2012 +! gz1oz0 is removed, and psim psih are ln(z1/z0)-psim,h, hong, mar 2012 ! ==> consider thermal z0 when differs from mechanical z0 ! a bug fix in wscale computation in stable bl, sukanta basu, jun 2012 ! ==> wscale becomes small with height, and less mixing in stable bl @@ -605,14 +577,17 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & real :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, & dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr, & prfac,prfac2,phim8z,radsum,tmp1,templ,rvls,temps,ent_eff, & - rcldb,bruptmp,radflux + rcldb,bruptmp,radflux,vconvlim,vconvnew,fluxc,vconvc,vconv +!topo-corr + real, dimension( ims:ime, kms:kme ) :: fric, & + tke_ysu,& + el_ysu,& + shear_ysu,& + buoy_ysu + real, dimension( ims:ime ) :: pblh_ysu,& + vconvfx ! -#if defined(mpas) -!MPAS specific begin: real,intent(out),dimension(ims:ime,kms:kme),optional::kzh,kzm,kzq -!MPAS specific end. -#endif - ! !------------------------------------------------------------------------------- ! @@ -716,7 +691,6 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & wstar3_2(i) = 0.0 enddo ! -!MPAS specific begin: Added initialization of local vertical diffusion coefficients: if(present(kzh) .and. present(kzm) .and. present(kzq)) then do k = kts,kte do i = its,ite @@ -727,7 +701,6 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & enddo enddo endif -!MPAS specific end. ! do k = kts,klpbl do i = its,ite @@ -1387,18 +1360,62 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & enddo enddo ! - do i = its,ite ! paj: ctopo=1 if topo_wind=0 (default) -! mchen add this line to make sure NMM can still work with YSU PBL - if(present(ctopo)) then - ad(i,1) = 1.+ctopo(i)*ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & - *(wspd1(i)/wspd(i))**2 - else - ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & +!raquel---paj tke code (could be replaced with shin-hong tke in future + do i = its,ite + do k= kts, kte-1 + shear_ysu(i,k)=xkzm(i,k)*((-hgamu(i)/hpbl(i)+(ux(i,k+1)-ux(i,k))/dza(i,k+1))*(ux(i,k+1)-ux(i,k))/dza(i,k+1) & + + (-hgamv(i)/hpbl(i)+(vx(i,k+1)-vx(i,k))/dza(i,k+1))*(vx(i,k+1)-vx(i,k))/dza(i,k+1)) + buoy_ysu(i,k)=xkzh(i,k)*g*(1.0/thx(i,k))*(-hgamt(i)/hpbl(i)+(thx(i,k+1)-thx(i,k))/dza(i,k+1)) + + zk = karman*zq(i,k+1) + !over pbl + if (k.ge.kpbl(i)) then + rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) + rlamdz = min(dza(i,k+1),rlamdz) + else + !in pbl + rlamdz = 150.0 + endif + el_ysu(i,k) = zk*rlamdz/(rlamdz+zk) + tke_ysu(i,k)=16.6*el_ysu(i,k)*(shear_ysu(i,k)-buoy_ysu(i,k)) + !q2 when q3 positive + if(tke_ysu(i,k).le.0) then + tke_ysu(i,k)=0.0 + else + tke_ysu(i,k)=(tke_ysu(i,k))**0.66 + endif + enddo + !Hybrid pblh of MYNN + !tke is q2 + CALL GET_PBLH(KTS,KTE,pblh_ysu(i),thvx(i,kts:kte),& + & tke_ysu(i,kts:kte),zq(i,kts:kte+1),dzq(i,kts:kte),xland(i)) + +!--- end of paj tke +! compute vconv +! Use Beljaars over land + if (xland(i).lt.1.5) then + fluxc = max(sflux(i),0.0) + vconvc=1. + VCONV = vconvc*(g/thvx(i,1)*pblh_ysu(i)*fluxc)**.33 + else +! for water there is no topo effect so vconv not needed + VCONV = 0. + endif + vconvfx(i) = vconv +!raquel +!ctopo stability correction + fric(i,1)=ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & *(wspd1(i)/wspd(i))**2 - endif - f1(i,1) = ux(i,1)+uox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i) - f2(i,1) = vx(i,1)+vox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i) + if(present(ctopo)) then + vconvnew=0.9*vconvfx(i)+1.5*(max((pblh_ysu(i)-500)/1000.0,0.0)) + vconvlim = min(vconvnew,1.0) + ad(i,1) = 1.+fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim) + else + ad(i,1) = 1.+fric(i,1) + endif + f1(i,1) = ux(i,1)+uox(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 + f2(i,1) = vx(i,1)+vox(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 enddo ! do k = kts,kte-1 @@ -1477,7 +1494,6 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & kpbl1d(i) = kpbl(i) enddo ! -!MPAS specific begin: if(present(kzh) .and. present(kzm) .and. present(kzq)) then do i = its,ite do k = kts,kte @@ -1487,7 +1503,6 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & enddo enddo endif -!MPAS specific end. ! end subroutine ysu2d !------------------------------------------------------------------------------- @@ -1704,5 +1719,117 @@ subroutine ysuinit(rublten,rvblten,rthblten,rqvblten, & ! end subroutine ysuinit !------------------------------------------------------------------------------- +! ================================================================== + + SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea) +! Copied from MYNN PBL + + !--------------------------------------------------------------- + ! NOTES ON THE PBLH FORMULATION + ! + !The 1.5-theta-increase method defines PBL heights as the level at + !which the potential temperature first exceeds the minimum potential + !temperature within the boundary layer by 1.5 K. When applied to + !observed temperatures, this method has been shown to produce PBL- + !height estimates that are unbiased relative to profiler-based + !estimates (Nielsen-Gammon et al. 2008). However, their study did not + !include LLJs. Banta and Pichugina (2008) show that a TKE-based + !threshold is a good estimate of the PBL height in LLJs. Therefore, + !a hybrid definition is implemented that uses both methods, weighting + !the TKE-method more during stable conditions (PBLH < 400 m). + !A variable tke threshold (TKEeps) is used since no hard-wired + !value could be found to work best in all conditions. + !--------------------------------------------------------------- + + INTEGER,INTENT(IN) :: KTS,KTE + REAL, INTENT(OUT) :: zi + REAL, INTENT(IN) :: landsea + REAL, DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D + REAL, DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D + !LOCAL VARS + REAL :: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv + REAL :: delt_thv !delta theta-v; dependent on land/sea point + REAL, PARAMETER :: sbl_lim = 200. !Theta-v PBL lower limit of trust (m). + REAL, PARAMETER :: sbl_damp = 400. !Damping range for averaging with TKE-based PBLH (m). + INTEGER :: I,J,K,kthv,ktke + + !FIND MAX TKE AND MIN THETAV IN THE LOWEST 500 M + k = kts+1 + kthv = 1 + ktke = 1 + maxqke = 0. + minthv = 9.E9 + + DO WHILE (zw1D(k) .LE. 500.) + qtke =MAX(Qke1D(k),0.) ! maximum QKE + IF (maxqke < qtke) then + maxqke = qtke + ktke = k + ENDIF + IF (minthv > thetav1D(k)) then + minthv = thetav1D(k) + kthv = k + ENDIF + k = k+1 + ENDDO + !TKEeps = maxtke/20. = maxqke/40. + TKEeps = maxqke/40. + TKEeps = MAX(TKEeps,0.025) + TKEeps = MIN(TKEeps,0.25) + + !FIND THETAV-BASED PBLH (BEST FOR DAYTIME). + zi=0. + k = kthv+1 + IF((landsea-1.5).GE.0)THEN + ! WATER + delt_thv = 0.75 + ELSE + ! LAND + delt_thv = 1.5 + ENDIF + + zi=0. + k = kthv+1 + DO WHILE (zi .EQ. 0.) + IF (thetav1D(k) .GE. (minthv + delt_thv))THEN + zi = zw1D(k) - dz1D(k-1)* & + & MIN((thetav1D(k)-(minthv + delt_thv))/MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0) + ENDIF + k = k+1 + IF (k .EQ. kte-1) zi = zw1D(kts+1) !EXIT SAFEGUARD + ENDDO + + !print*,"IN GET_PBLH:",thsfc,zi + !FOR STABLE BOUNDARY LAYERS, USE TKE METHOD TO COMPLEMENT THE + !THETAV-BASED DEFINITION (WHEN THE THETA-V BASED PBLH IS BELOW ~0.5 KM). + !THE TANH WEIGHTING FUNCTION WILL MAKE THE TKE-BASED DEFINITION NEGLIGIBLE + !WHEN THE THETA-V-BASED DEFINITION IS ABOVE ~1 KM. + !FIND TKE-BASED PBLH (BEST FOR NOCTURNAL/STABLE CONDITIONS). + + PBLH_TKE=0. + k = ktke+1 + DO WHILE (PBLH_TKE .EQ. 0.) + !QKE CAN BE NEGATIVE (IF CKmod == 0)... MAKE TKE NON-NEGATIVE. + qtke =MAX(Qke1D(k)/2.,0.) ! maximum TKE + qtkem1=MAX(Qke1D(k-1)/2.,0.) + IF (qtke .LE. TKEeps) THEN + PBLH_TKE = zw1D(k) - dz1D(k-1)* & + & MIN((TKEeps-qtke)/MAX(qtkem1-qtke, 1E-6), 1.0) + !IN CASE OF NEAR ZERO TKE, SET PBLH = LOWEST LEVEL. + PBLH_TKE = MAX(PBLH_TKE,zw1D(kts+1)) + !print *,"PBLH_TKE:",i,j,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1) + ENDIF + k = k+1 + IF (k .EQ. kte-1) PBLH_TKE = zw1D(kts+1) !EXIT SAFEGUARD + ENDDO + + !BLEND THE TWO PBLH TYPES HERE: + + wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5 + zi=PBLH_TKE*(1.-wt) + zi*wt + + END SUBROUTINE GET_PBLH +! ================================================================== + end module module_bl_ysu !------------------------------------------------------------------------------- From b93ce0fbd71a4def506087dac7354b0d7da88a89 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 16 Nov 2018 14:13:26 -0700 Subject: [PATCH 044/737] Change length of xtime variables to ShortStrKIND to match netCDF files This commit changes the declared length of xtime and similar timestamp variables in the mpas_io_streams module from StrKIND to ShortStrKIND to match the length of xtime in netCDF files. Prior to this change, because the in-memory xtime variable was larger than the in-file version, reading xtime could result in a string with garbage characters at the end (beginning at character ShortStrKIND+1). These gargbage characters, in turn, could lead to errors in the timekeeping module when trying to parse the string as a timestamp. By matching the in-memory size of the xtime variable with its size in files, we avoid this problem. --- src/framework/mpas_io_streams.F | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/framework/mpas_io_streams.F b/src/framework/mpas_io_streams.F index a7e8b53937..745534a319 100644 --- a/src/framework/mpas_io_streams.F +++ b/src/framework/mpas_io_streams.F @@ -148,12 +148,12 @@ integer function MPAS_seekStream(stream, seekTime, seekPosition, actualTime, max integer :: io_err integer :: i integer :: timeDim - character (len=StrKIND), dimension(:), pointer :: xtimes - character (len=StrKIND) :: strTemp + character (len=ShortStrKIND), dimension(:), pointer :: xtimes + character (len=ShortStrKIND) :: strTemp type (MPAS_Time_type) :: sliceTime, startTime type (MPAS_TimeInterval_type) :: timeDiff, minTimeDiff - character (len=StrKIND) :: xtime0, xtime1, xtime2, xtimeGuess + character (len=ShortStrKIND) :: xtime0, xtime1, xtime2, xtimeGuess type (MPAS_Time_type) :: time0, time1, time2, timeGuess, timeGuessData type (MPAS_TimeInterval_type) :: timeInterval @@ -1510,10 +1510,10 @@ subroutine MPAS_streamAddField_0dChar(stream, field, ierr) idim = ndims allocate(indices(0)) allocate(dimSizes(1)) - dimSizes(1) = 64 + dimSizes(1) = ShortStrKIND dimNames(1) = 'StrLen' - globalDimSize = 64 - totalDimSize = 64 + globalDimSize = ShortStrKIND + totalDimSize = ShortStrKIND if (field % isVarArray) then @@ -1602,7 +1602,7 @@ subroutine MPAS_streamAddField_1dChar(stream, field, ierr) idim = ndims allocate(indices(1)) allocate(dimSizes(2)) - dimSizes(1) = 64 + dimSizes(1) = ShortStrKIND dimNames(1) = 'StrLen' dimSizes(2) = field % dimSizes(1) dimNames(2) = field % dimNames(1) From 598b2e782121c547ce21442ac4a4840fe2a5df3c Mon Sep 17 00:00:00 2001 From: Kelly Werner Date: Fri, 14 Sep 2018 12:30:20 -0600 Subject: [PATCH 045/737] Modifications to unify WRF/MPAS MM5/Monin-Obukhov Scheme --- .../physics/mpas_atmphys_driver_sfclayer.F | 18 ++--- .../physics/physics_wrf/module_sf_sfclay.F | 80 ++++++++++--------- 2 files changed, 49 insertions(+), 49 deletions(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index afe42154d8..c5ace58d06 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -871,14 +871,13 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite rmol = rmol_p , u10 = u10_p , v10 = v10_p , & th2 = th2m_p , t2 = t2m_p , q2 = q2_p , & gz1oz0 = gz1oz0_p , wspd = wspd_p , br = br_p , & - isfflx = isfflx , dx = dx , svp1 = svp1 , & + isfflx = isfflx , dx = dx_p , svp1 = svp1 , & svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , & ep1 = ep_1 , ep2 = ep_2 , karman = karman , & eomeg = eomeg , stbolt = stbolt , P1000mb = P0 , & - dxCell = dx_p , ustm = ustm_p , ck = ck_p , & - cka = cka_p , cd = cd_p , cda = cda_p , & - isftcflx = isftcflx , iz0tlnd = iz0tlnd , & - scm_force_flux = scm_force_flux , & + ustm = ustm_p , ck = ck_p , cka = cka_p , & + cd = cd_p , cda = cda_p , isftcflx = isftcflx , & + iz0tlnd = iz0tlnd , scm_force_flux = scm_force_flux , & 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 & @@ -901,14 +900,13 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite rmol = rmol_sea , u10 = u10_sea , v10 = v10_sea , & th2 = th2m_sea , t2 = t2m_sea , q2 = q2_sea , & gz1oz0 = gz1oz0_sea , wspd = wspd_sea , br = br_sea , & - isfflx = isfflx , dx = dx , svp1 = svp1 , & + isfflx = isfflx , dx = dx_p , svp1 = svp1 , & svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , & ep1 = ep_1 , ep2 = ep_2 , karman = karman , & eomeg = eomeg , stbolt = stbolt , P1000mb = P0 , & - dxCell = dx_p , ustm = ustm_sea , ck = ck_sea , & - cka = cka_sea , cd = cd_sea , cda = cda_sea , & - isftcflx = isftcflx , iz0tlnd = iz0tlnd , & - scm_force_flux = scm_force_flux , & + ustm = ustm_sea , ck = ck_sea , cka = cka_sea , & + cd = cd_sea , cda = cda_sea , isftcflx = isftcflx , & + iz0tlnd = iz0tlnd , scm_force_flux = scm_force_flux , & ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F index 010f54dbf6..bb5daf7a3b 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -33,11 +33,8 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - ustm,ck,cka,cd,cda,isftcflx,iz0tlnd,scm_force_flux & -#if defined(mpas) - ,dxCell & -#endif - ) + ustm,ck,cka,cd,cda, & + isftcflx,iz0tlnd,scm_force_flux) !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- @@ -185,8 +182,14 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: & QGH +#if defined(mpas) + REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: DX +#else REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX +#endif REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT) :: ck,cka,cd,cda @@ -197,19 +200,15 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX -#if defined(mpas) - real,intent(in),dimension(ims:ime,jms:jme),optional:: dxCell - real,intent(inout),dimension(ims:ime,jms:jme):: qsfc - real,intent(out),dimension(ims:ime,jms:jme) :: u10,v10,th2,t2,q2 -#else + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT ) :: QSFC + REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT ) :: U10, & V10, & TH2, & T2, & - Q2, & - QSFC -#endif + Q2 ! LOCAL VARS @@ -221,9 +220,22 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & REAL, DIMENSION( its:ite ) :: dz8w1d + REAL, DIMENSION( its:ite ) :: DX2D + INTEGER :: I,J DO J=jts,jte + +#if defined(mpas) + DO i=its,ite + DX2D(i)=DX(i,j) + ENDDO +#else + DO i=its,ite + DX2D(i)=DX + ENDDo +#endif + DO i=its,ite dz8w1d(I) = dz8w(i,1,j) ENDDO @@ -249,17 +261,13 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & U10(ims,j),V10(ims,j),TH2(ims,j),T2(ims,j), & Q2(ims,j),FLHC(ims,j),FLQC(ims,j),QGH(ims,j), & QSFC(ims,j),LH(ims,j), & - GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX, & + GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT, & P1000mb, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & -#if defined(mpas) - ,isftcflx,iz0tlnd,scm_force_flux, & - USTM(ims,j),CK(ims,j),CKA(ims,j), & - CD(ims,j),CDA(ims,j),dxCell(ims,j) & -#elif ( EM_CORE == 1 ) +#if ( EM_CORE == 1 ) ,isftcflx,iz0tlnd,scm_force_flux, & USTM(ims,j),CK(ims,j),CKA(ims,j), & CD(ims,j),CDA(ims,j) & @@ -285,11 +293,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & isftcflx, iz0tlnd, scm_force_flux, & -#if defined(mpas) - ustm,ck,cka,cd,cda,dxCell ) -#else ustm,ck,cka,cd,cda ) -#endif !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- @@ -348,7 +352,9 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & TH2,T2,Q2,QSFC,LH - REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX + REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV + + REAL, DIMENSION( its:ite ), INTENT(IN ) :: DX ! MODULE-LOCAL VARIABLES, DEFINED IN SUBROUTINE SFCLAY REAL, DIMENSION( its:ite ), INTENT(IN ) :: dz8w1d @@ -359,10 +365,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & P1D, & T1D -#if defined(mpas) - real,intent(in),dimension(ims:ime),optional:: dxCell -#endif - REAL, OPTIONAL, DIMENSION( ims:ime ) , & INTENT(OUT) :: ck,cka,cd,cda REAL, OPTIONAL, DIMENSION( ims:ime ) , & @@ -539,14 +541,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & VCONV = SQRT(DTHVM) endif ! Mahrt and Sun low-res correction -!MPAS specific (Laura D. Fowler): We take into accound the actual size of individual -!grid-boxes: - if(present(dxCell)) then - vsgd = 0.32 * (max(dxCell(i)/5000.-1.,0.))**.33 - else - VSGD = 0.32 * (max(dx/5000.-1.,0.))**.33 - endif -!MPAS specific end. + VSGD = 0.32 * (max(dx(i)/5000.-1.,0.))**.33 WSPD(I)=SQRT(WSPD(I)*WSPD(I)+VCONV*VCONV+vsgd*vsgd) WSPD(I)=AMAX1(WSPD(I),0.1) BR(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD(I)*WSPD(I)) @@ -796,14 +791,19 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & Cda(I)=(karman/psix)*(karman/psix) ENDIF IF ( PRESENT(IZ0TLND) ) THEN - IF ( IZ0TLND.EQ.1 .AND. (XLAND(I)-1.5).LE.0. ) THEN + IF ( IZ0TLND.GE.1 .AND. (XLAND(I)-1.5).LE.0. ) THEN ZL=ZNT(I) ! CZIL RELATED CHANGES FOR LAND VISC=(1.32+0.009*(SCR3(I)-273.15))*1.E-5 RESTAR=UST(I)*ZL/VISC -! Modify CZIL according to Chen & Zhang, 2009 +! Modify CZIL according to Chen & Zhang, 2009 if iz0tlnd = 1 +! If iz0tlnd = 2, use traditional value - CZIL = 10.0 ** ( -0.40 * ( ZL / 0.07 ) ) + IF ( IZ0TLND.EQ.1 ) THEN + CZIL = 10.0 ** ( -0.40 * ( ZL / 0.07 ) ) + ELSE IF ( IZ0TLND.EQ.2 ) THEN + CZIL = 0.1 + END IF PSIT=GZ1OZ0(I)-PSIH(I)+CZIL*KARMAN*SQRT(RESTAR) PSIQ=GZ1OZ0(I)-PSIH(I)+CZIL*KARMAN*SQRT(RESTAR) @@ -863,6 +863,8 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & ! ZNT(I)=CZO*UST(I)*UST(I)/G+OZO ! Since V3.7 (ref: EC Physics document for Cy36r1) ZNT(I)=CZO*UST(I)*UST(I)/G+0.11*1.5E-5/UST(I) +! V3.9: Add limit as in isftcflx = 1,2 + ZNT(I)=MIN(ZNT(I),2.85e-3) ! COARE 3.5 (Edson et al. 2013) ! CZC = 0.0017*WSPD(I)-0.005 ! CZC = min(CZC,0.028) From bc03e09f3d448f65825e50e58ba460130245af5b Mon Sep 17 00:00:00 2001 From: "Miles A. Curry" Date: Thu, 31 Jan 2019 18:08:03 -0700 Subject: [PATCH 046/737] Well-defined "extra" neighbors for cellsOnCells etc. This commit creates a well-defined "extra" neighbors for the fields: `cellsOnCell`, `edgesOnCell`, `edgesOnEdge`, and `verticiesOnCell`. In this commit all of the well-defined extra neighbors are set to 0. A future commit could alter the value of any of these extra neighbors by altering the parameters `UNUSED_CELL`, `UNUSED_EDGE` or `UNUSED_VERTEX` accordingly. --- src/framework/mpas_stream_manager.F | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/framework/mpas_stream_manager.F b/src/framework/mpas_stream_manager.F index a74c0d643e..f1b88e3848 100644 --- a/src/framework/mpas_stream_manager.F +++ b/src/framework/mpas_stream_manager.F @@ -4787,6 +4787,10 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ implicit none + integer, parameter :: UNUSED_CELL = 0 + integer, parameter :: UNUSED_EDGE = 0 + integer, parameter :: UNUSED_VERTEX = 0 + type (mpas_pool_type), pointer :: allFields type (mpas_pool_type), pointer :: streamFields @@ -4909,7 +4913,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ cellsOnCell % array(j,i) = indexToCellID % array(cellsOnCell_ptr % array(j,i)) end do - cellsOnCell % array(nEdgesOnCell%array(i)+1:maxEdges,i) = nCells+1 + cellsOnCell % array(nEdgesOnCell%array(i)+1:maxEdges,i) = UNUSED_CELL end do cellsOnCell => cellsOnCell % next @@ -4929,7 +4933,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ edgesOnCell % array(j,i) = indexToEdgeID % array(edgesOnCell_ptr % array(j,i)) end do - edgesOnCell % array(nEdgesOnCell%array(i)+1:maxEdges,i) = nEdges+1 + edgesOnCell % array(nEdgesOnCell%array(i)+1:maxEdges,i) = UNUSED_EDGE end do edgesOnCell => edgesOnCell % next @@ -4949,7 +4953,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ verticesOnCell % array(j,i) = indexToVertexID % array(verticesOnCell_ptr % array(j,i)) end do - verticesOnCell % array(nEdgesOnCell%array(i)+1:maxEdges,i) = nVertices+1 + verticesOnCell % array(nEdgesOnCell%array(i)+1:maxEdges,i) = UNUSED_VERTEX end do verticesOnCell => verticesOnCell % next @@ -5003,7 +5007,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ edgesOnEdge % array(j,i) = indexToEdgeID % array(edgesOnEdge_ptr % array(j,i)) end do - edgesOnEdge % array(nEdgesOnEdge%array(i)+1:maxEdges2,i) = nEdges+1 + edgesOnEdge % array(nEdgesOnEdge%array(i)+1:maxEdges2,i) = UNUSED_EDGE end do edgesOnEdge => edgesOnEdge % next From 29dc7bc17e915cdd1b79a691ea1b7df82c4093c7 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 6 Feb 2019 17:12:28 -0700 Subject: [PATCH 047/737] Avoid use of paths in include statements for registry-generated files in MPAS-A In both the atmosphere and init_atmosphere core interface modules, files generated by the registry were assumed to be found in a sub-directory named "inc/". When building MPAS-A in alternate ways, the "*.inc" files generated by the registry program may be located elsewhere. This commit removes the "inc/" prefix for *.inc files included in the core interface modules, which necessitates the addition of -I./inc in the Makefiles for the atmosphere and init_atmosphere cores. --- src/core_atmosphere/Makefile | 4 ++-- src/core_atmosphere/mpas_atm_core_interface.F | 16 ++++++++-------- src/core_init_atmosphere/Makefile | 4 ++-- .../mpas_init_atm_core_interface.F | 16 ++++++++-------- 4 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index 2e77cf8846..0909d55952 100644 --- a/src/core_atmosphere/Makefile +++ b/src/core_atmosphere/Makefile @@ -70,8 +70,8 @@ clean: .F.o: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" - $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) $< > $*.f90 + $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) -I./inc $< > $*.f90 $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./inc -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I../external/esmf_time_f90 endif diff --git a/src/core_atmosphere/mpas_atm_core_interface.F b/src/core_atmosphere/mpas_atm_core_interface.F index 6a9064c60f..6e16141d96 100644 --- a/src/core_atmosphere/mpas_atm_core_interface.F +++ b/src/core_atmosphere/mpas_atm_core_interface.F @@ -55,7 +55,7 @@ subroutine atm_setup_core(core) core % Conventions = 'MPAS' core % source = 'MPAS' -#include "inc/core_variables.inc" +#include "core_variables.inc" end subroutine atm_setup_core @@ -80,7 +80,7 @@ subroutine atm_setup_domain(domain) type (domain_type), pointer :: domain -#include "inc/domain_variables.inc" +#include "domain_variables.inc" end subroutine atm_setup_domain @@ -346,16 +346,16 @@ function atm_setup_block(block) result(ierr) end function atm_setup_block -#include "inc/setup_immutable_streams.inc" +#include "setup_immutable_streams.inc" -#include "inc/block_dimension_routines.inc" +#include "block_dimension_routines.inc" -#include "inc/define_packages.inc" +#include "define_packages.inc" -#include "inc/structs_and_variables.inc" +#include "structs_and_variables.inc" -#include "inc/namelist_call.inc" +#include "namelist_call.inc" -#include "inc/namelist_defines.inc" +#include "namelist_defines.inc" end module atm_core_interface diff --git a/src/core_init_atmosphere/Makefile b/src/core_init_atmosphere/Makefile index 9579f48573..e8f71becfc 100644 --- a/src/core_init_atmosphere/Makefile +++ b/src/core_init_atmosphere/Makefile @@ -99,10 +99,10 @@ clean: .F.o: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) -I./inc $< > $*.f90 $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./inc -I../framework -I../operators -I../external/esmf_time_f90 endif .c.o: diff --git a/src/core_init_atmosphere/mpas_init_atm_core_interface.F b/src/core_init_atmosphere/mpas_init_atm_core_interface.F index 588dacdcb2..892383b0b3 100644 --- a/src/core_init_atmosphere/mpas_init_atm_core_interface.F +++ b/src/core_init_atmosphere/mpas_init_atm_core_interface.F @@ -56,7 +56,7 @@ subroutine init_atm_setup_core(core) core % Conventions = 'MPAS' core % source = 'MPAS' -#include "inc/core_variables.inc" +#include "core_variables.inc" end subroutine init_atm_setup_core @@ -81,7 +81,7 @@ subroutine init_atm_setup_domain(domain) type (domain_type), pointer :: domain -#include "inc/domain_variables.inc" +#include "domain_variables.inc" end subroutine init_atm_setup_domain @@ -396,16 +396,16 @@ function init_atm_setup_block(block) result(ierr) end function init_atm_setup_block -#include "inc/setup_immutable_streams.inc" +#include "setup_immutable_streams.inc" -#include "inc/block_dimension_routines.inc" +#include "block_dimension_routines.inc" -#include "inc/define_packages.inc" +#include "define_packages.inc" -#include "inc/structs_and_variables.inc" +#include "structs_and_variables.inc" -#include "inc/namelist_call.inc" +#include "namelist_call.inc" -#include "inc/namelist_defines.inc" +#include "namelist_defines.inc" end module init_atm_core_interface From 756f03e0c47c5e5f57617e5baf0c67b17d5b6f60 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 19 Feb 2019 15:53:34 -0700 Subject: [PATCH 048/737] Add new MPAS_sanitize_string routine to mpas_c_interfacing The MPAS_sanitize_string routine converts C null characters in a Fortran string to spaces. --- src/framework/mpas_c_interfacing.F | 31 ++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/src/framework/mpas_c_interfacing.F b/src/framework/mpas_c_interfacing.F index dd885600f4..f6dc97edc5 100644 --- a/src/framework/mpas_c_interfacing.F +++ b/src/framework/mpas_c_interfacing.F @@ -4,6 +4,37 @@ module mpas_c_interfacing contains + !----------------------------------------------------------------------- + ! routine mpas_sanitize_string + ! + !> \brief Converts C null characters in a Fortran string to spaces + !> \author Michael Duda + !> \date 19 February 2019 + !> \details + !> Converts all C null characters in a Fortran string to spaces. + !> This may be useful for strings that were provided by C code through other + !> Fortran code external to MPAS. + ! + !----------------------------------------------------------------------- + subroutine mpas_sanitize_string(str) + + use iso_c_binding, only : c_null_char + + implicit none + + character(len=*), intent(inout) :: str + + integer :: i + + do i=1,len(str) + if (str(i:i) == c_null_char) then + str(i:i) = ' ' + end if + end do + + end subroutine mpas_sanitize_string + + !----------------------------------------------------------------------- ! routine mpas_c_to_f_string ! From 9bd56e6d121f4bf2742ba5acc3da4ceff6bee5f4 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 19 Feb 2019 15:55:02 -0700 Subject: [PATCH 049/737] Remove C null characters from strings read by PIO The PIO2 library fills in unused characters of a string variable with C null characters, and replaces C null characters with spaces when reading strings. However, the PIO1 library does not perform these conversions. Consequently, if a file written by the PIO2 library is read by the PIO1 library, C null characters may be present in the resulting Fortran string. Under the assumption that C null characters will generally not be expected or handled in MPAS (e.g., in timestamp strings), this commit makes calls to MPAS_sanitize_string to convert any C null characters in strings read by PIO into spaces. --- src/framework/mpas_io.F | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/framework/mpas_io.F b/src/framework/mpas_io.F index 2c17d3c661..7fcec3a76b 100644 --- a/src/framework/mpas_io.F +++ b/src/framework/mpas_io.F @@ -2187,6 +2187,8 @@ end subroutine MPAS_io_get_var_real5d subroutine MPAS_io_get_var_char0d(handle, fieldname, val, ierr) + use mpas_c_interfacing, only : MPAS_sanitize_string + implicit none type (MPAS_IO_Handle_type), intent(inout) :: handle @@ -2198,12 +2200,15 @@ subroutine MPAS_io_get_var_char0d(handle, fieldname, val, ierr) if (present(ierr)) ierr = MPAS_IO_NOERR call MPAS_io_get_var_generic(handle, fieldname, charVal=val, ierr=ierr) + call MPAS_sanitize_string(val) end subroutine MPAS_io_get_var_char0d subroutine MPAS_io_get_var_char1d(handle, fieldname, val, ierr) + use mpas_c_interfacing, only : MPAS_sanitize_string + implicit none type (MPAS_IO_Handle_type), intent(inout) :: handle @@ -2211,10 +2216,15 @@ subroutine MPAS_io_get_var_char1d(handle, fieldname, val, ierr) character (len=*), dimension(:), intent(out) :: val integer, intent(out), optional :: ierr + integer :: i + ! call mpas_log_write('Called MPAS_io_get_var_char1d()') if (present(ierr)) ierr = MPAS_IO_NOERR call MPAS_io_get_var_generic(handle, fieldname, charArray1d=val, ierr=ierr) + do i=1,size(val) + call MPAS_sanitize_string(val(i)) + end do end subroutine MPAS_io_get_var_char1d From 2c3faa5f45dfdd0499f1b43d8489ef42fe2fc594 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 21 Feb 2019 16:46:11 -0700 Subject: [PATCH 050/737] Increment version number to 6.2 --- LICENSE | 2 +- README.md | 2 +- src/core_atmosphere/Registry.xml | 2 +- src/core_init_atmosphere/Registry.xml | 2 +- src/core_landice/Registry.xml | 2 +- src/core_ocean/Registry.xml | 2 +- src/core_seaice/Registry.xml | 2 +- src/core_sw/Registry.xml | 2 +- src/core_test/Registry.xml | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) diff --git a/LICENSE b/LICENSE index f6af5ee0a0..c8060c7f24 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013-2018, Los Alamos National Security, LLC (LANS) (Ocean: LA-CC-13-047; +Copyright (c) 2013-2019, Los Alamos National Security, LLC (LANS) (Ocean: LA-CC-13-047; Land Ice: LA-CC-13-117) and the University Corporation for Atmospheric Research (UCAR). All rights reserved. diff --git a/README.md b/README.md index 138deec514..b233bf28d0 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -MPAS-v6.1 +MPAS-v6.2 ==== The Model for Prediction Across Scales (MPAS) is a collaborative project for diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 7fc056c536..e5bdcc370f 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 670439f648..c18e576c5a 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 5a4936794d..3deaa6bff4 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index bde204347f..d8ff74a773 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -1,5 +1,5 @@ - + - + - + diff --git a/src/core_test/Registry.xml b/src/core_test/Registry.xml index fbdaaebff2..46f51ec59c 100644 --- a/src/core_test/Registry.xml +++ b/src/core_test/Registry.xml @@ -1,5 +1,5 @@ - + From 49f03646ef60d667e84e34fcbe95fbb1ff32b1fc Mon Sep 17 00:00:00 2001 From: JJ Guerrette Date: Tue, 26 Feb 2019 00:29:01 +0000 Subject: [PATCH 051/737] Add temperature and spechum fields in JEDI DA package These fields are used to produce analysis fields in the JEDI data assimilation framework. They are only used in that external framework and thus need to be in a package. --- src/core_atmosphere/Registry.xml | 15 +++++++++++++++ src/core_atmosphere/mpas_atm_core_interface.F | 9 +++++++++ 2 files changed, 24 insertions(+) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 05c514360d..f31382aa42 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -336,6 +336,12 @@ possible_values="Non-negative real values"/> + + + @@ -352,6 +358,7 @@ + @@ -1439,9 +1446,17 @@ + + + + diff --git a/src/core_atmosphere/mpas_atm_core_interface.F b/src/core_atmosphere/mpas_atm_core_interface.F index 6a9064c60f..7272a6daf2 100644 --- a/src/core_atmosphere/mpas_atm_core_interface.F +++ b/src/core_atmosphere/mpas_atm_core_interface.F @@ -119,6 +119,7 @@ function atm_setup_packages(configs, packages, iocontext) result(ierr) logical, pointer :: iauActive character(len=StrKIND), pointer :: config_iau_option + logical, pointer :: config_jedi_da, jedi_daActive ierr = 0 @@ -134,6 +135,14 @@ function atm_setup_packages(configs, packages, iocontext) result(ierr) iauActive = .false. end if + nullify(config_jedi_da) + call mpas_pool_get_config(configs, 'config_jedi_da', config_jedi_da) + + nullify(jedi_daActive) + call mpas_pool_get_package(packages, 'jedi_daActive', jedi_daActive) + + jedi_daActive = config_jedi_da + #ifdef DO_PHYSICS !check that all the physics options are correctly defined and that at !least one physics parameterization is called (using the logical moist_physics): From 5a6867195f13d11ae892871ddb3316ce01ad0d13 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 26 Feb 2019 14:35:18 -0700 Subject: [PATCH 052/737] removed need for -DROTATED_GRID in the build for the mtn_wave test case. This was accomplished by adding a new 1D array (v_init) that compliments u_init, and adopting the standard vector definition V_init = u_init * cos(angleEdge) + v_init * sin(angleEdge) in the code. Registry additions add the v_init(nVertLevels) array and other changes introduce the vector definition. --- src/core_atmosphere/Registry.xml | 5 ++ .../dynamics/mpas_atm_time_integration.F | 16 +++---- src/core_init_atmosphere/Registry.xml | 2 + .../mpas_init_atm_cases.F | 48 ++++++------------- 4 files changed, 28 insertions(+), 43 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 7fc056c536..597e3ceee6 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -422,6 +422,7 @@ + @@ -546,6 +547,7 @@ + @@ -1263,6 +1265,9 @@ + + diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index f642d0fb15..b27fd76695 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -3953,7 +3953,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge - real (kind=RKIND), dimension(:), pointer :: latCell, latEdge, angleEdge, u_init + real (kind=RKIND), dimension(:), pointer :: latCell, latEdge, angleEdge, u_init, v_init integer, dimension(:,:), pointer :: advCellsForEdge integer, dimension(:), pointer :: nAdvCellsForEdge @@ -4059,6 +4059,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) call mpas_pool_get_array(mesh, 'u_init', u_init) + call mpas_pool_get_array(mesh, 'v_init', v_init) call mpas_pool_get_array(mesh, 't_init', t_init) call mpas_pool_get_array(mesh, 'qv_init', qv_init) @@ -4126,7 +4127,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, 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, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & + 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, & @@ -4151,7 +4152,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm 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, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & + 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, & @@ -4235,7 +4236,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nCells+1) :: latCell real (kind=RKIND), dimension(nEdges+1) :: latEdge real (kind=RKIND), dimension(nEdges+1) :: angleEdge - real (kind=RKIND), dimension(nVertLevels) :: u_init + real (kind=RKIND), dimension(nVertLevels) :: u_init, v_init integer, dimension(15,nEdges+1) :: advCellsForEdge integer, dimension(nEdges+1) :: nAdvCellsForEdge @@ -4619,11 +4620,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm cell2 = cellsOnEdge(2,iEdge) do k=1,nVertLevels -#ifdef ROTATED_GRID - u_mix(k) = u(k,iEdge) - u_init(k) * sin( angleEdge(iEdge) ) -#else - u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) -#endif + u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & + - v_init(k) * sin( angleEdge(iEdge) ) end do do k=2,nVertLevels-1 diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 670439f648..fade9cdf89 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -469,6 +469,7 @@ + @@ -617,6 +618,7 @@ + diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 25b2b9719d..bff9aa9f38 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -75,29 +75,6 @@ subroutine init_atm_setup_case(domain, stream_manager) call mpas_pool_get_config(domain % blocklist % configs, 'config_init_case', config_init_case) - ! - ! Do some quick checks to make sure compile options are compatible with the chosen test case - ! - if (config_init_case == 6) then -#ifndef ROTATED_GRID - call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) - call mpas_log_write('To initialize and run the mountain wave test case (case 6),', messageType=MPAS_LOG_ERR) - call mpas_log_write(' please clean and re-compile init_atmosphere with -DROTATED_GRID', messageType=MPAS_LOG_ERR) - call mpas_log_write(' added to the specification of MODEL_FORMULATION', messageType=MPAS_LOG_ERR) - call mpas_log_write(' at the top of the Makefile.', messageType=MPAS_LOG_ERR) - call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_CRIT) -#endif - else -#ifdef ROTATED_GRID - call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) - call mpas_log_write('Only test case 6 should use code compiled with -DROTATED_GRID', messageType=MPAS_LOG_ERR) - call mpas_log_write(' specified in the Makefile.', messageType=MPAS_LOG_ERR) - call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_CRIT) -#endif - end if - - - if ((config_init_case == 1) .or. (config_init_case == 2) .or. (config_init_case == 3)) then call mpas_log_write(' Jablonowski and Williamson baroclinic wave test case ') @@ -1857,7 +1834,7 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm real (kind=RKIND) :: d1, d2, d3, cof1, cof2 - real (kind=RKIND) :: um, us, rcp, rcv + real (kind=RKIND) :: um, vm, us, vs, rcp, rcv real (kind=RKIND) :: xmid, temp, pres, a_scale real (kind=RKIND) :: xi, xa, xc, xla, zinv, xn2, xn2m, xn2l, sm, dzh, dzht, dzmin, z_edge, z_edge3 @@ -1879,7 +1856,7 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag real (kind=RKIND), pointer :: cf1, cf2, cf3 real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta - real (kind=RKIND), dimension(:), pointer :: u_init, angleEdge, fEdge, fVertex + real (kind=RKIND), dimension(:), pointer :: u_init, v_init, angleEdge, fEdge, fVertex call mpas_pool_get_array(mesh, 'xCell', xCell) @@ -1912,6 +1889,7 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) call mpas_pool_get_array(mesh, 't_init', t_init) call mpas_pool_get_array(mesh, 'u_init', u_init) + call mpas_pool_get_array(mesh, 'v_init', v_init) call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) call mpas_pool_get_array(mesh, 'fEdge', fEdge) call mpas_pool_get_array(mesh, 'fVertex', fVertex) @@ -2160,8 +2138,8 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag xn2m = 0.0000 xn2l = 0.0001 - um = 10. - us = 0. + vm = 10. + um = 0. do i=1,nCells do k=1,nz1 @@ -2185,13 +2163,15 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag do k=1,nz1 ztemp = .25*( zgrid(k,cell1 )+zgrid(k+1,cell1 ) & +zgrid(k,cell2)+zgrid(k+1,cell2)) - u(k,i) = um - if(i == 1 ) u_init(k) = u(k,i) - us -#ifdef ROTATED_GRID - u(k,i) = sin(angleEdge(i)) * (u(k,i) - us) -#else - u(k,i) = cos(angleEdge(i)) * (u(k,i) - us) -#endif + u(k,i) = vm + + if(i == 1 ) then + v_init(k) = vm + u_init(k) = 0. + end if + + u(k,i) = vm*sin(angleEdge(i)) + um*cos(angleEdge(i)) + end do end if end do From 7f06d1c53c91556fb4c19d680831e6dba00fd329 Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Tue, 26 Feb 2019 21:36:05 -0700 Subject: [PATCH 053/737] Update compass scripts to support python 3 --- testing_and_setup/compass/clean_testcase.py | 24 +- testing_and_setup/compass/list_testcases.py | 37 +-- .../compass/manage_regression_suite.py | 157 +++++------ testing_and_setup/compass/setup_testcase.py | 253 +++++++++--------- 4 files changed, 235 insertions(+), 236 deletions(-) diff --git a/testing_and_setup/compass/clean_testcase.py b/testing_and_setup/compass/clean_testcase.py index 499c94f645..2f23bad93c 100755 --- a/testing_and_setup/compass/clean_testcase.py +++ b/testing_and_setup/compass/clean_testcase.py @@ -6,6 +6,10 @@ It will remove directories / driver scripts that were generated as part of setting up a test case. """ + +from __future__ import absolute_import, division, print_function, \ + unicode_literals + import sys import os import shutil @@ -51,16 +55,16 @@ if not args.case_num and (not args.core and not args.configuration and not args.resolution and not args.test) \ and not args.clean_all: - print 'Must be run with either the --case_number argument, the ' \ - '--all argument, or all of the core, configuration, ' \ - 'resolution, and test arguments.' + print('Must be run with either the --case_number argument, the ' + '--all argument, or all of the core, configuration, ' + 'resolution, and test arguments.') parser.error(' Invalid configuration. Exiting...') if args.case_num and args.core and args.configuration and args.resoltuion \ and args.test and args.clean_all: - print 'Can only be configured with either --case_number (-n), --all ' \ - '(-a), or all of --core (-o), --configuration (-c), ' \ - '--resolution (-r), and --test (-t).' + print('Can only be configured with either --case_number (-n), --all ' + '(-a), or all of --core (-o), --configuration (-c), ' + '--resolution (-r), and --test (-t).') parser.error(' Invalid configuration. Too many options used. ' 'Exiting...') @@ -153,8 +157,8 @@ if os.path.isdir('{}/{}'.format(work_dir, case_base)): shutil.rmtree('{}/{}'.format(work_dir, case_base)) write_history = True - print ' -- Removed case {}/{}'.format(work_dir, - case_base) + print(' -- Removed case {}/{}'.format(work_dir, + case_base)) # Process files elif config_root.tag == 'driver_script': @@ -164,8 +168,8 @@ if os.path.exists('{}/{}'.format(work_dir, script_name)): os.remove('{}/{}'.format(work_dir, script_name)) write_history = True - print ' -- Removed driver script ' \ - '{}/{}'.format(work_dir, script_name) + print(' -- Removed driver script ' + '{}/{}'.format(work_dir, script_name)) del config_tree del config_root diff --git a/testing_and_setup/compass/list_testcases.py b/testing_and_setup/compass/list_testcases.py index 2d744910d7..847b1d54fd 100755 --- a/testing_and_setup/compass/list_testcases.py +++ b/testing_and_setup/compass/list_testcases.py @@ -12,6 +12,9 @@ it will only print the flags needed to setup that specific test case. """ +from __future__ import absolute_import, division, print_function, \ + unicode_literals + import os import fnmatch import argparse @@ -19,9 +22,7 @@ import re -def print_case(quiet, args, core_dir, config_dir, res_dir, test_dir, case_num, - print_num): # {{{ - # Xylar: the indentation got out of hand and I had to make this a function +def print_case(quiet, args, core_dir, config_dir, res_dir, test_dir, case_num): # Print the options if a case file was found. if not quiet: @@ -30,16 +31,14 @@ def print_case(quiet, args, core_dir, config_dir, res_dir, test_dir, case_num, config_dir): if (not args.resolution) or re.match(args.resolution, res_dir): if (not args.test) or re.match(args.test, test_dir): - print " {:d}: -o {} -c {} -r {} -t {}".format( - case_num, core_dir, config_dir, res_dir, test_dir) - if quiet and case_num == print_num: - print "-o {} -c {} -r {} -t {}".format( - core_dir, config_dir, res_dir, test_dir) + print(" {:d}: -o {} -c {} -r {} -t {}".format( + case_num, core_dir, config_dir, res_dir, test_dir)) + if quiet and case_num == args.number: + print("-o {} -c {} -r {} -t {}".format( + core_dir, config_dir, res_dir, test_dir)) case_num += 1 return case_num -# }}} - if __name__ == "__main__": # Define and process input arguments @@ -55,25 +54,16 @@ def print_case(quiet, args, core_dir, config_dir, res_dir, test_dir, case_num, help="Resolution to search for", metavar="RES") parser.add_argument("-t", "--test", dest="test", help="Test name to search for", metavar="TEST") - parser.add_argument("-n", "--number", dest="number", + parser.add_argument("-n", "--number", dest="number", type=int, help="If set, script will print the flags to use a " "the N'th configuraiton.") args = parser.parse_args() - quiet = False - - try: - print_num = 0 - if args.number: - quiet = True - print_num = int(args.number) - except ValueError: - args.number = 0 - print_num = 0 + quiet = args.number is not None if not quiet: - print "Available test cases are:" + print("Available test cases are:") # Start case numbering at 1 case_num = 1 @@ -118,7 +108,6 @@ def print_case(quiet, args, core_dir, config_dir, res_dir, test_dir, case_num, if do_print: case_num = print_case( quiet, args, core_dir, config_dir, - res_dir, test_dir, case_num, - print_num) + res_dir, test_dir, case_num) # vim: foldmethod=marker ai ts=4 sts=4 et sw=4 ft=python diff --git a/testing_and_setup/compass/manage_regression_suite.py b/testing_and_setup/compass/manage_regression_suite.py index b2c014cb81..cb25c67d34 100755 --- a/testing_and_setup/compass/manage_regression_suite.py +++ b/testing_and_setup/compass/manage_regression_suite.py @@ -12,6 +12,9 @@ for each individual test case, and the run script that runs all test cases. """ +from __future__ import absolute_import, division, print_function, \ + unicode_literals + import sys import os import fnmatch @@ -26,8 +29,8 @@ def process_test_setup(test_tag, config_file, work_dir, model_runtime, if verbose: stdout = open(work_dir + '/manage_regression_suite.py.out', 'a') stderr = stdout - print ' Script setup outputs to {}'.format( - work_dir + '/manage_regression_suite.py.out') + print(' Script setup outputs to {}'.format( + work_dir + '/manage_regression_suite.py.out')) else: dev_null = open('/dev/null', 'a') stderr = dev_null @@ -37,40 +40,40 @@ def process_test_setup(test_tag, config_file, work_dir, model_runtime, try: test_name = test_tag.attrib['name'] except KeyError: - print "ERROR: tag is missing 'name' attribute." - print "Exiting..." + print("ERROR: tag is missing 'name' attribute.") + print("Exiting...") sys.exit(1) try: test_core = test_tag.attrib['core'] except KeyError: - print "ERROR: tag with name '{}' is missing 'core' " \ - "attribute.".format(test_name) - print "Exiting..." + print("ERROR: tag with name '{}' is missing 'core' " + "attribute.".format(test_name)) + print("Exiting...") sys.exit(1) try: test_configuration = test_tag.attrib['configuration'] except KeyError: - print "ERROR: tag with name '{}' is missing 'configuration' " \ - "attribute.".format(test_name) - print "Exiting..." + print("ERROR: tag with name '{}' is missing 'configuration' " + "attribute.".format(test_name)) + print("Exiting...") sys.exit(1) try: test_resolution = test_tag.attrib['resolution'] except KeyError: - print "ERROR: tag with name '{}' is missing 'resolution' " \ - "attribute.".format(test_name) - print "Exiting..." + print("ERROR: tag with name '{}' is missing 'resolution' " + "attribute.".format(test_name)) + print("Exiting...") sys.exit(1) try: test_test = test_tag.attrib['test'] except KeyError: - print "ERROR: tag with name '{}' is missing 'test' " \ - "attribute.".format(test_name) - print "Exiting..." + print("ERROR: tag with name '{}' is missing 'test' " + "attribute.".format(test_name)) + print("Exiting...") sys.exit(1) # Determine the file name for the test case output @@ -91,8 +94,8 @@ def process_test_setup(test_tag, config_file, work_dir, model_runtime, '-r', test_resolution, '-t', test_test, '-m', model_runtime, '-b', baseline_dir], stdout=stdout, stderr=stderr) - print " -- Setup case '{}': -o {} -c {} -r {} -t {}".format( - test_name, test_core, test_configuration, test_resolution, test_test) + print(" -- Setup case '{}': -o {} -c {} -r {} -t {}".format( + test_name, test_core, test_configuration, test_resolution, test_test)) # Write step into suite script to cd into the base of the regression suite suite_script.write("os.chdir(base_path)\n") @@ -111,8 +114,8 @@ def process_test_setup(test_tag, config_file, work_dir, model_runtime, try: script_name = script.attrib['name'] except KeyError: - print "ERROR: