From 934f6e43fc90971eda69854b25ec4fbb8e633337 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 20 Dec 2019 12:38:04 -0700 Subject: [PATCH 001/109] add new deformation coefficients to registries --- src/core_atmosphere/Registry.xml | 30 +++++++++++++++++++++++++++ src/core_init_atmosphere/Registry.xml | 25 ++++++++++++++++++++++ 2 files changed, 55 insertions(+) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 4281c40bba..2ae703653d 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -494,6 +494,11 @@ + + + + + #ifdef MPAS_CAM_DYCORE @@ -594,6 +599,17 @@ #endif + + + + + + + + + + + @@ -1561,6 +1577,20 @@ #endif + + + + + + + + + + + + + + @@ -573,6 +578,11 @@ + + + + + @@ -1114,6 +1124,21 @@ + + + + + + + + + + From da78a8cb3384e32fb488cbb25d30eba02d18f1d6 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 20 Dec 2019 15:18:27 -0700 Subject: [PATCH 002/109] initialize new deformation coefficients --- src/core_init_atmosphere/mpas_atm_advection.F | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index f4d44c984e..59edf3b843 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -758,6 +758,8 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b real (kind=RKIND), dimension(:,:), pointer :: cell_gradient_coef_x, cell_gradient_coef_y + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c2, deformation_coef_s2, deformation_coef_cs + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c, deformation_coef_s integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, cellsOnCell, verticesOnCell integer, dimension(:), pointer :: nEdgesOnCell real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell @@ -927,9 +929,19 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere defc_b(i,iCell) = dl*2.*sint_cost/area_cell cell_gradient_coef_x(i,iCell) = dl*cos(thetat(i))/area_cell cell_gradient_coef_y(i,iCell) = dl*sin(thetat(i))/area_cell + deformation_coef_c2(i,iCell) = dl*cost2/area_cell + deformation_coef_s2(i,iCell) = dl*sint2/area_cell + deformation_coef_cs(i,iCell) = dl*sint_cost/area_cell + deformation_coef_c(i,iCell) = dl*cos(thetat(i))/area_cell + deformation_coef_s(i,iCell) = dl*sin(thetat(i))/area_cell if (cellsOnEdge(1,EdgesOnCell(i,iCell)) /= iCell) then defc_a(i,iCell) = - defc_a(i,iCell) defc_b(i,iCell) = - defc_b(i,iCell) + deformation_coef_c2(i,iCell) = - deformation_coef_c2(i,iCell) + deformation_coef_s2(i,iCell) = - deformation_coef_s2(i,iCell) + deformation_coef_cs(i,iCell) = - deformation_coef_cs(i,iCell) + deformation_coef_c(i,iCell) = - deformation_coef_c(i,iCell) + deformation_coef_s(i,iCell) = - deformation_coef_s(i,iCell) end if end do From b7880ce698cc608d17609505e258b3afbf6032af Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 20 Dec 2019 16:32:22 -0700 Subject: [PATCH 003/109] add pointers for new coefficients --- src/core_init_atmosphere/mpas_atm_advection.F | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index 59edf3b843..7e04564fa0 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -787,6 +787,11 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere call mpas_pool_get_array(mesh, 'defc_b', defc_b) call mpas_pool_get_array(mesh, 'cell_gradient_coef_x', cell_gradient_coef_x) call mpas_pool_get_array(mesh, 'cell_gradient_coef_y', cell_gradient_coef_y) + call mpas_pool_get_array(mesh, 'deformation_coef_c2', deformation_coef_c2) + call mpas_pool_get_array(mesh, 'deformation_coef_s2', deformation_coef_s2) + call mpas_pool_get_array(mesh, 'deformation_coef_cs', deformation_coef_cs) + call mpas_pool_get_array(mesh, 'deformation_coef_c', deformation_coef_c) + call mpas_pool_get_array(mesh, 'deformation_coef_s', deformation_coef_s) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) From 235b61ce726b41daf4572d3da1d3a71463a6eeb1 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Mon, 23 Dec 2019 15:07:40 -0700 Subject: [PATCH 004/109] add initialization of new arrays to zero --- src/core_init_atmosphere/mpas_atm_advection.F | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index 7e04564fa0..7a954cd630 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -806,6 +806,11 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere defc_a(:,:) = 0. defc_b(:,:) = 0. + deformation_coef_c2(:,:) = 0. + deformation_coef_s2(:,:) = 0. + deformation_coef_cs(:,:) = 0. + deformation_coef_c(:,:) = 0. + deformation_coef_s(:,:) = 0. cell_gradient_coef_x(:,:) = 0. cell_gradient_coef_y(:,:) = 0. From cf17fae8fcd6986ffcc45babcbd8be70339f9b0b Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Mon, 23 Dec 2019 15:29:57 -0700 Subject: [PATCH 005/109] pass new arrays to dyn_tend_work - compiles --- .../dynamics/mpas_atm_time_integration.F | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 4fe2faefc4..4aa46b4879 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4810,6 +4810,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:,:), pointer :: ur_cell, vr_cell real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c2, deformation_coef_s2, deformation_coef_cs + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c, deformation_coef_s real(kind=RKIND), dimension(:,:), pointer :: tend_w_pgf, tend_w_buoy @@ -4905,6 +4907,11 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) call mpas_pool_get_array(mesh, 'defc_a', defc_a) call mpas_pool_get_array(mesh, 'defc_b', defc_b) + call mpas_pool_get_array(mesh, 'deformation_coef_c2', deformation_coef_c2) + call mpas_pool_get_array(mesh, 'deformation_coef_s2', deformation_coef_s2) + call mpas_pool_get_array(mesh, 'deformation_coef_cs', deformation_coef_cs) + call mpas_pool_get_array(mesh, 'deformation_coef_c', deformation_coef_c) + call mpas_pool_get_array(mesh, 'deformation_coef_s', deformation_coef_s) 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) @@ -4966,6 +4973,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & + deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & @@ -4990,6 +4998,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & + deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & @@ -5098,6 +5107,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(maxEdges,nCells+1) :: defc_a real (kind=RKIND), dimension(maxEdges,nCells+1) :: defc_b + real (kind=RKIND), dimension(maxEdges,nCells+1) :: deformation_coef_c2, deformation_coef_s2, deformation_coef_cs + real (kind=RKIND), dimension(maxEdges,nCells+1) :: deformation_coef_c, deformation_coef_s real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_pgf real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_buoy From bf910d67d2934316b6339a69f3b54b1549f0cbaf Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 13:52:43 -0700 Subject: [PATCH 006/109] add deformation formulation to 2d Smagorinsky kdiff --- .../dynamics/mpas_atm_time_integration.F | 24 ++++++++++++++++++- 1 file changed, 23 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 4aa46b4879..b1e0241cc3 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5147,6 +5147,10 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension( nVertLevels+1 ) :: d_diag, d_off_diag, flux_arr real (kind=RKIND), dimension( nVertLevels + 1 ) :: wduz, wdwz, wdtz, dpzx real (kind=RKIND), dimension( nVertLevels ) :: ru_edge_w, q, u_mix + + real (kind=RKIND), dimension( nVertLevels+1 ) :: d_11, d_22, d_12 + real (kind=RKIND), dimension( nVertLevels+1 ) :: dudx, dudy, dvdx, dvdy + real (kind=RKIND) :: theta_turb_flux, w_turb_flux, r real (kind=RKIND) :: scalar_weight real (kind=RKIND) :: inv_r_earth @@ -5246,6 +5250,11 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm d_off_diag(k) = 0.0_RKIND end do + dudx(1:nVertLevels) = 0.0 + dudy(1:nVertLevels) = 0.0 + dvdx(1:nVertLevels) = 0.0 + dvdy(1:nVertLevels) = 0.0 + !$acc loop seq do iEdge=1,nEdgesOnCell(iCell) !$acc loop vector @@ -5254,6 +5263,14 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm - defc_b(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) d_off_diag(k) = d_off_diag(k) + defc_b(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + defc_a(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + - deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + - deformation_coef_s2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + + deformation_coef_c2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + + deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) end do end do !DIR$ IVDEP @@ -5261,7 +5278,12 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm do k=1, nVertLevels ! here is the Smagorinsky formulation, ! followed by imposition of an upper bound on the eddy viscosity - kdiff(k,iCell) = min((c_s * config_len_disp)**2 * sqrt(d_diag(k)**2 + d_off_diag(k)**2),(0.01*config_len_disp**2) * invDt) + ! kdiff(k,iCell) = min((c_s * config_len_disp)**2 * sqrt(d_diag(k)**2 + d_off_diag(k)**2),(0.01*config_len_disp**2) * invDt) + ! deformation formulation + d_11(k) = 2*dudx(k) + d_22(k) = 2*dvdy(k) + d_12(k) = dudy(k) + dvdx(k) + kdiff(k,iCell) = min((c_s * config_len_disp)**2 * sqrt(0.25*(d_11(k)-d_22(k))**2 + d_12(k)**2),(0.01*config_len_disp**2) * invDt) end do end do !$acc end parallel From 31a507c27690953c26ff409dfa7bcff605b0beba Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Fri, 27 Dec 2019 12:47:26 -0700 Subject: [PATCH 007/109] bug fixes for computing the deformation coefficients for the 2D Smagorinsky scheme on Cartesian planes. This also fixes periodicity on those planes for the coefficients. --- src/core_init_atmosphere/mpas_atm_advection.F | 66 ++++++++++++++++--- 1 file changed, 58 insertions(+), 8 deletions(-) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index 7a954cd630..585f5443ef 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -11,6 +11,7 @@ module atm_advection use mpas_derived_types use mpas_pool_routines use mpas_constants + use mpas_vector_operations use mpas_abort, only : mpas_dmpar_global_abort use mpas_log, only : mpas_log_write @@ -764,6 +765,7 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere integer, dimension(:), pointer :: nEdgesOnCell real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge real (kind=RKIND), dimension(nCells) :: theta_abs @@ -774,14 +776,22 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere integer :: iCell real (kind=RKIND) :: pii real (kind=RKIND), dimension(25) :: xp, yp + real (kind=RKIND) :: xe, ye + real (kind=RKIND) :: length_scale integer, dimension(25) :: cell_list - integer :: iv + integer :: iv, ie logical :: do_the_cell real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, dx, dy + logical, pointer :: is_periodic + real(kind=RKIND), pointer :: x_period, y_period + + call mpas_pool_get_config(mesh, 'is_periodic', is_periodic) + call mpas_pool_get_config(mesh, 'x_period', x_period) + call mpas_pool_get_config(mesh, 'y_period', y_period) call mpas_pool_get_array(mesh, 'defc_a', defc_a) call mpas_pool_get_array(mesh, 'defc_b', defc_b) @@ -803,6 +813,9 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere call mpas_pool_get_array(mesh, 'xVertex', xVertex) call mpas_pool_get_array(mesh, 'yVertex', yVertex) call mpas_pool_get_array(mesh, 'zVertex', zVertex) + call mpas_pool_get_array(mesh, 'xEdge', xEdge) + call mpas_pool_get_array(mesh, 'yEdge', yEdge) + call mpas_pool_get_array(mesh, 'zEdge', zEdge) defc_a(:,:) = 0. defc_b(:,:) = 0. @@ -900,21 +913,58 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere else ! On an x-y plane - theta_abs(iCell) = 0.0 + do i=1,n-1 + iv = verticesOnCell(i,iCell) + xp(i) = mpas_fix_periodicity(xVertex(iv),xCell(iCell),x_period) - xCell(iCell) + yp(i) = mpas_fix_periodicity(yVertex(iv),yCell(iCell),y_period) - yCell(iCell) + end do - xp(1) = xCell(iCell) - yp(1) = yCell(iCell) + ! if(iCell.lt.11) then + ! call mpas_log_write(' setting defc coefs, cell $i', intArgs=(/iCell/)) + ! do i=1,n-1 + ! iv = verticesOnCell(i,iCell) + ! call mpas_log_write(' xp,yp,xvc,yvc, $r $r $r $r', realArgs=(/xp(i),yp(i),xVertex(iv)-xCell(iCell),yVertex(iv)-yCell(iCell)/)) + ! end do + ! end if - do i=2,n - iv = verticesOnCell(i-1,iCell) - xp(i) = xVertex(iv) - yp(i) = yVertex(iv) + do i=1,n-1 + ie = edgesOnCell(i,iCell) + xe = mpas_fix_periodicity(xEdge(ie),xCell(iCell),x_period) - xCell(iCell) + ye = mpas_fix_periodicity(yEdge(ie),yCell(iCell),y_period) - yCell(iCell) + thetat(i) = atan2(ye,xe) end do + ! if(iCell .lt. 11) then + ! call mpas_log_write(' edge angles, plane calc, cell $i', intArgs=(/iCell/)) + ! do i=1,n-1 + ! call mpas_log_write(' edge angle $r', realArgs=(/thetat(i)*180./3.1415926/)) + ! end do + ! end if + + theta_abs(iCell) = thetat(1) + end if ! (1) compute cell area on the tangent plane used in the integrals ! (2) compute angle of cell edge normal vector. here we are repurposing thetat + thetat(1) = theta_abs(iCell) + + do i=2,n-1 + ip1 = i+1 + if (ip1 == n) ip1 = 1 + thetat(i) = plane_angle( 0.0_RKIND, 0.0_RKIND, 0.0_RKIND, & + xp(i)-xp(i-1), yp(i)-yp(i-1), 0.0_RKIND, & + xp(ip1)-xp(i), yp(ip1)-yp(i), 0.0_RKIND, & + 0.0_RKIND, 0.0_RKIND, 1.0_RKIND) + thetat(i) = thetat(i) + thetat(i-1) + end do + + if(iCell .lt. 11) then + call mpas_log_write(' edge angles, generic calc, cell $i', intArgs=(/iCell/)) + do i=1,n-1 + call mpas_log_write(' edge angle $r', realArgs=(/thetat(i)*180./3.1415926/)) + end do + end if area_cell = 0. do i=1,n-1 From a4c08d4a85fb719bbc03af26491ec4183a5c5fde Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 30 Dec 2019 12:26:47 -0700 Subject: [PATCH 008/109] Fixed error in w_x, w_y deformation coefficients. Added unit test for deformation coefficients on Cartesian-plane meshes. --- src/core_init_atmosphere/mpas_atm_advection.F | 243 +++++++++++++++++- 1 file changed, 234 insertions(+), 9 deletions(-) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index 585f5443ef..3b487f3797 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -765,7 +765,8 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere integer, dimension(:), pointer :: nEdgesOnCell real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex - real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge + real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge, angleEdge + real (kind=RKIND), dimension(:), pointer :: areaCell real (kind=RKIND), dimension(nCells) :: theta_abs @@ -784,7 +785,11 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere integer :: iv, ie logical :: do_the_cell +<<<<<<< HEAD real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, dx, dy +======= + real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost +>>>>>>> 94ba9031b (Fixed error in w_x, w_y deformation coefficients.) logical, pointer :: is_periodic real(kind=RKIND), pointer :: x_period, y_period @@ -816,6 +821,8 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere call mpas_pool_get_array(mesh, 'xEdge', xEdge) call mpas_pool_get_array(mesh, 'yEdge', yEdge) call mpas_pool_get_array(mesh, 'zEdge', zEdge) + call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) defc_a(:,:) = 0. defc_b(:,:) = 0. @@ -959,12 +966,12 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere thetat(i) = thetat(i) + thetat(i-1) end do - if(iCell .lt. 11) then - call mpas_log_write(' edge angles, generic calc, cell $i', intArgs=(/iCell/)) - do i=1,n-1 - call mpas_log_write(' edge angle $r', realArgs=(/thetat(i)*180./3.1415926/)) - end do - end if + ! if(iCell .lt. 11) then + ! call mpas_log_write(' edge angles, generic calc, cell $i', intArgs=(/iCell/)) + ! do i=1,n-1 + ! call mpas_log_write(' edge angle $r', realArgs=(/thetat(i)*180./3.1415926/)) + ! end do + ! end if area_cell = 0. do i=1,n-1 @@ -1000,14 +1007,232 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere deformation_coef_c2(i,iCell) = - deformation_coef_c2(i,iCell) deformation_coef_s2(i,iCell) = - deformation_coef_s2(i,iCell) deformation_coef_cs(i,iCell) = - deformation_coef_cs(i,iCell) - deformation_coef_c(i,iCell) = - deformation_coef_c(i,iCell) - deformation_coef_s(i,iCell) = - deformation_coef_s(i,iCell) +! deformation_coef_c(i,iCell) = - deformation_coef_c(i,iCell) +! deformation_coef_s(i,iCell) = - deformation_coef_s(i,iCell) end if end do end do + call atm_init_test_coefs( deformation_coef_c2, deformation_coef_s2, & + deformation_coef_cs, deformation_coef_c, & + deformation_coef_s, & + is_periodic, on_a_sphere, & + x_period, y_period, & + xEdge, yEdge, zEdge, & + xCell, yCell, zCell, nCells, & + angleEdge, nEdgesOnCell, edgesOnCell ) + + end subroutine atm_initialize_deformation_weights end module atm_advection +!----------------------- + + subroutine atm_init_test_coefs( deformation_coef_c2, deformation_coef_s2, & + deformation_coef_cs, deformation_coef_c, & + deformation_coef_s, & + is_periodic, on_a_sphere, & + x_period, y_period, & + xEdge, yEdge, zEdge, & + xCell, yCell, zCell, nCells, & + angleEdge, nEdgesOnCell, edgesOnCell ) + + implicit none + + logical :: is_periodic, on_a_sphere + integer :: nCells + integer, dimension(:) :: nEdgesOnCell + real (kind=RKIND) :: x_period, y_period + real (kind=RKIND), dimension(:,:) :: deformation_coef_c2, deformation_coef_s2 + real (kind=RKIND), dimension(:,:) :: deformation_coef_cs + real (kind=RKIND), dimension(:,:) :: deformation_coef_c, deformation_coef_s + integer, dimension(:,:) :: edgesOnCell + real (kind=RKIND), dimension(:) :: angleEdge, xEdge, yEdge, zEdge + real (kind=RKIND), dimension(:) :: xCell, yCell, zCell + + ! local variables + + integer :: iCell, iEdge, ie + real (kind=RKIND) :: cos_edge, sin_edge, ux, uy, vx, vy, wx, wy + real (kind=RKIND) :: xc, yc, xe, ye + real (kind=RKIND) :: angle_e, ue, ve, we, e_int + real (kind=RKIND) :: dudx, dudy, dvdx, dvdy, dwdx, dwdy + real (kind=RKIND) :: dudx_c, dudy_c, dvdx_c, dvdy_c, dwdx_c, dwdy_c + + real (kind=RKIND) :: dudx_err_max, dudy_err_max, dvdx_err_max, dvdy_err_max, dwdx_err_max, dwdy_err_max + real (kind=RKIND) :: dudx_err_tot, dudy_err_tot, dvdx_err_tot, dvdy_err_tot, dwdx_err_tot, dwdy_err_tot + real (kind=RKIND) :: dudx_max, dudy_max, dvdx_max, dvdy_max, dwdx_max, dwdy_max + + real (kind=RKIND) :: ang + real (kind=RKIND), parameter :: x_vel= 1.0, y_vel=1.0, w_vel=1.0 + real (kind=RKIND) :: u_edge, v_edge, w_edge, x, y, angle, xl, yl + real (kind=RKIND) :: dudx_cell, dudy_cell, dvdx_cell, dvdy_cell, dwdx_cell, dwdy_cell + + ! Test tunction definitions + ! + ! here are the velocity field functions and their derivatives. + ! First a simple test: U = x_vel*(-x+y), V = y_vel * (-x+y), W = w_vel*(-x+y) + + u_edge(x,y,ang,xl,yl) = (x_vel*(x+y)) * cos(ang) + (y_vel * (x+y) * sin(ang)) + v_edge(x,y,ang,xl,yl) = -(x_vel*(x+y)) * sin(ang) + (y_vel * (x+y) * cos(ang)) + w_edge(x,y,xl,yl) = w_vel * (x+y) + + dudx_cell(x,y,xl,yl) = x_vel + dudy_cell(x,y,xl,yl) = x_vel + dvdx_cell(x,y,xl,yl) = y_vel + dvdy_cell(x,y,xl,yl) = y_vel + dwdx_cell(x,y,xl,yl) = w_vel + dwdy_cell(x,y,xl,yl) = w_vel + + ! ----------------- + + if ( (.not. on_a_sphere) .and. (is_periodic) ) then ! test is for doubly-periodic Cartesian plane only + + dudx_err_max = 0. + dudy_err_max = 0. + dvdx_err_max = 0. + dvdy_err_max = 0. + dwdx_err_max = 0. + dwdy_err_max = 0. + + dudx_err_tot = 0. + dudy_err_tot = 0. + dvdx_err_tot = 0. + dvdy_err_tot = 0. + dwdx_err_tot = 0. + dwdy_err_tot = 0. + + dudx_max = 0. + dudy_max = 0. + dvdx_max = 0. + dvdy_max = 0. + dwdx_max = 0. + dwdy_max = 0. + + do iCell = 1, nCells + + dudx = 0. + dudy = 0. + dvdx = 0. + dvdy = 0. + dwdx = 0. + dwdy = 0. + + xc = xCell(iCell) + yc = yCell(iCell) + + dudx_c = dudx_cell(xc,yc,x_period,y_period) + dudy_c = dudy_cell(xc,yc,x_period,y_period) + dvdx_c = dvdx_cell(xc,yc,x_period,y_period) + dvdy_c = dvdy_cell(xc,yc,x_period,y_period) + dwdx_c = dwdx_cell(xc,yc,x_period,y_period) + dwdy_c = dwdy_cell(xc,yc,x_period,y_period) + + do iEdge = 1, nEdgesOnCell(iCell) + + ie = edgesOnCell(iEdge,iCell) + angle_e = angleEdge(ie) + xe = xEdge(ie) + ye = yEdge(ie) + + xe = mpas_fix_periodicity(xe,xc,x_period) + ye = mpas_fix_periodicity(ye,yc,y_period) + + ue = u_edge(xe,ye,angle_e,x_period,y_period) + ve = v_edge(xe,ye,angle_e,x_period,y_period) + we = w_edge(xe,ye,x_period,y_period) + + dudx = dudx + deformation_coef_c2(iEdge,iCell)*ue & + - deformation_coef_cs(iEdge,iCell)*ve + dudy = dudy + deformation_coef_cs(iEdge,iCell)*ue & + - deformation_coef_s2(iEdge,iCell)*ve + dvdx = dvdx + deformation_coef_cs(iEdge,iCell)*ue & + + deformation_coef_c2(iEdge,iCell)*ve + dvdy = dvdy + deformation_coef_s2(iEdge,iCell)*ue & + + deformation_coef_cs(iEdge,iCell)*ve + + dwdx = dwdx + deformation_coef_c(iEdge,iCell)*we + dwdy = dwdy + deformation_coef_s(iEdge,iCell)*we + + end do + + ! call mpas_log_write(' u_x, u_y, $r, $r ', realArgs=(/dudx, dudy/)) + ! call mpas_log_write(' v_x, v_y, $r, $r ', realArgs=(/dvdx, dvdy/)) + ! call mpas_log_write(' w_x, w_y, $r, $r ', realArgs=(/dwdx, dwdy/)) + + ! check result for cell + + e_int = abs(dudx_c - dudx) + dudx_err_tot = dudx_err_tot + e_int + dudx_err_max = max(dudx_err_max, e_int) + + e_int = abs(dudy_c - dudy) + dudy_err_tot = dudy_err_tot + e_int + dudy_err_max = max(dudy_err_max, e_int) + + e_int = abs(dvdx_c - dvdx) + dvdx_err_tot = dvdx_err_tot + e_int + dvdx_err_max = max(dvdx_err_max, e_int) + + e_int = abs(dvdy_c - dvdy) + dvdy_err_tot = dvdy_err_tot + e_int + dvdy_err_max = max(dvdy_err_max, e_int) + + e_int = abs(dwdx_c - dwdx) + dwdx_err_tot = dwdx_err_tot + e_int + dwdx_err_max = max(dwdx_err_max, e_int) + + e_int = abs(dwdy_c - dwdy) + dwdy_err_tot = dwdy_err_tot + e_int + dwdy_err_max = max(dwdy_err_max, e_int) + + dudx_max = max(dudx_max, abs(dudx_c)) + dudy_max = max(dudy_max, abs(dudy_c)) + dvdx_max = max(dvdx_max, abs(dvdx_c)) + dvdy_max = max(dvdy_max, abs(dvdy_c)) + dwdx_max = max(dwdx_max, abs(dwdx_c)) + dwdy_max = max(dwdy_max, abs(dwdy_c)) + + end do + + ! scale errors + + dudx_err_max = dudx_err_max/dudx_max + dudy_err_max = dudy_err_max/dudy_max + dvdx_err_max = dvdx_err_max/dvdx_max + dvdy_err_max = dvdy_err_max/dvdy_max + dwdx_err_max = dwdx_err_max/dwdx_max + dwdy_err_max = dwdy_err_max/dwdy_max + + dudx_err_tot = dudx_err_tot/dudx_max/real(nCells) + dudy_err_tot = dudy_err_tot/dudy_max/real(nCells) + dvdx_err_tot = dvdx_err_tot/dvdx_max/real(nCells) + dvdy_err_tot = dvdy_err_tot/dvdy_max/real(nCells) + dwdx_err_tot = dwdx_err_tot/dwdx_max/real(nCells) + dwdy_err_tot = dwdy_err_tot/dwdy_max/real(nCells) + + ! output + + call mpas_log_write(' ') + call mpas_log_write(' deformation coefficients check ') + call mpas_log_write(' dudx check, max abs(dudx), max and avg error $r, $r, $r', & + realArgs=(/dudx_max, dudx_err_max, dudx_err_tot/)) + call mpas_log_write(' dudy check, max abs(dudy), max and avg error $r, $r, $r', & + realArgs=(/dudy_max, dudy_err_max, dudy_err_tot/)) + call mpas_log_write(' dvdx check, max abs(dvdx), max and avg error $r, $r, $r', & + realArgs=(/dvdx_max, dvdx_err_max, dvdx_err_tot/)) + call mpas_log_write(' dvdy check, max abs(dvdy), max and avg error $r, $r, $r', & + realArgs=(/dvdy_max, dvdy_err_max, dvdy_err_tot/)) + call mpas_log_write(' dwdx check, max abs(dwdx), max and avg error $r, $r, $r', & + realArgs=(/dwdx_max, dwdx_err_max, dwdx_err_tot/)) + call mpas_log_write(' dwdy check, max abs(dwdy), max and avg error $r, $r, $r', & + realArgs=(/dwdy_max, dwdy_err_max, dwdy_err_tot/)) + call mpas_log_write(' ') + + end if + + end subroutine atm_init_test_coefs + +end module atm_advection From 4fbeab4ff8213c6b545ff6c34d31a4c63b8b2e7e Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 31 Dec 2019 10:50:15 -0700 Subject: [PATCH 009/109] New module file for the dissipation routines. The algorithm for the 2D Smagorinsky eddy viscosity coefficients are implemented in this module. Others to follow. --- .../dynamics/mpas_atm_dissipation_models.F | 74 +++++++++++++++++++ 1 file changed, 74 insertions(+) create mode 100644 src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F new file mode 100644 index 0000000000..c64fd90fa3 --- /dev/null +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -0,0 +1,74 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! + +module mpas_atm_dissipation_models + + use mpas_kind_types, only : RKIND + + contains + + subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & + nCells, nEdges, nVertLevels, maxEdges ) + implicit none + + integer, intent(in) :: cellStart, cellEnd, nCells, nEdges, nVertLevels, maxEdges + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: v + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_c2 + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_s2 + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_cs + real (kind=RKIND), intent(in) :: c_s, config_len_disp, invDt, config_visc4_2dsmag + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: kdiff + real (kind=RKIND), intent(out) :: h_mom_eddy_visc4, h_theta_eddy_visc4 + + ! local variables + + integer :: iCell, iEdge, k + real (kind=RKIND), dimension(nVertLevels) :: d_11, d_22, d_12, dudx, dudy, dvdx, dvdy + + do iCell = cellStart,cellEnd + dudx(1:nVertLevels) = 0.0 + dudy(1:nVertLevels) = 0.0 + dvdx(1:nVertLevels) = 0.0 + dvdy(1:nVertLevels) = 0.0 + do iEdge=1,nEdgesOnCell(iCell) + do k=1,nVertLevels + dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + - deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + - deformation_coef_s2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + + deformation_coef_c2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + + deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + end do + end do +!DIR$ IVDEP + do k=1, nVertLevels + ! here is the Smagorinsky formulation, + ! followed by imposition of an upper bound on the eddy viscosity + d_11(k) = 2*dudx(k) + d_22(k) = 2*dvdy(k) + d_12(k) = dudy(k) + dvdx(k) + kdiff(k,iCell) = (c_s * config_len_disp)**2 * sqrt(0.25*(d_11(k)-d_22(k))**2 + d_12(k)**2) + kdiff(k,iCell) = min(kdiff(k,iCell),(0.01*config_len_disp**2) * invDt) + end do + end do + + h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 + h_theta_eddy_visc4 = h_mom_eddy_visc4 + + end subroutine smagorinsky_2d + +end module mpas_atm_dissipation_models From bf5e369d941fae9323c95cbc3ab0a403d3937a1b Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 13:55:05 -0700 Subject: [PATCH 010/109] (1) Changes to the Makefile to compile new dissipation module. (2) Changes in atm_compute_dyn_tend to call dissipation module subroutine to compute 2D Smagorinsky eddy viscosity. --- src/core_atmosphere/dynamics/Makefile | 5 +- .../dynamics/mpas_atm_time_integration.F | 58 +++---------------- 2 files changed, 10 insertions(+), 53 deletions(-) diff --git a/src/core_atmosphere/dynamics/Makefile b/src/core_atmosphere/dynamics/Makefile index 6892633c68..1bf21fff9d 100644 --- a/src/core_atmosphere/dynamics/Makefile +++ b/src/core_atmosphere/dynamics/Makefile @@ -1,11 +1,12 @@ .SUFFIXES: .F .o OBJS = mpas_atm_time_integration.o \ - mpas_atm_boundaries.o + mpas_atm_boundaries.o \ + mpas_atm_dissipation_models.o all: $(OBJS) -mpas_atm_time_integration.o: mpas_atm_boundaries.o mpas_atm_iau.o +mpas_atm_time_integration.o: mpas_atm_boundaries.o mpas_atm_iau.o mpas_atm_dissipation_models.o mpas_atm_boundaries.o: diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index b1e0241cc3..c2aa4cf94f 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -36,6 +36,7 @@ module atm_time_integration use mpas_atm_boundaries, only : nSpecZone, nRelaxZone, nBdyZone, mpas_atm_get_bdy_state, mpas_atm_get_bdy_tend ! regional_MPAS addition use mpas_atm_iau + use mpas_atm_dissipation_models ! ! Abstract interface for routine used to communicate halos of fields @@ -5236,60 +5237,15 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc end parallel ! Smagorinsky eddy viscosity, based on horizontal deformation (in this case on model coordinate surfaces). - ! The integration coefficients were precomputed and stored in defc_a and defc_b + ! The integration coefficients were precomputed and stored in deformation_coef_* if(config_horiz_mixing == "2d_smagorinsky") then - !$acc parallel default(present) - !$acc loop gang worker private(d_diag, d_off_diag) - do iCell = cellStart,cellEnd - - !$acc loop vector - do k = 1, nVertLevels - d_diag(k) = 0.0_RKIND - d_off_diag(k) = 0.0_RKIND - end do - - dudx(1:nVertLevels) = 0.0 - dudy(1:nVertLevels) = 0.0 - dvdx(1:nVertLevels) = 0.0 - dvdy(1:nVertLevels) = 0.0 - - !$acc loop seq - do iEdge=1,nEdgesOnCell(iCell) - !$acc loop vector - do k=1,nVertLevels - d_diag(k) = d_diag(k) + defc_a(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - - defc_b(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - d_off_diag(k) = d_off_diag(k) + defc_b(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - + defc_a(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - - deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - - deformation_coef_s2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - + deformation_coef_c2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - + deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - end do - end do -!DIR$ IVDEP - !$acc loop vector - do k=1, nVertLevels - ! here is the Smagorinsky formulation, - ! followed by imposition of an upper bound on the eddy viscosity - ! kdiff(k,iCell) = min((c_s * config_len_disp)**2 * sqrt(d_diag(k)**2 + d_off_diag(k)**2),(0.01*config_len_disp**2) * invDt) - ! deformation formulation - d_11(k) = 2*dudx(k) - d_22(k) = 2*dvdy(k) - d_12(k) = dudy(k) + dvdx(k) - kdiff(k,iCell) = min((c_s * config_len_disp)**2 * sqrt(0.25*(d_11(k)-d_22(k))**2 + d_12(k)**2),(0.01*config_len_disp**2) * invDt) - end do - end do - !$acc end parallel - - h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 - h_theta_eddy_visc4 = h_mom_eddy_visc4 + call smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & + nCells, nEdges, nVertLevels, maxEdges ) else if(config_horiz_mixing == "2d_fixed") then From 597f74f0bddf7ddd17386fb29d1b3a917f7ed1e8 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 31 Dec 2019 11:11:04 -0700 Subject: [PATCH 011/109] Modifications to use mpas_atm_dimensions in the dissipation module so that compile time specification of Nvertlevels and maxEdges is enabled. --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 7 +++++-- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 2 +- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index c64fd90fa3..7b8457d927 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -16,10 +16,13 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & - nCells, nEdges, nVertLevels, maxEdges ) + nCells, nEdges ) + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + implicit none - integer, intent(in) :: cellStart, cellEnd, nCells, nEdges, nVertLevels, maxEdges + integer, intent(in) :: cellStart, cellEnd, nCells, nEdges real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: v real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_c2 diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index c2aa4cf94f..0ec79e0800 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5245,7 +5245,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & - nCells, nEdges, nVertLevels, maxEdges ) + nCells, nEdges ) else if(config_horiz_mixing == "2d_fixed") then From b454527bc22d6425241273219ab11c000d15bb65 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 14:00:37 -0700 Subject: [PATCH 012/109] Adding configuration string for the les models in the Registry. Made string available in atm_compute_dyn_tend and set up logic to allow for different dissipation options that now include the les models. --- src/core_atmosphere/Registry.xml | 5 ++ .../dynamics/mpas_atm_time_integration.F | 51 ++++++++++++------- 2 files changed, 37 insertions(+), 19 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 2ae703653d..94e6b43f22 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -146,6 +146,11 @@ description="Formulation of horizontal mixing" possible_values="`2d_fixed' or `2d_smagorinsky'"/> + + Date: Thu, 4 Dec 2025 14:06:43 -0700 Subject: [PATCH 013/109] Moved the dissipation term computations for u, theta and w from subroutine atm_compute_dyn_tend to subroutines in mpas_atm_dissipation.F. The results are no longer bit-for-bit with the modified code because we have re-arranged the order to the processes in the vertical momentum equation to accommodate doing the horizontal and vertical dissipation for w together. --- .../dynamics/mpas_atm_dissipation_models.F | 502 ++++++++++++++++++ .../dynamics/mpas_atm_time_integration.F | 447 ++-------------- 2 files changed, 533 insertions(+), 416 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 7b8457d927..af983af979 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -74,4 +74,506 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, end subroutine smagorinsky_2d +!--------------------------------------- + + subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & + cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & + nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & + invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & + angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & + config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & + config_del4u_div_factor, zgrid, kdiff, & + delsq_u, delsq_vorticity, delsq_divergence, & + u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + + implicit none + + integer, intent(in) :: edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: vertexStart, vertexEnd, vertexDegree + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: nCells, nEdges, nVertices + logical, intent(in) :: config_mix_full + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + integer, dimension(2,nEdges+1), intent(in) :: verticesOnEdge + integer, dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(vertexDegree,nVertices+1), intent(in) :: edgesOnVertex + + real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 + real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 + real (kind=RKIND), intent(in) :: config_del4u_div_factor + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(vertexDegree,nVertices+1), intent(in) :: edgesOnVertex_sign + real (kind=RKIND), dimension(nVertices+1), intent(in) :: invAreaTriangle + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: angleEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid + + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: divergence + real (kind=RKIND), dimension(nVertLevels,nVertices+1), intent(in) :: vorticity + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff + + + ! scratch space from calling routine + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: delsq_u + real (kind=RKIND), dimension(nVertLevels,nVertices+1) :: delsq_vorticity + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_divergence + + real (kind=RKIND), dimension(nVertLevels), intent(in) :: u_init, v_init + + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(out) :: tend_u_euler + + ! local variables + + integer :: iEdge, cell1, cell2, vertex1, vertex2, iVertex, iCell, i, k + real (kind=RKIND) :: r_dc, r_dv, u_diffusion, kdiffu, r, edge_sign, u_mix_scale + real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp + real (kind=RKIND), dimension(nVertLevels) :: u_mix + +!$OMP BARRIER + + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). + ! First, storage to hold the result from the first del^2 computation. + + delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 + + do iEdge=edgeStart,edgeEnd + 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)) + +!DIR$ IVDEP + do k=1,nVertLevels + + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant + u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & + -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv + + delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion + + kdiffu = 0.5*(kdiff(k,cell1)+kdiff(k,cell2)) + + ! include 2nd-orer diffusion here + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & + + rho_edge(k,iEdge)* kdiffu * u_diffusion * meshScalingDel2(iEdge) + + end do + end do + + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + +!$OMP BARRIER + + do iVertex=vertexStart,vertexEnd + delsq_vorticity(1:nVertLevels,iVertex) = 0.0 + do i=1,vertexDegree + iEdge = edgesOnVertex(i,iVertex) + edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) + do k=1,nVertLevels + delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) + end do + end do + end do + + do iCell=cellStart,cellEnd + delsq_divergence(1:nVertLevels,iCell) = 0.0 + r = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) + do k=1,nVertLevels + delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) + end do + end do + end do + +!$OMP BARRIER + + do iEdge=edgeSolveStart,edgeSolveEnd + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + vertex1 = verticesOnEdge(1,iEdge) + vertex2 = verticesOnEdge(2,iEdge) + + u_mix_scale = meshScalingDel4(iEdge)*h_mom_eddy_visc4 + r_dc = u_mix_scale * config_del4u_div_factor * invDcEdge(iEdge) + r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) + +!DIR$ IVDEP + do k=1,nVertLevels + + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant + ! + ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor + ! relative to the rotational part. The stability constraint on the divergence component is much less + ! stringent than the rotational part, and this flexibility may be useful. + ! + u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & + -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion + + end do + end do + + end if ! 4th order mixing is active + + ! + ! vertical mixing for u - 2nd order filter in physical (z) space + ! + if ( v_mom_eddy_visc2 > 0.0 ) then + + if (config_mix_full) then ! mix full state + + do iEdge=edgeSolveStart,edgeSolveEnd + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=2,nVertLevels-1 + + z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) + z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) + z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) + z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & + (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) & + -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + else ! idealized cases where we mix on the perturbation from the initial 1-D state + + do iEdge=edgeSolveStart,edgeSolveEnd + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + 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 + + z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) + z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) + z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) + z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & + (u_mix(k+1)-u_mix(k ))/(zp-z0) & + -(u_mix(k )-u_mix(k-1))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + end if ! mix perturbation state + + end if ! vertical mixing of horizontal momentum + + end subroutine u_dissipation + +!------------------------ + + subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, kdiff, rho_zz, & + tend_w_euler ) + + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + + implicit none + + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, intent(in) :: nCells, nEdges + + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 + real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: tend_w_euler + + ! storage passed in from calling routine + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_w + + ! local variables + + integer :: cell1, cell2, iEdge, iCell, i, k + real (kind=RKIND) :: r_areaCell, edge_sign, w_turb_flux + +! !OMP BARRIER why is this openmp barrier here??? + + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). + ! + ! First, storage to hold the result from the first del^2 computation. + ! we copied code from the theta mixing, hence the theta* names. + + + delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + tend_w_euler(1:nVertLevels+1,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + + edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + +!DIR$ IVDEP + do k=2,nVertLevels + + w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) + delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux + w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & + (kdiff(k,cell1)+kdiff(k,cell2)+kdiff(k-1,cell1)+kdiff(k-1,cell2)) + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux + end do + end do + end do + +!$OMP BARRIER + + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) + + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) + end do + + end do + end do + + end if ! 4th order mixing is active + + if ( v_mom_eddy_visc2 > 0.0 ) then ! vertical mixing + + do iCell=cellSolveStart,cellSolveEnd +!DIR$ IVDEP + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & + (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & + -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k) + end do + end do + + end if + + end subroutine w_dissipation + +!----------------------------------------------------- + + subroutine theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, kdiff, rho_zz, & + tend_theta_euler ) + + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + implicit none + + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, intent(in) :: nCells, nEdges + + logical, intent(in) :: config_mix_full + + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + real (kind=RKIND), intent(in) :: h_theta_eddy_visc4 + real (kind=RKIND), intent(in) :: v_theta_eddy_visc2 + real (kind=RKIND), intent(in) :: prandtl_inv + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + real (kind=RKIND), dimension(nVertLevels+1, nCells+1), intent(in) :: zgrid + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: t_init + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler + + ! storage passed in from calling routine + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_theta + + ! local variables + integer :: cell1, cell2, iEdge, iCell, i, k + real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale + real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp + + delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + tend_theta_euler(1:nVertLevels,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + pr_scale = prandtl_inv * meshScalingDel2(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) +!DIR$ IVDEP + do k=1,nVertLevels + +! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below + + theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) + delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux + theta_turb_flux = theta_turb_flux*0.5*(kdiff(k,cell1)+kdiff(k,cell2)) * pr_scale + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux + + end do + end do + end do + +!$OMP BARRIER + + if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active + + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + + iEdge = edgesOnCell(i,iCell) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) + end do + end do + end do + + end if ! 4th order mixing is active + + if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m + + if (config_mix_full) then + + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & + -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + else ! idealized cases where we mix on the perturbation from the initial 1-D state + + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & + -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + end if + + end if + + end subroutine theta_dissipation + end module mpas_atm_dissipation_models diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 97f3d85e25..1ae2abb219 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5461,203 +5461,16 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$OMP BARRIER - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). - ! First, storage to hold the result from the first del^2 computation. - - !$acc parallel default(present) - !$acc loop gang worker - do iEdge = edgeStart, edgeEnd - !$acc loop vector - do k = 1, nVertLevels - delsq_u(k,iEdge) = 0.0_RKIND - end do - end do - !$acc end parallel - - !$acc parallel default(present) - !$acc loop gang worker - do iEdge=edgeStart,edgeEnd - 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)) - -!DIR$ IVDEP - !$acc loop vector - do k=1,nVertLevels - - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant - u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & - -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv - - delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion - - kdiffu = 0.5*(kdiff(k,cell1)+kdiff(k,cell2)) - - ! include 2nd-orer diffusion here - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & - + rho_edge(k,iEdge)* kdiffu * u_diffusion * meshScalingDel2(iEdge) - - end do - end do - !$acc end parallel - - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active - -!$OMP BARRIER - - !$acc parallel default(present) - !$acc loop gang worker - do iVertex=vertexStart,vertexEnd - - !$acc loop vector - do k=1,nVertLevels - delsq_vorticity(k,iVertex) = 0.0_RKIND - end do - - !$acc loop seq - do i=1,vertexDegree - iEdge = edgesOnVertex(i,iVertex) - edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) - - !$acc loop vector - do k=1,nVertLevels - delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) - end do - end do - end do - - !$acc loop gang worker - do iCell=cellStart,cellEnd - - !$acc loop vector - do k=1,nVertLevels - delsq_divergence(k,iCell) = 0.0_RKIND - end do - - r = invAreaCell(iCell) - - !$acc loop seq - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) - - !$acc loop vector - do k=1,nVertLevels - delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) - end do - end do - end do - !$acc end parallel - -!$OMP BARRIER - - !$acc parallel default(present) - !$acc loop gang worker - do iEdge=edgeSolveStart,edgeSolveEnd - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - vertex1 = verticesOnEdge(1,iEdge) - vertex2 = verticesOnEdge(2,iEdge) - - u_mix_scale = meshScalingDel4(iEdge)*h_mom_eddy_visc4 - r_dc = u_mix_scale * config_del4u_div_factor * invDcEdge(iEdge) - r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) - -!DIR$ IVDEP - !$acc loop vector - do k=1,nVertLevels - - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant - ! - ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor - ! relative to the rotational part. The stability constraint on the divergence component is much less - ! stringent than the rotational part, and this flexibility may be useful. - ! - u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & - -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion - - end do - end do - !$acc end parallel - - end if ! 4th order mixing is active - - ! - ! vertical mixing for u - 2nd order filter in physical (z) space - ! - if ( v_mom_eddy_visc2 > 0.0 ) then - - if (config_mix_full) then ! mix full state - - !$acc parallel default(present) - !$acc loop gang worker - do iEdge=edgeSolveStart,edgeSolveEnd - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - !$acc loop vector - do k=2,nVertLevels-1 - - z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) - z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) - z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) - z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & - (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) & - -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - !$acc end parallel - - else ! idealized cases where we mix on the perturbation from the initial 1-D state - - !$acc parallel default(present) - !$acc loop gang worker private(u_mix) - do iEdge=edgeSolveStart,edgeSolveEnd - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - !$acc loop vector - do k=1,nVertLevels - u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & - - v_init(k) * sin( angleEdge(iEdge) ) - end do - - !$acc loop vector - do k=2,nVertLevels-1 - - z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) - z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) - z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) - z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & - (u_mix(k+1)-u_mix(k ))/(zp-z0) & - -(u_mix(k )-u_mix(k-1))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - !$acc end parallel - - end if ! mix perturbation state - - end if ! vertical mixing of horizontal momentum + call u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & + cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & + nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & + invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & + angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & + config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & + config_del4u_div_factor, zgrid, kdiff, & + delsq_u, delsq_vorticity, delsq_divergence, & + u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) end if ! (rk_step 1 test for computing mixing terms) @@ -5785,80 +5598,16 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then -! !OMP BARRIER why is this openmp barrier here??? - - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). - ! - ! First, storage to hold the result from the first del^2 computation. - ! we copied code from the theta mixing, hence the theta* names. - - !$acc parallel default(present) - !$acc loop gang worker - do iCell=cellStart,cellEnd - - !$acc loop vector - do k=1,nVertLevels - delsq_w(k,iCell) = 0.0_RKIND - end do - - !$acc loop vector - do k=1,nVertLevels+1 - tend_w_euler(k,iCell) = 0.0_RKIND - end do - - r_areaCell = invAreaCell(iCell) - - !$acc loop seq - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - - edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - -!DIR$ IVDEP - !$acc loop vector - do k=2,nVertLevels - - w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) - delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux - w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & - (kdiff(k,cell1)+kdiff(k,cell2)+kdiff(k-1,cell1)+kdiff(k-1,cell2)) - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux - end do - end do - end do - !$acc end parallel - -!$OMP BARRIER - - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active - - !$acc parallel default(present) - !$acc loop gang worker - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - - r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) - - !$acc loop seq - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) - - !$acc loop vector - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) - end do - - end do - end do - !$acc end parallel - - end if ! 4th order mixing is active + call w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, kdiff, rho_zz, & + tend_w_euler ) end if ! horizontal mixing for w computed in first rk_step @@ -5913,27 +5662,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end do !$acc end parallel - if (rk_step == 1) then - - if ( v_mom_eddy_visc2 > 0.0 ) then - - !$acc parallel default(present) - !$acc loop gang worker - do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP - !$acc loop vector - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & - (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & - -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k) - end do - end do - !$acc end parallel - - end if - - end if ! mixing term computed first rk_step - ! add in mixing terms for w !$acc parallel default(present) @@ -6024,69 +5752,17 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then - !$acc parallel default(present) - !$acc loop gang worker - do iCell=cellStart,cellEnd - - !$acc loop vector - do k=1,nVertLevels - delsq_theta(k,iCell) = 0.0_RKIND - tend_theta_euler(k,iCell) = 0.0_RKIND - end do - - r_areaCell = invAreaCell(iCell) - - !$acc loop seq - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - pr_scale = prandtl_inv * meshScalingDel2(iEdge) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) -!DIR$ IVDEP - !$acc loop vector - do k=1,nVertLevels - -! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below - - theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) - delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux - theta_turb_flux = theta_turb_flux*0.5*(kdiff(k,cell1)+kdiff(k,cell2)) * pr_scale - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux - - end do - end do - end do - !$acc end parallel - -!$OMP BARRIER - - if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active - - !$acc parallel default(present) - !$acc loop gang worker - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - - r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) - - !$acc loop seq - do i=1,nEdgesOnCell(iCell) - - iEdge = edgesOnCell(i,iCell) - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - !$acc loop vector - do k=1,nVertLevels - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) - end do - end do - end do - !$acc end parallel - - end if ! 4th order mixing is active + call theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, kdiff, rho_zz, & + tend_theta_euler ) end if ! theta mixing calculated first rk_step @@ -6127,73 +5803,12 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end do !$acc end parallel - ! - ! vertical mixing for theta - 2nd order - ! - - if (rk_step == 1) then - - if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m - - if (config_mix_full) then - - !$acc parallel default(present) - !$acc loop gang worker - do iCell = cellSolveStart,cellSolveEnd - - !$acc loop vector - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & - -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - !$acc end parallel - - else ! idealized cases where we mix on the perturbation from the initial 1-D state - - !$acc parallel default(present) - !$acc loop gang worker - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & - -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - !$acc end parallel - - end if - - end if - - end if ! compute vertical theta mixing on first rk_step - !$acc parallel default(present) !$acc loop gang worker do iCell = cellSolveStart,cellSolveEnd !DIR$ IVDEP !$acc loop vector do k=1,nVertLevels -! tend_theta(k,iCell) = tend_theta(k,iCell) + tend_theta_euler(k,iCell) tend_theta(k,iCell) = tend_theta(k,iCell) + tend_theta_euler(k,iCell) + tend_rtheta_physics(k,iCell) end do end do From 93d2ac51f461aad9d61e46ee0628496675b97ed7 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 6 Jan 2020 13:16:23 -0700 Subject: [PATCH 014/109] Added initialization for convective boundary layer LES case. This is config_init_case = 10 --- .../mpas_init_atm_cases.F | 577 +++++++++++++++++- 1 file changed, 576 insertions(+), 1 deletion(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 673ebfc525..82b2517e76 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -393,13 +393,30 @@ subroutine init_atm_setup_case(domain, stream_manager) call init_atm_case_cam_mpas(stream_manager, domain % dminfo, block_ptr, & mesh, block_ptr % dimensions, block_ptr % configs, nVertLevels) + else if (config_init_case == 10) then + + call mpas_log_write(' les test case ') + block_ptr => domain % blocklist + do while (associated(block_ptr)) + + call mpas_pool_get_dimension(block_ptr % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) + + 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_log_write(' calling test case setup ') + call init_atm_case_les(domain % dminfo, mesh, nCells, nVertLevels, state, diag, config_init_case, block_ptr % configs) + call decouple_variables(mesh, nCells, nVertLevels, state, diag) + call mpas_log_write(' returned from test case setup ') block_ptr => block_ptr % next end do else call mpas_log_write(' ***********************************************************', messageType=MPAS_LOG_ERR) - call mpas_log_write(' Only test cases 1 through 9 and 13 are currently supported.', messageType=MPAS_LOG_ERR) + call mpas_log_write(' Only test cases 1 through 10 and 13 are currently supported.', messageType=MPAS_LOG_ERR) call mpas_log_write(' ***********************************************************', messageType=MPAS_LOG_CRIT) end if @@ -6184,6 +6201,564 @@ subroutine init_atm_case_lbc(timestamp, block, mesh, nCells, nEdges, nVertLevels end subroutine init_atm_case_lbc +!--------------------- + + subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, test_case, configs) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Large Eddy Simulation (les) test case setup + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + implicit none + + type (dm_info), intent(in) :: dminfo + type (mpas_pool_type), intent(inout) :: mesh + integer, intent(in) :: nCells + integer, intent(in) :: nVertLevels + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout):: configs + + integer, intent(in) :: test_case + + real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp + real (kind=RKIND), dimension(:,:), pointer :: zgrid, zxu, zz, hx, cqw + real (kind=RKIND), dimension(:,:), pointer :: ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, dss, t, rt, u, ru + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 + + !This is temporary variable here. It just need when calculate tangential velocity v. + integer :: eoe, j + integer, dimension(:), pointer :: nEdgesOnEdge + integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge + real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge + + integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, cell1, cell2 + integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve + integer, pointer :: index_qv + + real (kind=RKIND), dimension(nVertLevels + 1 ) :: znu, znw, znwc, znwv + real (kind=RKIND), dimension(nVertLevels + 1 ) :: znuc, znuv + + real (kind=RKIND), dimension(nVertLevels + 1 ) :: zc, zw, ah + real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm + + real (kind=RKIND), dimension(nVertLevels, nCells) :: relhum, thi, tbi, cqwb + + real (kind=RKIND) :: r, xnutr + real (kind=RKIND) :: ztemp, zd, zt, dz, str + + real (kind=RKIND), dimension(nVertLevels ) :: qvb + real (kind=RKIND), dimension(nVertLevels ) :: t_init_1d + + real (kind=RKIND) :: d1, d2, d3, cof1, cof2 + real (kind=RKIND), pointer :: cf1, cf2, cf3 + real (kind=RKIND) :: ztr, thetar, ttr, thetas, um, us, zts, pitop, pibtop, ptopb, ptop, rcp, rcv, p0 + real (kind=RKIND) :: radx, radz, zcent, xmid, delt, xloc, rad, yloc, ymid, a_scale + real (kind=RKIND) :: pres, temp, es, qvs + + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell, areaTriangle + real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + logical, pointer :: on_a_sphere + real (kind=RKIND), pointer :: sphere_radius + real (kind=RKIND), pointer :: config_ztop + + real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta + real (kind=RKIND), dimension(:), pointer :: u_init, qv_init, angleEdge, fEdge, fVertex + real (kind=RKIND) :: u_vel, v_vel, randx + + call mpas_pool_get_array(mesh, 'xCell', xCell) + call mpas_pool_get_array(mesh, 'yCell', yCell) + call mpas_pool_get_array(mesh, 'zCell', zCell) + call mpas_pool_get_array(mesh, 'xEdge', xEdge) + call mpas_pool_get_array(mesh, 'yEdge', yEdge) + call mpas_pool_get_array(mesh, 'zEdge', zEdge) + call mpas_pool_get_array(mesh, 'xVertex', xVertex) + call mpas_pool_get_array(mesh, 'yVertex', yVertex) + call mpas_pool_get_array(mesh, 'zVertex', zVertex) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + + call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) + call mpas_pool_get_config(configs, 'config_ztop', config_ztop) + + ! + ! Scale all distances + ! + + a_scale = 1.0 + + xCell(:) = xCell(:) * a_scale + yCell(:) = yCell(:) * a_scale + zCell(:) = zCell(:) * a_scale + xVertex(:) = xVertex(:) * a_scale + yVertex(:) = yVertex(:) * a_scale + zVertex(:) = zVertex(:) * a_scale + xEdge(:) = xEdge(:) * a_scale + yEdge(:) = yEdge(:) * a_scale + zEdge(:) = zEdge(:) * a_scale + dvEdge(:) = dvEdge(:) * a_scale + dcEdge(:) = dcEdge(:) * a_scale + areaCell(:) = areaCell(:) * a_scale**2.0 + areaTriangle(:) = areaTriangle(:) * a_scale**2.0 + kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 + + call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) + call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) + call mpas_pool_get_array(mesh, 'edgesOnEdge', edgesOnEdge) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'maxEdges', maxEdges) + nz1 = nVertLevels + nz = nz1 + 1 + + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'zb', zb) + call mpas_pool_get_array(mesh, 'zb3', zb3) + call mpas_pool_get_array(mesh, 'rdzw', rdzw) + call mpas_pool_get_array(mesh, 'dzu', dzu) + call mpas_pool_get_array(mesh, 'rdzu', rdzu) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + call mpas_pool_get_array(mesh, 'zxu', zxu) + call mpas_pool_get_array(mesh, 'zz', zz) + call mpas_pool_get_array(mesh, 'hx', hx) + call mpas_pool_get_array(mesh, 'dss', dss) + 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, 'qv_init', qv_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) + + call mpas_pool_get_array(mesh, 'cf1', cf1) + call mpas_pool_get_array(mesh, 'cf2', cf2) + call mpas_pool_get_array(mesh, 'cf3', cf3) + + call mpas_pool_get_array(diag, 'pressure_base', ppb) + call mpas_pool_get_array(diag, 'exner_base', pb) + call mpas_pool_get_array(diag, 'rho_base', rb) + call mpas_pool_get_array(diag, 'theta_base', tb) + call mpas_pool_get_array(diag, 'rtheta_base', rtb) + call mpas_pool_get_array(diag, 'exner', p) + call mpas_pool_get_array(diag, 'cqw', cqw) + + call mpas_pool_get_array(diag, 'pressure_p', pp) + call mpas_pool_get_array(diag, 'rho_p', rr) + call mpas_pool_get_array(diag, 'rtheta_p', rt) + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(diag, 'rw', rw) + call mpas_pool_get_array(diag, 'v', v) + call mpas_pool_get_array(diag, 'rho', rho) + call mpas_pool_get_array(diag, 'theta', theta) + + call mpas_pool_get_array(state, 'rho_zz', rho_zz) + call mpas_pool_get_array(state, 'theta_m', t) + call mpas_pool_get_array(state, 'u', u) + call mpas_pool_get_array(state, 'w', w) + call mpas_pool_get_array(state, 'scalars', scalars) + + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + + scalars(:,:,:) = 0. + + call atm_initialize_advection_rk(mesh, nCells, nEdges, maxEdges, on_a_sphere, sphere_radius ) + call atm_initialize_deformation_weights(mesh, nCells, on_a_sphere, sphere_radius) + + xnutr = 0. + zd = 12000. + + p0 = 1.e+05 + rcp = rgas/cp + rcv = rgas/(cp-rgas) + + call mpas_log_write(' point 1 in test case setup ') + +! We may pass in an hx(:,:) that has been precomputed elsewhere. +! For now it is independent of k + + do iCell=1,nCells + do k=1,nz + hx(k,iCell) = 0. ! les on a flat Cartesian plane + end do + end do + +! write(0,*) ' dz = ',dz + call mpas_log_write(' hx computation complete ') + + ! metrics for hybrid coordinate and vertical stretching + + str = 1.0 ! no stretching in les case: constant dz + ! zt = 20000. + zt = config_ztop + dz = zt/float(nz1) + + + do k=1,nz + + ! zw(k) = zt*(real(k-1)*dz/zt)**str + zw(k) = float(k-1)*dz + zc(k) = zw(k) +! +! ah(k) governs the transition between terrain-following +! and pureheight coordinates +! ah(k) = 0 is a terrain-following coordinate +! ah(k) = 1 is a height coordinate + +! ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6 + ah(k) = 1. +! call mpas_log_write(' k, zc, zw, ah = $i $r $r $r', intArgs=(/k/), realArgs=(/zc(k),zw(k),ah(k)/)) + end do + do k=1,nz1 + dzw (k) = zw(k+1)-zw(k) + rdzw(k) = 1./dzw(k) + zu(k ) = .5*(zw(k)+zw(k+1)) + end do + do k=2,nz1 + dzu (k) = .5*(dzw(k)+dzw(k-1)) + rdzu(k) = 1./dzu(k) + fzp (k) = .5* dzw(k )/dzu(k) + fzm (k) = .5* dzw(k-1)/dzu(k) + rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1))) + rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1))) + end do + +!********** how are we storing cf1, cf2 and cf3? + + COF1 = (2.*DZU(2)+DZU(3))/(DZU(2)+DZU(3))*DZW(1)/DZU(2) + COF2 = DZU(2) /(DZU(2)+DZU(3))*DZW(1)/DZU(3) + CF1 = FZP(2) + COF1 + CF2 = FZM(2) - COF1 - COF2 + CF3 = COF2 + + do iCell=1,nCells + do k=1,nz + zgrid(k,iCell) = ah(k)*(zc(k)*(1.-hx(k,iCell)/zt)+hx(k,iCell)) & + + (1.-ah(k)) * zc(k) + end do + do k=1,nz1 + zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell)) + end do + end do + + do i=1, nEdges + iCell1 = cellsOnEdge(1,i) + iCell2 = cellsOnEdge(2,i) + do k=1,nz1 + zxu (k,i) = 0.5 * (zgrid(k,iCell2)-zgrid(k,iCell1) + zgrid(k+1,iCell2)-zgrid(k+1,iCell1)) / dcEdge(i) + end do + end do + do i=1, nCells + do k=1,nz1 + ztemp = .5*(zgrid(k+1,i)+zgrid(k,i)) + dss(k,i) = 0. + ztemp = zgrid(k,i) + if(ztemp.gt.zd+.1) then + dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2 + end if + end do + end do + +! +! initialization +! + do i=1,nCells + do k=1,nz1 + + ztemp = .5*(zgrid(k,i)+zgrid(k+1,i)) + + ! if(ztemp .gt. ztr) then + ! t (k,i) = thetar*exp(9.8*(ztemp-ztr)/(1003.*ttr)) + ! relhum(k,i) = 0.25 + ! else + ! t (k,i) = 300.+43.*(ztemp/ztr)**1.25 + ! relhum(k,i) = (1.-0.75*(ztemp/ztr)**1.25) + ! if(t(k,i).lt.thetas) t(k,i) = thetas + ! end if + + t(k,i) = atm_get_sounding('theta',ztemp) + scalars(index_qv,k,i) = atm_get_sounding('qv',ztemp) + + tb(k,i) = t(k,i) + thi(k,i) = t(k,i) + tbi(k,i) = t(k,i) + cqw(k,i) = 1. + cqwb(k,i) = 1. + end do + end do + +! set the velocity field - we are on a plane here. + + do i=1, nEdges + cell1 = cellsOnEdge(1,i) + cell2 = cellsOnEdge(2,i) + if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then + do k=1,nz1 + ztemp = .25*( zgrid(k,cell1 )+zgrid(k+1,cell1 ) & + +zgrid(k,cell2)+zgrid(k+1,cell2)) + u_vel = atm_get_sounding('u',ztemp) + v_vel = atm_get_sounding('v',ztemp) + u(k,i) = cos(angleEdge(i))*u_vel - sin(angleEdge(i))*v_vel + if(i == 1 ) u_init(k) = u(k,i) + end do + end if + end do + + call mpas_dmpar_bcast_reals(dminfo, nz1, u_init) + +! +! for reference sounding +! + do itr=1,30 + + pitop = 1.-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1)) + pibtop = 1.-.5*dzw(1)*gravity*(1.+qvb(1))/(cp*tb(1,1)*zz(1,1)) + do k=2,nz1 + pitop = pitop-dzu(k)*gravity/(cp*cqw(k,1)*.5*(t(k,1)+t(k-1,1)) & + *.5*(zz(k,1)+zz(k-1,1))) + pibtop = pibtop-dzu(k)*gravity/(cp*cqwb(k,1)*.5*(tb(k,1)+tb(k-1,1)) & + *.5*(zz(k,1)+zz(k-1,1))) + + !call mpas_log_write('$i $r $r $r $r', intArgs=(/k/), realArgs=(/pitop,tb(k,1),dzu(k),tb(k,1)/)) + end do + pitop = pitop-.5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1)) + pibtop = pibtop-.5*dzw(nz1)*gravity*(1.+qvb(nz1))/(cp*tb(nz1,1)*zz(nz1,1)) + + call mpas_dmpar_bcast_real(dminfo, pitop) + call mpas_dmpar_bcast_real(dminfo, pibtop) + + ptopb = p0*pibtop**(1./rcp) + call mpas_log_write('ptopb = $r', realArgs=(/0.01_RKIND*ptopb/)) + + do i=1, nCells + pb(nz1,i) = pibtop+.5*dzw(nz1)*gravity*(1.+qvb(nz1))/(cp*tb(nz1,i)*zz(nz1,i)) + p (nz1,i) = pitop+.5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,i))/(cp*t (nz1,i)*zz(nz1,i)) + do k=nz1-1,1,-1 + pb(k,i) = pb(k+1,i) + dzu(k+1)*gravity/(cp*cqwb(k+1,i)*.5*(tb(k,i)+tb(k+1,i)) & + *.5*(zz(k,i)+zz(k+1,i))) + p (k,i) = p (k+1,i) + dzu(k+1)*gravity/(cp*cqw(k+1,i)*.5*(t (k,i)+t (k+1,i)) & + *.5*(zz(k,i)+zz(k+1,i))) + end do + do k=1,nz1 + rb (k,i) = pb(k,i)**(1./rcv)/((rgas/p0)*tb(k,i)*zz(k,i)) + rtb(k,i) = rb(k,i)*tb(k,i) + rr (k,i) = p (k,i)**(1./rcv)/((rgas/p0)*t (k,i)*zz(k,i))-rb(k,i) + ppb(k,i) = p0*(zz(k,i)*rgas*rtb(k,i)/p0)**(cp/cv) + end do + end do + + ! + ! update water vapor mixing ratio from humidity profile + ! + ! do i= 1,nCells + ! do k=1,nz1 + ! temp = p(k,i)*thi(k,i) + ! pres = p0*p(k,i)**(1./rcp) + ! qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres + ! scalars(index_qv,k,i) = min(0.014_RKIND,relhum(k,i)*qvs) + ! end do + ! end do + + do k=1,nz1 +!********************************************************************* +! QVB = QV INCLUDES MOISTURE IN REFERENCE STATE +! qvb(k) = scalars(index_qv,k,1) +! QVB = 0 PRODUCES DRY REFERENCE STATE + qvb(k) = 0. +!********************************************************************* + end do + + do i= 1,nCells + do k=1,nz1 + t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) + tb(k,i) = tbi(k,i)*(1.+1.61*qvb(k)) + end do + do k=2,nz1 + cqw (k,i) = 1./(1.+.5*(scalars(index_qv,k,i)+scalars(index_qv,k-1,i))) + cqwb(k,i) = 1./(1.+.5*(qvb(k)+qvb(k-1))) + end do + end do + + end do !end of iteration loop + + call mpas_log_write(' base state sounding ') + call mpas_log_write(' k, pb, rb, tb, rtb, t, rr, p, qvb') + do k=1,nVertLevels + call mpas_log_write('$i $r $r $r $r $r $r $r $r', intArgs=(/k/), realArgs=(/pb(k,1),rb(k,1),tb(k,1),rtb(k,1),t(k,1),rr(k,1),p(k,1),qvb(k)/)) + end do + +! +! potential temperature perturbation +! + + do i=1,nCells + do k = 1,4 ! same as in WRF + call random_number(randx) + thi(k,i) = thi(k,i) + 0.1*(randx-0.5) + t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) + end do + end do + + do itr=1,30 + + pitop = 1.-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1)) + do k=2,nz1 + pitop = pitop-dzu(k)*gravity/(cp*cqw(k,1)*.5*(t (k,1)+t (k-1,1)) & + *.5*(zz(k,1)+zz(k-1,1))) + end do + pitop = pitop - .5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1)) + ptop = p0*pitop**(1./rcp) + call mpas_log_write('ptop = $r $r', realArgs=(/0.01_RKIND*ptop, 0.01_RKIND*ptopb/)) + + call mpas_dmpar_bcast_real(dminfo, ptop) + + do i = 1, nCells + + pp(nz1,i) = ptop-ptopb+.5*dzw(nz1)*gravity* & + (rr(nz1,i)+(rr(nz1,i)+rb(nz1,i))*scalars(index_qv,nz1,i)) + do k=nz1-1,1,-1 +! pp(k,i) = pp(k+1,i)+.5*dzu(k+1)*gravity* & +! (rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i) & +! +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i)) + pp(k,i) = pp(k+1,i)+dzu(k+1)*gravity*( & + fzm(k+1)*(rb(k+1,i)*(scalars(index_qv,k+1,i)-qvb(k+1)) & + +rr(k+1,i)*(1.+scalars(index_qv,k+1,i))) & + +fzp(k+1)*(rb(k ,i)*(scalars(index_qv,k ,i)-qvb(k)) & + +rr(k ,i)*(1.+scalars(index_qv,k ,i)))) + end do + if (itr==1.and.i==1) then + do k=1,nz1 + call mpas_log_write('pp-check $r', realArgs=(/pp(k,i)/)) + end do + end if + do k=1,nz1 + rt(k,i) = (pp(k,i)/(rgas*zz(k,i)) & + -rtb(k,i)*(p(k,i)-pb(k,i)))/p(k,i) + p (k,i) = (zz(k,i)*(rgas/p0)*(rtb(k,i)+rt(k,i)))**rcv + rr(k,i) = (rt(k,i)-rb(k,i)*(t(k,i)-tb(k,i)))/t(k,i) + end do + + end do ! loop over cells + + end do ! iteration loop +!---------------------------------------------------------------------- +! + do k=1,nz1 + qv_init(k) = scalars(index_qv,k,1) + end do + + t_init_1d(:) = t(:,1) + call mpas_dmpar_bcast_reals(dminfo, nz1, t_init_1d) + call mpas_dmpar_bcast_reals(dminfo, nz1, qv_init) + + do i=1,nCells + do k=1,nz1 + t_init(k,i) = t_init_1d(k) + rho_zz(k,i) = rb(k,i)+rr(k,i) + end do + end do + + do i=1,nEdges + cell1 = cellsOnEdge(1,i) + cell2 = cellsOnEdge(2,i) + if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then + do k=1,nz1 + ru (k,i) = 0.5*(rho_zz(k,cell1)+rho_zz(k,cell2))*u(k,i) + end do + end if + end do + + + ! + ! we are assuming w and rw are zero for this initialization + ! i.e., no terrain + ! + rw = 0.0 + w = 0.0 + + zb = 0.0 + zb3 = 0.0 + + ! + ! Generate rotated Coriolis field - same settings as in WRF + ! + do iEdge=1,nEdges + fEdge(iEdge) = 1.e-04 + end do + + do iVtx=1,nVertices + fVertex(iVtx) = 1.e-04 + end do + + ! + ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells) + ! + v(:,:) = 0.0 + do iEdge = 1, nEdges + do i=1,nEdgesOnEdge(iEdge) + eoe = edgesOnEdge(i,iEdge) + if (eoe > 0) then + do k = 1, nVertLevels + v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe) + end do + end if + end do + end do + + ! call mpas_log_write(' k,u_init, t_init, qv_init ') + ! do k=1,nVertLevels + ! call mpas_log_write('$i $r $r $r', intArgs=(/k/), realArgs=(/u_init(k),t_init(k,1),qv_init(k)/)) + ! end do + + ! Compute rho and theta from rho_zz and theta_m + do iCell=1,nCells + do k=1,nVertLevels + rho(k,iCell) = rho_zz(k,iCell) * zz(k,iCell) + theta(k,iCell) = t(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell)) + end do + end do + + end subroutine init_atm_case_les + + + real (kind=RKIND) function atm_get_sounding( variable, height ) + + implicit none + real (kind=RKIND), intent(in) :: height + character(len=*), intent(in) :: variable + + atm_get_sounding = -999. + + if(variable == 'u') then + atm_get_sounding = 0. + else if (variable == 'v') then + atm_get_sounding = 0. + else if (variable == 'qv') then + atm_get_sounding = 0. + else if (variable == 'theta') then + + if(height .le. 1000.) then + atm_get_sounding = 300. + else if(height .le. 1150.) then + atm_get_sounding = 300. + (height-1000.)*8./150. + else + atm_get_sounding = 308. + (height-1150.)*3./1000. + end if + + end if + + end function atm_get_sounding + +!----------- !----------------------------------------------------------------------- ! routine init_atm_case_cam_mpas From c5eb44e4615ababeaace7e7407b741d474346f67 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 7 Jan 2020 16:13:08 -0700 Subject: [PATCH 015/109] add calcalate_n2 routine (no functional code yet) --- .../dynamics/mpas_atm_dissipation_models.F | 15 +++++++++++++ .../dynamics/mpas_atm_time_integration.F | 21 +++++++++++++------ 2 files changed, 30 insertions(+), 6 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index af983af979..9431a6295f 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -9,6 +9,7 @@ module mpas_atm_dissipation_models use mpas_kind_types, only : RKIND + use mpas_atmphys_constants contains @@ -74,6 +75,20 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, end subroutine smagorinsky_2d +!--------------------------------------- + + subroutine calculate_n2(bn2, theta, scalars, num_scalars, index_qv, cellStart, cellEnd, nCells) + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + + integer, intent(in) :: cellStart, cellEnd, nCells + integer, intent(in) :: index_qv + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: bn2 + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta + real (kind=RKIND), dimension(:,:,:) :: scalars + + end subroutine calculate_n2 + !--------------------------------------- subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 1ae2abb219..d083f25233 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4777,7 +4777,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:), pointer :: fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, & meshScalingDel2, meshScalingDel4 real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & - divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & + divergence, vorticity, ke, pv_edge, theta_m, theta, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save @@ -4832,6 +4832,10 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, logical, pointer :: config_rayleigh_damp_u real (kind=RKIND), pointer :: config_rayleigh_damp_u_timescale_days integer, pointer :: config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels + integer, pointer :: config_number_rayleigh_damp_u_levels + integer, pointer :: index_qv + + logical :: inactive_rthdynten call mpas_pool_get_config(mesh, 'sphere_radius', r_earth) @@ -4860,6 +4864,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(state, 'w', w, 2) call mpas_pool_get_array(state, 'theta_m', theta_m, 2) call mpas_pool_get_array(state, 'theta_m', theta_m_save, 1) + call mpas_pool_get_array(state, 'theta', theta, 2) call mpas_pool_get_array(state, 'scalars', scalars, 2) call mpas_pool_get_array(diag, 'uReconstructZonal', ur_cell) @@ -4954,6 +4959,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) call mpas_pool_get_dimension(state, 'moist_start', moist_start) call mpas_pool_get_dimension(state, 'moist_end', moist_end) + call mpas_pool_get_dimension(state, 'index_qv', index_qv) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) @@ -4966,10 +4972,10 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(mesh, 'cf3', cf3) call atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels, & - nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, moist_start, moist_end, & + nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, index_qv, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & - divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & + divergence, vorticity, ke, pv_edge, theta_m, theta, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & @@ -4992,10 +4998,10 @@ end subroutine atm_compute_dyn_tend subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dummy, & - nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, moist_start, moist_end, & + nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & - divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & + divergence, vorticity, ke, pv_edge, theta_m, theta, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & @@ -5025,7 +5031,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! Dummy arguments ! integer :: nCells, nEdges, nVertices, nVertLevels_dummy, nCellsSolve, nEdgesSolve, vertexDegree, & - maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, moist_start, moist_end + maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, moist_start, moist_end real (kind=RKIND), dimension(nEdges+1) :: fEdge real (kind=RKIND), dimension(nEdges+1) :: dvEdge @@ -5049,6 +5055,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: ke real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: pv_edge real (kind=RKIND), dimension(nVertLevels,nCells+1) :: theta_m + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: theta real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_rho real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rt_diabatic_tend @@ -5065,6 +5072,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: cqu real (kind=RKIND), dimension(nVertLevels,nCells+1) :: h_divergence real (kind=RKIND), dimension(nVertLevels,nCells+1) :: kdiff + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: bn2 real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign real (kind=RKIND), dimension(vertexDegree,nVertices+1) :: edgesOnVertex_sign real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw_save @@ -5274,6 +5282,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if (config_les_model == "3d_smagorinsky") then ! call to 3D smagorinsky here... + call calculate_n2(bn2, theta, scalars, num_scalars, index_qv, cellStart, cellEnd, nCells) end if From b18f3e2e29f9a753d2f5cc3abc18d83ac2c0493b Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 8 Jan 2020 14:00:15 -0700 Subject: [PATCH 016/109] add to arg list of calculate_n2 --- .../dynamics/mpas_atm_dissipation_models.F | 17 +++++++++++++---- .../dynamics/mpas_atm_time_integration.F | 3 ++- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 9431a6295f..8d82678441 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -77,16 +77,25 @@ end subroutine smagorinsky_2d !--------------------------------------- - subroutine calculate_n2(bn2, theta, scalars, num_scalars, index_qv, cellStart, cellEnd, nCells) + subroutine calculate_n2( bn2, theta, exner, pressure_b, pp, zgrid, scalars, index_qv, & + cellStart, cellEnd, nCells) - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + use mpas_atm_dimensions ! pull nVertLevels and num_scalars from here integer, intent(in) :: cellStart, cellEnd, nCells integer, intent(in) :: index_qv real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: bn2 - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta - real (kind=RKIND), dimension(:,:,:) :: scalars + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta, exner, pressure_b, pp + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars + do iCell = cellStart,cellEnd +!DIR$ IVDEP + do k=1, nVertLevels + ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 + bn2(k,iCell) = 0. + end do + end do end subroutine calculate_n2 !--------------------------------------- diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index d083f25233..0f62fc2aa1 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5282,7 +5282,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if (config_les_model == "3d_smagorinsky") then ! call to 3D smagorinsky here... - call calculate_n2(bn2, theta, scalars, num_scalars, index_qv, cellStart, cellEnd, nCells) + call calculate_n2( bn2, theta, exner, pressure_b, pp, zgrid, scalars, index_qv, & + cellStart, cellEnd, nCells) end if From a6336368bde6fb76e1be44babe129346a5c1c39c Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 16 Jan 2020 10:54:29 -0700 Subject: [PATCH 017/109] add dry N^2 --- .../dynamics/mpas_atm_dissipation_models.F | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 8d82678441..43b89248b6 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -88,13 +88,19 @@ subroutine calculate_n2( bn2, theta, exner, pressure_b, pp, zgrid, scalars, inde real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta, exner, pressure_b, pp real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars +! local + real (kind=RKIND) :: dz + do iCell = cellStart,cellEnd !DIR$ IVDEP - do k=1, nVertLevels + do k=2, nVertLevels-1 ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 - bn2(k,iCell) = 0. + dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) + bn2(k,iCell) = gravity * (theta(k+1,iCell) - theta(k-1,iCell) ) / theta(k,iCell) / dz end do + bn2(1,iCell) = bn2(2,iCell) + bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) end do end subroutine calculate_n2 From d42a459d967d230e4a999a1c3a29c31e1dec5cf4 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 17 Jan 2020 11:31:38 -0700 Subject: [PATCH 018/109] fix theta to be in diag pool --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 2 +- 1 file changed, 1 insertion(+), 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 0f62fc2aa1..f8c0ee7d4b 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4864,9 +4864,9 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(state, 'w', w, 2) call mpas_pool_get_array(state, 'theta_m', theta_m, 2) call mpas_pool_get_array(state, 'theta_m', theta_m_save, 1) - call mpas_pool_get_array(state, 'theta', theta, 2) call mpas_pool_get_array(state, 'scalars', scalars, 2) + call mpas_pool_get_array(diag, 'theta', theta) call mpas_pool_get_array(diag, 'uReconstructZonal', ur_cell) call mpas_pool_get_array(diag, 'uReconstructMeridional', vr_cell) call mpas_pool_get_array(diag, 'rho_edge', rho_edge) From f0fc10df7424091c79d53ba52bf454bf1a83fbf0 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 17 Jan 2020 15:52:59 -0700 Subject: [PATCH 019/109] fix to use theta_m and qv instead of non-updated theta --- .../dynamics/mpas_atm_dissipation_models.F | 11 +++++++---- .../dynamics/mpas_atm_time_integration.F | 10 ++++------ 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 43b89248b6..df7df75521 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -77,7 +77,7 @@ end subroutine smagorinsky_2d !--------------------------------------- - subroutine calculate_n2( bn2, theta, exner, pressure_b, pp, zgrid, scalars, index_qv, & + subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, & cellStart, cellEnd, nCells) use mpas_atm_dimensions ! pull nVertLevels and num_scalars from here @@ -85,19 +85,22 @@ subroutine calculate_n2( bn2, theta, exner, pressure_b, pp, zgrid, scalars, inde integer, intent(in) :: cellStart, cellEnd, nCells integer, intent(in) :: index_qv real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: bn2 - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta, exner, pressure_b, pp + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m, exner, pressure_b, pp real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local - real (kind=RKIND) :: dz + real (kind=RKIND) :: dz, theta do iCell = cellStart,cellEnd !DIR$ IVDEP do k=2, nVertLevels-1 ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 + theta = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) + thetap = theta_m(k+1,iCell) / (1._RKIND + rvord * scalars(index_qv,k+1,iCell)) + thetam = theta_m(k-1,iCell) / (1._RKIND + rvord * scalars(index_qv,k-1,iCell)) dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) - bn2(k,iCell) = gravity * (theta(k+1,iCell) - theta(k-1,iCell) ) / theta(k,iCell) / dz + bn2(k,iCell) = gravity * (thetap - thetam ) / theta / dz end do bn2(1,iCell) = bn2(2,iCell) bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index f8c0ee7d4b..00f935e311 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4777,7 +4777,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:), pointer :: fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, & meshScalingDel2, meshScalingDel4 real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & - divergence, vorticity, ke, pv_edge, theta_m, theta, rw, tend_rho, & + divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save @@ -4866,7 +4866,6 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(state, 'theta_m', theta_m_save, 1) call mpas_pool_get_array(state, 'scalars', scalars, 2) - call mpas_pool_get_array(diag, 'theta', theta) call mpas_pool_get_array(diag, 'uReconstructZonal', ur_cell) call mpas_pool_get_array(diag, 'uReconstructMeridional', vr_cell) call mpas_pool_get_array(diag, 'rho_edge', rho_edge) @@ -4975,7 +4974,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, index_qv, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & - divergence, vorticity, ke, pv_edge, theta_m, theta, rw, tend_rho, & + divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & @@ -5001,7 +5000,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & - divergence, vorticity, ke, pv_edge, theta_m, theta, rw, tend_rho, & + divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & @@ -5055,7 +5054,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: ke real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: pv_edge real (kind=RKIND), dimension(nVertLevels,nCells+1) :: theta_m - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: theta real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_rho real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rt_diabatic_tend @@ -5282,7 +5280,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if (config_les_model == "3d_smagorinsky") then ! call to 3D smagorinsky here... - call calculate_n2( bn2, theta, exner, pressure_b, pp, zgrid, scalars, index_qv, & + call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, & cellStart, cellEnd, nCells) end if From 116368b7943c13ad4f3debf55dde5ec7c7329b3d Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 17 Jan 2020 16:15:04 -0700 Subject: [PATCH 020/109] use local 1d theta array for efficiency --- .../dynamics/mpas_atm_dissipation_models.F | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index df7df75521..987611a584 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -89,22 +89,24 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local - real (kind=RKIND) :: dz, theta + real (kind=RKIND) :: dz + real (kind=RKIND), dimension(nVertLevels) :: theta do iCell = cellStart,cellEnd !DIR$ IVDEP + do k=1, nVertLevels + theta(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) + end do do k=2, nVertLevels-1 ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 - theta = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) - thetap = theta_m(k+1,iCell) / (1._RKIND + rvord * scalars(index_qv,k+1,iCell)) - thetam = theta_m(k-1,iCell) / (1._RKIND + rvord * scalars(index_qv,k-1,iCell)) dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) - bn2(k,iCell) = gravity * (thetap - thetam ) / theta / dz + bn2(k,iCell) = gravity * (theta(k+1) - theta(k-1) ) / theta(k) / dz end do bn2(1,iCell) = bn2(2,iCell) bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) end do + end subroutine calculate_n2 !--------------------------------------- From b673e28325a2f024dc7207d6a74fd05aecf4df97 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 24 Jan 2020 11:16:18 -0700 Subject: [PATCH 021/109] add qtot drag term to thetav in dry case --- .../dynamics/mpas_atm_dissipation_models.F | 12 +++++++----- .../dynamics/mpas_atm_time_integration.F | 2 +- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 987611a584..db0492e262 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -77,7 +77,7 @@ end subroutine smagorinsky_2d !--------------------------------------- - subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, & + subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, qtot, & cellStart, cellEnd, nCells) use mpas_atm_dimensions ! pull nVertLevels and num_scalars from here @@ -85,23 +85,25 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in integer, intent(in) :: cellStart, cellEnd, nCells integer, intent(in) :: index_qv real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: bn2 - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m, exner, pressure_b, pp + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m, exner, pressure_b, pp, qtot real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local real (kind=RKIND) :: dz - real (kind=RKIND), dimension(nVertLevels) :: theta + real (kind=RKIND), dimension(nVertLevels) :: thetav do iCell = cellStart,cellEnd !DIR$ IVDEP do k=1, nVertLevels - theta(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) +! qtot is qv plus all species - thetav includes moist loading (rvord-1 gives 0.61 * qv) + thetav(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) & + * (1._RKIND + rvord * scalars(index_qv,k,iCell) - qtot(k, iCell)) end do do k=2, nVertLevels-1 ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) - bn2(k,iCell) = gravity * (theta(k+1) - theta(k-1) ) / theta(k) / dz + bn2(k,iCell) = gravity * (thetav(k+1) - thetav(k-1) ) / thetav(k) / dz end do bn2(1,iCell) = bn2(2,iCell) bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 00f935e311..2c6a1f4a57 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5280,7 +5280,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if (config_les_model == "3d_smagorinsky") then ! call to 3D smagorinsky here... - call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, & + call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, qtot, & cellStart, cellEnd, nCells) end if From a9d7bfa108cf1468350658671ac16d5f5220dd9f Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Mon, 27 Jan 2020 15:07:00 -0700 Subject: [PATCH 022/109] add cloudy conditions N2 calculation following WRF and Durran and Klemp (1982) --- .../dynamics/mpas_atm_dissipation_models.F | 40 ++++++++++++++----- .../dynamics/mpas_atm_time_integration.F | 11 ++--- 2 files changed, 37 insertions(+), 14 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index db0492e262..6605e0bad4 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -77,36 +77,58 @@ end subroutine smagorinsky_2d !--------------------------------------- - subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, qtot, & + subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) use mpas_atm_dimensions ! pull nVertLevels and num_scalars from here integer, intent(in) :: cellStart, cellEnd, nCells - integer, intent(in) :: index_qv + integer, intent(in) :: index_qv, index_qc real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: bn2 real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m, exner, pressure_b, pp, qtot real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local - real (kind=RKIND) :: dz - real (kind=RKIND), dimension(nVertLevels) :: thetav - + real (kind=RKIND) :: dz, esw, qc_cr + real (kind=RKIND), dimension(nVertLevels) :: theta, thetav, qvsw, temp, coefa + qc_cr = 0.00001 ! in kg/kg + do iCell = cellStart,cellEnd !DIR$ IVDEP do k=1, nVertLevels ! qtot is qv plus all species - thetav includes moist loading (rvord-1 gives 0.61 * qv) - thetav(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) & - * (1._RKIND + rvord * scalars(index_qv,k,iCell) - qtot(k, iCell)) + theta(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) + thetav(k) = theta(k) * (1._RKIND + rvord * scalars(index_qv,k,iCell) - qtot(k, iCell)) + + temp(k) = exner(k,iCell) * theta(k) + + p = pressure_b(k,iCell) + pp(k,iCell) + esw = 1000. * svp1 * exp(svp2 * (temp(k) - svpt0) / (temp(k) - svp3)) + if (p < esw) esw = p * 0.99 ! fix for pressure < esw + qvsw(k) = ep_2 * esw / (p - esw) + + coefa(k) = ( 1.0 + xlv * qvsw(k)/ R_d / temp(k) ) / & + ( 1.0 + xlv * xlv *qvsw(k) / Cp / R_v / temp(k) / temp(k) ) + end do + do k=2, nVertLevels-1 - ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) - bn2(k,iCell) = gravity * (thetav(k+1) - thetav(k-1) ) / thetav(k) / dz + + if ( scalars(index_qc,k,iCell) < qc_cr ) then + ! Dry Brunt-Vaisala frequency + bn2(k,iCell) = gravity * (thetav(k+1) - thetav(k-1) ) / thetav(k) / dz + else + ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 + bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & + + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) / dz ) & + - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) + endif end do bn2(1,iCell) = bn2(2,iCell) bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) + end do end subroutine calculate_n2 diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 2c6a1f4a57..fc875548f5 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4833,7 +4833,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), pointer :: config_rayleigh_damp_u_timescale_days integer, pointer :: config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels integer, pointer :: config_number_rayleigh_damp_u_levels - integer, pointer :: index_qv + integer, pointer :: index_qv, index_qc logical :: inactive_rthdynten @@ -4959,6 +4959,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_dimension(state, 'moist_start', moist_start) call mpas_pool_get_dimension(state, 'moist_end', moist_end) call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_dimension(state, 'index_qc', index_qc) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) @@ -4971,7 +4972,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(mesh, 'cf3', cf3) call atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels, & - nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, index_qv, moist_start, moist_end, & + nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, index_qv, index_qc, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & @@ -4997,7 +4998,7 @@ end subroutine atm_compute_dyn_tend subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dummy, & - nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, moist_start, moist_end, & + nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, index_qc, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & @@ -5030,7 +5031,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! Dummy arguments ! integer :: nCells, nEdges, nVertices, nVertLevels_dummy, nCellsSolve, nEdgesSolve, vertexDegree, & - maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, moist_start, moist_end + maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, index_qc, moist_start, moist_end real (kind=RKIND), dimension(nEdges+1) :: fEdge real (kind=RKIND), dimension(nEdges+1) :: dvEdge @@ -5280,7 +5281,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if (config_les_model == "3d_smagorinsky") then ! call to 3D smagorinsky here... - call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, qtot, & + call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) end if From f12589da0f1c779fcf61f34c05a5e3d3db16ed3a Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 30 Jan 2020 09:43:20 -0700 Subject: [PATCH 023/109] remove thetav use --- .../dynamics/mpas_atm_dissipation_models.F | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 6605e0bad4..c53904413d 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -90,16 +90,15 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local real (kind=RKIND) :: dz, esw, qc_cr - real (kind=RKIND), dimension(nVertLevels) :: theta, thetav, qvsw, temp, coefa + real (kind=RKIND), dimension(nVertLevels) :: theta, qvsw, temp, coefa qc_cr = 0.00001 ! in kg/kg do iCell = cellStart,cellEnd !DIR$ IVDEP do k=1, nVertLevels -! qtot is qv plus all species - thetav includes moist loading (rvord-1 gives 0.61 * qv) + theta(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) - thetav(k) = theta(k) * (1._RKIND + rvord * scalars(index_qv,k,iCell) - qtot(k, iCell)) temp(k) = exner(k,iCell) * theta(k) @@ -118,7 +117,9 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in if ( scalars(index_qc,k,iCell) < qc_cr ) then ! Dry Brunt-Vaisala frequency - bn2(k,iCell) = gravity * (thetav(k+1) - thetav(k-1) ) / thetav(k) / dz + bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & + + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) / dz & + - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) else ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & From 7abd792ab4aa31c702637e94cd40feba4cba876d Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 14:09:06 -0700 Subject: [PATCH 024/109] add bn2 to output and commented out test call --- src/core_atmosphere/Registry.xml | 6 ++++++ .../dynamics/mpas_atm_time_integration.F | 12 +++++++++--- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 94e6b43f22..23788430c1 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1959,6 +1959,12 @@ + + + + diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index fc875548f5..5b5edebf62 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4779,7 +4779,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save + h_divergence, kdiff, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save real (kind=RKIND), dimension(:,:), pointer :: theta_m_save @@ -4874,6 +4874,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(diag, 'rho_p_save', rr_save) call mpas_pool_get_array(diag, 'v', v) call mpas_pool_get_array(diag, 'kdiff', kdiff) + call mpas_pool_get_array(diag, 'bn2', bn2) call mpas_pool_get_array(diag, 'ru', ru) call mpas_pool_get_array(diag, 'ru_save', ru_save) call mpas_pool_get_array(diag, 'rw', rw) @@ -4977,7 +4978,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + h_divergence, kdiff, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & @@ -5003,7 +5004,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + h_divergence, kdiff, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & @@ -5263,6 +5264,11 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if(config_horiz_mixing == "2d_fixed") then +! testing +! call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & +! cellStart, cellEnd, nCells) +! testing + !$acc parallel default(present) !$acc loop gang worker do iCell = cellStart, cellEnd From a6faf86febfc6dbde29dcce876e2ea8c328db3c8 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Fri, 6 Mar 2020 08:46:26 -0700 Subject: [PATCH 025/109] added a 3D vertical eddy viscosity to the Registry for use in LES appliations. added a new 3D Smagorinsky eddy viscosity computation and vertical mixing for the dynamics variables. All code compiles but not tested. --- src/core_atmosphere/Registry.xml | 3 + .../dynamics/mpas_atm_dissipation_models.F | 932 ++++++++++++++++-- 2 files changed, 838 insertions(+), 97 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 23788430c1..ad6a27b4f3 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1959,6 +1959,9 @@ + + diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index c53904413d..37a9d3aabf 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -10,6 +10,7 @@ module mpas_atm_dissipation_models use mpas_kind_types, only : RKIND use mpas_atmphys_constants + use mpas_constants contains @@ -75,6 +76,131 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, end subroutine smagorinsky_2d +!--------------------------------------- + + subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, & + w, c_s, bv_freq2, zgrid, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + deformation_coef_c, deformation_coef_s, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & + nCells, nEdges, nVertLevels, maxEdges ) + + implicit none + + integer, intent(in) :: cellStart, cellEnd, nCells, nEdges, nVertLevels, maxEdges + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: v + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: uCell + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: vCell + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: bv_freq2 + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_c2 + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_s2 + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_cs + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_c + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_s + real (kind=RKIND), intent(in) :: c_s, config_len_disp, invDt, config_visc4_2dsmag + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: eddy_visc_horz, eddy_visc_vert + real (kind=RKIND), intent(in) :: h_mom_eddy_visc4, h_theta_eddy_visc4 + + ! local variables + + integer :: iCell, iEdge, k, ie, cell1, cell2 + real (kind=RKIND), dimension(nVertLevels) :: d_11, d_22, d_33, d_12, d_13, d_23 + real (kind=RKIND), dimension(nVertLevels) :: dudx, dudy, dvdx, dvdy + real (kind=RKIND), dimension(nVertLevels+1) :: dwdx, dwdy + real (kind=RKIND), dimension(nVertLevels) :: dudz, dvdz, dwdz + real (kind=RKIND) :: rdz, def2, pr_inv, wk + + pr_inv = 1./prandtl + + do iCell = cellStart,cellEnd + + dudx(1:nVertLevels) = 0.0 + dudy(1:nVertLevels) = 0.0 + dvdx(1:nVertLevels) = 0.0 + dvdy(1:nVertLevels) = 0.0 + dwdx(1:nVertLevels+1) = 0.0 + dwdy(1:nVertLevels+1) = 0.0 + + dudz(1:nVertLevels) = 0.0 + dvdz(1:nVertLevels) = 0.0 + dwdz(1:nVertLevels) = 0.0 + + do iEdge=1,nEdgesOnCell(iCell) + + ie = EdgesOnCell(iEdge,iCell) + cell1 = edgesOnCell(1,ie) + cell2 = edgesOnCell(2,ie) + + do k=1,nVertLevels + dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,ie) & + - deformation_coef_cs(iEdge,iCell)*v(k,ie) + dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,ie) & + - deformation_coef_s2(iEdge,iCell)*v(k,ie) + dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,ie) & + + deformation_coef_c2(iEdge,iCell)*v(k,ie) + dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,ie) & + + deformation_coef_cs(iEdge,iCell)*v(k,ie) + end do + + do k=1,nVertLevels+1 + wk = 0.5*(w(k,cell1)+w(k,cell2)) + dwdx(k) = dwdx(k) + deformation_coef_c(iEdge,iCell)*wk + dwdy(k) = dwdy(k) + deformation_coef_s(iEdge,iCell)*wk + end do + + end do + + do k=1,nVertLevels + rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) + dwdz(k) = (w(k+1,iCell)-w(k,iCell))*rdz + end do + + do k=2,nVertLevels-1 + rdz = 2./(zgrid(k+2,iCell)+zgrid(k+1,iCell)-zgrid(k,iCell)-zgrid(k-1,iCell)) + dudz(k) = (u(k+1,iCell)-u(k-1,iCell))*rdz + dvdz(k) = (v(k+1,iCell)-v(k-1,iCell))*rdz + end do + + k = 1 + rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) + dudz(k) = (u(k+1,iCell)-u(k,iCell))*rdz + dvdz(k) = (v(k+1,iCell)-v(k,iCell))*rdz + + k = nVertLevels-1 + rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) + dudz(k+1) = (u(k+1,iCell)-u(k,iCell))*rdz + dvdz(k+1) = (v(k+1,iCell)-v(k,iCell))*rdz + + do k=1, nVertLevels + ! here is the 3D Smagorinsky formulation, + ! followed by imposition of an upper bound on the eddy viscosity + d_11(k) = 2*dudx(k) + d_22(k) = 2*dvdy(k) + d_33(k) = 2*dwdz(k) + d_12(k) = dudy(k) + dvdx(k) + d_13(k) = dwdx(k) + dudz(k) + d_23(k) = dwdy(k) + dvdz(k) + + def2 = 0.5*(d_11(k)**2 + d_22(k)**2 + d_33(k)**2) + d_12(k)**2 + d_13(k)**2 + d_23(k)**2 + + eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * max(0.,def2 - pr_inv*bv_freq2(k,iCell)) + eddy_visc_horz(k,iCell) = min(eddy_visc_horz(k,iCell),(0.01*config_len_disp**2) * invDt) + eddy_visc_vert(k,iCell) = eddy_visc_horz(k,iCell) + + end do + + end do ! loop over all owned cells (columns) + + end subroutine smagorinsky_3d + !--------------------------------------- subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & @@ -361,165 +487,587 @@ end subroutine u_dissipation !------------------------ - subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - rdzw, rdzu, & - v_mom_eddy_visc2, h_mom_eddy_visc4, & - delsq_w, & - w, rho_edge, kdiff, rho_zz, & - tend_w_euler ) - + subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & + cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & + nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & + invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & + angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & + config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & + config_del4u_div_factor, zgrid, & + eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & + fzm, fzp, config_les_model, & + delsq_u, delsq_vorticity, delsq_divergence, & + u, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here implicit none + integer, intent(in) :: edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: vertexStart, vertexEnd, vertexDegree integer, intent(in) :: cellStart, cellEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd - integer, intent(in) :: nCells, nEdges + integer, intent(in) :: nCells, nEdges, nVertices + logical, intent(in) :: config_mix_full - integer, dimension(nCells+1), intent(in) :: nEdgesOnCell - integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + character (len=StrKIND) :: config_les_model integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + integer, dimension(2,nEdges+1), intent(in) :: verticesOnEdge + integer, dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(vertexDegree,nVertices+1), intent(in) :: edgesOnVertex real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 + real (kind=RKIND), intent(in) :: config_del4u_div_factor real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(vertexDegree,nVertices+1), intent(in) :: edgesOnVertex_sign + real (kind=RKIND), dimension(nVertices+1), intent(in) :: invAreaTriangle real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell - real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: angleEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid - real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: divergence + real (kind=RKIND), dimension(nVertLevels,nVertices+1), intent(in) :: vorticity real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_horz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw + real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzm + real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzp - real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: tend_w_euler - ! storage passed in from calling routine - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_w + ! scratch space from calling routine + real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: delsq_u + real (kind=RKIND), dimension(nVertLevels,nVertices+1) :: delsq_vorticity + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_divergence - ! local variables + real (kind=RKIND), dimension(nVertLevels), intent(in) :: u_init, v_init - integer :: cell1, cell2, iEdge, iCell, i, k - real (kind=RKIND) :: r_areaCell, edge_sign, w_turb_flux + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(out) :: tend_u_euler -! !OMP BARRIER why is this openmp barrier here??? + ! local variables - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). - ! - ! First, storage to hold the result from the first del^2 computation. - ! we copied code from the theta mixing, hence the theta* names. + integer :: iEdge, cell1, cell2, vertex1, vertex2, iVertex, iCell, i, k + real (kind=RKIND) :: r_dc, r_dv, u_diffusion, kdiffu, r, edge_sign, u_mix_scale + real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp + real (kind=RKIND), dimension(nVertLevels) :: u_mix + real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux + real (kind=RKIND) :: rho_k_cell1, rho_k_cell2, rho_k_at_w + real (kind=RKIND) :: zz_cell1, zz_cell2, zz_at_w - delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 +!$OMP BARRIER - do iCell=cellStart,cellEnd - tend_w_euler(1:nVertLevels+1,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). + ! First, storage to hold the result from the first del^2 computation. - edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + do iEdge=edgeStart,edgeEnd + 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)) !DIR$ IVDEP - do k=2,nVertLevels + do k=1,nVertLevels + + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant + u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & + -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv + + delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion + + kdiffu = 0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) + + ! include 2nd-orer diffusion here + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & + + rho_edge(k,iEdge)* kdiffu * u_diffusion * meshScalingDel2(iEdge) - w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) - delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux - w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & - (kdiff(k,cell1)+kdiff(k,cell2)+kdiff(k-1,cell1)+kdiff(k-1,cell2)) - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux - end do end do end do + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + !$OMP BARRIER - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + do iVertex=vertexStart,vertexEnd + delsq_vorticity(1:nVertLevels,iVertex) = 0.0 + do i=1,vertexDegree + iEdge = edgesOnVertex(i,iVertex) + edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) + do k=1,nVertLevels + delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) + end do + end do + end do - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) + do iCell=cellStart,cellEnd + delsq_divergence(1:nVertLevels,iCell) = 0.0 + r = invAreaCell(iCell) do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) - - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) + edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) + do k=1,nVertLevels + delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) end do - end do end do - end if ! 4th order mixing is active +!$OMP BARRIER - if ( v_mom_eddy_visc2 > 0.0 ) then ! vertical mixing + do iEdge=edgeSolveStart,edgeSolveEnd + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + vertex1 = verticesOnEdge(1,iEdge) + vertex2 = verticesOnEdge(2,iEdge) + + u_mix_scale = meshScalingDel4(iEdge)*h_mom_eddy_visc4 + r_dc = u_mix_scale * config_del4u_div_factor * invDcEdge(iEdge) + r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) - do iCell=cellSolveStart,cellSolveEnd !DIR$ IVDEP - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & - (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & - -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k) + do k=1,nVertLevels + + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant + ! + ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor + ! relative to the rotational part. The stability constraint on the divergence component is much less + ! stringent than the rotational part, and this flexibility may be useful. + ! + u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & + -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion + + end do end do - end do - end if + end if ! 4th order mixing is active - end subroutine w_dissipation + ! + ! vertical mixing for u - 2nd order filter in physical (z) space + ! + if ( v_mom_eddy_visc2 > 0.0 ) then -!----------------------------------------------------- + if (config_mix_full) then ! mix full state - subroutine theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - delsq_theta, & - theta_m, rho_edge, kdiff, rho_zz, & - tend_theta_euler ) + do iEdge=edgeSolveStart,edgeSolveEnd + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here - implicit none + do k=2,nVertLevels-1 - integer, intent(in) :: cellStart, cellEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd - integer, intent(in) :: nCells, nEdges + z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) + z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) + z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) + z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) - logical, intent(in) :: config_mix_full + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) - integer, dimension(nCells+1), intent(in) :: nEdgesOnCell - integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & + (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) & + -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do - integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + else ! idealized cases where we mix on the perturbation from the initial 1-D state - real (kind=RKIND), intent(in) :: h_theta_eddy_visc4 - real (kind=RKIND), intent(in) :: v_theta_eddy_visc2 - real (kind=RKIND), intent(in) :: prandtl_inv + do iEdge=edgeSolveStart,edgeSolveEnd - real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign - real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell - real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + 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 + + z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) + z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) + z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) + z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & + (u_mix(k+1)-u_mix(k ))/(zp-z0) & + -(u_mix(k )-u_mix(k-1))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + end if ! mix perturbation state + + end if ! vertical mixing of horizontal momentum for fixe viscosity + + if ( config_les_model == "3d_smagorinsky") then + + do iEdge=edgeSolveStart,edgeSolveEnd + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain + turb_vflux(1) = 0. ! lower bc flux handled where ??? + + do k=2,nVertLevels + rho_k_cell1 = fzm(k)*rho_zz(k ,cell1)*zz(k ,cell1)*eddy_visc_vert(k ,cell1) & + +fzp(k)*rho_zz(k-1,cell1)*zz(k-1,cell1)*eddy_visc_vert(k-1,cell1) + rho_k_cell2 = fzm(k)*rho_zz(k ,cell2)*zz(k ,cell2)*eddy_visc_vert(k ,cell2) & + +fzp(k)*rho_zz(k-1,cell2)*zz(k-1,cell2)*eddy_visc_vert(k-1,cell2) + rho_k_at_w = 0.5*(rho_k_cell1+rho_k_cell2) + + zz_cell1 = fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) + zz_cell2 = fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) + zz_at_w = 0.5*(zz_cell1+zz_cell2) + turb_vflux(k) = rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) + end do + + do k=1,nVertLevels + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + end do + + end do + + end if + + + end subroutine u_dissipation_3d + +!------------------------ + + subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, kdiff, rho_zz, & + tend_w_euler ) + + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + + implicit none + + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, intent(in) :: nCells, nEdges + + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 + real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: tend_w_euler + + ! storage passed in from calling routine + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_w + + ! local variables + + integer :: cell1, cell2, iEdge, iCell, i, k + real (kind=RKIND) :: r_areaCell, edge_sign, w_turb_flux + +! !OMP BARRIER why is this openmp barrier here??? + + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). + ! + ! First, storage to hold the result from the first del^2 computation. + ! we copied code from the theta mixing, hence the theta* names. + + + delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + tend_w_euler(1:nVertLevels+1,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + + edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + +!DIR$ IVDEP + do k=2,nVertLevels + + w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) + delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux + w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & + (kdiff(k,cell1)+kdiff(k,cell2)+kdiff(k-1,cell1)+kdiff(k-1,cell2)) + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux + end do + end do + end do + +!$OMP BARRIER + + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) + + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) + end do + + end do + end do + + end if ! 4th order mixing is active + + if ( v_mom_eddy_visc2 > 0.0 ) then ! vertical mixing + + do iCell=cellSolveStart,cellSolveEnd +!DIR$ IVDEP + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & + (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & + -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k) + end do + end do + + end if + + end subroutine w_dissipation + +!------------------------ + + subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + config_les_model, & + tend_w_euler ) + + + ! 3D w dissipation using the 3D smagorinsky eddy viscosities. + ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + + implicit none + + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, intent(in) :: nCells, nEdges + + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + character (len=StrKIND) :: config_les_model + + real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 + real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_horz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: tend_w_euler + + ! storage passed in from calling routine + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_w + real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux + + ! local variables + + integer :: cell1, cell2, iEdge, iCell, i, k + real (kind=RKIND) :: r_areaCell, edge_sign, w_turb_flux + +! !OMP BARRIER why is this openmp barrier here??? + + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). + ! + ! First, storage to hold the result from the first del^2 computation. + ! we copied code from the theta mixing, hence the theta* names. + + + delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + tend_w_euler(1:nVertLevels+1,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + + edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + +!DIR$ IVDEP + do k=2,nVertLevels + + w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) + delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux + w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & + ( eddy_visc_horz(k ,cell1)+eddy_visc_horz(k ,cell2) & + +eddy_visc_horz(k-1,cell1)+eddy_visc_horz(k-1,cell2) ) + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux + end do + end do + end do + +!$OMP BARRIER + + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) + + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) + end do + + end do + end do + + end if ! 4th order mixing is active + + if ( v_mom_eddy_visc2 > 0.0 ) then ! vertical mixing + + do iCell=cellSolveStart,cellSolveEnd +!DIR$ IVDEP + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & + (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & + -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k) + end do + end do + + end if + + if ( config_les_model == "3d_smagorinsky") then + + do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column + ! compute turbulent fluxes + do k=1,nVertLevels + turb_vflux(k) = rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*zz(k,iCell) & + *rdzu(k)*(w(k+1,iCell)-w(k,iCell)) + end do + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & + + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + end do + end do + + end if + + end subroutine w_dissipation_3d + +!----------------------------------------------------- + + subroutine theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, kdiff, rho_zz, & + tend_theta_euler ) + + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + implicit none + + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, intent(in) :: nCells, nEdges + + logical, intent(in) :: config_mix_full + + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + real (kind=RKIND), intent(in) :: h_theta_eddy_visc4 + real (kind=RKIND), intent(in) :: v_theta_eddy_visc2 + real (kind=RKIND), intent(in) :: prandtl_inv + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw @@ -636,4 +1184,194 @@ subroutine theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end subroutine theta_dissipation +!----------------------------------------------------- + + subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, fzm, fzp, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + config_les_model, & + tend_theta_euler ) + + + ! 3D theta_m dissipation using the 3D smagorinsky eddy viscosities. + ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + implicit none + + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, intent(in) :: nCells, nEdges + + logical, intent(in) :: config_mix_full + + character (len=StrKIND) :: config_les_model + + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + real (kind=RKIND), intent(in) :: h_theta_eddy_visc4 + real (kind=RKIND), intent(in) :: v_theta_eddy_visc2 + real (kind=RKIND), intent(in) :: prandtl_inv + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzm + real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzp + real (kind=RKIND), dimension(nVertLevels+1, nCells+1), intent(in) :: zgrid + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: t_init + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_horz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler + + ! storage passed in from calling routine + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_theta + + ! local variables + integer :: cell1, cell2, iEdge, iCell, i, k + real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale + real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp + real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux + real (kind=RKIND) :: rho_k_at_w, zz_at_w + + delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + tend_theta_euler(1:nVertLevels,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + pr_scale = prandtl_inv * meshScalingDel2(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) +!DIR$ IVDEP + do k=1,nVertLevels + +! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. +! This is in conservative form. + + theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) + delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux + theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_vert(k,cell2)) * pr_scale + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux + + end do + end do + end do + +!$OMP BARRIER + + if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active + + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + + iEdge = edgesOnCell(i,iCell) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) + end do + end do + end do + + end if ! 4th order mixing is active + + ! idealized case vertical mixing + + if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m + + if (config_mix_full) then + + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & + -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + else ! idealized cases where we mix on the perturbation from the initial 1-D state + + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & + -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + end if + + end if + + if ( config_les_model == "3d_smagorinsky") then + + do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column + ! compute turbulent fluxes + turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain + turb_vflux(1) = 0. ! lower bc flux handled where ??? + do k=2,nVertLevels + rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) + turb_vflux(k) = rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) + end do + + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & + + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + end do + end do + + end if + + end subroutine theta_dissipation_3d + end module mpas_atm_dissipation_models From 88aa0b2246fba3155c45154583d0db5265a42b60 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 9 Mar 2020 15:12:55 -0600 Subject: [PATCH 026/109] Added a horizontal eddy_viscosity array to go along with the vertical eddy viscosity array. For use in the LES models. --- src/core_atmosphere/Registry.xml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index ad6a27b4f3..7d56a042c5 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1960,7 +1960,10 @@ description="Smagorinsky horizontal eddy viscosity"/> + description="vertical eddy viscosity for les models"/> + + From 05f206c6e516ae2237001a044af9350a39872a9f Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 9 Mar 2020 15:14:22 -0600 Subject: [PATCH 027/109] Bug fixes in the new LES mixing routines. --- .../dynamics/mpas_atm_dissipation_models.F | 47 ++++++++++++------- 1 file changed, 30 insertions(+), 17 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 37a9d3aabf..e42d3551f9 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -119,6 +119,8 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, real (kind=RKIND) :: rdz, def2, pr_inv, wk pr_inv = 1./prandtl + ! testing + pr_inv = 0. do iCell = cellStart,cellEnd @@ -136,8 +138,8 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, do iEdge=1,nEdgesOnCell(iCell) ie = EdgesOnCell(iEdge,iCell) - cell1 = edgesOnCell(1,ie) - cell2 = edgesOnCell(2,ie) + cell1 = cellsOnEdge(1,ie) + cell2 = cellsOnEdge(2,ie) do k=1,nVertLevels dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,ie) & @@ -152,8 +154,8 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, do k=1,nVertLevels+1 wk = 0.5*(w(k,cell1)+w(k,cell2)) - dwdx(k) = dwdx(k) + deformation_coef_c(iEdge,iCell)*wk - dwdy(k) = dwdy(k) + deformation_coef_s(iEdge,iCell)*wk + dwdx(k) = dwdx(k) + deformation_coef_c(iEdge,iCell)*wk + dwdy(k) = dwdy(k) + deformation_coef_s(iEdge,iCell)*wk end do end do @@ -165,33 +167,33 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, do k=2,nVertLevels-1 rdz = 2./(zgrid(k+2,iCell)+zgrid(k+1,iCell)-zgrid(k,iCell)-zgrid(k-1,iCell)) - dudz(k) = (u(k+1,iCell)-u(k-1,iCell))*rdz - dvdz(k) = (v(k+1,iCell)-v(k-1,iCell))*rdz + dudz(k) = (uCell(k+1,iCell)-uCell(k-1,iCell))*rdz + dvdz(k) = (vCell(k+1,iCell)-vCell(k-1,iCell))*rdz end do k = 1 rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) - dudz(k) = (u(k+1,iCell)-u(k,iCell))*rdz - dvdz(k) = (v(k+1,iCell)-v(k,iCell))*rdz + dudz(k) = (uCell(k+1,iCell)-uCell(k,iCell))*rdz + dvdz(k) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz k = nVertLevels-1 rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) - dudz(k+1) = (u(k+1,iCell)-u(k,iCell))*rdz - dvdz(k+1) = (v(k+1,iCell)-v(k,iCell))*rdz + dudz(k+1) = (uCell(k+1,iCell)-uCell(k,iCell))*rdz + dvdz(k+1) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz do k=1, nVertLevels ! here is the 3D Smagorinsky formulation, ! followed by imposition of an upper bound on the eddy viscosity - d_11(k) = 2*dudx(k) - d_22(k) = 2*dvdy(k) - d_33(k) = 2*dwdz(k) + d_11(k) = 2.*dudx(k) + d_22(k) = 2.*dvdy(k) + d_33(k) = 2.*dwdz(k) d_12(k) = dudy(k) + dvdx(k) d_13(k) = dwdx(k) + dudz(k) d_23(k) = dwdy(k) + dvdz(k) def2 = 0.5*(d_11(k)**2 + d_22(k)**2 + d_33(k)**2) + d_12(k)**2 + d_13(k)**2 + d_23(k)**2 - eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * max(0.,def2 - pr_inv*bv_freq2(k,iCell)) + eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) eddy_visc_horz(k,iCell) = min(eddy_visc_horz(k,iCell),(0.01*config_len_disp**2) * invDt) eddy_visc_vert(k,iCell) = eddy_visc_horz(k,iCell) @@ -745,6 +747,11 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v turb_vflux(k) = rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) end do + ! test conditions for supercell case + turb_vflux(1) = turb_vflux(2) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + ! end test conditions + do k=1,nVertLevels tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do @@ -1276,7 +1283,7 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux - theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_vert(k,cell2)) * pr_scale + theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux end do @@ -1351,7 +1358,8 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn end if - if ( config_les_model == "3d_smagorinsky") then + ! test section + ! if ( config_les_model == "3d_smagorinsky") then do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes @@ -1364,13 +1372,18 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn turb_vflux(k) = rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) end do + ! test boundary conditions for supercell case + turb_vflux(1) = turb_vflux(2) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + do k=1,nVertLevels tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do end do - end if + ! end if + ! end test section end subroutine theta_dissipation_3d From 92fbf81b8e16a0b28502e4e227c9159b76267344 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 14:15:30 -0700 Subject: [PATCH 028/109] added test calls to the new 3D LES schemes. This is currently hardwired to always call these LES routines, in this case for the sueprcell test case. Code compiles and runs for the supercell test case. --- .../dynamics/mpas_atm_time_integration.F | 126 ++++++++++++++---- 1 file changed, 103 insertions(+), 23 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 5b5edebf62..9406ac6d2b 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4781,6 +4781,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & h_divergence, kdiff, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save + real (kind=RKIND), dimension(:,:), pointer :: eddy_visc_horz, eddy_visc_vert + real (kind=RKIND), dimension(:,:), pointer :: theta_m_save real (kind=RKIND), dimension(:,:), pointer :: exner @@ -4874,6 +4876,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(diag, 'rho_p_save', rr_save) call mpas_pool_get_array(diag, 'v', v) call mpas_pool_get_array(diag, 'kdiff', kdiff) + call mpas_pool_get_array(diag, 'eddy_visc_horz', eddy_visc_horz) + call mpas_pool_get_array(diag, 'eddy_visc_vert', eddy_visc_vert) call mpas_pool_get_array(diag, 'bn2', bn2) call mpas_pool_get_array(diag, 'ru', ru) call mpas_pool_get_array(diag, 'ru_save', ru_save) @@ -4978,7 +4982,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, & + edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & @@ -5004,7 +5009,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & + h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, & + edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & @@ -5072,6 +5078,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: cqu real (kind=RKIND), dimension(nVertLevels,nCells+1) :: h_divergence real (kind=RKIND), dimension(nVertLevels,nCells+1) :: kdiff + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_horz + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1) :: bn2 real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign real (kind=RKIND), dimension(vertexDegree,nVertices+1) :: edgesOnVertex_sign @@ -5136,6 +5144,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: config_visc4_2dsmag real (kind=RKIND) :: config_len_disp real (kind=RKIND) :: config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2 + logical, parameter :: test_dissipation_3d=.true. integer, intent(in) :: rk_step real (kind=RKIND), intent(in) :: dt @@ -5262,6 +5271,19 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & nCells, nEdges ) +! testing - 3D smagorinsky computation + call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & + cellStart, cellEnd, nCells) + + call smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, ur_cell, vr_cell, & + w, c_s, bn2, zgrid, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + deformation_coef_c, deformation_coef_s, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & + nCells, nEdges, nVertLevels, maxEdges ) +! testing + else if(config_horiz_mixing == "2d_fixed") then ! testing @@ -5476,6 +5498,23 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$OMP BARRIER + if(test_dissipation_3d) then + + call u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & + cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & + nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & + invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & + angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & + config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & + config_del4u_div_factor, zgrid, & + eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & + fzm, fzp, config_les_model, & + delsq_u, delsq_vorticity, delsq_divergence, & + u, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) + + else + call u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & @@ -5487,6 +5526,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm delsq_u, delsq_vorticity, delsq_divergence, & u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) + end if + end if ! (rk_step 1 test for computing mixing terms) !$OMP BARRIER @@ -5613,16 +5654,35 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then - call w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - rdzw, rdzu, & - v_mom_eddy_visc2, h_mom_eddy_visc4, & - delsq_w, & - w, rho_edge, kdiff, rho_zz, & - tend_w_euler ) + if(test_dissipation_3d) then + + call w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + config_les_model, & + tend_w_euler ) + + else + + call w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, kdiff, rho_zz, & + tend_w_euler ) + + end if end if ! horizontal mixing for w computed in first rk_step @@ -5767,17 +5827,37 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then - call theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - delsq_theta, & - theta_m, rho_edge, kdiff, rho_zz, & - tend_theta_euler ) + if(test_dissipation_3d) then + + call theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, fzm, fzp, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + config_les_model, & + tend_theta_euler ) + + else + + call theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, kdiff, rho_zz, & + tend_theta_euler ) + + end if end if ! theta mixing calculated first rk_step From 1eaffdfc68ffcbe06fdfb84757b9a07f7d605ed8 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 9 Mar 2020 15:56:00 -0600 Subject: [PATCH 029/109] Bug fixes for the supercell test case using the 3D Smagorinsky LES model. Fixes are for both configuration and algorithm errors. --- .../dynamics/mpas_atm_dissipation_models.F | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index e42d3551f9..bc1db0d6e7 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -166,7 +166,7 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, end do do k=2,nVertLevels-1 - rdz = 2./(zgrid(k+2,iCell)+zgrid(k+1,iCell)-zgrid(k,iCell)-zgrid(k-1,iCell)) + rdz = 1./(zgrid(k+2,iCell)+zgrid(k+1,iCell)-zgrid(k,iCell)-zgrid(k-1,iCell)) dudz(k) = (uCell(k+1,iCell)-uCell(k-1,iCell))*rdz dvdz(k) = (vCell(k+1,iCell)-vCell(k-1,iCell))*rdz end do @@ -725,7 +725,8 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end if ! vertical mixing of horizontal momentum for fixe viscosity - if ( config_les_model == "3d_smagorinsky") then + ! test section - always execute this code + ! if ( config_les_model == "3d_smagorinsky") then do iEdge=edgeSolveStart,edgeSolveEnd @@ -758,7 +759,8 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end do - end if + ! end if + ! end test section end subroutine u_dissipation_3d @@ -1020,7 +1022,8 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end if - if ( config_les_model == "3d_smagorinsky") then + ! test section - always execute this code + ! if ( config_les_model == "3d_smagorinsky") then do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes @@ -1034,7 +1037,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end do end do - end if + ! end if end subroutine w_dissipation_3d @@ -1358,7 +1361,7 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn end if - ! test section + ! test section - always execute this code ! if ( config_les_model == "3d_smagorinsky") then do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column From eb4b3ef1887469a26a2d778622dab02fd15ecea7 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 9 Mar 2020 16:38:52 -0600 Subject: [PATCH 030/109] switched signs of the vertical turbulent fluxes and vertical flux divergence in the 3D mixing routines to conform to convention. no change in results. --- .../dynamics/mpas_atm_dissipation_models.F | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index bc1db0d6e7..c9c3f3325f 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -745,7 +745,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v zz_cell1 = fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) zz_cell2 = fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) zz_at_w = 0.5*(zz_cell1+zz_cell2) - turb_vflux(k) = rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) + turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) end do ! test conditions for supercell case @@ -754,7 +754,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v ! end test conditions do k=1,nVertLevels - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do end do @@ -1028,12 +1028,12 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes do k=1,nVertLevels - turb_vflux(k) = rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*zz(k,iCell) & - *rdzu(k)*(w(k+1,iCell)-w(k,iCell)) + turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*zz(k,iCell) & + *rdzu(k)*(w(k+1,iCell)-w(k,iCell)) end do do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & - + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do end do @@ -1372,7 +1372,7 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) - turb_vflux(k) = rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) + turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) end do ! test boundary conditions for supercell case @@ -1381,7 +1381,7 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn do k=1,nVertLevels tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & - + rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do end do From dbd83ea5686cfdaa081aebb05e30e9c30f212952 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 14:20:31 -0700 Subject: [PATCH 031/109] Added new lower boundary conditions for LES simulations: (1) constant heat flux (2) simple surface drag cleaned up the driving layer in subroutine atm_compute_dyn_tend. convective boundary layer test results look OK. --- .../dynamics/mpas_atm_dissipation_models.F | 98 +++++++++--- .../dynamics/mpas_atm_time_integration.F | 141 ++++++++---------- 2 files changed, 139 insertions(+), 100 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index c9c3f3325f..dad19bd059 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -11,6 +11,12 @@ module mpas_atm_dissipation_models use mpas_kind_types, only : RKIND use mpas_atmphys_constants use mpas_constants + use mpas_log + + logical, parameter :: debug_dissipation = .true. + logical, parameter :: les_test = .true. + real (kind=RKIND), parameter :: tke_heat_flux = 0.24 + real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 contains @@ -42,6 +48,9 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, integer :: iCell, iEdge, k real (kind=RKIND), dimension(nVertLevels) :: d_11, d_22, d_12, dudx, dudy, dvdx, dvdy + if(debug_dissipation) call mpas_log_write(' begin smagorinsky_2d ') + + do iCell = cellStart,cellEnd dudx(1:nVertLevels) = 0.0 dudy(1:nVertLevels) = 0.0 @@ -74,6 +83,8 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 h_theta_eddy_visc4 = h_mom_eddy_visc4 + if(debug_dissipation) call mpas_log_write(' exiting smagorinsky_2d ') + end subroutine smagorinsky_2d !--------------------------------------- @@ -107,7 +118,7 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: eddy_visc_horz, eddy_visc_vert - real (kind=RKIND), intent(in) :: h_mom_eddy_visc4, h_theta_eddy_visc4 + real (kind=RKIND), intent(out) :: h_mom_eddy_visc4, h_theta_eddy_visc4 ! local variables @@ -118,9 +129,9 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, real (kind=RKIND), dimension(nVertLevels) :: dudz, dvdz, dwdz real (kind=RKIND) :: rdz, def2, pr_inv, wk + if(debug_dissipation) call mpas_log_write(' begin smagorinsky_3d ') + pr_inv = 1./prandtl - ! testing - pr_inv = 0. do iCell = cellStart,cellEnd @@ -201,6 +212,13 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, end do ! loop over all owned cells (columns) + ! set up coefficients for 4th-order horizontal background filter + + h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 + h_theta_eddy_visc4 = h_mom_eddy_visc4 + + if(debug_dissipation) call mpas_log_write(' exiting smagorinsky_3d ') + end subroutine smagorinsky_3d !--------------------------------------- @@ -217,11 +235,12 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local - real (kind=RKIND) :: dz, esw, qc_cr + real (kind=RKIND) :: dz, esw + real (kind=RKIND), parameter :: qc_cr = 0.00001 ! in kg/kg real (kind=RKIND), dimension(nVertLevels) :: theta, qvsw, temp, coefa - qc_cr = 0.00001 ! in kg/kg - + if(debug_dissipation) call mpas_log_write(' begin BV frequency calculations ') + do iCell = cellStart,cellEnd !DIR$ IVDEP do k=1, nVertLevels @@ -260,6 +279,8 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in end do + if(debug_dissipation) call mpas_log_write(' exiting BV frequency calculations ') + end subroutine calculate_n2 !--------------------------------------- @@ -500,7 +521,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & fzm, fzp, config_les_model, & delsq_u, delsq_vorticity, delsq_divergence, & - u, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) + u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here @@ -538,6 +559,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: v real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: divergence real (kind=RKIND), dimension(nVertLevels,nVertices+1), intent(in) :: vorticity real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge @@ -571,6 +593,15 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND) :: rho_k_cell1, rho_k_cell2, rho_k_at_w real (kind=RKIND) :: zz_cell1, zz_cell2, zz_at_w + real (kind=RKIND) :: velocity_magnitude + + if(debug_dissipation) then + call mpas_log_write(' begin u_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) + call mpas_log_write(' 4th order divergence factor is $r ', realArgs=(/config_del4u_div_factor/)) + end if + !$OMP BARRIER ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). @@ -725,8 +756,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end if ! vertical mixing of horizontal momentum for fixe viscosity - ! test section - always execute this code - ! if ( config_les_model == "3d_smagorinsky") then + if ( config_les_model == "3d_smagorinsky") then do iEdge=edgeSolveStart,edgeSolveEnd @@ -748,10 +778,17 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) end do + if( les_test ) then + velocity_magnitude = sqrt(u(1,iEdge)**2 + v(1,iEdge)**2) + turb_vflux(1) = -rho_edge(1,iEdge)*tke_drag_coefficient*u(1,iEdge)*velocity_magnitude + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + ! end test conditions + else ! test conditions for supercell case turb_vflux(1) = turb_vflux(2) turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) ! end test conditions + end if do k=1,nVertLevels tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) @@ -759,9 +796,9 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end do - ! end if - ! end test section + end if + if(debug_dissipation) call mpas_log_write(' exiting u_dissipation_3d ') end subroutine u_dissipation_3d @@ -960,6 +997,11 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, ! First, storage to hold the result from the first del^2 computation. ! we copied code from the theta mixing, hence the theta* names. + if(debug_dissipation) then + call mpas_log_write(' begin w_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) + end if delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 @@ -1022,8 +1064,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end if - ! test section - always execute this code - ! if ( config_les_model == "3d_smagorinsky") then + if ( config_les_model == "3d_smagorinsky") then do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes @@ -1037,7 +1078,9 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end do end do - ! end if + end if + + if(debug_dissipation) call mpas_log_write(' exiting w_dissipation_3d ') end subroutine w_dissipation_3d @@ -1267,6 +1310,12 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux real (kind=RKIND) :: rho_k_at_w, zz_at_w + if(debug_dissipation) then + call mpas_log_write(' begin theta_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_theta_eddy_visc4/)) + end if + delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 do iCell=cellStart,cellEnd @@ -1361,8 +1410,7 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn end if - ! test section - always execute this code - ! if ( config_les_model == "3d_smagorinsky") then + if ( config_les_model == "3d_smagorinsky") then do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes @@ -1375,9 +1423,16 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) end do - ! test boundary conditions for supercell case - turb_vflux(1) = turb_vflux(2) - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + ! test boundary conditions for supercell and les test cases + + if( les_test ) then + turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + else + turb_vflux(1) = turb_vflux(2) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + end if + do k=1,nVertLevels tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & @@ -1385,8 +1440,9 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn end do end do - ! end if - ! end test section + end if + + if(debug_dissipation) call mpas_log_write(' exiting theta_dissipation_3d ') end subroutine theta_dissipation_3d diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 9406ac6d2b..a04c9cc97a 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5265,13 +5265,22 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if(config_horiz_mixing == "2d_smagorinsky") then - call smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, & + call smagorinsky_2d( eddy_visc_horz, u, v, c_s, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & nCells, nEdges ) -! testing - 3D smagorinsky computation + else if(config_horiz_mixing == "2d_fixed") then + + eddy_visc_horz(1:nVertLevels,cellStart:cellEnd) = config_h_theta_eddy_visc2 + h_mom_eddy_visc4 = config_h_mom_eddy_visc4 + h_theta_eddy_visc4 = config_h_theta_eddy_visc4 + + end if + + else if (config_les_model == "3d_smagorinsky") then + call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) @@ -5282,35 +5291,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & nCells, nEdges, nVertLevels, maxEdges ) -! testing - - else if(config_horiz_mixing == "2d_fixed") then - -! testing -! call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & -! cellStart, cellEnd, nCells) -! testing - - !$acc parallel default(present) - !$acc loop gang worker - do iCell = cellStart, cellEnd - !$acc loop vector - do k = 1, nVertLevels - kdiff(k,iCell) = config_h_theta_eddy_visc2 - end do - end do - !$acc end parallel - - h_mom_eddy_visc4 = config_h_mom_eddy_visc4 - h_theta_eddy_visc4 = config_h_theta_eddy_visc4 - - end if - - else if (config_les_model == "3d_smagorinsky") then - - ! call to 3D smagorinsky here... - call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & - cellStart, cellEnd, nCells) end if @@ -5329,6 +5309,9 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm visc2cam = visc2cam*(1.0-real(nVertLevels-k)/real(config_number_cam_damping_levels)) kdiff(k ,iCell) = max(kdiff(k ,iCell),visc2cam) end do + eddy_visc_horz(nVertLevels-2,iCell) = max(eddy_visc_horz(nVertLevels-2,iCell), 2.0833*config_len_disp*config_mpas_cam_coef) + eddy_visc_horz(nVertLevels-1,iCell) = max(eddy_visc_horz(nVertLevels-1,iCell),2.0*2.0833*config_len_disp*config_mpas_cam_coef) + eddy_visc_horz(nVertLevels ,iCell) = max(eddy_visc_horz(nVertLevels ,iCell),4.0*2.0833*config_len_disp*config_mpas_cam_coef) end do !$acc end parallel @@ -5498,7 +5481,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$OMP BARRIER - if(test_dissipation_3d) then +! if(test_dissipation_3d) then call u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & @@ -5511,22 +5494,22 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & fzm, fzp, config_les_model, & delsq_u, delsq_vorticity, delsq_divergence, & - u, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) + u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) - else - - call u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & - cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & - cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & - nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & - invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & - angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & - config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & - config_del4u_div_factor, zgrid, kdiff, & - delsq_u, delsq_vorticity, delsq_divergence, & - u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) - - end if +! else ! this is the original MPAS dissipation code +! +! call u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & +! cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & +! cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & +! nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & +! invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & +! angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & +! config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & +! config_del4u_div_factor, zgrid, kdiff, & +! delsq_u, delsq_vorticity, delsq_divergence, & +! u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) +! +! end if end if ! (rk_step 1 test for computing mixing terms) @@ -5654,7 +5637,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then - if(test_dissipation_3d) then +! if(test_dissipation_3d) then call w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & nCells, nEdges, & @@ -5669,22 +5652,22 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm config_les_model, & tend_w_euler ) - else - - call w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - rdzw, rdzu, & - v_mom_eddy_visc2, h_mom_eddy_visc4, & - delsq_w, & - w, rho_edge, kdiff, rho_zz, & - tend_w_euler ) - - end if +! else +! +! call w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & +! nCells, nEdges, & +! nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & +! invAreaCell, invDcEdge, dvEdge, & +! meshScalingDel2, meshScalingDel4, & +! rdzw, rdzu, & +! v_mom_eddy_visc2, h_mom_eddy_visc4, & +! delsq_w, & +! w, rho_edge, kdiff, rho_zz, & +! tend_w_euler ) +! +! end if - end if ! horizontal mixing for w computed in first rk_step + end if ! mixing for w computed in first rk_step ! Note for OpenMP parallelization: We could avoid allocating the delsq_w scratch ! array, and just use the delsq_theta array as was previously done; however, @@ -5827,7 +5810,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then - if(test_dissipation_3d) then +! if(test_dissipation_3d) then call theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & nCells, nEdges, & @@ -5843,21 +5826,21 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm config_les_model, & tend_theta_euler ) - else - - call theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - delsq_theta, & - theta_m, rho_edge, kdiff, rho_zz, & - tend_theta_euler ) - - end if +! else ! this is the original MPAS dissipation code +! +! call theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & +! nCells, nEdges, & +! nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & +! invAreaCell, invDcEdge, dvEdge, & +! meshScalingDel2, meshScalingDel4, & +! config_mix_full, t_init, zgrid, & +! rdzw, rdzu, & +! v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & +! delsq_theta, & +! theta_m, rho_edge, kdiff, rho_zz, & +! tend_theta_euler ) +! +! end if end if ! theta mixing calculated first rk_step From 59f1348c754f6c41383776b0a03be457193f1076 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 16 Mar 2020 15:52:47 -0600 Subject: [PATCH 032/109] Added a scalar variable named tke. This is the turbulent kinetic energy used in the prognostic 1.5 order TKE (LES) scheme. Initialized the values to 0.1 (i.e. a small number) becuase there must be a seed to grow tke. --- src/core_init_atmosphere/Registry.xml | 2 ++ src/core_init_atmosphere/mpas_init_atm_cases.F | 10 ++++++++++ 2 files changed, 12 insertions(+) diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index d24568c866..b4f4622246 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -1196,6 +1196,8 @@ + diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 82b2517e76..0160139fb8 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -6235,6 +6235,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, cell1, cell2 integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve integer, pointer :: index_qv + integer, pointer :: index_tke real (kind=RKIND), dimension(nVertLevels + 1 ) :: znu, znw, znwc, znwv real (kind=RKIND), dimension(nVertLevels + 1 ) :: znuc, znuv @@ -6368,6 +6369,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes call mpas_pool_get_array(state, 'scalars', scalars) call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_dimension(state, 'index_tke', index_tke) scalars(:,:,:) = 0. @@ -6607,6 +6609,14 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) end do end do +! +! initial seed for tke +! + do i=1,nCells + do k = 1,nz1 + scalars(index_tke,k,i) = 0.1 + end do + end do do itr=1,30 From 31f21ff571126a8ea48eb19845ff1991c53f2e9c Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 17 Mar 2020 11:09:52 -0600 Subject: [PATCH 033/109] Added passive test of prognostic tke. Does not yet pass debug step. --- src/core_atmosphere/Registry.xml | 10 ++ .../dynamics/mpas_atm_dissipation_models.F | 111 ++++++++++++++++-- .../dynamics/mpas_atm_time_integration.F | 21 +++- 3 files changed, 124 insertions(+), 18 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 7d56a042c5..f78ca1b2fb 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1696,6 +1696,12 @@ + packages="mp_thompson_in"/> + + + + + packages="mp_thompson_in"/> + + #endif diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index dad19bd059..ea5181a8f7 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -89,22 +89,26 @@ end subroutine smagorinsky_2d !--------------------------------------- - subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, & + subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, & w, c_s, bv_freq2, zgrid, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & deformation_coef_c, deformation_coef_s, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & - nCells, nEdges, nVertLevels, maxEdges ) + nCells, nEdges, nVertLevels, maxEdges, num_scalars ) implicit none - integer, intent(in) :: cellStart, cellEnd, nCells, nEdges, nVertLevels, maxEdges + integer, intent(in) :: cellStart, cellEnd, nCells, nEdges, nVertLevels, maxEdges, index_tke, num_scalars real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: v real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: uCell real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: vCell real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: bv_freq2 + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: tend_scalars real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_c2 @@ -112,6 +116,7 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_cs real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_c real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: deformation_coef_s + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 real (kind=RKIND), intent(in) :: c_s, config_len_disp, invDt, config_visc4_2dsmag integer, dimension(nCells+1), intent(in) :: nEdgesOnCell integer, dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell @@ -128,6 +133,11 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, real (kind=RKIND), dimension(nVertLevels+1) :: dwdx, dwdy real (kind=RKIND), dimension(nVertLevels) :: dudz, dvdz, dwdz real (kind=RKIND) :: rdz, def2, pr_inv, wk + real (kind=RKIND) :: shear_production, buoyancy, dissipation, delta_z, delta_s, bv, tke_length, diss_length + real (kind=RKIND) :: l_horizontal, l_vertical, c_k, c_dissipation + real (kind=RKIND) :: prandtl_horizontal_inv, prandtl_vertical_inv + + logical, parameter :: test_tke=.true. if(debug_dissipation) call mpas_log_write(' begin smagorinsky_3d ') @@ -210,6 +220,63 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, end do +!*************************************************** + + if (test_tke) then + + do k=1,nVertLevels + + shear_production = eddy_visc_horz(k,iCell)*(d_11(k)**2 + d_22(k)**2 + d_12(k)**2) & + +eddy_visc_vert(k,iCell)*(d_33(k)**2 + d_13(k)**2 + d_13(k)**2) + + buoyancy = -eddy_visc_vert(k,iCell)*bv_freq2(k,iCell) + + ! dissipation + + delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) + delta_s = ((config_len_disp**2)*delta_z)**(1./3.) + bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon ) + tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv + + diss_length = min(delta_s,tke_length) + if(bv_freq2(k,iCell) <= 0) diss_length = delta_s + + c_k = 0.25 + c_dissipation = 1.9*c_k + max( 0.0, 0.93 - 1.9*c_k )*diss_length/delta_s + + dissipation = -c_dissipation*(scalars(index_tke,k,iCell)**(1.5))/diss_length + + ! computing eddy viscosities ********* + + ! non-isotropic mixing + + l_horizontal = config_len_disp + l_vertical = min(delta_z,tke_length) + if(bv_freq2(k,iCell) <= 0) diss_length = delta_z + + ! isotropic mixing + + l_horizontal = min(delta_s,tke_length) + if(bv_freq2(k,iCell) <= 0) diss_length = delta_s + l_vertical = l_horizontal + + prandtl_horizontal_inv = 3. + prandtl_vertical_inv = 1.0+(2.0*l_vertical/delta_z) ! going to need to store this off somewhere + + ! eddy viscocities set here if we are running the 1.5 order prognostic tke scheme + ! eddy_visc_horz(k,iCell) = c_k*l_horizontal*sqrt(scalars(index_tke,k,iCell)) + ! eddy_visc_vert(k,iCell) = c_k*l_vertical*sqrt(scalars(index_tke,k,iCell)) + + ! RHS term for the subgrid ke. + + tend_scalars(index_tke,k,iCell) = rho_zz(k,iCell)*( shear_production + buoyancy + dissipation ) + + end do + + end if ! end of test_tke + +!*************************************************** + end do ! loop over all owned cells (columns) ! set up coefficients for 4th-order horizontal background filter @@ -235,9 +302,10 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local - real (kind=RKIND) :: dz, esw + real (kind=RKIND) :: dz, rdz, esw real (kind=RKIND), parameter :: qc_cr = 0.00001 ! in kg/kg real (kind=RKIND), dimension(nVertLevels) :: theta, qvsw, temp, coefa + logical :: dry_bv_frequency if(debug_dissipation) call mpas_log_write(' begin BV frequency calculations ') @@ -261,18 +329,37 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in do k=2, nVertLevels-1 dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) - - if ( scalars(index_qc,k,iCell) < qc_cr ) then + rdz = 1.0/dz + + ! if ( scalars(index_qc,k,iCell) < qc_cr ) then + ! ! Dry Brunt-Vaisala frequency + ! bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & + ! + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) / dz & + ! - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) + ! else + ! ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 + ! bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & + ! + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) / dz ) & + ! - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) + ! endif + + dry_bv_frequency = .true. + if(index_qc .gt. 0) then ! if moist simulation, qc exists + if ( scalars(index_qc,k,iCell) .ge. qc_cr ) dry_bv_frequency = .false. + end if + + if (dry_bv_frequency) then ! Dry Brunt-Vaisala frequency - bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & - + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) / dz & - - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) + bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) * rdz & + + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) * rdz & + - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) * rdz ) else ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 - bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & - + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) / dz ) & - - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) + bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) * rdz & + + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) * rdz ) & + - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) * rdz ) endif + end do bn2(1,iCell) = bn2(2,iCell) bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index a04c9cc97a..a3dd869be5 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4791,7 +4791,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:,:), pointer :: rthdynten - real (kind=RKIND), dimension(:,:,:), pointer :: scalars + real (kind=RKIND), dimension(:,:,:), pointer :: scalars, tend_scalars real (kind=RKIND), dimension(:,:), pointer :: tend_u_euler, tend_w_euler, tend_theta_euler @@ -4835,7 +4835,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), pointer :: config_rayleigh_damp_u_timescale_days integer, pointer :: config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels integer, pointer :: config_number_rayleigh_damp_u_levels - integer, pointer :: index_qv, index_qc + integer, pointer :: index_qv, index_qc, index_tke logical :: inactive_rthdynten @@ -4947,6 +4947,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(tend, 'w_euler', tend_w_euler) call mpas_pool_get_array(tend, 'w_pgf', tend_w_pgf) call mpas_pool_get_array(tend, 'w_buoy', tend_w_buoy) + call mpas_pool_get_array(tend, 'scalars_tend', tend_scalars) + call mpas_pool_get_array(diag, 'cqw', cqw) call mpas_pool_get_array(diag, 'cqu', cqu) @@ -4965,6 +4967,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_dimension(state, 'moist_end', moist_end) 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_tke', index_tke) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) @@ -4978,11 +4981,12 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels, & nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, index_qv, index_qc, moist_start, moist_end, & + tend_scalars, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, & + h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, index_tke, & 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, & @@ -5005,11 +5009,12 @@ end subroutine atm_compute_dyn_tend subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dummy, & nCellsSolve, nEdgesSolve, vertexDegree, maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, index_qc, moist_start, moist_end, & + tend_scalars, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, & + h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, index_tke, & 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, & @@ -5038,7 +5043,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! Dummy arguments ! integer :: nCells, nEdges, nVertices, nVertLevels_dummy, nCellsSolve, nEdgesSolve, vertexDegree, & - maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, index_qc, moist_start, moist_end + maxEdges_dummy, maxEdges2_dummy, num_scalars_dummy, index_qv, index_qc, moist_start, moist_end, index_tke real (kind=RKIND), dimension(nEdges+1) :: fEdge real (kind=RKIND), dimension(nEdges+1) :: dvEdge @@ -5090,6 +5095,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: exner real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rr_save real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: scalars + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: tend_scalars real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: tend_u_euler real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_euler real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_theta_euler @@ -5281,6 +5287,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if (config_les_model == "3d_smagorinsky") then + ! call mpas_log_write(' BV call, index qv, qc, tke $i $i $i ', intArgs=(/index_qv, index_qc, index_tke/)) + call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) @@ -5289,8 +5297,9 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & deformation_coef_c, deformation_coef_s, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & - nCells, nEdges, nVertLevels, maxEdges ) + nCells, nEdges, nVertLevels, maxEdges, num_scalars ) end if From 7e1581b745dbbb19e617c44188417318add61a97 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 17 Mar 2020 19:59:43 -0600 Subject: [PATCH 034/109] 1.5 order prognostic tke mods. The prognostic tke does not feed back on the solution in this formulation. further testing ahead. --- .../dynamics/mpas_atm_dissipation_models.F | 46 +++++++++++-------- 1 file changed, 27 insertions(+), 19 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index ea5181a8f7..0d76397baf 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -136,8 +136,10 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, real (kind=RKIND) :: shear_production, buoyancy, dissipation, delta_z, delta_s, bv, tke_length, diss_length real (kind=RKIND) :: l_horizontal, l_vertical, c_k, c_dissipation real (kind=RKIND) :: prandtl_horizontal_inv, prandtl_vertical_inv + real (kind=RKIND) :: eddy_visc_h, eddy_visc_v logical, parameter :: test_tke=.true. + real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 if(debug_dissipation) call mpas_log_write(' begin smagorinsky_3d ') @@ -226,28 +228,13 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, do k=1,nVertLevels - shear_production = eddy_visc_horz(k,iCell)*(d_11(k)**2 + d_22(k)**2 + d_12(k)**2) & - +eddy_visc_vert(k,iCell)*(d_33(k)**2 + d_13(k)**2 + d_13(k)**2) - - buoyancy = -eddy_visc_vert(k,iCell)*bv_freq2(k,iCell) - - ! dissipation - delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) delta_s = ((config_len_disp**2)*delta_z)**(1./3.) - bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon ) + bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon_bv ) tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv - diss_length = min(delta_s,tke_length) if(bv_freq2(k,iCell) <= 0) diss_length = delta_s - c_k = 0.25 - c_dissipation = 1.9*c_k + max( 0.0, 0.93 - 1.9*c_k )*diss_length/delta_s - - dissipation = -c_dissipation*(scalars(index_tke,k,iCell)**(1.5))/diss_length - - ! computing eddy viscosities ********* - ! non-isotropic mixing l_horizontal = config_len_disp @@ -256,9 +243,30 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, ! isotropic mixing - l_horizontal = min(delta_s,tke_length) - if(bv_freq2(k,iCell) <= 0) diss_length = delta_s - l_vertical = l_horizontal + ! l_horizontal = min(delta_s,tke_length) + ! if(bv_freq2(k,iCell) <= 0) diss_length = delta_s + ! l_vertical = l_horizontal + + ! eddy viscocities set here if we are running the 1.5 order prognostic tke scheme + eddy_visc_h = c_k*l_horizontal*sqrt(scalars(index_tke,k,iCell)) + eddy_visc_v = c_k*l_vertical*sqrt(scalars(index_tke,k,iCell)) + + ! terms for the prognostic tke integration + + shear_production = eddy_visc_h*(d_11(k)**2 + d_22(k)**2 + d_12(k)**2) & + +eddy_visc_v*(d_33(k)**2 + d_13(k)**2 + d_13(k)**2) + + buoyancy = -eddy_visc_v*bv_freq2(k,iCell) + + ! dissipation + + c_k = 0.25 + c_dissipation = 1.9*c_k + max( 0.0, 0.93 - 1.9*c_k )*diss_length/delta_s + if( (k.eq. 1) .or. (k.eq.nVertLevels) ) c_dissipation = 3.9 + + dissipation = -c_dissipation*(scalars(index_tke,k,iCell)**(1.5))/diss_length + + ! computing eddy viscosities ********* prandtl_horizontal_inv = 3. prandtl_vertical_inv = 1.0+(2.0*l_vertical/delta_z) ! going to need to store this off somewhere From 84ad242fffcee936e513556eb762d90ee7c7c43c Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Wed, 18 Mar 2020 16:50:43 -0600 Subject: [PATCH 035/109] Added mixing routines for scalars within the LES models, both diagnostic and prognostic versions. The progostic tke option is still running in a no-feedback mode. --- .../dynamics/mpas_atm_dissipation_models.F | 320 ++++++++++++++++++ .../dynamics/mpas_atm_time_integration.F | 44 ++- 2 files changed, 351 insertions(+), 13 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 0d76397baf..510b213184 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1541,4 +1541,324 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn end subroutine theta_dissipation_3d +!----------------------------------------------------- + + subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, fzm, fzp, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + bv_freq2, config_len_disp, scalars, tend_scalars, & + index_tke, index_qv, num_scalars_dummy, mix_scalars, & + config_les_model, & + tend_theta_euler ) + + + ! 3D theta_m dissipation using the 3D smagorinsky eddy viscosities. + ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + implicit none + + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, intent(in) :: nCells, nEdges + integer, intent(in) :: num_scalars_dummy + integer, intent(in) :: index_tke, index_qv + + logical, intent(in) :: config_mix_full, mix_scalars + + character (len=StrKIND) :: config_les_model + + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell + + integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + + real (kind=RKIND), intent(in) :: h_theta_eddy_visc4 + real (kind=RKIND), intent(in) :: v_theta_eddy_visc2 + real (kind=RKIND), intent(in) :: prandtl_inv + real (kind=RKIND), intent(in) :: config_len_disp + + real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell + real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 + real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw + real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu + real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzm + real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzp + real (kind=RKIND), dimension(nVertLevels+1, nCells+1), intent(in) :: zgrid + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: t_init + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: bv_freq2 + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout) :: tend_scalars + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_horz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler + + ! storage passed in from calling routine + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_theta + + ! local variables + integer :: cell1, cell2, iEdge, iCell, i, k, iScalar + real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale + real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp + real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux + real (kind=RKIND), dimension(num_scalars,nVertLevels+1) :: turb_vflux_scalars + real (kind=RKIND) :: rho_k_at_w, zz_at_w + + logical, parameter :: vmix_scalars = .true. + logical, parameter :: hmix_scalars = .true. + logical, parameter :: hmix4_scalars = .false. + + if(debug_dissipation) then + call mpas_log_write(' begin scalar_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_theta_eddy_visc4/)) + end if + + delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + tend_theta_euler(1:nVertLevels,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + pr_scale = prandtl_inv * meshScalingDel2(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) +!DIR$ IVDEP + do k=1,nVertLevels + +! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. +! This is in conservative form. + + theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) + delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux + theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux + + end do + end do + end do + +!$OMP BARRIER + + if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active + + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + + iEdge = edgesOnCell(i,iCell) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) + end do + end do + end do + + end if ! 4th order mixing is active + + if(mix_scalars .and. hmix_scalars) then ! dissipation for scalars, including 4th-order filter. Likely needs optimization + + do iScalar=1,num_scalars + + delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + ! tend_theta_euler(1:nVertLevels,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + pr_scale = prandtl_inv * meshScalingDel2(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) +!DIR$ IVDEP + do k=1,nVertLevels + +! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. +! This is in conservative form. + + theta_turb_flux = edge_sign*(scalars(iScalar,k,cell2) - scalars(iScalar,k,cell1))*rho_edge(k,iEdge) + delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux + theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale + tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) + theta_turb_flux + + end do + end do + end do + +!$OMP BARRIER + + if ((h_theta_eddy_visc4 > 0.0).and. hmix4_scalars) then ! 4th order mixing is active + + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + + iEdge = edgesOnCell(i,iCell) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) + end do + end do + end do + + end if ! 4th order mixing is active + + end do ! loop over scalars for horizontal mixing + + end if ! horizontal scalar mixing + + + ! idealized case vertical mixing. No scalar mixing here. + + if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m + + if (config_mix_full) then + + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & + -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + else ! idealized cases where we mix on the perturbation from the initial 1-D state + + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) + + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) + + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & + -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) + end do + end do + + end if + + end if + + if ( config_les_model /= "none") then + + do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column + ! compute turbulent fluxes + turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain + turb_vflux(1) = 0. ! lower bc flux handled where ??? + do k=2,nVertLevels + rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) + turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) + end do + + ! test boundary conditions for supercell and les test cases + + if( les_test ) then + turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + else + turb_vflux(1) = turb_vflux(2) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + end if + + + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & + - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + end do + + end do + + if (mix_scalars .and. vmix_scalars) then + + do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column + ! compute turbulent fluxes + turb_vflux_scalars(:,nVertlevels+1) = 0. ! no turbulent flux out of the domain + turb_vflux_scalars(:,1) = 0. ! lower bc flux handled where ??? + do k=2,nVertLevels + rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) + do iScalar=1,num_scalars + turb_vflux_scalars(iScalar,k) = - rho_k_at_w*zz_at_w*rdzu(k)* & + (scalars(iScalar,k,iCell)-scalars(iScalar,k-1,iCell)) + end do + end do + + ! test boundary conditions for supercell and les test cases + + ! need lower bc for qv here... + + ! if( les_test ) then + ! turb_vflux_scalars(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY + ! turb_vflux_scalars(nVertLevels+1) = turb_vflux_scalars(nVertLevels) + ! else + ! turb_vflux_scalars(1) = turb_vflux_scalars(2) + ! turb_vflux_scalars(nVertLevels+1) = turb_vflux_scalars(nVertLevels) + ! end if + + + do k=1,nVertLevels + do iScalar=1,num_scalars + tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) & + - rdzw(k)*(turb_vflux_scalars(iScalar,k+1)-turb_vflux_scalars(iScalar,k)) + end do + end do + + end do + + end if ! mix scalars + + end if + + if(debug_dissipation) call mpas_log_write(' exiting scalar_dissipation_3d ') + + end subroutine scalar_dissipation_3d_les + end module mpas_atm_dissipation_models diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index a3dd869be5..f79485b5be 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5151,6 +5151,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: config_len_disp real (kind=RKIND) :: config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2 logical, parameter :: test_dissipation_3d=.true. + logical, parameter :: mix_scalars = .true. integer, intent(in) :: rk_step real (kind=RKIND), intent(in) :: dt @@ -5821,19 +5822,36 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! if(test_dissipation_3d) then - call theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, fzm, fzp, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - delsq_theta, & - theta_m, rho_edge, rho_zz, zz, & - eddy_visc_horz, eddy_visc_vert, & - config_les_model, & - tend_theta_euler ) + !call theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + ! nCells, nEdges, & + ! nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + ! invAreaCell, invDcEdge, dvEdge, & + ! meshScalingDel2, meshScalingDel4, & + ! config_mix_full, t_init, zgrid, & + ! rdzw, rdzu, fzm, fzp, & + ! v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + ! delsq_theta, & + ! theta_m, rho_edge, rho_zz, zz, & + ! eddy_visc_horz, eddy_visc_vert, & + ! config_les_model, & + ! tend_theta_euler ) + + call scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, fzm, fzp, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + delsq_theta, & + theta_m, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + bn2, config_len_disp, scalars, tend_scalars, & + index_tke, index_qv, num_scalars, mix_scalars, & + config_les_model, & + tend_theta_euler ) + ! else ! this is the original MPAS dissipation code ! From bf39525c523e673133b26abea9c0d19a728ae0fc Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Fri, 20 Mar 2020 10:59:32 -0600 Subject: [PATCH 036/109] Clean up and changes to run the prognostic tke les model. initial tests of the prognostic scheme with a convective boundary layer appear to be OK. More testing to follow. --- .../dynamics/mpas_atm_dissipation_models.F | 153 +++++++++--------- .../dynamics/mpas_atm_time_integration.F | 21 ++- 2 files changed, 90 insertions(+), 84 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 510b213184..9b1d122866 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -12,6 +12,7 @@ module mpas_atm_dissipation_models use mpas_atmphys_constants use mpas_constants use mpas_log + use mpas_derived_types, only : MPAS_LOG_CRIT logical, parameter :: debug_dissipation = .true. logical, parameter :: les_test = .true. @@ -89,17 +90,20 @@ end subroutine smagorinsky_2d !--------------------------------------- - subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, & - w, c_s, bv_freq2, zgrid, config_len_disp, & - deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & - deformation_coef_c, deformation_coef_s, & - invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & - scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & - cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & - nCells, nEdges, nVertLevels, maxEdges, num_scalars ) + subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, & + u, v, uCell, vCell, & + w, c_s, bv_freq2, zgrid, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + deformation_coef_c, deformation_coef_s, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & + nCells, nEdges, nVertLevels, maxEdges, num_scalars ) implicit none + character (len=StrKIND), intent(in) :: config_les_model + integer, intent(in) :: cellStart, cellEnd, nCells, nEdges, nVertLevels, maxEdges, index_tke, num_scalars real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: v @@ -107,7 +111,7 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: vCell real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: bv_freq2 real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz - real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars + real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout) :: scalars real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: tend_scalars real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid @@ -141,10 +145,16 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, logical, parameter :: test_tke=.true. real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 - if(debug_dissipation) call mpas_log_write(' begin smagorinsky_3d ') + if(debug_dissipation) call mpas_log_write(' begin les_models ') + if(debug_dissipation) call mpas_log_write(' les scheme is '//trim(config_les_model)) pr_inv = 1./prandtl + ! set up coefficients for 4th-order horizontal background filter + + h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 + h_theta_eddy_visc4 = h_mom_eddy_visc4 + do iCell = cellStart,cellEnd dudx(1:nVertLevels) = 0.0 @@ -205,26 +215,28 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, dvdz(k+1) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz do k=1, nVertLevels - ! here is the 3D Smagorinsky formulation, - ! followed by imposition of an upper bound on the eddy viscosity d_11(k) = 2.*dudx(k) d_22(k) = 2.*dvdy(k) d_33(k) = 2.*dwdz(k) d_12(k) = dudy(k) + dvdx(k) d_13(k) = dwdx(k) + dudz(k) d_23(k) = dwdy(k) + dvdz(k) + end do - def2 = 0.5*(d_11(k)**2 + d_22(k)**2 + d_33(k)**2) + d_12(k)**2 + d_13(k)**2 + d_23(k)**2 - - eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) - eddy_visc_horz(k,iCell) = min(eddy_visc_horz(k,iCell),(0.01*config_len_disp**2) * invDt) - eddy_visc_vert(k,iCell) = eddy_visc_horz(k,iCell) + if (config_les_model == "3d_smagorinsky") then - end do + do k=1, nVertLevels + def2 = 0.5*(d_11(k)**2 + d_22(k)**2 + d_33(k)**2) + d_12(k)**2 + d_13(k)**2 + d_23(k)**2 + eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) + eddy_visc_horz(k,iCell) = min(eddy_visc_horz(k,iCell),(0.01*config_len_disp**2) * invDt) + eddy_visc_vert(k,iCell) = eddy_visc_horz(k,iCell) + end do -!*************************************************** + else if (config_les_model == "prognostic_1.5_order") then - if (test_tke) then + do k=1,nVertLevels ! bound the tke here, currently hardwired + scalars(index_tke,k,iCell) = max(0.,min(100.,scalars(index_tke,k,iCell))) + end do do k=1,nVertLevels @@ -232,7 +244,7 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, delta_s = ((config_len_disp**2)*delta_z)**(1./3.) bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon_bv ) tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv - diss_length = min(delta_s,tke_length) + diss_length = min(delta_s,max(tke_length,0.01*delta_s)) if(bv_freq2(k,iCell) <= 0) diss_length = delta_s ! non-isotropic mixing @@ -251,6 +263,10 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, eddy_visc_h = c_k*l_horizontal*sqrt(scalars(index_tke,k,iCell)) eddy_visc_v = c_k*l_vertical*sqrt(scalars(index_tke,k,iCell)) + ! testing + !eddy_visc_horz(k,iCell) = eddy_visc_h + !eddy_visc_vert(k,iCell) = eddy_visc_v + ! terms for the prognostic tke integration shear_production = eddy_visc_h*(d_11(k)**2 + d_22(k)**2 + d_12(k)**2) & @@ -271,37 +287,30 @@ subroutine smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, prandtl_horizontal_inv = 3. prandtl_vertical_inv = 1.0+(2.0*l_vertical/delta_z) ! going to need to store this off somewhere - ! eddy viscocities set here if we are running the 1.5 order prognostic tke scheme - ! eddy_visc_horz(k,iCell) = c_k*l_horizontal*sqrt(scalars(index_tke,k,iCell)) - ! eddy_visc_vert(k,iCell) = c_k*l_vertical*sqrt(scalars(index_tke,k,iCell)) - ! RHS term for the subgrid ke. tend_scalars(index_tke,k,iCell) = rho_zz(k,iCell)*( shear_production + buoyancy + dissipation ) end do - end if ! end of test_tke + else -!*************************************************** + call mpas_log_write(' in les_models, no les scheme for '//trim(config_les_model), messageType=MPAS_LOG_CRIT) + + end if ! end of config_les_model test end do ! loop over all owned cells (columns) - ! set up coefficients for 4th-order horizontal background filter - - h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 - h_theta_eddy_visc4 = h_mom_eddy_visc4 - - if(debug_dissipation) call mpas_log_write(' exiting smagorinsky_3d ') + if(debug_dissipation) call mpas_log_write(' les_models ') - end subroutine smagorinsky_3d + end subroutine les_models -!--------------------------------------- +!--------------------------------------- subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) - use mpas_atm_dimensions ! pull nVertLevels and num_scalars from here + use mpas_atm_dimensions ! pull nVertLevels and num_scalars from here integer, intent(in) :: cellStart, cellEnd, nCells integer, intent(in) :: index_qv, index_qc @@ -378,7 +387,7 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in end subroutine calculate_n2 -!--------------------------------------- +!--------------------------------------- subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & @@ -391,7 +400,7 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert delsq_u, delsq_vorticity, delsq_divergence, & u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here implicit none @@ -440,17 +449,17 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(out) :: tend_u_euler - ! local variables + ! local variables integer :: iEdge, cell1, cell2, vertex1, vertex2, iVertex, iCell, i, k real (kind=RKIND) :: r_dc, r_dv, u_diffusion, kdiffu, r, edge_sign, u_mix_scale real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp real (kind=RKIND), dimension(nVertLevels) :: u_mix -!$OMP BARRIER +!$OMP BARRIER - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). - ! First, storage to hold the result from the first del^2 computation. + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). + ! First, storage to hold the result from the first del^2 computation. delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 @@ -462,11 +471,11 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert r_dc = invDcEdge(iEdge) r_dv = min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) -!DIR$ IVDEP +!DIR$ IVDEP do k=1,nVertLevels - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv @@ -474,17 +483,17 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert kdiffu = 0.5*(kdiff(k,cell1)+kdiff(k,cell2)) - ! include 2nd-orer diffusion here + ! include 2nd-orer diffusion here + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & + rho_edge(k,iEdge)* kdiffu * u_diffusion * meshScalingDel2(iEdge) end do end do - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active - -!$OMP BARRIER + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active +!$OMP BARRIER do iVertex=vertexStart,vertexEnd delsq_vorticity(1:nVertLevels,iVertex) = 0.0 do i=1,vertexDegree @@ -508,8 +517,7 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert end do end do -!$OMP BARRIER - +!$OMP BARRIER do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -520,16 +528,16 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert r_dc = u_mix_scale * config_del4u_div_factor * invDcEdge(iEdge) r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) -!DIR$ IVDEP +!DIR$ IVDEP do k=1,nVertLevels - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant - ! - ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor - ! relative to the rotational part. The stability constraint on the divergence component is much less - ! stringent than the rotational part, and this flexibility may be useful. - ! + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant + ! + ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor + ! relative to the rotational part. The stability constraint on the divergence component is much less + ! stringent than the rotational part, and this flexibility may be useful. + ! u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion @@ -537,14 +545,13 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert end do end do - end if ! 4th order mixing is active - - ! - ! vertical mixing for u - 2nd order filter in physical (z) space - ! + end if ! 4th order mixing is active + ! + ! vertical mixing for u - 2nd order filter in physical (z) space + ! if ( v_mom_eddy_visc2 > 0.0 ) then - if (config_mix_full) then ! mix full state + if (config_mix_full) then ! mix full state do iEdge=edgeSolveStart,edgeSolveEnd @@ -568,9 +575,9 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert end do end do - else ! idealized cases where we mix on the perturbation from the initial 1-D state + else ! idealized cases where we mix on the perturbation from the initial 1-D state - do iEdge=edgeSolveStart,edgeSolveEnd + do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -597,9 +604,9 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert end do end do - end if ! mix perturbation state + end if ! mix perturbation state - end if ! vertical mixing of horizontal momentum + end if ! vertical mixing of horizontal momentum end subroutine u_dissipation @@ -849,9 +856,9 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end if ! mix perturbation state - end if ! vertical mixing of horizontal momentum for fixe viscosity + end if ! vertical mixing of horizontal momentum for les formulation - if ( config_les_model == "3d_smagorinsky") then + if ( config_les_model /= "none") then do iEdge=edgeSolveStart,edgeSolveEnd @@ -1159,7 +1166,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end if - if ( config_les_model == "3d_smagorinsky") then + if ( config_les_model /= "none") then do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes @@ -1505,7 +1512,7 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn end if - if ( config_les_model == "3d_smagorinsky") then + if ( config_les_model /= "none") then do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index f79485b5be..961ceaefa3 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5286,21 +5286,22 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end if - else if (config_les_model == "3d_smagorinsky") then + else if (config_les_model /= "none") then ! call mpas_log_write(' BV call, index qv, qc, tke $i $i $i ', intArgs=(/index_qv, index_qc, index_tke/)) call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) - call smagorinsky_3d( eddy_visc_horz, eddy_visc_vert, u, v, ur_cell, vr_cell, & - w, c_s, bn2, zgrid, config_len_disp, & - deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & - deformation_coef_c, deformation_coef_s, & - invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & - scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & - cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & - nCells, nEdges, nVertLevels, maxEdges, num_scalars ) + call les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, & + u, v, ur_cell, vr_cell, & + w, c_s, bn2, zgrid, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + deformation_coef_c, deformation_coef_s, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & + nCells, nEdges, nVertLevels, maxEdges, num_scalars ) end if @@ -5330,8 +5331,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end if ! tendency for density. - ! accumulate total water here for later use in w tendency calculation. - ! accumulate horizontal mass-flux !$acc parallel default(present) From 203fdef7c346af77fdcc0702e91e7bdcb10dddc1 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Tue, 24 Mar 2020 09:25:43 -0600 Subject: [PATCH 037/109] bug fixes and the addition of the Prandtl number formulation to the scalar mixing routines for the prognostic tke scheme. more testing to follow. --- .../dynamics/mpas_atm_dissipation_models.F | 61 +++++++++++++------ 1 file changed, 44 insertions(+), 17 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 9b1d122866..d99eb221d1 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -14,10 +14,13 @@ module mpas_atm_dissipation_models use mpas_log use mpas_derived_types, only : MPAS_LOG_CRIT - logical, parameter :: debug_dissipation = .true. + logical, parameter :: debug_dissipation = .false. logical, parameter :: les_test = .true. real (kind=RKIND), parameter :: tke_heat_flux = 0.24 real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 + real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 + real (kind=RKIND), parameter :: c_k = 0.25 + contains @@ -138,12 +141,12 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, real (kind=RKIND), dimension(nVertLevels) :: dudz, dvdz, dwdz real (kind=RKIND) :: rdz, def2, pr_inv, wk real (kind=RKIND) :: shear_production, buoyancy, dissipation, delta_z, delta_s, bv, tke_length, diss_length - real (kind=RKIND) :: l_horizontal, l_vertical, c_k, c_dissipation + real (kind=RKIND) :: l_horizontal, l_vertical, c_dissipation real (kind=RKIND) :: prandtl_horizontal_inv, prandtl_vertical_inv real (kind=RKIND) :: eddy_visc_h, eddy_visc_v logical, parameter :: test_tke=.true. - real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 + ! real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 if(debug_dissipation) call mpas_log_write(' begin les_models ') if(debug_dissipation) call mpas_log_write(' les scheme is '//trim(config_les_model)) @@ -243,7 +246,9 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) delta_s = ((config_len_disp**2)*delta_z)**(1./3.) bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon_bv ) - tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv + tke_length = delta_s + if(bv_freq2(k,iCell) .gt. 1.e-06) & + tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv diss_length = min(delta_s,max(tke_length,0.01*delta_s)) if(bv_freq2(k,iCell) <= 0) diss_length = delta_s @@ -264,8 +269,8 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, eddy_visc_v = c_k*l_vertical*sqrt(scalars(index_tke,k,iCell)) ! testing - !eddy_visc_horz(k,iCell) = eddy_visc_h - !eddy_visc_vert(k,iCell) = eddy_visc_v + eddy_visc_horz(k,iCell) = eddy_visc_h + eddy_visc_vert(k,iCell) = eddy_visc_v ! terms for the prognostic tke integration @@ -276,9 +281,8 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, ! dissipation - c_k = 0.25 c_dissipation = 1.9*c_k + max( 0.0, 0.93 - 1.9*c_k )*diss_length/delta_s - if( (k.eq. 1) .or. (k.eq.nVertLevels) ) c_dissipation = 3.9 + ! if( (k.eq. 1) .or. (k.eq.nVertLevels) ) c_dissipation = 3.9 dissipation = -c_dissipation*(scalars(index_tke,k,iCell)**(1.5))/diss_length @@ -1626,9 +1630,10 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo integer :: cell1, cell2, iEdge, iCell, i, k, iScalar real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp - real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux + real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux, prandtl_inverse real (kind=RKIND), dimension(num_scalars,nVertLevels+1) :: turb_vflux_scalars real (kind=RKIND) :: rho_k_at_w, zz_at_w + real (kind=RKIND) :: delta_z, delta_s, tke_length, bv_frequency2 logical, parameter :: vmix_scalars = .true. logical, parameter :: hmix_scalars = .true. @@ -1795,13 +1800,38 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes + + turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain turb_vflux(1) = 0. ! lower bc flux handled where ??? + + if ( config_les_model == "3d_smagorinsky") then + do k=2,nVertLevels + prandtl_inverse(k) = prandtl_inv + end do + else ! prognostic_1.5_order + do k=2,nVertLevels + delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) + delta_s = ((config_len_disp**2)*delta_z)**(1./3.) + bv_frequency2 = 0.5*(bv_freq2(k,iCell)+bv_freq2(k-1,iCell)) + tke_length = delta_s + if(bv_frequency2 .gt. 1.e-06) & + tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/sqrt(bv_frequency2) + prandtl_inverse(k) = 1. + 2.*tke_length/delta_z + end do + end if + do k=2,nVertLevels + + ! delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) + ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) + ! bv_frequency2 = 0.5*(bv_freq2(k)+bv_freq(k-1)) + ! bv = max( sqrt(abs(bv_frequency2)), epsilon_bv ) + rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) - turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) + turb_vflux(k) = - prandtl_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) end do ! test boundary conditions for supercell and les test cases @@ -1820,11 +1850,8 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do - end do - - if (mix_scalars .and. vmix_scalars) then + if (mix_scalars .and. vmix_scalars) then - do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes turb_vflux_scalars(:,nVertlevels+1) = 0. ! no turbulent flux out of the domain turb_vflux_scalars(:,1) = 0. ! lower bc flux handled where ??? @@ -1833,7 +1860,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) do iScalar=1,num_scalars - turb_vflux_scalars(iScalar,k) = - rho_k_at_w*zz_at_w*rdzu(k)* & + turb_vflux_scalars(iScalar,k) = - prandtl_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)* & (scalars(iScalar,k,iCell)-scalars(iScalar,k-1,iCell)) end do end do @@ -1858,9 +1885,9 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do - end do - end if ! mix scalars + + end do ! loop over cells (columns) end if From 1f442aecea508b0d492f34dc0651fa1272df0039 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Thu, 2 Apr 2020 11:38:42 -0600 Subject: [PATCH 038/109] changed Prandtl number to 1/3 for LES simulations in the MPAS_constants module. --- src/framework/mpas_constants.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/mpas_constants.F b/src/framework/mpas_constants.F index 2c8168510a..5822f9c0e6 100644 --- a/src/framework/mpas_constants.F +++ b/src/framework/mpas_constants.F @@ -53,7 +53,7 @@ module mpas_constants real (kind=RKIND), parameter :: cvpm = -cv / cp ! #endif real (kind=RKIND), parameter :: p0 = 1.0e5_RKIND !< Constant: 100000 Pa - real (kind=RKIND), parameter :: prandtl = 1.0_RKIND !< Constant: Prandtl number + real (kind=RKIND), parameter :: prandtl = 1.0_RKIND/3.0_RKIND !< Constant: Prandtl number contains From 57a88294e26633558ae83e0c40c41439d54e06d2 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Thu, 2 Apr 2020 11:40:56 -0600 Subject: [PATCH 039/109] implemented a perturbation coriolis term option for the LES cases. --- .../dynamics/mpas_atm_dissipation_models.F | 38 ++++++++++--------- .../dynamics/mpas_atm_time_integration.F | 15 ++++++++ 2 files changed, 35 insertions(+), 18 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index d99eb221d1..e0f802eae7 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -16,10 +16,12 @@ module mpas_atm_dissipation_models logical, parameter :: debug_dissipation = .false. logical, parameter :: les_test = .true. - real (kind=RKIND), parameter :: tke_heat_flux = 0.24 - real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 + !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour + real (kind=RKIND), parameter :: tke_heat_flux = 0.0 + !! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 ! ocean roughness length + real (kind=RKIND), parameter :: tke_drag_coefficient = 0.00935 real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 - real (kind=RKIND), parameter :: c_k = 0.25 + real (kind=RKIND), parameter :: c_k = 0.1 contains @@ -588,7 +590,7 @@ subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vert do k=1,nVertLevels u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & - - v_init(k) * sin( angleEdge(iEdge) ) + + v_init(k) * sin( angleEdge(iEdge) ) end do do k=2,nVertLevels-1 @@ -838,7 +840,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v do k=1,nVertLevels u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & - - v_init(k) * sin( angleEdge(iEdge) ) + + v_init(k) * sin( angleEdge(iEdge) ) end do do k=2,nVertLevels-1 @@ -1568,6 +1570,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo bv_freq2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars_dummy, mix_scalars, & config_les_model, & + uReconstructZonal, uReconstructMeridional, & tend_theta_euler ) @@ -1609,6 +1612,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzp real (kind=RKIND), dimension(nVertLevels+1, nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: uReconstructZonal, uReconstructMeridional real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: t_init @@ -1638,6 +1642,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo logical, parameter :: vmix_scalars = .true. logical, parameter :: hmix_scalars = .true. logical, parameter :: hmix4_scalars = .false. + real (kind=RKIND) :: moisture_flux, heat_flux, theta_m_flux, c_h, c_q if(debug_dissipation) then call mpas_log_write(' begin scalar_dissipation_3d ') @@ -1837,7 +1842,15 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! test boundary conditions for supercell and les test cases if( les_test ) then - turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY + moisture_flux = 0. + heat_flux = tke_heat_flux + + ! bulk formulation will go here. + + theta_m_flux = heat_flux*(1.0+(rv/rgas)*scalars(index_qv,1,iCell)) & + +(rv/rgas)*theta_m(1,iCell)*moisture_flux/rho_zz(k,iCell) + ! turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY + turb_vflux(1) = theta_m_flux*rho_zz(1,iCell) turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) else turb_vflux(1) = turb_vflux(2) @@ -1865,18 +1878,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do - ! test boundary conditions for supercell and les test cases - - ! need lower bc for qv here... - - ! if( les_test ) then - ! turb_vflux_scalars(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY - ! turb_vflux_scalars(nVertLevels+1) = turb_vflux_scalars(nVertLevels) - ! else - ! turb_vflux_scalars(1) = turb_vflux_scalars(2) - ! turb_vflux_scalars(nVertLevels+1) = turb_vflux_scalars(nVertLevels) - ! end if - + if( les_test ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv do k=1,nVertLevels do iScalar=1,num_scalars diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 961ceaefa3..5d65db2752 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5198,6 +5198,10 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: flux3, flux4 real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 + logical, parameter :: perturbation_coriolis = .true. + real (kind=RKIND), parameter :: coriolis_value = 1.e-04 + real (kind=RKIND) :: reference_u + flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ua*( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 @@ -5458,6 +5462,16 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end do end do + if (perturbation_coriolis) then ! this is correct only for constant f + do j = 1,nEdgesOnEdge(iEdge) + eoe = edgesOnEdge(j,iEdge) + do k=1,nVertLevels + reference_u = u_init(k) * cos(angleEdge(eoe)) - v_init(k) * sin(angleEdge(eoe)) + q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * coriolis_value + end do + end do + end if + !DIR$ IVDEP !$acc loop vector do k=1,nVertLevels @@ -5849,6 +5863,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm bn2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars, mix_scalars, & config_les_model, & + ur_cell, vr_cell, & tend_theta_euler ) From 7ddd21d10bc15436a7975e2d8ecba8920d6c4d7c Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Thu, 2 Apr 2020 11:42:04 -0600 Subject: [PATCH 040/109] introduced the sheared PBL test case for the LES implementation, including setting both u_init and v_init properly for the perturbation coriolis terms. --- .../mpas_init_atm_cases.F | 58 ++++++++++++++++--- 1 file changed, 50 insertions(+), 8 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 0160139fb8..2371016310 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -6267,7 +6267,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes real (kind=RKIND), pointer :: config_ztop real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta - real (kind=RKIND), dimension(:), pointer :: u_init, qv_init, angleEdge, fEdge, fVertex + real (kind=RKIND), dimension(:), pointer :: u_init, v_init, qv_init, angleEdge, fEdge, fVertex real (kind=RKIND) :: u_vel, v_vel, randx call mpas_pool_get_array(mesh, 'xCell', xCell) @@ -6336,6 +6336,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes call mpas_pool_get_array(mesh, 'dss', dss) 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, 'qv_init', qv_init) call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) call mpas_pool_get_array(mesh, 'fEdge', fEdge) @@ -6510,7 +6511,10 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes u_vel = atm_get_sounding('u',ztemp) v_vel = atm_get_sounding('v',ztemp) u(k,i) = cos(angleEdge(i))*u_vel - sin(angleEdge(i))*v_vel - if(i == 1 ) u_init(k) = u(k,i) + if(i == 1 ) then + u_init(k) = u_vel + v_init(k) = v_vel + end if end do end if end do @@ -6749,25 +6753,63 @@ real (kind=RKIND) function atm_get_sounding( variable, height ) atm_get_sounding = -999. if(variable == 'u') then - atm_get_sounding = 0. + atm_get_sounding = 15.0 else if (variable == 'v') then atm_get_sounding = 0. else if (variable == 'qv') then - atm_get_sounding = 0. + + atm_get_sounding = 0. ! dry sounding + ! atm_get_sounding = 0.010 + ! if(height .gt. 500.) atm_get_sounding = 0.004 + else if (variable == 'theta') then - if(height .le. 1000.) then + if(height .le. 500.) then atm_get_sounding = 300. - else if(height .le. 1150.) then - atm_get_sounding = 300. + (height-1000.)*8./150. + else if(height .le. 600.) then + atm_get_sounding = 300. + (height-500.)*3./100. else - atm_get_sounding = 308. + (height-1150.)*3./1000. + atm_get_sounding = 303. + (height-600.)*3./1000. end if + ! atm_get_sounding = atm_get_sounding - 10.0 ! for water case end if end function atm_get_sounding + real (kind=RKIND) function atm_get_sounding_1( variable, height ) + + implicit none + real (kind=RKIND), intent(in) :: height + character(len=*), intent(in) :: variable + + atm_get_sounding_1 = -999. + + if(variable == 'u') then + atm_get_sounding_1 = 10.0 + else if (variable == 'v') then + atm_get_sounding_1 = 0. + else if (variable == 'qv') then + + ! atm_get_sounding_1 = 0. ! dry sounding_1 + atm_get_sounding_1 = 0.010 + if(height .gt. 1000.) atm_get_sounding_1 = 0.004 + + else if (variable == 'theta') then + + if(height .le. 1000.) then + atm_get_sounding_1 = 300. + else if(height .le. 1150.) then + atm_get_sounding_1 = 300. + (height-1000.)*8./150. + else + atm_get_sounding_1 = 308. + (height-1150.)*3./1000. + end if + atm_get_sounding_1 = atm_get_sounding_1 - 10.0 ! for water case + + end if + + end function atm_get_sounding_1 + !----------- !----------------------------------------------------------------------- From 6212e0e5a61b821a2437f970095c660f55c73888 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Thu, 23 Apr 2020 13:59:49 -0600 Subject: [PATCH 041/109] Implemented SAS case sounding in LES initialization. --- .../mpas_init_atm_cases.F | 92 ++++++++++++++----- 1 file changed, 67 insertions(+), 25 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 2371016310..e9dc369a29 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -6248,7 +6248,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes real (kind=RKIND) :: r, xnutr real (kind=RKIND) :: ztemp, zd, zt, dz, str - real (kind=RKIND), dimension(nVertLevels ) :: qvb + real (kind=RKIND), dimension(nVertLevels ) :: qvb, qvp, zg real (kind=RKIND), dimension(nVertLevels ) :: t_init_1d real (kind=RKIND) :: d1, d2, d3, cof1, cof2 @@ -6580,6 +6580,8 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes ! qvb(k) = scalars(index_qv,k,1) ! QVB = 0 PRODUCES DRY REFERENCE STATE qvb(k) = 0. + qvp(k) = scalars(index_qv,k,1)*1000. + zg(k) = .5*(zgrid(k,1)+zgrid(k+1,1)) !********************************************************************* end do @@ -6596,10 +6598,10 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes end do !end of iteration loop - call mpas_log_write(' base state sounding ') - call mpas_log_write(' k, pb, rb, tb, rtb, t, rr, p, qvb') + call mpas_log_write(' sounding ') + call mpas_log_write(' k, zg, rb, tb, rtb, t, rr, p, qvp') do k=1,nVertLevels - call mpas_log_write('$i $r $r $r $r $r $r $r $r', intArgs=(/k/), realArgs=(/pb(k,1),rb(k,1),tb(k,1),rtb(k,1),t(k,1),rr(k,1),p(k,1),qvb(k)/)) + call mpas_log_write('$i $r $r $r $r $r $r $r $r', intArgs=(/k/), realArgs=(/zg(k),rb(k,1),tb(k,1),rtb(k,1),t(k,1),rr(k,1),p(k,1),qvp(k)/)) end do ! @@ -6751,32 +6753,39 @@ real (kind=RKIND) function atm_get_sounding( variable, height ) character(len=*), intent(in) :: variable atm_get_sounding = -999. +! SAS case sounding if(variable == 'u') then - atm_get_sounding = 15.0 + atm_get_sounding = 0.0 + else if (variable == 'v') then atm_get_sounding = 0. - else if (variable == 'qv') then - - atm_get_sounding = 0. ! dry sounding - ! atm_get_sounding = 0.010 - ! if(height .gt. 500.) atm_get_sounding = 0.004 else if (variable == 'theta') then - if(height .le. 500.) then - atm_get_sounding = 300. - else if(height .le. 600.) then - atm_get_sounding = 300. + (height-500.)*3./100. + if(height .le. 352.5) then + atm_get_sounding = 296.6 + else if(height .le. 442.5) then + atm_get_sounding = 296.6 + (height-352.5)*1.5/90. + else + atm_get_sounding = 298.1 + (height-442.5)*0.003 + end if + + else if (variable == 'qv') then + + if(height .le. 352.5) then + atm_get_sounding = 11.8/1000. + else if(height .le. 442.5) then + atm_get_sounding = 11.8/1000. - (height-352.5)*4.0/90./1000. else - atm_get_sounding = 303. + (height-600.)*3./1000. + atm_get_sounding = max(7.8/1000. - (height-442.5)*0.004/1000.,0.0) end if - ! atm_get_sounding = atm_get_sounding - 10.0 ! for water case end if end function atm_get_sounding + real (kind=RKIND) function atm_get_sounding_1( variable, height ) implicit none @@ -6786,30 +6795,63 @@ real (kind=RKIND) function atm_get_sounding_1( variable, height ) atm_get_sounding_1 = -999. if(variable == 'u') then - atm_get_sounding_1 = 10.0 + atm_get_sounding_1 = 15.0 else if (variable == 'v') then atm_get_sounding_1 = 0. else if (variable == 'qv') then - ! atm_get_sounding_1 = 0. ! dry sounding_1 - atm_get_sounding_1 = 0.010 - if(height .gt. 1000.) atm_get_sounding_1 = 0.004 + atm_get_sounding_1 = 0. ! dry sounding + ! atm_get_sounding_1 = 0.010 + ! if(height .gt. 500.) atm_get_sounding_1 = 0.004 else if (variable == 'theta') then - if(height .le. 1000.) then + if(height .le. 500.) then atm_get_sounding_1 = 300. - else if(height .le. 1150.) then - atm_get_sounding_1 = 300. + (height-1000.)*8./150. + else if(height .le. 600.) then + atm_get_sounding_1 = 300. + (height-500.)*3./100. else - atm_get_sounding_1 = 308. + (height-1150.)*3./1000. + atm_get_sounding_1 = 303. + (height-600.)*3./1000. end if - atm_get_sounding_1 = atm_get_sounding_1 - 10.0 ! for water case + ! atm_get_sounding_1 = atm_get_sounding_1 - 10.0 ! for water case end if end function atm_get_sounding_1 + real (kind=RKIND) function atm_get_sounding_2( variable, height ) + + implicit none + real (kind=RKIND), intent(in) :: height + character(len=*), intent(in) :: variable + + atm_get_sounding_2 = -999. + + if(variable == 'u') then + atm_get_sounding_2 = 10.0 + else if (variable == 'v') then + atm_get_sounding_2 = 0. + else if (variable == 'qv') then + + ! atm_get_sounding_2 = 0. ! dry sounding_2 + atm_get_sounding_2 = 0.010 + if(height .gt. 1000.) atm_get_sounding_2 = 0.004 + + else if (variable == 'theta') then + + if(height .le. 1000.) then + atm_get_sounding_2 = 300. + else if(height .le. 1150.) then + atm_get_sounding_2 = 300. + (height-1000.)*8./150. + else + atm_get_sounding_2 = 308. + (height-1150.)*3./1000. + end if + atm_get_sounding_2 = atm_get_sounding_2 - 10.0 ! for water case + + end if + + end function atm_get_sounding_2 + !----------- !----------------------------------------------------------------------- From 35910083c352652dff17021bbe45533d607376f5 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 14:22:38 -0700 Subject: [PATCH 042/109] Added the SAS LES time-varying lower boundary moisture and heat fluxes. --- .../dynamics/mpas_atm_dissipation_models.F | 53 +++++++++++++++++-- .../dynamics/mpas_atm_time_integration.F | 15 +++++- 2 files changed, 63 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index e0f802eae7..7fdf0e4794 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -15,7 +15,7 @@ module mpas_atm_dissipation_models use mpas_derived_types, only : MPAS_LOG_CRIT logical, parameter :: debug_dissipation = .false. - logical, parameter :: les_test = .true. + logical, parameter :: les_test = .false., les_sas_test = .true. !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour real (kind=RKIND), parameter :: tke_heat_flux = 0.0 !! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 ! ocean roughness length @@ -1535,6 +1535,8 @@ subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEn if( les_test ) then turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY + ! SAS case lower flux for theta_m - code goes here + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) else turb_vflux(1) = turb_vflux(2) @@ -1569,7 +1571,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo eddy_visc_horz, eddy_visc_vert, & bv_freq2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars_dummy, mix_scalars, & - config_les_model, & + config_les_model, time_of_day_seconds, & uReconstructZonal, uReconstructMeridional, & tend_theta_euler ) @@ -1586,6 +1588,8 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo integer, intent(in) :: num_scalars_dummy integer, intent(in) :: index_tke, index_qv + real (kind=RKIND), intent(in) :: time_of_day_seconds + logical, intent(in) :: config_mix_full, mix_scalars character (len=StrKIND) :: config_les_model @@ -1643,6 +1647,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo logical, parameter :: hmix_scalars = .true. logical, parameter :: hmix4_scalars = .false. real (kind=RKIND) :: moisture_flux, heat_flux, theta_m_flux, c_h, c_q + real (kind=RKIND) :: qv_cell, theta_m_cell, theta_cell if(debug_dissipation) then call mpas_log_write(' begin scalar_dissipation_3d ') @@ -1842,6 +1847,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! test boundary conditions for supercell and les test cases if( les_test ) then + moisture_flux = 0. heat_flux = tke_heat_flux @@ -1852,9 +1858,27 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY turb_vflux(1) = theta_m_flux*rho_zz(1,iCell) turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + + else if (les_sas_test) then + + ! if(iCell == 1) call mpas_log_write(' les_sas_test for theta and qv surface fluxes ') + qv_cell = scalars(index_qv,1,iCell) + theta_m_cell = theta_m(1,iCell) + theta_cell = theta_m_cell/(1.0+(rv/rgas)*qv_cell) + + call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) + if(iCell == 1) call mpas_log_write(' SAS t and qv fluxes, $r, $r ', realArgs=(/heat_flux, moisture_flux/)) + + theta_m_flux = heat_flux*(1.0+(rv/rgas)*qv_cell)+(rv/rgas)*theta_cell*moisture_flux + turb_vflux(1) = theta_m_flux*rho_zz(1,iCell) + moisture_flux = moisture_flux*rho_zz(1,iCell) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + else + turb_vflux(1) = turb_vflux(2) turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + end if @@ -1878,7 +1902,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do - if( les_test ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv + if( les_test .or. les_sas_test ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv do k=1,nVertLevels do iScalar=1,num_scalars @@ -1897,4 +1921,27 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end subroutine scalar_dissipation_3d_les +!----------- + + subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) + + implicit none + + real (kind=RKIND), intent(in) :: time_of_day_seconds + real (kind=RKIND), intent(out) :: heat_flux, moisture_flux + + real (kind=RKIND), parameter:: t_start_t_flux = 3600.*6.0 + real (kind=RKIND), parameter:: t_end_t_flux = 3600.*19.50 + real (kind=RKIND), parameter:: t_start_q_flux = 3600.*7.0 + real (kind=RKIND), parameter:: t_end_q_flux = 3600.*19.50 + real (kind=RKIND) :: rel_time_t_flux, rel_time_q_flux + + rel_time_t_flux = max(0.,(time_of_day_seconds - t_start_t_flux)/(t_end_t_flux - t_start_t_flux)) + rel_time_q_flux = max(0.,(time_of_day_seconds - t_start_q_flux)/(t_end_q_flux - t_start_q_flux)) + + heat_flux = max(0., 0.1*sin(pii*rel_time_t_flux)) + moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux)) + + end subroutine flux_les_sas + end module mpas_atm_dissipation_models diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 5d65db2752..f8fee790ff 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -24,7 +24,8 @@ module atm_time_integration use mpas_vector_reconstruction ! Added only clause to keep xlf90 from getting confused from the overloaded abs intrinsic in mpas_timekeeping use mpas_derived_types, only : MPAS_Time_type, MPAS_TimeInterval_type, MPAS_NOW - use mpas_timekeeping, only: mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+) + use mpas_timekeeping, only: MPAS_Time_type, MPAS_TimeInterval_type, mpas_get_clock_time, & + mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+), add_t_ti use mpas_timer #ifdef DO_PHYSICS @@ -5202,6 +5203,11 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), parameter :: coriolis_value = 1.e-04 real (kind=RKIND) :: reference_u + type (MPAS_Time_Type) :: currTime + integer :: H, M, S, S_n, S_d + integer :: ierr + real(kind=RKIND) :: time_of_day_seconds + flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ua*( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 @@ -5297,6 +5303,11 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) + currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) + call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) + time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*dt + ! call mpas_log_write(' les integration, timestep midpoint time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) + call les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, & u, v, ur_cell, vr_cell, & w, c_s, bn2, zgrid, config_len_disp, & @@ -5862,7 +5873,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eddy_visc_horz, eddy_visc_vert, & bn2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars, mix_scalars, & - config_les_model, & + config_les_model, time_of_day_seconds, & ur_cell, vr_cell, & tend_theta_euler ) From f77c123d939aa723e4fd266489cf6b7275cd680a Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 4 May 2020 12:25:35 -0600 Subject: [PATCH 043/109] changed the initialization for the random potential temperature preturbation, the Coriolis parameter and the horizontal wind field (u) to match the SAS cases configuration --- .../mpas_init_atm_cases.F | 43 +++++++++++++------ 1 file changed, 30 insertions(+), 13 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index e9dc369a29..12de5af3e9 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -6608,20 +6608,35 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes ! potential temperature perturbation ! - do i=1,nCells - do k = 1,4 ! same as in WRF - call random_number(randx) - thi(k,i) = thi(k,i) + 0.1*(randx-0.5) - t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) - end do +! do i=1,nCells +! do k = 1,nz1 ! same as in WRF +! call random_number(randx) +! thi(k,i) = thi(k,i) + 0.1*(randx-0.5) +! t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) +! end do +! end do + + do k = 1,nz1 ! same as in WRF + if(zg(k) .le. 397.0) then ! the SAS initial PBL height + do i=1,nCells + call random_number(randx) + thi(k,i) = thi(k,i) + 1.0*(randx-0.5) + t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) + end do + end if end do ! ! initial seed for tke ! - do i=1,nCells - do k = 1,nz1 - scalars(index_tke,k,i) = 0.1 - end do + scalars(index_tke,:,:) = 0. + + do k = 1,nz1 + if( zg(k) .le. 255.) then + do i=1,nCells + !! scalars(index_tke,k,i) = 0.1 + scalars(index_tke,k,i) = 0.4*((1.-(zg(k)/255.))**3) + end do + end if end do do itr=1,30 @@ -6708,11 +6723,13 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes ! Generate rotated Coriolis field - same settings as in WRF ! do iEdge=1,nEdges - fEdge(iEdge) = 1.e-04 + ! fEdge(iEdge) = 1.e-04 + fEdge(iEdge) = 7.2921e-05 end do do iVtx=1,nVertices - fVertex(iVtx) = 1.e-04 + ! fVertex(iVtx) = 1.e-04 + fVertex(iVtx) = 7.2921e-05 end do ! @@ -6756,7 +6773,7 @@ real (kind=RKIND) function atm_get_sounding( variable, height ) ! SAS case sounding if(variable == 'u') then - atm_get_sounding = 0.0 + atm_get_sounding = 2.0 ! SAS value else if (variable == 'v') then atm_get_sounding = 0. From b6f044a8a45816d55dbd9a1fd7ff9c6ae9828bf2 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 4 May 2020 12:27:55 -0600 Subject: [PATCH 044/109] Added a 3D diagnostic variable: the inverse Prandtl number used in the scalar mixing formulation in the prognostic LES scheme. This allows for computing it only once and also allows it to be output for use in off-line diagnostic calculation of the sub-grid fluxes. --- 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 f78ca1b2fb..9d1d5ac8a7 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1971,6 +1971,9 @@ + + From 2a9afcaac60b4626ce2bcc7fccf745198d1a9dde Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Mon, 4 May 2020 12:31:42 -0600 Subject: [PATCH 045/109] Threaded the 3D inverse Prandtl number through to the routines that need it in the prognostic LES models, and set its values appropriately. Also switched the hardwired formulation to isotropic mixing. --- .../dynamics/mpas_atm_dissipation_models.F | 48 +++++++++++-------- .../dynamics/mpas_atm_time_integration.F | 12 +++-- 2 files changed, 38 insertions(+), 22 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 7fdf0e4794..891cc6152a 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -99,7 +99,7 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, u, v, uCell, vCell, & w, c_s, bv_freq2, zgrid, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & - deformation_coef_c, deformation_coef_s, & + deformation_coef_c, deformation_coef_s, prandtl_3d_inv, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & @@ -115,6 +115,7 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: uCell real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: vCell real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: bv_freq2 + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(out) :: prandtl_3d_inv real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout) :: scalars real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1) :: tend_scalars @@ -249,22 +250,24 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, delta_s = ((config_len_disp**2)*delta_z)**(1./3.) bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon_bv ) tke_length = delta_s + ! isentropic mixing formulation if(bv_freq2(k,iCell) .gt. 1.e-06) & tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv + tke_length = min(tke_length, delta_z) diss_length = min(delta_s,max(tke_length,0.01*delta_s)) if(bv_freq2(k,iCell) <= 0) diss_length = delta_s ! non-isotropic mixing - l_horizontal = config_len_disp - l_vertical = min(delta_z,tke_length) - if(bv_freq2(k,iCell) <= 0) diss_length = delta_z + ! l_horizontal = config_len_disp + ! l_vertical = min(delta_z,tke_length) + ! if(bv_freq2(k,iCell) <= 0) diss_length = delta_z ! isotropic mixing - ! l_horizontal = min(delta_s,tke_length) - ! if(bv_freq2(k,iCell) <= 0) diss_length = delta_s - ! l_vertical = l_horizontal + l_horizontal = min(delta_s,tke_length) + if(bv_freq2(k,iCell) <= 0) diss_length = delta_s + l_vertical = l_horizontal ! eddy viscocities set here if we are running the 1.5 order prognostic tke scheme eddy_visc_h = c_k*l_horizontal*sqrt(scalars(index_tke,k,iCell)) @@ -291,7 +294,8 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, ! computing eddy viscosities ********* prandtl_horizontal_inv = 3. - prandtl_vertical_inv = 1.0+(2.0*l_vertical/delta_z) ! going to need to store this off somewhere + prandtl_3d_inv(k,iCell) = 1.0+(2.0*l_vertical/delta_z) + ! RHS term for the subgrid ke. @@ -1566,6 +1570,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo config_mix_full, t_init, zgrid, & rdzw, rdzu, fzm, fzp, & v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + prandtl_3d_inv, & delsq_theta, & theta_m, rho_edge, rho_zz, zz, & eddy_visc_horz, eddy_visc_vert, & @@ -1621,6 +1626,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: t_init real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: bv_freq2 + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: prandtl_3d_inv real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout) :: tend_scalars real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m @@ -1819,16 +1825,20 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo do k=2,nVertLevels prandtl_inverse(k) = prandtl_inv end do - else ! prognostic_1.5_order - do k=2,nVertLevels - delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) - delta_s = ((config_len_disp**2)*delta_z)**(1./3.) - bv_frequency2 = 0.5*(bv_freq2(k,iCell)+bv_freq2(k-1,iCell)) - tke_length = delta_s - if(bv_frequency2 .gt. 1.e-06) & - tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/sqrt(bv_frequency2) - prandtl_inverse(k) = 1. + 2.*tke_length/delta_z - end do + else ! prognostic_1.5_order, isentropic mixing length + ! do k=2,nVertLevels + ! delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) + ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) + ! bv_frequency2 = 0.5*(bv_freq2(k,iCell)+bv_freq2(k-1,iCell)) + ! tke_length = delta_s + ! if(bv_frequency2 .gt. 1.e-06) & + ! tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/sqrt(bv_frequency2) + ! tke_length = min(delta_z,tke_length) + ! prandtl_inverse(k) = 1. + 2.*tke_length/delta_z + ! end do + + prandtl_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) + end if do k=2,nVertLevels @@ -1940,7 +1950,7 @@ subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) rel_time_q_flux = max(0.,(time_of_day_seconds - t_start_q_flux)/(t_end_q_flux - t_start_q_flux)) heat_flux = max(0., 0.1*sin(pii*rel_time_t_flux)) - moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux)) + moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux))/1000. end subroutine flux_les_sas diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index f8fee790ff..58ee52ffbd 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4816,6 +4816,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c2, deformation_coef_s2, deformation_coef_cs real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c, deformation_coef_s + real (kind=RKIND), dimension(:,:), pointer :: prandtl_3d_inv + real(kind=RKIND), dimension(:,:), pointer :: tend_w_pgf, tend_w_buoy @@ -4892,6 +4894,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(diag, 'pressure_base', pressure_b) call mpas_pool_get_array(diag, 'h_divergence', h_divergence) call mpas_pool_get_array(diag, 'exner', exner) + call mpas_pool_get_array(diag, 'prandtl_3d_inv', prandtl_3d_inv) + call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) @@ -4995,7 +4999,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_les_model, & - config_del4u_div_factor, & + prandtl_3d_inv, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & config_mpas_cam_coef, & @@ -5023,7 +5027,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_les_model, & - config_del4u_div_factor, & + prandtl_3d_inv, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & config_mpas_cam_coef, & @@ -5087,6 +5091,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_horz real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1) :: bn2 + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: prandtl_3d_inv real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign real (kind=RKIND), dimension(vertexDegree,nVertices+1) :: edgesOnVertex_sign real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw_save @@ -5312,7 +5317,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm u, v, ur_cell, vr_cell, & w, c_s, bn2, zgrid, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & - deformation_coef_c, deformation_coef_s, & + deformation_coef_c, deformation_coef_s, prandtl_3d_inv, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & @@ -5868,6 +5873,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm config_mix_full, t_init, zgrid, & rdzw, rdzu, fzm, fzp, & v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + prandtl_3d_inv, & delsq_theta, & theta_m, rho_edge, rho_zz, zz, & eddy_visc_horz, eddy_visc_vert, & From 7bef48fb31cdd8c178be5a328fd87cf2e3e6315e Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 13 May 2020 16:00:22 -0600 Subject: [PATCH 046/109] ustm passed to u_dissipation_3d, diag_physics pool accessed --- .../dynamics/mpas_atm_dissipation_models.F | 3 +- .../dynamics/mpas_atm_time_integration.F | 39 ++++++++++++------- 2 files changed, 28 insertions(+), 14 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 891cc6152a..b44e1ebbab 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -633,7 +633,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & fzm, fzp, config_les_model, & delsq_u, delsq_vorticity, delsq_divergence, & - u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) + u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, tend_u_euler ) use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here @@ -691,6 +691,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_divergence real (kind=RKIND), dimension(nVertLevels), intent(in) :: u_init, v_init + real (kind=RKIND), dimension(nCells+1), intent(in) :: ustm real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(out) :: tend_u_euler diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 58ee52ffbd..c32c7a5801 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1149,6 +1149,14 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) end if call mpas_timer_start('atm_compute_dyn_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_subpool(block % structs, 'diag_physics', diag_physics) + call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) allocate(delsq_theta(nVertLevels,nCells+1)) allocate(delsq_w(nVertLevels,nCells+1)) @@ -1172,15 +1180,16 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !$acc end parallel !$OMP PARALLEL DO - do thread=1,nThreads - call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, block % configs, nVertLevels, rk_step, dt, & - 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 + do thread=1,nThreads + call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, diag_physics, & + block % configs, nVertLevels, rk_step, dt, & + 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(delsq_theta) @@ -4736,7 +4745,7 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge end subroutine atm_advance_scalars_mono_work - subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, nVertLevels, rk_step, dt, & + subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_physics, configs, nVertLevels, rk_step, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -4762,6 +4771,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, type (mpas_pool_type), intent(in) :: state type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: diag_physics type (mpas_pool_type), intent(in) :: configs integer, intent(in) :: nVertLevels ! for allocating stack variables integer, intent(in) :: rk_step @@ -4899,6 +4909,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) + call mpas_pool_get_array(diag_physics,'ustm'  ,ustm  ) + call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) @@ -5005,7 +5017,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & - rthdynten, & + tend_rtheta_adv, rthdynten, ustm, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -5033,7 +5045,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & - rthdynten, & + tend_rtheta_adv, rthdynten, ustm, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -5091,6 +5103,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_horz real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1) :: bn2 + real (kind=RKIND), dimension(nCells+1) :: ustm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: prandtl_3d_inv real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign real (kind=RKIND), dimension(vertexDegree,nVertices+1) :: edgesOnVertex_sign @@ -5533,7 +5546,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & fzm, fzp, config_les_model, & delsq_u, delsq_vorticity, delsq_divergence, & - u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, tend_u_euler ) + u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, tend_u_euler ) ! else ! this is the original MPAS dissipation code ! From f2ae5beb59154911fa6f98348b82ea7156878fa5 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 15 May 2020 14:08:27 -0600 Subject: [PATCH 047/109] ustm add pointer remove blanks in pool statement --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 3 ++- 1 file changed, 2 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 c32c7a5801..96e74f7202 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4817,6 +4817,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys real (kind=RKIND), dimension(:), pointer :: rdzu, rdzw, fzm, fzp, qv_init real (kind=RKIND), dimension(:,:), pointer :: t_init + real (kind=RKIND), dimension(:), pointer:: ustm real (kind=RKIND), pointer :: cf1, cf2, cf3 @@ -4909,7 +4910,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) - call mpas_pool_get_array(diag_physics,'ustm'  ,ustm  ) + call mpas_pool_get_array(diag_physics,'ustm',ustm) call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) From 1ab69a02c4c0a1773e636c8090abe78f52c935fb Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 3 Jun 2020 15:09:15 -0600 Subject: [PATCH 048/109] add les_model check to bypass pbl calls --- src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F index 72a411aeba..43837ee27c 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F @@ -775,6 +775,7 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics bl_mynn_tkeadvect character(len=StrKIND),pointer:: pbl_scheme + character(len=StrKIND),pointer:: config_les_model integer,pointer:: bl_mynn_cloudpdf, & bl_mynn_mixlength, & @@ -813,6 +814,7 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics call mpas_pool_get_config(configs,'config_do_DAcycling',config_do_DAcycling) call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) call mpas_pool_get_config(configs,'config_pbl_scheme' ,pbl_scheme ) + call mpas_pool_get_config(configs, 'config_les_model', config_les_model) !copy MPAS arrays to local arrays: call pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,ite) @@ -820,6 +822,7 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics initflag = 1 if(config_do_restart .or. itimestep > 1) initflag = 0 + if(config_les_model == "none") then pbl_select: select case (trim(pbl_scheme)) case("bl_ysu") @@ -964,6 +967,8 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics case default end select pbl_select + + endif ! les skip pbl !copy local arrays to MPAS grid: call pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) From b6f5cba0ddda660c118f99e333304262535880e0 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 17 Jun 2020 15:56:42 -0600 Subject: [PATCH 049/109] add time_of_day_seconds calculation (compiles) --- .../physics/mpas_atmphys_driver_sfclayer.F | 42 +++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index afde4fa523..3435ecbe60 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -8,7 +8,11 @@ !================================================================================================================= module mpas_atmphys_driver_sfclayer use mpas_kind_types + use mpas_derived_types use mpas_pool_routines +! use mpas_timekeeping, only: MPAS_Time_type, MPAS_TimeInterval_type, mpas_get_clock_time, & +! mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+), add_t_ti + use mpas_timekeeping, only: MPAS_Time_type, mpas_get_clock_time, mpas_get_time use mpas_timer, only : mpas_timer_start, mpas_timer_stop use mpas_atmphys_constants @@ -32,6 +36,7 @@ module mpas_atmphys_driver_sfclayer integer,parameter,private:: iz0tlnd = 0 !=0,(Carlson-Boland). integer,parameter,private:: scm_force_flux = 0 !SCM surface forcing by surface fluxes. !0=no 1=yes (WRF single column model option only). + type (MPAS_Clock_type), pointer, private :: clock !MPAS driver for parameterization of the surface layer. !Laura D. Fowler (send comments to laura@ucar.edu). @@ -854,6 +859,7 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite logical,pointer:: config_do_restart,config_frac_seaice character(len=StrKIND),pointer:: sfclayer_scheme real(kind=RKIND),dimension(:),pointer:: areaCell + real(kind=RKIND),pointer:: config_dt !local variables: integer:: initflag @@ -863,6 +869,11 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite character(len=StrKIND):: errmsg integer:: errflg + type (MPAS_Time_Type) :: currTime + integer :: H, M, S, S_n, S_d + integer :: ierr + real(kind=RKIND) :: time_of_day_seconds + !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_sfclayer:') @@ -874,6 +885,7 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) + call mpas_pool_get_config(configs,'config_dt',config_dt) call mpas_pool_get_array(mesh,'areaCell',areaCell) @@ -889,6 +901,12 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite case("sf_monin_obukhov") call mpas_timer_start('sf_monin_obukhov') + + currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) + call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) + time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*config_dt + call mpas_log_write(' sfclay, time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) + call sfclay( & p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & u3d = u_p , v3d = v_p , qv3d = qv_p , & @@ -1087,6 +1105,30 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite end subroutine driver_sfclayer + subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) + + implicit none + + real (kind=RKIND), intent(in) :: time_of_day_seconds + real (kind=RKIND), intent(out) :: heat_flux, moisture_flux + + real (kind=RKIND), parameter:: t_start_t_flux = 3600.*6.0 + real (kind=RKIND), parameter:: t_end_t_flux = 3600.*19.50 + real (kind=RKIND), parameter:: t_start_q_flux = 3600.*7.0 + real (kind=RKIND), parameter:: t_end_q_flux = 3600.*19.50 + real (kind=RKIND) :: rel_time_t_flux, rel_time_q_flux + + rel_time_t_flux = max(0.,(time_of_day_seconds - t_start_t_flux)/(t_end_t_flux - t_start_t_flux)) + rel_time_q_flux = max(0.,(time_of_day_seconds - t_start_q_flux)/(t_end_q_flux - t_start_q_flux)) + + heat_flux = max(0., 0.1*sin(pii*rel_time_t_flux)) + moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux))/1000. + + end subroutine flux_les_sas + + + + !================================================================================================================= end module mpas_atmphys_driver_sfclayer !================================================================================================================= From d6d42f0de61cdef68009bdc4827f5ef4f346996c Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 23 Jun 2020 14:55:07 -0600 Subject: [PATCH 050/109] add flux_les_sas call in driver_sfclayer routine --- src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index 3435ecbe60..bc0007eb7a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -873,6 +873,7 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite integer :: H, M, S, S_n, S_d integer :: ierr real(kind=RKIND) :: time_of_day_seconds + real(kind=RKIND) :: heat_flux, moisture_flux !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') @@ -906,6 +907,7 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*config_dt call mpas_log_write(' sfclay, time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) + call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) call sfclay( & p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & From a7a1dc58ee7988b367cf21a7e1aefe805e438446 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 23 Jun 2020 15:18:51 -0600 Subject: [PATCH 051/109] add fluxes to sfclay arguments and pass in --- src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F | 6 ++++++ src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F | 5 ++++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index bc0007eb7a..bc379217b9 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -874,6 +874,7 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite integer :: ierr real(kind=RKIND) :: time_of_day_seconds real(kind=RKIND) :: heat_flux, moisture_flux + logical :: specified_flux !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') @@ -908,6 +909,7 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*config_dt call mpas_log_write(' sfclay, time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) + specified_flux = .true. call sfclay( & p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & @@ -932,6 +934,8 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite 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 , & + heat_flux = heat_flux , moisture_flux = moisture_flux , & + specified_flux = specified_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 & @@ -961,6 +965,8 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite 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 , & + heat_flux = heat_flux , moisture_flux = moisture_flux , & + specified_flux = specified_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 2b3ba578f0..d9709a5547 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -25,7 +25,8 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & ustm,ck,cka,cd,cda, & - isftcflx,iz0tlnd,scm_force_flux) + isftcflx,iz0tlnd,scm_force_flux, & + heat_flux, moisture_flux, specified_flux ) !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- @@ -184,6 +185,8 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX + REAL, INTENT(IN ) :: heat_flux, moisture_flux + LOGICAL, INTENT(IN ) :: specified_flux REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT ) :: QSFC From e6d26f2bf42aebc84f98d14de2f94aa1cd4848f8 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 30 Jul 2020 10:44:57 -0600 Subject: [PATCH 052/109] pass heat flux args to sfclay1d --- src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F | 4 ++++ 1 file changed, 4 insertions(+) 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 d9709a5547..bd614cb359 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -246,6 +246,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT, & P1000mb, & + heat_flux, moisture_flux, specified_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -271,6 +272,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & P1000mb, & + heat_flux, moisture_flux, specified_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -292,6 +294,8 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT REAL, INTENT(IN ) :: P1000mb + REAL, INTENT(IN ) :: heat_flux, moisture_flux + LOGICAL, INTENT(IN ) :: specified_flux ! REAL, DIMENSION( ims:ime ) , & INTENT(IN ) :: MAVAIL, & From 460c8b5dc2113e9bfd72696c0d653e03ff11603c Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 30 Jul 2020 11:11:56 -0600 Subject: [PATCH 053/109] copy specified fluxes to hfx and qfx before sfclay1d --- .../physics/physics_wrf/module_sf_sfclay.F | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) 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 bd614cb359..948f6e52ce 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -230,6 +230,13 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & T1D(i) =T3D(i,1,j) ENDDO + IF(specified_flux)THEN + DO i=its,ite + HFX(i,j)=heat_flux + QFX(i,j)=moisture_flux + ENDDO + ENDIF + ! Sending array starting locations of optional variables may cause ! troubles, so we explicitly change the call. @@ -246,7 +253,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT, & P1000mb, & - heat_flux, moisture_flux, specified_flux, & + specified_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -272,7 +279,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & P1000mb, & - heat_flux, moisture_flux, specified_flux, & + specified_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -294,7 +301,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT REAL, INTENT(IN ) :: P1000mb - REAL, INTENT(IN ) :: heat_flux, moisture_flux LOGICAL, INTENT(IN ) :: specified_flux ! REAL, DIMENSION( ims:ime ) , & From fb5e94f36e79b1ae266cde5afc14df7e76e17b27 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 30 Jul 2020 15:51:56 -0600 Subject: [PATCH 054/109] add MOL and BR calculations to sfclay1d --- .../physics/physics_wrf/module_sf_sfclay.F | 10 ++++++++++ 1 file changed, 10 insertions(+) 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 948f6e52ce..7d726e40ae 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -398,6 +398,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & REAL :: FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,GZ0OZQ,GZ0OZT REAL :: ZW, ZN1, ZN2 REAL :: Z0T, CZC + REAL :: USTI !------------------------------------------------------------------- KL=kte @@ -544,6 +545,15 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & 260 CONTINUE + IF(specified_flux)THEN +! Need to recalculate MOL and BR when HFX is given and TSK is not used + DO I=ITS,ITE +! MOL is THETA* + USTI = MAX(UST(I),0.01) + MOL(I) = HFX(I)/(RHOX(I)*CP*USTI) + BR(I) = KARMAN*GOVRTH(I)*ZA(I)*MOL(I)/(USTI*USTI)/GZ1OZ0(I) + ENDDO + ENDIF ! !-----DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATED STABILITY CLASS: ! From 88df14a5bf98a19db023dfb58954379ed3874659 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 12 Aug 2020 14:48:22 -0600 Subject: [PATCH 055/109] add ustm drag in u_dissipation_3d les_sas_test --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index b44e1ebbab..90b843168b 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -705,6 +705,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux real (kind=RKIND) :: rho_k_cell1, rho_k_cell2, rho_k_at_w real (kind=RKIND) :: zz_cell1, zz_cell2, zz_at_w + real (kind=RKIND) :: ust_edge real (kind=RKIND) :: velocity_magnitude @@ -895,6 +896,11 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v velocity_magnitude = sqrt(u(1,iEdge)**2 + v(1,iEdge)**2) turb_vflux(1) = -rho_edge(1,iEdge)*tke_drag_coefficient*u(1,iEdge)*velocity_magnitude turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + else if (les_sas_test) then + ust_edge = 0.5*(ustm(cell1) + ustm(cell2)) + velocity_magnitude = max(sqrt(u(1,iEdge)**2 + v(1,iEdge)**2),0.1) + turb_vflux(1) = -rho_edge(1,iEdge)*ust_edge*ust_edge*(u(1,iEdge)/velocity_magnitude) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) ! end test conditions else ! test conditions for supercell case From 5c9feb4e8a7fa6a7a5e5f53b2ca5d876ca8e96fa Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 13 Aug 2020 10:07:27 -0600 Subject: [PATCH 056/109] skip hfx and qfx calcs in sfclay for specified_flux --- src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F | 2 ++ 1 file changed, 2 insertions(+) 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 7d726e40ae..77a115231d 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -844,6 +844,8 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & 330 CONTINUE ! 335 CONTINUE + + IF(specified_flux) GOTO 410 !-----COMPUTE THE SURFACE SENSIBLE AND LATENT HEAT FLUXES: IF ( PRESENT(SCM_FORCE_FLUX) ) THEN From d0d418d2bcdc914015df02031bfa0b6e83f42e36 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 13 Aug 2020 16:02:52 -0600 Subject: [PATCH 057/109] pass hfx and qfx to dissipation and use for les_sas --- .../dynamics/mpas_atm_dissipation_models.F | 6 +++++- .../dynamics/mpas_atm_time_integration.F | 11 +++++++---- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 90b843168b..b19fd9551c 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1585,6 +1585,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo index_tke, index_qv, num_scalars_dummy, mix_scalars, & config_les_model, time_of_day_seconds, & uReconstructZonal, uReconstructMeridional, & + hfx, qfx, & tend_theta_euler ) @@ -1641,6 +1642,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge + real (kind=RKIND), dimension(nCells+1), intent(in) :: hfx, qfx real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler @@ -1883,7 +1885,9 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo theta_m_cell = theta_m(1,iCell) theta_cell = theta_m_cell/(1.0+(rv/rgas)*qv_cell) - call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) +! call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) + heat_flux = hfx(iCell)/rho_zz(1,iCell)/cp + moisture_flux = qfx(iCell) if(iCell == 1) call mpas_log_write(' SAS t and qv fluxes, $r, $r ', realArgs=(/heat_flux, moisture_flux/)) theta_m_flux = heat_flux*(1.0+(rv/rgas)*qv_cell)+(rv/rgas)*theta_cell*moisture_flux diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 96e74f7202..2c78768b84 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4817,7 +4817,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys real (kind=RKIND), dimension(:), pointer :: rdzu, rdzw, fzm, fzp, qv_init real (kind=RKIND), dimension(:,:), pointer :: t_init - real (kind=RKIND), dimension(:), pointer:: ustm + real (kind=RKIND), dimension(:), pointer:: ustm, hfx, qfx real (kind=RKIND), pointer :: cf1, cf2, cf3 @@ -4911,6 +4911,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) call mpas_pool_get_array(diag_physics,'ustm',ustm) + call mpas_pool_get_array(diag_physics,'hfx',hfx) + call mpas_pool_get_array(diag_physics,'qfx',qfx) call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) @@ -5018,7 +5020,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & - tend_rtheta_adv, rthdynten, ustm, & + tend_rtheta_adv, rthdynten, ustm, hfx, qfx, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -5046,7 +5048,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & - tend_rtheta_adv, rthdynten, ustm, & + tend_rtheta_adv, rthdynten, ustm, hfx, qfx, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -5104,7 +5106,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_horz real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1) :: bn2 - real (kind=RKIND), dimension(nCells+1) :: ustm + real (kind=RKIND), dimension(nCells+1) :: ustm, hfx, qfx real (kind=RKIND), dimension(nVertLevels,nCells+1) :: prandtl_3d_inv real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign real (kind=RKIND), dimension(vertexDegree,nVertices+1) :: edgesOnVertex_sign @@ -5895,6 +5897,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm index_tke, index_qv, num_scalars, mix_scalars, & config_les_model, time_of_day_seconds, & ur_cell, vr_cell, & + hfx, qfx, & tend_theta_euler ) From 3121ce5a425b484da045cd97b25bf23268f644d7 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 18 Aug 2020 11:44:13 -0600 Subject: [PATCH 058/109] comment out duplicate flux_les_sas in dissipiation module --- .../dynamics/mpas_atm_dissipation_models.F | 28 +++++++++---------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index b19fd9551c..501efd8df9 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1944,25 +1944,25 @@ end subroutine scalar_dissipation_3d_les !----------- - subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) +! subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) - implicit none +! implicit none - real (kind=RKIND), intent(in) :: time_of_day_seconds - real (kind=RKIND), intent(out) :: heat_flux, moisture_flux +! real (kind=RKIND), intent(in) :: time_of_day_seconds +! real (kind=RKIND), intent(out) :: heat_flux, moisture_flux - real (kind=RKIND), parameter:: t_start_t_flux = 3600.*6.0 - real (kind=RKIND), parameter:: t_end_t_flux = 3600.*19.50 - real (kind=RKIND), parameter:: t_start_q_flux = 3600.*7.0 - real (kind=RKIND), parameter:: t_end_q_flux = 3600.*19.50 - real (kind=RKIND) :: rel_time_t_flux, rel_time_q_flux +! real (kind=RKIND), parameter:: t_start_t_flux = 3600.*6.0 +! real (kind=RKIND), parameter:: t_end_t_flux = 3600.*19.50 +! real (kind=RKIND), parameter:: t_start_q_flux = 3600.*7.0 +! real (kind=RKIND), parameter:: t_end_q_flux = 3600.*19.50 +! real (kind=RKIND) :: rel_time_t_flux, rel_time_q_flux - rel_time_t_flux = max(0.,(time_of_day_seconds - t_start_t_flux)/(t_end_t_flux - t_start_t_flux)) - rel_time_q_flux = max(0.,(time_of_day_seconds - t_start_q_flux)/(t_end_q_flux - t_start_q_flux)) +! rel_time_t_flux = max(0.,(time_of_day_seconds - t_start_t_flux)/(t_end_t_flux - t_start_t_flux)) +! rel_time_q_flux = max(0.,(time_of_day_seconds - t_start_q_flux)/(t_end_q_flux - t_start_q_flux)) - heat_flux = max(0., 0.1*sin(pii*rel_time_t_flux)) - moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux))/1000. +! heat_flux = max(0., 0.1*sin(pii*rel_time_t_flux)) +! moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux))/1000. - end subroutine flux_les_sas +! end subroutine flux_les_sas end module mpas_atm_dissipation_models From af3233d053950096aeb8d3fa4d5df40582722c58 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 18 Aug 2020 11:51:02 -0600 Subject: [PATCH 059/109] Set dummy TSK and UST=USTM (no VCONV) --- .../physics/physics_wrf/module_sf_sfclay.F | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) 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 77a115231d..9739b08786 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -410,10 +410,16 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & !----CONVERT GROUND TEMPERATURE TO POTENTIAL TEMPERATURE: ! DO 5 I=its,ite - TGDSA(I)=TSK(I) + IF(.not.specified_flux)THEN + TGDSA(I)=TSK(I) ! PSFC cb -! THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP - THGB(I)=TSK(I)*(P1000mb/PSFCPA(I))**ROVCP +! THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP + THGB(I)=TSK(I)*(P1000mb/PSFCPA(I))**ROVCP + ELSE +! with specified_flux TSK value is not input and given value will not affect USTM + TGDSA(I)=300. + THGB(I)=300.*(P1000mb/PSFCPA(I))**ROVCP + ENDIF 5 CONTINUE ! !-----DECOUPLE FLUX-FORM VARIABLES TO GIVE U,V,T,THETA,THETA-VIR., @@ -819,6 +825,8 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & WSPDI(I)=SQRT(UX(I)*UX(I)+VX(I)*VX(I)) IF ( PRESENT(USTM) ) THEN USTM(I)=0.5*USTM(I)+0.5*KARMAN*WSPDI(I)/PSIX +! For specified_flux VCONV effect not added to UST that will be used for ZOL + IF(specified_flux)UST(I)=USTM(I) ENDIF U10(I)=UX(I)*PSIX10/PSIX V10(I)=VX(I)*PSIX10/PSIX From 16637caa1cf3f3a2369f84980976b88a6ff3b1dd Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 18 Aug 2020 14:38:11 -0600 Subject: [PATCH 060/109] sign correction for MOL --- src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 9739b08786..36e53d11f0 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -556,7 +556,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & DO I=ITS,ITE ! MOL is THETA* USTI = MAX(UST(I),0.01) - MOL(I) = HFX(I)/(RHOX(I)*CP*USTI) + MOL(I) = - HFX(I)/(RHOX(I)*CP*USTI) BR(I) = KARMAN*GOVRTH(I)*ZA(I)*MOL(I)/(USTI*USTI)/GZ1OZ0(I) ENDDO ENDIF From 210df8e127ebe3363fb8a5aa7627ea1abb00d0c2 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 19 Aug 2020 10:59:52 -0600 Subject: [PATCH 061/109] pass clock atm_do_timestep to physics_driver to driver_sfclayer --- src/core_atmosphere/mpas_atm_core.F | 2 +- src/core_atmosphere/physics/mpas_atmphys_driver.F | 7 ++++--- src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F | 4 +++- 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index f7d04a1f0c..ce9875cc89 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -1015,7 +1015,7 @@ subroutine atm_do_timestep(domain, dt, itimestep) !proceed with physics if moist_physics is set to true: if(moist_physics) then call physics_timetracker(domain,dt,clock,itimestep,xtime_s) - call physics_driver(domain,itimestep,xtime_s) + call physics_driver(domain,clock,itimestep,xtime_s) endif #endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index 8e31672657..5d9d5d092c 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -108,12 +108,13 @@ module mpas_atmphys_driver !================================================================================================================= - subroutine physics_driver(domain,itimestep,xtime_s) + subroutine physics_driver(domain,clock,itimestep,xtime_s) !================================================================================================================= !input arguments: integer,intent(in):: itimestep real(kind=RKIND),intent(in):: xtime_s + type(MPAS_Clock_type),intent(in):: clock !inout arguments: type(domain_type),intent(inout):: domain @@ -269,8 +270,8 @@ subroutine physics_driver(domain,itimestep,xtime_s) call allocate_sfclayer(block%configs) !$OMP PARALLEL DO do thread=1,nThreads - call driver_sfclayer(itimestep,block%configs,mesh,diag_physics,sfc_input, & - cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + call driver_sfclayer(clock,itimestep,block%configs,mesh,diag_physics,sfc_input, & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO call deallocate_sfclayer(block%configs) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index bc379217b9..791d933405 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -841,10 +841,12 @@ subroutine init_sfclayer(configs) end subroutine init_sfclayer !================================================================================================================= - subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) + subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,its,ite) !================================================================================================================= !input and inout arguments: + type(MPAS_Clock_type),intent(in):: clock + type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: sfc_input From eba2aeec2a673c0a64a19e5de1f2f43f8b758589 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 19 Aug 2020 15:29:14 -0600 Subject: [PATCH 062/109] put k loop around prandtl_inverse calc in dissipation --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 501efd8df9..71c694c9a4 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1846,7 +1846,9 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! prandtl_inverse(k) = 1. + 2.*tke_length/delta_z ! end do - prandtl_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) + do k=2,nVertLevels + prandtl_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) + end do end if From 9895ad556b19bccbc56353f7e3580338a04ca012 Mon Sep 17 00:00:00 2001 From: Bill Skamarock Date: Fri, 25 Sep 2020 14:31:17 -0600 Subject: [PATCH 063/109] bug fixes - fixed an uninitialized value in the w turbulent flux at the model top, and fixed a problem with the variable prandtl_inv in the scalar 3d mixing routine. --- .../dynamics/mpas_atm_dissipation_models.F | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 71c694c9a4..7d170c8bd3 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1191,6 +1191,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*zz(k,iCell) & *rdzu(k)*(w(k+1,iCell)-w(k,iCell)) end do + turb_vflux(nVertLevels+1) = 0. do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) @@ -1653,7 +1654,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo integer :: cell1, cell2, iEdge, iCell, i, k, iScalar real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp - real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux, prandtl_inverse + real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux, prandtl_1d_inverse real (kind=RKIND), dimension(num_scalars,nVertLevels+1) :: turb_vflux_scalars real (kind=RKIND) :: rho_k_at_w, zz_at_w real (kind=RKIND) :: delta_z, delta_s, tke_length, bv_frequency2 @@ -1832,7 +1833,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo if ( config_les_model == "3d_smagorinsky") then do k=2,nVertLevels - prandtl_inverse(k) = prandtl_inv + prandtl_1d_inverse(k) = prandtl_inv end do else ! prognostic_1.5_order, isentropic mixing length ! do k=2,nVertLevels @@ -1847,7 +1848,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! end do do k=2,nVertLevels - prandtl_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) + prandtl_1d_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) end do end if @@ -1862,7 +1863,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) - turb_vflux(k) = - prandtl_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) + turb_vflux(k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) end do ! test boundary conditions for supercell and les test cases @@ -1920,7 +1921,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) do iScalar=1,num_scalars - turb_vflux_scalars(iScalar,k) = - prandtl_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)* & + turb_vflux_scalars(iScalar,k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)* & (scalars(iScalar,k,iCell)-scalars(iScalar,k-1,iCell)) end do end do From 82a1a8cc2780d5d9b4c9d143250d89d87ef98e12 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 27 Oct 2020 11:36:32 -0600 Subject: [PATCH 064/109] hfx = heat_flux*rho*cp (factor added) --- src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) 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 36e53d11f0..73852e6220 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -211,6 +211,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & REAL, DIMENSION( its:ite ) :: DX2D INTEGER :: I,J + REAL :: RHO DO J=jts,jte @@ -232,7 +233,8 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & IF(specified_flux)THEN DO i=its,ite - HFX(i,j)=heat_flux + RHO = P1D(i)/R/(T1D(i)*(1.+EP1*QV1D(i))) + HFX(i,j)=heat_flux*RHO*CP QFX(i,j)=moisture_flux ENDDO ENDIF From a7828afda7380955fd30179fb6cc1ff2ce95ed7b Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 10 Nov 2020 14:05:56 -0700 Subject: [PATCH 065/109] add print for ust_edge --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 7d170c8bd3..3430571a2f 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -898,6 +898,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) else if (les_sas_test) then ust_edge = 0.5*(ustm(cell1) + ustm(cell2)) + if(iEdge == 1) call mpas_log_write(' SAS ust_edge, $r ', realArgs=(/ust_edge/)) velocity_magnitude = max(sqrt(u(1,iEdge)**2 + v(1,iEdge)**2),0.1) turb_vflux(1) = -rho_edge(1,iEdge)*ust_edge*ust_edge*(u(1,iEdge)/velocity_magnitude) turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) From 5e34d468f13bbe6e9a90334ba0c94fe70b83b145 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 10 Nov 2020 16:00:01 -0700 Subject: [PATCH 066/109] initialize landmask, lu_index(ivgtyp), xland = 1 --- .../mpas_init_atm_cases.F | 35 ++++++++++++++----- 1 file changed, 26 insertions(+), 9 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 12de5af3e9..785f7a4b68 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -403,11 +403,12 @@ subroutine init_atm_setup_case(domain, stream_manager) call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block_ptr % structs, 'fg', fg) call mpas_pool_get_subpool(block_ptr % structs, 'state', state) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) call mpas_log_write(' calling test case setup ') - call init_atm_case_les(domain % dminfo, mesh, nCells, nVertLevels, state, diag, config_init_case, block_ptr % configs) + call init_atm_case_les(domain % dminfo, mesh, fg, nCells, nVertLevels, state, diag, config_init_case, block_ptr % configs) call decouple_variables(mesh, nCells, nVertLevels, state, diag) call mpas_log_write(' returned from test case setup ') block_ptr => block_ptr % next @@ -6203,7 +6204,7 @@ end subroutine init_atm_case_lbc !--------------------- - subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, test_case, configs) + subroutine init_atm_case_les(dminfo, mesh, fg, nCells, nVertLevels, state, diag, test_case, configs) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Large Eddy Simulation (les) test case setup !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -6212,6 +6213,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes type (dm_info), intent(in) :: dminfo type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(inout) :: fg integer, intent(in) :: nCells integer, intent(in) :: nVertLevels type (mpas_pool_type), intent(inout) :: state @@ -6226,6 +6228,9 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes real (kind=RKIND), dimension(:,:,:), pointer :: scalars real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 + real (kind=RKIND), dimension(:), pointer :: xland + integer, dimension(:), pointer :: landmask, lu_index + !This is temporary variable here. It just need when calculate tangential velocity v. integer :: eoe, j integer, dimension(:), pointer :: nEdgesOnEdge @@ -6372,6 +6377,10 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes call mpas_pool_get_dimension(state, 'index_qv', index_qv) call mpas_pool_get_dimension(state, 'index_tke', index_tke) + call mpas_pool_get_array(fg, 'xland', xland) + call mpas_pool_get_array(mesh, 'landmask', landmask) + call mpas_pool_get_array(mesh, 'lu_index', lu_index) + scalars(:,:,:) = 0. call atm_initialize_advection_rk(mesh, nCells, nEdges, maxEdges, on_a_sphere, sphere_radius ) @@ -6543,7 +6552,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes call mpas_dmpar_bcast_real(dminfo, pibtop) ptopb = p0*pibtop**(1./rcp) - call mpas_log_write('ptopb = $r', realArgs=(/0.01_RKIND*ptopb/)) +! call mpas_log_write('ptopb = $r', realArgs=(/0.01_RKIND*ptopb/)) do i=1, nCells pb(nz1,i) = pibtop+.5*dzw(nz1)*gravity*(1.+qvb(nz1))/(cp*tb(nz1,i)*zz(nz1,i)) @@ -6648,7 +6657,7 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes end do pitop = pitop - .5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1)) ptop = p0*pitop**(1./rcp) - call mpas_log_write('ptop = $r $r', realArgs=(/0.01_RKIND*ptop, 0.01_RKIND*ptopb/)) +! call mpas_log_write('ptop = $r $r', realArgs=(/0.01_RKIND*ptop, 0.01_RKIND*ptopb/)) call mpas_dmpar_bcast_real(dminfo, ptop) @@ -6666,11 +6675,11 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes +fzp(k+1)*(rb(k ,i)*(scalars(index_qv,k ,i)-qvb(k)) & +rr(k ,i)*(1.+scalars(index_qv,k ,i)))) end do - if (itr==1.and.i==1) then - do k=1,nz1 - call mpas_log_write('pp-check $r', realArgs=(/pp(k,i)/)) - end do - end if +! if (itr==1.and.i==1) then +! do k=1,nz1 +! call mpas_log_write('pp-check $r', realArgs=(/pp(k,i)/)) +! end do +! end if do k=1,nz1 rt(k,i) = (pp(k,i)/(rgas*zz(k,i)) & -rtb(k,i)*(p(k,i)-pb(k,i)))/p(k,i) @@ -6760,6 +6769,14 @@ subroutine init_atm_case_les(dminfo, mesh, nCells, nVertLevels, state, diag, tes end do end do + do iCell = 1, nCells + !land category + landmask(iCell) = 1 + lu_index(iCell) = 1 + xland(iCell) = 1.0 + if (iCell == 1) call mpas_log_write(' landmask, lu_index, xland $i $i $r', intArgs=(/landmask(iCell),lu_index(iCell)/), realArgs=(/xland(iCell)/)) + end do + end subroutine init_atm_case_les From 451424455359c0f24903f800d614bd9446960a36 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 2 Nov 2021 15:33:00 -0600 Subject: [PATCH 067/109] change hardwired value of f - need to generize to use fEdge --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 2 +- 1 file changed, 1 insertion(+), 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 2c78768b84..f69f0847c8 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5221,7 +5221,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 logical, parameter :: perturbation_coriolis = .true. - real (kind=RKIND), parameter :: coriolis_value = 1.e-04 + real (kind=RKIND), parameter :: coriolis_value = 7.2921e-05 real (kind=RKIND) :: reference_u type (MPAS_Time_Type) :: currTime From cdb3a2e1b2cc37f074ae1e42e4178c13ef8f6abe Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 3 Nov 2021 12:59:51 -0600 Subject: [PATCH 068/109] fix rdzw/rdzu for w dissipation, use fEdge instead of coriolis_value --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 4 ++-- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 3 +-- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 3430571a2f..63d558dfb8 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1190,12 +1190,12 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, ! compute turbulent fluxes do k=1,nVertLevels turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*zz(k,iCell) & - *rdzu(k)*(w(k+1,iCell)-w(k,iCell)) + *rdzw(k)*(w(k+1,iCell)-w(k,iCell)) end do turb_vflux(nVertLevels+1) = 0. do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & - - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + - rdzu(k)*(turb_vflux(k)-turb_vflux(k-1)) end do end do diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index f69f0847c8..064b8d4db3 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5221,7 +5221,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 logical, parameter :: perturbation_coriolis = .true. - real (kind=RKIND), parameter :: coriolis_value = 7.2921e-05 real (kind=RKIND) :: reference_u type (MPAS_Time_Type) :: currTime @@ -5499,7 +5498,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eoe = edgesOnEdge(j,iEdge) do k=1,nVertLevels reference_u = u_init(k) * cos(angleEdge(eoe)) - v_init(k) * sin(angleEdge(eoe)) - q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * coriolis_value + q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * fEdge(iEdge) end do end do end if From dcaa6205a88d97d4a0a984c82f43dedf4c287c5f Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 3 Nov 2021 15:07:25 -0600 Subject: [PATCH 069/109] revert to hardwired f until fEdge can be used --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 2 +- 1 file changed, 1 insertion(+), 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 064b8d4db3..948b50b7d7 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5498,7 +5498,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eoe = edgesOnEdge(j,iEdge) do k=1,nVertLevels reference_u = u_init(k) * cos(angleEdge(eoe)) - v_init(k) * sin(angleEdge(eoe)) - q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * fEdge(iEdge) + q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * 0.729210E-04 end do end do end if From 19e94ab31d43ed255be9c2e3b0704a43277e9879 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 30 Nov 2021 14:08:23 -0700 Subject: [PATCH 070/109] convert moisture_flux w'q' to surface flux qfx --- src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 73852e6220..f7399e4b40 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -235,7 +235,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & DO i=its,ite RHO = P1D(i)/R/(T1D(i)*(1.+EP1*QV1D(i))) HFX(i,j)=heat_flux*RHO*CP - QFX(i,j)=moisture_flux + QFX(i,j)=moisture_flux*RHO ENDDO ENDIF From 2bea0489d118f0efef4acc55c9024c0e5ad7c5c9 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 8 Dec 2021 11:58:20 -0700 Subject: [PATCH 071/109] moisture_flux in dynamics should be w'q' = qfx/rho --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 63d558dfb8..99d899462e 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1891,7 +1891,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) heat_flux = hfx(iCell)/rho_zz(1,iCell)/cp - moisture_flux = qfx(iCell) + moisture_flux = qfx(iCell)/rho_zz(1,iCell) if(iCell == 1) call mpas_log_write(' SAS t and qv fluxes, $r, $r ', realArgs=(/heat_flux, moisture_flux/)) theta_m_flux = heat_flux*(1.0+(rv/rgas)*qv_cell)+(rv/rgas)*theta_cell*moisture_flux From 99e890589fce090dd5f454fd45b1cd818e01baa0 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 24 Mar 2022 11:34:03 -0600 Subject: [PATCH 072/109] add commented fEdge line while still using hardwired f --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 948b50b7d7..73d9731e52 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5498,6 +5498,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eoe = edgesOnEdge(j,iEdge) do k=1,nVertLevels reference_u = u_init(k) * cos(angleEdge(eoe)) - v_init(k) * sin(angleEdge(eoe)) +! q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * fEdge(iEdge) q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * 0.729210E-04 end do end do From 684cc611e820186d6fa0bf304f29f16991140b16 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 22 Jun 2022 15:53:09 -0600 Subject: [PATCH 073/109] initial prep to use les_test option --- .../dynamics/mpas_atm_dissipation_models.F | 10 +++++++--- .../dynamics/mpas_atm_time_integration.F | 4 ++-- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 99d899462e..39ab3c9ad4 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -15,7 +15,7 @@ module mpas_atm_dissipation_models use mpas_derived_types, only : MPAS_LOG_CRIT logical, parameter :: debug_dissipation = .false. - logical, parameter :: les_test = .false., les_sas_test = .true. + logical, parameter :: les_test = .true., les_sas_test = .false. !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour real (kind=RKIND), parameter :: tke_heat_flux = 0.0 !! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 ! ocean roughness length @@ -1874,10 +1874,14 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo moisture_flux = 0. heat_flux = tke_heat_flux + qv_cell = scalars(index_qv,1,iCell) + theta_m_cell = theta_m(1,iCell) + theta_cell = theta_m_cell/(1.0+(rv/rgas)*qv_cell) ! bulk formulation will go here. - theta_m_flux = heat_flux*(1.0+(rv/rgas)*scalars(index_qv,1,iCell)) & - +(rv/rgas)*theta_m(1,iCell)*moisture_flux/rho_zz(k,iCell) +! theta_m_flux = heat_flux*(1.0+(rv/rgas)*scalars(index_qv,1,iCell)) & +! +(rv/rgas)*theta_m(1,iCell)*moisture_flux/rho_zz(k,iCell) + theta_m_flux = heat_flux*(1.0+(rv/rgas)*qv_cell)+(rv/rgas)*theta_cell*moisture_flux ! turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY turb_vflux(1) = theta_m_flux*rho_zz(1,iCell) turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 73d9731e52..48dce63ab7 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5498,8 +5498,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eoe = edgesOnEdge(j,iEdge) do k=1,nVertLevels reference_u = u_init(k) * cos(angleEdge(eoe)) - v_init(k) * sin(angleEdge(eoe)) -! q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * fEdge(iEdge) - q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * 0.729210E-04 + q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * fEdge(iEdge) +! q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * 0.729210E-04 end do end do end if From 2410a5143d9a13a9666c5ed88d05e1517988a598 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 30 Oct 2024 09:57:52 -0600 Subject: [PATCH 074/109] fix for compile --- src/core_init_atmosphere/mpas_atm_advection.F | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index 3b487f3797..891224a5e3 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -785,11 +785,7 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere integer :: iv, ie logical :: do_the_cell -<<<<<<< HEAD real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, dx, dy -======= - real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost ->>>>>>> 94ba9031b (Fixed error in w_x, w_y deformation coefficients.) logical, pointer :: is_periodic real(kind=RKIND), pointer :: x_period, y_period From f0ee5ebaa6efebbcf985a81c39e143025f1eb7d0 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 30 Oct 2024 13:21:19 -0600 Subject: [PATCH 075/109] fixes to compile init_atmosphere --- src/core_init_atmosphere/mpas_atm_advection.F | 1 - .../mpas_init_atm_cases.F | 39 ++++++++++--------- 2 files changed, 21 insertions(+), 19 deletions(-) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index 891224a5e3..bff8843fbc 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -1023,7 +1023,6 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere end subroutine atm_initialize_deformation_weights - end module atm_advection !----------------------- subroutine atm_init_test_coefs( deformation_coef_c2, deformation_coef_s2, & diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 785f7a4b68..cdfb9324f3 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -367,6 +367,27 @@ subroutine init_atm_setup_case(domain, stream_manager) ! call mpas_stream_mgr_reset_alarms(stream_manager, streamID='lbc', direction=MPAS_STREAM_OUTPUT, ierr=ierr) + else if (config_init_case == 10) then + + call mpas_log_write(' les test case ') + block_ptr => domain % blocklist + do while (associated(block_ptr)) + + call mpas_pool_get_dimension(block_ptr % dimensions, 'nCells', nCells) + call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) + + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block_ptr % structs, 'fg', fg) + call mpas_pool_get_subpool(block_ptr % structs, 'state', state) + call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) + + call mpas_log_write(' calling test case setup ') + call init_atm_case_les(domain % dminfo, mesh, fg, nCells, nVertLevels, state, diag, config_init_case, block_ptr % configs) + call decouple_variables(mesh, nCells, nVertLevels, state, diag) + call mpas_log_write(' returned from test case setup ') + block_ptr => block_ptr % next + end do + else if (config_init_case == 13 ) then call mpas_log_write(' CAM-MPAS grid ') @@ -393,24 +414,6 @@ subroutine init_atm_setup_case(domain, stream_manager) call init_atm_case_cam_mpas(stream_manager, domain % dminfo, block_ptr, & mesh, block_ptr % dimensions, block_ptr % configs, nVertLevels) - else if (config_init_case == 10) then - - call mpas_log_write(' les test case ') - block_ptr => domain % blocklist - do while (associated(block_ptr)) - - call mpas_pool_get_dimension(block_ptr % dimensions, 'nCells', nCells) - call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) - - call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block_ptr % structs, 'fg', fg) - call mpas_pool_get_subpool(block_ptr % structs, 'state', state) - call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) - - call mpas_log_write(' calling test case setup ') - call init_atm_case_les(domain % dminfo, mesh, fg, nCells, nVertLevels, state, diag, config_init_case, block_ptr % configs) - call decouple_variables(mesh, nCells, nVertLevels, state, diag) - call mpas_log_write(' returned from test case setup ') block_ptr => block_ptr % next end do From af5807a6d4266d0e399e8980abdf349bc672c141 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 1 Nov 2024 10:19:39 -0600 Subject: [PATCH 076/109] to compile atmosphere --- src/core_atmosphere/Registry.xml | 4 ---- .../dynamics/mpas_atm_time_integration.F | 16 +++------------- 2 files changed, 3 insertions(+), 17 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 9d1d5ac8a7..2f159f3958 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1696,13 +1696,10 @@ - packages="mp_thompson_in"/> - - @@ -2080,7 +2077,6 @@ - packages="mp_thompson_in"/> diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 48dce63ab7..b687fdc0a3 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -16,14 +16,13 @@ module atm_time_integration - use mpas_derived_types use mpas_pool_routines use mpas_kind_types use mpas_constants use mpas_dmpar use mpas_vector_reconstruction ! Added only clause to keep xlf90 from getting confused from the overloaded abs intrinsic in mpas_timekeeping - use mpas_derived_types, only : MPAS_Time_type, MPAS_TimeInterval_type, MPAS_NOW + use mpas_derived_types, only : MPAS_NOW use mpas_timekeeping, only: MPAS_Time_type, MPAS_TimeInterval_type, mpas_get_clock_time, & mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+), add_t_ti use mpas_timer @@ -1149,14 +1148,6 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) end if call mpas_timer_start('atm_compute_dyn_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_subpool(block % structs, 'diag_physics', diag_physics) - call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) allocate(delsq_theta(nVertLevels,nCells+1)) allocate(delsq_w(nVertLevels,nCells+1)) @@ -4848,7 +4839,6 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys logical, pointer :: config_rayleigh_damp_u real (kind=RKIND), pointer :: config_rayleigh_damp_u_timescale_days integer, pointer :: config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels - integer, pointer :: config_number_rayleigh_damp_u_levels integer, pointer :: index_qv, index_qc, index_tke logical :: inactive_rthdynten @@ -5020,7 +5010,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & - tend_rtheta_adv, rthdynten, ustm, hfx, qfx, & + rthdynten, ustm, hfx, qfx, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -5048,7 +5038,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & - tend_rtheta_adv, rthdynten, ustm, hfx, qfx, & + rthdynten, ustm, hfx, qfx, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) From a28454222ffd25e4a60d2d542917c2ce58c5a240 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 2 Jan 2025 14:20:53 -0700 Subject: [PATCH 077/109] fix small error in tke shear production and add surface heat flux --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 39ab3c9ad4..7933a777bc 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -17,9 +17,9 @@ module mpas_atm_dissipation_models logical, parameter :: debug_dissipation = .false. logical, parameter :: les_test = .true., les_sas_test = .false. !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour - real (kind=RKIND), parameter :: tke_heat_flux = 0.0 + real (kind=RKIND), parameter :: tke_heat_flux = 0.03 !! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 ! ocean roughness length - real (kind=RKIND), parameter :: tke_drag_coefficient = 0.00935 + real (kind=RKIND), parameter :: tke_drag_coefficient = 0.006 real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 real (kind=RKIND), parameter :: c_k = 0.1 @@ -280,7 +280,7 @@ subroutine les_models( config_les_model, eddy_visc_horz, eddy_visc_vert, ! terms for the prognostic tke integration shear_production = eddy_visc_h*(d_11(k)**2 + d_22(k)**2 + d_12(k)**2) & - +eddy_visc_v*(d_33(k)**2 + d_13(k)**2 + d_13(k)**2) + +eddy_visc_v*(d_33(k)**2 + d_13(k)**2 + d_23(k)**2) buoyancy = -eddy_visc_v*bv_freq2(k,iCell) From c3f694c42250a4a9a4e116f139488c4968a7b65d Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 19 Mar 2025 11:53:12 -0600 Subject: [PATCH 078/109] remove specialized physics code to leave dynonly les --- src/core_atmosphere/mpas_atm_core.F | 2 +- .../physics/mpas_atmphys_driver.F | 7 ++- .../physics/mpas_atmphys_driver_pbl.F | 5 -- .../physics/mpas_atmphys_driver_sfclayer.F | 54 +------------------ .../physics/physics_wrf/module_sf_sfclay.F | 43 ++------------- 5 files changed, 9 insertions(+), 102 deletions(-) diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index ce9875cc89..f7d04a1f0c 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -1015,7 +1015,7 @@ subroutine atm_do_timestep(domain, dt, itimestep) !proceed with physics if moist_physics is set to true: if(moist_physics) then call physics_timetracker(domain,dt,clock,itimestep,xtime_s) - call physics_driver(domain,clock,itimestep,xtime_s) + call physics_driver(domain,itimestep,xtime_s) endif #endif diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index 5d9d5d092c..8e31672657 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -108,13 +108,12 @@ module mpas_atmphys_driver !================================================================================================================= - subroutine physics_driver(domain,clock,itimestep,xtime_s) + subroutine physics_driver(domain,itimestep,xtime_s) !================================================================================================================= !input arguments: integer,intent(in):: itimestep real(kind=RKIND),intent(in):: xtime_s - type(MPAS_Clock_type),intent(in):: clock !inout arguments: type(domain_type),intent(inout):: domain @@ -270,8 +269,8 @@ subroutine physics_driver(domain,clock,itimestep,xtime_s) call allocate_sfclayer(block%configs) !$OMP PARALLEL DO do thread=1,nThreads - call driver_sfclayer(clock,itimestep,block%configs,mesh,diag_physics,sfc_input, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + call driver_sfclayer(itimestep,block%configs,mesh,diag_physics,sfc_input, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO call deallocate_sfclayer(block%configs) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F index 43837ee27c..72a411aeba 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F @@ -775,7 +775,6 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics bl_mynn_tkeadvect character(len=StrKIND),pointer:: pbl_scheme - character(len=StrKIND),pointer:: config_les_model integer,pointer:: bl_mynn_cloudpdf, & bl_mynn_mixlength, & @@ -814,7 +813,6 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics call mpas_pool_get_config(configs,'config_do_DAcycling',config_do_DAcycling) call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) call mpas_pool_get_config(configs,'config_pbl_scheme' ,pbl_scheme ) - call mpas_pool_get_config(configs, 'config_les_model', config_les_model) !copy MPAS arrays to local arrays: call pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,ite) @@ -822,7 +820,6 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics initflag = 1 if(config_do_restart .or. itimestep > 1) initflag = 0 - if(config_les_model == "none") then pbl_select: select case (trim(pbl_scheme)) case("bl_ysu") @@ -967,8 +964,6 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics case default end select pbl_select - - endif ! les skip pbl !copy local arrays to MPAS grid: call pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index 791d933405..afde4fa523 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -8,11 +8,7 @@ !================================================================================================================= module mpas_atmphys_driver_sfclayer use mpas_kind_types - use mpas_derived_types use mpas_pool_routines -! use mpas_timekeeping, only: MPAS_Time_type, MPAS_TimeInterval_type, mpas_get_clock_time, & -! mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+), add_t_ti - use mpas_timekeeping, only: MPAS_Time_type, mpas_get_clock_time, mpas_get_time use mpas_timer, only : mpas_timer_start, mpas_timer_stop use mpas_atmphys_constants @@ -36,7 +32,6 @@ module mpas_atmphys_driver_sfclayer integer,parameter,private:: iz0tlnd = 0 !=0,(Carlson-Boland). integer,parameter,private:: scm_force_flux = 0 !SCM surface forcing by surface fluxes. !0=no 1=yes (WRF single column model option only). - type (MPAS_Clock_type), pointer, private :: clock !MPAS driver for parameterization of the surface layer. !Laura D. Fowler (send comments to laura@ucar.edu). @@ -841,12 +836,10 @@ subroutine init_sfclayer(configs) end subroutine init_sfclayer !================================================================================================================= - subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,its,ite) + subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) !================================================================================================================= !input and inout arguments: - type(MPAS_Clock_type),intent(in):: clock - type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: sfc_input @@ -861,7 +854,6 @@ subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,i logical,pointer:: config_do_restart,config_frac_seaice character(len=StrKIND),pointer:: sfclayer_scheme real(kind=RKIND),dimension(:),pointer:: areaCell - real(kind=RKIND),pointer:: config_dt !local variables: integer:: initflag @@ -871,13 +863,6 @@ subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,i character(len=StrKIND):: errmsg integer:: errflg - type (MPAS_Time_Type) :: currTime - integer :: H, M, S, S_n, S_d - integer :: ierr - real(kind=RKIND) :: time_of_day_seconds - real(kind=RKIND) :: heat_flux, moisture_flux - logical :: specified_flux - !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_sfclayer:') @@ -889,7 +874,6 @@ subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,i call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) - call mpas_pool_get_config(configs,'config_dt',config_dt) call mpas_pool_get_array(mesh,'areaCell',areaCell) @@ -905,14 +889,6 @@ subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,i case("sf_monin_obukhov") call mpas_timer_start('sf_monin_obukhov') - - currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) - call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) - time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*config_dt - call mpas_log_write(' sfclay, time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) - call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) - specified_flux = .true. - call sfclay( & p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & u3d = u_p , v3d = v_p , qv3d = qv_p , & @@ -936,8 +912,6 @@ subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,i 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 , & - heat_flux = heat_flux , moisture_flux = moisture_flux , & - specified_flux = specified_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 & @@ -967,8 +941,6 @@ subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,i 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 , & - heat_flux = heat_flux , moisture_flux = moisture_flux , & - specified_flux = specified_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 & @@ -1115,30 +1087,6 @@ subroutine driver_sfclayer(clock,itimestep,configs,mesh,diag_physics,sfc_input,i end subroutine driver_sfclayer - subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) - - implicit none - - real (kind=RKIND), intent(in) :: time_of_day_seconds - real (kind=RKIND), intent(out) :: heat_flux, moisture_flux - - real (kind=RKIND), parameter:: t_start_t_flux = 3600.*6.0 - real (kind=RKIND), parameter:: t_end_t_flux = 3600.*19.50 - real (kind=RKIND), parameter:: t_start_q_flux = 3600.*7.0 - real (kind=RKIND), parameter:: t_end_q_flux = 3600.*19.50 - real (kind=RKIND) :: rel_time_t_flux, rel_time_q_flux - - rel_time_t_flux = max(0.,(time_of_day_seconds - t_start_t_flux)/(t_end_t_flux - t_start_t_flux)) - rel_time_q_flux = max(0.,(time_of_day_seconds - t_start_q_flux)/(t_end_q_flux - t_start_q_flux)) - - heat_flux = max(0., 0.1*sin(pii*rel_time_t_flux)) - moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux))/1000. - - end subroutine flux_les_sas - - - - !================================================================================================================= end module mpas_atmphys_driver_sfclayer !================================================================================================================= 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 f7399e4b40..2b3ba578f0 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -25,8 +25,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & ustm,ck,cka,cd,cda, & - isftcflx,iz0tlnd,scm_force_flux, & - heat_flux, moisture_flux, specified_flux ) + isftcflx,iz0tlnd,scm_force_flux) !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- @@ -185,8 +184,6 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX - REAL, INTENT(IN ) :: heat_flux, moisture_flux - LOGICAL, INTENT(IN ) :: specified_flux REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT ) :: QSFC @@ -211,7 +208,6 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & REAL, DIMENSION( its:ite ) :: DX2D INTEGER :: I,J - REAL :: RHO DO J=jts,jte @@ -231,14 +227,6 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & T1D(i) =T3D(i,1,j) ENDDO - IF(specified_flux)THEN - DO i=its,ite - RHO = P1D(i)/R/(T1D(i)*(1.+EP1*QV1D(i))) - HFX(i,j)=heat_flux*RHO*CP - QFX(i,j)=moisture_flux*RHO - ENDDO - ENDIF - ! Sending array starting locations of optional variables may cause ! troubles, so we explicitly change the call. @@ -255,7 +243,6 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT, & P1000mb, & - specified_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -281,7 +268,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & P1000mb, & - specified_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -303,7 +289,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT REAL, INTENT(IN ) :: P1000mb - LOGICAL, INTENT(IN ) :: specified_flux ! REAL, DIMENSION( ims:ime ) , & INTENT(IN ) :: MAVAIL, & @@ -400,7 +385,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & REAL :: FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,GZ0OZQ,GZ0OZT REAL :: ZW, ZN1, ZN2 REAL :: Z0T, CZC - REAL :: USTI !------------------------------------------------------------------- KL=kte @@ -412,16 +396,10 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & !----CONVERT GROUND TEMPERATURE TO POTENTIAL TEMPERATURE: ! DO 5 I=its,ite - IF(.not.specified_flux)THEN - TGDSA(I)=TSK(I) + TGDSA(I)=TSK(I) ! PSFC cb -! THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP - THGB(I)=TSK(I)*(P1000mb/PSFCPA(I))**ROVCP - ELSE -! with specified_flux TSK value is not input and given value will not affect USTM - TGDSA(I)=300. - THGB(I)=300.*(P1000mb/PSFCPA(I))**ROVCP - ENDIF +! THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP + THGB(I)=TSK(I)*(P1000mb/PSFCPA(I))**ROVCP 5 CONTINUE ! !-----DECOUPLE FLUX-FORM VARIABLES TO GIVE U,V,T,THETA,THETA-VIR., @@ -553,15 +531,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & 260 CONTINUE - IF(specified_flux)THEN -! Need to recalculate MOL and BR when HFX is given and TSK is not used - DO I=ITS,ITE -! MOL is THETA* - USTI = MAX(UST(I),0.01) - MOL(I) = - HFX(I)/(RHOX(I)*CP*USTI) - BR(I) = KARMAN*GOVRTH(I)*ZA(I)*MOL(I)/(USTI*USTI)/GZ1OZ0(I) - ENDDO - ENDIF ! !-----DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATED STABILITY CLASS: ! @@ -827,8 +796,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & WSPDI(I)=SQRT(UX(I)*UX(I)+VX(I)*VX(I)) IF ( PRESENT(USTM) ) THEN USTM(I)=0.5*USTM(I)+0.5*KARMAN*WSPDI(I)/PSIX -! For specified_flux VCONV effect not added to UST that will be used for ZOL - IF(specified_flux)UST(I)=USTM(I) ENDIF U10(I)=UX(I)*PSIX10/PSIX V10(I)=VX(I)*PSIX10/PSIX @@ -854,8 +821,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & 330 CONTINUE ! 335 CONTINUE - - IF(specified_flux) GOTO 410 !-----COMPUTE THE SURFACE SENSIBLE AND LATENT HEAT FLUXES: IF ( PRESENT(SCM_FORCE_FLUX) ) THEN From d916283e4b28d6ba6ed9a3892775e5d767e488e6 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 21 May 2025 10:14:59 -0600 Subject: [PATCH 079/109] mods to scale les-supercell case and remove surface fluxes from les_test option --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 6 ++++-- src/core_init_atmosphere/mpas_init_atm_cases.F | 7 +++++-- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 7933a777bc..c07df5669a 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -17,9 +17,11 @@ module mpas_atm_dissipation_models logical, parameter :: debug_dissipation = .false. logical, parameter :: les_test = .true., les_sas_test = .false. !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour - real (kind=RKIND), parameter :: tke_heat_flux = 0.03 + ! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 + real (kind=RKIND), parameter :: tke_heat_flux = 0.0 !! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 ! ocean roughness length - real (kind=RKIND), parameter :: tke_drag_coefficient = 0.006 + ! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.006 + real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0 real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 real (kind=RKIND), parameter :: c_k = 0.1 diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index cdfb9324f3..f1b747eb78 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -1459,6 +1459,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d real (kind=RKIND), pointer :: nominalMinDc logical, pointer :: on_a_sphere real (kind=RKIND), pointer :: sphere_radius + real (kind=RKIND), pointer :: config_ztop real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta real (kind=RKIND), dimension(:), pointer :: u_init, qv_init, angleEdge, fEdge, fVertex @@ -1484,12 +1485,13 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) call mpas_pool_get_config(configs, 'config_interface_projection', config_interface_projection) + call mpas_pool_get_config(configs, 'config_ztop', config_ztop) ! ! Scale all distances ! - a_scale = 1.0 + a_scale = 11.25 xCell(:) = xCell(:) * a_scale yCell(:) = yCell(:) * a_scale @@ -1593,7 +1595,8 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d ! metrics for hybrid coordinate and vertical stretching str = 1.0 - zt = 20000. +! zt = 20000. + zt = config_ztop dz = zt/float(nz1) ! write(0,*) ' dz = ',dz From 97e73ed9fd85567f807bc55b85961b17bff584b1 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Fri, 23 May 2025 15:15:45 -0600 Subject: [PATCH 080/109] add seed tke = 0.1 at all points --- src/core_init_atmosphere/mpas_init_atm_cases.F | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index f1b747eb78..0f2d92d42c 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -1433,6 +1433,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, nz1, itr, cell1, cell2 integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve integer, pointer :: index_qv + integer, pointer :: index_tke real (kind=RKIND), dimension(nVertLevels + 1 ) :: zc, zw, ah real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm @@ -1568,6 +1569,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d call mpas_pool_get_array(state, 'scalars', scalars) call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_dimension(state, 'index_tke', index_tke) scalars(:,:,:) = 0. @@ -1883,6 +1885,18 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) end do end do +! +! initial seed for tke +! +! call mpas_log_write('index_qv $i ', intArgs=(/index_qv/)) +! call mpas_log_write('index_tke $i ', intArgs=(/index_tke/)) + scalars(index_tke,:,:) = 0. + + do k = 1,nz1 + do i=1,nCells + scalars(index_tke,k,i) = 0.1 + end do + end do do itr=1,30 From ac2f96cf9fe415dc50e748c0e8e26f7debfa9929 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 12 Aug 2025 09:27:31 -0600 Subject: [PATCH 081/109] fix scaling for x_period and y_period for cases --- src/core_init_atmosphere/mpas_init_atm_cases.F | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 0f2d92d42c..48cff2c52e 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -1429,7 +1429,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d integer, dimension(:), pointer :: nEdgesOnEdge integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge - + real (kind=RKIND), pointer :: x_period, y_period integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, nz1, itr, cell1, cell2 integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve integer, pointer :: index_qv @@ -1482,7 +1482,9 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) - + + call mpas_pool_get_config(mesh, 'x_period', x_period) + call mpas_pool_get_config(mesh, 'y_period', y_period) call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) call mpas_pool_get_config(configs, 'config_interface_projection', config_interface_projection) @@ -1509,6 +1511,8 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d areaTriangle(:) = areaTriangle(:) * a_scale**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 nominalMinDc = nominalMinDc * a_scale + x_period = x_period * a_scale + y_period = y_period * a_scale call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) @@ -2051,6 +2055,7 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag integer, dimension(:), pointer :: nEdgesOnEdge, nEdgesOnCell integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge, cellsOnCell real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge + real (kind=RKIND), pointer :: x_period, y_period integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, itr, cell1, cell2, nz1 integer, pointer :: nEdges, maxEdges, nCellsSolve, nVertices @@ -2109,6 +2114,8 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) + call mpas_pool_get_config(mesh, 'x_period', x_period) + call mpas_pool_get_config(mesh, 'y_period', y_period) call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) @@ -2150,6 +2157,8 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag areaTriangle(:) = areaTriangle(:) * a_scale**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 nominalMinDc = nominalMinDc * a_scale + x_period = x_period * a_scale + y_period = y_period * a_scale call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) @@ -6256,6 +6265,7 @@ subroutine init_atm_case_les(dminfo, mesh, fg, nCells, nVertLevels, state, diag, integer, dimension(:), pointer :: nEdgesOnEdge integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge + real (kind=RKIND), pointer :: x_period, y_period integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, cell1, cell2 integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve @@ -6310,6 +6320,8 @@ subroutine init_atm_case_les(dminfo, mesh, fg, nCells, nVertLevels, state, diag, call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_config(mesh, 'x_period', x_period) + call mpas_pool_get_config(mesh, 'y_period', y_period) call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) call mpas_pool_get_config(configs, 'config_ztop', config_ztop) @@ -6334,6 +6346,8 @@ subroutine init_atm_case_les(dminfo, mesh, fg, nCells, nVertLevels, state, diag, areaCell(:) = areaCell(:) * a_scale**2.0 areaTriangle(:) = areaTriangle(:) * a_scale**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 + x_period = x_period * a_scale + y_period = y_period * a_scale call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) From 250db000bd9be8d1c022b6e42fc0e0c59a8da28f Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Wed, 27 Aug 2025 10:57:45 -0600 Subject: [PATCH 082/109] revert supercell a_scale to 1.0 --- src/core_init_atmosphere/mpas_init_atm_cases.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 48cff2c52e..9f936dcf93 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -1494,7 +1494,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d ! Scale all distances ! - a_scale = 11.25 + a_scale = 1.0 xCell(:) = xCell(:) * a_scale yCell(:) = yCell(:) * a_scale From e446ec8f17d242275070c74645aca1d7cc2a5a66 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Mon, 29 Sep 2025 14:55:36 -0600 Subject: [PATCH 083/109] add config_les_surface to registry and routines (not used yet) --- src/core_atmosphere/Registry.xml | 7 ++++++- .../dynamics/mpas_atm_dissipation_models.F | 16 ++++++++++++---- .../dynamics/mpas_atm_time_integration.F | 15 +++++++++------ 3 files changed, 27 insertions(+), 11 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 2f159f3958..5c0950aa10 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -149,7 +149,12 @@ + possible_values="`none', `3d_smagorinsky', 'prognostic_1.5_order'"/> + + Date: Wed, 8 Oct 2025 10:47:54 -0600 Subject: [PATCH 084/109] clean up and reduce duplication --- src/core_atmosphere/Registry.xml | 2 +- .../dynamics/mpas_atm_dissipation_models.F | 39 +++++++------------ 2 files changed, 14 insertions(+), 27 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 5c0950aa10..86cf2e749a 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -154,7 +154,7 @@ + possible_values="`free', 'specified', `varying'"/> Date: Wed, 8 Oct 2025 15:07:24 -0600 Subject: [PATCH 085/109] remove redundant dissipation routines --- .../dynamics/mpas_atm_dissipation_models.F | 801 +----------------- 1 file changed, 45 insertions(+), 756 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 8515f6b7a7..d2b6245e13 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -403,229 +403,6 @@ end subroutine calculate_n2 !--------------------------------------- - subroutine u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & - cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & - cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & - nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & - invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & - angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & - config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & - config_del4u_div_factor, zgrid, kdiff, & - delsq_u, delsq_vorticity, delsq_divergence, & - u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) - - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here - - implicit none - - integer, intent(in) :: edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd - integer, intent(in) :: vertexStart, vertexEnd, vertexDegree - integer, intent(in) :: cellStart, cellEnd - integer, intent(in) :: nCells, nEdges, nVertices - logical, intent(in) :: config_mix_full - - integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge - integer, dimension(2,nEdges+1), intent(in) :: verticesOnEdge - integer, dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell - integer, dimension(nCells+1), intent(in) :: nEdgesOnCell - integer, dimension(vertexDegree,nVertices+1), intent(in) :: edgesOnVertex - - real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 - real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 - real (kind=RKIND), intent(in) :: config_del4u_div_factor - - real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign - real (kind=RKIND), dimension(vertexDegree,nVertices+1), intent(in) :: edgesOnVertex_sign - real (kind=RKIND), dimension(nVertices+1), intent(in) :: invAreaTriangle - real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell - real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDvEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: angleEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: dcEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 - real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid - - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: divergence - real (kind=RKIND), dimension(nVertLevels,nVertices+1), intent(in) :: vorticity - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff - - - ! scratch space from calling routine - real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: delsq_u - real (kind=RKIND), dimension(nVertLevels,nVertices+1) :: delsq_vorticity - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_divergence - - real (kind=RKIND), dimension(nVertLevels), intent(in) :: u_init, v_init - - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(out) :: tend_u_euler - - ! local variables - - integer :: iEdge, cell1, cell2, vertex1, vertex2, iVertex, iCell, i, k - real (kind=RKIND) :: r_dc, r_dv, u_diffusion, kdiffu, r, edge_sign, u_mix_scale - real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp - real (kind=RKIND), dimension(nVertLevels) :: u_mix - -!$OMP BARRIER - - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). - ! First, storage to hold the result from the first del^2 computation. - - delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 - - do iEdge=edgeStart,edgeEnd - 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)) - -!DIR$ IVDEP - do k=1,nVertLevels - - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant - u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & - -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv - - delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion - - kdiffu = 0.5*(kdiff(k,cell1)+kdiff(k,cell2)) - - ! include 2nd-orer diffusion here - - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & - + rho_edge(k,iEdge)* kdiffu * u_diffusion * meshScalingDel2(iEdge) - - end do - end do - - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active - -!$OMP BARRIER - do iVertex=vertexStart,vertexEnd - delsq_vorticity(1:nVertLevels,iVertex) = 0.0 - do i=1,vertexDegree - iEdge = edgesOnVertex(i,iVertex) - edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) - do k=1,nVertLevels - delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) - end do - end do - end do - - do iCell=cellStart,cellEnd - delsq_divergence(1:nVertLevels,iCell) = 0.0 - r = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) - do k=1,nVertLevels - delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) - end do - end do - end do - -!$OMP BARRIER - do iEdge=edgeSolveStart,edgeSolveEnd - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - vertex1 = verticesOnEdge(1,iEdge) - vertex2 = verticesOnEdge(2,iEdge) - - u_mix_scale = meshScalingDel4(iEdge)*h_mom_eddy_visc4 - r_dc = u_mix_scale * config_del4u_div_factor * invDcEdge(iEdge) - r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) - -!DIR$ IVDEP - do k=1,nVertLevels - - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant - ! - ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor - ! relative to the rotational part. The stability constraint on the divergence component is much less - ! stringent than the rotational part, and this flexibility may be useful. - ! - u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & - -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion - - end do - end do - - end if ! 4th order mixing is active - ! - ! vertical mixing for u - 2nd order filter in physical (z) space - ! - if ( v_mom_eddy_visc2 > 0.0 ) then - - if (config_mix_full) then ! mix full state - - do iEdge=edgeSolveStart,edgeSolveEnd - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - do k=2,nVertLevels-1 - - z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) - z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) - z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) - z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & - (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) & - -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - - else ! idealized cases where we mix on the perturbation from the initial 1-D state - - do iEdge=edgeSolveStart,edgeSolveEnd - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - do k=1,nVertLevels - 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 - - z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) - z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) - z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) - z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & - (u_mix(k+1)-u_mix(k ))/(zp-z0) & - -(u_mix(k )-u_mix(k-1))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - - end if ! mix perturbation state - - end if ! vertical mixing of horizontal momentum - - end subroutine u_dissipation - -!------------------------ - subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & @@ -929,17 +706,22 @@ end subroutine u_dissipation_3d !------------------------ - subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - rdzw, rdzu, & - v_mom_eddy_visc2, h_mom_eddy_visc4, & - delsq_w, & - w, rho_edge, kdiff, rho_zz, & - tend_w_euler ) + subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + config_les_model, config_les_surface, & + tend_w_euler ) + + ! 3D w dissipation using the 3D smagorinsky eddy viscosities. + ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here @@ -954,6 +736,9 @@ subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge + character (len=StrKIND) :: config_les_model + character (len=StrKIND) :: config_les_surface + real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 @@ -967,14 +752,17 @@ subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_horz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: tend_w_euler ! storage passed in from calling routine real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_w + real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux ! local variables @@ -988,6 +776,12 @@ subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, ! First, storage to hold the result from the first del^2 computation. ! we copied code from the theta mixing, hence the theta* names. + if(debug_dissipation) then + call mpas_log_write(' begin w_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' les surface is '//trim(config_les_surface)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) + end if delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 @@ -1008,7 +802,8 @@ subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & - (kdiff(k,cell1)+kdiff(k,cell2)+kdiff(k-1,cell1)+kdiff(k-1,cell2)) + ( eddy_visc_horz(k ,cell1)+eddy_visc_horz(k ,cell2) & + +eddy_visc_horz(k-1,cell1)+eddy_visc_horz(k-1,cell2) ) tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux end do end do @@ -1049,533 +844,27 @@ subroutine w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end if - end subroutine w_dissipation - -!------------------------ - - subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - rdzw, rdzu, & - v_mom_eddy_visc2, h_mom_eddy_visc4, & - delsq_w, & - w, rho_edge, rho_zz, zz, & - eddy_visc_horz, eddy_visc_vert, & - config_les_model, config_les_surface, & - tend_w_euler ) - - - ! 3D w dissipation using the 3D smagorinsky eddy viscosities. - ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter + if ( config_les_model /= "none") then - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column + ! compute turbulent fluxes + do k=1,nVertLevels + turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*zz(k,iCell) & + *rdzw(k)*(w(k+1,iCell)-w(k,iCell)) + end do + turb_vflux(nVertLevels+1) = 0. + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & + - rdzu(k)*(turb_vflux(k)-turb_vflux(k-1)) + end do + end do - implicit none + end if - integer, intent(in) :: cellStart, cellEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd - integer, intent(in) :: nCells, nEdges - - integer, dimension(nCells+1), intent(in) :: nEdgesOnCell - integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell - - integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge - - character (len=StrKIND) :: config_les_model - character (len=StrKIND) :: config_les_surface - - real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 - real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 - - real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign - real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell - real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu - - real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: w - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_horz - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge - - real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: tend_w_euler - - ! storage passed in from calling routine - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_w - real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux - - ! local variables - - integer :: cell1, cell2, iEdge, iCell, i, k - real (kind=RKIND) :: r_areaCell, edge_sign, w_turb_flux - -! !OMP BARRIER why is this openmp barrier here??? - - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). - ! - ! First, storage to hold the result from the first del^2 computation. - ! we copied code from the theta mixing, hence the theta* names. - - if(debug_dissipation) then - call mpas_log_write(' begin w_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' les surface is '//trim(config_les_surface)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) - end if - - delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 - - do iCell=cellStart,cellEnd - tend_w_euler(1:nVertLevels+1,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - - edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - -!DIR$ IVDEP - do k=2,nVertLevels - - w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) - delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux - w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & - ( eddy_visc_horz(k ,cell1)+eddy_visc_horz(k ,cell2) & - +eddy_visc_horz(k-1,cell1)+eddy_visc_horz(k-1,cell2) ) - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux - end do - end do - end do - -!$OMP BARRIER - - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active - - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) - - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) - end do - - end do - end do - - end if ! 4th order mixing is active - - if ( v_mom_eddy_visc2 > 0.0 ) then ! vertical mixing - - do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & - (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & - -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k) - end do - end do - - end if - - if ( config_les_model /= "none") then - - do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column - ! compute turbulent fluxes - do k=1,nVertLevels - turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*zz(k,iCell) & - *rdzw(k)*(w(k+1,iCell)-w(k,iCell)) - end do - turb_vflux(nVertLevels+1) = 0. - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & - - rdzu(k)*(turb_vflux(k)-turb_vflux(k-1)) - end do - end do - - end if - - if(debug_dissipation) call mpas_log_write(' exiting w_dissipation_3d ') + if(debug_dissipation) call mpas_log_write(' exiting w_dissipation_3d ') end subroutine w_dissipation_3d -!----------------------------------------------------- - - subroutine theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - delsq_theta, & - theta_m, rho_edge, kdiff, rho_zz, & - tend_theta_euler ) - - - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here - implicit none - - integer, intent(in) :: cellStart, cellEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd - integer, intent(in) :: nCells, nEdges - - logical, intent(in) :: config_mix_full - - integer, dimension(nCells+1), intent(in) :: nEdgesOnCell - integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell - - integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge - - real (kind=RKIND), intent(in) :: h_theta_eddy_visc4 - real (kind=RKIND), intent(in) :: v_theta_eddy_visc2 - real (kind=RKIND), intent(in) :: prandtl_inv - - real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign - real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell - real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu - real (kind=RKIND), dimension(nVertLevels+1, nCells+1), intent(in) :: zgrid - - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: t_init - - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: kdiff - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge - - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler - - ! storage passed in from calling routine - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_theta - - ! local variables - integer :: cell1, cell2, iEdge, iCell, i, k - real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale - real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp - - delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 - - do iCell=cellStart,cellEnd - tend_theta_euler(1:nVertLevels,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - pr_scale = prandtl_inv * meshScalingDel2(iEdge) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) -!DIR$ IVDEP - do k=1,nVertLevels - -! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below - - theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) - delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux - theta_turb_flux = theta_turb_flux*0.5*(kdiff(k,cell1)+kdiff(k,cell2)) * pr_scale - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux - - end do - end do - end do - -!$OMP BARRIER - - if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active - - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - - iEdge = edgesOnCell(i,iCell) - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - do k=1,nVertLevels - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) - end do - end do - end do - - end if ! 4th order mixing is active - - if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m - - if (config_mix_full) then - - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & - -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - - else ! idealized cases where we mix on the perturbation from the initial 1-D state - - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & - -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - - end if - - end if - - end subroutine theta_dissipation - -!----------------------------------------------------- - - subroutine theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, fzm, fzp, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - delsq_theta, & - theta_m, rho_edge, rho_zz, zz, & - eddy_visc_horz, eddy_visc_vert, & - config_les_model, & - tend_theta_euler ) - - - ! 3D theta_m dissipation using the 3D smagorinsky eddy viscosities. - ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter - - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here - implicit none - - integer, intent(in) :: cellStart, cellEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd - integer, intent(in) :: nCells, nEdges - - logical, intent(in) :: config_mix_full - - character (len=StrKIND) :: config_les_model - - integer, dimension(nCells+1), intent(in) :: nEdgesOnCell - integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell - - integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge - - real (kind=RKIND), intent(in) :: h_theta_eddy_visc4 - real (kind=RKIND), intent(in) :: v_theta_eddy_visc2 - real (kind=RKIND), intent(in) :: prandtl_inv - - real (kind=RKIND), dimension(maxEdges,nCells+1), intent(in) :: edgesOnCell_sign - real (kind=RKIND), dimension(nCells+1), intent(in) :: invAreaCell - real (kind=RKIND), dimension(nEdges+1), intent(in) :: dvEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: invDcEdge - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel2 - real (kind=RKIND), dimension(nEdges+1), intent(in) :: meshScalingDel4 - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzw - real (kind=RKIND), dimension(nVertLevels), intent(in) :: rdzu - real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzm - real (kind=RKIND), dimension(nVertLevels), intent(in) :: fzp - real (kind=RKIND), dimension(nVertLevels+1, nCells+1), intent(in) :: zgrid - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: zz - - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: t_init - - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_horz - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge - - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler - - ! storage passed in from calling routine - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_theta - - ! local variables - integer :: cell1, cell2, iEdge, iCell, i, k - real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale - real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp - real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux - real (kind=RKIND) :: rho_k_at_w, zz_at_w - - if(debug_dissipation) then - call mpas_log_write(' begin theta_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_theta_eddy_visc4/)) - end if - - delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 - - do iCell=cellStart,cellEnd - tend_theta_euler(1:nVertLevels,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - pr_scale = prandtl_inv * meshScalingDel2(iEdge) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) -!DIR$ IVDEP - do k=1,nVertLevels - -! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. -! This is in conservative form. - - theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) - delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux - theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux - - end do - end do - end do - -!$OMP BARRIER - - if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active - - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - - iEdge = edgesOnCell(i,iCell) - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - do k=1,nVertLevels - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) - end do - end do - end do - - end if ! 4th order mixing is active - - ! idealized case vertical mixing - - if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m - - if (config_mix_full) then - - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & - -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - - else ! idealized cases where we mix on the perturbation from the initial 1-D state - - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) - - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) - - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & - -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) - end do - end do - - end if - - end if - - if ( config_les_model /= "none") then - - do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column - ! compute turbulent fluxes - turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain - turb_vflux(1) = 0. ! lower bc flux handled where ??? - do k=2,nVertLevels - rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & - +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) - zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) - turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) - end do - - ! test boundary conditions for supercell and les test cases - - if( les_test ) then - turb_vflux(1) = tke_heat_flux*rho_zz(1,iCell) ! this is correct for DRY CASE ONLY - ! SAS case lower flux for theta_m - code goes here - - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) - else - turb_vflux(1) = turb_vflux(2) - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) - end if - - - do k=1,nVertLevels - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & - - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) - end do - end do - - end if - - if(debug_dissipation) call mpas_log_write(' exiting theta_dissipation_3d ') - - end subroutine theta_dissipation_3d - !----------------------------------------------------- subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & From 49372ce4707e6fde3b27fac13b89cf9b8645e418 Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Thu, 9 Oct 2025 13:01:58 -0600 Subject: [PATCH 086/109] Merge with Bill Skamarock updated LES modules --- src/core_atmosphere/Registry.xml | 5 ++ .../dynamics/mpas_atm_dissipation_models.F | 83 +++++++++++-------- .../dynamics/mpas_atm_time_integration.F | 29 +++---- 3 files changed, 69 insertions(+), 48 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 86cf2e749a..7cfd643b5e 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -166,6 +166,11 @@ description="Scaling coefficient of $\delta x^3$ to obtain $\nabla^4$ diffusion coefficient" possible_values="Non-negative real values"/> + + 0.0).and. hmix4_scalars) then ! 4th order mixing is active + if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) @@ -1147,7 +1162,8 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! end do do k=2,nVertLevels - prandtl_1d_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) + ! prandtl_1d_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) + prandtl_1d_inverse(k) = fzm(k)*prandtl_3d_inv(k,iCell)+fzp(k)*prandtl_3d_inv(k-1,iCell) end do end if @@ -1158,9 +1174,8 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) ! bv_frequency2 = 0.5*(bv_freq2(k)+bv_freq(k-1)) ! bv = max( sqrt(abs(bv_frequency2)), epsilon_bv ) - - rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & - +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) turb_vflux(k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) end do @@ -1202,14 +1217,14 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do - if (mix_scalars .and. vmix_scalars) then + if (mix_scalars ) then ! compute turbulent fluxes turb_vflux_scalars(:,nVertlevels+1) = 0. ! no turbulent flux out of the domain turb_vflux_scalars(:,1) = 0. ! lower bc flux handled where ??? do k=2,nVertLevels - rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & - +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) do iScalar=1,num_scalars turb_vflux_scalars(iScalar,k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)* & diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index dde697a3e1..05dd4feb36 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1173,7 +1173,7 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !$OMP PARALLEL DO do thread=1,nThreads call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, diag_physics, & - block % configs, nVertLevels, rk_step, dt, & + block % configs, nVertLevels, rk_step, dynamics_substep, dt, & cellThreadStart(thread), cellThreadEnd(thread), & vertexThreadStart(thread), vertexThreadEnd(thread), & edgeThreadStart(thread), edgeThreadEnd(thread), & @@ -4736,7 +4736,7 @@ subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdge end subroutine atm_advance_scalars_mono_work - subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_physics, configs, nVertLevels, rk_step, dt, & + subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_physics, configs, nVertLevels, rk_step, dynamics_substep, dt, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -4765,7 +4765,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys type (mpas_pool_type), intent(in) :: diag_physics type (mpas_pool_type), intent(in) :: configs integer, intent(in) :: nVertLevels ! for allocating stack variables - integer, intent(in) :: rk_step + integer, intent(in) :: rk_step, dynamics_substep real (kind=RKIND), intent(in) :: dt integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd @@ -4825,6 +4825,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys real (kind=RKIND), pointer :: coef_3rd_order, c_s logical, pointer :: config_mix_full + logical, pointer :: config_mix_scalars character (len=StrKIND), pointer :: config_horiz_mixing character (len=StrKIND), pointer :: config_les_model character (len=StrKIND), pointer :: config_les_surface @@ -4848,6 +4849,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys call mpas_pool_get_config(mesh, 'sphere_radius', r_earth) call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) call mpas_pool_get_config(configs, 'config_mix_full', config_mix_full) + call mpas_pool_get_config(configs, 'config_mix_scalars', config_mix_scalars) call mpas_pool_get_config(configs, 'config_horiz_mixing', config_horiz_mixing) call mpas_pool_get_config(configs, 'config_les_model', config_les_model) call mpas_pool_get_config(configs, 'config_les_surface', config_les_surface) @@ -5005,10 +5007,10 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys 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, & deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & - tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_les_model, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_mix_scalars, config_horiz_mixing, config_les_model, & config_les_surface, prandtl_3d_inv, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & - config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & + config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dynamics_substep, dt, & config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & @@ -5033,10 +5035,10 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm 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, & deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & - tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_les_model, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_mix_scalars, config_horiz_mixing, config_les_model, & config_les_surface, prandtl_3d_inv, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & - config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & + config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dynamics_substep, dt, & config_mpas_cam_coef, & config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & @@ -5155,7 +5157,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: tend_w_buoy real (kind=RKIND) :: coef_3rd_order, c_s - logical :: config_mix_full + logical :: config_mix_full, config_mix_scalars character (len=StrKIND) :: config_horiz_mixing character (len=StrKIND) :: config_les_model character (len=StrKIND) :: config_les_surface @@ -5166,9 +5168,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: config_len_disp real (kind=RKIND) :: config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2 logical, parameter :: test_dissipation_3d=.true. - logical, parameter :: mix_scalars = .true. - integer, intent(in) :: rk_step + integer, intent(in) :: rk_step, dynamics_substep real (kind=RKIND), intent(in) :: dt real (kind=RKIND) :: config_mpas_cam_coef @@ -5321,7 +5322,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*dt ! call mpas_log_write(' les integration, timestep midpoint time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) - call les_models( config_les_model, config_les_surface, eddy_visc_horz, eddy_visc_vert, & + call les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & u, v, ur_cell, vr_cell, & w, c_s, bn2, zgrid, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & @@ -5695,7 +5696,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm rdzw, rdzu, & v_mom_eddy_visc2, h_mom_eddy_visc4, & delsq_w, & - w, rho_edge, rho_zz, zz, & + w, rho_edge, rho_zz, divergence, zz, & eddy_visc_horz, eddy_visc_vert, & config_les_model, config_les_surface, & tend_w_euler ) @@ -5887,11 +5888,11 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm theta_m, rho_edge, rho_zz, zz, & eddy_visc_horz, eddy_visc_vert, & bn2, config_len_disp, scalars, tend_scalars, & - index_tke, index_qv, num_scalars, mix_scalars, & + index_tke, index_qv, num_scalars, config_mix_scalars, & config_les_model, config_les_surface, time_of_day_seconds,& ur_cell, vr_cell, & hfx, qfx, & - tend_theta_euler ) + tend_theta_euler, dynamics_substep ) ! else ! this is the original MPAS dissipation code From 6345dc1640d1cd79c1d68ae035769e883d15daab Mon Sep 17 00:00:00 2001 From: Jimy Dudhia Date: Tue, 21 Oct 2025 13:24:09 -0600 Subject: [PATCH 087/109] add surface flux namelist options --- src/core_atmosphere/Registry.xml | 17 ++++++++++++++++- .../dynamics/mpas_atm_dissipation_models.F | 15 ++++++++++----- .../dynamics/mpas_atm_time_integration.F | 13 +++++++++++++ 3 files changed, 39 insertions(+), 6 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 7cfd643b5e..2264cf1fd5 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -154,7 +154,22 @@ + possible_values="'specified', `varying'"/> + + + + + + Date: Thu, 4 Dec 2025 15:32:48 -0700 Subject: [PATCH 088/109] Add explicit declarations of iCell, k, and p in the calculate_n2 routine By ensuring that all variables are explicitly declared in the calculate_n2 routine, the code can be built with compiler flags (e.g., -fimplicit-none) that forbid implicitly declared variables. --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 50c0619962..7753e692c5 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -340,7 +340,8 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: zgrid real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars ! local - real (kind=RKIND) :: dz, rdz, esw + integer :: iCell, k + real (kind=RKIND) :: dz, rdz, esw, p real (kind=RKIND), parameter :: qc_cr = 0.00001 ! in kg/kg real (kind=RKIND), dimension(nVertLevels) :: theta, qvsw, temp, coefa logical :: dry_bv_frequency From a6eec0e0794771092ef43480c2a478fd75d3f90e Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 17:01:35 -0700 Subject: [PATCH 089/109] Avoid passing null pointers for ustm, hfx, and qfx to atm_compute_dyn_tend_work The dummy arguments for ustm, hfx, and qfx in the atm_compute_dyn_tend_work routine are not pointers, and so passing unassociated pointers for the actual arguments is invalid and will trigger a runtime error when debugging options are enabled with the GNU compilers. The workaround adopted in this commit is to allocate the ustm, hfx, and qfx array pointers with a trivial size if these fields are not available (due to packages associated with PBL schemes), and to deallocate them after the call to atm_compute_dyn_tend_work. The dummy arguments for ustm, hfx, and qfx in atm_compute_dyn_tend_work (as well as in u_dissipation_3d and scalar_dissipation_3d_les) are now assumed-shape arrays, as the actual arguments may not have (nCells+1) elements. --- .../dynamics/mpas_atm_dissipation_models.F | 4 ++-- .../dynamics/mpas_atm_time_integration.F | 23 ++++++++++++++++++- 2 files changed, 24 insertions(+), 3 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 7753e692c5..1b35cedd3a 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -484,7 +484,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_divergence real (kind=RKIND), dimension(nVertLevels), intent(in) :: u_init, v_init - real (kind=RKIND), dimension(nCells+1), intent(in) :: ustm + real (kind=RKIND), dimension(:), intent(in) :: ustm real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(out) :: tend_u_euler @@ -964,7 +964,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rho_zz real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: rho_edge - real (kind=RKIND), dimension(nCells+1), intent(in) :: hfx, qfx + real (kind=RKIND), dimension(:), intent(in) :: hfx, qfx real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index e5b9c98733..f54804cc93 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4847,6 +4847,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys integer, pointer :: index_qv, index_qc, index_tke logical :: inactive_rthdynten + logical :: nopbl call mpas_pool_get_config(mesh, 'sphere_radius', r_earth) @@ -4910,10 +4911,24 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) + nullify(ustm) call mpas_pool_get_array(diag_physics,'ustm',ustm) + nullify(hfx) call mpas_pool_get_array(diag_physics,'hfx',hfx) + nullify(qfx) call mpas_pool_get_array(diag_physics,'qfx',qfx) + nopbl = .false. + if (.not. associated(ustm) & + .or. .not. associated(hfx) & + .or. .not. associated(qfx)) then + + allocate(ustm(1)) + allocate(hfx(1)) + allocate(qfx(1)) + nopbl = .true. + end if + call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) @@ -5025,6 +5040,12 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + if (nopbl) then + deallocate(ustm) + deallocate(hfx) + deallocate(qfx) + end if + end subroutine atm_compute_dyn_tend @@ -5108,7 +5129,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_horz real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1) :: bn2 - real (kind=RKIND), dimension(nCells+1) :: ustm, hfx, qfx + real (kind=RKIND), dimension(:) :: ustm, hfx, qfx real (kind=RKIND), dimension(nVertLevels,nCells+1) :: prandtl_3d_inv real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign real (kind=RKIND), dimension(vertexDegree,nVertices+1) :: edgesOnVertex_sign From 44e0d396c63585382436c6381c1aaa64b4e79aa2 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Thu, 4 Dec 2025 19:15:30 -0700 Subject: [PATCH 090/109] Remove unused variables from new LES code This commit removes unused variables from the new LES code -- both the test case initialization routine (init_atm_case_les) as well as the new mpas_atm_dissipation_models.F file. --- .../dynamics/mpas_atm_dissipation_models.F | 5 ++--- src/core_init_atmosphere/mpas_init_atm_cases.F | 18 +++++++----------- 2 files changed, 9 insertions(+), 14 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 1b35cedd3a..5328f0e4a0 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -150,7 +150,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e real (kind=RKIND) :: rdz, def2, pr_inv, wk real (kind=RKIND) :: shear_production, buoyancy, dissipation, delta_z, delta_s, bv, tke_length, diss_length real (kind=RKIND) :: l_horizontal, l_vertical, c_dissipation - real (kind=RKIND) :: prandtl_horizontal_inv, prandtl_vertical_inv + real (kind=RKIND) :: prandtl_horizontal_inv real (kind=RKIND) :: eddy_visc_h, eddy_visc_v logical, parameter :: test_tke=.true. @@ -978,9 +978,8 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux, prandtl_1d_inverse real (kind=RKIND), dimension(num_scalars,nVertLevels+1) :: turb_vflux_scalars real (kind=RKIND) :: rho_k_at_w, zz_at_w - real (kind=RKIND) :: delta_z, delta_s, tke_length, bv_frequency2 - real (kind=RKIND) :: moisture_flux, heat_flux, theta_m_flux, c_h, c_q + real (kind=RKIND) :: moisture_flux, heat_flux, theta_m_flux real (kind=RKIND) :: qv_cell, theta_m_cell, theta_cell if(debug_dissipation) then diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 9f936dcf93..9c372cb163 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -6261,36 +6261,32 @@ subroutine init_atm_case_les(dminfo, mesh, fg, nCells, nVertLevels, state, diag, integer, dimension(:), pointer :: landmask, lu_index !This is temporary variable here. It just need when calculate tangential velocity v. - integer :: eoe, j + integer :: eoe integer, dimension(:), pointer :: nEdgesOnEdge integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge real (kind=RKIND), pointer :: x_period, y_period - integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, cell1, cell2 + integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, nz1, itr, cell1, cell2 integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve integer, pointer :: index_qv integer, pointer :: index_tke - real (kind=RKIND), dimension(nVertLevels + 1 ) :: znu, znw, znwc, znwv - real (kind=RKIND), dimension(nVertLevels + 1 ) :: znuc, znuv - real (kind=RKIND), dimension(nVertLevels + 1 ) :: zc, zw, ah real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm - real (kind=RKIND), dimension(nVertLevels, nCells) :: relhum, thi, tbi, cqwb + real (kind=RKIND), dimension(nVertLevels, nCells) :: thi, tbi, cqwb - real (kind=RKIND) :: r, xnutr + real (kind=RKIND) :: xnutr real (kind=RKIND) :: ztemp, zd, zt, dz, str real (kind=RKIND), dimension(nVertLevels ) :: qvb, qvp, zg real (kind=RKIND), dimension(nVertLevels ) :: t_init_1d - real (kind=RKIND) :: d1, d2, d3, cof1, cof2 + real (kind=RKIND) :: cof1, cof2 real (kind=RKIND), pointer :: cf1, cf2, cf3 - real (kind=RKIND) :: ztr, thetar, ttr, thetas, um, us, zts, pitop, pibtop, ptopb, ptop, rcp, rcv, p0 - real (kind=RKIND) :: radx, radz, zcent, xmid, delt, xloc, rad, yloc, ymid, a_scale - real (kind=RKIND) :: pres, temp, es, qvs + real (kind=RKIND) :: pitop, pibtop, ptopb, ptop, rcp, rcv, p0 + real (kind=RKIND) :: a_scale real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge From 197296f61ee44f816c99e5ce554094b7b4b97374 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 5 Dec 2025 12:13:38 -0700 Subject: [PATCH 091/109] Clean up trailing whitespace and indentation in mpas_atm_dissipation_models.F --- .../dynamics/mpas_atm_dissipation_models.F | 1452 +++++++++-------- 1 file changed, 730 insertions(+), 722 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 5328f0e4a0..70cf9c24b3 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -8,37 +8,38 @@ module mpas_atm_dissipation_models - use mpas_kind_types, only : RKIND - use mpas_atmphys_constants - use mpas_constants - use mpas_log - use mpas_derived_types, only : MPAS_LOG_CRIT - - logical, parameter :: debug_dissipation = .false. - logical, parameter :: les_test = .true., les_sas_test = .false. - !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour - ! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 - ! real (kind=RKIND), parameter :: tke_heat_flux = 0.0 - !! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 ! ocean roughness length - ! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.006 - ! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0 - real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 - ! real (kind=RKIND), parameter :: c_k = 0.1 - real (kind=RKIND), parameter :: c_k = 0.25 - - - contains - - subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, & - deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & - invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & - cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & - nCells, nEdges ) + use mpas_kind_types, only : RKIND + use mpas_atmphys_constants + use mpas_constants + use mpas_log + use mpas_derived_types, only : MPAS_LOG_CRIT + + logical, parameter :: debug_dissipation = .false. + logical, parameter :: les_test = .true., les_sas_test = .false. + !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour + ! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 + ! real (kind=RKIND), parameter :: tke_heat_flux = 0.0 + !! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0013 ! ocean roughness length + ! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.006 + ! real (kind=RKIND), parameter :: tke_drag_coefficient = 0.0 + real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 + ! real (kind=RKIND), parameter :: c_k = 0.1 + real (kind=RKIND), parameter :: c_k = 0.25 + + +contains + + + subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, & + nCells, nEdges ) use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here implicit none - + integer, intent(in) :: cellStart, cellEnd, nCells, nEdges real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: u real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: v @@ -57,59 +58,60 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, integer :: iCell, iEdge, k real (kind=RKIND), dimension(nVertLevels) :: d_11, d_22, d_12, dudx, dudy, dvdx, dvdy - if(debug_dissipation) call mpas_log_write(' begin smagorinsky_2d ') + if(debug_dissipation) call mpas_log_write(' begin smagorinsky_2d ') - do iCell = cellStart,cellEnd - dudx(1:nVertLevels) = 0.0 - dudy(1:nVertLevels) = 0.0 - dvdx(1:nVertLevels) = 0.0 - dvdy(1:nVertLevels) = 0.0 - do iEdge=1,nEdgesOnCell(iCell) - do k=1,nVertLevels - dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - - deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - - deformation_coef_s2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - + deformation_coef_c2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - + deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) - end do - end do -!DIR$ IVDEP - do k=1, nVertLevels - ! here is the Smagorinsky formulation, - ! followed by imposition of an upper bound on the eddy viscosity - d_11(k) = 2*dudx(k) - d_22(k) = 2*dvdy(k) - d_12(k) = dudy(k) + dvdx(k) - kdiff(k,iCell) = (c_s * config_len_disp)**2 * sqrt(0.25*(d_11(k)-d_22(k))**2 + d_12(k)**2) - kdiff(k,iCell) = min(kdiff(k,iCell),(0.01*config_len_disp**2) * invDt) - end do + do iCell = cellStart,cellEnd + dudx(1:nVertLevels) = 0.0 + dudy(1:nVertLevels) = 0.0 + dvdx(1:nVertLevels) = 0.0 + dvdy(1:nVertLevels) = 0.0 + do iEdge=1,nEdgesOnCell(iCell) + do k=1,nVertLevels + dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + - deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + - deformation_coef_s2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + + deformation_coef_c2(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) + dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & + + deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) end do + end do + +!DIR$ IVDEP + do k=1, nVertLevels + ! here is the Smagorinsky formulation, + ! followed by imposition of an upper bound on the eddy viscosity + d_11(k) = 2*dudx(k) + d_22(k) = 2*dvdy(k) + d_12(k) = dudy(k) + dvdx(k) + kdiff(k,iCell) = (c_s * config_len_disp)**2 * sqrt(0.25*(d_11(k)-d_22(k))**2 + d_12(k)**2) + kdiff(k,iCell) = min(kdiff(k,iCell),(0.01*config_len_disp**2) * invDt) + end do + end do - h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 - h_theta_eddy_visc4 = h_mom_eddy_visc4 + h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 + h_theta_eddy_visc4 = h_mom_eddy_visc4 - if(debug_dissipation) call mpas_log_write(' exiting smagorinsky_2d ') + if(debug_dissipation) call mpas_log_write(' exiting smagorinsky_2d ') - end subroutine smagorinsky_2d + end subroutine smagorinsky_2d !--------------------------------------- - subroutine les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & - u, v, uCell, vCell, & - w, c_s, bv_freq2, zgrid, config_len_disp, & - deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & - deformation_coef_c, deformation_coef_s, prandtl_3d_inv, & - invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & - scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & - cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & - nCells, nEdges, nVertLevels, maxEdges, num_scalars ) + subroutine les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & + u, v, uCell, vCell, & + w, c_s, bv_freq2, zgrid, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + deformation_coef_c, deformation_coef_s, prandtl_3d_inv, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & + nCells, nEdges, nVertLevels, maxEdges, num_scalars ) implicit none - + character (len=StrKIND), intent(in) :: config_les_model character (len=StrKIND), intent(in) :: config_les_surface @@ -143,7 +145,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e ! local variables integer :: iCell, iEdge, k, ie, cell1, cell2 - real (kind=RKIND), dimension(nVertLevels) :: d_11, d_22, d_33, d_12, d_13, d_23 + real (kind=RKIND), dimension(nVertLevels) :: d_11, d_22, d_33, d_12, d_13, d_23 real (kind=RKIND), dimension(nVertLevels) :: dudx, dudy, dvdx, dvdy real (kind=RKIND), dimension(nVertLevels+1) :: dwdx, dwdy real (kind=RKIND), dimension(nVertLevels) :: dudz, dvdz, dwdz @@ -169,167 +171,167 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e do iCell = cellStart,cellEnd - dudx(1:nVertLevels) = 0.0 - dudy(1:nVertLevels) = 0.0 - dvdx(1:nVertLevels) = 0.0 - dvdy(1:nVertLevels) = 0.0 - dwdx(1:nVertLevels+1) = 0.0 - dwdy(1:nVertLevels+1) = 0.0 - - dudz(1:nVertLevels) = 0.0 - dvdz(1:nVertLevels) = 0.0 - dwdz(1:nVertLevels) = 0.0 - - do iEdge=1,nEdgesOnCell(iCell) - - ie = EdgesOnCell(iEdge,iCell) - cell1 = cellsOnEdge(1,ie) - cell2 = cellsOnEdge(2,ie) - - do k=1,nVertLevels - dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,ie) & - - deformation_coef_cs(iEdge,iCell)*v(k,ie) - dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,ie) & - - deformation_coef_s2(iEdge,iCell)*v(k,ie) - dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,ie) & - + deformation_coef_c2(iEdge,iCell)*v(k,ie) - dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,ie) & - + deformation_coef_cs(iEdge,iCell)*v(k,ie) - end do - - do k=1,nVertLevels+1 - wk = 0.5*(w(k,cell1)+w(k,cell2)) - dwdx(k) = dwdx(k) + deformation_coef_c(iEdge,iCell)*wk - dwdy(k) = dwdy(k) + deformation_coef_s(iEdge,iCell)*wk - end do - - end do - - do k=1,nVertLevels - rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) - dwdz(k) = (w(k+1,iCell)-w(k,iCell))*rdz - end do - - do k=2,nVertLevels-1 - rdz = 1./(zgrid(k+2,iCell)+zgrid(k+1,iCell)-zgrid(k,iCell)-zgrid(k-1,iCell)) - dudz(k) = (uCell(k+1,iCell)-uCell(k-1,iCell))*rdz - dvdz(k) = (vCell(k+1,iCell)-vCell(k-1,iCell))*rdz - end do - - k = 1 - rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) - dudz(k) = (uCell(k+1,iCell)-uCell(k,iCell))*rdz - dvdz(k) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz - - k = nVertLevels-1 - rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) - dudz(k+1) = (uCell(k+1,iCell)-uCell(k,iCell))*rdz - dvdz(k+1) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz - - do k=1, nVertLevels - d_11(k) = 2.*dudx(k) - d_22(k) = 2.*dvdy(k) - d_33(k) = 2.*dwdz(k) - d_12(k) = dudy(k) + dvdx(k) - d_13(k) = dwdx(k) + dudz(k) - d_23(k) = dwdy(k) + dvdz(k) - end do - - if (config_les_model == "3d_smagorinsky") then - - do k=1, nVertLevels - def2 = 0.5*(d_11(k)**2 + d_22(k)**2 + d_33(k)**2) + d_12(k)**2 + d_13(k)**2 + d_23(k)**2 - eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) - eddy_visc_horz(k,iCell) = min(eddy_visc_horz(k,iCell),(0.01*config_len_disp**2) * invDt) - delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) - eddy_visc_vert(k,iCell) = (c_s * delta_z)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) - ! eddy_visc_vert(k,iCell) = eddy_visc_horz(k,iCell) - end do - - else if (config_les_model == "prognostic_1.5_order") then - - do k=1,nVertLevels ! bound the tke here, currently hardwired - ! scalars(index_tke,k,iCell) = max(0.,min(100.,scalars(index_tke,k,iCell))) - scalars(index_tke,k,iCell) = max(0.,scalars(index_tke,k,iCell)) - end do - - do k=1,nVertLevels - - delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) - delta_s = ((config_len_disp**2)*delta_z)**(1./3.) - bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon_bv ) - tke_length = delta_s - ! isentropic mixing formulation - if(bv_freq2(k,iCell) .gt. 1.e-06) & - tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv - tke_length = min(tke_length, delta_z) - diss_length = min(delta_s,max(tke_length,0.01*delta_s)) - if(bv_freq2(k,iCell) <= 0) diss_length = delta_s - - ! non-isotropic mixing - - l_horizontal = config_len_disp - l_vertical = min(delta_z,tke_length) - if(bv_freq2(k,iCell) <= 0) diss_length = delta_z - - ! isotropic mixing + dudx(1:nVertLevels) = 0.0 + dudy(1:nVertLevels) = 0.0 + dvdx(1:nVertLevels) = 0.0 + dvdy(1:nVertLevels) = 0.0 + dwdx(1:nVertLevels+1) = 0.0 + dwdy(1:nVertLevels+1) = 0.0 + + dudz(1:nVertLevels) = 0.0 + dvdz(1:nVertLevels) = 0.0 + dwdz(1:nVertLevels) = 0.0 + + do iEdge=1,nEdgesOnCell(iCell) + + ie = EdgesOnCell(iEdge,iCell) + cell1 = cellsOnEdge(1,ie) + cell2 = cellsOnEdge(2,ie) + + do k=1,nVertLevels + dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,ie) & + - deformation_coef_cs(iEdge,iCell)*v(k,ie) + dudy(k) = dudy(k) + deformation_coef_cs(iEdge,iCell)*u(k,ie) & + - deformation_coef_s2(iEdge,iCell)*v(k,ie) + dvdx(k) = dvdx(k) + deformation_coef_cs(iEdge,iCell)*u(k,ie) & + + deformation_coef_c2(iEdge,iCell)*v(k,ie) + dvdy(k) = dvdy(k) + deformation_coef_s2(iEdge,iCell)*u(k,ie) & + + deformation_coef_cs(iEdge,iCell)*v(k,ie) + end do + + do k=1,nVertLevels+1 + wk = 0.5*(w(k,cell1)+w(k,cell2)) + dwdx(k) = dwdx(k) + deformation_coef_c(iEdge,iCell)*wk + dwdy(k) = dwdy(k) + deformation_coef_s(iEdge,iCell)*wk + end do + + end do + + do k=1,nVertLevels + rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) + dwdz(k) = (w(k+1,iCell)-w(k,iCell))*rdz + end do + + do k=2,nVertLevels-1 + rdz = 1./(zgrid(k+2,iCell)+zgrid(k+1,iCell)-zgrid(k,iCell)-zgrid(k-1,iCell)) + dudz(k) = (uCell(k+1,iCell)-uCell(k-1,iCell))*rdz + dvdz(k) = (vCell(k+1,iCell)-vCell(k-1,iCell))*rdz + end do + + k = 1 + rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) + dudz(k) = (uCell(k+1,iCell)-uCell(k,iCell))*rdz + dvdz(k) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz + + k = nVertLevels-1 + rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) + dudz(k+1) = (uCell(k+1,iCell)-uCell(k,iCell))*rdz + dvdz(k+1) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz + + do k=1, nVertLevels + d_11(k) = 2.*dudx(k) + d_22(k) = 2.*dvdy(k) + d_33(k) = 2.*dwdz(k) + d_12(k) = dudy(k) + dvdx(k) + d_13(k) = dwdx(k) + dudz(k) + d_23(k) = dwdy(k) + dvdz(k) + end do + + if (config_les_model == "3d_smagorinsky") then + + do k=1, nVertLevels + def2 = 0.5*(d_11(k)**2 + d_22(k)**2 + d_33(k)**2) + d_12(k)**2 + d_13(k)**2 + d_23(k)**2 + eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) + eddy_visc_horz(k,iCell) = min(eddy_visc_horz(k,iCell),(0.01*config_len_disp**2) * invDt) + delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) + eddy_visc_vert(k,iCell) = (c_s * delta_z)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) + ! eddy_visc_vert(k,iCell) = eddy_visc_horz(k,iCell) + end do + + else if (config_les_model == "prognostic_1.5_order") then + + do k=1,nVertLevels ! bound the tke here, currently hardwired + ! scalars(index_tke,k,iCell) = max(0.,min(100.,scalars(index_tke,k,iCell))) + scalars(index_tke,k,iCell) = max(0.,scalars(index_tke,k,iCell)) + end do + + do k=1,nVertLevels + + delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) + delta_s = ((config_len_disp**2)*delta_z)**(1./3.) + bv = max( sqrt(abs(bv_freq2(k,iCell))), epsilon_bv ) + tke_length = delta_s + ! isentropic mixing formulation + if(bv_freq2(k,iCell) .gt. 1.e-06) & + tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/bv + tke_length = min(tke_length, delta_z) + diss_length = min(delta_s,max(tke_length,0.01*delta_s)) + if(bv_freq2(k,iCell) <= 0) diss_length = delta_s + + ! non-isotropic mixing + + l_horizontal = config_len_disp + l_vertical = min(delta_z,tke_length) + if(bv_freq2(k,iCell) <= 0) diss_length = delta_z + + ! isotropic mixing - ! l_horizontal = min(delta_s,tke_length) - ! if(bv_freq2(k,iCell) <= 0) diss_length = delta_s - ! l_vertical = l_horizontal + ! l_horizontal = min(delta_s,tke_length) + ! if(bv_freq2(k,iCell) <= 0) diss_length = delta_s + ! l_vertical = l_horizontal - ! eddy viscocities set here if we are running the 1.5 order prognostic tke scheme - eddy_visc_h = c_k*l_horizontal*sqrt(scalars(index_tke,k,iCell)) - eddy_visc_h = min(eddy_visc_h,(0.01*config_len_disp**2) * invDt) - eddy_visc_v = c_k*l_vertical*sqrt(scalars(index_tke,k,iCell)) - eddy_visc_v = min(eddy_visc_v,(0.01*delta_z**2) * invDt) + ! eddy viscocities set here if we are running the 1.5 order prognostic tke scheme + eddy_visc_h = c_k*l_horizontal*sqrt(scalars(index_tke,k,iCell)) + eddy_visc_h = min(eddy_visc_h,(0.01*config_len_disp**2) * invDt) + eddy_visc_v = c_k*l_vertical*sqrt(scalars(index_tke,k,iCell)) + eddy_visc_v = min(eddy_visc_v,(0.01*delta_z**2) * invDt) - eddy_visc_horz(k,iCell) = eddy_visc_h - eddy_visc_vert(k,iCell) = eddy_visc_v + eddy_visc_horz(k,iCell) = eddy_visc_h + eddy_visc_vert(k,iCell) = eddy_visc_v - ! terms for the prognostic tke integration + ! terms for the prognostic tke integration - shear_production = eddy_visc_h*(d_11(k)**2 + d_22(k)**2 + d_12(k)**2) & - +eddy_visc_v*(d_33(k)**2 + d_13(k)**2 + d_23(k)**2) + shear_production = eddy_visc_h*(d_11(k)**2 + d_22(k)**2 + d_12(k)**2) & + +eddy_visc_v*(d_33(k)**2 + d_13(k)**2 + d_23(k)**2) - buoyancy = -eddy_visc_v*bv_freq2(k,iCell) + buoyancy = -eddy_visc_v*bv_freq2(k,iCell) - ! dissipation + ! dissipation - c_dissipation = 1.9*c_k + max( 0.0, 0.93 - 1.9*c_k )*diss_length/delta_s - ! if( (k.eq. 1) .or. (k.eq.nVertLevels) ) c_dissipation = 3.9 + c_dissipation = 1.9*c_k + max( 0.0, 0.93 - 1.9*c_k )*diss_length/delta_s + ! if( (k.eq. 1) .or. (k.eq.nVertLevels) ) c_dissipation = 3.9 - dissipation = -c_dissipation*(scalars(index_tke,k,iCell)**(1.5))/diss_length + dissipation = -c_dissipation*(scalars(index_tke,k,iCell)**(1.5))/diss_length - ! computing eddy viscosities ********* + ! computing eddy viscosities ********* - prandtl_horizontal_inv = 3. - prandtl_3d_inv(k,iCell) = 1.0+(2.0*l_vertical/delta_z) - + prandtl_horizontal_inv = 3. + prandtl_3d_inv(k,iCell) = 1.0+(2.0*l_vertical/delta_z) - ! RHS term for the subgrid ke. - if(dynamics_substep == 1) & - tend_scalars(index_tke,k,iCell) = rho_zz(k,iCell)*( shear_production + buoyancy + dissipation ) + ! RHS term for the subgrid ke. - end do + if(dynamics_substep == 1) & + tend_scalars(index_tke,k,iCell) = rho_zz(k,iCell)*( shear_production + buoyancy + dissipation ) - else + end do + + else - call mpas_log_write(' in les_models, no les scheme for '//trim(config_les_model), messageType=MPAS_LOG_CRIT) - - end if ! end of config_les_model test + call mpas_log_write(' in les_models, no les scheme for '//trim(config_les_model), messageType=MPAS_LOG_CRIT) + + end if ! end of config_les_model test end do ! loop over all owned cells (columns) if(debug_dissipation) call mpas_log_write(' les_models ') - end subroutine les_models + end subroutine les_models !--------------------------------------- - subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & - cellStart, cellEnd, nCells) + subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & + cellStart, cellEnd, nCells) use mpas_atm_dimensions ! pull nVertLevels and num_scalars from here @@ -346,87 +348,88 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(nVertLevels) :: theta, qvsw, temp, coefa logical :: dry_bv_frequency - if(debug_dissipation) call mpas_log_write(' begin BV frequency calculations ') + if(debug_dissipation) call mpas_log_write(' begin BV frequency calculations ') - do iCell = cellStart,cellEnd + do iCell = cellStart,cellEnd !DIR$ IVDEP - do k=1, nVertLevels + do k=1, nVertLevels - theta(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) + theta(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) - temp(k) = exner(k,iCell) * theta(k) + temp(k) = exner(k,iCell) * theta(k) - p = pressure_b(k,iCell) + pp(k,iCell) - esw = 1000. * svp1 * exp(svp2 * (temp(k) - svpt0) / (temp(k) - svp3)) - if (p < esw) esw = p * 0.99 ! fix for pressure < esw - qvsw(k) = ep_2 * esw / (p - esw) + p = pressure_b(k,iCell) + pp(k,iCell) + esw = 1000. * svp1 * exp(svp2 * (temp(k) - svpt0) / (temp(k) - svp3)) + if (p < esw) esw = p * 0.99 ! fix for pressure < esw + qvsw(k) = ep_2 * esw / (p - esw) - coefa(k) = ( 1.0 + xlv * qvsw(k)/ R_d / temp(k) ) / & - ( 1.0 + xlv * xlv *qvsw(k) / Cp / R_v / temp(k) / temp(k) ) + coefa(k) = ( 1.0 + xlv * qvsw(k)/ R_d / temp(k) ) / & + ( 1.0 + xlv * xlv *qvsw(k) / Cp / R_v / temp(k) / temp(k) ) - end do + end do - do k=2, nVertLevels-1 - dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) - rdz = 1.0/dz - - ! if ( scalars(index_qc,k,iCell) < qc_cr ) then - ! ! Dry Brunt-Vaisala frequency - ! bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & - ! + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) / dz & - ! - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) - ! else - ! ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 - ! bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & - ! + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) / dz ) & - ! - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) - ! endif - - dry_bv_frequency = .true. - if(index_qc .gt. 0) then ! if moist simulation, qc exists - if ( scalars(index_qc,k,iCell) .ge. qc_cr ) dry_bv_frequency = .false. - end if - - if (dry_bv_frequency) then - ! Dry Brunt-Vaisala frequency - bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) * rdz & - + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) * rdz & - - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) * rdz ) - else - ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 - bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) * rdz & - + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) * rdz ) & - - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) * rdz ) - endif + do k=2, nVertLevels-1 + dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) + rdz = 1.0/dz + + ! if ( scalars(index_qc,k,iCell) < qc_cr ) then + ! ! Dry Brunt-Vaisala frequency + ! bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & + ! + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) / dz & + ! - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) + ! else + ! ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 + ! bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) / dz & + ! + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) / dz ) & + ! - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) / dz ) + ! endif + + dry_bv_frequency = .true. + if(index_qc .gt. 0) then ! if moist simulation, qc exists + if ( scalars(index_qc,k,iCell) .ge. qc_cr ) dry_bv_frequency = .false. + end if - end do - bn2(1,iCell) = bn2(2,iCell) - bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) + if (dry_bv_frequency) then + ! Dry Brunt-Vaisala frequency + bn2(k,iCell) = gravity * ((theta(k+1) - theta(k-1) ) / theta(k) * rdz & + + rvord * (scalars(index_qv,k+1,iCell) - scalars(index_qv,k-1,iCell)) * rdz & + - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) * rdz ) + else + ! Moist Brunt-Vaisala frequency according to Durran and Klemp (1982) Eq. 36 + bn2(k,iCell) = gravity * ( coefa(k) * ((theta(k+1) - theta(k-1) ) / theta(k) * rdz & + + xlv / cp / temp(k) * ( qvsw(k+1) - qvsw(k-1)) * rdz ) & + - ( qtot(k+1, iCell) - qtot(k-1, iCell) ) * rdz ) + endif - end do + end do + + bn2(1,iCell) = bn2(2,iCell) + bn2(nVertLevels,iCell) = bn2(nVertLevels-1,iCell) + + end do - if(debug_dissipation) call mpas_log_write(' exiting BV frequency calculations ') + if(debug_dissipation) call mpas_log_write(' exiting BV frequency calculations ') - end subroutine calculate_n2 + end subroutine calculate_n2 !--------------------------------------- - subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & - cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & - cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & - nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & - invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & - angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & - config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & - config_del4u_div_factor, zgrid, & - eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & - fzm, fzp, config_les_model, config_les_surface, & - config_surface_drag_coefficient, & - delsq_u, delsq_vorticity, delsq_divergence, & - u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, & - tend_u_euler ) - - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & + cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & + nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & + invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & + angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & + config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & + config_del4u_div_factor, zgrid, & + eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & + fzm, fzp, config_les_model, config_les_surface, & + config_surface_drag_coefficient, & + delsq_u, delsq_vorticity, delsq_divergence, & + u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, & + tend_u_euler ) + + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here implicit none @@ -488,7 +491,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(out) :: tend_u_euler - ! local variables + ! local variables integer :: iEdge, cell1, cell2, vertex1, vertex2, iVertex, iCell, i, k real (kind=RKIND) :: r_dc, r_dv, u_diffusion, u_diffusion_les, kdiffu, r, edge_sign, u_mix_scale @@ -503,244 +506,244 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND) :: velocity_magnitude real (kind=RKIND) :: tau_12_factor - if(debug_dissipation) then - call mpas_log_write(' begin u_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' les surface is '//trim(config_les_surface)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) - call mpas_log_write(' 4th order divergence factor is $r ', realArgs=(/config_del4u_div_factor/)) - end if + if(debug_dissipation) then + call mpas_log_write(' begin u_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' les surface is '//trim(config_les_surface)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) + call mpas_log_write(' 4th order divergence factor is $r ', realArgs=(/config_del4u_div_factor/)) + end if -!$OMP BARRIER +!$OMP BARRIER - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). - ! First, storage to hold the result from the first del^2 computation. + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). + ! First, storage to hold the result from the first del^2 computation. - delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 - tau_12_factor = 0.0 - if(config_les_model /= 'none') tau_12_factor = 1.0 + delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 + tau_12_factor = 0.0 + if(config_les_model /= 'none') tau_12_factor = 1.0 - do iEdge=edgeStart,edgeEnd - 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)) + do iEdge=edgeStart,edgeEnd + 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)) -!DIR$ IVDEP - do k=1,nVertLevels +!DIR$ IVDEP + do k=1,nVertLevels - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant - u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & - -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv - ! for LES models we need 2 times the gradient of divergence, in contrast to what is - ! saved and used to calculate the 4th-order horizontal filter - u_diffusion_les = u_diffusion + tau_12_factor * ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant + u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc & + -( vorticity(k,vertex2) - vorticity(k,vertex1) ) * r_dv + ! for LES models we need 2 times the gradient of divergence, in contrast to what is + ! saved and used to calculate the 4th-order horizontal filter + u_diffusion_les = u_diffusion + tau_12_factor * ( divergence(k,cell2) - divergence(k,cell1) ) * r_dc - delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion + delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion - kdiffu = 0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) + kdiffu = 0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) - ! include 2nd-order diffusion here - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & - + rho_edge(k,iEdge)* kdiffu * u_diffusion_les * meshScalingDel2(iEdge) + ! include 2nd-order diffusion here + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) & + + rho_edge(k,iEdge)* kdiffu * u_diffusion_les * meshScalingDel2(iEdge) - end do end do + end do - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active -!$OMP BARRIER +!$OMP BARRIER - do iVertex=vertexStart,vertexEnd - delsq_vorticity(1:nVertLevels,iVertex) = 0.0 - do i=1,vertexDegree - iEdge = edgesOnVertex(i,iVertex) - edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) - do k=1,nVertLevels - delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) - end do + do iVertex=vertexStart,vertexEnd + delsq_vorticity(1:nVertLevels,iVertex) = 0.0 + do i=1,vertexDegree + iEdge = edgesOnVertex(i,iVertex) + edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) + do k=1,nVertLevels + delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) end do end do + end do - do iCell=cellStart,cellEnd - delsq_divergence(1:nVertLevels,iCell) = 0.0 - r = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) - do k=1,nVertLevels - delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) - end do + do iCell=cellStart,cellEnd + delsq_divergence(1:nVertLevels,iCell) = 0.0 + r = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) + do k=1,nVertLevels + delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) end do end do + end do -!$OMP BARRIER +!$OMP BARRIER - do iEdge=edgeSolveStart,edgeSolveEnd - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - vertex1 = verticesOnEdge(1,iEdge) - vertex2 = verticesOnEdge(2,iEdge) + do iEdge=edgeSolveStart,edgeSolveEnd + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + vertex1 = verticesOnEdge(1,iEdge) + vertex2 = verticesOnEdge(2,iEdge) - u_mix_scale = meshScalingDel4(iEdge)*h_mom_eddy_visc4 - r_dc = u_mix_scale * config_del4u_div_factor * invDcEdge(iEdge) - r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) + u_mix_scale = meshScalingDel4(iEdge)*h_mom_eddy_visc4 + r_dc = u_mix_scale * config_del4u_div_factor * invDcEdge(iEdge) + r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) -!DIR$ IVDEP - do k=1,nVertLevels +!DIR$ IVDEP + do k=1,nVertLevels - ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity - ! only valid for h_mom_eddy_visc4 == constant - ! - ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor - ! relative to the rotational part. The stability constraint on the divergence component is much less - ! stringent than the rotational part, and this flexibility may be useful. - ! - u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & - -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! only valid for h_mom_eddy_visc4 == constant + ! + ! Here, we scale the diffusion on the divergence part a factor of config_del4u_div_factor + ! relative to the rotational part. The stability constraint on the divergence component is much less + ! stringent than the rotational part, and this flexibility may be useful. + ! + u_diffusion = rho_edge(k,iEdge) * ( ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) * r_dc & + -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * r_dv ) + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - u_diffusion - end do end do + end do - end if ! 4th order mixing is active + end if ! 4th order mixing is active - ! - ! vertical mixing for u - 2nd order filter in physical (z) space - ! - if ( v_mom_eddy_visc2 > 0.0 ) then + ! + ! vertical mixing for u - 2nd order filter in physical (z) space + ! + if ( v_mom_eddy_visc2 > 0.0 ) then - if (config_mix_full) then ! mix full state + if (config_mix_full) then ! mix full state - do iEdge=edgeSolveStart,edgeSolveEnd + do iEdge=edgeSolveStart,edgeSolveEnd - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) - do k=2,nVertLevels-1 + do k=2,nVertLevels-1 - z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) - z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) - z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) - z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) + z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) + z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) + z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) + z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & - (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) & - -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm)) - end do + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & + (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) & + -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm)) end do + end do - else ! idealized cases where we mix on the perturbation from the initial 1-D state + else ! idealized cases where we mix on the perturbation from the initial 1-D state - do iEdge=edgeSolveStart,edgeSolveEnd + do iEdge=edgeSolveStart,edgeSolveEnd - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) - do k=1,nVertLevels - u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & - + v_init(k) * sin( angleEdge(iEdge) ) - end do + do k=1,nVertLevels + 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 + do k=2,nVertLevels-1 - z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) - z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) - z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) - z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) + z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) + z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2)) + z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2)) + z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2)) - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & - (u_mix(k+1)-u_mix(k ))/(zp-z0) & - -(u_mix(k )-u_mix(k-1))/(z0-zm) )/(0.5*(zp-zm)) - end do + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( & + (u_mix(k+1)-u_mix(k ))/(zp-z0) & + -(u_mix(k )-u_mix(k-1))/(z0-zm) )/(0.5*(zp-zm)) end do + end do - end if ! mix perturbation state + end if ! mix perturbation state - end if ! vertical mixing of horizontal momentum for les formulation + end if ! vertical mixing of horizontal momentum for les formulation - if ( config_les_model /= "none") then + if ( config_les_model /= "none") then - do iEdge=edgeSolveStart,edgeSolveEnd + do iEdge=edgeSolveStart,edgeSolveEnd - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain - turb_vflux(1) = 0. ! lower bc flux handled where ??? - - do k=2,nVertLevels - rho_k_cell1 = fzm(k)*rho_zz(k ,cell1)*zz(k ,cell1)*eddy_visc_vert(k ,cell1) & - +fzp(k)*rho_zz(k-1,cell1)*zz(k-1,cell1)*eddy_visc_vert(k-1,cell1) - rho_k_cell2 = fzm(k)*rho_zz(k ,cell2)*zz(k ,cell2)*eddy_visc_vert(k ,cell2) & - +fzp(k)*rho_zz(k-1,cell2)*zz(k-1,cell2)*eddy_visc_vert(k-1,cell2) - rho_k_at_w = 0.5*(rho_k_cell1+rho_k_cell2) - - zz_cell1 = fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) - zz_cell2 = fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) - zz_at_w = 0.5*(zz_cell1+zz_cell2) - turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) - end do + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain + turb_vflux(1) = 0. ! lower bc flux handled where ??? - if( config_les_surface == "specified" ) then - velocity_magnitude = sqrt(u(1,iEdge)**2 + v(1,iEdge)**2) - turb_vflux(1) = -rho_edge(1,iEdge)*config_surface_drag_coefficient*u(1,iEdge)*velocity_magnitude - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) - else if ( config_les_surface == "varying" ) then - ust_edge = 0.5*(ustm(cell1) + ustm(cell2)) - velocity_magnitude = max(sqrt(u(1,iEdge)**2 + v(1,iEdge)**2),0.1) - turb_vflux(1) = -rho_edge(1,iEdge)*ust_edge*ust_edge*(u(1,iEdge)/velocity_magnitude) - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) - ! end test conditions - else - ! test conditions for supercell case - turb_vflux(1) = turb_vflux(2) - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) - ! end test conditions - end if + do k=2,nVertLevels + rho_k_cell1 = fzm(k)*rho_zz(k ,cell1)*zz(k ,cell1)*eddy_visc_vert(k ,cell1) & + +fzp(k)*rho_zz(k-1,cell1)*zz(k-1,cell1)*eddy_visc_vert(k-1,cell1) + rho_k_cell2 = fzm(k)*rho_zz(k ,cell2)*zz(k ,cell2)*eddy_visc_vert(k ,cell2) & + +fzp(k)*rho_zz(k-1,cell2)*zz(k-1,cell2)*eddy_visc_vert(k-1,cell2) + rho_k_at_w = 0.5*(rho_k_cell1+rho_k_cell2) + + zz_cell1 = fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) + zz_cell2 = fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) + zz_at_w = 0.5*(zz_cell1+zz_cell2) + turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) + end do - do k=1,nVertLevels - tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) - end do + if( config_les_surface == "specified" ) then + velocity_magnitude = sqrt(u(1,iEdge)**2 + v(1,iEdge)**2) + turb_vflux(1) = -rho_edge(1,iEdge)*config_surface_drag_coefficient*u(1,iEdge)*velocity_magnitude + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + else if ( config_les_surface == "varying" ) then + ust_edge = 0.5*(ustm(cell1) + ustm(cell2)) + velocity_magnitude = max(sqrt(u(1,iEdge)**2 + v(1,iEdge)**2),0.1) + turb_vflux(1) = -rho_edge(1,iEdge)*ust_edge*ust_edge*(u(1,iEdge)/velocity_magnitude) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + ! end test conditions + else + ! test conditions for supercell case + turb_vflux(1) = turb_vflux(2) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + ! end test conditions + end if - end do + do k=1,nVertLevels + tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + end do + + end do - end if + end if - if(debug_dissipation) call mpas_log_write(' exiting u_dissipation_3d ') + if(debug_dissipation) call mpas_log_write(' exiting u_dissipation_3d ') - end subroutine u_dissipation_3d + end subroutine u_dissipation_3d !------------------------ - subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - rdzw, rdzu, & - v_mom_eddy_visc2, h_mom_eddy_visc4, & - delsq_w, & - w, rho_edge, rho_zz, divergence, zz, & - eddy_visc_horz, eddy_visc_vert, & - config_les_model, config_les_surface, & - tend_w_euler ) - - - ! 3D w dissipation using the 3D smagorinsky eddy viscosities. + subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, rho_zz, divergence, zz, & + eddy_visc_horz, eddy_visc_vert, & + config_les_model, config_les_surface, & + tend_w_euler ) + + + ! 3D w dissipation using the 3D smagorinsky eddy viscosities. ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here implicit none @@ -778,81 +781,81 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: tend_w_euler - ! storage passed in from calling routine + ! storage passed in from calling routine real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_w real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux - ! local variables + ! local variables integer :: cell1, cell2, iEdge, iCell, i, k real (kind=RKIND) :: r_areaCell, edge_sign, w_turb_flux -! !OMP BARRIER why is this openmp barrier here??? +! !OMP BARRIER why is this openmp barrier here??? - ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). - ! - ! First, storage to hold the result from the first del^2 computation. - ! we copied code from the theta mixing, hence the theta* names. + ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). + ! + ! First, storage to hold the result from the first del^2 computation. + ! we copied code from the theta mixing, hence the theta* names. - if(debug_dissipation) then - call mpas_log_write(' begin w_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' les surface is '//trim(config_les_surface)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) - end if + if(debug_dissipation) then + call mpas_log_write(' begin w_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' les surface is '//trim(config_les_surface)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) + end if - delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 + delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 - do iCell=cellStart,cellEnd - tend_w_euler(1:nVertLevels+1,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) + do iCell=cellStart,cellEnd + tend_w_euler(1:nVertLevels+1,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) - edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + edge_sign = 0.5 * r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) -!DIR$ IVDEP - do k=2,nVertLevels +!DIR$ IVDEP + do k=2,nVertLevels - w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) - delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux - w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & - ( eddy_visc_horz(k ,cell1)+eddy_visc_horz(k ,cell2) & - +eddy_visc_horz(k-1,cell1)+eddy_visc_horz(k-1,cell2) ) - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux - end do + w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) + delsq_w(k,iCell) = delsq_w(k,iCell) + w_turb_flux + w_turb_flux = w_turb_flux * meshScalingDel2(iEdge) * 0.25 * & + ( eddy_visc_horz(k ,cell1)+eddy_visc_horz(k ,cell2) & + +eddy_visc_horz(k-1,cell1)+eddy_visc_horz(k-1,cell2) ) + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + w_turb_flux end do end do + end do -!$OMP BARRIER +!$OMP BARRIER - if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) - - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) - end do + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) end do + end do + end do - end if ! 4th order mixing is active + end if ! 4th order mixing is active if ( v_mom_eddy_visc2 > 0.0 ) then ! vertical mixing do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP +!DIR$ IVDEP do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & @@ -862,55 +865,58 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end if - if ( config_les_model /= "none") then + if ( config_les_model /= "none") then + + do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column + ! compute turbulent fluxes + do k=1,nVertLevels + turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*( & + 2.0*zz(k,iCell)*rdzw(k)*(w(k+1,iCell)-w(k,iCell)) & + + divergence(k,iCell) ) + end do + + turb_vflux(nVertLevels+1) = 0.0 - do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column - ! compute turbulent fluxes - do k=1,nVertLevels - turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*( & - 2.0*zz(k,iCell)*rdzw(k)*(w(k+1,iCell)-w(k,iCell)) & - + divergence(k,iCell) ) - end do - turb_vflux(nVertLevels+1) = 0.0 - do k=2,nVertLevels - tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & - - rdzu(k)*(turb_vflux(k)-turb_vflux(k-1)) - end do - end do + do k=2,nVertLevels + tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & + - rdzu(k)*(turb_vflux(k)-turb_vflux(k-1)) + end do + end do - end if + end if - if(debug_dissipation) call mpas_log_write(' exiting w_dissipation_3d ') + if(debug_dissipation) call mpas_log_write(' exiting w_dissipation_3d ') - end subroutine w_dissipation_3d + end subroutine w_dissipation_3d !----------------------------------------------------- - subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, fzm, fzp, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - prandtl_3d_inv, & - delsq_theta, & - theta_m, rho_edge, rho_zz, zz, & - eddy_visc_horz, eddy_visc_vert, & - bv_freq2, config_len_disp, scalars, tend_scalars, & - index_tke, index_qv, num_scalars_dummy, mix_scalars, & - config_les_model, config_les_surface, time_of_day_seconds,& - config_surface_heat_flux, config_surface_moisture_flux, & - uReconstructZonal, uReconstructMeridional, & - hfx, qfx, & - tend_theta_euler, dynamics_substep ) - - - ! 3D theta_m dissipation using the 3D smagorinsky eddy viscosities. + subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, fzm, fzp, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + prandtl_3d_inv, & + delsq_theta, & + theta_m, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + bv_freq2, config_len_disp, scalars, tend_scalars, & + index_tke, index_qv, num_scalars_dummy, mix_scalars, & + config_les_model, config_les_surface, time_of_day_seconds,& + config_surface_heat_flux, config_surface_moisture_flux, & + uReconstructZonal, uReconstructMeridional, & + hfx, qfx, & + tend_theta_euler, dynamics_substep ) + + + ! 3D theta_m dissipation using the 3D smagorinsky eddy viscosities. ! This routine also includes the simpler mixing models, and the 4th-order horizontal filter - use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + use mpas_atm_dimensions ! pull nVertLevels and maxEdges from here + implicit none integer, intent(in) :: cellStart, cellEnd @@ -968,10 +974,10 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta_euler - ! storage passed in from calling routine + ! storage passed in from calling routine real (kind=RKIND), dimension(nVertLevels,nCells+1) :: delsq_theta - ! local variables + ! local variables integer :: cell1, cell2, iEdge, iCell, i, k, iScalar real (kind=RKIND) :: r_areaCell, edge_sign, theta_turb_flux, pr_scale real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp @@ -982,252 +988,254 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND) :: moisture_flux, heat_flux, theta_m_flux real (kind=RKIND) :: qv_cell, theta_m_cell, theta_cell - if(debug_dissipation) then - call mpas_log_write(' begin scalar_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' les surface is '//trim(config_les_surface)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_theta_eddy_visc4/)) - end if - if( mix_scalars .and. (dynamics_substep == 1)) call mpas_log_write(' scalar mixing on ') + if(debug_dissipation) then + call mpas_log_write(' begin scalar_dissipation_3d ') + call mpas_log_write(' les model is '//trim(config_les_model)) + call mpas_log_write(' les surface is '//trim(config_les_surface)) + call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_theta_eddy_visc4/)) + end if - delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + if( mix_scalars .and. (dynamics_substep == 1)) call mpas_log_write(' scalar mixing on ') + + delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + tend_theta_euler(1:nVertLevels,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + pr_scale = prandtl_inv * meshScalingDel2(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) - do iCell=cellStart,cellEnd - tend_theta_euler(1:nVertLevels,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - pr_scale = prandtl_inv * meshScalingDel2(iEdge) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) !DIR$ IVDEP - do k=1,nVertLevels + do k=1,nVertLevels ! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. ! This is in conservative form. - theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) - delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux - theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux + theta_turb_flux = edge_sign*(theta_m(k,cell2) - theta_m(k,cell1))*rho_edge(k,iEdge) + delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux + theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + theta_turb_flux - end do end do - end do + end do + end do !$OMP BARRIER - - if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) + if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active - iEdge = edgesOnCell(i,iCell) - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + iEdge = edgesOnCell(i,iCell) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) - do k=1,nVertLevels - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) - end do + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) end do end do + end do + + end if ! 4th order mixing is active - end if ! 4th order mixing is active + if(mix_scalars .and. (dynamics_substep == 1)) then ! dissipation for scalars, including 4th-order filter. Likely needs optimization - if(mix_scalars .and. (dynamics_substep == 1)) then ! dissipation for scalars, including 4th-order filter. Likely needs optimization - do iScalar=1,num_scalars - - delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 - do iCell=cellStart,cellEnd - ! tend_theta_euler(1:nVertLevels,iCell) = 0.0 - r_areaCell = invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) - pr_scale = prandtl_inv * meshScalingDel2(iEdge) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + + do iCell=cellStart,cellEnd + ! tend_theta_euler(1:nVertLevels,iCell) = 0.0 + r_areaCell = invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) + pr_scale = prandtl_inv * meshScalingDel2(iEdge) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + !DIR$ IVDEP - do k=1,nVertLevels + do k=1,nVertLevels ! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. ! This is in conservative form. - theta_turb_flux = edge_sign*(scalars(iScalar,k,cell2) - scalars(iScalar,k,cell1))*rho_edge(k,iEdge) - delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux - theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale - tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) + theta_turb_flux + theta_turb_flux = edge_sign*(scalars(iScalar,k,cell2) - scalars(iScalar,k,cell1))*rho_edge(k,iEdge) + delsq_theta(k,iCell) = delsq_theta(k,iCell) + theta_turb_flux + theta_turb_flux = theta_turb_flux*0.5*(eddy_visc_horz(k,cell1)+eddy_visc_horz(k,cell2)) * pr_scale + tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) + theta_turb_flux + end do end do end do - end do !$OMP BARRIER - - if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... - r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) - do i=1,nEdgesOnCell(iCell) + if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active - iEdge = edgesOnCell(i,iCell) - edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) + do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + do i=1,nEdgesOnCell(iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + iEdge = edgesOnCell(i,iCell) + edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell)*invDcEdge(iEdge) - do k=1,nVertLevels - tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + do k=1,nVertLevels + tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) + end do end do end do - end do - end if ! 4th order mixing is active - - end do ! loop over scalars for horizontal mixing + end if ! 4th order mixing is active + + end do ! loop over scalars for horizontal mixing end if ! horizontal scalar mixing - ! idealized case vertical mixing. No scalar mixing here. + ! idealized case vertical mixing. No scalar mixing here. - if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m + if ( v_theta_eddy_visc2 > 0.0 ) then ! vertical mixing for theta_m - if (config_mix_full) then + if (config_mix_full) then - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & - -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) - end do + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + (theta_m(k+1,iCell)-theta_m(k ,iCell))/(zp-z0) & + -(theta_m(k ,iCell)-theta_m(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm)) end do + end do else ! idealized cases where we mix on the perturbation from the initial 1-D state - do iCell = cellSolveStart,cellSolveEnd - do k=2,nVertLevels-1 - z1 = zgrid(k-1,iCell) - z2 = zgrid(k ,iCell) - z3 = zgrid(k+1,iCell) - z4 = zgrid(k+2,iCell) + do iCell = cellSolveStart,cellSolveEnd + do k=2,nVertLevels-1 + z1 = zgrid(k-1,iCell) + z2 = zgrid(k ,iCell) + z3 = zgrid(k+1,iCell) + z4 = zgrid(k+2,iCell) - zm = 0.5*(z1+z2) - z0 = 0.5*(z2+z3) - zp = 0.5*(z3+z4) + zm = 0.5*(z1+z2) + z0 = 0.5*(z2+z3) + zp = 0.5*(z3+z4) - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& - ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & - -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) - end do + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) + v_theta_eddy_visc2*prandtl_inv*rho_zz(k,iCell)*(& + ((theta_m(k+1,iCell)-t_init(k+1,iCell))-(theta_m(k ,iCell)-t_init(k,iCell)))/(zp-z0) & + -((theta_m(k ,iCell)-t_init(k,iCell))-(theta_m(k-1,iCell)-t_init(k-1,iCell)))/(z0-zm) )/(0.5*(zp-zm)) end do - - end if + end do end if - if ( config_les_model /= "none") then + end if - do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column - ! compute turbulent fluxes + if ( config_les_model /= "none") then + do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column + ! compute turbulent fluxes - turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain - turb_vflux(1) = 0. ! lower bc flux handled where ??? + turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain + turb_vflux(1) = 0. ! lower bc flux handled where ??? - if ( config_les_model == "3d_smagorinsky") then - do k=2,nVertLevels - prandtl_1d_inverse(k) = prandtl_inv - end do - else ! prognostic_1.5_order, isentropic mixing length - ! do k=2,nVertLevels - ! delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) - ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) - ! bv_frequency2 = 0.5*(bv_freq2(k,iCell)+bv_freq2(k-1,iCell)) - ! tke_length = delta_s - ! if(bv_frequency2 .gt. 1.e-06) & - ! tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/sqrt(bv_frequency2) - ! tke_length = min(delta_z,tke_length) - ! prandtl_inverse(k) = 1. + 2.*tke_length/delta_z - ! end do - - do k=2,nVertLevels - ! prandtl_1d_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) - prandtl_1d_inverse(k) = fzm(k)*prandtl_3d_inv(k,iCell)+fzp(k)*prandtl_3d_inv(k-1,iCell) - end do + if ( config_les_model == "3d_smagorinsky") then + do k=2,nVertLevels + prandtl_1d_inverse(k) = prandtl_inv + end do + else ! prognostic_1.5_order, isentropic mixing length + ! do k=2,nVertLevels + ! delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) + ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) + ! bv_frequency2 = 0.5*(bv_freq2(k,iCell)+bv_freq2(k-1,iCell)) + ! tke_length = delta_s + ! if(bv_frequency2 .gt. 1.e-06) & + ! tke_length = 0.76*sqrt(scalars(index_tke,k,iCell))/sqrt(bv_frequency2) + ! tke_length = min(delta_z,tke_length) + ! prandtl_inverse(k) = 1. + 2.*tke_length/delta_z + ! end do + + do k=2,nVertLevels + ! prandtl_1d_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) + prandtl_1d_inverse(k) = fzm(k)*prandtl_3d_inv(k,iCell)+fzp(k)*prandtl_3d_inv(k-1,iCell) + end do + + end if - end if + do k=2,nVertLevels - do k=2,nVertLevels + ! delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) + ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) + ! bv_frequency2 = 0.5*(bv_freq2(k)+bv_freq(k-1)) + ! bv = max( sqrt(abs(bv_frequency2)), epsilon_bv ) + rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) + turb_vflux(k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) + end do - ! delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) - ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) - ! bv_frequency2 = 0.5*(bv_freq2(k)+bv_freq(k-1)) - ! bv = max( sqrt(abs(bv_frequency2)), epsilon_bv ) - rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & - +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) - zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) - turb_vflux(k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) - end do + ! test boundary conditions for supercell and les test cases - ! test boundary conditions for supercell and les test cases + if( config_les_surface == "specified" .or. config_les_surface == "varying" ) then - if( config_les_surface == "specified" .or. config_les_surface == "varying" ) then + if( config_les_surface == "specified" ) then + moisture_flux = config_surface_moisture_flux + heat_flux = config_surface_heat_flux - if( config_les_surface == "specified" ) then - moisture_flux = config_surface_moisture_flux - heat_flux = config_surface_heat_flux -! place holder routine for time-varying specified +! place holder routine for time-varying specified ! call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) - else if ( config_les_surface == "varying" ) then - heat_flux = hfx(iCell)/rho_zz(1,iCell)/cp - moisture_flux = qfx(iCell)/rho_zz(1,iCell) - endif - - qv_cell = scalars(index_qv,1,iCell) - theta_m_cell = theta_m(1,iCell) - theta_cell = theta_m_cell/(1.0+(rv/rgas)*qv_cell) + else if ( config_les_surface == "varying" ) then + heat_flux = hfx(iCell)/rho_zz(1,iCell)/cp + moisture_flux = qfx(iCell)/rho_zz(1,iCell) + endif - theta_m_flux = heat_flux*(1.0+(rv/rgas)*qv_cell)+(rv/rgas)*theta_cell*moisture_flux - turb_vflux(1) = theta_m_flux*rho_zz(1,iCell) - moisture_flux = moisture_flux*rho_zz(1,iCell) - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + qv_cell = scalars(index_qv,1,iCell) + theta_m_cell = theta_m(1,iCell) + theta_cell = theta_m_cell/(1.0+(rv/rgas)*qv_cell) - else + theta_m_flux = heat_flux*(1.0+(rv/rgas)*qv_cell)+(rv/rgas)*theta_cell*moisture_flux + turb_vflux(1) = theta_m_flux*rho_zz(1,iCell) + moisture_flux = moisture_flux*rho_zz(1,iCell) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) - turb_vflux(1) = turb_vflux(2) - turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + else - end if + turb_vflux(1) = turb_vflux(2) + turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) + end if - do k=1,nVertLevels - tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & - - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) - end do + do k=1,nVertLevels + tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & + - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) + end do - if (mix_scalars ) then + if (mix_scalars ) then - ! compute turbulent fluxes - turb_vflux_scalars(:,nVertlevels+1) = 0. ! no turbulent flux out of the domain - turb_vflux_scalars(:,1) = 0. ! lower bc flux handled where ??? - do k=2,nVertLevels + ! compute turbulent fluxes + turb_vflux_scalars(:,nVertlevels+1) = 0. ! no turbulent flux out of the domain + turb_vflux_scalars(:,1) = 0. ! lower bc flux handled where ??? + do k=2,nVertLevels rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) @@ -1235,30 +1243,30 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo turb_vflux_scalars(iScalar,k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)* & (scalars(iScalar,k,iCell)-scalars(iScalar,k-1,iCell)) end do - end do + end do - if( config_les_surface == "specified" .or. config_les_surface == "varying" ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv + if( config_les_surface == "specified" .or. config_les_surface == "varying" ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv - do k=1,nVertLevels + do k=1,nVertLevels do iScalar=1,num_scalars - tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) & - - rdzw(k)*(turb_vflux_scalars(iScalar,k+1)-turb_vflux_scalars(iScalar,k)) + tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) & + - rdzw(k)*(turb_vflux_scalars(iScalar,k+1)-turb_vflux_scalars(iScalar,k)) end do - end do + end do - end if ! mix scalars + end if ! mix scalars - end do ! loop over cells (columns) - - end if + end do ! loop over cells (columns) + + end if - if(debug_dissipation) call mpas_log_write(' exiting scalar_dissipation_3d ') + if(debug_dissipation) call mpas_log_write(' exiting scalar_dissipation_3d ') - end subroutine scalar_dissipation_3d_les + end subroutine scalar_dissipation_3d_les !----------- -! subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) +! subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) ! implicit none @@ -1277,6 +1285,6 @@ end subroutine scalar_dissipation_3d_les ! heat_flux = max(0., 0.1*sin(pii*rel_time_t_flux)) ! moisture_flux = max(0., 0.15*sin(pii*rel_time_q_flux))/1000. -! end subroutine flux_les_sas +! end subroutine flux_les_sas end module mpas_atm_dissipation_models From 3df68570f7200156f21fde45eed032f75a4f0d47 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 5 Dec 2025 14:42:21 -0700 Subject: [PATCH 092/109] Use a macro for debugging print statements in mpas_atm_dissipation_models.F With a macro, when debugging prints are not enabled the compiler will see no executable code. --- .../dynamics/mpas_atm_dissipation_models.F | 61 +++++++++---------- 1 file changed, 30 insertions(+), 31 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 70cf9c24b3..4fd7000acd 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -6,6 +6,9 @@ ! distributed with this code, or at http://mpas-dev.github.com/license.html ! +#define COMMA , +#define DEBUG_WRITE(M) ! call mpas_log_write(M) + module mpas_atm_dissipation_models use mpas_kind_types, only : RKIND @@ -14,7 +17,6 @@ module mpas_atm_dissipation_models use mpas_log use mpas_derived_types, only : MPAS_LOG_CRIT - logical, parameter :: debug_dissipation = .false. logical, parameter :: les_test = .true., les_sas_test = .false. !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour ! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 @@ -58,8 +60,8 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, integer :: iCell, iEdge, k real (kind=RKIND), dimension(nVertLevels) :: d_11, d_22, d_12, dudx, dudy, dvdx, dvdy - if(debug_dissipation) call mpas_log_write(' begin smagorinsky_2d ') + DEBUG_WRITE(' begin smagorinsky_2d ') do iCell = cellStart,cellEnd dudx(1:nVertLevels) = 0.0 @@ -94,7 +96,7 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 h_theta_eddy_visc4 = h_mom_eddy_visc4 - if(debug_dissipation) call mpas_log_write(' exiting smagorinsky_2d ') + DEBUG_WRITE(' exiting smagorinsky_2d ') end subroutine smagorinsky_2d @@ -158,9 +160,10 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e logical, parameter :: test_tke=.true. ! real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 - if(debug_dissipation) call mpas_log_write(' begin les_models ') - if(debug_dissipation) call mpas_log_write(' les scheme is '//trim(config_les_model)) - if(debug_dissipation) call mpas_log_write(' les surface scheme is '//trim(config_les_surface)) + + DEBUG_WRITE(' begin les_models ') + DEBUG_WRITE(' les scheme is '//trim(config_les_model)) + DEBUG_WRITE(' les surface scheme is '//trim(config_les_surface)) pr_inv = 1./prandtl @@ -324,7 +327,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e end do ! loop over all owned cells (columns) - if(debug_dissipation) call mpas_log_write(' les_models ') + DEBUG_WRITE(' les_models ') end subroutine les_models @@ -348,7 +351,7 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(nVertLevels) :: theta, qvsw, temp, coefa logical :: dry_bv_frequency - if(debug_dissipation) call mpas_log_write(' begin BV frequency calculations ') + DEBUG_WRITE(' begin BV frequency calculations ') do iCell = cellStart,cellEnd !DIR$ IVDEP @@ -408,7 +411,7 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in end do - if(debug_dissipation) call mpas_log_write(' exiting BV frequency calculations ') + DEBUG_WRITE(' exiting BV frequency calculations ') end subroutine calculate_n2 @@ -506,13 +509,11 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND) :: velocity_magnitude real (kind=RKIND) :: tau_12_factor - if(debug_dissipation) then - call mpas_log_write(' begin u_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' les surface is '//trim(config_les_surface)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) - call mpas_log_write(' 4th order divergence factor is $r ', realArgs=(/config_del4u_div_factor/)) - end if + DEBUG_WRITE(' begin u_dissipation_3d ') + DEBUG_WRITE(' les model is '//trim(config_les_model)) + DEBUG_WRITE(' les surface is '//trim(config_les_surface)) + DEBUG_WRITE(' 4th order hyperviscosity is $r ' COMMA realArgs=(/h_mom_eddy_visc4/)) + DEBUG_WRITE(' 4th order divergence factor is $r ' COMMA realArgs=(/config_del4u_div_factor/)) !$OMP BARRIER @@ -720,7 +721,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end if - if(debug_dissipation) call mpas_log_write(' exiting u_dissipation_3d ') + DEBUG_WRITE(' exiting u_dissipation_3d ') end subroutine u_dissipation_3d @@ -797,12 +798,11 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, ! First, storage to hold the result from the first del^2 computation. ! we copied code from the theta mixing, hence the theta* names. - if(debug_dissipation) then - call mpas_log_write(' begin w_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' les surface is '//trim(config_les_surface)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_mom_eddy_visc4/)) - end if + + DEBUG_WRITE(' begin w_dissipation_3d ') + DEBUG_WRITE(' les model is '//trim(config_les_model)) + DEBUG_WRITE(' les surface is '//trim(config_les_surface)) + DEBUG_WRITE(' 4th order hyperviscosity is $r ' COMMA realArgs=(/h_mom_eddy_visc4/)) delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 @@ -885,7 +885,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end if - if(debug_dissipation) call mpas_log_write(' exiting w_dissipation_3d ') + DEBUG_WRITE(' exiting w_dissipation_3d ') end subroutine w_dissipation_3d @@ -988,12 +988,11 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND) :: moisture_flux, heat_flux, theta_m_flux real (kind=RKIND) :: qv_cell, theta_m_cell, theta_cell - if(debug_dissipation) then - call mpas_log_write(' begin scalar_dissipation_3d ') - call mpas_log_write(' les model is '//trim(config_les_model)) - call mpas_log_write(' les surface is '//trim(config_les_surface)) - call mpas_log_write(' 4th order hyperviscosity is $r ', realArgs=(/h_theta_eddy_visc4/)) - end if + + DEBUG_WRITE(' begin scalar_dissipation_3d ') + DEBUG_WRITE(' les model is '//trim(config_les_model)) + DEBUG_WRITE(' les surface is '//trim(config_les_surface)) + DEBUG_WRITE(' 4th order hyperviscosity is $r ' COMMA realArgs=(/h_theta_eddy_visc4/)) if( mix_scalars .and. (dynamics_substep == 1)) call mpas_log_write(' scalar mixing on ') @@ -1260,7 +1259,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end if - if(debug_dissipation) call mpas_log_write(' exiting scalar_dissipation_3d ') + DEBUG_WRITE(' exiting scalar_dissipation_3d ') end subroutine scalar_dissipation_3d_les From e0932725c82168a608fffb61223ef0be06427fb6 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 20 Jan 2026 17:15:05 -0700 Subject: [PATCH 093/109] Add 'lbc_tke' to the 'lbc_scalars' var_array in atmosphere core Registry.xml --- src/core_atmosphere/Registry.xml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 2264cf1fd5..68b0952e9b 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1722,9 +1722,6 @@ description="Rain number concentration" packages="mp_thompson_in;mp_thompson_aers_in"/> - - @@ -1736,6 +1733,9 @@ + + #endif @@ -2104,7 +2104,7 @@ packages="mp_thompson_aers_in"/> + description="Tendency of tke multiplied by dry air density divided by d(zeta)/dz"/> #endif @@ -2183,6 +2183,10 @@ + + From d60a7653e9a18196fa8021e8ac192a09e00d4933 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 25 Feb 2026 14:26:21 -0700 Subject: [PATCH 094/109] Initial pass at porting mpas_atm_dissipation_models to GPUs with OpenACC Results with the NVHPC 25.9 compilers are bit-identical between CPU and GPU runs when compiling with the additional flags -Mnofma -gpu=math_uniform . --- .../dynamics/mpas_atm_dissipation_models.F | 314 ++++++++++++++++-- .../dynamics/mpas_atm_time_integration.F | 97 +++++- 2 files changed, 369 insertions(+), 42 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 4fd7000acd..cadd1cfdff 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -63,12 +63,25 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, DEBUG_WRITE(' begin smagorinsky_2d ') + !$acc enter data create(dudx, dudy, dvdx, dvdy) + !$acc enter data create(d_11, d_22, d_12) + + !$acc parallel default(present) + + !$acc loop gang worker private(dudx, dudy, dvdx, dvdy, d_11, d_22, d_12) do iCell = cellStart,cellEnd - dudx(1:nVertLevels) = 0.0 - dudy(1:nVertLevels) = 0.0 - dvdx(1:nVertLevels) = 0.0 - dvdy(1:nVertLevels) = 0.0 + + !$acc loop vector + do k = 1, nVertLevels + dudx(k) = 0.0_RKIND + dudy(k) = 0.0_RKIND + dvdx(k) = 0.0_RKIND + dvdy(k) = 0.0_RKIND + end do + + !$acc loop seq do iEdge=1,nEdgesOnCell(iCell) + !$acc loop vector do k=1,nVertLevels dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,EdgesOnCell(iEdge,iCell)) & - deformation_coef_cs(iEdge,iCell)*v(k,EdgesOnCell(iEdge,iCell)) @@ -82,6 +95,7 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, end do !DIR$ IVDEP + !$acc loop vector do k=1, nVertLevels ! here is the Smagorinsky formulation, ! followed by imposition of an upper bound on the eddy viscosity @@ -93,6 +107,11 @@ subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, end do end do + !$acc end parallel + + !$acc exit data delete(dudx, dudy, dvdx, dvdy) + !$acc exit data delete(d_11, d_22, d_12) + h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 h_theta_eddy_visc4 = h_mom_eddy_visc4 @@ -165,6 +184,9 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e DEBUG_WRITE(' les scheme is '//trim(config_les_model)) DEBUG_WRITE(' les surface scheme is '//trim(config_les_surface)) + !$acc enter data create(dudx, dudy, dvdx, dvdy, dwdx, dwdy, dudz, dvdz, dwdz) + !$acc enter data create(d_11, d_22, d_33, d_12, d_13, d_23) + pr_inv = 1./prandtl ! set up coefficients for 4th-order horizontal background filter @@ -172,25 +194,37 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 h_theta_eddy_visc4 = h_mom_eddy_visc4 + !$acc parallel default(present) + + !$acc loop gang worker private(dudx, dudy, dvdx, dvdy, dwdx, dwdy, dudz, dvdz, dwdz, d_11, d_22, d_33, d_12, d_13, d_23) do iCell = cellStart,cellEnd - dudx(1:nVertLevels) = 0.0 - dudy(1:nVertLevels) = 0.0 - dvdx(1:nVertLevels) = 0.0 - dvdy(1:nVertLevels) = 0.0 - dwdx(1:nVertLevels+1) = 0.0 - dwdy(1:nVertLevels+1) = 0.0 + !$acc loop vector + do k = 1, nVertLevels + dudx(k) = 0.0_RKIND + dudy(k) = 0.0_RKIND + dvdx(k) = 0.0_RKIND + dvdy(k) = 0.0_RKIND - dudz(1:nVertLevels) = 0.0 - dvdz(1:nVertLevels) = 0.0 - dwdz(1:nVertLevels) = 0.0 + dudz(k) = 0.0_RKIND + dvdz(k) = 0.0_RKIND + dwdz(k) = 0.0_RKIND + end do + + !$acc loop vector + do k = 1, nVertLevels+1 + dwdx(k) = 0.0_RKIND + dwdy(k) = 0.0_RKIND + end do + !$acc loop seq do iEdge=1,nEdgesOnCell(iCell) ie = EdgesOnCell(iEdge,iCell) cell1 = cellsOnEdge(1,ie) cell2 = cellsOnEdge(2,ie) + !$acc loop vector do k=1,nVertLevels dudx(k) = dudx(k) + deformation_coef_c2(iEdge,iCell)*u(k,ie) & - deformation_coef_cs(iEdge,iCell)*v(k,ie) @@ -202,6 +236,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e + deformation_coef_cs(iEdge,iCell)*v(k,ie) end do + !$acc loop vector do k=1,nVertLevels+1 wk = 0.5*(w(k,cell1)+w(k,cell2)) dwdx(k) = dwdx(k) + deformation_coef_c(iEdge,iCell)*wk @@ -210,11 +245,13 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e end do + !$acc loop vector do k=1,nVertLevels rdz = 1./(zgrid(k+1,iCell)-zgrid(k,iCell)) dwdz(k) = (w(k+1,iCell)-w(k,iCell))*rdz end do + !$acc loop vector do k=2,nVertLevels-1 rdz = 1./(zgrid(k+2,iCell)+zgrid(k+1,iCell)-zgrid(k,iCell)-zgrid(k-1,iCell)) dudz(k) = (uCell(k+1,iCell)-uCell(k-1,iCell))*rdz @@ -231,6 +268,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e dudz(k+1) = (uCell(k+1,iCell)-uCell(k,iCell))*rdz dvdz(k+1) = (vCell(k+1,iCell)-vCell(k,iCell))*rdz + !$acc loop vector do k=1, nVertLevels d_11(k) = 2.*dudx(k) d_22(k) = 2.*dvdy(k) @@ -242,6 +280,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e if (config_les_model == "3d_smagorinsky") then + !$acc loop vector do k=1, nVertLevels def2 = 0.5*(d_11(k)**2 + d_22(k)**2 + d_33(k)**2) + d_12(k)**2 + d_13(k)**2 + d_23(k)**2 eddy_visc_horz(k,iCell) = (c_s * config_len_disp)**2 * sqrt(max(0.,def2 - pr_inv*bv_freq2(k,iCell))) @@ -253,11 +292,13 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e else if (config_les_model == "prognostic_1.5_order") then + !$acc loop vector do k=1,nVertLevels ! bound the tke here, currently hardwired ! scalars(index_tke,k,iCell) = max(0.,min(100.,scalars(index_tke,k,iCell))) scalars(index_tke,k,iCell) = max(0.,scalars(index_tke,k,iCell)) end do + !$acc loop vector do k=1,nVertLevels delta_z = zgrid(k+1,iCell)-zgrid(k,iCell) @@ -321,12 +362,17 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e else - call mpas_log_write(' in les_models, no les scheme for '//trim(config_les_model), messageType=MPAS_LOG_CRIT) +!MGD call mpas_log_write(' in les_models, no les scheme for '//trim(config_les_model), messageType=MPAS_LOG_CRIT) end if ! end of config_les_model test end do ! loop over all owned cells (columns) + !$acc end parallel + + !$acc exit data delete(dudx, dudy, dvdx, dvdy, dwdx, dwdy, dudz, dvdz, dwdz) + !$acc exit data delete(d_11, d_22, d_33, d_12, d_13, d_23) + DEBUG_WRITE(' les_models ') end subroutine les_models @@ -351,10 +397,18 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in real (kind=RKIND), dimension(nVertLevels) :: theta, qvsw, temp, coefa logical :: dry_bv_frequency + DEBUG_WRITE(' begin BV frequency calculations ') + !$acc enter data create(theta, temp, qvsw, coefa) + + !$acc parallel default(present) + + !$acc loop gang worker private(theta, temp, qvsw, coefa) do iCell = cellStart,cellEnd + !DIR$ IVDEP + !$acc loop vector do k=1, nVertLevels theta(k) = theta_m(k,iCell) / (1._RKIND + rvord * scalars(index_qv,k,iCell)) @@ -371,6 +425,7 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in end do + !$acc loop vector do k=2, nVertLevels-1 dz = 0.5 * (zgrid(k+2,iCell)+zgrid(k+1,iCell)) - 0.5 * (zgrid(k,iCell)+zgrid(k-1,iCell)) rdz = 1.0/dz @@ -411,6 +466,10 @@ subroutine calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, in end do + !$acc end parallel + + !$acc exit data delete(theta, temp, qvsw, coefa) + DEBUG_WRITE(' exiting BV frequency calculations ') end subroutine calculate_n2 @@ -520,10 +579,15 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v ! del^4 horizontal filter. We compute this as del^2 ( del^2 (u) ). ! First, storage to hold the result from the first del^2 computation. - delsq_u(1:nVertLevels,edgeStart:edgeEnd) = 0.0 + !$acc enter data create(u_mix) + !$acc enter data create(turb_vflux) + + !$acc parallel default(present) + tau_12_factor = 0.0 if(config_les_model /= 'none') tau_12_factor = 1.0 + !$acc loop gang worker do iEdge=edgeStart,edgeEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -532,7 +596,13 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v r_dc = invDcEdge(iEdge) r_dv = min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) + !$acc loop vector + do k = 1, nVertLevels + delsq_u(k,iEdge) = 0.0_RKIND + end do + !DIR$ IVDEP + !$acc loop vector do k=1,nVertLevels ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity @@ -554,35 +624,61 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end do end do + !$acc end parallel + if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active !$OMP BARRIER + !$acc parallel default(present) + + !$acc loop gang worker do iVertex=vertexStart,vertexEnd - delsq_vorticity(1:nVertLevels,iVertex) = 0.0 + !$acc loop vector + do k = 1, nVertLevels + delsq_vorticity(k,iVertex) = 0.0_RKIND + end do + + !$acc loop seq do i=1,vertexDegree iEdge = edgesOnVertex(i,iVertex) edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge) * edgesOnVertex_sign(i,iVertex) + + !$acc loop vector do k=1,nVertLevels delsq_vorticity(k,iVertex) = delsq_vorticity(k,iVertex) + edge_sign * delsq_u(k,iEdge) end do end do end do + !$acc loop gang worker do iCell=cellStart,cellEnd - delsq_divergence(1:nVertLevels,iCell) = 0.0 + !$acc loop vector + do k = 1, nVertLevels + delsq_divergence(k,iCell) = 0.0_RKIND + end do + r = invAreaCell(iCell) + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) edge_sign = r * dvEdge(iEdge) * edgesOnCell_sign(i,iCell) + + !$acc loop vector do k=1,nVertLevels delsq_divergence(k,iCell) = delsq_divergence(k,iCell) + edge_sign * delsq_u(k,iEdge) end do end do end do + !$acc end parallel + !$OMP BARRIER + !$acc parallel default(present) + + !$acc loop gang worker do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) @@ -594,6 +690,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v r_dv = u_mix_scale * min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) !DIR$ IVDEP + !$acc loop vector do k=1,nVertLevels ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity @@ -610,6 +707,8 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end do end do + !$acc end parallel + end if ! 4th order mixing is active ! @@ -619,11 +718,15 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v if (config_mix_full) then ! mix full state + !$acc parallel default(present) + + !$acc loop gang worker do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) + !$acc loop vector do k=2,nVertLevels-1 z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) @@ -641,18 +744,25 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end do end do + !$acc end parallel + else ! idealized cases where we mix on the perturbation from the initial 1-D state + !$acc parallel default(present) + + !$acc loop gang worker private(u_mix) do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) + !$acc loop vector do k=1,nVertLevels u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & + v_init(k) * sin( angleEdge(iEdge) ) end do + !$acc loop vector do k=2,nVertLevels-1 z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2)) @@ -670,19 +780,25 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end do end do + !$acc end parallel + end if ! mix perturbation state end if ! vertical mixing of horizontal momentum for les formulation if ( config_les_model /= "none") then + !$acc parallel default(present) + + !$acc loop gang worker private(turb_vflux) do iEdge=edgeSolveStart,edgeSolveEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) - turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain - turb_vflux(1) = 0. ! lower bc flux handled where ??? + turb_vflux(nVertlevels+1) = 0.0_RKIND ! no turbulent flux out of the domain + turb_vflux(1) = 0.0_RKIND ! lower bc flux handled where ??? + !$acc loop vector do k=2,nVertLevels rho_k_cell1 = fzm(k)*rho_zz(k ,cell1)*zz(k ,cell1)*eddy_visc_vert(k ,cell1) & +fzp(k)*rho_zz(k-1,cell1)*zz(k-1,cell1)*eddy_visc_vert(k-1,cell1) @@ -713,14 +829,20 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v ! end test conditions end if + !$acc loop vector do k=1,nVertLevels tend_u_euler(k,iEdge) = tend_u_euler(k,iEdge) - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) end do end do + !$acc end parallel + end if + !$acc exit data delete(turb_vflux) + !$acc exit data delete(u_mix) + DEBUG_WRITE(' exiting u_dissipation_3d ') end subroutine u_dissipation_3d @@ -804,11 +926,26 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, DEBUG_WRITE(' les surface is '//trim(config_les_surface)) DEBUG_WRITE(' 4th order hyperviscosity is $r ' COMMA realArgs=(/h_mom_eddy_visc4/)) - delsq_w(1:nVertLevels,cellStart:cellEnd) = 0.0 + !$acc enter data create(turb_vflux) + !$acc parallel default(present) + + !$acc loop gang worker do iCell=cellStart,cellEnd - tend_w_euler(1:nVertLevels+1,iCell) = 0.0 + + !$acc loop vector + do k = 1, nVertLevels + delsq_w(k,iCell) = 0.0_RKIND + end do + + !$acc loop vector + do k = 1, nVertLevels+1 + tend_w_euler(k,iCell) = 0.0_RKIND + end do + r_areaCell = invAreaCell(iCell) + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) @@ -818,6 +955,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, cell2 = cellsOnEdge(2,iEdge) !DIR$ IVDEP + !$acc loop vector do k=2,nVertLevels w_turb_flux = edge_sign*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1)) @@ -830,12 +968,20 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end do end do + !$acc end parallel + !$OMP BARRIER if (h_mom_eddy_visc4 > 0.0) then ! 4th order mixing is active + !$acc parallel default(present) + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_mom_eddy_visc4 * invAreaCell(iCell) + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) cell1 = cellsOnEdge(1,iEdge) @@ -843,6 +989,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, edge_sign = meshScalingDel4(iEdge)*r_areaCell*dvEdge(iEdge)*edgesOnCell_sign(i,iCell) * invDcEdge(iEdge) + !$acc loop vector do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) - edge_sign * (delsq_w(k,cell2) - delsq_w(k,cell1)) end do @@ -850,12 +997,18 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end do end do + !$acc end parallel + end if ! 4th order mixing is active if ( v_mom_eddy_visc2 > 0.0 ) then ! vertical mixing + !$acc parallel default(present) + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd !DIR$ IVDEP + !$acc loop vector do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) + v_mom_eddy_visc2*0.5*(rho_zz(k,iCell)+rho_zz(k-1,iCell))*( & (w(k+1,iCell)-w(k ,iCell))*rdzw(k) & @@ -863,12 +1016,19 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end do end do + !$acc end parallel + end if if ( config_les_model /= "none") then + !$acc parallel default(present) + + !$acc loop gang worker private(turb_vflux) do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes + + !$acc loop vector do k=1,nVertLevels turb_vflux(k) = - rho_zz(k,iCell)*eddy_visc_vert(k,iCell)*zz(k,iCell)*( & 2.0*zz(k,iCell)*rdzw(k)*(w(k+1,iCell)-w(k,iCell)) & @@ -877,14 +1037,19 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, turb_vflux(nVertLevels+1) = 0.0 + !$acc loop vector do k=2,nVertLevels tend_w_euler(k,iCell) = tend_w_euler(k,iCell) & - rdzu(k)*(turb_vflux(k)-turb_vflux(k-1)) end do end do + !$acc end parallel + end if + !$acc exit data delete(turb_vflux) + DEBUG_WRITE(' exiting w_dissipation_3d ') end subroutine w_dissipation_3d @@ -983,7 +1148,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo real (kind=RKIND) :: z1, z2, z3, z4, zm, z0, zp real (kind=RKIND), dimension(nVertLevels+1) :: turb_vflux, prandtl_1d_inverse real (kind=RKIND), dimension(num_scalars,nVertLevels+1) :: turb_vflux_scalars - real (kind=RKIND) :: rho_k_at_w, zz_at_w + real (kind=RKIND), dimension(nVertLevels) :: rho_k_at_w, zz_at_w real (kind=RKIND) :: moisture_flux, heat_flux, theta_m_flux real (kind=RKIND) :: qv_cell, theta_m_cell, theta_cell @@ -996,11 +1161,23 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo if( mix_scalars .and. (dynamics_substep == 1)) call mpas_log_write(' scalar mixing on ') - delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + !$acc enter data create(turb_vflux_scalars) + !$acc enter data create(turb_vflux, prandtl_1d_inverse) + !$acc parallel default(present) + + !$acc loop gang worker do iCell=cellStart,cellEnd - tend_theta_euler(1:nVertLevels,iCell) = 0.0 + + !$acc loop vector + do k = 1, nVertLevels + delsq_theta(k,iCell) = 0.0_RKIND + tend_theta_euler(k,iCell) = 0.0_RKIND + end do + r_areaCell = invAreaCell(iCell) + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) @@ -1009,6 +1186,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo cell2 = cellsOnEdge(2,iEdge) !DIR$ IVDEP + !$acc loop vector do k=1,nVertLevels ! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. @@ -1023,12 +1201,19 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do + !$acc end parallel + !$OMP BARRIER if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active + !$acc parallel default(present) + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) @@ -1037,23 +1222,34 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) + !$acc loop vector do k=1,nVertLevels tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) end do end do end do + !$acc end parallel + end if ! 4th order mixing is active if(mix_scalars .and. (dynamics_substep == 1)) then ! dissipation for scalars, including 4th-order filter. Likely needs optimization do iScalar=1,num_scalars - delsq_theta(1:nVertLevels,cellStart:cellEnd) = 0.0 + !$acc parallel default(present) + !$acc loop gang worker do iCell=cellStart,cellEnd + !$acc loop vector + do k = 1, nVertLevels + delsq_theta(k,iCell) = 0.0_RKIND + end do + ! tend_theta_euler(1:nVertLevels,iCell) = 0.0 r_areaCell = invAreaCell(iCell) + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) @@ -1062,6 +1258,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo cell2 = cellsOnEdge(2,iEdge) !DIR$ IVDEP + !$acc loop vector do k=1,nVertLevels ! we are computing the Smagorinsky filter at more points than needed here so as to pick up the delsq_theta for 4th order filter below. @@ -1076,12 +1273,20 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do + !$acc end parallel + !$OMP BARRIER if (h_theta_eddy_visc4 > 0.0) then ! 4th order mixing is active + !$acc parallel default(present) + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... + r_areaCell = h_theta_eddy_visc4 * prandtl_inv * invAreaCell(iCell) + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) @@ -1090,12 +1295,15 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) + !$acc loop vector do k=1,nVertLevels tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) - edge_sign*(delsq_theta(k,cell2) - delsq_theta(k,cell1)) end do end do end do + !$acc end parallel + end if ! 4th order mixing is active end do ! loop over scalars for horizontal mixing @@ -1109,7 +1317,12 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo if (config_mix_full) then + !$acc parallel default(present) + + !$acc loop gang worker do iCell = cellSolveStart,cellSolveEnd + + !$acc loop vector do k=2,nVertLevels-1 z1 = zgrid(k-1,iCell) z2 = zgrid(k ,iCell) @@ -1126,9 +1339,16 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do + !$acc end parallel + else ! idealized cases where we mix on the perturbation from the initial 1-D state + !$acc parallel default(present) + + !$acc loop gang worker do iCell = cellSolveStart,cellSolveEnd + + !$acc loop vector do k=2,nVertLevels-1 z1 = zgrid(k-1,iCell) z2 = zgrid(k ,iCell) @@ -1145,12 +1365,17 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do + !$acc end parallel + end if end if if ( config_les_model /= "none") then + !$acc parallel default(present) + + !$acc loop gang worker private(turb_vflux, turb_vflux_scalars, prandtl_1d_inverse, rho_k_at_w, zz_at_w) do iCell = cellSolveStart,cellSolveEnd ! vertical mixing for each column ! compute turbulent fluxes @@ -1158,6 +1383,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo turb_vflux(1) = 0. ! lower bc flux handled where ??? if ( config_les_model == "3d_smagorinsky") then + !$acc loop vector do k=2,nVertLevels prandtl_1d_inverse(k) = prandtl_inv end do @@ -1173,6 +1399,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! prandtl_inverse(k) = 1. + 2.*tke_length/delta_z ! end do + !$acc loop vector do k=2,nVertLevels ! prandtl_1d_inverse(k) = 0.5*(prandtl_3d_inv(k,iCell)+prandtl_3d_inv(k-1,iCell)) prandtl_1d_inverse(k) = fzm(k)*prandtl_3d_inv(k,iCell)+fzp(k)*prandtl_3d_inv(k-1,iCell) @@ -1180,16 +1407,17 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end if + !$acc loop vector do k=2,nVertLevels ! delta_z = 0.5*(zgrid(k+1,iCell)-zgrid(k-1,iCell)) ! delta_s = ((config_len_disp**2)*delta_z)**(1./3.) ! bv_frequency2 = 0.5*(bv_freq2(k)+bv_freq(k-1)) ! bv = max( sqrt(abs(bv_frequency2)), epsilon_bv ) - rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & - +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) - zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) - turb_vflux(k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) + rho_k_at_w(k) = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + zz_at_w(k) = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) + turb_vflux(k) = - prandtl_1d_inverse(k)*rho_k_at_w(k)*zz_at_w(k)*rdzu(k)*(theta_m(k,iCell)-theta_m(k-1,iCell)) end do ! test boundary conditions for supercell and les test cases @@ -1224,6 +1452,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end if + !$acc loop vector do k=1,nVertLevels tend_theta_euler(k,iCell) = tend_theta_euler(k,iCell) & - rdzw(k)*(turb_vflux(k+1)-turb_vflux(k)) @@ -1232,20 +1461,30 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo if (mix_scalars ) then ! compute turbulent fluxes - turb_vflux_scalars(:,nVertlevels+1) = 0. ! no turbulent flux out of the domain - turb_vflux_scalars(:,1) = 0. ! lower bc flux handled where ??? + !$acc loop vector + do iScalar=1,num_scalars + turb_vflux_scalars(iScalar,nVertlevels+1) = 0.0_RKIND ! no turbulent flux out of the domain + turb_vflux_scalars(iScalar,1) = 0.0_RKIND ! lower bc flux handled where ??? + end do + + !$acc loop vector + do k=2,nVertLevels + rho_k_at_w(k) = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & + + fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) + zz_at_w(k) = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) + end do + + !$acc loop vector collapse(2) do k=2,nVertLevels - rho_k_at_w = fzm(k)*rho_zz(k ,iCell)*zz(k ,iCell)*zz(k ,iCell)*eddy_visc_vert(k ,iCell) & - +fzp(k)*rho_zz(k-1,iCell)*zz(k-1,iCell)*zz(k-1,iCell)*eddy_visc_vert(k-1,iCell) - zz_at_w = fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell) do iScalar=1,num_scalars - turb_vflux_scalars(iScalar,k) = - prandtl_1d_inverse(k)*rho_k_at_w*zz_at_w*rdzu(k)* & + turb_vflux_scalars(iScalar,k) = - prandtl_1d_inverse(k)*rho_k_at_w(k)*zz_at_w(k)*rdzu(k)* & (scalars(iScalar,k,iCell)-scalars(iScalar,k-1,iCell)) end do end do if( config_les_surface == "specified" .or. config_les_surface == "varying" ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv + !$acc loop vector collapse(2) do k=1,nVertLevels do iScalar=1,num_scalars tend_scalars(iScalar,k,iCell) = tend_scalars(iScalar,k,iCell) & @@ -1257,8 +1496,13 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do ! loop over cells (columns) + !$acc end parallel + end if + !$acc exit data delete(turb_vflux_scalars) + !$acc exit data delete(turb_vflux, prandtl_1d_inverse) + DEBUG_WRITE(' exiting scalar_dissipation_3d ') end subroutine scalar_dissipation_3d_les diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index f54804cc93..3d79ef059c 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -273,6 +273,11 @@ subroutine mpas_atm_dynamics_init(domain) real (kind=RKIND), dimension(:), pointer :: angleEdge real (kind=RKIND), dimension(:), pointer :: meshScalingDel2 real (kind=RKIND), dimension(:), pointer :: meshScalingDel4 + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c2 + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_s2 + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_cs + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_s #endif #ifdef MPAS_CAM_DYCORE @@ -457,6 +462,21 @@ subroutine mpas_atm_dynamics_init(domain) call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) !$acc enter data copyin(meshScalingDel4) + + call mpas_pool_get_array(mesh, 'deformation_coef_c2', deformation_coef_c2) + !$acc enter data copyin(deformation_coef_c2) + + call mpas_pool_get_array(mesh, 'deformation_coef_s2', deformation_coef_s2) + !$acc enter data copyin(deformation_coef_s2) + + call mpas_pool_get_array(mesh, 'deformation_coef_cs', deformation_coef_cs) + !$acc enter data copyin(deformation_coef_cs) + + call mpas_pool_get_array(mesh, 'deformation_coef_c', deformation_coef_c) + !$acc enter data copyin(deformation_coef_c) + + call mpas_pool_get_array(mesh, 'deformation_coef_s', deformation_coef_s) + !$acc enter data copyin(deformation_coef_s) #endif end subroutine mpas_atm_dynamics_init @@ -547,6 +567,11 @@ subroutine mpas_atm_dynamics_finalize(domain) real (kind=RKIND), dimension(:), pointer :: angleEdge real (kind=RKIND), dimension(:), pointer :: meshScalingDel2 real (kind=RKIND), dimension(:), pointer :: meshScalingDel4 + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c2 + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_s2 + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_cs + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_c + real (kind=RKIND), dimension(:,:), pointer :: deformation_coef_s #endif @@ -732,6 +757,21 @@ subroutine mpas_atm_dynamics_finalize(domain) call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) !$acc exit data delete(meshScalingDel4) + + call mpas_pool_get_array(mesh, 'deformation_coef_c2', deformation_coef_c2) + !$acc exit data delete(deformation_coef_c2) + + call mpas_pool_get_array(mesh, 'deformation_coef_s2', deformation_coef_s2) + !$acc exit data delete(deformation_coef_s2) + + call mpas_pool_get_array(mesh, 'deformation_coef_cs', deformation_coef_cs) + !$acc exit data delete(deformation_coef_cs) + + call mpas_pool_get_array(mesh, 'deformation_coef_c', deformation_coef_c) + !$acc exit data delete(deformation_coef_c) + + call mpas_pool_get_array(mesh, 'deformation_coef_s', deformation_coef_s) + !$acc exit data delete(deformation_coef_s) #endif end subroutine mpas_atm_dynamics_finalize @@ -5226,8 +5266,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension( nVertLevels + 1 ) :: wduz, wdwz, wdtz, dpzx real (kind=RKIND), dimension( nVertLevels ) :: ru_edge_w, q, u_mix - real (kind=RKIND), dimension( nVertLevels+1 ) :: d_11, d_22, d_12 - real (kind=RKIND), dimension( nVertLevels+1 ) :: dudx, dudy, dvdx, dvdy +! real (kind=RKIND), dimension( nVertLevels+1 ) :: d_11, d_22, d_12 +! real (kind=RKIND), dimension( nVertLevels+1 ) :: dudx, dudy, dvdx, dvdy real (kind=RKIND) :: theta_turb_flux, w_turb_flux, r real (kind=RKIND) :: scalar_weight @@ -5263,6 +5303,13 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm MPAS_ACC_TIMER_START('atm_compute_dyn_tend_work [ACC_data_xfer]') + if (perturbation_coriolis) then + !$acc enter data copyin(u_init, v_init) + end if + if (trim(config_les_model) /= 'none') then + !$acc enter data copyin(exner, pressure_b, bn2) + end if + !$acc enter data copyin(ustm, hfx, qfx) if (rk_step == 1) then !$acc enter data create(tend_w_euler) !$acc enter data create(tend_u_euler) @@ -5274,7 +5321,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc enter data copyin(rb, rr_save) !$acc enter data copyin(divergence, vorticity) !$acc enter data copyin(v) - !$acc enter data copyin(u_init, v_init) else !$acc enter data copyin(tend_w_euler) !$acc enter data copyin(tend_u_euler) @@ -5297,9 +5343,18 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc enter data copyin(rw_save, rt_diabatic_tend) !$acc enter data create(rthdynten) !$acc enter data copyin(t_init) + if (trim(config_les_model) /= 'none') then + !$acc enter data copyin(ur_cell, vr_cell) + else #ifdef CURVATURE - !$acc enter data copyin(ur_cell, vr_cell) + !$acc enter data copyin(ur_cell, vr_cell) #endif + end if + !$acc enter data create(eddy_visc_horz) + !$acc enter data create(eddy_visc_vert) + !$acc enter data create(prandtl_3d_inv) + !$acc enter data copyin(scalars) + !$acc enter data copyin(tend_scalars) MPAS_ACC_TIMER_STOP('atm_compute_dyn_tend_work [ACC_data_xfer]') prandtl_inv = 1.0_RKIND / prandtl @@ -5336,7 +5391,16 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if(config_horiz_mixing == "2d_fixed") then - eddy_visc_horz(1:nVertLevels,cellStart:cellEnd) = config_h_theta_eddy_visc2 + !$acc parallel default(present) + !$acc loop gang worker + do iCell = cellStart, cellEnd + !$acc loop vector + do k = 1, nVertLevels + eddy_visc_horz(k,iCell) = config_h_theta_eddy_visc2 + end do + end do + !$acc end parallel + h_mom_eddy_visc4 = config_h_mom_eddy_visc4 h_theta_eddy_visc4 = config_h_theta_eddy_visc4 @@ -5520,8 +5584,11 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end do if (perturbation_coriolis) then ! this is correct only for constant f + !$acc loop seq do j = 1,nEdgesOnEdge(iEdge) eoe = edgesOnEdge(j,iEdge) + + !$acc loop vector do k=1,nVertLevels reference_u = u_init(k) * cos(angleEdge(eoe)) - v_init(k) * sin(angleEdge(eoe)) q(k) = q(k) - weightsOnEdge(j,iEdge) * reference_u * fEdge(iEdge) @@ -5996,6 +6063,14 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc end parallel MPAS_ACC_TIMER_START('atm_compute_dyn_tend_work [ACC_data_xfer]') + if (perturbation_coriolis) then + !$acc exit data delete(u_init, v_init) + end if + if (trim(config_les_model) /= 'none') then + !$acc exit data delete(exner, pressure_b) + !$acc exit data copyout(bn2) + end if + !$acc exit data delete(ustm, hfx, qfx) if (rk_step == 1) then !$acc exit data copyout(tend_w_euler) !$acc exit data copyout(tend_u_euler) @@ -6007,7 +6082,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc exit data delete(rb, rr_save) !$acc exit data delete(divergence, vorticity) !$acc exit data delete(v) - !$acc exit data delete(u_init, v_init) else !$acc exit data delete(tend_w_euler) !$acc exit data delete(tend_u_euler) @@ -6030,9 +6104,18 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc exit data delete(rw_save, rt_diabatic_tend) !$acc exit data copyout(rthdynten) !$acc exit data delete(t_init) + if (trim(config_les_model) /= 'none') then + !$acc exit data delete(ur_cell, vr_cell) + else #ifdef CURVATURE - !$acc exit data delete(ur_cell, vr_cell) + !$acc exit data delete(ur_cell, vr_cell) #endif + end if + !$acc exit data delete(eddy_visc_horz) + !$acc exit data delete(eddy_visc_vert) + !$acc exit data delete(prandtl_3d_inv) + !$acc exit data delete(scalars) + !$acc exit data copyout(tend_scalars) MPAS_ACC_TIMER_STOP('atm_compute_dyn_tend_work [ACC_data_xfer]') end subroutine atm_compute_dyn_tend_work From d79df9cf2a8948394ab7c3dc1babe83cfe55dd3e Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 28 Jan 2026 17:49:51 -0700 Subject: [PATCH 095/109] Update copyright statement at the top of mpas_atm_dissipation_models.F --- src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index cadd1cfdff..1a5e642377 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -1,5 +1,4 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). +! Copyright (c) 2026, 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 From f600615eaabac8a55302001236c0290f0af12f3a Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 28 Jan 2026 17:55:01 -0700 Subject: [PATCH 096/109] Fix LaTeX quotes in possible_values for config_les_model and config_les_surface This commit modifies the possible_values attribute for the config_les_model and config_les_surface namelist options in the atmosphere core's Registry.xml file to use LaTeX ` and ' quotes. --- src/core_atmosphere/Registry.xml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 68b0952e9b..a697eaf2e5 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -149,12 +149,12 @@ + possible_values="`none', `3d_smagorinsky', `prognostic_1.5_order'"/> + possible_values="`specified', `varying'"/> Date: Tue, 3 Feb 2026 20:19:37 +0000 Subject: [PATCH 097/109] Fix indentation of deformation_coef_* variables in atmosphere core Registry.xml The deformation_coef_* variables now use tabs for indentation rather than spaces to match other variables in the default stream definitions. --- src/core_atmosphere/Registry.xml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index a697eaf2e5..5ac9420576 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -524,11 +524,11 @@ - - - - - + + + + + #ifdef MPAS_CAM_DYCORE @@ -632,11 +632,11 @@ - - - - - + + + + + From d866412e572551ab242aac67053d4c4b697d8b62 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 3 Feb 2026 20:28:35 +0000 Subject: [PATCH 098/109] Clean up indentation in atm_init_test_coefs routine in mpas_atm_advection.F This commit cleans up whitespace and indentation in the atm_init_test_coefs routine, and it also performs minor cleanup elsewhere in the mpas_atm_advection.F file. --- src/core_init_atmosphere/mpas_atm_advection.F | 277 +++++++++--------- 1 file changed, 138 insertions(+), 139 deletions(-) diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index bff8843fbc..4852b17117 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -778,7 +778,6 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere real (kind=RKIND) :: pii real (kind=RKIND), dimension(25) :: xp, yp real (kind=RKIND) :: xe, ye - real (kind=RKIND) :: length_scale integer, dimension(25) :: cell_list @@ -790,6 +789,7 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere logical, pointer :: is_periodic real(kind=RKIND), pointer :: x_period, y_period + call mpas_pool_get_config(mesh, 'is_periodic', is_periodic) call mpas_pool_get_config(mesh, 'x_period', x_period) call mpas_pool_get_config(mesh, 'y_period', y_period) @@ -1023,16 +1023,15 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere end subroutine atm_initialize_deformation_weights -!----------------------- - subroutine atm_init_test_coefs( deformation_coef_c2, deformation_coef_s2, & - deformation_coef_cs, deformation_coef_c, & - deformation_coef_s, & - is_periodic, on_a_sphere, & - x_period, y_period, & - xEdge, yEdge, zEdge, & - xCell, yCell, zCell, nCells, & - angleEdge, nEdgesOnCell, edgesOnCell ) + subroutine atm_init_test_coefs( deformation_coef_c2, deformation_coef_s2, & + deformation_coef_cs, deformation_coef_c, & + deformation_coef_s, & + is_periodic, on_a_sphere, & + x_period, y_period, & + xEdge, yEdge, zEdge, & + xCell, yCell, zCell, nCells, & + angleEdge, nEdgesOnCell, edgesOnCell ) implicit none @@ -1085,149 +1084,149 @@ subroutine atm_init_test_coefs( deformation_coef_c2, deformation_coef_s2, & if ( (.not. on_a_sphere) .and. (is_periodic) ) then ! test is for doubly-periodic Cartesian plane only - dudx_err_max = 0. - dudy_err_max = 0. - dvdx_err_max = 0. - dvdy_err_max = 0. - dwdx_err_max = 0. - dwdy_err_max = 0. - - dudx_err_tot = 0. - dudy_err_tot = 0. - dvdx_err_tot = 0. - dvdy_err_tot = 0. - dwdx_err_tot = 0. - dwdy_err_tot = 0. - - dudx_max = 0. - dudy_max = 0. - dvdx_max = 0. - dvdy_max = 0. - dwdx_max = 0. - dwdy_max = 0. - - do iCell = 1, nCells - - dudx = 0. - dudy = 0. - dvdx = 0. - dvdy = 0. - dwdx = 0. - dwdy = 0. - - xc = xCell(iCell) - yc = yCell(iCell) - - dudx_c = dudx_cell(xc,yc,x_period,y_period) - dudy_c = dudy_cell(xc,yc,x_period,y_period) - dvdx_c = dvdx_cell(xc,yc,x_period,y_period) - dvdy_c = dvdy_cell(xc,yc,x_period,y_period) - dwdx_c = dwdx_cell(xc,yc,x_period,y_period) - dwdy_c = dwdy_cell(xc,yc,x_period,y_period) - - do iEdge = 1, nEdgesOnCell(iCell) + dudx_err_max = 0. + dudy_err_max = 0. + dvdx_err_max = 0. + dvdy_err_max = 0. + dwdx_err_max = 0. + dwdy_err_max = 0. + + dudx_err_tot = 0. + dudy_err_tot = 0. + dvdx_err_tot = 0. + dvdy_err_tot = 0. + dwdx_err_tot = 0. + dwdy_err_tot = 0. + + dudx_max = 0. + dudy_max = 0. + dvdx_max = 0. + dvdy_max = 0. + dwdx_max = 0. + dwdy_max = 0. + + do iCell = 1, nCells + + dudx = 0. + dudy = 0. + dvdx = 0. + dvdy = 0. + dwdx = 0. + dwdy = 0. + + xc = xCell(iCell) + yc = yCell(iCell) + + dudx_c = dudx_cell(xc,yc,x_period,y_period) + dudy_c = dudy_cell(xc,yc,x_period,y_period) + dvdx_c = dvdx_cell(xc,yc,x_period,y_period) + dvdy_c = dvdy_cell(xc,yc,x_period,y_period) + dwdx_c = dwdx_cell(xc,yc,x_period,y_period) + dwdy_c = dwdy_cell(xc,yc,x_period,y_period) + + do iEdge = 1, nEdgesOnCell(iCell) + + ie = edgesOnCell(iEdge,iCell) + angle_e = angleEdge(ie) + xe = xEdge(ie) + ye = yEdge(ie) + + xe = mpas_fix_periodicity(xe,xc,x_period) + ye = mpas_fix_periodicity(ye,yc,y_period) + + ue = u_edge(xe,ye,angle_e,x_period,y_period) + ve = v_edge(xe,ye,angle_e,x_period,y_period) + we = w_edge(xe,ye,x_period,y_period) + + dudx = dudx + deformation_coef_c2(iEdge,iCell)*ue & + - deformation_coef_cs(iEdge,iCell)*ve + dudy = dudy + deformation_coef_cs(iEdge,iCell)*ue & + - deformation_coef_s2(iEdge,iCell)*ve + dvdx = dvdx + deformation_coef_cs(iEdge,iCell)*ue & + + deformation_coef_c2(iEdge,iCell)*ve + dvdy = dvdy + deformation_coef_s2(iEdge,iCell)*ue & + + deformation_coef_cs(iEdge,iCell)*ve + + dwdx = dwdx + deformation_coef_c(iEdge,iCell)*we + dwdy = dwdy + deformation_coef_s(iEdge,iCell)*we - ie = edgesOnCell(iEdge,iCell) - angle_e = angleEdge(ie) - xe = xEdge(ie) - ye = yEdge(ie) - - xe = mpas_fix_periodicity(xe,xc,x_period) - ye = mpas_fix_periodicity(ye,yc,y_period) - - ue = u_edge(xe,ye,angle_e,x_period,y_period) - ve = v_edge(xe,ye,angle_e,x_period,y_period) - we = w_edge(xe,ye,x_period,y_period) - - dudx = dudx + deformation_coef_c2(iEdge,iCell)*ue & - - deformation_coef_cs(iEdge,iCell)*ve - dudy = dudy + deformation_coef_cs(iEdge,iCell)*ue & - - deformation_coef_s2(iEdge,iCell)*ve - dvdx = dvdx + deformation_coef_cs(iEdge,iCell)*ue & - + deformation_coef_c2(iEdge,iCell)*ve - dvdy = dvdy + deformation_coef_s2(iEdge,iCell)*ue & - + deformation_coef_cs(iEdge,iCell)*ve - - dwdx = dwdx + deformation_coef_c(iEdge,iCell)*we - dwdy = dwdy + deformation_coef_s(iEdge,iCell)*we - - end do + end do - ! call mpas_log_write(' u_x, u_y, $r, $r ', realArgs=(/dudx, dudy/)) - ! call mpas_log_write(' v_x, v_y, $r, $r ', realArgs=(/dvdx, dvdy/)) - ! call mpas_log_write(' w_x, w_y, $r, $r ', realArgs=(/dwdx, dwdy/)) + ! call mpas_log_write(' u_x, u_y, $r, $r ', realArgs=(/dudx, dudy/)) + ! call mpas_log_write(' v_x, v_y, $r, $r ', realArgs=(/dvdx, dvdy/)) + ! call mpas_log_write(' w_x, w_y, $r, $r ', realArgs=(/dwdx, dwdy/)) - ! check result for cell + ! check result for cell - e_int = abs(dudx_c - dudx) - dudx_err_tot = dudx_err_tot + e_int - dudx_err_max = max(dudx_err_max, e_int) + e_int = abs(dudx_c - dudx) + dudx_err_tot = dudx_err_tot + e_int + dudx_err_max = max(dudx_err_max, e_int) - e_int = abs(dudy_c - dudy) - dudy_err_tot = dudy_err_tot + e_int - dudy_err_max = max(dudy_err_max, e_int) + e_int = abs(dudy_c - dudy) + dudy_err_tot = dudy_err_tot + e_int + dudy_err_max = max(dudy_err_max, e_int) - e_int = abs(dvdx_c - dvdx) - dvdx_err_tot = dvdx_err_tot + e_int - dvdx_err_max = max(dvdx_err_max, e_int) + e_int = abs(dvdx_c - dvdx) + dvdx_err_tot = dvdx_err_tot + e_int + dvdx_err_max = max(dvdx_err_max, e_int) - e_int = abs(dvdy_c - dvdy) - dvdy_err_tot = dvdy_err_tot + e_int - dvdy_err_max = max(dvdy_err_max, e_int) + e_int = abs(dvdy_c - dvdy) + dvdy_err_tot = dvdy_err_tot + e_int + dvdy_err_max = max(dvdy_err_max, e_int) - e_int = abs(dwdx_c - dwdx) - dwdx_err_tot = dwdx_err_tot + e_int - dwdx_err_max = max(dwdx_err_max, e_int) + e_int = abs(dwdx_c - dwdx) + dwdx_err_tot = dwdx_err_tot + e_int + dwdx_err_max = max(dwdx_err_max, e_int) - e_int = abs(dwdy_c - dwdy) - dwdy_err_tot = dwdy_err_tot + e_int - dwdy_err_max = max(dwdy_err_max, e_int) + e_int = abs(dwdy_c - dwdy) + dwdy_err_tot = dwdy_err_tot + e_int + dwdy_err_max = max(dwdy_err_max, e_int) - dudx_max = max(dudx_max, abs(dudx_c)) - dudy_max = max(dudy_max, abs(dudy_c)) - dvdx_max = max(dvdx_max, abs(dvdx_c)) - dvdy_max = max(dvdy_max, abs(dvdy_c)) - dwdx_max = max(dwdx_max, abs(dwdx_c)) - dwdy_max = max(dwdy_max, abs(dwdy_c)) + dudx_max = max(dudx_max, abs(dudx_c)) + dudy_max = max(dudy_max, abs(dudy_c)) + dvdx_max = max(dvdx_max, abs(dvdx_c)) + dvdy_max = max(dvdy_max, abs(dvdy_c)) + dwdx_max = max(dwdx_max, abs(dwdx_c)) + dwdy_max = max(dwdy_max, abs(dwdy_c)) - end do + end do - ! scale errors - - dudx_err_max = dudx_err_max/dudx_max - dudy_err_max = dudy_err_max/dudy_max - dvdx_err_max = dvdx_err_max/dvdx_max - dvdy_err_max = dvdy_err_max/dvdy_max - dwdx_err_max = dwdx_err_max/dwdx_max - dwdy_err_max = dwdy_err_max/dwdy_max - - dudx_err_tot = dudx_err_tot/dudx_max/real(nCells) - dudy_err_tot = dudy_err_tot/dudy_max/real(nCells) - dvdx_err_tot = dvdx_err_tot/dvdx_max/real(nCells) - dvdy_err_tot = dvdy_err_tot/dvdy_max/real(nCells) - dwdx_err_tot = dwdx_err_tot/dwdx_max/real(nCells) - dwdy_err_tot = dwdy_err_tot/dwdy_max/real(nCells) - - ! output - - call mpas_log_write(' ') - call mpas_log_write(' deformation coefficients check ') - call mpas_log_write(' dudx check, max abs(dudx), max and avg error $r, $r, $r', & - realArgs=(/dudx_max, dudx_err_max, dudx_err_tot/)) - call mpas_log_write(' dudy check, max abs(dudy), max and avg error $r, $r, $r', & - realArgs=(/dudy_max, dudy_err_max, dudy_err_tot/)) - call mpas_log_write(' dvdx check, max abs(dvdx), max and avg error $r, $r, $r', & - realArgs=(/dvdx_max, dvdx_err_max, dvdx_err_tot/)) - call mpas_log_write(' dvdy check, max abs(dvdy), max and avg error $r, $r, $r', & - realArgs=(/dvdy_max, dvdy_err_max, dvdy_err_tot/)) - call mpas_log_write(' dwdx check, max abs(dwdx), max and avg error $r, $r, $r', & - realArgs=(/dwdx_max, dwdx_err_max, dwdx_err_tot/)) - call mpas_log_write(' dwdy check, max abs(dwdy), max and avg error $r, $r, $r', & - realArgs=(/dwdy_max, dwdy_err_max, dwdy_err_tot/)) - call mpas_log_write(' ') + ! scale errors + + dudx_err_max = dudx_err_max/dudx_max + dudy_err_max = dudy_err_max/dudy_max + dvdx_err_max = dvdx_err_max/dvdx_max + dvdy_err_max = dvdy_err_max/dvdy_max + dwdx_err_max = dwdx_err_max/dwdx_max + dwdy_err_max = dwdy_err_max/dwdy_max + + dudx_err_tot = dudx_err_tot/dudx_max/real(nCells) + dudy_err_tot = dudy_err_tot/dudy_max/real(nCells) + dvdx_err_tot = dvdx_err_tot/dvdx_max/real(nCells) + dvdy_err_tot = dvdy_err_tot/dvdy_max/real(nCells) + dwdx_err_tot = dwdx_err_tot/dwdx_max/real(nCells) + dwdy_err_tot = dwdy_err_tot/dwdy_max/real(nCells) + + ! output + + call mpas_log_write(' ') + call mpas_log_write(' deformation coefficients check ') + call mpas_log_write(' dudx check, max abs(dudx), max and avg error $r, $r, $r', & + realArgs=(/dudx_max, dudx_err_max, dudx_err_tot/)) + call mpas_log_write(' dudy check, max abs(dudy), max and avg error $r, $r, $r', & + realArgs=(/dudy_max, dudy_err_max, dudy_err_tot/)) + call mpas_log_write(' dvdx check, max abs(dvdx), max and avg error $r, $r, $r', & + realArgs=(/dvdx_max, dvdx_err_max, dvdx_err_tot/)) + call mpas_log_write(' dvdy check, max abs(dvdy), max and avg error $r, $r, $r', & + realArgs=(/dvdy_max, dvdy_err_max, dvdy_err_tot/)) + call mpas_log_write(' dwdx check, max abs(dwdx), max and avg error $r, $r, $r', & + realArgs=(/dwdx_max, dwdx_err_max, dwdx_err_tot/)) + call mpas_log_write(' dwdy check, max abs(dwdy), max and avg error $r, $r, $r', & + realArgs=(/dwdy_max, dwdy_err_max, dwdy_err_tot/)) + call mpas_log_write(' ') end if - end subroutine atm_init_test_coefs + end subroutine atm_init_test_coefs end module atm_advection From 84986ea87d6eec3c2120513b2bfec804e475973f Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 3 Feb 2026 20:51:03 +0000 Subject: [PATCH 099/109] Tidy up module use statements in mpas_atm_time_integration.F --- src/core_atmosphere/dynamics/mpas_atm_time_integration.F | 5 ++--- 1 file changed, 2 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 3d79ef059c..de8c7b6c9c 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -22,9 +22,8 @@ module atm_time_integration use mpas_dmpar use mpas_vector_reconstruction ! Added only clause to keep xlf90 from getting confused from the overloaded abs intrinsic in mpas_timekeeping - use mpas_derived_types, only : MPAS_NOW - use mpas_timekeeping, only: MPAS_Time_type, MPAS_TimeInterval_type, mpas_get_clock_time, & - mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+), add_t_ti + use mpas_derived_types, only : MPAS_Time_type, MPAS_TimeInterval_type, MPAS_NOW + use mpas_timekeeping, only: mpas_get_clock_time, mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+) use mpas_timer #ifdef DO_PHYSICS From be8887d8decd7b95fc5a880eaf4b7102aac065f4 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 3 Feb 2026 20:53:16 +0000 Subject: [PATCH 100/109] Fix indentation of call to atm_compute_dyn_tend in atm_srk3 --- .../dynamics/mpas_atm_time_integration.F | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index de8c7b6c9c..1c543c5716 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -1210,16 +1210,16 @@ subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !$acc end parallel !$OMP PARALLEL DO - do thread=1,nThreads - call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, diag_physics, & - block % configs, nVertLevels, rk_step, dynamics_substep, dt, & - 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 + do thread=1,nThreads + call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, diag_physics, & + block % configs, nVertLevels, rk_step, dynamics_substep, dt, & + 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(delsq_theta) From 42455024275d3ca80afa1f13340b04b2c1b5f8af Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 4 Feb 2026 00:28:38 +0000 Subject: [PATCH 101/109] Fix indentation of calls to calculate_n2 and les_models in atm_compute_dyn_tend_work --- .../dynamics/mpas_atm_time_integration.F | 32 +++++++++---------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 1c543c5716..a0ceae6422 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5407,25 +5407,25 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm else if (config_les_model /= "none") then - ! call mpas_log_write(' BV call, index qv, qc, tke $i $i $i ', intArgs=(/index_qv, index_qc, index_tke/)) + ! call mpas_log_write(' BV call, index qv, qc, tke $i $i $i ', intArgs=(/index_qv, index_qc, index_tke/)) - call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & - cellStart, cellEnd, nCells) + call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & + cellStart, cellEnd, nCells) - currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) - call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) - time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*dt - ! call mpas_log_write(' les integration, timestep midpoint time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) + currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) + call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) + time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*dt + ! call mpas_log_write(' les integration, timestep midpoint time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) - call les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & - u, v, ur_cell, vr_cell, & - w, c_s, bn2, zgrid, config_len_disp, & - deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & - deformation_coef_c, deformation_coef_s, prandtl_3d_inv, & - invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & - scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & - cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & - nCells, nEdges, nVertLevels, maxEdges, num_scalars ) + call les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & + u, v, ur_cell, vr_cell, & + w, c_s, bn2, zgrid, config_len_disp, & + deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & + deformation_coef_c, deformation_coef_s, prandtl_3d_inv, & + invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & + scalars, tend_scalars, index_tke, rho_zz, meshScalingDel2, & + cellStart, cellEnd, nEdgesOnCell, edgesOnCell, cellsOnEdge, & + nCells, nEdges, nVertLevels, maxEdges, num_scalars ) end if From 01c4a5ebe2b419803e1e95d3ea01d4dcb0d4684c Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 4 Feb 2026 00:34:57 +0000 Subject: [PATCH 102/109] Remove commented-out calls to non-existent dissipation routines This commit removes commented-out calls to the u_dissipation, w_dissipation, theta_dissipation, and theta_dissipation_3d routines in the atm_compute_dyn_tend_work routine; the implementations of these routines no longer exist, and they had only been used for testing during the migration to new dissipation routines for u, w, and scalars. This commit also removes the local variable test_dissipation_3d, which was used to control whether the aforementioned routines were called. --- .../dynamics/mpas_atm_time_integration.F | 157 +++++------------- 1 file changed, 45 insertions(+), 112 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index a0ceae6422..c063760f36 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -5238,7 +5238,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: config_visc4_2dsmag real (kind=RKIND) :: config_len_disp real (kind=RKIND) :: config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2 - logical, parameter :: test_dissipation_3d=.true. integer, intent(in) :: rk_step, dynamics_substep real (kind=RKIND), intent(in) :: dt @@ -5628,36 +5627,20 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$OMP BARRIER -! if(test_dissipation_3d) then - - call u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & - cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & - cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & - nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & - invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & - angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & - config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & - config_del4u_div_factor, zgrid, & - eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & - fzm, fzp, config_les_model, config_les_surface, & - config_surface_drag_coefficient, & - delsq_u, delsq_vorticity, delsq_divergence, & - u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, tend_u_euler ) - -! else ! this is the original MPAS dissipation code -! -! call u_dissipation( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & -! cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & -! cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & -! nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & -! invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & -! angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & -! config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & -! config_del4u_div_factor, zgrid, kdiff, & -! delsq_u, delsq_vorticity, delsq_divergence, & -! u, divergence, vorticity, rho_edge, u_init, v_init, tend_u_euler ) -! -! end if + call u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, vertexStart, vertexEnd, & + cellStart, cellEnd, nCells, nEdges, nVertices, vertexDegree, & + cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex, & + nEdgesOnCell, edgesOnCell_sign, edgesOnVertex_sign, & + invAreaCell, invAreaTriangle, invDvEdge, invDcEdge, & + angleEdge, dcEdge, dvEdge, meshScalingDel2, meshScalingDel4, & + config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & + config_del4u_div_factor, zgrid, & + eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & + fzm, fzp, config_les_model, config_les_surface, & + config_surface_drag_coefficient, & + delsq_u, delsq_vorticity, delsq_divergence, & + u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, tend_u_euler ) + end if ! (rk_step 1 test for computing mixing terms) @@ -5785,35 +5768,18 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then -! if(test_dissipation_3d) then - - call w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - rdzw, rdzu, & - v_mom_eddy_visc2, h_mom_eddy_visc4, & - delsq_w, & - w, rho_edge, rho_zz, divergence, zz, & - eddy_visc_horz, eddy_visc_vert, & - config_les_model, config_les_surface, & - tend_w_euler ) - -! else -! -! call w_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & -! nCells, nEdges, & -! nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & -! invAreaCell, invDcEdge, dvEdge, & -! meshScalingDel2, meshScalingDel4, & -! rdzw, rdzu, & -! v_mom_eddy_visc2, h_mom_eddy_visc4, & -! delsq_w, & -! w, rho_edge, kdiff, rho_zz, & -! tend_w_euler ) -! -! end if + call w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + rdzw, rdzu, & + v_mom_eddy_visc2, h_mom_eddy_visc4, & + delsq_w, & + w, rho_edge, rho_zz, divergence, zz, & + eddy_visc_horz, eddy_visc_vert, & + config_les_model, config_les_surface, & + tend_w_euler ) end if ! mixing for w computed in first rk_step @@ -5958,58 +5924,25 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (rk_step == 1) then -! if(test_dissipation_3d) then - - !call theta_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - ! nCells, nEdges, & - ! nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - ! invAreaCell, invDcEdge, dvEdge, & - ! meshScalingDel2, meshScalingDel4, & - ! config_mix_full, t_init, zgrid, & - ! rdzw, rdzu, fzm, fzp, & - ! v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - ! delsq_theta, & - ! theta_m, rho_edge, rho_zz, zz, & - ! eddy_visc_horz, eddy_visc_vert, & - ! config_les_model, & - ! tend_theta_euler ) - - call scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & - nCells, nEdges, & - nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & - invAreaCell, invDcEdge, dvEdge, & - meshScalingDel2, meshScalingDel4, & - config_mix_full, t_init, zgrid, & - rdzw, rdzu, fzm, fzp, & - v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & - prandtl_3d_inv, & - delsq_theta, & - theta_m, rho_edge, rho_zz, zz, & - eddy_visc_horz, eddy_visc_vert, & - bn2, config_len_disp, scalars, tend_scalars, & - index_tke, index_qv, num_scalars, config_mix_scalars, & - config_les_model, config_les_surface, time_of_day_seconds,& - config_surface_heat_flux, config_surface_moisture_flux, & - ur_cell, vr_cell, & - hfx, qfx, & - tend_theta_euler, dynamics_substep ) - - -! else ! this is the original MPAS dissipation code -! -! call theta_dissipation( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & -! nCells, nEdges, & -! nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & -! invAreaCell, invDcEdge, dvEdge, & -! meshScalingDel2, meshScalingDel4, & -! config_mix_full, t_init, zgrid, & -! rdzw, rdzu, & -! v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & -! delsq_theta, & -! theta_m, rho_edge, kdiff, rho_zz, & -! tend_theta_euler ) -! -! end if + call scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSolveEnd, & + nCells, nEdges, & + nEdgesOnCell, edgesOnCell, cellsOnEdge, edgesOnCell_sign, & + invAreaCell, invDcEdge, dvEdge, & + meshScalingDel2, meshScalingDel4, & + config_mix_full, t_init, zgrid, & + rdzw, rdzu, fzm, fzp, & + v_theta_eddy_visc2, h_theta_eddy_visc4, prandtl_inv, & + prandtl_3d_inv, & + delsq_theta, & + theta_m, rho_edge, rho_zz, zz, & + eddy_visc_horz, eddy_visc_vert, & + bn2, config_len_disp, scalars, tend_scalars, & + index_tke, index_qv, num_scalars, config_mix_scalars, & + config_les_model, config_les_surface, time_of_day_seconds,& + config_surface_heat_flux, config_surface_moisture_flux, & + ur_cell, vr_cell, & + hfx, qfx, & + tend_theta_euler, dynamics_substep ) end if ! theta mixing calculated first rk_step From fb5c14ad2969a0cab78e463a733f0d842f635771 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 4 Feb 2026 00:39:23 +0000 Subject: [PATCH 103/109] Set the Prandtl number back to 1.0 in mpas_constants The value of the Prandtl number had been changed to 1/3 during development of the initial LES capability for MPAS-Atmosphere. --- src/framework/mpas_constants.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/mpas_constants.F b/src/framework/mpas_constants.F index 5822f9c0e6..2c8168510a 100644 --- a/src/framework/mpas_constants.F +++ b/src/framework/mpas_constants.F @@ -53,7 +53,7 @@ module mpas_constants real (kind=RKIND), parameter :: cvpm = -cv / cp ! #endif real (kind=RKIND), parameter :: p0 = 1.0e5_RKIND !< Constant: 100000 Pa - real (kind=RKIND), parameter :: prandtl = 1.0_RKIND/3.0_RKIND !< Constant: Prandtl number + real (kind=RKIND), parameter :: prandtl = 1.0_RKIND !< Constant: Prandtl number contains From 128b96d067584164553a843554ebcaca1b68627c Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 4 Feb 2026 01:01:57 +0000 Subject: [PATCH 104/109] Remove unnecessary variables from the atmosphere core's restart stream This commit removes the following variables from the definition of the restart stream in the atmosphere core: deriv_two defc_a defc_b deformation_coef_c2 deformation_coef_s2 deformation_coef_cs deformation_coef_c deformation_coef_s coeffs_reconstruct east north These variables are either already indirectly included in the restart stream through the invariant stream or they are not needed in restart files. --- src/core_atmosphere/Registry.xml | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 5ac9420576..fa243580ca 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -629,17 +629,6 @@ #endif - - - - - - - - - - - From ce6c254b27481cc1cbc290b34a96e1d6a449ee84 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 4 Feb 2026 01:34:38 +0000 Subject: [PATCH 105/109] Move computation of time_of_day_seconds into flux_les_sas routine The logic to compute time_of_day_seconds was previously in the atm_compute_dyn_tend_work routine, though the time_of_day_seconds variable was only used in the commented-out routine flux_les_sas in the mpas_atm_dissipation_models module. In an attempt to keep the atm_compute_dyn_tend_work routine cleaner, this commit pushes the computation of time_of_day_seconds down to the flux_les_sas routine where it is actually used. In order to do this, the simulation clock and timestep, dt, are now passed as arguments to scalar_dissipation_3d_les and thereafter into flux_les_sas. --- .../dynamics/mpas_atm_dissipation_models.F | 25 ++++++++++++++----- .../dynamics/mpas_atm_time_integration.F | 14 ++--------- 2 files changed, 21 insertions(+), 18 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 1a5e642377..60814f8a20 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -14,7 +14,8 @@ module mpas_atm_dissipation_models use mpas_atmphys_constants use mpas_constants use mpas_log - use mpas_derived_types, only : MPAS_LOG_CRIT + use mpas_timekeeping, only : mpas_get_clock_time, mpas_get_time + use mpas_derived_types, only : MPAS_Clock_type, MPAS_Time_type, MPAS_NOW, MPAS_LOG_CRIT logical, parameter :: les_test = .true., les_sas_test = .false. !! real (kind=RKIND), parameter :: tke_heat_flux = 0.03 ! shear case from Moeng et al., first hour @@ -1069,7 +1070,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo eddy_visc_horz, eddy_visc_vert, & bv_freq2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars_dummy, mix_scalars, & - config_les_model, config_les_surface, time_of_day_seconds,& + config_les_model, config_les_surface, clock, dt, & config_surface_heat_flux, config_surface_moisture_flux, & uReconstructZonal, uReconstructMeridional, & hfx, qfx, & @@ -1090,7 +1091,6 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo integer, intent(in) :: index_tke, index_qv integer, intent(in) :: dynamics_substep - real (kind=RKIND), intent(in) :: time_of_day_seconds real (kind=RKIND), intent(in) :: config_surface_heat_flux real (kind=RKIND), intent(in) :: config_surface_moisture_flux @@ -1099,6 +1099,9 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo character (len=StrKIND) :: config_les_model character (len=StrKIND) :: config_les_surface + type (MPAS_Clock_type), intent(in) :: clock + real (kind=RKIND), intent(in) :: dt + integer, dimension(nCells+1), intent(in) :: nEdgesOnCell integer, dimension(maxEdges,nCells+1), intent(in) :: EdgesOnCell @@ -1428,7 +1431,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo heat_flux = config_surface_heat_flux ! place holder routine for time-varying specified -! call flux_les_sas( heat_flux, moisture_flux, time_of_day_seconds ) +! call flux_les_sas( heat_flux, moisture_flux, clock, dt ) else if ( config_les_surface == "varying" ) then heat_flux = hfx(iCell)/rho_zz(1,iCell)/cp @@ -1508,18 +1511,28 @@ end subroutine scalar_dissipation_3d_les !----------- -! subroutine flux_les_sas(heat_flux, moisture_flux, time_of_day_seconds) +! subroutine flux_les_sas(heat_flux, moisture_flux, clock, dt) ! implicit none -! real (kind=RKIND), intent(in) :: time_of_day_seconds ! real (kind=RKIND), intent(out) :: heat_flux, moisture_flux +! type (MPAS_Clock_type), intent(in) :: clock +! real (kind=RKIND), intent(in) :: dt ! real (kind=RKIND), parameter:: t_start_t_flux = 3600.*6.0 ! real (kind=RKIND), parameter:: t_end_t_flux = 3600.*19.50 ! real (kind=RKIND), parameter:: t_start_q_flux = 3600.*7.0 ! real (kind=RKIND), parameter:: t_end_q_flux = 3600.*19.50 ! real (kind=RKIND) :: rel_time_t_flux, rel_time_q_flux +! real (kind=RKIND) :: time_of_day_seconds +! type (MPAS_Time_type) :: currTime +! integer :: H, M, S, S_n, S_d +! integer :: ierr + +! currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) +! call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) +! time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*dt +! call mpas_log_write(' les integration, timestep midpoint time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) ! rel_time_t_flux = max(0.,(time_of_day_seconds - t_start_t_flux)/(t_end_t_flux - t_start_t_flux)) ! rel_time_q_flux = max(0.,(time_of_day_seconds - t_start_q_flux)/(t_end_q_flux - t_start_q_flux)) diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index c063760f36..25179e987c 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -23,7 +23,7 @@ module atm_time_integration use mpas_vector_reconstruction ! Added only clause to keep xlf90 from getting confused from the overloaded abs intrinsic in mpas_timekeeping use mpas_derived_types, only : MPAS_Time_type, MPAS_TimeInterval_type, MPAS_NOW - use mpas_timekeeping, only: mpas_get_clock_time, mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+) + use mpas_timekeeping, only: mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+) use mpas_timer #ifdef DO_PHYSICS @@ -5287,11 +5287,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm logical, parameter :: perturbation_coriolis = .true. real (kind=RKIND) :: reference_u - type (MPAS_Time_Type) :: currTime - integer :: H, M, S, S_n, S_d - integer :: ierr - real(kind=RKIND) :: time_of_day_seconds - flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ua*( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 @@ -5410,11 +5405,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) - - currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) - call mpas_get_time(curr_time=currTime, H=H, M=M, S=S, S_n=S_n, S_d=S_d) - time_of_day_seconds = real(H)*3600. + real(M)*60. + real(S) + real(S_n)/real(S_d) + 0.5*dt - ! call mpas_log_write(' les integration, timestep midpoint time of day in seconds, $r ', realArgs=(/time_of_day_seconds/)) call les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & u, v, ur_cell, vr_cell, & @@ -5938,7 +5928,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eddy_visc_horz, eddy_visc_vert, & bn2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars, config_mix_scalars, & - config_les_model, config_les_surface, time_of_day_seconds,& + config_les_model, config_les_surface, clock, dt, & config_surface_heat_flux, config_surface_moisture_flux, & ur_cell, vr_cell, & hfx, qfx, & From b2a744955964ddacc1c3f66c174ed6422014dc97 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 4 Feb 2026 16:48:49 -0700 Subject: [PATCH 106/109] Fix implementation of "CAM-MPAS" 2nd-order horizontal filter The implementation of the "CAM-MPAS" 2nd-order horizontal filter contained code to place a lower-bound on the 'kdiff' variable, which is no longer used, and it also included out-dated code to apply the filter over only the top three layers in the model. This commit updates the filter code (active when config_mpas_cam_coef > 0.0) so that it correctly enforces a lower-bound on 'eddy_visc_horz' over a variable number of layers below the model top. As part of the changes in this commit, the variable 'kdiff' can be removed entirely from the atmosphere core, as it has been supplanted by the 'eddy_visc_horz' variable. --- src/core_atmosphere/Registry.xml | 3 --- .../dynamics/mpas_atm_time_integration.F | 15 ++++----------- 2 files changed, 4 insertions(+), 14 deletions(-) diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index fa243580ca..a0a94ad03c 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1973,9 +1973,6 @@ - - diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 25179e987c..4307dca8f0 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4820,7 +4820,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save + h_divergence, bn2, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save real (kind=RKIND), dimension(:,:), pointer :: eddy_visc_horz, eddy_visc_vert @@ -4929,7 +4929,6 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys call mpas_pool_get_array(diag, 'rho_p', rr) call mpas_pool_get_array(diag, 'rho_p_save', rr_save) call mpas_pool_get_array(diag, 'v', v) - call mpas_pool_get_array(diag, 'kdiff', kdiff) call mpas_pool_get_array(diag, 'eddy_visc_horz', eddy_visc_horz) call mpas_pool_get_array(diag, 'eddy_visc_vert', eddy_visc_vert) call mpas_pool_get_array(diag, 'bn2', bn2) @@ -5060,7 +5059,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, index_tke, & + h_divergence, bn2, eddy_visc_horz, eddy_visc_vert, index_tke, & 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, & @@ -5095,7 +5094,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm weightsOnEdge, zgrid, rho_edge, rho_zz, ru, u, v, tend_u, & divergence, vorticity, ke, pv_edge, theta_m, rw, tend_rho, & rt_diabatic_tend, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zxu, cqu, & - h_divergence, kdiff, bn2, eddy_visc_horz, eddy_visc_vert, index_tke, & + h_divergence, bn2, eddy_visc_horz, eddy_visc_vert, index_tke, & 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, & @@ -5164,7 +5163,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: zxu real (kind=RKIND), dimension(nVertLevels,nEdges+1) :: cqu real (kind=RKIND), dimension(nVertLevels,nCells+1) :: h_divergence - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: kdiff real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_horz real (kind=RKIND), dimension(nVertLevels,nCells+1) :: eddy_visc_vert real (kind=RKIND), dimension(nVertLevels,nCells+1) :: bn2 @@ -5309,7 +5307,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc enter data create(tend_theta_euler) !$acc enter data create(tend_rho) - !$acc enter data create(kdiff) !$acc enter data copyin(tend_rho_physics) !$acc enter data copyin(rb, rr_save) !$acc enter data copyin(divergence, vorticity) @@ -5431,11 +5428,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm do k = nVertLevels-config_number_cam_damping_levels + 1, nVertLevels visc2cam = 4.0*2.0833*config_len_disp*config_mpas_cam_coef visc2cam = visc2cam*(1.0-real(nVertLevels-k)/real(config_number_cam_damping_levels)) - kdiff(k ,iCell) = max(kdiff(k ,iCell),visc2cam) + eddy_visc_horz(k,iCell) = max(eddy_visc_horz(k,iCell),visc2cam) end do - eddy_visc_horz(nVertLevels-2,iCell) = max(eddy_visc_horz(nVertLevels-2,iCell), 2.0833*config_len_disp*config_mpas_cam_coef) - eddy_visc_horz(nVertLevels-1,iCell) = max(eddy_visc_horz(nVertLevels-1,iCell),2.0*2.0833*config_len_disp*config_mpas_cam_coef) - eddy_visc_horz(nVertLevels ,iCell) = max(eddy_visc_horz(nVertLevels ,iCell),4.0*2.0833*config_len_disp*config_mpas_cam_coef) end do !$acc end parallel @@ -5999,7 +5993,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc exit data copyout(tend_theta_euler) !$acc exit data copyout(tend_rho) - !$acc exit data delete(kdiff) !$acc exit data delete(tend_rho_physics) !$acc exit data delete(rb, rr_save) !$acc exit data delete(divergence, vorticity) From dc9c0d799783459552e39881026e3966119dd202 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Wed, 25 Feb 2026 14:27:40 -0700 Subject: [PATCH 107/109] Use integer comparisons for config_les_model and config_les_surface Rather than comparing strings, this commit introduces changes to allow for integer comparisons when checking the LES model option and LES surface option. The mpas_atm_dissipation_models module now contains two new functions, les_model_from_string and les_surface_from_string, that translate character strings from the namelist options config_les_model and config_les_surface, respectively, into integer parameters. These two new functions are used in the atm_compute_dyn_tend routine to obtain integer values representing the runtime selection of LES model option and LES surface option, and these integers are employed thereafter. --- .../dynamics/mpas_atm_dissipation_models.F | 149 +++++++++++++----- .../dynamics/mpas_atm_time_integration.F | 39 +++-- 2 files changed, 136 insertions(+), 52 deletions(-) diff --git a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F index 60814f8a20..450ed045c1 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F +++ b/src/core_atmosphere/dynamics/mpas_atm_dissipation_models.F @@ -28,10 +28,95 @@ module mpas_atm_dissipation_models ! real (kind=RKIND), parameter :: c_k = 0.1 real (kind=RKIND), parameter :: c_k = 0.25 + integer, parameter :: LES_INVALID_OPT = -1 + + integer, parameter :: LES_MODEL_NONE = 0, & + LES_MODEL_3D_SMAGORINSKY = 1, & + LES_MODEL_PROGNOSTIC_15_ORDER = 2 + + integer, parameter :: LES_SURFACE_NONE = 0, & + LES_SURFACE_SPECIFIED = 1, & + LES_SURFACE_VARYING = 2 contains + !----------------------------------------------------------------------- + ! routine les_model_from_string + ! + !> \brief Converts an LES model option from a string to an integer parameter + !> \author Michael Duda + !> \date 13 February 2026 + !> \details + !> Given a string that contains the name of a valid LES model option, this + !> routine returns an integer parameter corresponding to that option. + !> + !> If the given string is not recognized as a valid LES model option, the + !> integer parameter LES_INVALID_OPT is returned. + ! + !----------------------------------------------------------------------- + pure function les_model_from_string(les_model_str) result(les_model_opt) + + implicit none + + ! Arguments + character(len=*), intent(in) :: les_model_str + + ! Return value + integer :: les_model_opt + + + if (trim(les_model_str) == 'none') then + les_model_opt = LES_MODEL_NONE + else if (trim(les_model_str) == '3d_smagorinsky') then + les_model_opt = LES_MODEL_3D_SMAGORINSKY + else if (trim(les_model_str) == 'prognostic_1.5_order') then + les_model_opt = LES_MODEL_PROGNOSTIC_15_ORDER + else + les_model_opt = LES_INVALID_OPT + end if + + end function les_model_from_string + + + !----------------------------------------------------------------------- + ! routine les_surface_from_string + ! + !> \brief Converts an LES surface option from a string to an integer parameter + !> \author Michael Duda + !> \date 13 February 2026 + !> \details + !> Given a string that contains the name of a valid LES surface option, this + !> routine returns an integer parameter corresponding to that option. + !> + !> If the given string is not recognized as a valid LES surface option, the + !> integer parameter LES_INVALID_OPT is returned. + ! + !----------------------------------------------------------------------- + pure function les_surface_from_string(les_surface_str) result(les_surface_opt) + + implicit none + + ! Arguments + character(len=*), intent(in) :: les_surface_str + + ! Return value + integer :: les_surface_opt + + + if (trim(les_surface_str) == 'none') then + les_surface_opt = LES_SURFACE_NONE + else if (trim(les_surface_str) == 'specified') then + les_surface_opt = LES_SURFACE_SPECIFIED + else if (trim(les_surface_str) == 'varying') then + les_surface_opt = LES_SURFACE_VARYING + else + les_surface_opt = LES_INVALID_OPT + end if + + end function les_surface_from_string + + subroutine smagorinsky_2d( kdiff, u, v, c_s, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & invDt, h_mom_eddy_visc4, config_visc4_2dsmag, h_theta_eddy_visc4, & @@ -121,7 +206,7 @@ end subroutine smagorinsky_2d !--------------------------------------- - subroutine les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & + subroutine les_models( les_model_opt, les_surface_opt, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & u, v, uCell, vCell, & w, c_s, bv_freq2, zgrid, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & @@ -133,8 +218,8 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e implicit none - character (len=StrKIND), intent(in) :: config_les_model - character (len=StrKIND), intent(in) :: config_les_surface + integer, intent(in) :: les_model_opt + integer, intent(in) :: les_surface_opt integer, intent(in) :: cellStart, cellEnd, nCells, nEdges, nVertLevels, maxEdges, index_tke, num_scalars integer, intent(in) :: dynamics_substep @@ -180,10 +265,6 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e ! real (kind=RKIND), parameter :: epsilon_bv = 1.e-06 - DEBUG_WRITE(' begin les_models ') - DEBUG_WRITE(' les scheme is '//trim(config_les_model)) - DEBUG_WRITE(' les surface scheme is '//trim(config_les_surface)) - !$acc enter data create(dudx, dudy, dvdx, dvdy, dwdx, dwdy, dudz, dvdz, dwdz) !$acc enter data create(d_11, d_22, d_33, d_12, d_13, d_23) @@ -278,7 +359,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e d_23(k) = dwdy(k) + dvdz(k) end do - if (config_les_model == "3d_smagorinsky") then + if (les_model_opt == LES_MODEL_3D_SMAGORINSKY) then !$acc loop vector do k=1, nVertLevels @@ -290,7 +371,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e ! eddy_visc_vert(k,iCell) = eddy_visc_horz(k,iCell) end do - else if (config_les_model == "prognostic_1.5_order") then + else if (les_model_opt == LES_MODEL_PROGNOSTIC_15_ORDER) then !$acc loop vector do k=1,nVertLevels ! bound the tke here, currently hardwired @@ -364,7 +445,7 @@ subroutine les_models( config_les_model, config_les_surface, dynamics_substep, e !MGD call mpas_log_write(' in les_models, no les scheme for '//trim(config_les_model), messageType=MPAS_LOG_CRIT) - end if ! end of config_les_model test + end if ! end of les_model_opt test end do ! loop over all owned cells (columns) @@ -485,7 +566,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & config_del4u_div_factor, zgrid, & eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & - fzm, fzp, config_les_model, config_les_surface, & + fzm, fzp, les_model_opt, les_surface_opt, & config_surface_drag_coefficient, & delsq_u, delsq_vorticity, delsq_divergence, & u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, & @@ -501,8 +582,8 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v integer, intent(in) :: nCells, nEdges, nVertices logical, intent(in) :: config_mix_full - character (len=StrKIND) :: config_les_model - character (len=StrKIND) :: config_les_surface + integer, intent(in) :: les_model_opt + integer, intent(in) :: les_surface_opt integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge integer, dimension(2,nEdges+1), intent(in) :: verticesOnEdge @@ -568,9 +649,8 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v real (kind=RKIND) :: velocity_magnitude real (kind=RKIND) :: tau_12_factor + DEBUG_WRITE(' begin u_dissipation_3d ') - DEBUG_WRITE(' les model is '//trim(config_les_model)) - DEBUG_WRITE(' les surface is '//trim(config_les_surface)) DEBUG_WRITE(' 4th order hyperviscosity is $r ' COMMA realArgs=(/h_mom_eddy_visc4/)) DEBUG_WRITE(' 4th order divergence factor is $r ' COMMA realArgs=(/config_del4u_div_factor/)) @@ -585,7 +665,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v !$acc parallel default(present) tau_12_factor = 0.0 - if(config_les_model /= 'none') tau_12_factor = 1.0 + if(les_model_opt /= LES_MODEL_NONE) tau_12_factor = 1.0 !$acc loop gang worker do iEdge=edgeStart,edgeEnd @@ -786,7 +866,7 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v end if ! vertical mixing of horizontal momentum for les formulation - if ( config_les_model /= "none") then + if ( les_model_opt /= LES_MODEL_NONE ) then !$acc parallel default(present) @@ -812,11 +892,11 @@ subroutine u_dissipation_3d( edgeStart, edgeEnd, edgeSolveStart, edgeSolveEnd, v turb_vflux(k) = - rho_k_at_w*zz_at_w*rdzu(k)*(u(k,iEdge)-u(k-1,iEdge)) end do - if( config_les_surface == "specified" ) then + if( les_surface_opt == LES_SURFACE_SPECIFIED ) then velocity_magnitude = sqrt(u(1,iEdge)**2 + v(1,iEdge)**2) turb_vflux(1) = -rho_edge(1,iEdge)*config_surface_drag_coefficient*u(1,iEdge)*velocity_magnitude turb_vflux(nVertLevels+1) = turb_vflux(nVertLevels) - else if ( config_les_surface == "varying" ) then + else if ( les_surface_opt == LES_SURFACE_VARYING ) then ust_edge = 0.5*(ustm(cell1) + ustm(cell2)) velocity_magnitude = max(sqrt(u(1,iEdge)**2 + v(1,iEdge)**2),0.1) turb_vflux(1) = -rho_edge(1,iEdge)*ust_edge*ust_edge*(u(1,iEdge)/velocity_magnitude) @@ -859,7 +939,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, delsq_w, & w, rho_edge, rho_zz, divergence, zz, & eddy_visc_horz, eddy_visc_vert, & - config_les_model, config_les_surface, & + les_model_opt, les_surface_opt, & tend_w_euler ) @@ -879,8 +959,8 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, integer, dimension(2,nEdges+1), intent(in) :: cellsOnEdge - character (len=StrKIND) :: config_les_model - character (len=StrKIND) :: config_les_surface + integer, intent(in) :: les_model_opt + integer, intent(in) :: les_surface_opt real (kind=RKIND), intent(in) :: h_mom_eddy_visc4 real (kind=RKIND), intent(in) :: v_mom_eddy_visc2 @@ -913,6 +993,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, integer :: cell1, cell2, iEdge, iCell, i, k real (kind=RKIND) :: r_areaCell, edge_sign, w_turb_flux + ! !OMP BARRIER why is this openmp barrier here??? ! del^4 horizontal filter. We compute this as del^2 ( del^2 (w) ). @@ -922,8 +1003,6 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, DEBUG_WRITE(' begin w_dissipation_3d ') - DEBUG_WRITE(' les model is '//trim(config_les_model)) - DEBUG_WRITE(' les surface is '//trim(config_les_surface)) DEBUG_WRITE(' 4th order hyperviscosity is $r ' COMMA realArgs=(/h_mom_eddy_visc4/)) !$acc enter data create(turb_vflux) @@ -1020,7 +1099,7 @@ subroutine w_dissipation_3d( cellStart, cellEnd, cellSolveStart, cellSolveEnd, end if - if ( config_les_model /= "none") then + if ( les_model_opt /= LES_MODEL_NONE ) then !$acc parallel default(present) @@ -1070,7 +1149,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo eddy_visc_horz, eddy_visc_vert, & bv_freq2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars_dummy, mix_scalars, & - config_les_model, config_les_surface, clock, dt, & + les_model_opt, les_surface_opt, clock, dt, & config_surface_heat_flux, config_surface_moisture_flux, & uReconstructZonal, uReconstructMeridional, & hfx, qfx, & @@ -1096,8 +1175,8 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo logical, intent(in) :: config_mix_full, mix_scalars - character (len=StrKIND) :: config_les_model - character (len=StrKIND) :: config_les_surface + integer, intent(in) :: les_model_opt + integer, intent(in) :: les_surface_opt type (MPAS_Clock_type), intent(in) :: clock real (kind=RKIND), intent(in) :: dt @@ -1157,8 +1236,6 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo DEBUG_WRITE(' begin scalar_dissipation_3d ') - DEBUG_WRITE(' les model is '//trim(config_les_model)) - DEBUG_WRITE(' les surface is '//trim(config_les_surface)) DEBUG_WRITE(' 4th order hyperviscosity is $r ' COMMA realArgs=(/h_theta_eddy_visc4/)) if( mix_scalars .and. (dynamics_substep == 1)) call mpas_log_write(' scalar mixing on ') @@ -1373,7 +1450,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end if - if ( config_les_model /= "none") then + if ( les_model_opt /= LES_MODEL_NONE ) then !$acc parallel default(present) @@ -1384,7 +1461,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo turb_vflux(nVertlevels+1) = 0. ! no turbulent flux out of the domain turb_vflux(1) = 0. ! lower bc flux handled where ??? - if ( config_les_model == "3d_smagorinsky") then + if ( les_model_opt == LES_MODEL_3D_SMAGORINSKY ) then !$acc loop vector do k=2,nVertLevels prandtl_1d_inverse(k) = prandtl_inv @@ -1424,16 +1501,16 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo ! test boundary conditions for supercell and les test cases - if( config_les_surface == "specified" .or. config_les_surface == "varying" ) then + if( les_surface_opt == LES_SURFACE_SPECIFIED .or. les_surface_opt == LES_SURFACE_VARYING ) then - if( config_les_surface == "specified" ) then + if( les_surface_opt == LES_SURFACE_SPECIFIED ) then moisture_flux = config_surface_moisture_flux heat_flux = config_surface_heat_flux ! place holder routine for time-varying specified ! call flux_les_sas( heat_flux, moisture_flux, clock, dt ) - else if ( config_les_surface == "varying" ) then + else if ( les_surface_opt == LES_SURFACE_VARYING ) then heat_flux = hfx(iCell)/rho_zz(1,iCell)/cp moisture_flux = qfx(iCell)/rho_zz(1,iCell) endif @@ -1484,7 +1561,7 @@ subroutine scalar_dissipation_3d_les( cellStart, cellEnd, cellSolveStart, cellSo end do end do - if( config_les_surface == "specified" .or. config_les_surface == "varying" ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv + if( les_surface_opt == LES_SURFACE_SPECIFIED .or. les_surface_opt == LES_SURFACE_VARYING ) turb_vflux_scalars(index_qv,1) = moisture_flux ! lower b.c. for qv !$acc loop vector collapse(2) do k=1,nVertLevels diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 4307dca8f0..644963c3e6 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -4791,6 +4791,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + use mpas_atm_dissipation_models, only : les_model_from_string, les_surface_from_string + implicit none ! @@ -4868,6 +4870,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys character (len=StrKIND), pointer :: config_horiz_mixing character (len=StrKIND), pointer :: config_les_model character (len=StrKIND), pointer :: config_les_surface + integer :: les_model_opt, les_surface_opt real (kind=RKIND), pointer :: config_surface_heat_flux real (kind=RKIND), pointer :: config_surface_moisture_flux real (kind=RKIND), pointer :: config_surface_drag_coefficient @@ -5052,6 +5055,9 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys call mpas_pool_get_array(mesh, 'cf2', cf2) call mpas_pool_get_array(mesh, 'cf3', cf3) + les_model_opt = les_model_from_string(config_les_model) + les_surface_opt = les_surface_from_string(config_les_surface) + call atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels, & nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, index_qv, index_qc, moist_start, moist_end, & tend_scalars, & @@ -5066,8 +5072,8 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, diag_phys 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, & deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & - tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_mix_scalars, config_horiz_mixing, config_les_model, & - config_les_surface, prandtl_3d_inv, config_del4u_div_factor, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_mix_scalars, config_horiz_mixing, les_model_opt, & + les_surface_opt, prandtl_3d_inv, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dynamics_substep, dt, & config_mpas_cam_coef, & @@ -5101,8 +5107,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm 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, & deformation_coef_c2,deformation_coef_s2,deformation_coef_cs,deformation_coef_c,deformation_coef_s, & - tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_mix_scalars, config_horiz_mixing, config_les_model, & - config_les_surface, prandtl_3d_inv, config_del4u_div_factor, & + tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_mix_scalars, config_horiz_mixing, les_model_opt, & + les_surface_opt, prandtl_3d_inv, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dynamics_substep, dt, & config_mpas_cam_coef, & @@ -5115,6 +5121,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm use mpas_atm_dimensions + use mpas_atm_dissipation_models, only : LES_MODEL_NONE implicit none @@ -5225,8 +5232,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: coef_3rd_order, c_s logical :: config_mix_full, config_mix_scalars character (len=StrKIND) :: config_horiz_mixing - character (len=StrKIND) :: config_les_model - character (len=StrKIND) :: config_les_surface + integer, intent(in) :: les_model_opt + integer, intent(in) :: les_surface_opt real (kind=RKIND) :: config_surface_heat_flux real (kind=RKIND) :: config_surface_moisture_flux real (kind=RKIND) :: config_surface_drag_coefficient @@ -5297,7 +5304,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (perturbation_coriolis) then !$acc enter data copyin(u_init, v_init) end if - if (trim(config_les_model) /= 'none') then + if (les_model_opt /= LES_MODEL_NONE) then !$acc enter data copyin(exner, pressure_b, bn2) end if !$acc enter data copyin(ustm, hfx, qfx) @@ -5333,7 +5340,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc enter data copyin(rw_save, rt_diabatic_tend) !$acc enter data create(rthdynten) !$acc enter data copyin(t_init) - if (trim(config_les_model) /= 'none') then + if (les_model_opt /= LES_MODEL_NONE) then !$acc enter data copyin(ur_cell, vr_cell) else #ifdef CURVATURE @@ -5369,7 +5376,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm ! Smagorinsky eddy viscosity, based on horizontal deformation (in this case on model coordinate surfaces). ! The integration coefficients were precomputed and stored in deformation_coef_* - if(config_les_model == "none") then + if(les_model_opt == LES_MODEL_NONE) then if(config_horiz_mixing == "2d_smagorinsky") then @@ -5396,14 +5403,14 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end if - else if (config_les_model /= "none") then + else if (les_model_opt /= LES_MODEL_NONE) then ! call mpas_log_write(' BV call, index qv, qc, tke $i $i $i ', intArgs=(/index_qv, index_qc, index_tke/)) call calculate_n2( bn2, theta_m, exner, pressure_b, pp, zgrid, scalars, index_qv, index_qc, qtot, & cellStart, cellEnd, nCells) - call les_models( config_les_model, config_les_surface, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & + call les_models( les_model_opt, les_surface_opt, dynamics_substep, eddy_visc_horz, eddy_visc_vert, & u, v, ur_cell, vr_cell, & w, c_s, bn2, zgrid, config_len_disp, & deformation_coef_c2, deformation_coef_s2, deformation_coef_cs, & @@ -5620,7 +5627,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm config_mix_full, h_mom_eddy_visc4, v_mom_eddy_visc2, & config_del4u_div_factor, zgrid, & eddy_visc_horz, eddy_visc_vert, zz, rdzu, rdzw, & - fzm, fzp, config_les_model, config_les_surface, & + fzm, fzp, les_model_opt, les_surface_opt, & config_surface_drag_coefficient, & delsq_u, delsq_vorticity, delsq_divergence, & u, v, divergence, vorticity, rho_edge, rho_zz, u_init, v_init, ustm, tend_u_euler ) @@ -5762,7 +5769,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm delsq_w, & w, rho_edge, rho_zz, divergence, zz, & eddy_visc_horz, eddy_visc_vert, & - config_les_model, config_les_surface, & + les_model_opt, les_surface_opt, & tend_w_euler ) end if ! mixing for w computed in first rk_step @@ -5922,7 +5929,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm eddy_visc_horz, eddy_visc_vert, & bn2, config_len_disp, scalars, tend_scalars, & index_tke, index_qv, num_scalars, config_mix_scalars, & - config_les_model, config_les_surface, clock, dt, & + les_model_opt, les_surface_opt, clock, dt, & config_surface_heat_flux, config_surface_moisture_flux, & ur_cell, vr_cell, & hfx, qfx, & @@ -5982,7 +5989,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm if (perturbation_coriolis) then !$acc exit data delete(u_init, v_init) end if - if (trim(config_les_model) /= 'none') then + if (les_model_opt /= LES_MODEL_NONE) then !$acc exit data delete(exner, pressure_b) !$acc exit data copyout(bn2) end if @@ -6019,7 +6026,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$acc exit data delete(rw_save, rt_diabatic_tend) !$acc exit data copyout(rthdynten) !$acc exit data delete(t_init) - if (trim(config_les_model) /= 'none') then + if (les_model_opt /= LES_MODEL_NONE) then !$acc exit data delete(ur_cell, vr_cell) else #ifdef CURVATURE From 27c8b388688183364cffaa647e74565bec204c9d Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 24 Feb 2026 17:48:48 -0700 Subject: [PATCH 108/109] Revert init_atm_case_squall_line routine to v8.3.1 This commit reverts all changes to the init_atm_case_squall_line routine since the v8.3.1 tag. These changes are not strictly necessary to the initial LES capability, and for the present, the initialization case 10 (init_atm_case_les) is the only supported test case for use with LES options. --- .../mpas_init_atm_cases.F | 27 +++---------------- 1 file changed, 3 insertions(+), 24 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 9c372cb163..02b8391dbf 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -1429,11 +1429,10 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d integer, dimension(:), pointer :: nEdgesOnEdge integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge - real (kind=RKIND), pointer :: x_period, y_period + integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, nz1, itr, cell1, cell2 integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve integer, pointer :: index_qv - integer, pointer :: index_tke real (kind=RKIND), dimension(nVertLevels + 1 ) :: zc, zw, ah real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm @@ -1460,7 +1459,6 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d real (kind=RKIND), pointer :: nominalMinDc logical, pointer :: on_a_sphere real (kind=RKIND), pointer :: sphere_radius - real (kind=RKIND), pointer :: config_ztop real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta real (kind=RKIND), dimension(:), pointer :: u_init, qv_init, angleEdge, fEdge, fVertex @@ -1482,13 +1480,10 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) - - call mpas_pool_get_config(mesh, 'x_period', x_period) - call mpas_pool_get_config(mesh, 'y_period', y_period) + call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) call mpas_pool_get_config(configs, 'config_interface_projection', config_interface_projection) - call mpas_pool_get_config(configs, 'config_ztop', config_ztop) ! ! Scale all distances @@ -1511,8 +1506,6 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d areaTriangle(:) = areaTriangle(:) * a_scale**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 nominalMinDc = nominalMinDc * a_scale - x_period = x_period * a_scale - y_period = y_period * a_scale call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) @@ -1573,7 +1566,6 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d call mpas_pool_get_array(state, 'scalars', scalars) call mpas_pool_get_dimension(state, 'index_qv', index_qv) - call mpas_pool_get_dimension(state, 'index_tke', index_tke) scalars(:,:,:) = 0. @@ -1601,8 +1593,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d ! metrics for hybrid coordinate and vertical stretching str = 1.0 -! zt = 20000. - zt = config_ztop + zt = 20000. dz = zt/float(nz1) ! write(0,*) ' dz = ',dz @@ -1889,18 +1880,6 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i)) end do end do -! -! initial seed for tke -! -! call mpas_log_write('index_qv $i ', intArgs=(/index_qv/)) -! call mpas_log_write('index_tke $i ', intArgs=(/index_tke/)) - scalars(index_tke,:,:) = 0. - - do k = 1,nz1 - do i=1,nCells - scalars(index_tke,k,i) = 0.1 - end do - end do do itr=1,30 From e9d81de891bb9c22b0fd61452c6638a827f836f1 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Tue, 24 Feb 2026 17:54:36 -0700 Subject: [PATCH 109/109] Revert the init_atm_case_mtn_wave routine to v8.3.1 This commit reverts all changes to the init_atm_case_mtn_wave routine since the v8.3.1 tag. These changes are not strictly necessary to the initial LES capability, and they can be re-introduced separately in future. --- src/core_init_atmosphere/mpas_init_atm_cases.F | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 02b8391dbf..2629e9972d 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -2034,7 +2034,6 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag integer, dimension(:), pointer :: nEdgesOnEdge, nEdgesOnCell integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge, cellsOnCell real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge - real (kind=RKIND), pointer :: x_period, y_period integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, itr, cell1, cell2, nz1 integer, pointer :: nEdges, maxEdges, nCellsSolve, nVertices @@ -2093,8 +2092,6 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) - call mpas_pool_get_config(mesh, 'x_period', x_period) - call mpas_pool_get_config(mesh, 'y_period', y_period) call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) @@ -2136,8 +2133,6 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag areaTriangle(:) = areaTriangle(:) * a_scale**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 nominalMinDc = nominalMinDc * a_scale - x_period = x_period * a_scale - y_period = y_period * a_scale call mpas_pool_get_dimension(mesh, 'nEdges', nEdges)