diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 4281c40bba..603e879e35 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -226,7 +226,7 @@ description="Mix full $\theta$ and $u$ fields, or mix perturbation from intitial state" possible_values=".true. or .false."/> - @@ -292,6 +292,27 @@ units="-" description="Number of layers in which to apply Rayleigh damping on horizontal velocity at top of model; damping linearly ramps to zero by layer number from the top" possible_values="Positive integer values"/> + + + + + + + + + @@ -1484,6 +1505,18 @@ + + + + + + + + diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 4fe2faefc4..a016e39c96 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -156,6 +156,7 @@ subroutine mpas_atm_dynamics_checks(dminfo, blockList, streamManager, ierr) integer, intent(out) :: ierr logical, pointer :: config_positive_definite + real (kind=RKIND), pointer :: config_epssm call mpas_log_write('') @@ -177,6 +178,37 @@ subroutine mpas_atm_dynamics_checks(dminfo, blockList, streamManager, ierr) messageType=MPAS_LOG_WARN) call mpas_log_write('&nhyd_model namelist group.', & messageType=MPAS_LOG_WARN) + call mpas_log_write('') + end if + + ! + ! Check whether old config_epssm namelist option has been specified + ! + nullify(config_epssm) + call mpas_pool_get_config(blocklist % configs, 'config_epssm', config_epssm) + + if (associated(config_epssm)) then + if (config_epssm /= 0.0_RKIND) then + call mpas_log_write('The specification of the off-centering parameter for the vertically implicit', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('acoustic integration using config_epssm in the &nhyd_model namelist group is', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('no longer supported.', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('Please use the namelist options', & + messageType=MPAS_LOG_WARN) + call mpas_log_write(' config_epssm_minimum', & + messageType=MPAS_LOG_WARN) + call mpas_log_write(' config_epssm_maximum', & + messageType=MPAS_LOG_WARN) + call mpas_log_write(' config_epssm_transition_bottom_z', & + messageType=MPAS_LOG_WARN) + call mpas_log_write(' config_epssm_transition_top_z', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('in the &damping namelist group to specify level-dependent off-centering parameters.', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('') + end if end if call mpas_log_write(' ----- done checking dynamics settings -----') @@ -260,6 +292,10 @@ subroutine mpas_atm_dynamics_init(domain) real (kind=RKIND), dimension(:,:), pointer :: zgrid real (kind=RKIND), dimension(:,:), pointer :: zxu real (kind=RKIND), dimension(:,:), pointer :: dss + real (kind=RKIND), dimension(:), pointer :: etp + real (kind=RKIND), dimension(:), pointer :: etm + real (kind=RKIND), dimension(:), pointer :: ewp + real (kind=RKIND), dimension(:), pointer :: ewm real (kind=RKIND), dimension(:), pointer :: specZoneMaskCell real (kind=RKIND), dimension(:), pointer :: meshScalingRegionalCell real (kind=RKIND), dimension(:), pointer :: meshScalingRegionalEdge @@ -421,6 +457,18 @@ subroutine mpas_atm_dynamics_init(domain) call mpas_pool_get_array(mesh, 'dss', dss) !$acc enter data copyin(dss) + call mpas_pool_get_array(mesh, 'etp', etp) + !$acc enter data copyin(etp) + + call mpas_pool_get_array(mesh, 'etm', etm) + !$acc enter data copyin(etm) + + call mpas_pool_get_array(mesh, 'ewp', ewp) + !$acc enter data copyin(ewp) + + call mpas_pool_get_array(mesh, 'ewm', ewm) + !$acc enter data copyin(ewm) + call mpas_pool_get_array(mesh, 'specZoneMaskCell', specZoneMaskCell) !$acc enter data copyin(specZoneMaskCell) @@ -534,6 +582,10 @@ subroutine mpas_atm_dynamics_finalize(domain) real (kind=RKIND), dimension(:,:), pointer :: zgrid real (kind=RKIND), dimension(:,:), pointer :: zxu real (kind=RKIND), dimension(:,:), pointer :: dss + real (kind=RKIND), dimension(:), pointer :: etp + real (kind=RKIND), dimension(:), pointer :: etm + real (kind=RKIND), dimension(:), pointer :: ewp + real (kind=RKIND), dimension(:), pointer :: ewm real (kind=RKIND), dimension(:), pointer :: specZoneMaskCell real (kind=RKIND), dimension(:), pointer :: meshScalingRegionalCell real (kind=RKIND), dimension(:), pointer :: meshScalingRegionalEdge @@ -696,6 +748,18 @@ subroutine mpas_atm_dynamics_finalize(domain) call mpas_pool_get_array(mesh, 'dss', dss) !$acc exit data delete(dss) + call mpas_pool_get_array(mesh, 'etp', etp) + !$acc exit data delete(etp) + + call mpas_pool_get_array(mesh, 'etm', etm) + !$acc exit data delete(etm) + + call mpas_pool_get_array(mesh, 'ewp', ewp) + !$acc exit data delete(ewp) + + call mpas_pool_get_array(mesh, 'ewm', ewm) + !$acc exit data delete(ewm) + call mpas_pool_get_array(mesh, 'specZoneMaskCell', specZoneMaskCell) !$acc exit data delete(specZoneMaskCell) @@ -2175,12 +2239,15 @@ subroutine atm_compute_vert_imp_coefs(state, mesh, diag, configs, nVertLevels, d real (kind=RKIND), dimension(:), pointer :: cofrz, rdzw, fzm, fzp, rdzu real (kind=RKIND), dimension(:,:,:), pointer :: scalars - real (kind=RKIND), pointer :: epssm + ! variable epssm arrays + real (kind=RKIND), dimension(:), pointer :: etp, etm, ewp, ewm integer, pointer :: nCells, moist_start, moist_end - - call mpas_pool_get_config(configs, 'config_epssm', epssm) + call mpas_pool_get_array(mesh, 'etp', etp) + call mpas_pool_get_array(mesh, 'etm', etm) + call mpas_pool_get_array(mesh, 'ewp', ewp) + call mpas_pool_get_array(mesh, 'ewm', ewm) call mpas_pool_get_array(mesh, 'rdzu', rdzu) call mpas_pool_get_array(mesh, 'rdzw', rdzw) @@ -2212,9 +2279,10 @@ subroutine atm_compute_vert_imp_coefs(state, mesh, diag, configs, nVertLevels, d call mpas_pool_get_dimension(state, 'moist_end', moist_end) - call atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, epssm, & + call atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, & zz, cqw, p, t, rb, rtb, pb, rt, cofwr, cofwz, coftz, cofwt, & a_tri, alpha_tri, gamma_tri, cofrz, rdzw, fzm, fzp, rdzu, scalars, & + etp, etm, ewp, ewm, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -2222,9 +2290,10 @@ subroutine atm_compute_vert_imp_coefs(state, mesh, diag, configs, nVertLevels, d end subroutine atm_compute_vert_imp_coefs - subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, epssm, & + subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, & zz, cqw, p, t, rb, rtb, pb, rt, cofwr, cofwz, coftz, cofwt, & a_tri, alpha_tri, gamma_tri, cofrz, rdzw, fzm, fzp, rdzu, scalars, & + etp, etm, ewp, ewm, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -2238,7 +2307,6 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, ! integer, intent(in) :: nCells, moist_start, moist_end real (kind=RKIND), intent(in) :: dts - real (kind=RKIND), intent(in) :: epssm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: zz real (kind=RKIND), dimension(nVertLevels,nCells+1) :: cqw @@ -2260,6 +2328,8 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, real (kind=RKIND), dimension(nVertLevels) :: fzm real (kind=RKIND), dimension(nVertLevels) :: fzp real (kind=RKIND), dimension(nVertLevels) :: rdzu + real (kind=RKIND), dimension(nVertLevels ) :: etp,etm + real (kind=RKIND), dimension(nVertLevels+1) :: ewp,ewm real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: scalars integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd @@ -2280,7 +2350,6 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, MPAS_ACC_TIMER_STOP('atm_compute_vert_imp_coefs_work [ACC_data_xfer]') ! set coefficients - dtseps = .5*dts*(1.+epssm) rcv = rgas/(cp-rgas) c2 = cp*rcv @@ -2288,7 +2357,7 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, !$acc loop gang worker ! MGD bad to have all threads setting this variable? do k=1,nVertLevels - cofrz(k) = dtseps*rdzw(k) + cofrz(k) = rdzw(k) end do !$acc end parallel @@ -2299,15 +2368,15 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, !DIR$ IVDEP !$acc loop vector do k=2,nVertLevels - cofwr(k,iCell) =.5*dtseps*gravity*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) + cofwr(k,iCell) =.5*gravity*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) end do coftz(1,iCell) = 0.0 !DIR$ IVDEP !$acc loop vector do k=2,nVertLevels - cofwz(k,iCell) = dtseps*c2*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) & + cofwz(k,iCell) = c2*(fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell)) & *rdzu(k)*cqw(k,iCell)*(fzm(k)*p (k,iCell)+fzp(k)*p (k-1,iCell)) - coftz(k,iCell) = dtseps* (fzm(k)*t (k,iCell)+fzp(k)*t (k-1,iCell)) + coftz(k,iCell) = (fzm(k)*t (k,iCell)+fzp(k)*t (k-1,iCell)) end do coftz(nVertLevels+1,iCell) = 0.0 !DIR$ IVDEP @@ -2320,9 +2389,10 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, ! end do qtotal = qtot(k,iCell) - cofwt(k,iCell) = .5*dtseps*rcv*zz(k,iCell)*gravity*rb(k,iCell)/(1.+qtotal) & + cofwt(k,iCell) = .5*rcv*zz(k,iCell)*gravity*rb(k,iCell)/(1.+qtotal) & *p(k,iCell)/((rtb(k,iCell)+rt(k,iCell))*pb(k,iCell)) -! cofwt(k,iCell) = 0. + ! cofwt(k,iCell) = .5*rcv*zz(k,iCell)*gravity/t(k,iCell) ! zero base state option + ! cofwt(k,iCell) = 0. end do a_tri(1,iCell) = 0. ! note, this value is never used @@ -2337,21 +2407,27 @@ subroutine atm_compute_vert_imp_coefs_work(nCells, moist_start, moist_end, dts, a_tri(k,iCell) = -cofwz(k ,iCell)* coftz(k-1,iCell)*rdzw(k-1)*zz(k-1,iCell) & +cofwr(k ,iCell)* cofrz(k-1 ) & -cofwt(k-1,iCell)* coftz(k-1,iCell)*rdzw(k-1) - b_tri(k) = 1. & - +cofwz(k ,iCell)*(coftz(k ,iCell)*rdzw(k )*zz(k ,iCell) & - +coftz(k ,iCell)*rdzw(k-1)*zz(k-1,iCell)) & - -coftz(k ,iCell)*(cofwt(k ,iCell)*rdzw(k ) & - -cofwt(k-1,iCell)*rdzw(k-1)) & - +cofwr(k, iCell)*(cofrz(k )-cofrz(k-1)) + a_tri(k,iCell) = a_tri(k,iCell)*etp(k-1)*ewp(k-1) + + b_tri(k) = +cofwz(k ,iCell)*coftz(k,iCell)* & + ( etp(k )*rdzw(k )*zz(k ,iCell) & + +etp(k-1)*rdzw(k-1)*zz(k-1,iCell)) & + -coftz(k ,iCell)*( etp(k )*cofwt(k ,iCell)*rdzw(k ) & + -etp(k-1)*cofwt(k-1,iCell)*rdzw(k-1)) & + +cofwr(k, iCell)*(etp(k)*cofrz(k )-etp(k-1)*cofrz(k-1)) + b_tri(k) = b_tri(k)*ewp(k) + c_tri(k) = -cofwz(k ,iCell)* coftz(k+1,iCell)*rdzw(k )*zz(k ,iCell) & -cofwr(k ,iCell)* cofrz(k ) & +cofwt(k ,iCell)* coftz(k+1,iCell)*rdzw(k ) + c_tri(k) = c_tri(k)*etp(k)*ewp(k+1) end do + c_tri(nVertLevels) = 0.0 !MGD VECTOR DEPENDENCE !$acc loop seq do k=2,nVertLevels - alpha_tri(k,iCell) = 1./(b_tri(k)-a_tri(k,iCell)*gamma_tri(k-1,iCell)) - gamma_tri(k,iCell) = c_tri(k)*alpha_tri(k,iCell) + alpha_tri(k,iCell) = 1./(1.0+(dts**2)*(b_tri(k)-a_tri(k,iCell)*gamma_tri(k-1,iCell))) + gamma_tri(k,iCell) = (dts**2)*c_tri(k)*alpha_tri(k,iCell) end do end do ! loop over cells @@ -2557,10 +2633,10 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign - real (kind=RKIND), pointer :: epssm - real (kind=RKIND), pointer :: cf1, cf2, cf3 + real (kind=RKIND), dimension(:), pointer :: etp, etm, ewp, ewm + integer, pointer :: nEdges, nCellsSolve call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) @@ -2570,6 +2646,11 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, call mpas_pool_get_array(mesh, 'specZoneMaskEdge', specZoneMaskEdge) call mpas_pool_get_array(mesh, 'specZoneMaskCell', specZoneMaskCell) + call mpas_pool_get_array(mesh, 'etp', etp) + call mpas_pool_get_array(mesh, 'etm', etm) + call mpas_pool_get_array(mesh, 'ewp', ewp) + call mpas_pool_get_array(mesh, 'ewm', ewm) + call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) ! call mpas_pool_get_array(state, 'theta_m', theta_m, 2) call mpas_pool_get_array(state, 'theta_m', theta_m, 1) @@ -2627,16 +2708,14 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, call mpas_pool_get_array(diag, 'rw', rw) call mpas_pool_get_array(diag, 'rw_save', rw_save) - ! epssm is the offcentering coefficient for the vertically implicit integration. - call mpas_pool_get_config(configs, 'config_epssm', epssm) - call atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & rho_zz, theta_m, ru_p, rw_p, rtheta_pp, rtheta_pp_old, zz, exner, cqu, ruAvg, wwAvg, & rho_pp, cofwt, coftz, zxu, a_tri, alpha_tri, gamma_tri, dss, tend_ru, tend_rho, tend_rt, & tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & - dts, small_step, epssm, cf1, cf2, cf3, & + dts, small_step, cf1, cf2, cf3, & + etp, etm, ewp, ewm, & specZoneMaskEdge, specZoneMaskCell & ) @@ -2649,7 +2728,8 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart rho_pp, cofwt, coftz, zxu, a_tri, alpha_tri, gamma_tri, dss, tend_ru, tend_rho, tend_rt, & tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & - dts, small_step, epssm, cf1, cf2, cf3, & + dts, small_step, cf1, cf2, cf3, & + etp, etm, ewp, ewm, & specZoneMaskEdge, specZoneMaskCell & ) @@ -2703,6 +2783,10 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart real (kind=RKIND), dimension(nVertLevels) :: fzm real (kind=RKIND), dimension(nVertLevels) :: fzp real (kind=RKIND), dimension(nVertLevels) :: rdzw + real (kind=RKIND), dimension(nVertLevels ) :: etp + real (kind=RKIND), dimension(nVertLevels ) :: etm + real (kind=RKIND), dimension(nVertLevels+1) :: ewp + real (kind=RKIND), dimension(nVertLevels+1) :: ewm real (kind=RKIND), dimension(nEdges+1) :: dcEdge real (kind=RKIND), dimension(nEdges+1) :: invDcEdge real (kind=RKIND), dimension(nCells+1) :: invAreaCell @@ -2719,7 +2803,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart integer, intent(in) :: small_step - real (kind=RKIND), intent(in) :: dts, epssm,cf1, cf2, cf3 + real (kind=RKIND), intent(in) :: dts, cf1, cf2, cf3 real (kind=RKIND), dimension(nVertLevels) :: ts, rs @@ -2728,12 +2812,11 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart ! integer :: cell1, cell2, iEdge, iCell, i, k real (kind=RKIND) :: c2, rcv, rtheta_pp_tmp - real (kind=RKIND) :: pgrad, flux, resm, rdts + real (kind=RKIND) :: pgrad, flux, rdts rcv = rgas / (cp - rgas) c2 = cp * rcv - resm = (1.0 - epssm) / (1.0 + epssm) rdts = 1./dts MPAS_ACC_TIMER_START('atm_advance_acoustic_step [ACC_data_xfer]') @@ -2888,31 +2971,32 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP !$acc loop vector do k=1, nVertLevels - rs(k) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) + rs(k) & - - cofrz(k)*resm*(rw_p(k+1,iCell)-rw_p(k,iCell)) - ts(k) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) + ts(k) & - - resm*rdzw(k)*( coftz(k+1,iCell)*rw_p(k+1,iCell) & - -coftz(k,iCell)*rw_p(k,iCell)) + rs(k) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) + rs(k) & + - dts*cofrz(k)*(ewm(k+1)*rw_p(k+1,iCell)-ewm(k)*rw_p(k,iCell)) + ts(k) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) + ts(k) & + - dts*rdzw(k)*( ewm(k+1)*coftz(k+1,iCell)*rw_p(k+1,iCell) & + -ewm(k )*coftz(k,iCell)*rw_p(k,iCell)) end do !DIR$ IVDEP !$acc loop vector do k=2, nVertLevels - wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0-epssm)*rw_p(k,iCell) + wwavg(k,iCell) = wwavg(k,iCell) + ewm(k)*rw_p(k,iCell) end do !DIR$ IVDEP !$acc loop vector do k=2, nVertLevels - rw_p(k,iCell) = rw_p(k,iCell) + dts*tend_rw(k,iCell) & - - cofwz(k,iCell)*((zz(k ,iCell)*ts(k) & - -zz(k-1,iCell)*ts(k-1)) & - +resm*(zz(k ,iCell)*rtheta_pp(k ,iCell) & - -zz(k-1,iCell)*rtheta_pp(k-1,iCell))) & - - cofwr(k,iCell)*((rs(k)+rs(k-1)) & - +resm*(rho_pp(k,iCell)+rho_pp(k-1,iCell))) & - + cofwt(k ,iCell)*(ts(k )+resm*rtheta_pp(k ,iCell)) & - + cofwt(k-1,iCell)*(ts(k-1)+resm*rtheta_pp(k-1,iCell)) + rw_p(k,iCell) = rw_p(k,iCell) + dts*(tend_rw(k,iCell) & + - cofwz(k,iCell)*(( etp(k )*zz(k ,iCell)*ts(k) & + -etp(k-1)*zz(k-1,iCell)*ts(k-1)) & + + ( etm(k )*zz(k ,iCell)*rtheta_pp(k ,iCell) & + -etm(k-1)*zz(k-1,iCell)*rtheta_pp(k-1,iCell))) & + - cofwr(k,iCell)*((etp(k)*rs(k)+etp(k-1)*rs(k-1)) & + +( etm(k )*rho_pp(k ,iCell) & + +etm(k-1)*rho_pp(k-1,iCell))) & + + cofwt(k ,iCell)*(etp(k )*ts(k )+etm(k )*rtheta_pp(k ,iCell)) & + + cofwt(k-1,iCell)*(etp(k-1)*ts(k-1)+etm(k-1)*rtheta_pp(k-1,iCell))) end do ! tridiagonal solve sweeping up and then down the column @@ -2920,7 +3004,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !MGD VECTOR DEPENDENCE !$acc loop seq do k=2,nVertLevels - rw_p(k,iCell) = (rw_p(k,iCell)-a_tri(k,iCell)*rw_p(k-1,iCell))*alpha_tri(k,iCell) + rw_p(k,iCell) = (rw_p(k,iCell)-(dts**2)*a_tri(k,iCell)*rw_p(k-1,iCell))*alpha_tri(k,iCell) end do !MGD VECTOR DEPENDENCE @@ -2945,7 +3029,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP !$acc loop vector do k=2,nVertLevels - wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) + wwAvg(k,iCell) = wwAvg(k,iCell) + ewp(k)*rw_p(k,iCell) end do ! update rho_pp and theta_pp given updated rw_p @@ -2953,9 +3037,10 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart !DIR$ IVDEP !$acc loop vector do k=1,nVertLevels - rho_pp(k,iCell) = rs(k) - cofrz(k) *(rw_p(k+1,iCell)-rw_p(k ,iCell)) - rtheta_pp(k,iCell) = ts(k) - rdzw(k)*(coftz(k+1,iCell)*rw_p(k+1,iCell) & - -coftz(k ,iCell)*rw_p(k ,iCell)) + rho_pp(k,iCell) = rs(k) - dts*cofrz(k) *( ewp(k+1)*rw_p(k+1,iCell) & + -ewp(k )*rw_p(k ,iCell)) + rtheta_pp(k,iCell) = ts(k) - dts*rdzw(k)*( ewp(k+1)*coftz(k+1,iCell)*rw_p(k+1,iCell) & + -ewp(k )*coftz(k ,iCell)*rw_p(k ,iCell)) end do else ! specifed zone in regional_MPAS @@ -2965,7 +3050,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart rho_pp(k,iCell) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) rtheta_pp(k,iCell) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) rw_p(k,iCell) = rw_p(k,iCell) + dts*tend_rw(k,iCell) - wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) + wwAvg(k,iCell) = wwAvg(k,iCell) + ewp(k)*rw_p(k,iCell) end do end if diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index f7d04a1f0c..cd7fe97345 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -1253,6 +1253,11 @@ subroutine atm_compute_damping_coefs(mesh, configs) real (kind=RKIND), dimension(:), pointer :: meshDensity real (kind=RKIND) :: dx_scale_power + real (kind=RKIND), dimension(:), pointer :: rdzw, etp, etm, ewp, ewm + real (kind=RKIND), pointer :: max_coeff, min_coeff, transition_lower_bound, transition_upper_bound + real (kind=RKIND) :: transition_width + real (kind=RKIND), allocatable, dimension(:) :: height_u_levels, epssm_coeff_u, height_w_levels, epssm_coeff_w + m1 = -1.0 pii = acos(m1) @@ -1279,6 +1284,79 @@ subroutine atm_compute_damping_coefs(mesh, configs) end do end do + call mpas_pool_get_array(mesh, 'rdzw', rdzw) + call mpas_pool_get_array(mesh, 'etp', etp) + call mpas_pool_get_array(mesh, 'etm', etm) + call mpas_pool_get_array(mesh, 'ewp', ewp) + call mpas_pool_get_array(mesh, 'ewm', ewm) + call mpas_pool_get_config(configs, 'config_epssm_minimum', min_coeff) + call mpas_pool_get_config(configs, 'config_epssm_maximum', max_coeff) + call mpas_pool_get_config(configs, 'config_epssm_transition_bottom_z', transition_lower_bound) + call mpas_pool_get_config(configs, 'config_epssm_transition_top_z', transition_upper_bound) + + allocate(height_u_levels(nVertLevels)) + allocate(epssm_coeff_u(nVertLevels)) + allocate(height_w_levels(nVertLevels+1)) + allocate(epssm_coeff_w(nVertLevels+1)) + + transition_width = transition_upper_bound - transition_lower_bound + +! initialization for heights of coordinate at u and w levels +! These are the heights of the computational coordinate zeta + + height_w_levels(:) = 0.0_RKIND + do k =1, nVertLevels + height_w_levels(k+1) = height_w_levels(k) + 1.0_RKIND/rdzw(k) + height_u_levels(k) = 0.5*(height_w_levels(k+1) + height_w_levels(k)) + enddo + +! Height dependent values of epssm; profiles stored in etp, etm, ewp, and ewm, + +#ifdef MPAS_DEBUG + call mpas_log_write(' setting epssm coefficients ') + call mpas_log_write(' minimum epssm: $r ',realArgs=(/min_coeff/)) + call mpas_log_write(' maximum epssm: $r ',realArgs=(/max_coeff/)) + call mpas_log_write(' transition lower bound (m): $r ',realArgs=(/transition_lower_bound/)) + call mpas_log_write(' transition upper bound (m): $r ',realArgs=(/transition_upper_bound/)) + call mpas_log_write(' ') +#endif + + do k = 1,nVertLevels + if(height_u_levels(k).le.transition_lower_bound) then + epssm_coeff_u(k) = min_coeff + else if(height_u_levels(k).ge.transition_upper_bound) then + epssm_coeff_u(k) = max_coeff + else + z = (height_u_levels(k)-transition_lower_bound)/transition_width + epssm_coeff_u(k) = min_coeff + sin(0.5_RKIND*pii*z)**2*(max_coeff-min_coeff) + end if + etp(k) = 0.5*(1.0 + epssm_coeff_u(k)) + etm(k) = 0.5*(1.0 - epssm_coeff_u(k)) +#ifdef MPAS_DEBUG + call mpas_log_write('k, etp, etm $i $r $r ',intArgs=(/k/),realArgs=(/etp(k),etm(k)/)) +#endif + end do + do k= 1,nVertlevels+1 + if(height_w_levels(k).le.transition_lower_bound) then + epssm_coeff_w(k) = min_coeff + else if(height_w_levels(k).ge.transition_upper_bound) then + epssm_coeff_w(k) = max_coeff + else + z = (height_w_levels(k)-transition_lower_bound)/transition_width + epssm_coeff_w(k) = min_coeff + sin(0.5_RKIND*pii*z)**2*(max_coeff-min_coeff) + end if + ewp(k) = 0.5*(1.0 + epssm_coeff_w(k)) + ewm(k) = 0.5*(1.0 - epssm_coeff_w(k)) +#ifdef MPAS_DEBUG + call mpas_log_write('k, ewp, ewm $i $r $r ',intArgs=(/k/),realArgs=(/ewp(k),ewm(k)/)) +#endif + end do + + deallocate(height_u_levels) + deallocate(epssm_coeff_u) + deallocate(height_w_levels) + deallocate(epssm_coeff_w) + end subroutine atm_compute_damping_coefs