From 02c8015ec21f181b499239ef1316b0a1985be9ea Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 27 Sep 2016 17:22:48 -0600 Subject: [PATCH 001/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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/182] 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 afae72d1ceb17f54cc85f0802e44c05f45dd450d Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 21 Dec 2017 14:29:50 -0800 Subject: [PATCH 043/182] Remove -DUSE_PIO2 from FCINCLUDES to avoid assembler output with XL compilers The XL Fortran compiler creates assembler (*.s) files rather than object (*.o) files when -DUSE_PIO2 is present in the build options. Not all uses of -D seem to lead to this behavior: for example, -DUS and -DS lead to the generation of assembler rather than object files, but -DfooS does not. Since MPAS is essentially always built with the XL compilers with GEN_F90=true, we only need -DUSE_PIO2 to be included in the definition of CPPFLAGS, and the include paths only need to be added to FCINCLUDES. --- Makefile | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index baceb05cb7..2def549258 100644 --- a/Makefile +++ b/Makefile @@ -401,8 +401,8 @@ FCINCLUDES = LIBS = ifneq ($(wildcard $(PIO)/lib), ) # Check for newer PIO version ifeq "$(USE_PIO2)" "true" - CPPINCLUDES = -DUSE_PIO2 -I$(PIO)/include - FCINCLUDES = -DUSE_PIO2 -I$(PIO)/include + FCINCLUDES = -I$(PIO)/include + override CPPFLAGS += -DUSE_PIO2 LIBS = -L$(PIO)/lib -lpiof -lpioc ifneq ($(wildcard $(PIO)/lib/libgptl.a), ) # Check for GPTL library for PIO2 LIBS += -lgptl @@ -414,8 +414,8 @@ else endif else ifeq "$(USE_PIO2)" "true" - CPPINCLUDES = -DUSE_PIO2 -I$(PIO)/include - FCINCLUDES = -DUSE_PIO2 -I$(PIO)/include + FCINCLUDES = -I$(PIO)/include + override CPPFLAGS += -DUSE_PIO2 LIBS = -L$(PIO) -lpiof -lpioc ifneq ($(wildcard $(PIO)/libgptl.a), ) # Check for GPTL library for PIO2 LIBS += -lgptl From 7a66ba370ec1e1ff8ca7a77898eb43e7becff2cd Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 21 Dec 2017 14:55:52 -0800 Subject: [PATCH 044/182] Explicitly undefine "vector" in CPPFLAGS when building with GEN_F90=true Certain versions of cpp (so far, only those associated with XL build environments) appear to internally define the macro "vector", which leads to build errors for any source file that contains the string "vector", e.g., cpp -P -traditional -D_MPI -DUSE_PIO2 -DCORE_ATMOSPHERE -DMPAS_NAMELIST_SUFFIX=atmosphere -DMPAS_EXE_NAME=atmosphere_model -DSINGLE_PRECISION -DMPAS_NATIVE_TIMERS -DMPAS_GIT_VERSION=v5.1-159-g063c74b-dirty -I/home/mduda/xl-openmpi/include -I/home/mduda/xl-openmpi/include -I/home/mduda/xl-openmpi/include mpas_vector_operations.F > mpas_vector_operations.f90 mpas_vector_operations.F:12:0: error: detected recursion whilst expanding macro "vector" !> \brief MPAS vector operations ^ This commit adds -Uvector to the definition of CPPFLAGS when MPAS is compiled with GEN_F90=true to undefine the "vector" macro, which is never used by MPAS itself. --- Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile b/Makefile index 2def549258..0ab437feec 100644 --- a/Makefile +++ b/Makefile @@ -574,6 +574,7 @@ else endif ifeq "$(GEN_F90)" "true" + override CPPFLAGS += -Uvector GEN_F90_MESSAGE="MPAS generated and was built with intermediate .f90 files." else override GEN_F90=false From 90711d849d7a361fb056f332318f324fed191d69 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 21 Dec 2017 15:47:57 -0800 Subject: [PATCH 045/182] Add "-qufmt=be" to XL Fortran compiler flags For little-endian architectures, we need "-qufmt=be" to perform byteswapping when reading unformatted input files in MPAS-Atmosphere. --- Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 0ab437feec..59b48868e8 100644 --- a/Makefile +++ b/Makefile @@ -13,11 +13,11 @@ xlf: "CC_SERIAL = xlc" \ "CXX_SERIAL = xlcxx" \ "FFLAGS_PROMOTION = -qrealsize=8" \ - "FFLAGS_OPT = -O3" \ + "FFLAGS_OPT = -O3 -qufmt=be" \ "CFLAGS_OPT = -O3" \ "CXXFLAGS_OPT = -O3" \ "LDFLAGS_OPT = -O3" \ - "FFLAGS_DEBUG = -O0 -g -C" \ + "FFLAGS_DEBUG = -O0 -g -C -qufmt=be" \ "CFLAGS_DEBUG = -O0 -g" \ "CXXFLAGS_DEBUG = -O0 -g" \ "LDFLAGS_DEBUG = -O0 -g" \ From e314dbc06c883673ab437271f8ca309e3cb0b6c3 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 21 Dec 2017 15:49:45 -0800 Subject: [PATCH 046/182] Update compiler names in "xlf" build target For ongoing work on newer systems with the XL compilers, we need to use the following compilers and MPI wrappers: xlf2003_r, xlc_r, xlc++_r, mpifort, mpicc, and mpic++. --- Makefile | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Makefile b/Makefile index 59b48868e8..39b99732a5 100644 --- a/Makefile +++ b/Makefile @@ -6,12 +6,12 @@ dummy: xlf: ( $(MAKE) all \ - "FC_PARALLEL = mpxlf90" \ - "CC_PARALLEL = mpcc" \ - "CXX_PARALLEL = mpixlcxx" \ - "FC_SERIAL = xlf90" \ - "CC_SERIAL = xlc" \ - "CXX_SERIAL = xlcxx" \ + "FC_PARALLEL = mpifort" \ + "CC_PARALLEL = mpicc" \ + "CXX_PARALLEL = mpic++" \ + "FC_SERIAL = xlf2003_r" \ + "CC_SERIAL = xlc_r" \ + "CXX_SERIAL = xlc++_r" \ "FFLAGS_PROMOTION = -qrealsize=8" \ "FFLAGS_OPT = -O3 -qufmt=be" \ "CFLAGS_OPT = -O3" \ From 47af56d81595b20a75bb6b9a891e07d929dcb83e Mon Sep 17 00:00:00 2001 From: Philip W Jones Date: Wed, 2 May 2018 15:06:58 -0700 Subject: [PATCH 047/182] added -align array64byte flag to optimized Intel builds to fix reproducibility issues on some machines also replaced deprecated -FR flag with -free for free-form source --- Makefile | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/Makefile b/Makefile index baceb05cb7..c26887839e 100644 --- a/Makefile +++ b/Makefile @@ -144,11 +144,11 @@ ifort: "CC_SERIAL = icc" \ "CXX_SERIAL = icpc" \ "FFLAGS_PROMOTION = -real-size 64" \ - "FFLAGS_OPT = -O3 -convert big_endian -FR" \ + "FFLAGS_OPT = -O3 -convert big_endian -free -align array64byte" \ "CFLAGS_OPT = -O3" \ "CXXFLAGS_OPT = -O3" \ "LDFLAGS_OPT = -O3" \ - "FFLAGS_DEBUG = -g -convert big_endian -FR -CU -CB -check all -fpe0 -traceback" \ + "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback" \ "CFLAGS_DEBUG = -g -traceback" \ "CXXFLAGS_DEBUG = -g -traceback" \ "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ @@ -169,11 +169,11 @@ ifort-scorep: "CC_SERIAL = icc" \ "CXX_SERIAL = icpc" \ "FFLAGS_PROMOTION = -real-size 64" \ - "FFLAGS_OPT = -O3 -g -convert big_endian -FR" \ + "FFLAGS_OPT = -O3 -g -convert big_endian -free -align array64byte" \ "CFLAGS_OPT = -O3 -g" \ "CXXFLAGS_OPT = -O3 -g" \ "LDFLAGS_OPT = -O3 -g" \ - "FFLAGS_DEBUG = -g -convert big_endian -FR -CU -CB -check all -fpe0 -traceback" \ + "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback" \ "CFLAGS_DEBUG = -g -traceback" \ "CXXFLAGS_DEBUG = -g -traceback" \ "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ @@ -194,11 +194,11 @@ ifort-gcc: "CC_SERIAL = gcc" \ "CXX_SERIAL = g++" \ "FFLAGS_PROMOTION = -real-size 64" \ - "FFLAGS_OPT = -O3 -convert big_endian -FR" \ + "FFLAGS_OPT = -O3 -convert big_endian -free -align array64byte" \ "CFLAGS_OPT = -O3" \ "CXXFLAGS_OPT = -O3" \ "LDFLAGS_OPT = -O3" \ - "FFLAGS_DEBUG = -g -convert big_endian -FR -CU -CB -check all -fpe0 -traceback" \ + "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback" \ "CFLAGS_DEBUG = -g" \ "CXXFLAGS_DEBUG = -g" \ "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ @@ -355,13 +355,13 @@ intel-nersc: "CC_SERIAL = cc" \ "CXX_SERIAL = CC" \ "FFLAGS_PROMOTION = -real-size 64" \ - "FFLAGS_OPT = -O3 -convert big_endian -FR" \ + "FFLAGS_OPT = -O3 -convert big_endian -free -align array64byte" \ "CFLAGS_OPT = -O3" \ "CXXFLAGS_OPT = -O3" \ "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -qopenmp" \ - "FFLAGS_DEBUG = -real-size 64 -g -convert big_endian -FR -CU -CB -check all -gen-interfaces -warn interfaces -traceback" \ + "FFLAGS_DEBUG = -real-size 64 -g -convert big_endian -free -CU -CB -check all -gen-interfaces -warn interfaces -traceback" \ "CFLAGS_DEBUG = -g -traceback" \ "CXXFLAGS_DEBUG = -g -traceback" \ "LDFLAGS_DEBUG = -g -traceback" \ From e10d27938d0bc13ff31b7a33fb1897eded29b65a Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Fri, 12 Jan 2018 06:51:15 -0700 Subject: [PATCH 048/182] Similifies restart in terms of a write --- .../mpas_ocn_lagrangian_particle_tracking.F | 32 +++---------------- 1 file changed, 5 insertions(+), 27 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F index 1ac184bd8c..4ac2544425 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F @@ -907,35 +907,13 @@ subroutine ocn_restart_lagrangian_particle_tracking(domain, err)!{{{ ! do restart if this is a restart step if (mpas_stream_mgr_ringing_alarms(domain % streamManager, streamID='lagrPartTrackRestart', & direction=MPAS_STREAM_OUTPUT, ierr=err)) then - call mpas_timer_start("restartLPT") + call mpas_timer_start("restartLPT") LIGHT_DEBUG_WRITE('start ocn_restart_lagrangian_particle_tracking') - ! transfer particles to their appropriate blocks (ioBlock) via MPI - ! note, don't necessarily need to have g_ionSend and g_ionRecv comeout - call mpas_timer_start("build_halos_LPT") - call mpas_particle_list_build_halos(domain, err, 'ioBlock', g_ioProcNeighs) - call mpas_timer_stop("build_halos_LPT") - call mpas_timer_start("transfer_particles_LPT") - call mpas_particle_list_transfer_particles_from_block_to_named_block(domain, err, .True., .True., 'ioBlock', & - g_ioProcNeighs) - call mpas_timer_stop("transfer_particles_LPT") - deallocate(g_ioProcNeighs) - - ! write out all the data, sorting to make sure that shuffled particles - ! are ouptut correctly (done separately in each function, could be - ! pulled out as an optimization) - ! write halo data out, but don't need nonhalo data because it is - ! computed for output (diagnostic, not prognostic) - call mpas_timer_start("write_halo_LPT") - call mpas_particle_list_write_halo_data(domain, err) - call mpas_timer_stop("write_halo_LPT") - !call mpas_particle_list_write_nonhalo_data(domain, err) - - ! need to now remove the io particles (remove particles that don't have the - ! correct currentBlock) - call mpas_timer_start("remove_block_particles_LPT") - call mpas_particle_list_remove_particles_not_on_current_block(domain,err) - call mpas_timer_stop("remove_block_particles_LPT") + + ! note, difference here is that nonhalo data may not be needed for + ! restart, but including here for now for simplity of the code + call write_lagrangian_particle_tracking(domain, err) LIGHT_DEBUG_WRITE('end ocn_restart_lagrangian_particle_tracking') call mpas_timer_stop("restartLPT") From 14e7ac3c92d7d7945f463bab3a3faaaa34bb3d6a Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Fri, 12 Jan 2018 07:01:27 -0700 Subject: [PATCH 049/182] Fixes comment / text output typos --- .../analysis_members/mpas_ocn_particle_list.F | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/core_ocean/analysis_members/mpas_ocn_particle_list.F b/src/core_ocean/analysis_members/mpas_ocn_particle_list.F index 43b9cc4b88..7e91133e25 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_particle_list.F +++ b/src/core_ocean/analysis_members/mpas_ocn_particle_list.F @@ -971,13 +971,13 @@ subroutine mpas_particle_list_write_halo_data(domain, err)!{{{ ! reorder field1DIntPointer % array = Array1DIntPointer(orderingVector) else - LIGHT_DEBUG_ALL_WRITE("Different field type than implemented in nonHalo write!") + LIGHT_DEBUG_ALL_WRITE("Different field type than implemented in Halo write!") end if elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then ! ignore dimensions for now and have this code so they aren't printed as an error message else write(message, *) "Different type expected in registry for key ", trim(dimItr % memberName), & - " in nonHalo data for write-- don't know what to do!" + " in Halo data for write-- don't know what to do!" LIGHT_DEBUG_ALL_WRITE(message) end if end do @@ -3942,11 +3942,11 @@ subroutine read_haloData(domain, err)!{{{ " in halo data for read-- don't know what to do!" LIGHT_DEBUG_WRITE(message) ! false warning for - !Different type expected in registry for key on_a_sphere in nonHalo data for read, don't know what to do! - !Different type expected in registry for key sphere_radius in nonHalo data for read, don't know what to do! - !Different type expected in registry for key is_periodic in nonHalo data for read, don't know what to do! - !Different type expected in registry for key x_period in nonHalo data for read, don't know what to do! - !Different type expected in registry for key y_period in nonHalo data for read, don't know what to do! + !Different type expected in registry for key on_a_sphere in Halo data for read, don't know what to do! + !Different type expected in registry for key sphere_radius in Halo data for read, don't know what to do! + !Different type expected in registry for key is_periodic in Halo data for read, don't know what to do! + !Different type expected in registry for key x_period in Halo data for read, don't know what to do! + !Different type expected in registry for key y_period in Halo data for read, don't know what to do! end if end do From 4162bf1ea93180e0c4c371b9b92c935560131a71 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Fri, 12 Jan 2018 07:01:53 -0700 Subject: [PATCH 050/182] Removes nonhalo code as it is not currently used --- .../Registry_lagrangian_particle_tracking.xml | 2 + .../mpas_ocn_lagrangian_particle_tracking.F | 3 +- .../analysis_members/mpas_ocn_particle_list.F | 1473 +++++++++-------- 3 files changed, 742 insertions(+), 736 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml index 21ba816f5d..7b950d049c 100644 --- a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml +++ b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml @@ -350,8 +350,10 @@ description="v velocity of particle - meridional direction" /> + This routine writes nonhaloData output for this MPAS-Ocean analysis member. ! !----------------------------------------------------------------------- - subroutine mpas_particle_list_write_nonhalo_data(domain, err)!{{{ - - implicit none - - !----------------------------------------------------------------- - ! input variables - !----------------------------------------------------------------- - type (domain_type), intent(in) :: domain - - !----------------------------------------------------------------- - ! output variables - !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag - - !----------------------------------------------------------------- - ! local variables - !----------------------------------------------------------------- - type (block_type), pointer :: block - type (mpas_particle_list_type), pointer :: particlelist - type (mpas_pool_type), pointer :: lagrPartTrackPool - type (mpas_pool_iterator_type) :: dimItr - type (field1DReal), pointer :: field1DRealPointer - type (field1DInteger), pointer :: field1DIntPointer - real (kind=RKIND), dimension(:), pointer :: Array1DRealPointer => NULL() - integer, dimension(:), pointer :: Array1DIntPointer => NULL() - integer, dimension(:), pointer :: indexToParticleIDOriginal => NULL(), & - indexToParticleIDNew => NULL(), & - orderingVector =>NULL() - character (len=StrKIND) :: message - - err = 0 - - block => domain % blocklist - do while (associated(block)) - ! particle related pointers - particlelist => block % particlelist - ! iterate over each member of the pool and make the relevant assignment - call mpas_pool_get_subpool(block % structs, 'lagrPartTrackHalo', lagrPartTrackPool) - ! need to compute the ordering matrices - call mpas_pool_get_array(lagrPartTrackPool, 'indexToParticleID', indexToParticleIDOriginal) - call get_halo_data_from_particle_list_array(particlelist, 'indexToParticleID', indexToParticleIDNew) - ! note: orderingVector can be a subset of indexToParticleIDNew because this index can include compute as well as - ! IO particles however, it must be of the same size as indexToParticleIDOriginal - call compute_ordering_vector(indexToParticleIDOriginal, indexToParticleIDNew, orderingVector) - - ! iterate over each member of the pool and make the relevant assignment - call mpas_pool_get_subpool(block % structs, 'lagrPartTrackNonHalo', lagrPartTrackPool) - call mpas_pool_begin_iteration(lagrPartTrackPool) - do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) - ! determine the type of data - if (dimItr % memberType == MPAS_POOL_FIELD) then - if (dimItr % dataType == MPAS_POOL_REAL) then - ! get data and place it in appropriate array - call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DRealPointer) - !{{{ - LIGHT_DEBUG_WRITE('write nonhalo data') - LIGHT_DEBUG_WRITE('member name =' COMMA dimItr % memberName) - LIGHT_DEBUG_WRITE('particlelistSize= ' COMMA count_particlelist(particlelist)) - LIGHT_DEBUG_WRITE('memory arraysize= ' COMMA size(field1DRealPointer % array)) - !}}} - allocate(Array1DRealPointer(count_particlelist(particlelist))) - call get_nonhalo_data_from_particle_list_array(particlelist, dimItr % memberName, Array1DRealPointer) - ! reorder - field1DRealPointer % array = Array1DRealPointer(orderingVector) - deallocate(Array1DRealPointer) - elseif (dimItr % dataType == MPAS_POOL_INTEGER) then - write(message, *) "Integer type in registry for key ", dimItr % memberName, & - " in nonHalo data for write, not yet tested!" - LIGHT_DEBUG_ALL_WRITE(message) - ! get data and place it in appropriate array - call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DIntPointer) - allocate(Array1DIntPointer(count_particlelist(particlelist))) - call get_nonhalo_data_from_particle_list_array(particlelist, dimItr % memberName, Array1DIntPointer) - ! reorder - field1DIntPointer % array = Array1DIntPointer(orderingVector) - deallocate(Array1DIntPointer) - else - LIGHT_DEBUG_ALL_WRITE("Different field type than implemented in nonHalo write!") - end if - elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then - ! ignore dimensions for now and have this code so they aren't printed as an error message - else - write(message, *) "Different type expected in registry for key ", trim(dimItr % memberName), & - " in nonHalo data for write-- don't know what to do!" - LIGHT_DEBUG_ALL_WRITE(message) - end if - end do - - ! free memory for the next loop - deallocate(indexToParticleIDNew) - deallocate(orderingVector) - - block => block % next - end do - - end subroutine mpas_particle_list_write_nonhalo_data!}}} +! subroutine mpas_particle_list_write_nonhalo_data(domain, err)!{{{ + +! implicit none + +! !----------------------------------------------------------------- +! ! input variables +! !----------------------------------------------------------------- +! type (domain_type), intent(in) :: domain + +! !----------------------------------------------------------------- +! ! output variables +! !----------------------------------------------------------------- +! integer, intent(out) :: err !< Output: error flag + +! !----------------------------------------------------------------- +! ! local variables +! !----------------------------------------------------------------- +! type (block_type), pointer :: block +! type (mpas_particle_list_type), pointer :: particlelist +! type (mpas_pool_type), pointer :: lagrPartTrackPool +! type (mpas_pool_iterator_type) :: dimItr +! type (field1DReal), pointer :: field1DRealPointer +! type (field1DInteger), pointer :: field1DIntPointer +! real (kind=RKIND), dimension(:), pointer :: Array1DRealPointer => NULL() +! integer, dimension(:), pointer :: Array1DIntPointer => NULL() +! integer, dimension(:), pointer :: indexToParticleIDOriginal => NULL(), & +! indexToParticleIDNew => NULL(), & +! orderingVector =>NULL() +! character (len=StrKIND) :: message + +! err = 0 + +! block => domain % blocklist +! do while (associated(block)) +! ! particle related pointers +! particlelist => block % particlelist +! ! iterate over each member of the pool and make the relevant assignment +! call mpas_pool_get_subpool(block % structs, 'lagrPartTrackHalo', lagrPartTrackPool) +! ! need to compute the ordering matrices +! call mpas_pool_get_array(lagrPartTrackPool, 'indexToParticleID', indexToParticleIDOriginal) +! call get_halo_data_from_particle_list_array(particlelist, 'indexToParticleID', indexToParticleIDNew) +! ! note: orderingVector can be a subset of indexToParticleIDNew because this index can include compute as well as +! ! IO particles however, it must be of the same size as indexToParticleIDOriginal +! call compute_ordering_vector(indexToParticleIDOriginal, indexToParticleIDNew, orderingVector) + +! ! iterate over each member of the pool and make the relevant assignment +! call mpas_pool_get_subpool(block % structs, 'lagrPartTrackNonHalo', lagrPartTrackPool) +! call mpas_pool_begin_iteration(lagrPartTrackPool) +! do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) +! ! determine the type of data +! if (dimItr % memberType == MPAS_POOL_FIELD) then +! if (dimItr % dataType == MPAS_POOL_REAL) then +! ! get data and place it in appropriate array +! call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DRealPointer) +! !{{{ +! LIGHT_DEBUG_WRITE('write nonhalo data') +! LIGHT_DEBUG_WRITE('member name =' COMMA dimItr % memberName) +! LIGHT_DEBUG_WRITE('particlelistSize= ' COMMA count_particlelist(particlelist)) +! LIGHT_DEBUG_WRITE('memory arraysize= ' COMMA size(field1DRealPointer % array)) +! !}}} +! allocate(Array1DRealPointer(count_particlelist(particlelist))) +! call get_nonhalo_data_from_particle_list_array(particlelist, dimItr % memberName, Array1DRealPointer) +! ! reorder +! field1DRealPointer % array = Array1DRealPointer(orderingVector) +! deallocate(Array1DRealPointer) +! elseif (dimItr % dataType == MPAS_POOL_INTEGER) then +! write(message, *) "Integer type in registry for key ", dimItr % memberName, & +! " in nonHalo data for write, not yet tested!" +! LIGHT_DEBUG_ALL_WRITE(message) +! ! get data and place it in appropriate array +! call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DIntPointer) +! allocate(Array1DIntPointer(count_particlelist(particlelist))) +! call get_nonhalo_data_from_particle_list_array(particlelist, dimItr % memberName, Array1DIntPointer) +! ! reorder +! field1DIntPointer % array = Array1DIntPointer(orderingVector) +! deallocate(Array1DIntPointer) +! else +! LIGHT_DEBUG_ALL_WRITE("Different field type than implemented in nonHalo write!") +! end if +! elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then +! ! ignore dimensions for now and have this code so they aren't printed as an error message +! else +! write(message, *) "Different type expected in registry for key ", trim(dimItr % memberName), & +! " in nonHalo data for write-- don't know what to do!" +! LIGHT_DEBUG_ALL_WRITE(message) +! end if +! end do + +! ! free memory for the next loop +! deallocate(indexToParticleIDNew) +! deallocate(orderingVector) + +! block => block % next +! end do + +! end subroutine mpas_particle_list_write_nonhalo_data!}}} !----------------------------------------------------------------------- ! @@ -1250,33 +1253,33 @@ end subroutine get_halo_data_from_particle_list_1Dreal !}}} !> \details ! !----------------------------------------------------------------------- -subroutine get_nonhalo_data_from_particle_list_1Dint& !{{{ - (particlelist, dataName, field1DIntPointer) - ! input data - type (mpas_particle_list_type), pointer, intent(in) :: particlelist - character(len=*), intent(in) :: dataName - type (field1DInteger), pointer, intent(out) :: field1DIntPointer - - ! subroutine data - integer :: dataNumber - type (mpas_particle_list_type), pointer :: particlelistCurr - type (field0DInteger), pointer :: field0DIntPointer - - ! loop over all elements of the list and insert the data - dataNumber = 1 - particlelistCurr => particlelist - ! while we have a real link - do while(associated(particlelistCurr)) - call mpas_pool_get_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DIntPointer) - field1DIntPointer % array(dataNumber) = field0DIntPointer % scalar - - ! increment for new dataNumber - dataNumber = dataNumber + 1 - ! get next link - particlelistCurr => particlelistCurr % next - end do - -end subroutine get_nonhalo_data_from_particle_list_1Dint !}}} +!subroutine get_nonhalo_data_from_particle_list_1Dint& !{{{ +! (particlelist, dataName, field1DIntPointer) +! ! input data +! type (mpas_particle_list_type), pointer, intent(in) :: particlelist +! character(len=*), intent(in) :: dataName +! type (field1DInteger), pointer, intent(out) :: field1DIntPointer +! +! ! subroutine data +! integer :: dataNumber +! type (mpas_particle_list_type), pointer :: particlelistCurr +! type (field0DInteger), pointer :: field0DIntPointer +! +! ! loop over all elements of the list and insert the data +! dataNumber = 1 +! particlelistCurr => particlelist +! ! while we have a real link +! do while(associated(particlelistCurr)) +! call mpas_pool_get_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DIntPointer) +! field1DIntPointer % array(dataNumber) = field0DIntPointer % scalar +! +! ! increment for new dataNumber +! dataNumber = dataNumber + 1 +! ! get next link +! particlelistCurr => particlelistCurr % next +! end do +! +!end subroutine get_nonhalo_data_from_particle_list_1Dint !}}} !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! @@ -1288,38 +1291,38 @@ end subroutine get_nonhalo_data_from_particle_list_1Dint !}}} !> \details ! !----------------------------------------------------------------------- -subroutine get_nonhalo_data_from_particle_list_1Dint_array & !{{{ - (particlelist, dataName, array1DIntPointer) - ! input data - type (mpas_particle_list_type), pointer, intent(in) :: particlelist - character(len=*), intent(in) :: dataName - integer, dimension(:), pointer, intent(out) :: array1DIntPointer - - ! subroutine data - integer :: dataNumber - type (mpas_particle_list_type), pointer :: particlelistCurr - type (field0DInteger), pointer :: field0DIntPointer - - ! allocate the array if it isn't allocated - if(.not.associated(array1DIntPointer)) then - allocate(array1DIntPointer(count_particlelist(particlelist))) - end if - - ! loop over all elements of the list and insert the data - dataNumber = 1 - particlelistCurr => particlelist - ! while we have a real link - do while(associated(particlelistCurr)) - call mpas_pool_get_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DIntPointer) - array1DIntPointer(dataNumber) = field0DIntPointer % scalar - - ! increment for new dataNumber - dataNumber = dataNumber + 1 - ! get next link - particlelistCurr => particlelistCurr % next - end do - -end subroutine get_nonhalo_data_from_particle_list_1Dint_array !}}} +!subroutine get_nonhalo_data_from_particle_list_1Dint_array & !{{{ +! (particlelist, dataName, array1DIntPointer) +! ! input data +! type (mpas_particle_list_type), pointer, intent(in) :: particlelist +! character(len=*), intent(in) :: dataName +! integer, dimension(:), pointer, intent(out) :: array1DIntPointer +! +! ! subroutine data +! integer :: dataNumber +! type (mpas_particle_list_type), pointer :: particlelistCurr +! type (field0DInteger), pointer :: field0DIntPointer +! +! ! allocate the array if it isn't allocated +! if(.not.associated(array1DIntPointer)) then +! allocate(array1DIntPointer(count_particlelist(particlelist))) +! end if +! +! ! loop over all elements of the list and insert the data +! dataNumber = 1 +! particlelistCurr => particlelist +! ! while we have a real link +! do while(associated(particlelistCurr)) +! call mpas_pool_get_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DIntPointer) +! array1DIntPointer(dataNumber) = field0DIntPointer % scalar +! +! ! increment for new dataNumber +! dataNumber = dataNumber + 1 +! ! get next link +! particlelistCurr => particlelistCurr % next +! end do +! +!end subroutine get_nonhalo_data_from_particle_list_1Dint_array !}}} !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! @@ -1331,33 +1334,33 @@ end subroutine get_nonhalo_data_from_particle_list_1Dint_array !}}} !> \details ! !----------------------------------------------------------------------- -subroutine get_nonhalo_data_from_particle_list_1Dreal & !{{{ - (particlelist, dataName, field1DRealPointer) - ! input data - type (mpas_particle_list_type), pointer, intent(in) :: particlelist - character(len=*), intent(in) :: dataName - type (field1DReal), pointer, intent(out) :: field1DRealPointer - - ! subroutine data - integer :: dataNumber - type (mpas_particle_list_type), pointer :: particlelistCurr - type (field0DReal), pointer :: field0DRealPointer - - ! loop over all elements of the list and insert the data - dataNumber = 1 - particlelistCurr => particlelist - ! while we have a real link - do while(associated(particlelistCurr)) - call mpas_pool_get_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DRealPointer) - field1DRealPointer % array(dataNumber) = field0DRealPointer % scalar - - ! increment for new dataNumber - dataNumber = dataNumber + 1 - ! get next link - particlelistCurr => particlelistCurr % next - end do - -end subroutine get_nonhalo_data_from_particle_list_1Dreal !}}} +!subroutine get_nonhalo_data_from_particle_list_1Dreal & !{{{ +! (particlelist, dataName, field1DRealPointer) +! ! input data +! type (mpas_particle_list_type), pointer, intent(in) :: particlelist +! character(len=*), intent(in) :: dataName +! type (field1DReal), pointer, intent(out) :: field1DRealPointer +! +! ! subroutine data +! integer :: dataNumber +! type (mpas_particle_list_type), pointer :: particlelistCurr +! type (field0DReal), pointer :: field0DRealPointer +! +! ! loop over all elements of the list and insert the data +! dataNumber = 1 +! particlelistCurr => particlelist +! ! while we have a real link +! do while(associated(particlelistCurr)) +! call mpas_pool_get_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DRealPointer) +! field1DRealPointer % array(dataNumber) = field0DRealPointer % scalar +! +! ! increment for new dataNumber +! dataNumber = dataNumber + 1 +! ! get next link +! particlelistCurr => particlelistCurr % next +! end do +! +!end subroutine get_nonhalo_data_from_particle_list_1Dreal !}}} !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! @@ -1369,38 +1372,38 @@ end subroutine get_nonhalo_data_from_particle_list_1Dreal !}}} !> \details ! !----------------------------------------------------------------------- -subroutine get_nonhalo_data_from_particle_list_1Dreal_array & !{{{ - (particlelist, dataName, array1DRealPointer) - ! input data - type (mpas_particle_list_type), pointer, intent(in) :: particlelist - character(len=*), intent(in) :: dataName - real (kind=RKIND), dimension(:), pointer, intent(out) :: array1DRealPointer - - ! subroutine data - integer :: dataNumber - type (mpas_particle_list_type), pointer :: particlelistCurr - type (field0DReal), pointer :: field0DRealPointer - - ! allocate the array if it isn't allocated - if(.not.associated(array1DRealPointer)) then - allocate(array1DRealPointer(count_particlelist(particlelist))) - end if - - ! loop over all elements of the list and insert the data - dataNumber = 1 - particlelistCurr => particlelist - ! while we have a real link - do while(associated(particlelistCurr)) - call mpas_pool_get_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DRealPointer) - array1DRealPointer(dataNumber) = field0DRealPointer % scalar - - ! increment for new dataNumber - dataNumber = dataNumber + 1 - ! get next link - particlelistCurr => particlelistCurr % next - end do - -end subroutine get_nonhalo_data_from_particle_list_1Dreal_array !}}} +!subroutine get_nonhalo_data_from_particle_list_1Dreal_array & !{{{ +! (particlelist, dataName, array1DRealPointer) +! ! input data +! type (mpas_particle_list_type), pointer, intent(in) :: particlelist +! character(len=*), intent(in) :: dataName +! real (kind=RKIND), dimension(:), pointer, intent(out) :: array1DRealPointer +! +! ! subroutine data +! integer :: dataNumber +! type (mpas_particle_list_type), pointer :: particlelistCurr +! type (field0DReal), pointer :: field0DRealPointer +! +! ! allocate the array if it isn't allocated +! if(.not.associated(array1DRealPointer)) then +! allocate(array1DRealPointer(count_particlelist(particlelist))) +! end if +! +! ! loop over all elements of the list and insert the data +! dataNumber = 1 +! particlelistCurr => particlelist +! ! while we have a real link +! do while(associated(particlelistCurr)) +! call mpas_pool_get_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DRealPointer) +! array1DRealPointer(dataNumber) = field0DRealPointer % scalar +! +! ! increment for new dataNumber +! dataNumber = dataNumber + 1 +! ! get next link +! particlelistCurr => particlelistCurr % next +! end do +! +!end subroutine get_nonhalo_data_from_particle_list_1Dreal_array !}}} !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! @@ -1416,33 +1419,33 @@ end subroutine get_nonhalo_data_from_particle_list_1Dreal_array !}}} !> on each particle. ! !----------------------------------------------------------------------- -subroutine get_nonhalo_data_from_particle_list_2Dreal & !{{{ - (particlelist, dataName, field2DRealPointer) - ! input data - type (mpas_particle_list_type), pointer, intent(in) :: particlelist - character(len=*), intent(in) :: dataName - type (field2DReal), pointer, intent(out) :: field2DRealPointer - - ! subroutine data - integer :: dataNumber - type (mpas_particle_list_type), pointer :: particlelistCurr - type (field1DReal), pointer :: field1DRealPointer - - ! loop over all elements of the list and insert the data - dataNumber = 1 - particlelistCurr => particlelist - ! while we have a real link - do while(associated(particlelistCurr)) - call mpas_pool_get_field(particlelistCurr % particle % nonhaloDataPool, dataName, field1DRealPointer) - field2DRealPointer % array(dataNumber, :) = field1DRealPointer % array(:) - - ! increment for new dataNumber - dataNumber = dataNumber + 1 - ! get next link - particlelistCurr => particlelistCurr % next - end do - -end subroutine get_nonhalo_data_from_particle_list_2Dreal !}}} +!subroutine get_nonhalo_data_from_particle_list_2Dreal & !{{{ +! (particlelist, dataName, field2DRealPointer) +! ! input data +! type (mpas_particle_list_type), pointer, intent(in) :: particlelist +! character(len=*), intent(in) :: dataName +! type (field2DReal), pointer, intent(out) :: field2DRealPointer +! +! ! subroutine data +! integer :: dataNumber +! type (mpas_particle_list_type), pointer :: particlelistCurr +! type (field1DReal), pointer :: field1DRealPointer +! +! ! loop over all elements of the list and insert the data +! dataNumber = 1 +! particlelistCurr => particlelist +! ! while we have a real link +! do while(associated(particlelistCurr)) +! call mpas_pool_get_field(particlelistCurr % particle % nonhaloDataPool, dataName, field1DRealPointer) +! field2DRealPointer % array(dataNumber, :) = field1DRealPointer % array(:) +! +! ! increment for new dataNumber +! dataNumber = dataNumber + 1 +! ! get next link +! particlelistCurr => particlelistCurr % next +! end do +! +!end subroutine get_nonhalo_data_from_particle_list_2Dreal !}}} !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! @@ -1635,35 +1638,35 @@ end subroutine add_halo_data_to_particle_list_1Dreal !}}} !> on each particle. ! !----------------------------------------------------------------------- -subroutine add_nonhalo_data_to_particle_list_1Dreal_array & !{{{ - (particlelist, dataName, array1DRealPointer) - ! input data - type (mpas_particle_list_type), pointer, intent(in) :: particlelist - character(len=*), intent(in) :: dataName - real (kind=RKIND), dimension(:), pointer :: array1DRealPointer - - ! subroutine data - integer :: dataNumber - type (mpas_particle_list_type), pointer :: particlelistCurr - type (field0DReal), pointer :: field0DRealPointer - - ! loop over all elements of the list and insert the data - dataNumber = 1 - particlelistCurr => particlelist - ! while we have a real link - do while(associated(particlelistCurr)) - - allocate(field0DRealPointer) - field0DRealPointer % scalar = array1DRealPointer(dataNumber) - call mpas_pool_add_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DRealPointer) - - ! increment for new dataNumber - dataNumber = dataNumber + 1 - ! get next link - particlelistCurr => particlelistCurr % next - end do - -end subroutine add_nonhalo_data_to_particle_list_1Dreal_array !}}} +!subroutine add_nonhalo_data_to_particle_list_1Dreal_array & !{{{ +! (particlelist, dataName, array1DRealPointer) +! ! input data +! type (mpas_particle_list_type), pointer, intent(in) :: particlelist +! character(len=*), intent(in) :: dataName +! real (kind=RKIND), dimension(:), pointer :: array1DRealPointer +! +! ! subroutine data +! integer :: dataNumber +! type (mpas_particle_list_type), pointer :: particlelistCurr +! type (field0DReal), pointer :: field0DRealPointer +! +! ! loop over all elements of the list and insert the data +! dataNumber = 1 +! particlelistCurr => particlelist +! ! while we have a real link +! do while(associated(particlelistCurr)) +! +! allocate(field0DRealPointer) +! field0DRealPointer % scalar = array1DRealPointer(dataNumber) +! call mpas_pool_add_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DRealPointer) +! +! ! increment for new dataNumber +! dataNumber = dataNumber + 1 +! ! get next link +! particlelistCurr => particlelistCurr % next +! end do +! +!end subroutine add_nonhalo_data_to_particle_list_1Dreal_array !}}} !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! @@ -1679,35 +1682,35 @@ end subroutine add_nonhalo_data_to_particle_list_1Dreal_array !}}} !> on each particle. ! !----------------------------------------------------------------------- -subroutine add_nonhalo_data_to_particle_list_1Dreal & !{{{ - (particlelist, dataName, field1DRealPointer) - ! input data - type (mpas_particle_list_type), pointer, intent(in) :: particlelist - character(len=*), intent(in) :: dataName - type (field1DReal), pointer :: field1DRealPointer - - ! subroutine data - integer :: dataNumber - type (mpas_particle_list_type), pointer :: particlelistCurr - type (field0DReal), pointer :: field0DRealPointer - - ! loop over all elements of the list and insert the data - dataNumber = 1 - particlelistCurr => particlelist - ! while we have a real link - do while(associated(particlelistCurr)) - - allocate(field0DRealPointer) - field0DRealPointer % scalar = field1DRealPointer % array(dataNumber) - call mpas_pool_add_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DRealPointer) - - ! increment for new dataNumber - dataNumber = dataNumber + 1 - ! get next link - particlelistCurr => particlelistCurr % next - end do - -end subroutine add_nonhalo_data_to_particle_list_1Dreal !}}} +!subroutine add_nonhalo_data_to_particle_list_1Dreal & !{{{ +! (particlelist, dataName, field1DRealPointer) +! ! input data +! type (mpas_particle_list_type), pointer, intent(in) :: particlelist +! character(len=*), intent(in) :: dataName +! type (field1DReal), pointer :: field1DRealPointer +! +! ! subroutine data +! integer :: dataNumber +! type (mpas_particle_list_type), pointer :: particlelistCurr +! type (field0DReal), pointer :: field0DRealPointer +! +! ! loop over all elements of the list and insert the data +! dataNumber = 1 +! particlelistCurr => particlelist +! ! while we have a real link +! do while(associated(particlelistCurr)) +! +! allocate(field0DRealPointer) +! field0DRealPointer % scalar = field1DRealPointer % array(dataNumber) +! call mpas_pool_add_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DRealPointer) +! +! ! increment for new dataNumber +! dataNumber = dataNumber + 1 +! ! get next link +! particlelistCurr => particlelistCurr % next +! end do +! +!end subroutine add_nonhalo_data_to_particle_list_1Dreal !}}} !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! @@ -1811,35 +1814,35 @@ end subroutine add_halo_data_to_particle_list_1Dint !}}} !> on each particle. ! !----------------------------------------------------------------------- -subroutine add_nonhalo_data_to_particle_list_1Dint_array & !{{{ - (particlelist, dataName, array1DIntPointer) - ! input data - type (mpas_particle_list_type), pointer, intent(in) :: particlelist - character(len=*), intent(in) :: dataName - integer, dimension(:), pointer, intent(in) :: array1DIntPointer - - ! subroutine data - integer :: dataNumber - type (mpas_particle_list_type), pointer :: particlelistCurr - type (field0DInteger), pointer :: field0DIntPointer - - ! loop over all elements of the list and insert the data - dataNumber = 1 - particlelistCurr => particlelist - ! while we have a int link - do while(associated(particlelistCurr)) - - allocate(field0DIntPointer) - field0DIntPointer % scalar = array1DIntPointer(dataNumber) - call mpas_pool_add_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DIntPointer) - - ! increment for new dataNumber - dataNumber = dataNumber + 1 - ! get next link - particlelistCurr => particlelistCurr % next - end do - -end subroutine add_nonhalo_data_to_particle_list_1Dint_array !}}} +!subroutine add_nonhalo_data_to_particle_list_1Dint_array & !{{{ +! (particlelist, dataName, array1DIntPointer) +! ! input data +! type (mpas_particle_list_type), pointer, intent(in) :: particlelist +! character(len=*), intent(in) :: dataName +! integer, dimension(:), pointer, intent(in) :: array1DIntPointer +! +! ! subroutine data +! integer :: dataNumber +! type (mpas_particle_list_type), pointer :: particlelistCurr +! type (field0DInteger), pointer :: field0DIntPointer +! +! ! loop over all elements of the list and insert the data +! dataNumber = 1 +! particlelistCurr => particlelist +! ! while we have a int link +! do while(associated(particlelistCurr)) +! +! allocate(field0DIntPointer) +! field0DIntPointer % scalar = array1DIntPointer(dataNumber) +! call mpas_pool_add_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DIntPointer) +! +! ! increment for new dataNumber +! dataNumber = dataNumber + 1 +! ! get next link +! particlelistCurr => particlelistCurr % next +! end do +! +!end subroutine add_nonhalo_data_to_particle_list_1Dint_array !}}} !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! @@ -1855,35 +1858,35 @@ end subroutine add_nonhalo_data_to_particle_list_1Dint_array !}}} !> on each particle. ! !----------------------------------------------------------------------- -subroutine add_nonhalo_data_to_particle_list_1Dint & !{{{ - (particlelist, dataName, field1DIntPointer) - ! input data - type (mpas_particle_list_type), pointer, intent(in) :: particlelist - character(len=*), intent(in) :: dataName - type (field1DInteger), pointer, intent(in) :: field1DIntPointer - - ! subroutine data - integer :: dataNumber - type (mpas_particle_list_type), pointer :: particlelistCurr - type (field0DInteger), pointer :: field0DIntPointer - - ! loop over all elements of the list and insert the data - dataNumber = 1 - particlelistCurr => particlelist - ! while we have a int link - do while(associated(particlelistCurr)) - - allocate(field0DIntPointer) - field0DIntPointer % scalar = field1DIntPointer % array(dataNumber) - call mpas_pool_add_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DIntPointer) - - ! increment for new dataNumber - dataNumber = dataNumber + 1 - ! get next link - particlelistCurr => particlelistCurr % next - end do - -end subroutine add_nonhalo_data_to_particle_list_1Dint !}}} +!subroutine add_nonhalo_data_to_particle_list_1Dint & !{{{ +! (particlelist, dataName, field1DIntPointer) +! ! input data +! type (mpas_particle_list_type), pointer, intent(in) :: particlelist +! character(len=*), intent(in) :: dataName +! type (field1DInteger), pointer, intent(in) :: field1DIntPointer +! +! ! subroutine data +! integer :: dataNumber +! type (mpas_particle_list_type), pointer :: particlelistCurr +! type (field0DInteger), pointer :: field0DIntPointer +! +! ! loop over all elements of the list and insert the data +! dataNumber = 1 +! particlelistCurr => particlelist +! ! while we have a int link +! do while(associated(particlelistCurr)) +! +! allocate(field0DIntPointer) +! field0DIntPointer % scalar = field1DIntPointer % array(dataNumber) +! call mpas_pool_add_field(particlelistCurr % particle % nonhaloDataPool, dataName, field0DIntPointer) +! +! ! increment for new dataNumber +! dataNumber = dataNumber + 1 +! ! get next link +! particlelistCurr => particlelistCurr % next +! end do +! +!end subroutine add_nonhalo_data_to_particle_list_1Dint !}}} !||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ! @@ -1968,7 +1971,7 @@ subroutine build_new_particlelist(nParticles, particlelist, ioBlock) !{{{ ! allocate memory for the new particle allocate(particle) call mpas_pool_create_pool(particle % haloDataPool) - call mpas_pool_create_pool(particle % nonhaloDataPool) + !call mpas_pool_create_pool(particle % nonhaloDataPool) if (present(ioBlock)) then allocate(ioBlockfield) ioBlockfield % scalar = ioBlock @@ -1987,7 +1990,7 @@ subroutine build_new_particlelist(nParticles, particlelist, ioBlock) !{{{ ! allocate memory for the new particle allocate(particle) call mpas_pool_create_pool(particle % haloDataPool) - call mpas_pool_create_pool(particle % nonhaloDataPool) + !call mpas_pool_create_pool(particle % nonhaloDataPool) if(present(ioBlock)) then allocate(ioBlockfield) ioBlockfield % scalar = ioBlock @@ -2069,9 +2072,9 @@ subroutine destroy_particle(particle) !{{{ if(associated(particle % haloDataPool)) then call mpas_pool_destroy_pool(particle % haloDataPool) end if - if(associated(particle % nonhaloDataPool)) then - call mpas_pool_destroy_pool(particle % nonhaloDataPool) - end if + !if(associated(particle % nonhaloDataPool)) then + ! call mpas_pool_destroy_pool(particle % nonhaloDataPool) + !end if deallocate(particle) end if @@ -3223,213 +3226,213 @@ end function find_index !}}} !> This routine transmitts nonHaloData from particlelists ! !----------------------------------------------------------------------- - subroutine communicate_particle_nonhalo_data(domain, procNeighs, nPartSend, nPartRecv, listSend, listRecv) !{{{ - implicit none - - type (domain_type), intent(in) :: domain - integer, dimension(:), pointer, intent(in) :: procNeighs - integer, dimension(:), pointer, intent(in) :: nPartSend - integer, dimension(:), pointer, intent(in) :: nPartRecv - type (mpas_list_of_particle_list_type), dimension(:), pointer :: listSend, listRecv - - integer :: i, j, numProcs, numFields, numRecv, numSends - integer, dimension(:), pointer :: recvRequestID, sendRequestID - integer :: mpi_ierr - type (mpas_pool_type), pointer :: lagrPartTrackPool - type (mpas_pool_iterator_type) :: dimItr - type array1DReal_list - real (kind=RKIND), dimension(:), pointer :: val - end type - type array1DInt_list - integer, dimension(:), pointer :: val - end type - type (array1DInt_list), dimension(:), pointer :: array1DIntSend, array1DIntRecv - type (array1DReal_list), dimension(:), pointer :: array1DRealSend, array1DRealRecv - character (len=StrKIND) :: message - - ! for each entry in the halo pool, want to send and recv the data - -#ifdef _MPI - !call MPI_Barrier(domain % dminfo % comm) -#endif - - numProcs = size(procNeighs) - allocate(array1DRealSend(numProcs), array1DRealRecv(numProcs)) - allocate(array1DIntSend(numProcs), array1DIntRecv(numProcs)) - - numSends = 0 - do i = 1, numProcs - if (nPartSend(i) > 0) numSends = numSends + 1 - end do - allocate(sendRequestID(numSends)) - - numRecv = 0 - do i = 1, numProcs - if (nPartRecv(i) > 0) numRecv = numRecv + 1 - end do - allocate(recvRequestID(numRecv)) - - !Notes !{{{ - !! get number of items that need transfered from halo pool, numFields which is a constant - !call mpas_pool_get_subpool(domain % blocklist % structs, 'lagrPartTrackHalo', lagrPartTrackPool) - !call mpas_pool_begin_iteration(lagrPartTrackPool) - !numFields = 0 - !do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) - ! ! only need to transfer pool - ! if (dimItr % memberType == MPAS_POOL_FIELD) then - ! numFields = numFields + 1 - ! end if - !end do - !! assume, for now, that this will be constant accross processors. If not, it would need to be sent to other - !! processors too. This also presumes that properties will be fixed accross the processesors. - !}}} - - ! on each list, transmit relevant fields to associated processors (note using the var struct since it has the names - ! required and this information is on each processor, even if the pool's fields are empty their names and types - ! are there from the registry). - call mpas_pool_get_subpool(domain % blocklist % structs, 'lagrPartTrackNonHalo', lagrPartTrackPool) - call mpas_pool_begin_iteration(lagrPartTrackPool) - do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) - if (dimItr % memberType == MPAS_POOL_FIELD) then - !print *, 'transfering ', trim(dimItr % memberName) - if (dimItr % dataType == MPAS_POOL_REAL) then - ! recv - j = 1 - do i=1,numProcs - if(nPartRecv(i) > 0) then - allocate(array1DRealRecv(i)%val(nPartRecv(i))) - !print *, 'receiving real ', trim(dimItr % memberName), ' from ', procNeighs(i) - ! receive communicated data -#ifdef _MPI - call MPI_IRecv(array1DRealRecv(i)%val, nPartRecv(i), MPI_REALKIND, procNeighs(i), procNeighs(i), & - domain % dminfo % comm, recvRequestID(j), mpi_ierr) -#endif - j = j + 1 - end if - end do - ! send - j = 1 - do i=1,numProcs - if (nPartSend(i) > 0) then - allocate(array1DRealSend(i)%val(nPartSend(i))) - !print *, 'sending real ', trim(dimItr % memberName), ' to ', procNeighs(i) - call get_nonhalo_data_from_particle_list_array(listSend(i)%list, dimItr % memberName, & - array1DRealSend(i)%val) -#ifdef _MPI - call MPI_ISend(array1DRealSend(i)%val, nPartSend(i), MPI_REALKIND, procNeighs(i), & - domain % dminfo % my_proc_id, domain % dminfo % comm, sendRequestID(j), mpi_ierr) -#endif - j = j + 1 - end if - end do - -#ifdef _MPI - call MPI_WaitAll(numRecv, recvRequestID, MPI_STATUSES_IGNORE, mpi_ierr) -#endif - if (mpi_ierr /= 0) call mpas_log_write('recv: mpi_ierr = ' COMMA mpi_ierr) -#ifdef _MPI - call MPI_WaitAll(numSends, sendRequestID, MPI_STATUSES_IGNORE, mpi_ierr) -#endif - if (mpi_ierr /= 0) call mpas_log_write('send: mpi_ierr = ' COMMA mpi_ierr) - - ! store values - j = 1 - do i=1,numProcs - if(nPartRecv(i) > 0) then - ! place it in particle list - call add_nonhalo_data_to_particle_list_array(listRecv(i)%list, dimItr % memberName, & - array1DRealRecv(i)%val) - j = j + 1 - end if - end do - - do i=1,numProcs - if(nPartSend(i) > 0) deallocate(array1DRealSend(i)%val) - end do - do i=1,numProcs - if(nPartRecv(i) > 0) deallocate(array1DRealRecv(i)%val) - end do - !call mpas_log_write( 'finished' - - elseif (dimItr % dataType == MPAS_POOL_INTEGER) then - ! recv - j = 1 - do i=1,numProcs - if(nPartRecv(i) > 0) then - allocate(array1DIntRecv(i)%val(nPartRecv(i))) - ! receive communicated data - !print *, 'receiving int ', trim(dimItr % memberName), ' from ', procNeighs(i) -#ifdef _MPI - call MPI_IRecv(array1DIntRecv(i)%val, nPartRecv(i), MPI_INTEGERKIND, procNeighs(i), procNeighs(i), & - domain % dminfo % comm, recvRequestID(j), mpi_ierr) -#endif - !if( trim(dimItr % memberName) == 'currentBlock') print *, 'currentBlock received ', & - ! nPartRecv(i), ' from', procNeighs(i), ' = ', array1DIntRecv(i)%val - j = j + 1 - end if - end do - ! send - j = 1 - do i=1,numProcs - if(nPartSend(i) > 0) then - allocate(array1DIntSend(i)%val(nPartSend(i))) - !print *, 'sending int ', trim(dimItr % memberName), ' to ', procNeighs(i) - call get_nonhalo_data_from_particle_list_array(listSend(i)%list, dimItr % memberName, array1DIntSend(i)%val) - !if( trim(dimItr % memberName) == 'currentBlock') print *, 'currentBlock sent ',nPartSend(i), & - ! ' to ', procNeighs(i), ' = ', array1DIntSend(i)%val -#ifdef _MPI - call MPI_ISend(array1DIntSend(i)%val, nPartSend(i), MPI_INTEGERKIND, procNeighs(i), & - domain % dminfo % my_proc_id, domain % dminfo % comm, sendRequestID(j), mpi_ierr) -#endif - j = j + 1 - end if - end do - -#ifdef _MPI - call MPI_WaitAll(numRecv, recvRequestID, MPI_STATUSES_IGNORE, mpi_ierr) -#endif - if (mpi_ierr /= 0) call mpas_log_write('mpi_ierr = ' COMMA mpi_ierr) -#ifdef _MPI - call MPI_WaitAll(numSends, sendRequestID, MPI_STATUSES_IGNORE, mpi_ierr) -#endif - if (mpi_ierr /= 0) print *, 'mpi_ierr = ', mpi_ierr - - !do i=1,numProcs - ! if(nPartRecv(i) > 0) print *, 'Received ', trim(dimItr % memberName), ' = ', array1DIntRecv(i) % val - !end do - - ! store values - do i=1,numProcs - if(nPartRecv(i) > 0) then - ! place it in particle list - call add_nonhalo_data_to_particle_list_array(listRecv(i)%list, dimItr % memberName, array1DIntRecv(i)%val) - j = j + 1 - end if - end do - - do i=1,numProcs - if(nPartSend(i) > 0) deallocate(array1DIntSend(i)%val) - end do - do i=1,numProcs - if(nPartRecv(i) > 0) deallocate(array1DIntRecv(i)%val) - end do - !call mpas_log_write( 'finished') - else - !call mpas_log_write( "Different field type than implemented during nonHalo communication!") - end if - elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then - ! ignore dimensions for now and have this code so they aren't printed as an error message - else - write(message, *) "Different type expected in registry for key ", trim(dimItr % memberName), & - " in nonHalo data for communication-- don't know what to do!" - LIGHT_DEBUG_ALL_WRITE(message) - end if - end do - - deallocate(array1DIntSend, array1DIntRecv, array1DRealSend, array1DRealRecv, recvRequestID, sendRequestID) - LIGHT_DEBUG_WRITE('Finished primary MPI communication for nonhalo') - - end subroutine communicate_particle_nonhalo_data!}}} +! subroutine communicate_particle_nonhalo_data(domain, procNeighs, nPartSend, nPartRecv, listSend, listRecv) !{{{ +! implicit none + +! type (domain_type), intent(in) :: domain +! integer, dimension(:), pointer, intent(in) :: procNeighs +! integer, dimension(:), pointer, intent(in) :: nPartSend +! integer, dimension(:), pointer, intent(in) :: nPartRecv +! type (mpas_list_of_particle_list_type), dimension(:), pointer :: listSend, listRecv + +! integer :: i, j, numProcs, numFields, numRecv, numSends +! integer, dimension(:), pointer :: recvRequestID, sendRequestID +! integer :: mpi_ierr +! type (mpas_pool_type), pointer :: lagrPartTrackPool +! type (mpas_pool_iterator_type) :: dimItr +! type array1DReal_list +! real (kind=RKIND), dimension(:), pointer :: val +! end type +! type array1DInt_list +! integer, dimension(:), pointer :: val +! end type +! type (array1DInt_list), dimension(:), pointer :: array1DIntSend, array1DIntRecv +! type (array1DReal_list), dimension(:), pointer :: array1DRealSend, array1DRealRecv +! character (len=StrKIND) :: message + +! ! for each entry in the halo pool, want to send and recv the data + +!ifdef _MPI +! !call MPI_Barrier(domain % dminfo % comm) +!endif + +! numProcs = size(procNeighs) +! allocate(array1DRealSend(numProcs), array1DRealRecv(numProcs)) +! allocate(array1DIntSend(numProcs), array1DIntRecv(numProcs)) + +! numSends = 0 +! do i = 1, numProcs +! if (nPartSend(i) > 0) numSends = numSends + 1 +! end do +! allocate(sendRequestID(numSends)) + +! numRecv = 0 +! do i = 1, numProcs +! if (nPartRecv(i) > 0) numRecv = numRecv + 1 +! end do +! allocate(recvRequestID(numRecv)) + +! !Notes !{{{ +! !! get number of items that need transfered from halo pool, numFields which is a constant +! !call mpas_pool_get_subpool(domain % blocklist % structs, 'lagrPartTrackHalo', lagrPartTrackPool) +! !call mpas_pool_begin_iteration(lagrPartTrackPool) +! !numFields = 0 +! !do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) +! ! ! only need to transfer pool +! ! if (dimItr % memberType == MPAS_POOL_FIELD) then +! ! numFields = numFields + 1 +! ! end if +! !end do +! !! assume, for now, that this will be constant accross processors. If not, it would need to be sent to other +! !! processors too. This also presumes that properties will be fixed accross the processesors. +! !}}} + +! ! on each list, transmit relevant fields to associated processors (note using the var struct since it has the names +! ! required and this information is on each processor, even if the pool's fields are empty their names and types +! ! are there from the registry). +! call mpas_pool_get_subpool(domain % blocklist % structs, 'lagrPartTrackNonHalo', lagrPartTrackPool) +! call mpas_pool_begin_iteration(lagrPartTrackPool) +! do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) +! if (dimItr % memberType == MPAS_POOL_FIELD) then +! !print *, 'transfering ', trim(dimItr % memberName) +! if (dimItr % dataType == MPAS_POOL_REAL) then +! ! recv +! j = 1 +! do i=1,numProcs +! if(nPartRecv(i) > 0) then +! allocate(array1DRealRecv(i)%val(nPartRecv(i))) +! !print *, 'receiving real ', trim(dimItr % memberName), ' from ', procNeighs(i) +! ! receive communicated data +!ifdef _MPI +! call MPI_IRecv(array1DRealRecv(i)%val, nPartRecv(i), MPI_REALKIND, procNeighs(i), procNeighs(i), & +! domain % dminfo % comm, recvRequestID(j), mpi_ierr) +!endif +! j = j + 1 +! end if +! end do +! ! send +! j = 1 +! do i=1,numProcs +! if (nPartSend(i) > 0) then +! allocate(array1DRealSend(i)%val(nPartSend(i))) +! !print *, 'sending real ', trim(dimItr % memberName), ' to ', procNeighs(i) +! call get_nonhalo_data_from_particle_list_array(listSend(i)%list, dimItr % memberName, & +! array1DRealSend(i)%val) +!ifdef _MPI +! call MPI_ISend(array1DRealSend(i)%val, nPartSend(i), MPI_REALKIND, procNeighs(i), & +! domain % dminfo % my_proc_id, domain % dminfo % comm, sendRequestID(j), mpi_ierr) +!endif +! j = j + 1 +! end if +! end do + +!ifdef _MPI +! call MPI_WaitAll(numRecv, recvRequestID, MPI_STATUSES_IGNORE, mpi_ierr) +!endif +! if (mpi_ierr /= 0) call mpas_log_write('recv: mpi_ierr = ' COMMA mpi_ierr) +!ifdef _MPI +! call MPI_WaitAll(numSends, sendRequestID, MPI_STATUSES_IGNORE, mpi_ierr) +!endif +! if (mpi_ierr /= 0) call mpas_log_write('send: mpi_ierr = ' COMMA mpi_ierr) + +! ! store values +! j = 1 +! do i=1,numProcs +! if(nPartRecv(i) > 0) then +! ! place it in particle list +! call add_nonhalo_data_to_particle_list_array(listRecv(i)%list, dimItr % memberName, & +! array1DRealRecv(i)%val) +! j = j + 1 +! end if +! end do + +! do i=1,numProcs +! if(nPartSend(i) > 0) deallocate(array1DRealSend(i)%val) +! end do +! do i=1,numProcs +! if(nPartRecv(i) > 0) deallocate(array1DRealRecv(i)%val) +! end do +! !call mpas_log_write( 'finished' + +! elseif (dimItr % dataType == MPAS_POOL_INTEGER) then +! ! recv +! j = 1 +! do i=1,numProcs +! if(nPartRecv(i) > 0) then +! allocate(array1DIntRecv(i)%val(nPartRecv(i))) +! ! receive communicated data +! !print *, 'receiving int ', trim(dimItr % memberName), ' from ', procNeighs(i) +!ifdef _MPI +! call MPI_IRecv(array1DIntRecv(i)%val, nPartRecv(i), MPI_INTEGERKIND, procNeighs(i), procNeighs(i), & +! domain % dminfo % comm, recvRequestID(j), mpi_ierr) +!endif +! !if( trim(dimItr % memberName) == 'currentBlock') print *, 'currentBlock received ', & +! ! nPartRecv(i), ' from', procNeighs(i), ' = ', array1DIntRecv(i)%val +! j = j + 1 +! end if +! end do +! ! send +! j = 1 +! do i=1,numProcs +! if(nPartSend(i) > 0) then +! allocate(array1DIntSend(i)%val(nPartSend(i))) +! !print *, 'sending int ', trim(dimItr % memberName), ' to ', procNeighs(i) +! call get_nonhalo_data_from_particle_list_array(listSend(i)%list, dimItr % memberName, array1DIntSend(i)%val) +! !if( trim(dimItr % memberName) == 'currentBlock') print *, 'currentBlock sent ',nPartSend(i), & +! ! ' to ', procNeighs(i), ' = ', array1DIntSend(i)%val +!ifdef _MPI +! call MPI_ISend(array1DIntSend(i)%val, nPartSend(i), MPI_INTEGERKIND, procNeighs(i), & +! domain % dminfo % my_proc_id, domain % dminfo % comm, sendRequestID(j), mpi_ierr) +!endif +! j = j + 1 +! end if +! end do + +!ifdef _MPI +! call MPI_WaitAll(numRecv, recvRequestID, MPI_STATUSES_IGNORE, mpi_ierr) +!endif +! if (mpi_ierr /= 0) call mpas_log_write('mpi_ierr = ' COMMA mpi_ierr) +!ifdef _MPI +! call MPI_WaitAll(numSends, sendRequestID, MPI_STATUSES_IGNORE, mpi_ierr) +!endif +! if (mpi_ierr /= 0) print *, 'mpi_ierr = ', mpi_ierr + +! !do i=1,numProcs +! ! if(nPartRecv(i) > 0) print *, 'Received ', trim(dimItr % memberName), ' = ', array1DIntRecv(i) % val +! !end do + +! ! store values +! do i=1,numProcs +! if(nPartRecv(i) > 0) then +! ! place it in particle list +! call add_nonhalo_data_to_particle_list_array(listRecv(i)%list, dimItr % memberName, array1DIntRecv(i)%val) +! j = j + 1 +! end if +! end do + +! do i=1,numProcs +! if(nPartSend(i) > 0) deallocate(array1DIntSend(i)%val) +! end do +! do i=1,numProcs +! if(nPartRecv(i) > 0) deallocate(array1DIntRecv(i)%val) +! end do +! !call mpas_log_write( 'finished') +! else +! !call mpas_log_write( "Different field type than implemented during nonHalo communication!") +! end if +! elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then +! ! ignore dimensions for now and have this code so they aren't printed as an error message +! else +! write(message, *) "Different type expected in registry for key ", trim(dimItr % memberName), & +! " in nonHalo data for communication-- don't know what to do!" +! LIGHT_DEBUG_ALL_WRITE(message) +! end if +! end do + +! deallocate(array1DIntSend, array1DIntRecv, array1DRealSend, array1DRealRecv, recvRequestID, sendRequestID) +! LIGHT_DEBUG_WRITE('Finished primary MPI communication for nonhalo') + +! end subroutine communicate_particle_nonhalo_data!}}} !*********************************************************************** ! @@ -3710,70 +3713,70 @@ end subroutine communicate_particle_halo_data!}}} !> This routine allocates space for nonHaloData on the particlelist ! !----------------------------------------------------------------------- - subroutine allocate_nonHalo_data(domain, particlelist) !{{{ - implicit none - - type (domain_type), intent(in) :: domain - type (mpas_particle_list_type), pointer, intent(in) :: particlelist - type (mpas_pool_type), pointer :: lagrPartTrackPool - type (mpas_pool_iterator_type) :: dimItr - - integer :: i, nPart - real (kind=RKIND), dimension(:), pointer :: array1DRealPointer - integer, dimension(:), pointer :: array1DIntPointer - character (len=StrKIND) :: message - - - ! get number of particle on list - nPart = count_particlelist(particlelist) - - ! allocate zero arrays - allocate(array1DRealPointer(nPart)) - allocate(array1DIntPointer(nPart)) - array1DRealPointer = 0.0_RKIND - array1DIntPointer = 0 - - ! on each list, transmit relevant fields to associated processors - call mpas_pool_get_subpool(domain % blocklist % structs, 'lagrPartTrackNonHalo', lagrPartTrackPool) - call mpas_pool_begin_iteration(lagrPartTrackPool) - do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) - if (dimItr % memberType == MPAS_POOL_FIELD) then - if (dimItr % dataType == MPAS_POOL_REAL) then - call add_nonhalo_data_to_particle_list_array(particlelist, dimItr % memberName, array1DRealPointer) - elseif (dimItr % dataType == MPAS_POOL_INTEGER) then - call add_nonhalo_data_to_particle_list_array(particlelist, dimItr % memberName, array1DIntPointer) - else - LIGHT_DEBUG_ALL_WRITE("Different field type than implemented during halo communication!") - end if - elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then - ! ignore dimensions for now and have this code so they aren't printed as an error message - else - write(message, *) "Different type expected in registry for key ", trim(dimItr % memberName), & - " in halo data for communication-- don't know what to do!" - LIGHT_DEBUG_ALL_WRITE(message) - end if - end do - - ! deallocate arrays - deallocate(array1DRealPointer) - deallocate(array1DIntPointer) - - end subroutine allocate_nonHalo_data !}}} - - subroutine allocate_list_nonHalo_data(domain, listPL) !{{{ - implicit none - - type (domain_type), intent(in) :: domain - type (mpas_list_of_particle_list_type), dimension(:), pointer, intent(inout) :: listPL - - integer :: i, numList - - numList = size(listPL) - do i=1, numList - call allocate_nonHalo_data(domain, listPL(i)%list) - end do - - end subroutine allocate_list_nonHalo_data !}}} +! subroutine allocate_nonHalo_data(domain, particlelist) !{{{ +! implicit none + +! type (domain_type), intent(in) :: domain +! type (mpas_particle_list_type), pointer, intent(in) :: particlelist +! type (mpas_pool_type), pointer :: lagrPartTrackPool +! type (mpas_pool_iterator_type) :: dimItr + +! integer :: i, nPart +! real (kind=RKIND), dimension(:), pointer :: array1DRealPointer +! integer, dimension(:), pointer :: array1DIntPointer +! character (len=StrKIND) :: message + + +! ! get number of particle on list +! nPart = count_particlelist(particlelist) + +! ! allocate zero arrays +! allocate(array1DRealPointer(nPart)) +! allocate(array1DIntPointer(nPart)) +! array1DRealPointer = 0.0_RKIND +! array1DIntPointer = 0 + +! ! on each list, transmit relevant fields to associated processors +! call mpas_pool_get_subpool(domain % blocklist % structs, 'lagrPartTrackNonHalo', lagrPartTrackPool) +! call mpas_pool_begin_iteration(lagrPartTrackPool) +! do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) +! if (dimItr % memberType == MPAS_POOL_FIELD) then +! if (dimItr % dataType == MPAS_POOL_REAL) then +! call add_nonhalo_data_to_particle_list_array(particlelist, dimItr % memberName, array1DRealPointer) +! elseif (dimItr % dataType == MPAS_POOL_INTEGER) then +! call add_nonhalo_data_to_particle_list_array(particlelist, dimItr % memberName, array1DIntPointer) +! else +! LIGHT_DEBUG_ALL_WRITE("Different field type than implemented during halo communication!") +! end if +! elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then +! ! ignore dimensions for now and have this code so they aren't printed as an error message +! else +! write(message, *) "Different type expected in registry for key ", trim(dimItr % memberName), & +! " in halo data for communication-- don't know what to do!" +! LIGHT_DEBUG_ALL_WRITE(message) +! end if +! end do + +! ! deallocate arrays +! deallocate(array1DRealPointer) +! deallocate(array1DIntPointer) + +! end subroutine allocate_nonHalo_data !}}} + +! subroutine allocate_list_nonHalo_data(domain, listPL) !{{{ +! implicit none + +! type (domain_type), intent(in) :: domain +! type (mpas_list_of_particle_list_type), dimension(:), pointer, intent(inout) :: listPL + +! integer :: i, numList + +! numList = size(listPL) +! do i=1, numList +! call allocate_nonHalo_data(domain, listPL(i)%list) +! end do + +! end subroutine allocate_list_nonHalo_data !}}} !*********************************************************************** ! @@ -3967,69 +3970,69 @@ end subroutine read_haloData!}}} !> This routine reads nonhaloData input for this MPAS-Ocean analysis member. ! !----------------------------------------------------------------------- - subroutine read_nonhaloData(domain, err)!{{{ - - implicit none - - !----------------------------------------------------------------- - ! input/output variables - !----------------------------------------------------------------- - type (domain_type), intent(in) :: domain - - !----------------------------------------------------------------- - ! output variables - !----------------------------------------------------------------- - integer, intent(out) :: err !< Output: error flag - - !----------------------------------------------------------------- - ! local variables - !----------------------------------------------------------------- - type (block_type), pointer :: block - type (mpas_pool_type), pointer :: lagrPartTrackPool - type (mpas_pool_iterator_type) :: dimItr - type (mpas_particle_list_type), pointer :: particlelist - type (field1DReal), pointer :: field1DRealPointer - type (field1DInteger), pointer :: field1DIntPointer - character (len=StrKIND) :: message - - err = 0 - - block => domain % blocklist - do while (associated(block)) - ! allocate pointers - particlelist => block % particlelist - call mpas_pool_get_subpool(block % structs, 'lagrPartTrackNonHalo', lagrPartTrackPool) - - ! iterate over each member of the pool and make the relevant assignment - call mpas_pool_begin_iteration(lagrPartTrackPool) - do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) - ! determine the type of data - if (dimItr % memberType == MPAS_POOL_FIELD) then - if (dimItr % dataType == MPAS_POOL_REAL) then - call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DRealPointer) - call add_nonhalo_data_to_particle_list(particlelist, dimItr % memberName, field1DRealPointer) - elseif (dimItr % dataType == MPAS_POOL_INTEGER) then - call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DIntPointer) - call add_nonhalo_data_to_particle_list(particlelist, dimItr % memberName, field1DIntPointer) - else - LIGHT_DEBUG_WRITE("Different field type than implemented in nonHalo read!") - end if - elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then - ! ignore dimensions for now and have this code so they aren't printed as an error message - else - write(message, *) "Different type expected in registry for key ", trim(dimItr % memberName), & - " in nonHalo data for read-- don't know what to do!" - LIGHT_DEBUG_WRITE(message) - end if - end do - - ! alternatively, could initialize these fields or just make sure that they exist! - - block => block % next - end do - LIGHT_DEBUG_WRITE('Finished reading non-halo data') - - end subroutine read_nonhaloData!}}} +! subroutine read_nonhaloData(domain, err)!{{{ + +! implicit none + +! !----------------------------------------------------------------- +! ! input/output variables +! !----------------------------------------------------------------- +! type (domain_type), intent(in) :: domain + +! !----------------------------------------------------------------- +! ! output variables +! !----------------------------------------------------------------- +! integer, intent(out) :: err !< Output: error flag + +! !----------------------------------------------------------------- +! ! local variables +! !----------------------------------------------------------------- +! type (block_type), pointer :: block +! type (mpas_pool_type), pointer :: lagrPartTrackPool +! type (mpas_pool_iterator_type) :: dimItr +! type (mpas_particle_list_type), pointer :: particlelist +! type (field1DReal), pointer :: field1DRealPointer +! type (field1DInteger), pointer :: field1DIntPointer +! character (len=StrKIND) :: message + +! err = 0 + +! block => domain % blocklist +! do while (associated(block)) +! ! allocate pointers +! particlelist => block % particlelist +! call mpas_pool_get_subpool(block % structs, 'lagrPartTrackNonHalo', lagrPartTrackPool) + +! ! iterate over each member of the pool and make the relevant assignment +! call mpas_pool_begin_iteration(lagrPartTrackPool) +! do while(mpas_pool_get_next_member(lagrPartTrackPool, dimItr)) +! ! determine the type of data +! if (dimItr % memberType == MPAS_POOL_FIELD) then +! if (dimItr % dataType == MPAS_POOL_REAL) then +! call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DRealPointer) +! call add_nonhalo_data_to_particle_list(particlelist, dimItr % memberName, field1DRealPointer) +! elseif (dimItr % dataType == MPAS_POOL_INTEGER) then +! call mpas_pool_get_field(lagrPartTrackPool, dimItr % memberName, field1DIntPointer) +! call add_nonhalo_data_to_particle_list(particlelist, dimItr % memberName, field1DIntPointer) +! else +! LIGHT_DEBUG_WRITE("Different field type than implemented in nonHalo read!") +! end if +! elseif (dimItr % memberType == MPAS_POOL_DIMENSION) then +! ! ignore dimensions for now and have this code so they aren't printed as an error message +! else +! write(message, *) "Different type expected in registry for key ", trim(dimItr % memberName), & +! " in nonHalo data for read-- don't know what to do!" +! LIGHT_DEBUG_WRITE(message) +! end if +! end do + +! ! alternatively, could initialize these fields or just make sure that they exist! + +! block => block % next +! end do +! LIGHT_DEBUG_WRITE('Finished reading non-halo data') + +! end subroutine read_nonhaloData!}}} !*********************************************************************** ! From f8e862e7a79621737c5435cc8d17f78159999787 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Fri, 12 Jan 2018 09:16:54 -0700 Subject: [PATCH 051/182] Removes unused halo variables Removes vertexReconstMethod and horizTreatment --- .../Registry_lagrangian_particle_tracking.xml | 12 ------------ .../mpas_ocn_lagrangian_particle_tracking.F | 6 ++---- .../lagrangian_particle_tracking.xml | 6 ------ 3 files changed, 2 insertions(+), 22 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml index 7b950d049c..866d4f87b0 100644 --- a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml +++ b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml @@ -92,8 +92,6 @@ - - @@ -137,8 +135,6 @@ - - @@ -174,8 +170,6 @@ - - @@ -304,15 +298,9 @@ - - diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F index 522083551a..b8289603ff 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F @@ -300,7 +300,7 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ real (kind=RKIND) :: diffSubStepVert, diffParticlePositionVert, particleVelocityVert, verticalVelocityInterp real (kind=RKIND) :: buoyancyInterp real (kind=RKIND), pointer :: sphereRadius - integer, pointer :: verticalTreatment, vertexReconstMethod, timeIntegration, indexLevel, filterNum + integer, pointer :: verticalTreatment, timeIntegration, indexLevel, filterNum character(len=StrKIND), pointer :: config_dt type (MPAS_timeInterval_type) :: timeStepESMF logical :: resetParticle, resetParticleAny @@ -465,7 +465,6 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ call mpas_pool_get_array(particle % haloDataPool, 'zLevelParticle', zLevelParticle) call mpas_pool_get_array(particle % haloDataPool, 'verticalTreatment', verticalTreatment) - call mpas_pool_get_array(particle % haloDataPool, 'vertexReconstMethod', vertexReconstMethod) call mpas_pool_get_array(particle % haloDataPool, 'indexLevel', indexLevel) call mpas_pool_get_array(particle % haloDataPool, 'timeIntegration', timeIntegration) call mpas_pool_get_array(particle % haloDataPool, 'dtParticle', dtParticle) @@ -1686,7 +1685,7 @@ subroutine initialize_particle_properties(domain, timeLevel, err)!{{{ real (kind=RKIND) :: diffSubStepVert, diffParticlePositionVert, particleVelocityVert, verticalVelocityInterp real (kind=RKIND) :: buoyancyInterp real (kind=RKIND), pointer :: sphereRadius - integer, pointer :: verticalTreatment, vertexReconstMethod, timeIntegration, indexLevel, filterNum, iCell + integer, pointer :: verticalTreatment, timeIntegration, indexLevel, filterNum, iCell err = 0 @@ -1754,7 +1753,6 @@ subroutine initialize_particle_properties(domain, timeLevel, err)!{{{ call mpas_pool_get_array(particle % haloDataPool, 'zLevelParticle', zLevelParticle) call mpas_pool_get_array(particle % haloDataPool, 'verticalTreatment', verticalTreatment) - call mpas_pool_get_array(particle % haloDataPool, 'vertexReconstMethod', vertexReconstMethod) call mpas_pool_get_array(particle % haloDataPool, 'indexLevel', indexLevel) call mpas_pool_get_array(particle % haloDataPool, 'timeIntegration', timeIntegration) call mpas_pool_get_array(particle % haloDataPool, 'dtParticle', dtParticle) diff --git a/testing_and_setup/compass/ocean/templates/analysis_members/lagrangian_particle_tracking.xml b/testing_and_setup/compass/ocean/templates/analysis_members/lagrangian_particle_tracking.xml index 3f93587418..6ec72afd12 100644 --- a/testing_and_setup/compass/ocean/templates/analysis_members/lagrangian_particle_tracking.xml +++ b/testing_and_setup/compass/ocean/templates/analysis_members/lagrangian_particle_tracking.xml @@ -45,8 +45,6 @@ - - @@ -96,8 +94,6 @@ - - @@ -133,8 +129,6 @@ - - From 8fdacd06613de850e45550fa98a1ff4bab0ba402 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Fri, 12 Jan 2018 09:49:59 -0700 Subject: [PATCH 052/182] Makes timeIntegration a global namelist option --- .../Registry_lagrangian_particle_tracking.xml | 10 ++++------ .../mpas_ocn_lagrangian_particle_tracking.F | 7 +++---- .../analysis_members/lagrangian_particle_tracking.xml | 3 --- 3 files changed, 7 insertions(+), 13 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml index 866d4f87b0..c1cf2ca17c 100644 --- a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml +++ b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml @@ -31,6 +31,10 @@ description="Number of times to apply filtering operation." possible_values="0, 1, 2, ..." /> + - @@ -137,7 +140,6 @@ - @@ -172,7 +174,6 @@ - @@ -298,9 +299,6 @@ - diff --git a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F index b8289603ff..3c9e35c335 100644 --- a/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F +++ b/src/core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F @@ -300,7 +300,7 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ real (kind=RKIND) :: diffSubStepVert, diffParticlePositionVert, particleVelocityVert, verticalVelocityInterp real (kind=RKIND) :: buoyancyInterp real (kind=RKIND), pointer :: sphereRadius - integer, pointer :: verticalTreatment, timeIntegration, indexLevel, filterNum + integer, pointer :: verticalTreatment, indexLevel, filterNum, timeIntegration character(len=StrKIND), pointer :: config_dt type (MPAS_timeInterval_type) :: timeStepESMF logical :: resetParticle, resetParticleAny @@ -322,6 +322,7 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_reset_criteria', config_AM_lagrPartTrack_reset_criteria) call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_compute_interval', config_AM_lagrPartTrack_compute_interval) call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_output_stream', config_AM_lagrPartTrack_output_stream) + call mpas_pool_get_config(ocnConfigs, 'config_AM_lagrPartTrack_timeIntegration', timeIntegration) if (trim(config_AM_lagrPartTrack_reset_criteria) == 'none') then config_AM_lagrPartTrack_reset_particles = .False. @@ -466,7 +467,6 @@ subroutine ocn_compute_lagrangian_particle_tracking(domain, timeLevel, err)!{{{ call mpas_pool_get_array(particle % haloDataPool, 'verticalTreatment', verticalTreatment) call mpas_pool_get_array(particle % haloDataPool, 'indexLevel', indexLevel) - call mpas_pool_get_array(particle % haloDataPool, 'timeIntegration', timeIntegration) call mpas_pool_get_array(particle % haloDataPool, 'dtParticle', dtParticle) call mpas_pool_get_array(particle % haloDataPool, 'buoyancyParticle', buoyancyParticle) call mpas_pool_get_array(particle % haloDataPool, 'indexToParticleID', indexToParticleID) @@ -1685,7 +1685,7 @@ subroutine initialize_particle_properties(domain, timeLevel, err)!{{{ real (kind=RKIND) :: diffSubStepVert, diffParticlePositionVert, particleVelocityVert, verticalVelocityInterp real (kind=RKIND) :: buoyancyInterp real (kind=RKIND), pointer :: sphereRadius - integer, pointer :: verticalTreatment, timeIntegration, indexLevel, filterNum, iCell + integer, pointer :: verticalTreatment, indexLevel, filterNum, iCell err = 0 @@ -1754,7 +1754,6 @@ subroutine initialize_particle_properties(domain, timeLevel, err)!{{{ call mpas_pool_get_array(particle % haloDataPool, 'verticalTreatment', verticalTreatment) call mpas_pool_get_array(particle % haloDataPool, 'indexLevel', indexLevel) - call mpas_pool_get_array(particle % haloDataPool, 'timeIntegration', timeIntegration) call mpas_pool_get_array(particle % haloDataPool, 'dtParticle', dtParticle) call mpas_pool_get_array(particle % haloDataPool, 'buoyancyParticle', buoyancyParticle) call mpas_pool_get_array(particle % haloDataPool, 'indexToParticleID', indexToParticleID) diff --git a/testing_and_setup/compass/ocean/templates/analysis_members/lagrangian_particle_tracking.xml b/testing_and_setup/compass/ocean/templates/analysis_members/lagrangian_particle_tracking.xml index 6ec72afd12..fa436a1bb2 100644 --- a/testing_and_setup/compass/ocean/templates/analysis_members/lagrangian_particle_tracking.xml +++ b/testing_and_setup/compass/ocean/templates/analysis_members/lagrangian_particle_tracking.xml @@ -47,7 +47,6 @@ - @@ -96,7 +95,6 @@ - @@ -131,7 +129,6 @@ - From ec5adec7154afdcebad4eaea5847bede1a56bc77 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Fri, 12 Jan 2018 13:23:41 -0700 Subject: [PATCH 053/182] Removes autocorrelation calculation Also removes computed particle velocity BFB --- .../Registry_lagrangian_particle_tracking.xml | 28 --- .../mpas_ocn_lagrangian_particle_tracking.F | 173 +++++++++--------- ...s_ocn_lagrangian_particle_tracking_reset.F | 24 +-- 3 files changed, 99 insertions(+), 126 deletions(-) diff --git a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml index c1cf2ca17c..63b797d774 100644 --- a/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml +++ b/src/core_ocean/analysis_members/Registry_lagrangian_particle_tracking.xml @@ -101,8 +101,6 @@ - - @@ -142,11 +140,6 @@ - - - - - @@ -314,27 +307,6 @@ - - - - - - - - diff --git a/src/core_init_atmosphere/mpas_init_atm_static.F b/src/core_init_atmosphere/mpas_init_atm_static.F index 253d681f94..f676f6d07e 100644 --- a/src/core_init_atmosphere/mpas_init_atm_static.F +++ b/src/core_init_atmosphere/mpas_init_atm_static.F @@ -799,7 +799,6 @@ subroutine init_atm_static_orogwd(mesh, dims, configs) real(kind=RKIND), dimension(:), pointer :: latCell, lonCell real(kind=RKIND), dimension(:), pointer :: meshDensity real(kind=RKIND), dimension(:), pointer :: dcEdge - real(kind=RKIND), dimension(:), pointer :: varsso real(kind=RKIND), dimension(:), pointer :: con, oa1, oa2, oa3, oa4, ol1, ol2, ol3, ol4, var2d @@ -812,7 +811,6 @@ subroutine init_atm_static_orogwd(mesh, dims, configs) call mpas_pool_get_array(mesh, 'landmask', landmask) call mpas_pool_get_array(mesh, 'latCell', latCell) call mpas_pool_get_array(mesh, 'lonCell', lonCell) - call mpas_pool_get_array(mesh, 'varsso', varsso) call mpas_pool_get_array(mesh, 'meshDensity', meshDensity) call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) call mpas_pool_get_array(mesh, 'con', con) @@ -838,67 +836,6 @@ subroutine init_atm_static_orogwd(mesh, dims, configs) geog_data_path(i+1:i+1) = '/' end if -! -! Interpolate VARSSO: - varsso(:) = 0.0_RKIND - nx = 600 - ny = 600 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 4 - scalefactor = 1.0 - - dx = 0.00833333 - dy = 0.00833333 - known_x = 1.0 - known_y = 1.0 - known_lat = -59.99583 - known_lon = -179.99583 - - allocate(rarray(nx,ny,nz)) - allocate(nhs(nCells)) - nhs(:) = 0 - rarray(:,:,:) = 0._RKIND - do jTileStart = 1,13801,ny - jTileEnd = jTileStart + ny - 1 - - do iTileStart = 1,42601,nx - iTileEnd = iTileStart + nx -1 - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)//'varsso/', & - iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd - call mpas_log_write(trim(fname)) - - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - - iPoint = 1 - do j = 1,ny - do i = 1,nx - lat_pt = known_lat + (jTileStart + j - 2) * dy - lon_pt = known_lon + (iTileStart + i - 2) * dx - lat_pt = lat_pt * PI / 180.0 - lon_pt = lon_pt * PI / 180.0 - - iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & - nEdgesOnCell,cellsOnCell, & - latCell,lonCell) - varsso(iPoint) = varsso(iPoint) + rarray(i,j,1) - nhs(iPoint) = nhs(iPoint) + 1 - enddo - enddo - - enddo - enddo - - do iCell = 1,nCells - if(nhs(iCell) .gt. 0) & - varsso(iCell) = varsso(iCell) / real(nhs(iCell)) - enddo - deallocate(rarray) - deallocate(nhs) - call mpas_log_write('--- end interpolate VARSSO') !... statistic fields needed for the parameterization of gravity wavwe drag over orography. The !input directory depends on the mesh resolution, and the mesh must be a uniform mesh. From 5d70c9091d5cb2f0c836a1d0ade5826fc96951d8 Mon Sep 17 00:00:00 2001 From: Mark Petersen Date: Fri, 8 Jun 2018 14:36:46 -0600 Subject: [PATCH 058/182] Change == to .eqv. for gnu --- src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F index 9d84b8f4cb..d94cb0db9b 100644 --- a/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F +++ b/src/core_ocean/mode_forward/mpas_ocn_time_integration_split.F @@ -1063,7 +1063,7 @@ subroutine ocn_time_integrator_split(domain, dt)!{{{ end do ! block edgeHaloComputeCounter = edgeHaloComputeCounter - 1 - if ( BtrCorIter >= 1 .or. config_btr_solve_SSH2 == .false.) then + if ( BtrCorIter >= 1 .or. config_btr_solve_SSH2 .eqv. .false.) then cellHaloComputeCounter = cellHaloComputeCounter - 1 end if From b791a17ad58e3cbe0d81ce2213fdf0d015adf652 Mon Sep 17 00:00:00 2001 From: "Phillip J. Wolfram" Date: Fri, 3 Aug 2018 12:41:23 -0600 Subject: [PATCH 059/182] Fixes issue with mpich as noted by @xylar in #50 Ensures that mpich finds correct executable --- testing_and_setup/compass/setup_testcase.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/testing_and_setup/compass/setup_testcase.py b/testing_and_setup/compass/setup_testcase.py index d914ce88b6..5f7f71e911 100755 --- a/testing_and_setup/compass/setup_testcase.py +++ b/testing_and_setup/compass/setup_testcase.py @@ -1083,7 +1083,7 @@ def process_model_run_step(model_run_tag, configs, script): # {{{ config.get('executables', executable_name), link_path], stdout=dev_null, stderr=dev_null) - grandchild.text = executable_link + grandchild.text = './{}'.format(executable_link) elif arg_text.find('attr_') >= 0: attr_array = arg_text.split('_') try: From 45cc3a92fb2912a43e6d1eb662c3f8d31b1aa528 Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Sat, 4 Aug 2018 15:56:19 -0700 Subject: [PATCH 060/182] Change "quiet" to write stderr (but still not stdout) Before this merge, calls that are quiet suppress stderr. Since stderr is also not captured in a log file, it is not easy to know what went wrong without rerunning the step that failed. --- testing_and_setup/compass/setup_testcase.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/testing_and_setup/compass/setup_testcase.py b/testing_and_setup/compass/setup_testcase.py index 5f7f71e911..8cbb21825d 100755 --- a/testing_and_setup/compass/setup_testcase.py +++ b/testing_and_setup/compass/setup_testcase.py @@ -1135,7 +1135,7 @@ def wrap_subprocess_comment(command_args, indentation): # {{{ def wrap_subprocess_command(command_args, indentation, quiet): # {{{ # Setup command redirection if quiet: - redirect = ", stdout=dev_null, stderr=dev_null" + redirect = ", stdout=dev_null, stderr=None" else: redirect = "" From bb729b8b4f07d3636f929f2224f88af35c069138 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 13 Sep 2018 10:53:58 -0600 Subject: [PATCH 061/182] Use default null() initialization for pointer components of field types By providing default initialization for all pointer components of field types, we can eliminate all registry-generated code to nullify these components. Overall, it seems preferable to provide default initialization, since doing so eliminates the possiblity of accidentally forgetting to initialize these components of data structures. --- src/framework/mpas_field_types.inc | 161 ++++++++++++++++------------- src/tools/registry/gen_inc.c | 18 +--- 2 files changed, 89 insertions(+), 90 deletions(-) diff --git a/src/framework/mpas_field_types.inc b/src/framework/mpas_field_types.inc index 7940728041..2f98f791eb 100644 --- a/src/framework/mpas_field_types.inc +++ b/src/framework/mpas_field_types.inc @@ -10,10 +10,10 @@ type field5DReal ! Back-pointer to the containing block - type (block_type), pointer :: block + type (block_type), pointer :: block => null() ! Raw array holding field data on this block - real (kind=RKIND), dimension(:,:,:,:,:), pointer :: array + real (kind=RKIND), dimension(:,:,:,:,:), pointer :: array => null() ! Information used by the I/O layer character (len=StrKIND) :: fieldName @@ -30,12 +30,13 @@ type (att_lists_type), dimension(:), pointer :: attLists => null() ! Pointers to the prev and next blocks for this field on this task - type (field5DReal), pointer :: prev, next + type (field5DReal), pointer :: prev => null() + type (field5DReal), pointer :: next => null() ! Halo communication lists - type (mpas_multihalo_exchange_list), pointer :: sendList - type (mpas_multihalo_exchange_list), pointer :: recvList - type (mpas_multihalo_exchange_list), pointer :: copyList + type (mpas_multihalo_exchange_list), pointer :: sendList => null() + type (mpas_multihalo_exchange_list), pointer :: recvList => null() + type (mpas_multihalo_exchange_list), pointer :: copyList => null() end type field5DReal @@ -43,10 +44,10 @@ type field4DReal ! Back-pointer to the containing block - type (block_type), pointer :: block + type (block_type), pointer :: block => null() ! Raw array holding field data on this block - real (kind=RKIND), dimension(:,:,:,:), pointer :: array + real (kind=RKIND), dimension(:,:,:,:), pointer :: array => null() ! Information used by the I/O layer character (len=StrKIND) :: fieldName @@ -63,12 +64,13 @@ type (att_lists_type), dimension(:), pointer :: attLists => null() ! Pointers to the prev and next blocks for this field on this task - type (field4DReal), pointer :: prev, next + type (field4DReal), pointer :: prev => null() + type (field4DReal), pointer :: next => null() ! Halo communication lists - type (mpas_multihalo_exchange_list), pointer :: sendList - type (mpas_multihalo_exchange_list), pointer :: recvList - type (mpas_multihalo_exchange_list), pointer :: copyList + type (mpas_multihalo_exchange_list), pointer :: sendList => null() + type (mpas_multihalo_exchange_list), pointer :: recvList => null() + type (mpas_multihalo_exchange_list), pointer :: copyList => null() end type field4DReal @@ -77,10 +79,10 @@ type field3DReal ! Back-pointer to the containing block - type (block_type), pointer :: block + type (block_type), pointer :: block => null() ! Raw array holding field data on this block - real (kind=RKIND), dimension(:,:,:), pointer :: array + real (kind=RKIND), dimension(:,:,:), pointer :: array => null() ! Information used by the I/O layer character (len=StrKIND) :: fieldName @@ -97,12 +99,13 @@ type (att_lists_type), dimension(:), pointer :: attLists => null() ! Pointers to the prev and next blocks for this field on this task - type (field3DReal), pointer :: prev, next + type (field3DReal), pointer :: prev => null() + type (field3DReal), pointer :: next => null() ! Halo communication lists - type (mpas_multihalo_exchange_list), pointer :: sendList - type (mpas_multihalo_exchange_list), pointer :: recvList - type (mpas_multihalo_exchange_list), pointer :: copyList + type (mpas_multihalo_exchange_list), pointer :: sendList => null() + type (mpas_multihalo_exchange_list), pointer :: recvList => null() + type (mpas_multihalo_exchange_list), pointer :: copyList => null() end type field3DReal @@ -110,10 +113,10 @@ type field2DReal ! Back-pointer to the containing block - type (block_type), pointer :: block + type (block_type), pointer :: block => null() ! Raw array holding field data on this block - real (kind=RKIND), dimension(:,:), pointer :: array + real (kind=RKIND), dimension(:,:), pointer :: array => null() ! Information used by the I/O layer character (len=StrKIND) :: fieldName @@ -130,12 +133,13 @@ type (att_lists_type), dimension(:), pointer :: attLists => null() ! Pointers to the prev and next blocks for this field on this task - type (field2DReal), pointer :: prev, next + type (field2DReal), pointer :: prev => null() + type (field2DReal), pointer :: next => null() ! Halo communication lists - type (mpas_multihalo_exchange_list), pointer :: sendList - type (mpas_multihalo_exchange_list), pointer :: recvList - type (mpas_multihalo_exchange_list), pointer :: copyList + type (mpas_multihalo_exchange_list), pointer :: sendList => null() + type (mpas_multihalo_exchange_list), pointer :: recvList => null() + type (mpas_multihalo_exchange_list), pointer :: copyList => null() end type field2DReal @@ -143,10 +147,10 @@ type field1DReal ! Back-pointer to the containing block - type (block_type), pointer :: block + type (block_type), pointer :: block => null() ! Raw array holding field data on this block - real (kind=RKIND), dimension(:), pointer :: array + real (kind=RKIND), dimension(:), pointer :: array => null() ! Information used by the I/O layer character (len=StrKIND) :: fieldName @@ -163,12 +167,13 @@ type (att_lists_type), dimension(:), pointer :: attLists => null() ! Pointers to the prev and next blocks for this field on this task - type (field1DReal), pointer :: prev, next + type (field1DReal), pointer :: prev => null() + type (field1DReal), pointer :: next => null() ! Halo communication lists - type (mpas_multihalo_exchange_list), pointer :: sendList - type (mpas_multihalo_exchange_list), pointer :: recvList - type (mpas_multihalo_exchange_list), pointer :: copyList + type (mpas_multihalo_exchange_list), pointer :: sendList => null() + type (mpas_multihalo_exchange_list), pointer :: recvList => null() + type (mpas_multihalo_exchange_list), pointer :: copyList => null() end type field1DReal @@ -176,7 +181,7 @@ type field0DReal ! Back-pointer to the containing block - type (block_type), pointer :: block + type (block_type), pointer :: block => null() ! Raw array holding field data on this block real (kind=RKIND) :: scalar @@ -193,12 +198,13 @@ type (att_lists_type), dimension(:), pointer :: attLists => null() ! Pointers to the prev and next blocks for this field on this task - type (field0DReal), pointer :: prev, next + type (field0DReal), pointer :: prev => null() + type (field0DReal), pointer :: next => null() ! Halo communication lists - type (mpas_multihalo_exchange_list), pointer :: sendList - type (mpas_multihalo_exchange_list), pointer :: recvList - type (mpas_multihalo_exchange_list), pointer :: copyList + type (mpas_multihalo_exchange_list), pointer :: sendList => null() + type (mpas_multihalo_exchange_list), pointer :: recvList => null() + type (mpas_multihalo_exchange_list), pointer :: copyList => null() end type field0DReal @@ -206,10 +212,10 @@ type field3DInteger ! Back-pointer to the containing block - type (block_type), pointer :: block + type (block_type), pointer :: block => null() ! Raw array holding field data on this block - integer, dimension(:,:,:), pointer :: array + integer, dimension(:,:,:), pointer :: array => null() ! Information used by the I/O layer character (len=StrKIND) :: fieldName @@ -226,12 +232,13 @@ type (att_lists_type), dimension(:), pointer :: attLists => null() ! Pointers to the prev and next blocks for this field on this task - type (field3DInteger), pointer :: prev, next + type (field3DInteger), pointer :: prev => null() + type (field3DInteger), pointer :: next => null() ! Halo communication lists - type (mpas_multihalo_exchange_list), pointer :: sendList - type (mpas_multihalo_exchange_list), pointer :: recvList - type (mpas_multihalo_exchange_list), pointer :: copyList + type (mpas_multihalo_exchange_list), pointer :: sendList => null() + type (mpas_multihalo_exchange_list), pointer :: recvList => null() + type (mpas_multihalo_exchange_list), pointer :: copyList => null() end type field3DInteger @@ -239,10 +246,10 @@ type field2DInteger ! Back-pointer to the containing block - type (block_type), pointer :: block + type (block_type), pointer :: block => null() ! Raw array holding field data on this block - integer, dimension(:,:), pointer :: array + integer, dimension(:,:), pointer :: array => null() ! Information used by the I/O layer character (len=StrKIND) :: fieldName @@ -259,12 +266,13 @@ type (att_lists_type), dimension(:), pointer :: attLists => null() ! Pointers to the prev and next blocks for this field on this task - type (field2DInteger), pointer :: prev, next + type (field2DInteger), pointer :: prev => null() + type (field2DInteger), pointer :: next => null() ! Halo communication lists - type (mpas_multihalo_exchange_list), pointer :: sendList - type (mpas_multihalo_exchange_list), pointer :: recvList - type (mpas_multihalo_exchange_list), pointer :: copyList + type (mpas_multihalo_exchange_list), pointer :: sendList => null() + type (mpas_multihalo_exchange_list), pointer :: recvList => null() + type (mpas_multihalo_exchange_list), pointer :: copyList => null() end type field2DInteger @@ -272,10 +280,10 @@ type field1DInteger ! Back-pointer to the containing block - type (block_type), pointer :: block + type (block_type), pointer :: block => null() ! Raw array holding field data on this block - integer, dimension(:), pointer :: array + integer, dimension(:), pointer :: array => null() ! Information used by the I/O layer character (len=StrKIND) :: fieldName @@ -292,12 +300,13 @@ type (att_lists_type), dimension(:), pointer :: attLists => null() ! Pointers to the prev and next blocks for this field on this task - type (field1DInteger), pointer :: prev, next + type (field1DInteger), pointer :: prev => null() + type (field1DInteger), pointer :: next => null() ! Halo communication lists - type (mpas_multihalo_exchange_list), pointer :: sendList - type (mpas_multihalo_exchange_list), pointer :: recvList - type (mpas_multihalo_exchange_list), pointer :: copyList + type (mpas_multihalo_exchange_list), pointer :: sendList => null() + type (mpas_multihalo_exchange_list), pointer :: recvList => null() + type (mpas_multihalo_exchange_list), pointer :: copyList => null() end type field1DInteger @@ -305,7 +314,7 @@ type field0DInteger ! Back-pointer to the containing block - type (block_type), pointer :: block + type (block_type), pointer :: block => null() ! Raw array holding field data on this block integer :: scalar @@ -322,12 +331,13 @@ type (att_lists_type), dimension(:), pointer :: attLists => null() ! Pointers to the prev and next blocks for this field on this task - type (field0DInteger), pointer :: prev, next + type (field0DInteger), pointer :: prev => null() + type (field0DInteger), pointer :: next => null() ! Halo communication lists - type (mpas_multihalo_exchange_list), pointer :: sendList - type (mpas_multihalo_exchange_list), pointer :: recvList - type (mpas_multihalo_exchange_list), pointer :: copyList + type (mpas_multihalo_exchange_list), pointer :: sendList => null() + type (mpas_multihalo_exchange_list), pointer :: recvList => null() + type (mpas_multihalo_exchange_list), pointer :: copyList => null() end type field0DInteger @@ -335,10 +345,10 @@ type field1DChar ! Back-pointer to the containing block - type (block_type), pointer :: block + type (block_type), pointer :: block => null() ! Raw array holding field data on this block - character (len=StrKIND), dimension(:), pointer :: array + character (len=StrKIND), dimension(:), pointer :: array => null() ! Information used by the I/O layer character (len=StrKIND) :: fieldName @@ -355,12 +365,13 @@ type (att_lists_type), dimension(:), pointer :: attLists => null() ! Pointers to the prev and next blocks for this field on this task - type (field1DChar), pointer :: prev, next + type (field1DChar), pointer :: prev => null() + type (field1DChar), pointer :: next => null() ! Halo communication lists - type (mpas_multihalo_exchange_list), pointer :: sendList - type (mpas_multihalo_exchange_list), pointer :: recvList - type (mpas_multihalo_exchange_list), pointer :: copyList + type (mpas_multihalo_exchange_list), pointer :: sendList => null() + type (mpas_multihalo_exchange_list), pointer :: recvList => null() + type (mpas_multihalo_exchange_list), pointer :: copyList => null() end type field1DChar @@ -368,7 +379,7 @@ type field0DChar ! Back-pointer to the containing block - type (block_type), pointer :: block + type (block_type), pointer :: block => null() ! Raw array holding field data on this block character (len=StrKIND) :: scalar @@ -385,12 +396,13 @@ type (att_lists_type), dimension(:), pointer :: attLists => null() ! Pointers to the prev and next blocks for this field on this task - type (field0DChar), pointer :: prev, next + type (field0DChar), pointer :: prev => null() + type (field0DChar), pointer :: next => null() ! Halo communication lists - type (mpas_multihalo_exchange_list), pointer :: sendList - type (mpas_multihalo_exchange_list), pointer :: recvList - type (mpas_multihalo_exchange_list), pointer :: copyList + type (mpas_multihalo_exchange_list), pointer :: sendList => null() + type (mpas_multihalo_exchange_list), pointer :: recvList => null() + type (mpas_multihalo_exchange_list), pointer :: copyList => null() end type field0DChar @@ -398,7 +410,7 @@ type field0DLogical ! Back-pointer to the containing block - type (block_type), pointer :: block + type (block_type), pointer :: block => null() ! Raw array holding field data on this block logical :: scalar @@ -415,11 +427,12 @@ type (att_lists_type), dimension(:), pointer :: attLists => null() ! Pointers to the prev and next blocks for this field on this task - type (field0DLogical), pointer :: prev, next + type (field0DLogical), pointer :: prev => null() + type (field0DLogical), pointer :: next => null() ! Halo communication lists - type (mpas_multihalo_exchange_list), pointer :: sendList - type (mpas_multihalo_exchange_list), pointer :: recvList - type (mpas_multihalo_exchange_list), pointer :: copyList + type (mpas_multihalo_exchange_list), pointer :: sendList => null() + type (mpas_multihalo_exchange_list), pointer :: recvList => null() + type (mpas_multihalo_exchange_list), pointer :: copyList => null() end type field0DLogical diff --git a/src/tools/registry/gen_inc.c b/src/tools/registry/gen_inc.c index 90074576e5..0518d03139 100644 --- a/src/tools/registry/gen_inc.c +++ b/src/tools/registry/gen_inc.c @@ -1316,17 +1316,10 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var fortprintf(fd, "\n"); - if ( ndims > 0 ) { - fortprintf(fd, " nullify(%s(%d) %% array)\n", pointer_name, time_lev); - } else { + if ( ndims == 0 ) { fortprintf(fd, " %s(%d) %% scalar = %s\n", pointer_name, time_lev, default_value); } fortprintf(fd, " %s(%d) %% defaultValue = %s\n", pointer_name, time_lev, default_value); - fortprintf(fd, " nullify(%s(%d) %% next)\n", pointer_name, time_lev); - fortprintf(fd, " nullify(%s(%d) %% prev)\n", pointer_name, time_lev); - fortprintf(fd, " nullify(%s(%d) %% sendList)\n", pointer_name, time_lev); - fortprintf(fd, " nullify(%s(%d) %% recvList)\n", pointer_name, time_lev); - fortprintf(fd, " nullify(%s(%d) %% copyList)\n", pointer_name, time_lev); fortprintf(fd, " allocate(%s(%d) %% attLists(size(%s(%d) %% constituentNames, dim=1)))\n", pointer_name, time_lev, pointer_name, time_lev); fortprintf(fd, " do index_counter = 1, size(%s(%d) %% constituentNames, dim=1)\n", pointer_name, time_lev); @@ -1556,16 +1549,9 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa fortprintf(fd, " %s(%d) %% defaultValue = %s\n", pointer_name, time_lev, default_value); fortprintf(fd, " %s(%d) %% defaultValue = %s\n", pointer_name, time_lev, default_value); - if ( ndims > 0 ) { - fortprintf(fd, " nullify(%s(%d) %% array)\n", pointer_name, time_lev); - } else { + if ( ndims == 0 ) { fortprintf(fd, " %s(%d) %% scalar = %s\n", pointer_name, time_lev, default_value); } - fortprintf(fd, " nullify(%s(%d) %% next)\n", pointer_name, time_lev); - fortprintf(fd, " nullify(%s(%d) %% prev)\n", pointer_name, time_lev); - fortprintf(fd, " nullify(%s(%d) %% sendList)\n", pointer_name, time_lev); - fortprintf(fd, " nullify(%s(%d) %% recvList)\n", pointer_name, time_lev); - fortprintf(fd, " nullify(%s(%d) %% copyList)\n", pointer_name, time_lev); fortprintf(fd, " allocate(%s(%d) %% attLists(1))\n", pointer_name, time_lev); fortprintf(fd, " allocate(%s(%d) %% attLists(1) %% attList)\n", pointer_name, time_lev); fortprintf(fd, " %s(%d) %% attLists(1) %% attList %% attName = ''\n", pointer_name, time_lev); From 2a401af2d4068397489ecca3cc3a3a4060b535cf Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 13 Sep 2018 11:09:33 -0600 Subject: [PATCH 062/182] Avoid unnecessary nullification of attList components in registry-generated code The 'next', 'attValueIntA', and 'attValueRealA' components of attribute lists already have default initialization to null() in mpas_attlist_types.inc, so there's no need to redundantly nullify these components in registry-generated code. --- src/tools/registry/gen_inc.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/tools/registry/gen_inc.c b/src/tools/registry/gen_inc.c index 0518d03139..48ef1faa23 100644 --- a/src/tools/registry/gen_inc.c +++ b/src/tools/registry/gen_inc.c @@ -1326,9 +1326,6 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var fortprintf(fd, " allocate(%s(%d) %% attLists(index_counter) %% attList)\n", pointer_name, time_lev); fortprintf(fd, " %s(%d) %% attLists(index_counter) %% attList %% attName = ''\n", pointer_name, time_lev); fortprintf(fd, " %s(%d) %% attLists(index_counter) %% attList %% attType = -1\n", pointer_name, time_lev); - fortprintf(fd, " nullify(%s(%d) %% attLists(index_counter) %% attList %% next)\n", pointer_name, time_lev); - fortprintf(fd, " nullify(%s(%d) %% attLists(index_counter) %% attList %% attValueIntA)\n", pointer_name, time_lev); - fortprintf(fd, " nullify(%s(%d) %% attLists(index_counter) %% attList %% attValueRealA)\n", pointer_name, time_lev); fortprintf(fd, " end do\n"); for(var_xml = ezxml_child(var_arr_xml, "var"); var_xml; var_xml = var_xml->next){ @@ -1556,9 +1553,6 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa fortprintf(fd, " allocate(%s(%d) %% attLists(1) %% attList)\n", pointer_name, time_lev); fortprintf(fd, " %s(%d) %% attLists(1) %% attList %% attName = ''\n", pointer_name, time_lev); fortprintf(fd, " %s(%d) %% attLists(1) %% attList %% attType = -1\n", pointer_name, time_lev); - fortprintf(fd, " nullify(%s(%d) %% attLists(1) %% attList %% next)\n", pointer_name, time_lev); - fortprintf(fd, " nullify(%s(%d) %% attLists(1) %% attList %% attValueIntA)\n", pointer_name, time_lev); - fortprintf(fd, " nullify(%s(%d) %% attLists(1) %% attList %% attValueRealA)\n", pointer_name, time_lev); if ( varunits != NULL ) { string = strdup(varunits); From 43c9f93f3d4fa84e2769fb0415da889f7c754aed Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 13 Sep 2018 11:20:10 -0600 Subject: [PATCH 063/182] Provide default initialization for attribute list name and type In order to avoid the need to generate code to initialize the attName and attType components of attribute list nodes in the registry, we now provide default initialization for these components in mpas_attlist_types.inc. --- src/framework/mpas_attlist_types.inc | 4 ++-- src/tools/registry/gen_inc.c | 4 ---- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/src/framework/mpas_attlist_types.inc b/src/framework/mpas_attlist_types.inc index 0d2652e063..8c664bdcbe 100644 --- a/src/framework/mpas_attlist_types.inc +++ b/src/framework/mpas_attlist_types.inc @@ -10,8 +10,8 @@ ! Derived type for holding field attributes type att_list_type - character (len=StrKIND) :: attName - integer :: attType + character (len=StrKIND) :: attName = '' + integer :: attType = -1 integer :: attValueInt integer, dimension(:), pointer :: attValueIntA => null() real (kind=RKIND) :: attValueReal diff --git a/src/tools/registry/gen_inc.c b/src/tools/registry/gen_inc.c index 48ef1faa23..d2753186cf 100644 --- a/src/tools/registry/gen_inc.c +++ b/src/tools/registry/gen_inc.c @@ -1324,8 +1324,6 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var fortprintf(fd, " do index_counter = 1, size(%s(%d) %% constituentNames, dim=1)\n", pointer_name, time_lev); fortprintf(fd, " allocate(%s(%d) %% attLists(index_counter) %% attList)\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% attLists(index_counter) %% attList %% attName = ''\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% attLists(index_counter) %% attList %% attType = -1\n", pointer_name, time_lev); fortprintf(fd, " end do\n"); for(var_xml = ezxml_child(var_arr_xml, "var"); var_xml; var_xml = var_xml->next){ @@ -1551,8 +1549,6 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa } fortprintf(fd, " allocate(%s(%d) %% attLists(1))\n", pointer_name, time_lev); fortprintf(fd, " allocate(%s(%d) %% attLists(1) %% attList)\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% attLists(1) %% attList %% attName = ''\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% attLists(1) %% attList %% attType = -1\n", pointer_name, time_lev); if ( varunits != NULL ) { string = strdup(varunits); From b348bf913e84994e39c8fc5d7759fcfbf79ce770 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 13 Sep 2018 11:28:59 -0600 Subject: [PATCH 064/182] In registry-generated code, fix bug where defaultValue was set twice The defaultValue for fields was being set twice (in successive lines) in the code generated by the registry to define new fields. This commit simply eliminates the redundant line from each variable definition, and it also fixes a minor indentation issue in the generated code. --- src/tools/registry/gen_inc.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/tools/registry/gen_inc.c b/src/tools/registry/gen_inc.c index d2753186cf..f0f69a2112 100644 --- a/src/tools/registry/gen_inc.c +++ b/src/tools/registry/gen_inc.c @@ -1542,10 +1542,9 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa free(tofree); } - fortprintf(fd, " %s(%d) %% defaultValue = %s\n", pointer_name, time_lev, default_value); - fortprintf(fd, " %s(%d) %% defaultValue = %s\n", pointer_name, time_lev, default_value); + fortprintf(fd, " %s(%d) %% defaultValue = %s\n", pointer_name, time_lev, default_value); if ( ndims == 0 ) { - fortprintf(fd, " %s(%d) %% scalar = %s\n", pointer_name, time_lev, default_value); + fortprintf(fd, " %s(%d) %% scalar = %s\n", pointer_name, time_lev, default_value); } fortprintf(fd, " allocate(%s(%d) %% attLists(1))\n", pointer_name, time_lev); fortprintf(fd, " allocate(%s(%d) %% attLists(1) %% attList)\n", pointer_name, time_lev); From 126af268f095cfebeab801b570dcfa3af7fdf524 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 13 Sep 2018 14:16:59 -0600 Subject: [PATCH 065/182] Remove calls to get subpools, left over from sounding code that was relocated The call to mpas_atm_soundings_write was originally made at the end of the time integration loop directly from mpas_atm_core_run(...). Commit 156cae7a moved calls to the soundings module into the diagnostics framework, but it didn't remove the calls to mpas_pool_get_subpool(...). These subpool calls are not needed and can be safely deleted. --- src/core_atmosphere/mpas_atm_core.F | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index b431e9cc1c..3d0197071f 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -693,15 +693,10 @@ function atm_core_run(domain) result(ierr) call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=ierr) - block_ptr => domain % blocklist - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block_ptr % structs, 'state', state) - call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) - call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) - end do end function atm_core_run + subroutine atm_compute_output_diagnostics(state, time_lev, diag, mesh) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 8238256536fd88611da482df0373f68ed9b940e1 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 13 Sep 2018 15:01:44 -0600 Subject: [PATCH 066/182] Remove atm_compute_restart_diagnostics routine The atm_compute_restart_diagnostics routine was previously used to compute theta and rho before a restart file was written. However, there is an earlier call to atm_compute_output_diagnostics that also computes theta and rho (and also pressure) before any output stream (restart or otherwise) is written, making redundant the call to atm_compute_restart_diagnostics. --- src/core_atmosphere/mpas_atm_core.F | 60 ----------------------------- 1 file changed, 60 deletions(-) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index b431e9cc1c..620ff61e78 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -633,20 +633,6 @@ function atm_core_run(domain) result(ierr) call mpas_atm_diag_update() call mpas_atm_diag_compute() - - if (MPAS_stream_mgr_ringing_alarms(domain % streamManager, streamID='restart', direction=MPAS_STREAM_OUTPUT, ierr=ierr)) then - block_ptr => domain % blocklist - do while (associated(block_ptr)) - - call mpas_pool_get_subpool(block_ptr % structs, 'state', state) - call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) - call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) - call atm_compute_restart_diagnostics(state, 1, diag, mesh) - - block_ptr => block_ptr % next - end do - end if call mpas_dmpar_get_time(diag_stop_time) call mpas_dmpar_get_time(output_start_time) @@ -755,52 +741,6 @@ subroutine atm_compute_output_diagnostics(state, time_lev, diag, mesh) end subroutine atm_compute_output_diagnostics - subroutine atm_compute_restart_diagnostics(state, time_lev, diag, mesh) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Compute diagnostic fields for a domain to be written to restart files - ! - ! Input: state - contains model prognostic fields - ! mesh - contains grid metadata - ! - ! Output: state - upon returning, diagnostic fields will have be computed - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - use mpas_constants - - implicit none - - type (mpas_pool_type), intent(inout) :: state - integer, intent(in) :: time_lev ! which time level to use from state - type (mpas_pool_type), intent(inout) :: diag - type (mpas_pool_type), intent(in) :: mesh - - integer :: iCell, k - integer, pointer :: nCells, nVertLevels, index_qv - real (kind=RKIND), dimension(:,:), pointer :: theta, rho, theta_m, rho_zz, zz - real (kind=RKIND), dimension(:,:,:), pointer :: scalars - - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(state, 'index_qv', index_qv) - - call mpas_pool_get_array(state, 'theta_m', theta_m, time_lev) - call mpas_pool_get_array(state, 'rho_zz', rho_zz, time_lev) - call mpas_pool_get_array(state, 'scalars', scalars, time_lev) - - call mpas_pool_get_array(diag, 'theta', theta) - call mpas_pool_get_array(diag, 'rho', rho) - - call mpas_pool_get_array(mesh, 'zz', zz) - - do iCell=1,nCells - do k=1,nVertLevels - theta(k,iCell) = theta_m(k,iCell) / (1.0_RKIND + rvord * scalars(index_qv,k,iCell)) - rho(k,iCell) = rho_zz(k,iCell) * zz(k,iCell) - end do - end do - - end subroutine atm_compute_restart_diagnostics - subroutine atm_reset_diagnostics(diag, diag_physics) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! reset some diagnostics after output From 464f35456fba26f0922e622ece8978161d0eb085 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 7 Jun 2018 14:59:20 -0600 Subject: [PATCH 067/182] Remove code to interpolate pre-computed GWDO fields The init_atm_static_orogwd routine was previously used to interpolate statistics of sub-grid-scale orography from pre-computed datasets at fixed resolutions (e.g., 2-deg, 1-deg, 30-arc-min, 10-arc-min). Certain MPAS meshes, e.g., the quasi-uniform 15-km mesh, were not handled, and in general, the approach of using pre-computed statistics at fixed spatial resolutions was problematic for variable-resolution meshes. As of the v5.0 release of MPAS-Atmosphere, we have code to compute the GWDO statistics directly on the native MPAS mesh, which more or less obviates the need for the older init_atm_static_orogwd routine. Thus, this commit deletes the init_atm_static_orogwd routine. --- .../mpas_init_atm_cases.F | 1 - .../mpas_init_atm_static.F | 1151 ----------------- 2 files changed, 1152 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 25b2b9719d..b2c9b72aba 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -204,7 +204,6 @@ subroutine init_atm_setup_case(domain, stream_manager) end if call init_atm_static(mesh, block_ptr % dimensions, block_ptr % configs) - call init_atm_static_orogwd(mesh, block_ptr % dimensions, block_ptr % configs) end if if (config_native_gwd_static) then diff --git a/src/core_init_atmosphere/mpas_init_atm_static.F b/src/core_init_atmosphere/mpas_init_atm_static.F index f676f6d07e..322edc5fee 100644 --- a/src/core_init_atmosphere/mpas_init_atm_static.F +++ b/src/core_init_atmosphere/mpas_init_atm_static.F @@ -21,7 +21,6 @@ module mpas_init_atm_static implicit none private public:: init_atm_static, & - init_atm_static_orogwd, & init_atm_check_read_error, & nearest_cell, & sphere_distance @@ -755,1156 +754,6 @@ subroutine init_atm_static(mesh, dims, configs) end subroutine init_atm_static -!================================================================================================== - subroutine init_atm_static_orogwd(mesh, dims, configs) -!================================================================================================== - -!inout arguments: - type (mpas_pool_type), intent(inout) :: mesh - type (mpas_pool_type), intent(in) :: dims - type (mpas_pool_type), intent(in) :: configs - -!local variables: - type(proj_info):: proj - - character(len=StrKIND) :: mess - character(len=StrKIND) :: fname - character(len=StrKIND) :: dir_gwdo - character(len=StrKIND), pointer :: config_geog_data_path - character(len=StrKIND+1) :: geog_data_path ! same as config_geog_data_path, but guaranteed to have a trailing slash - - integer, pointer :: nCells, nEdges, maxEdges - - integer, dimension(:), pointer :: nEdgesOnCell - integer, dimension(:,:), pointer :: cellsOnCell - integer, dimension(:), pointer :: landmask - - integer:: nx,ny,nz - integer:: endian,isigned,istatus,wordsize - integer:: i,j - integer:: iCell,iPoint,iTileStart,iTileEnd,jTileStart,jTileEnd - integer,dimension(5) :: interp_list - integer,dimension(:),allocatable:: nhs - - real(kind=4):: scalefactor - real(kind=4),dimension(:,:,:),allocatable:: rarray - - real(kind=RKIND):: lat,lon,x,y - real(kind=RKIND):: lat_pt,lon_pt - real(kind=RKIND):: dx,dy,known_lat,known_lon,known_x,known_y - real(kind=RKIND):: minMeshD,maxMeshD - real(kind=RKIND):: mindcEdge,maxdcEdge - real(kind=RKIND),dimension(:,:),allocatable:: xarray - - real(kind=RKIND), dimension(:), pointer :: latCell, lonCell - real(kind=RKIND), dimension(:), pointer :: meshDensity - real(kind=RKIND), dimension(:), pointer :: dcEdge - real(kind=RKIND), dimension(:), pointer :: con, oa1, oa2, oa3, oa4, ol1, ol2, ol3, ol4, var2d - - - call mpas_pool_get_dimension(dims, 'nCells', nCells) - call mpas_pool_get_dimension(dims, 'nEdges', nEdges) - call mpas_pool_get_dimension(dims, 'maxEdges', maxEdges) - - call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) - call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) - call mpas_pool_get_array(mesh, 'landmask', landmask) - call mpas_pool_get_array(mesh, 'latCell', latCell) - call mpas_pool_get_array(mesh, 'lonCell', lonCell) - call mpas_pool_get_array(mesh, 'meshDensity', meshDensity) - call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) - call mpas_pool_get_array(mesh, 'con', con) - call mpas_pool_get_array(mesh, 'oa1', oa1) - call mpas_pool_get_array(mesh, 'oa2', oa2) - call mpas_pool_get_array(mesh, 'oa3', oa3) - call mpas_pool_get_array(mesh, 'oa4', oa4) - call mpas_pool_get_array(mesh, 'ol1', ol1) - call mpas_pool_get_array(mesh, 'ol2', ol2) - call mpas_pool_get_array(mesh, 'ol3', ol3) - call mpas_pool_get_array(mesh, 'ol4', ol4) - call mpas_pool_get_array(mesh, 'var2d', var2d) - - - call mpas_log_write('') - call mpas_log_write('--- enter subroutine init_atm_static_orogwd:') - - call mpas_pool_get_config(configs, 'config_geog_data_path', config_geog_data_path) - - write(geog_data_path, '(a)') config_geog_data_path - i = len_trim(geog_data_path) - if (geog_data_path(i:i) /= '/') then - geog_data_path(i+1:i+1) = '/' - end if - - -!... statistic fields needed for the parameterization of gravity wavwe drag over orography. The -!input directory depends on the mesh resolution, and the mesh must be a uniform mesh. - minMeshD = minval(meshDensity(1:nCells)) - maxMeshD = maxval(meshDensity(1:nCells)) - mindcEdge = minval(dcEdge(1:nEdges)) - maxdcEdge = maxval(dcEdge(1:nEdges)) - - call mpas_log_write('') - call mpas_log_write('BEGIN INTERPOLATION OF STATISTICAL FIELDS FOR GRAVITY WAVE DRAG OVER OROGRAPHY') - call mpas_log_write('min MeshD = $r', realArgs=(/minMeshD/)) - call mpas_log_write('max MeshD = $r', realArgs=(/maxMeshD/)) - call mpas_log_write('min dcEdge = $r', realArgs=(/mindcEdge/)) - call mpas_log_write('max dcEdge = $r', realArgs=(/maxdcEdge/)) - - dir_gwdo = ' ' - if(minMeshD == 1.0_RKIND .and. maxMeshD == 1.0_RKIND) then - !... uniform 10242 mesh: - if(mindcEdge .ge. 200000._RKIND .and. maxdcEdge .lt. 260000._RKIND) then - dir_gwdo = 'orogwd_2deg' - elseif(mindcEdge .ge. 90000._RKIND .and. maxdcEdge .lt. 150000_RKIND) then - dir_gwdo = 'orogwd_1deg' - elseif(mindcEdge .ge. 40000._RKIND .and. maxdcEdge .lt. 70000._RKIND) then - dir_gwdo = 'orogwd_30m' - else - call mpas_log_write('') - call mpas_log_write('GWDO: Interpolation not available. Set config_gwdo_scheme = .false.', messageType=MPAS_LOG_WARN) - return - endif - else - call mpas_log_write('') - call mpas_log_write('GWDO: The input mesh must be a uniform mesh. Set config_gwdo_scheme = .false.', messageType=MPAS_LOG_WARN) - return - endif - call mpas_log_write('dir_gwdo = '//trim(dir_gwdo)) - call mpas_log_write('') - -! -! Interpolate CON: -! - con(:) = 0.0_RKIND - - con_select: select case(dir_gwdo) - case("orogwd_2deg") - nx = 180 - ny = 90 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.025 - dx = 2.0 - dy = 2.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.0 - known_lon = 1.0 - case("orogwd_1deg") - nx = 360 - ny = 180 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.025 - dx = 1.0 - dy = 1.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.5 - known_lon = 0.5 - case("orogwd_30m") - nx = 720 - ny = 360 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.025 - dx = 0.5 - dy = 0.5 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.75 - known_lon = 0.25 - case("orogwd_10m") - nx = 2160 - ny = 1080 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.025 - dx = 0.16666667 - dy = 0.16666667 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.916667 - known_lon = 0.0833333 - case default - end select con_select - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') & - trim(geog_data_path)//trim(dir_gwdo)//'/con/',1,'-',nx,'.',1,'-',ny - call mpas_log_write(trim(fname)) - - allocate(xarray(nx,ny)) - allocate(rarray(nx,ny,nz)) - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) - - call map_set(PROJ_LATLON, proj, & - latinc = dy, & - loninc = dx, & - knowni = known_x, & - knownj = known_y, & - lat1 = known_lat, & - lon1 = known_lon) - - interp_list(1) = AVERAGE4 - interp_list(2) = AVERAGE4 - interp_list(3) = AVERAGE4 - interp_list(4) = AVERAGE4 - interp_list(5) = 0 - - do iCell = 1,nCells - if(landmask(iCell) == 1) then - lat = latCell(iCell) * DEG_PER_RAD - lon = lonCell(iCell) * DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - con(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) - endif - enddo - deallocate(rarray) - deallocate(xarray) - call mpas_log_write('--- end interpolate CON') - -! -! Interpolate OA1: -! - oa1(:) = 0.0_RKIND - - oa1_select: select case(dir_gwdo) - case("orogwd_2deg") - nx = 180 - ny = 90 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 2.0 - dy = 2.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.0 - known_lon = 1.0 - case("orogwd_1deg") - nx = 360 - ny = 180 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 1.0 - dy = 1.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.5 - known_lon = 0.5 - case("orogwd_30m") - nx = 720 - ny = 360 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.5 - dy = 0.5 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.75 - known_lon = 0.25 - case("orogwd_10m") - nx = 2160 - ny = 1080 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.16666667 - dy = 0.16666667 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.916667 - known_lon = 0.0833333 - case default - end select oa1_select - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') & - trim(geog_data_path)//trim(dir_gwdo)//'/oa1/',1,'-',nx,'.',1,'-',ny - call mpas_log_write(trim(fname)) - - allocate(xarray(nx,ny)) - allocate(rarray(nx,ny,nz)) - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) - - call map_set(PROJ_LATLON, proj, & - latinc = dy, & - loninc = dx, & - knowni = known_x, & - knownj = known_y, & - lat1 = known_lat, & - lon1 = known_lon) - - interp_list(1) = AVERAGE4 - interp_list(2) = AVERAGE4 - interp_list(3) = AVERAGE4 - interp_list(4) = AVERAGE4 - interp_list(5) = 0 - - do iCell = 1,nCells - if(landmask(iCell) == 1) then - lat = latCell(iCell) * DEG_PER_RAD - lon = lonCell(iCell) * DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - oa1(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) - endif - enddo - deallocate(rarray) - deallocate(xarray) - call mpas_log_write('--- end interpolate OA1') - -! -! Interpolate OA2: - oa2(:) = 0.0_RKIND - - oa2_select: select case(dir_gwdo) - case("orogwd_2deg") - nx = 180 - ny = 90 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 2.0 - dy = 2.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.0 - known_lon = 1.0 - case("orogwd_1deg") - nx = 360 - ny = 180 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 1.0 - dy = 1.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.5 - known_lon = 0.5 - case("orogwd_30m") - nx = 720 - ny = 360 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.5 - dy = 0.5 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.75 - known_lon = 0.25 - case("orogwd_10m") - nx = 2160 - ny = 1080 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.16666667 - dy = 0.16666667 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.916667 - known_lon = 0.0833333 - case default - end select oa2_select - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') & - trim(geog_data_path)//trim(dir_gwdo)//'/oa2/',1,'-',nx,'.',1,'-',ny - call mpas_log_write(trim(fname)) - - allocate(xarray(nx,ny)) - allocate(rarray(nx,ny,nz)) - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) - - call map_set(PROJ_LATLON, proj, & - latinc = dy, & - loninc = dx, & - knowni = known_x, & - knownj = known_y, & - lat1 = known_lat, & - lon1 = known_lon) - - interp_list(1) = AVERAGE4 - interp_list(2) = AVERAGE4 - interp_list(3) = AVERAGE4 - interp_list(4) = AVERAGE4 - interp_list(5) = 0 - - do iCell = 1,nCells - if(landmask(iCell) == 1) then - lat = latCell(iCell) * DEG_PER_RAD - lon = lonCell(iCell) * DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - oa2(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) - endif - enddo - deallocate(rarray) - deallocate(xarray) - call mpas_log_write('--- end interpolate OA2') - -! -! Interpolate OA3: -! - oa3(:) = 0.0_RKIND - - oa3_select: select case(dir_gwdo) - case("orogwd_2deg") - nx = 180 - ny = 90 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 2.0 - dy = 2.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.0 - known_lon = 1.0 - case("orogwd_1deg") - nx = 360 - ny = 180 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 1.0 - dy = 1.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.5 - known_lon = 0.5 - case("orogwd_30m") - nx = 720 - ny = 360 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.5 - dy = 0.5 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.75 - known_lon = 0.25 - case("orogwd_10m") - nx = 2160 - ny = 1080 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.16666667 - dy = 0.16666667 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.916667 - known_lon = 0.0833333 - case default - end select oa3_select - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') & - trim(geog_data_path)//trim(dir_gwdo)//'/oa3/',1,'-',nx,'.',1,'-',ny - call mpas_log_write(trim(fname)) - - allocate(xarray(nx,ny)) - allocate(rarray(nx,ny,nz)) - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) - - call map_set(PROJ_LATLON, proj, & - latinc = dy, & - loninc = dx, & - knowni = known_x, & - knownj = known_y, & - lat1 = known_lat, & - lon1 = known_lon) - - interp_list(1) = AVERAGE4 - interp_list(2) = AVERAGE4 - interp_list(3) = AVERAGE4 - interp_list(4) = AVERAGE4 - interp_list(5) = 0 - - do iCell = 1,nCells - if(landmask(iCell) == 1) then - lat = latCell(iCell) * DEG_PER_RAD - lon = lonCell(iCell) * DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - oa3(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) - endif - enddo - deallocate(rarray) - deallocate(xarray) - call mpas_log_write('--- end interpolate OA3') - -! -! Interpolate OA4: -! - oa4(:) = 0.0_RKIND - - oa4_select: select case(dir_gwdo) - case("orogwd_2deg") - nx = 180 - ny = 90 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 2.0 - dy = 2.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.0 - known_lon = 1.0 - case("orogwd_1deg") - nx = 360 - ny = 180 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 1.0 - dy = 1.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.5 - known_lon = 0.5 - case("orogwd_30m") - nx = 720 - ny = 360 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.5 - dy = 0.5 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.75 - known_lon = 0.25 - case("orogwd_10m") - nx = 2160 - ny = 1080 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.16666667 - dy = 0.16666667 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.916667 - known_lon = 0.0833333 - case default - end select oa4_select - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') & - trim(geog_data_path)//trim(dir_gwdo)//'/oa4/',1,'-',nx,'.',1,'-',ny - call mpas_log_write(trim(fname)) - - allocate(xarray(nx,ny)) - allocate(rarray(nx,ny,nz)) - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) - - call map_set(PROJ_LATLON, proj, & - latinc = dy, & - loninc = dx, & - knowni = known_x, & - knownj = known_y, & - lat1 = known_lat, & - lon1 = known_lon) - - interp_list(1) = AVERAGE4 - interp_list(2) = AVERAGE4 - interp_list(3) = AVERAGE4 - interp_list(4) = AVERAGE4 - interp_list(5) = 0 - - do iCell = 1,nCells - if(landmask(iCell) == 1) then - lat = latCell(iCell) * DEG_PER_RAD - lon = lonCell(iCell) * DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - oa4(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) - endif - enddo - deallocate(rarray) - deallocate(xarray) - call mpas_log_write('--- end interpolate OA4') - -! -! Interpolate OL1: -! - ol1(:) = 0.0_RKIND - - ol1_select: select case(dir_gwdo) - case("orogwd_2deg") - nx = 180 - ny = 90 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 2.0 - dy = 2.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.0 - known_lon = 1.0 - case("orogwd_1deg") - nx = 360 - ny = 180 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 1.0 - dy = 1.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.5 - known_lon = 0.5 - case("orogwd_30m") - nx = 720 - ny = 360 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.5 - dy = 0.5 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.75 - known_lon = 0.25 - case("orogwd_10m") - nx = 2160 - ny = 1080 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.16666667 - dy = 0.16666667 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.916667 - known_lon = 0.0833333 - case default - end select ol1_select - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') & - trim(geog_data_path)//trim(dir_gwdo)//'/ol1/',1,'-',nx,'.',1,'-',ny - call mpas_log_write(trim(fname)) - - allocate(xarray(nx,ny)) - allocate(rarray(nx,ny,nz)) - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) - - call map_set(PROJ_LATLON, proj, & - latinc = dy, & - loninc = dx, & - knowni = known_x, & - knownj = known_y, & - lat1 = known_lat, & - lon1 = known_lon) - - interp_list(1) = AVERAGE4 - interp_list(2) = AVERAGE4 - interp_list(3) = AVERAGE4 - interp_list(4) = AVERAGE4 - interp_list(5) = 0 - - do iCell = 1,nCells - if(landmask(iCell) == 1) then - lat = latCell(iCell) * DEG_PER_RAD - lon = lonCell(iCell) * DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - ol1(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) - endif - enddo - deallocate(rarray) - deallocate(xarray) - call mpas_log_write('--- end interpolate OL1') - -! -! Interpolate OL2: -! - ol2(:) = 0.0_RKIND - - ol2_select: select case(dir_gwdo) - case("orogwd_2deg") - nx = 180 - ny = 90 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 2.0 - dy = 2.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.0 - known_lon = 1.0 - case("orogwd_1deg") - nx = 360 - ny = 180 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 1.0 - dy = 1.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.5 - known_lon = 0.5 - case("orogwd_30m") - nx = 720 - ny = 360 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.5 - dy = 0.5 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.75 - known_lon = 0.25 - case("orogwd_10m") - nx = 2160 - ny = 1080 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.16666667 - dy = 0.16666667 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.916667 - known_lon = 0.0833333 - case default - end select ol2_select - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') & - trim(geog_data_path)//trim(dir_gwdo)//'/ol2/',1,'-',nx,'.',1,'-',ny - call mpas_log_write(trim(fname)) - - allocate(xarray(nx,ny)) - allocate(rarray(nx,ny,nz)) - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) - - call map_set(PROJ_LATLON, proj, & - latinc = dy, & - loninc = dx, & - knowni = known_x, & - knownj = known_y, & - lat1 = known_lat, & - lon1 = known_lon) - - interp_list(1) = AVERAGE4 - interp_list(2) = AVERAGE4 - interp_list(3) = AVERAGE4 - interp_list(4) = AVERAGE4 - interp_list(5) = 0 - - do iCell = 1,nCells - if(landmask(iCell) == 1) then - lat = latCell(iCell) * DEG_PER_RAD - lon = lonCell(iCell) * DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - ol2(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) - endif - enddo - deallocate(rarray) - deallocate(xarray) - call mpas_log_write('--- end interpolate OL2') - -! -! Interpolate OL3: -! - ol3(:) = 0.0_RKIND - - ol3_select: select case(dir_gwdo) - case("orogwd_2deg") - nx = 180 - ny = 90 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 2.0 - dy = 2.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.0 - known_lon = 1.0 - case("orogwd_1deg") - nx = 360 - ny = 180 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 1.0 - dy = 1.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.5 - known_lon = 0.5 - case("orogwd_30m") - nx = 720 - ny = 360 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.5 - dy = 0.5 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.75 - known_lon = 0.25 - case("orogwd_10m") - nx = 2160 - ny = 1080 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.16666667 - dy = 0.16666667 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.916667 - known_lon = 0.0833333 - case default - end select ol3_select - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') & - trim(geog_data_path)//trim(dir_gwdo)//'/ol3/',1,'-',nx,'.',1,'-',ny - call mpas_log_write(trim(fname)) - - allocate(xarray(nx,ny)) - allocate(rarray(nx,ny,nz)) - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) - - call map_set(PROJ_LATLON, proj, & - latinc = dy, & - loninc = dx, & - knowni = known_x, & - knownj = known_y, & - lat1 = known_lat, & - lon1 = known_lon) - - interp_list(1) = AVERAGE4 - interp_list(2) = AVERAGE4 - interp_list(3) = AVERAGE4 - interp_list(4) = AVERAGE4 - interp_list(5) = 0 - - do iCell = 1,nCells - if(landmask(iCell) == 1) then - lat = latCell(iCell) * DEG_PER_RAD - lon = lonCell(iCell) * DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - ol3(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) - endif - enddo - deallocate(rarray) - deallocate(xarray) - call mpas_log_write('--- end interpolate OL3') - -! -! Interpolate OL4: -! - ol4(:) = 0.0_RKIND - - ol4_select: select case(dir_gwdo) - case("orogwd_2deg") - nx = 180 - ny = 90 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 2.0 - dy = 2.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.0 - known_lon = 1.0 - case("orogwd_1deg") - nx = 360 - ny = 180 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 1.0 - dy = 1.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.5 - known_lon = 0.5 - case("orogwd_30m") - nx = 720 - ny = 360 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.5 - dy = 0.5 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.75 - known_lon = 0.25 - case("orogwd_10m") - nx = 2160 - ny = 1080 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.0001 - dx = 0.16666667 - dy = 0.16666667 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.916667 - known_lon = 0.0833333 - case default - end select ol4_select - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') & - trim(geog_data_path)//trim(dir_gwdo)//'/ol4/',1,'-',nx,'.',1,'-',ny - call mpas_log_write(trim(fname)) - - allocate(xarray(nx,ny)) - allocate(rarray(nx,ny,nz)) - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) - - call map_set(PROJ_LATLON, proj, & - latinc = dy, & - loninc = dx, & - knowni = known_x, & - knownj = known_y, & - lat1 = known_lat, & - lon1 = known_lon) - - interp_list(1) = AVERAGE4 - interp_list(2) = AVERAGE4 - interp_list(3) = AVERAGE4 - interp_list(4) = AVERAGE4 - interp_list(5) = 0 - - do iCell = 1,nCells - if(landmask(iCell) == 1) then - lat = latCell(iCell) * DEG_PER_RAD - lon = lonCell(iCell) * DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - ol4(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) - endif - enddo - deallocate(rarray) - deallocate(xarray) - call mpas_log_write('--- end interpolate OL4') - -! -! Interpolate VAR2D: -! - var2d(:) = 0.0_RKIND - - var2d_select: select case(dir_gwdo) - case("orogwd_2deg") - nx = 180 - ny = 90 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 4 - scalefactor = 0.02 - dx = 2.0 - dy = 2.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.0 - known_lon = 1.0 - case("orogwd_1deg") - nx = 360 - ny = 180 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 4 - scalefactor = 0.02 - dx = 1.0 - dy = 1.0 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.5 - known_lon = 0.5 - case("orogwd_30m") - nx = 720 - ny = 360 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 4 - scalefactor = 0.02 - dx = 0.5 - dy = 0.5 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.75 - known_lon = 0.25 - case("orogwd_10m") - nx = 2160 - ny = 1080 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.02 - dx = 0.16666667 - dy = 0.16666667 - known_x = 1.0 - known_y = 1.0 - known_lat = -89.916667 - known_lon = 0.0833333 - case default - end select var2d_select - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') & - trim(geog_data_path)//trim(dir_gwdo)//'/var/',1,'-',nx,'.',1,'-',ny - call mpas_log_write(trim(fname)) - - - allocate(xarray(nx,ny)) - allocate(rarray(nx,ny,nz)) - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - xarray(1:nx,1:ny) = rarray(1:nx,1:ny,1) - - call map_set(PROJ_LATLON, proj, & - latinc = dy, & - loninc = dx, & - knowni = known_x, & - knownj = known_y, & - lat1 = known_lat, & - lon1 = known_lon) - - interp_list(1) = AVERAGE4 - interp_list(2) = AVERAGE4 - interp_list(3) = AVERAGE4 - interp_list(4) = AVERAGE4 - interp_list(5) = 0 - - do iCell = 1,nCells - if(landmask(iCell) == 1) then - lat = latCell(iCell) * DEG_PER_RAD - lon = lonCell(iCell) * DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - var2d(iCell) = interp_sequence(x,y,1,xarray,1,nx,1,ny,1,1, & - 0.0_RKIND,interp_list,1) - endif - enddo - deallocate(rarray) - deallocate(xarray) - call mpas_log_write('--- end interpolate VAR2D') - - end subroutine init_atm_static_orogwd - !================================================================================================== subroutine init_atm_check_read_error(istatus, fname) !================================================================================================== From 32c7208d72855c07a40f88fcdd471a2a202d9237 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 13 Sep 2018 17:21:14 -0600 Subject: [PATCH 068/182] Add 'gwd_stage_out' package in init_atmosphere core In order to clean up the reading and writing of fields that are computed at various stages of pre-processing, and in particular, to address the fact that setting 'config_static_interp' alone to true doesn't produce GWDO static fields (following the previous commit), this commit defines a new package, gwd_stage_out, and reworks the logic for setting packages. --- src/core_init_atmosphere/Registry.xml | 43 ++++++++++--------- .../mpas_init_atm_core_interface.F | 29 ++++++++++--- 2 files changed, 46 insertions(+), 26 deletions(-) diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index e8426835d9..79458a5442 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -272,7 +272,8 @@ - + + @@ -343,16 +344,16 @@ - - - - - - - - - - + + + + + + + + + + @@ -436,16 +437,16 @@ - - - - - - - - - - + + + + + + + + + + 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..36523bdb8a 100644 --- a/src/core_init_atmosphere/mpas_init_atm_core_interface.F +++ b/src/core_init_atmosphere/mpas_init_atm_core_interface.F @@ -113,7 +113,7 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) integer :: ierr logical, pointer :: initial_conds, sfc_update - logical, pointer :: gwd_stage_in, vertical_stage_in, vertical_stage_out, met_stage_in, met_stage_out + logical, pointer :: gwd_stage_in, gwd_stage_out, vertical_stage_in, vertical_stage_out, met_stage_in, met_stage_out logical, pointer :: config_native_gwd_static, config_static_interp, config_vertical_grid, config_met_interp integer, pointer :: config_init_case @@ -135,6 +135,9 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) nullify(gwd_stage_in) call mpas_pool_get_package(packages, 'gwd_stage_inActive', gwd_stage_in) + nullify(gwd_stage_out) + call mpas_pool_get_package(packages, 'gwd_stage_outActive', gwd_stage_out) + nullify(vertical_stage_in) call mpas_pool_get_package(packages, 'vertical_stage_inActive', vertical_stage_in) @@ -150,6 +153,7 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) if (.not. associated(initial_conds) .or. & .not. associated(sfc_update) .or. & .not. associated(gwd_stage_in) .or. & + .not. associated(gwd_stage_out) .or. & .not. associated(vertical_stage_in) .or. & .not. associated(vertical_stage_out) .or. & .not. associated(met_stage_in) .or. & @@ -170,19 +174,34 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) end if if (config_init_case == 7) then - gwd_stage_in = (config_native_gwd_static .and. .not. config_static_interp) - vertical_stage_in = (config_vertical_grid .and. .not. config_static_interp) - vertical_stage_out = (config_vertical_grid .and. .not. config_met_interp) - met_stage_in = (config_met_interp .and. .not. config_vertical_grid) + + ! + ! The logic here is a little convoluted + ! For input, we want to read in fields from all earlier stages, except if those earlier stages are being run now + ! For output, we want to output the fields that were computed in a stage and all of those from earlier stages + ! + gwd_stage_in = config_native_gwd_static .and. & + (.not. config_static_interp) + gwd_stage_out = config_native_gwd_static + vertical_stage_in = config_vertical_grid .and. & + (.not. config_native_gwd_static) .and. & + (.not. config_static_interp) + vertical_stage_out = config_vertical_grid + met_stage_in = config_met_interp .and. & + (.not. config_native_gwd_static) .and. & + (.not. config_static_interp) .and. & + (.not. config_vertical_grid) met_stage_out = config_met_interp else if (config_init_case == 8) then gwd_stage_in = .false. + gwd_stage_out = .false. vertical_stage_in = .true. vertical_stage_out = .false. met_stage_in = .false. met_stage_out = .false. else gwd_stage_in = .false. + gwd_stage_out = .false. vertical_stage_in = .false. vertical_stage_out = .false. met_stage_in = .false. From 377e7dfb27141b342f4bd566e03a542aa6f49680 Mon Sep 17 00:00:00 2001 From: Kelly Werner Date: Mon, 17 Sep 2018 14:57:26 -0600 Subject: [PATCH 069/182] 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 84557e7b286b0ec09a2d43b22458677c62146b30 Mon Sep 17 00:00:00 2001 From: JJ Guerrette Date: Mon, 1 Oct 2018 21:08:57 +0000 Subject: [PATCH 070/182] Update core_atmosphere for multiple instances of domain When there are multiple instances of the MPAS domain, the clock and mpas_log_info pointers need to be updated for each call to dependent high-level subroutines in mpas_atm_core.F. --- src/core_atmosphere/mpas_atm_core.F | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index b431e9cc1c..4978cd2c62 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -10,7 +10,7 @@ module atm_core use mpas_derived_types use mpas_pool_routines use mpas_dmpar - use mpas_log, only : mpas_log_write + use mpas_log, only : mpas_log_write, mpas_log_info type (MPAS_Clock_type), pointer :: clock @@ -76,6 +76,7 @@ function atm_core_init(domain, startTimeStamp) result(ierr) ! Set "local" clock to point to the clock contained in the domain type ! clock => domain % clock + mpas_log_info => domain % logInfo call mpas_pool_get_config(domain % blocklist % configs, 'config_do_restart', config_do_restart) @@ -494,6 +495,9 @@ function atm_core_run(domain) result(ierr) real (kind=R8KIND) :: output_start_time, output_stop_time ierr = 0 + + clock => domain % clock + mpas_log_info => domain % logInfo ! Eventually, dt should be domain specific call mpas_pool_get_config(domain % blocklist % configs, 'config_dt', dt) @@ -851,6 +855,9 @@ subroutine atm_do_timestep(domain, dt, itimestep) real (kind=RKIND) :: xtime_s integer :: ierr + clock => domain % clock + mpas_log_info => domain % logInfo + startTime = mpas_get_clock_time(clock, MPAS_START_TIME, ierr) currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) @@ -893,6 +900,9 @@ function atm_core_finalize(domain) result(ierr) ierr = 0 + clock => domain % clock + mpas_log_info => domain % logInfo + call mpas_atm_diag_cleanup() call mpas_destroy_clock(clock, ierr) From 1efdb637623d3ab001c1e85eb6db42139cf5cecd Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Mon, 22 Oct 2018 17:40:12 -0600 Subject: [PATCH 071/182] Add new mpas_atm_run_compatibility() to verify input fields and namelist options This commit introduces a new routine in the atm_core module for checking the consistency and compatibility of inputs supplied at run-time. This routine is called after packages (and physics suites) have been set up, and also after namelists and input streams have been read. In its initial implementation, this subroutine checks that we have what appear to be valid GWDO static fields if the config_gwdo_scheme options is not 'off'. --- src/core_atmosphere/mpas_atm_core.F | 90 +++++++++++++++++++++++++++++ 1 file changed, 90 insertions(+) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index b431e9cc1c..806491f6ae 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -144,6 +144,17 @@ function atm_core_init(domain, startTimeStamp) result(ierr) call mpas_pool_get_field(state, 'u', u_field, 1) call mpas_dmpar_exch_halo_field(u_field) + + ! + ! Perform basic compatibility checks among the fields that were read and the run-time options that were selected + ! + call mpas_atm_run_compatibility(domain % dminfo, domain % blocklist, domain % streamManager, ierr) + if (ierr /= 0) then + call mpas_log_write('Please correct issues with the model input fields and/or namelist.', messageType=MPAS_LOG_ERR) + return + end if + + block => domain % blocklist do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'mesh', mesh) @@ -1263,5 +1274,84 @@ subroutine atm_couple_coef_3rd_order(mesh, configs) end subroutine atm_couple_coef_3rd_order + !----------------------------------------------------------------------- + ! routine mpas_atm_run_compatibility + ! + !> \brief Checks input fields and options for compatibility + !> \author Michael Duda + !> \date 22 October 2018 + !> \details + !> This routine checks the input fields and run-time options provided + !> by the user for compatibility. For example, two run-time options may + !> be mutually exclusive, or an option may require that a certain input + !> field is provided. + !> + !> A value of 0 is returned if there are no incompatibilities among + !> the provided input fields and run-time options, and a non-zero value + !> otherwise. + ! + !----------------------------------------------------------------------- + subroutine mpas_atm_run_compatibility(dminfo, blockList, streamManager, ierr) + + implicit none + + type (dm_info), pointer :: dminfo + type (block_type), pointer :: blockList + type (MPAS_streamManager_type), pointer :: streamManager + integer, intent(out) :: ierr + + real (kind=RKIND) :: maxvar2d_local, maxvar2d_global + real (kind=RKIND), dimension(:), pointer :: var2d + integer, pointer :: nCellsSolve + character (len=StrKIND), pointer :: gwdo_scheme + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: sfc_inputPool + + + ierr = 0 + + ! + ! For the GWDO option, ensure that we have valid static fields var2d, con, ol{1,2,3,4}, oa{1,2,3,4} + ! + call mpas_pool_get_config(blocklist % configs, 'config_gwdo_scheme', gwdo_scheme) + + if (trim(gwdo_scheme) /= 'off') then + maxvar2d_local = -huge(maxvar2d_local) + block => blockList + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'sfc_input', sfc_inputPool) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_array(sfc_inputPool, 'var2d', var2d) + + maxvar2d_local = max(maxvar2d_local, maxval(var2d(1:nCellsSolve))) + + block => block % next + end do + + call mpas_dmpar_max_real(dminfo, maxvar2d_local, maxvar2d_global) + + if (maxvar2d_global <= 0.0_RKIND) then + call mpas_log_write('*******************************************************************************', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('The GWDO scheme requires valid var2d, con, oa{1,2,3,4}, and ol{1,2,3,4} fields,', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('but these fields appear to be zero everywhere in the model input.', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('Either set config_gwdo_scheme = ''off'' in the &physics namelist, or generate', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('the GWDO static fields with the init_atmosphere core.', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('*******************************************************************************', & + messageType=MPAS_LOG_ERR) + ierr = ierr + 1 + end if + + end if + + end subroutine mpas_atm_run_compatibility + + end module atm_core From d5f9476f59796cfe0f387c5f7cc901bebbbdeecb Mon Sep 17 00:00:00 2001 From: "Miles A. Curry" Date: Wed, 31 Oct 2018 12:09:13 -0600 Subject: [PATCH 072/182] Moved physics compatibility checks into mpas_atmphys_control.F This commit moves the physics compatibility check created in the previous commit to a new routine, physics_compatibility_check(), within mpas_atmphys_control.F and replaces it with a call to that subroutine. This should keep compatibility checks in mpas_atmm_run_compatibility at higher level while delegating specific checks to other routines. --- src/core_atmosphere/mpas_atm_core.F | 51 ++---------- .../physics/mpas_atmphys_control.F | 78 ++++++++++++++++++- 2 files changed, 83 insertions(+), 46 deletions(-) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index 806491f6ae..da67db9b08 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -1293,6 +1293,8 @@ end subroutine atm_couple_coef_3rd_order !----------------------------------------------------------------------- subroutine mpas_atm_run_compatibility(dminfo, blockList, streamManager, ierr) + use mpas_atmphys_control, only : physics_compatibility_check + implicit none type (dm_info), pointer :: dminfo @@ -1300,55 +1302,14 @@ subroutine mpas_atm_run_compatibility(dminfo, blockList, streamManager, ierr) type (MPAS_streamManager_type), pointer :: streamManager integer, intent(out) :: ierr - real (kind=RKIND) :: maxvar2d_local, maxvar2d_global - real (kind=RKIND), dimension(:), pointer :: var2d - integer, pointer :: nCellsSolve - character (len=StrKIND), pointer :: gwdo_scheme - type (block_type), pointer :: block - type (mpas_pool_type), pointer :: meshPool - type (mpas_pool_type), pointer :: sfc_inputPool - + integer :: local_ierr ierr = 0 - ! - ! For the GWDO option, ensure that we have valid static fields var2d, con, ol{1,2,3,4}, oa{1,2,3,4} - ! - call mpas_pool_get_config(blocklist % configs, 'config_gwdo_scheme', gwdo_scheme) - - if (trim(gwdo_scheme) /= 'off') then - maxvar2d_local = -huge(maxvar2d_local) - block => blockList - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) - call mpas_pool_get_subpool(block % structs, 'sfc_input', sfc_inputPool) - call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_array(sfc_inputPool, 'var2d', var2d) - - maxvar2d_local = max(maxvar2d_local, maxval(var2d(1:nCellsSolve))) - - block => block % next - end do + ! Physics specific checks found in /physics/mpas_atmphys_control.F + call physics_compatibility_check(dminfo, blockList, streamManager, local_ierr) + ierr = ierr + local_ierr - call mpas_dmpar_max_real(dminfo, maxvar2d_local, maxvar2d_global) - - if (maxvar2d_global <= 0.0_RKIND) then - call mpas_log_write('*******************************************************************************', & - messageType=MPAS_LOG_ERR) - call mpas_log_write('The GWDO scheme requires valid var2d, con, oa{1,2,3,4}, and ol{1,2,3,4} fields,', & - messageType=MPAS_LOG_ERR) - call mpas_log_write('but these fields appear to be zero everywhere in the model input.', & - messageType=MPAS_LOG_ERR) - call mpas_log_write('Either set config_gwdo_scheme = ''off'' in the &physics namelist, or generate', & - messageType=MPAS_LOG_ERR) - call mpas_log_write('the GWDO static fields with the init_atmosphere core.', & - messageType=MPAS_LOG_ERR) - call mpas_log_write('*******************************************************************************', & - messageType=MPAS_LOG_ERR) - ierr = ierr + 1 - end if - - end if end subroutine mpas_atm_run_compatibility diff --git a/src/core_atmosphere/physics/mpas_atmphys_control.F b/src/core_atmosphere/physics/mpas_atmphys_control.F index 3ea3e96878..9b7a08c5e0 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_control.F +++ b/src/core_atmosphere/physics/mpas_atmphys_control.F @@ -18,7 +18,8 @@ module mpas_atmphys_control private public:: physics_namelist_check, & physics_registry_init, & - physics_tables_init + physics_tables_init, & + physics_compatibility_check logical,public:: moist_physics @@ -417,6 +418,81 @@ subroutine physics_tables_init(dminfo,configs) end subroutine physics_tables_init +!================================================================================================================= +! routine physics_compatibility_check() +! +!> \brief Checks physics input fields and options for compatibility +!> \author Miles Curry and Michael Duda +!> \date 25 October 2018 +!> \details +!> This routine checks the input fields and run-time options provided +!> by the user for compatibility. For example, two run-time options may +!> be mutually exclusive, or an option may require that a certain input +!> field is provided. The checks performed by this routine are only for +!> physics related fields and options. +!> +!> A value of 0 is returned if there are no incompatibilities among +!> the provided input fields and run-time options, and a non-zero value +!> otherwise. +!> + subroutine physics_compatibility_check(dminfo, blockList, streamManager, ierr) +!================================================================================================================= + + implicit none + + type (dm_info), pointer :: dminfo + type (block_type), pointer :: blockList + type (MPAS_streamManager_type), pointer :: streamManager + integer, intent(out) :: ierr + + real (kind=RKIND) :: maxvar2d_local, maxvar2d_global + real (kind=RKIND), dimension(:), pointer :: var2d + integer, pointer :: nCellsSolve + character (len=StrKIND), pointer :: gwdo_scheme + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: meshPool + type (mpas_pool_type), pointer :: sfc_inputPool + + ierr = 0 + + call mpas_pool_get_config(blocklist % configs, 'config_gwdo_scheme', gwdo_scheme) + + if (trim(gwdo_scheme) /= 'off') then + maxvar2d_local = -huge(maxvar2d_local) + block => blockList + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_subpool(block % structs, 'sfc_input', sfc_inputPool) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_array(sfc_inputPool, 'var2d', var2d) + + maxvar2d_local = max(maxvar2d_local, maxval(var2d(1:nCellsSolve))) + + block => block % next + end do + + call mpas_dmpar_max_real(dminfo, maxvar2d_local, maxvar2d_global) + + if (maxvar2d_global <= 0.0_RKIND) then + call mpas_log_write('*******************************************************************************', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('The GWDO scheme requires valid var2d, con, oa{1,2,3,4}, and ol{1,2,3,4} fields,', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('but these fields appear to be zero everywhere in the model input.', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('Either set config_gwdo_scheme = ''off'' in the &physics namelist, or generate', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('the GWDO static fields with the init_atmosphere core.', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('*******************************************************************************', & + messageType=MPAS_LOG_ERR) + ierr = ierr + 1 + end if + + end if + + end subroutine physics_compatibility_check + !================================================================================================================= end module mpas_atmphys_control !================================================================================================================= From a3097a649affbf3b4d57168476b674b6b75c7505 Mon Sep 17 00:00:00 2001 From: Laura Fowler Date: Thu, 15 Nov 2018 10:41:11 -0700 Subject: [PATCH 073/182] * In ./src/core_atmosphere/Registry.xml: -> corrected the description of several all-sky and clear-sky surface and top-of-the-atmosphere long wave radiation diagnostics. -> corrected the description for the effective radius for snow calculated on the RRTMG long and shortwave radiation codes. --- src/core_atmosphere/Registry.xml | 34 +++++++++++++++----------------- 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 7fc056c536..f1a21c9fe1 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -2367,7 +2367,6 @@ - @@ -2378,7 +2377,7 @@ description="all-sky downward surface shortwave radiation flux"/> + description="clear-sky downward surface shortwave radiation flux"/> @@ -2402,7 +2401,7 @@ description="accumulated all-sky downward surface shortwave radiation flux"/> + description="accumulated clear-sky downward surface shortwave radiation flux"/> @@ -2425,7 +2424,6 @@ - @@ -2484,22 +2482,22 @@ description="clear-sky downward surface longwave radiation flux"/> + description="all-sky downward top-of-the-atmosphere longwave radiation flux"/> + description="clear-sky downward top-of-the-atmosphere longwave radiation flux"/> + description="clear-sky upward surface longwave radiation flux"/> + description="all-sky upward top-of-the-atmosphere longwave radiation flux"/> + description="clear-sky upward top-of-the-atmosphere longwave radiation flux"/> @@ -2508,28 +2506,28 @@ description="accumulated clear-sky downward surface longwave radiation flux"/> + description="accumulated all-sky downward top-of-the-atmosphere longwave radiation flux"/> + description="accumulated clear-sky downward top-of-the-atmosphere longwave radiation flux"/> + description="accumulated clear-sky upward surface longwave radiation flux"/> + description="accumulated all-sky upward top-of-the-atmosphere longwave radiation flux"/> + description="accumulated clear-sky upward top-of-the-atmosphere longwave radiation flux"/> + description="all-sky top-of-atmosphere outgoing longwave radiation flux"/> + description="all-sky downward surface longwave radiation"/> @@ -2537,8 +2535,8 @@ - - description="effective radius of cloud ice crystals calculated in RRTMG radiation"/> + From 4f10e6fb163fbd5c72e2c0bcaa8c83c3fe38840c Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 29 Nov 2018 18:30:37 -0700 Subject: [PATCH 074/182] Add 'llvm' make target to support compilation with clang+flang --- Makefile | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/Makefile b/Makefile index baceb05cb7..dcf6c7b075 100644 --- a/Makefile +++ b/Makefile @@ -396,6 +396,31 @@ bluegene: "OPENMP = $(OPENMP)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) +llvm: + ( $(MAKE) all \ + "FC_PARALLEL = mpifort" \ + "CC_PARALLEL = mpicc" \ + "CXX_PARALLEL = mpic++" \ + "FC_SERIAL = flang" \ + "CC_SERIAL = clang" \ + "CXX_SERIAL = clang++" \ + "FFLAGS_PROMOTION = -r8" \ + "FFLAGS_OPT = -O3 -g -Mbyteswapio -Mfreeform" \ + "CFLAGS_OPT = -O3 -g" \ + "CXXFLAGS_OPT = -O3 -g" \ + "LDFLAGS_OPT = -O3 -g" \ + "FFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -Mbyteswapio -Mfreeform -Mstandard" \ + "CFLAGS_DEBUG = -O0 -g -Weverything" \ + "CXXFLAGS_DEBUG = -O0 -g -Weverything" \ + "LDFLAGS_DEBUG = -O0 -g" \ + "FFLAGS_OMP = -mp" \ + "CFLAGS_OMP = -fopenmp" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "OPENMP = $(OPENMP)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) + CPPINCLUDES = FCINCLUDES = LIBS = From 30ce80c42fa06707e62e679cfbc9e6740ba5457e Mon Sep 17 00:00:00 2001 From: "Miles A. Curry" Date: Wed, 28 Nov 2018 09:52:52 -0700 Subject: [PATCH 075/182] Adds units and descriptions to init atmosphere's Registry.xml This commit updates the variables and dimensions within init atmosphere core's Registry.xml to contain units and descriptions. Also fixes a misspelling of 'surface' in the description of the variable 'albedo12m' in core_atmosphere/Registry.xml. --- src/core_atmosphere/Registry.xml | 2 +- src/core_init_atmosphere/Registry.xml | 675 +++++++++++++++++++------- 2 files changed, 498 insertions(+), 179 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 7fc056c536..751eaa6cc5 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -2634,7 +2634,7 @@ description="initial number of time-steps since last snow fall"/> + description="skin sea-surface temperature"/> diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 670439f648..d172b7a912 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -6,23 +6,40 @@ - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + @@ -498,11 +515,11 @@ - + - + @@ -527,208 +544,510 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - + + + + + - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + - + + + + + - - - + - - + + + - - + + + - + - - - - - + + + + + + + + + + - - - + + + + + - + - + - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - - + + + + + + + + + + - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - + + + + + + + - + From ad2f28421898103267fef18096be6ef60ff705ca Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Mon, 3 Dec 2018 14:57:23 -0700 Subject: [PATCH 076/182] Add missing dependency in core_atmosphere/physics/Makefile to fix parallel build The 'all' target in the src/core_atmosphere/physics/Makefile depends on both 'core_physics_wrf' and 'core_physics_init', among others. 'make' can choose to process these in any order (subject to dependencies), so it could happen that 'core_physics_wrf' was processed in parallel with 'core_physics_init'. However, some objects in 'core_physics_wrf' depend on objects in 'core_physics_init' (e.g., module_mp_radar.F depends on mpas_atmphys_utilities.F), so we need to add a dependency on 'core_physics_init' to the 'core_physics_wrf' target to ensure correct parallel builds. --- src/core_atmosphere/physics/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index e8cb03f6f5..8e9abfcedb 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -48,7 +48,7 @@ OBJS = \ lookup_tables: ./checkout_data_files.sh -core_physics_wrf: +core_physics_wrf: core_physics_init (cd physics_wrf; $(MAKE) all COREDEF="$(COREDEF)") core_physics_init: $(OBJS_init) From 598b2e782121c547ce21442ac4a4840fe2a5df3c Mon Sep 17 00:00:00 2001 From: Kelly Werner Date: Fri, 14 Sep 2018 12:30:20 -0600 Subject: [PATCH 077/182] 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 e7b3ad65c3d18f6f62c32eb1d9ee1144852924d0 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 16 Jan 2019 17:02:18 -0700 Subject: [PATCH 078/182] Avoid divide-by-zero in zb computation for Jablonowski & Williamson initialization The initialization routine for the Jablonowski and Williamson test case could previously generate a divide by zero in the computatation of zb and zb3 due to areaCell(nCells+1) being zero and appearing in the denominator of a term. One way to avoid this divide by zero would have been to simply set areaCell(nCells+1) to some reasonable non-zero value. However, other test cases that also compute zb and zb3 added an if-test to compute zb and zb3 only for edges that border an owned cell. For uniformity, the same approach is used for the Jablonowski and Williamson test case. Since the value of the zb and zb3 field only matters for owned edges (in the test case setup), there is no change to results. --- .../mpas_init_atm_cases.F | 34 +++++++++++-------- 1 file changed, 19 insertions(+), 15 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 25b2b9719d..d1e6f6487c 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -967,16 +967,19 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) - do k = 1, nVertLevels + + ! Avoid a potential divide by zero below if areaCell(nCells+1) is used in the denominator + if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then + do k = 1, nVertLevels - if (config_theta_adv_order == 2) then + if (config_theta_adv_order == 2) then - z_edge = (zgrid(k,cell1)+zgrid(k,cell2))/2. + z_edge = (zgrid(k,cell1)+zgrid(k,cell2))/2. - else if (config_theta_adv_order == 3 .or. config_theta_adv_order ==4) then !theta_adv_order == 3 or 4 + else if (config_theta_adv_order == 3 .or. config_theta_adv_order ==4) then !theta_adv_order == 3 or 4 - d2fdx2_cell1 = deriv_two(1,1,iEdge) * zgrid(k,cell1) - d2fdx2_cell2 = deriv_two(1,2,iEdge) * zgrid(k,cell2) + d2fdx2_cell1 = deriv_two(1,1,iEdge) * zgrid(k,cell1) + d2fdx2_cell2 = deriv_two(1,2,iEdge) * zgrid(k,cell2) ! WCS fix 20120711 @@ -989,23 +992,24 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,cellsOnCell(i,cell2)) end do - z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) & - - (dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. + z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) & + - (dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. - if (config_theta_adv_order == 3) then - z_edge3 = - (dcEdge(iEdge) **2) * (d2fdx2_cell1 - d2fdx2_cell2) / 12. - else - z_edge3 = 0. - end if + if (config_theta_adv_order == 3) then + z_edge3 = - (dcEdge(iEdge) **2) * (d2fdx2_cell1 - d2fdx2_cell2) / 12. + else + z_edge3 = 0. + end if - end if + end if zb(k,1,iEdge) = (z_edge-zgrid(k,cell1))*dvEdge(iEdge)/areaCell(cell1) zb(k,2,iEdge) = (z_edge-zgrid(k,cell2))*dvEdge(iEdge)/areaCell(cell2) zb3(k,1,iEdge)= z_edge3*dvEdge(iEdge)/areaCell(cell1) zb3(k,2,iEdge)= z_edge3*dvEdge(iEdge)/areaCell(cell2) - end do + end do + end if end do From bc03e09f3d448f65825e50e58ba460130245af5b Mon Sep 17 00:00:00 2001 From: "Miles A. Curry" Date: Thu, 31 Jan 2019 18:08:03 -0700 Subject: [PATCH 079/182] 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 04d78108156f40f1f04f59f110460a011cba617a Mon Sep 17 00:00:00 2001 From: Xylar Asay-Davis Date: Tue, 5 Feb 2019 07:07:30 -0800 Subject: [PATCH 080/182] Fix core count in compass regression suites The core count now only involves those configurations that are part of the driver script of each test case, not all configurations. --- .../compass/manage_regression_suite.py | 61 ++++++++++++------- 1 file changed, 38 insertions(+), 23 deletions(-) diff --git a/testing_and_setup/compass/manage_regression_suite.py b/testing_and_setup/compass/manage_regression_suite.py index ac332ecdb5..b2c014cb81 100755 --- a/testing_and_setup/compass/manage_regression_suite.py +++ b/testing_and_setup/compass/manage_regression_suite.py @@ -354,6 +354,19 @@ def summarize_suite(suite_tag): # {{{ test_path = '{}/{}/{}/{}'.format(test_core, test_configuration, test_resolution, test_test) + driver_path = '{}/config_driver.xml'.format(test_path) + config_tree = ET.parse(driver_path) + config_root = config_tree.getroot() + + cases = [] + assert(config_root.tag == 'driver_script') + for case in config_root.iter('case'): + name = case.attrib['name'] + cases.append(name) + + del config_root + del config_tree + # Loop over all files in test_path that have the .xml extension. for file in os.listdir('{}'.format(test_path)): if fnmatch.fnmatch(file, '*.xml'): @@ -364,29 +377,31 @@ def summarize_suite(suite_tag): # {{{ config_root = config_tree.getroot() if config_root.tag == 'config': - for model_run in config_root.iter('model_run'): - try: - procs_str = model_run.attrib['procs'] - procs = int(procs_str) - except (KeyError, ValueError): - procs = 1 - - try: - threads_str = model_run.attrib['threads'] - threads = int(threads_str) - except (KeyError, ValueError): - threads = 1 - - cores = threads * procs - - if procs > max_procs: - max_procs = procs - - if threads > max_threads: - max_threads = threads - - if cores > max_cores: - max_cores = cores + case = config_root.attrib['case'] + if case in cases: + for model_run in config_root.iter('model_run'): + try: + procs_str = model_run.attrib['procs'] + procs = int(procs_str) + except (KeyError, ValueError): + procs = 1 + + try: + threads_str = model_run.attrib['threads'] + threads = int(threads_str) + except (KeyError, ValueError): + threads = 1 + + cores = threads * procs + + if procs > max_procs: + max_procs = procs + + if threads > max_threads: + max_threads = threads + + if cores > max_cores: + max_cores = cores del config_root del config_tree From 3a15c6646bb96a4134fd519c368f98b20b0f6c97 Mon Sep 17 00:00:00 2001 From: "Miles A. Curry" Date: Tue, 5 Feb 2019 12:23:40 -0700 Subject: [PATCH 081/182] Updated config_geog_data_path deafult directiory `/glade/p/work/` no longer exists. This commit updates the default to `/glade/work/wrfhelp/WPS_GEOG` --- src/core_init_atmosphere/Registry.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 670439f648..a66c0d9251 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -108,7 +108,7 @@ - From 3ee9b3423ccc35bc27052d5360b87169a96a5210 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 6 Feb 2019 12:17:57 -0700 Subject: [PATCH 082/182] Zero-out physics tendencies if MPAS-A was not built with physics If MPAS-A was compiled without -DDO_PHYSICS, the tendency arrays for ru, rtheta, and rho need to be set to zero to get correct results. --- 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 f642d0fb15..7449b06b1f 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -419,6 +419,13 @@ subroutine atm_srk3(domain, dt, itimestep) block => block % next end do call mpas_timer_stop('physics_get_tend') +#else + ! + ! If no physics are being used, simply zero-out the physics tendency fields + ! + tend_ru_physics(:,:) = 0.0_RKIND + tend_rtheta_physics(:,:) = 0.0_RKIND + tend_rho_physics(:,:) = 0.0_RKIND #endif ! From 7774823e82a2d3f6d5274f787ed4fc8311cec6bf Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 6 Feb 2019 12:30:06 -0700 Subject: [PATCH 083/182] Obviate the need for r8 compiler flags in MPAS-A without physics The changes in this commit enable compilation of the MPAS-Atmosphere model (excluding physics) without the need to supply auto-promotion flags like -fdefault-real-8. Principally, this is accomplished by adding an explicit RKIND kind for real variables, though several uses of type-specific intrinsics like ALOG have also been corrected. Compilation of MPAS-A with physics still requires auto-promotion flags, since the physics schemes from the WRF model generally declare real values without any explicit kind. With this commit, it should also be possible to compile the init_atmosphere core without auto-promotion flags. --- .../diagnostics/convective_diagnostics.F | 26 +++--- .../diagnostics/isobaric_diagnostics.F | 2 +- src/core_atmosphere/diagnostics/soundings.F | 48 +++++------ .../physics/mpas_atmphys_functions.F | 81 ++++++++++--------- 4 files changed, 79 insertions(+), 78 deletions(-) diff --git a/src/core_atmosphere/diagnostics/convective_diagnostics.F b/src/core_atmosphere/diagnostics/convective_diagnostics.F index 549e6292ca..9554113e4e 100644 --- a/src/core_atmosphere/diagnostics/convective_diagnostics.F +++ b/src/core_atmosphere/diagnostics/convective_diagnostics.F @@ -185,7 +185,7 @@ subroutine convective_diagnostics_update() ! compute above ground level (AGL) heights z_agl(1:nVertLevelsP1) = zgrid(1:nVertLevelsP1,iCell) - zgrid(1,iCell) - uph = integral_zstaggered(updraft_helicity(1:nVertLevels,iCell),z_agl,2000.,5000.,nVertLevels,nVertLevelsP1) + uph = integral_zstaggered(updraft_helicity(1:nVertLevels,iCell),z_agl,2000.0_RKIND,5000.0_RKIND,nVertLevels,nVertLevelsP1) updraft_helicity_max(iCell) = max( updraft_helicity_max(iCell),uph) end do @@ -385,16 +385,16 @@ subroutine convective_diagnostics_compute() temperature_surface(iCell) = temperature(1,iCell) dewpoint_surface(iCell) = dewpoint(1,iCell) if (need_uzonal_1km) then - uzonal_1km(iCell) = column_height_value(uzonal(1:nVertLevels,iCell), zp, 1000., nVertLevels) + uzonal_1km(iCell) = column_height_value(uzonal(1:nVertLevels,iCell), zp, 1000.0_RKIND, nVertLevels) end if if (need_umerid_1km) then - umeridional_1km(iCell) = column_height_value(umeridional(1:nVertLevels,iCell), zp, 1000., nVertLevels) + umeridional_1km(iCell) = column_height_value(umeridional(1:nVertLevels,iCell), zp, 1000.0_RKIND, nVertLevels) end if if (need_uzonal_6km) then - uzonal_6km(iCell) = column_height_value(uzonal(1:nVertLevels,iCell), zp, 6000., nVertLevels) + uzonal_6km(iCell) = column_height_value(uzonal(1:nVertLevels,iCell), zp, 6000.0_RKIND, nVertLevels) end if if (need_umerid_6km) then - umeridional_6km(iCell) = column_height_value(umeridional(1:nVertLevels,iCell), zp, 6000., nVertLevels) + umeridional_6km(iCell) = column_height_value(umeridional(1:nVertLevels,iCell), zp, 6000.0_RKIND, nVertLevels) end if ! storm-relative helicity @@ -441,10 +441,10 @@ subroutine convective_diagnostics_compute() end do if (need_srh_01km) then - srh_0_1km(iCell) = integral_zpoint(srh, zrel, 0., 1000., nVertLevelsP1) + srh_0_1km(iCell) = integral_zpoint(srh, zrel, 0.0_RKIND, 1000.0_RKIND, nVertLevelsP1) end if if (need_srh_03km) then - srh_0_3km(iCell) = integral_zpoint(srh, zrel, 0., 3000., nVertLevelsP1) + srh_0_3km(iCell) = integral_zpoint(srh, zrel, 0.0_RKIND, 3000.0_RKIND, nVertLevelsP1) end if end if @@ -454,8 +454,8 @@ subroutine convective_diagnostics_compute() if (need_cape .or. need_cin) then do iCell=1, nCellsSolve p_in(1:nVertLevels) = (pressure_p(1:nVertLevels,iCell) + pressure_base(1:nVertLevels,iCell)) / 100.0_RKIND - t_in(1:nVertLevels) = temperature(1:nVertLevels,iCell) - 273.15 - td_in(1:nVertLevels) = dewpoint(1:nVertLevels,iCell) - 273.15 + t_in(1:nVertLevels) = temperature(1:nVertLevels,iCell) - 273.15_RKIND + td_in(1:nVertLevels) = dewpoint(1:nVertLevels,iCell) - 273.15_RKIND ! do k=1,nVertLevels ! relhum(k,iCell) = max(1.e-08,min(1.,relhum(k,iCell))) @@ -569,8 +569,8 @@ end function integral_zstaggered real (kind=RKIND) function integral_zpoint( column_values, z, zbot, ztop, n ) implicit none integer n - real :: column_values(n), z(n), zbot, ztop - real :: zb, zt, dz, zr_midpoint, midpoint_value + real(kind=RKIND) :: column_values(n), z(n), zbot, ztop + real(kind=RKIND) :: zb, zt, dz, zr_midpoint, midpoint_value integer :: k @@ -929,7 +929,7 @@ subroutine getcape( nk , p_in , t_in , td_in, cape , cin ) cpm=cp+cpv*qvbar+cpl*qlbar+cpi*qibar th2=th1*exp( lhv*(ql2-ql1)/(cpm*tbar) & +lhs*(qi2-qi1)/(cpm*tbar) & - +(rm/cpm-rd/cp)*alog(p2/p1) ) + +(rm/cpm-rd/cp)*log(p2/p1) ) if(i .gt. 90 .and. debug_level .gt. 0) call mpas_log_write('$i $r $r $r', intArgs=(/i/), realArgs=(/th2,thlast,th2-thlast/)) if(i .gt. 100)then @@ -1083,7 +1083,7 @@ real (kind=RKIND) function getthe(p,t,td,q) if( (td-t).ge.-0.1 )then tlcl = t else - tlcl = 56.0 + ( (td-56.0)**(-1) + 0.00125*alog(t/td) )**(-1) + tlcl = 56.0 + ( (td-56.0)**(-1) + 0.00125*log(t/td) )**(-1) endif getthe=t*( (100000.0/p)**(0.2854*(1.0-0.28*q)) ) & diff --git a/src/core_atmosphere/diagnostics/isobaric_diagnostics.F b/src/core_atmosphere/diagnostics/isobaric_diagnostics.F index f9a7821806..c7aa9b568c 100644 --- a/src/core_atmosphere/diagnostics/isobaric_diagnostics.F +++ b/src/core_atmosphere/diagnostics/isobaric_diagnostics.F @@ -839,7 +839,7 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) !!!!!!!!!!! Calculate mean temperature in 500 hPa - 300 hPa layer !!!!!!!!!!! if (need_meanT_500_300) then - call compute_layer_mean(meanT_500_300, 50000.0, 30000.0, field_in, press_in) + call compute_layer_mean(meanT_500_300, 50000.0_RKIND, 30000.0_RKIND, field_in, press_in) end if diff --git a/src/core_atmosphere/diagnostics/soundings.F b/src/core_atmosphere/diagnostics/soundings.F index 68c331bd69..c213f6f82b 100644 --- a/src/core_atmosphere/diagnostics/soundings.F +++ b/src/core_atmosphere/diagnostics/soundings.F @@ -402,20 +402,20 @@ end function sphere_distance ! THIS FUNCTION CALCULATES THE LIQUID SATURATION VAPOR MIXING RATIO AS ! A FUNCTION OF TEMPERATURE AND PRESSURE ! - REAL FUNCTION RSLF(P,T) + REAL(KIND=RKIND) FUNCTION RSLF(P,T) IMPLICIT NONE - REAL, INTENT(IN):: P, T - REAL:: ESL,X - REAL, PARAMETER:: C0= .611583699E03 - REAL, PARAMETER:: C1= .444606896E02 - REAL, PARAMETER:: C2= .143177157E01 - REAL, PARAMETER:: C3= .264224321E-1 - REAL, PARAMETER:: C4= .299291081E-3 - REAL, PARAMETER:: C5= .203154182E-5 - REAL, PARAMETER:: C6= .702620698E-8 - REAL, PARAMETER:: C7= .379534310E-11 - REAL, PARAMETER:: C8=-.321582393E-13 + REAL(KIND=RKIND), INTENT(IN):: P, T + REAL(KIND=RKIND):: ESL,X + REAL(KIND=RKIND), PARAMETER:: C0= .611583699E03 + REAL(KIND=RKIND), PARAMETER:: C1= .444606896E02 + REAL(KIND=RKIND), PARAMETER:: C2= .143177157E01 + REAL(KIND=RKIND), PARAMETER:: C3= .264224321E-1 + REAL(KIND=RKIND), PARAMETER:: C4= .299291081E-3 + REAL(KIND=RKIND), PARAMETER:: C5= .203154182E-5 + REAL(KIND=RKIND), PARAMETER:: C6= .702620698E-8 + REAL(KIND=RKIND), PARAMETER:: C7= .379534310E-11 + REAL(KIND=RKIND), PARAMETER:: C8=-.321582393E-13 X=MAX(-80.,T-273.16) @@ -436,20 +436,20 @@ END FUNCTION RSLF ! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR MIXING RATIO AS A ! FUNCTION OF TEMPERATURE AND PRESSURE ! - REAL FUNCTION RSIF(P,T) + REAL(KIND=RKIND) FUNCTION RSIF(P,T) IMPLICIT NONE - REAL, INTENT(IN):: P, T - REAL:: ESI,X - REAL, PARAMETER:: C0= .609868993E03 - REAL, PARAMETER:: C1= .499320233E02 - REAL, PARAMETER:: C2= .184672631E01 - REAL, PARAMETER:: C3= .402737184E-1 - REAL, PARAMETER:: C4= .565392987E-3 - REAL, PARAMETER:: C5= .521693933E-5 - REAL, PARAMETER:: C6= .307839583E-7 - REAL, PARAMETER:: C7= .105785160E-9 - REAL, PARAMETER:: C8= .161444444E-12 + REAL(KIND=RKIND), INTENT(IN):: P, T + REAL(KIND=RKIND):: ESI,X + REAL(KIND=RKIND), PARAMETER:: C0= .609868993E03 + REAL(KIND=RKIND), PARAMETER:: C1= .499320233E02 + REAL(KIND=RKIND), PARAMETER:: C2= .184672631E01 + REAL(KIND=RKIND), PARAMETER:: C3= .402737184E-1 + REAL(KIND=RKIND), PARAMETER:: C4= .565392987E-3 + REAL(KIND=RKIND), PARAMETER:: C5= .521693933E-5 + REAL(KIND=RKIND), PARAMETER:: C6= .307839583E-7 + REAL(KIND=RKIND), PARAMETER:: C7= .105785160E-9 + REAL(KIND=RKIND), PARAMETER:: C8= .161444444E-12 X=MAX(-80.,T-273.16) ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) diff --git a/src/core_atmosphere/physics/mpas_atmphys_functions.F b/src/core_atmosphere/physics/mpas_atmphys_functions.F index e2980bbb3f..bbc5922667 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_functions.F +++ b/src/core_atmosphere/physics/mpas_atmphys_functions.F @@ -8,6 +8,7 @@ !================================================================================================================= module mpas_atmphys_functions + use mpas_kind_types, only : RKIND use mpas_derived_types, only : MPAS_LOG_ERR use mpas_log, only : mpas_log_write @@ -34,12 +35,12 @@ SUBROUTINE GCF(GAMMCF,A,X,GLN) ! --- USES GAMMLN IMPLICIT NONE INTEGER, PARAMETER:: ITMAX=100 - REAL, PARAMETER:: gEPS=3.E-7 - REAL, PARAMETER:: FPMIN=1.E-30 - REAL, INTENT(IN):: A, X - REAL:: GAMMCF,GLN + REAL(KIND=RKIND), PARAMETER:: gEPS=3.E-7 + REAL(KIND=RKIND), PARAMETER:: FPMIN=1.E-30 + REAL(KIND=RKIND), INTENT(IN):: A, X + REAL(KIND=RKIND):: GAMMCF,GLN INTEGER:: I - REAL:: AN,B,C,D,DEL,H + REAL(KIND=RKIND):: AN,B,C,D,DEL,H GLN=GAMMLN(A) B=X+1.-A C=1./FPMIN @@ -69,11 +70,11 @@ SUBROUTINE GSER(GAMSER,A,X,GLN) ! --- USES GAMMLN IMPLICIT NONE INTEGER, PARAMETER:: ITMAX=100 - REAL, PARAMETER:: gEPS=3.E-7 - REAL, INTENT(IN):: A, X - REAL:: GAMSER,GLN + REAL(KIND=RKIND), PARAMETER:: gEPS=3.E-7 + REAL(KIND=RKIND), INTENT(IN):: A, X + REAL(KIND=RKIND):: GAMSER,GLN INTEGER:: N - REAL:: AP,DEL,SUM + REAL(KIND=RKIND):: AP,DEL,SUM GLN=GAMMLN(A) IF(X.LE.0.)THEN IF(X.LT.0.) CALL MPAS_LOG_WRITE('X < 0 IN GSER', MESSAGETYPE=MPAS_LOG_ERR) @@ -94,10 +95,10 @@ SUBROUTINE GSER(GAMSER,A,X,GLN) END SUBROUTINE GSER ! (C) Copr. 1986-92 Numerical Recipes Software 2.02 !+---+-----------------------------------------------------------------+ - REAL FUNCTION GAMMLN(XX) + REAL(KIND=RKIND) FUNCTION GAMMLN(XX) ! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0. IMPLICIT NONE - REAL, INTENT(IN):: XX + REAL(KIND=RKIND), INTENT(IN):: XX DOUBLE PRECISION, PARAMETER:: STP = 2.5066282746310005D0 DOUBLE PRECISION, DIMENSION(6), PARAMETER:: & COF = (/76.18009172947146D0, -86.50532032941677D0, & @@ -119,13 +120,13 @@ REAL FUNCTION GAMMLN(XX) END FUNCTION GAMMLN ! (C) Copr. 1986-92 Numerical Recipes Software 2.02 !+---+-----------------------------------------------------------------+ - REAL FUNCTION GAMMP(A,X) + REAL(KIND=RKIND) FUNCTION GAMMP(A,X) ! --- COMPUTES THE INCOMPLETE GAMMA FUNCTION P(A,X) ! --- SEE ABRAMOWITZ AND STEGUN 6.5.1 ! --- USES GCF,GSER IMPLICIT NONE - REAL, INTENT(IN):: A,X - REAL:: GAMMCF,GAMSER,GLN + REAL(KIND=RKIND), INTENT(IN):: A,X + REAL(KIND=RKIND):: GAMMCF,GAMSER,GLN GAMMP = 0. IF((X.LT.0.) .OR. (A.LE.0.)) THEN CALL MPAS_LOG_WRITE('BAD ARGUMENTS IN GAMMP', MESSAGETYPE=MPAS_LOG_ERR) @@ -140,10 +141,10 @@ REAL FUNCTION GAMMP(A,X) END FUNCTION GAMMP ! (C) Copr. 1986-92 Numerical Recipes Software 2.02 !+---+-----------------------------------------------------------------+ - REAL FUNCTION WGAMMA(y) + REAL(KIND=RKIND) FUNCTION WGAMMA(y) IMPLICIT NONE - REAL, INTENT(IN):: y + REAL(KIND=RKIND), INTENT(IN):: y WGAMMA = EXP(GAMMLN(y)) @@ -152,20 +153,20 @@ END FUNCTION WGAMMA ! THIS FUNCTION CALCULATES THE LIQUID SATURATION VAPOR MIXING RATIO AS ! A FUNCTION OF TEMPERATURE AND PRESSURE ! - REAL FUNCTION RSLF(P,T) + REAL(KIND=RKIND) FUNCTION RSLF(P,T) IMPLICIT NONE - REAL, INTENT(IN):: P, T - REAL:: ESL,X - REAL, PARAMETER:: C0= .611583699E03 - REAL, PARAMETER:: C1= .444606896E02 - REAL, PARAMETER:: C2= .143177157E01 - REAL, PARAMETER:: C3= .264224321E-1 - REAL, PARAMETER:: C4= .299291081E-3 - REAL, PARAMETER:: C5= .203154182E-5 - REAL, PARAMETER:: C6= .702620698E-8 - REAL, PARAMETER:: C7= .379534310E-11 - REAL, PARAMETER:: C8=-.321582393E-13 + REAL(KIND=RKIND), INTENT(IN):: P, T + REAL(KIND=RKIND):: ESL,X + REAL(KIND=RKIND), PARAMETER:: C0= .611583699E03 + REAL(KIND=RKIND), PARAMETER:: C1= .444606896E02 + REAL(KIND=RKIND), PARAMETER:: C2= .143177157E01 + REAL(KIND=RKIND), PARAMETER:: C3= .264224321E-1 + REAL(KIND=RKIND), PARAMETER:: C4= .299291081E-3 + REAL(KIND=RKIND), PARAMETER:: C5= .203154182E-5 + REAL(KIND=RKIND), PARAMETER:: C6= .702620698E-8 + REAL(KIND=RKIND), PARAMETER:: C7= .379534310E-11 + REAL(KIND=RKIND), PARAMETER:: C8=-.321582393E-13 X=MAX(-80.,T-273.16) @@ -187,20 +188,20 @@ END FUNCTION RSLF ! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR MIXING RATIO AS A ! FUNCTION OF TEMPERATURE AND PRESSURE ! - REAL FUNCTION RSIF(P,T) + REAL(KIND=RKIND) FUNCTION RSIF(P,T) IMPLICIT NONE - REAL, INTENT(IN):: P, T - REAL:: ESI,X - REAL, PARAMETER:: C0= .609868993E03 - REAL, PARAMETER:: C1= .499320233E02 - REAL, PARAMETER:: C2= .184672631E01 - REAL, PARAMETER:: C3= .402737184E-1 - REAL, PARAMETER:: C4= .565392987E-3 - REAL, PARAMETER:: C5= .521693933E-5 - REAL, PARAMETER:: C6= .307839583E-7 - REAL, PARAMETER:: C7= .105785160E-9 - REAL, PARAMETER:: C8= .161444444E-12 + REAL(KIND=RKIND), INTENT(IN):: P, T + REAL(KIND=RKIND):: ESI,X + REAL(KIND=RKIND), PARAMETER:: C0= .609868993E03 + REAL(KIND=RKIND), PARAMETER:: C1= .499320233E02 + REAL(KIND=RKIND), PARAMETER:: C2= .184672631E01 + REAL(KIND=RKIND), PARAMETER:: C3= .402737184E-1 + REAL(KIND=RKIND), PARAMETER:: C4= .565392987E-3 + REAL(KIND=RKIND), PARAMETER:: C5= .521693933E-5 + REAL(KIND=RKIND), PARAMETER:: C6= .307839583E-7 + REAL(KIND=RKIND), PARAMETER:: C7= .105785160E-9 + REAL(KIND=RKIND), PARAMETER:: C8= .161444444E-12 X=MAX(-80.,T-273.16) ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) From 29dc7bc17e915cdd1b79a691ea1b7df82c4093c7 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 6 Feb 2019 17:12:28 -0700 Subject: [PATCH 084/182] 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 49f03646ef60d667e84e34fcbe95fbb1ff32b1fc Mon Sep 17 00:00:00 2001 From: JJ Guerrette Date: Tue, 26 Feb 2019 00:29:01 +0000 Subject: [PATCH 085/182] 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 086/182] 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 087/182] 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: