From 576fafbf26c577ec61c5427b4d2e91948fae5205 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Wed, 4 Sep 2019 14:48:18 -0600 Subject: [PATCH 001/103] Initial commit for implementing near-surface mixing First stab at parameterizing the diabatic mixing by mesoscale eddies using a 'bulk layer' approach. Added a simple unit test where column thickness is exactly equal to the boundary layer depth, equal, layer thicknesses, and the tracer gradient points from right to left. Go Gustavo and Andrew --- src/tracer/MOM_surface_mixing.F90 | 193 ++++++++++++++++++++++++++++++ 1 file changed, 193 insertions(+) create mode 100644 src/tracer/MOM_surface_mixing.F90 diff --git a/src/tracer/MOM_surface_mixing.F90 b/src/tracer/MOM_surface_mixing.F90 new file mode 100644 index 0000000000..4401b6749d --- /dev/null +++ b/src/tracer/MOM_surface_mixing.F90 @@ -0,0 +1,193 @@ +!> A column-wise toolbox for implementing neutral diffusion +module MOM_surface_mixing + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_diag_mediator, only : post_data, register_diag_field +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_grid, only : ocean_grid_type +use MOM_remapping, only : remapping_CS, initialize_remapping +use MOM_remapping, only : extract_member_remapping_CS, build_reconstructions_1d +use MOM_remapping, only : average_value_ppoly, remappingSchemesDoc, remappingDefaultScheme +use MOM_tracer_registry, only : tracer_registry_type, tracer_type +use MOM_verticalGrid, only : verticalGrid_type +use polynomial_functions, only : evaluation_polynomial, first_derivative_polynomial +use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation +use regrid_edge_values, only : edge_values_implicit_h4 + +implicit none ; private + +#include +contains + +!< Calculate bulk layer value of a scalar quantity as the thickness weighted average +real function bulk_average(h, hBLT, phi) + real, dimension(:), intent(in) :: h !< Layer thicknesses [m] + real , intent(in) :: hBLT !< Depth of the mixing layer [m] + real, dimension(:), intent(in) :: phi !< Scalar quantity + ! Local variables + integer :: nk ! Number of layers + real :: htot ! Running sum of the thicknesses (top to bottom) + integer :: k + + ! if ( len(h) .ne. len(phi ) call MOM_error(FATAL,"surface_mixing: tracer and thicknesses of different size") + nk = SIZE(h) + + htot = 0. + bulk_average = 0. + do k = 1,nk + bulk_average = bulk_average + phi(k)*h(k) + htot = htot + h(k) + enddo + + if (htot > 0.) then + bulk_average = bulk_average / hBLT + else + call MOM_error(FATAL, "Column thickness is 0.") + endif + +end function bulk_average + +!> Calculate the harmonic mean of two quantities +real function harmonic_mean(h1,h2) + real :: h1 !< Scalar quantity + real :: h2 !< Scalar quantity + + harmonic_mean = (h1*h2)/(h1+h2) +end function harmonic_mean + +!> Calculate the near-surface diffusive fluxes calculated from a 'bulk model' +subroutine layer_fluxes_bulk_method(nk, h_L, h_R, phi_L, phi_R, hBLT_L, hBLT_R, khtr_u, F_layer) + integer , intent(in ) :: nk !< Number of layers [nondim] + real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [m] + real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [m] + real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [ nondim m^-3 ] + real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [ nondim m^-3 ] + real , intent(in ) :: hBLT_L !< Depth of the boundary layer (left) [m] + real , intent(in ) :: hBLT_R !< Depth of the boundary layer (right) [m] + real, dimension(nk), intent(in ) :: khtr_u !< Horizontal diffusivities at U-point [m^2 s^-1] + real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [tracer_units s^-1] + ! Local variables + real :: F_bulk ! Total diffusive flux across the U point [nondim s^-1] + real, dimension(nk) :: h_means ! Calculate the layer-wise harmonic means [m] + real, dimension(nk) :: h_u ! Thickness at the u-point [m] + real :: hblt_u ! Boundary layer Thickness at the u-point [m] + real :: khtr_avg ! Thickness-weighted diffusivity at the u-point [m^2 s^-1] + real :: heff ! Harmonic mean of layer thicknesses [m] + real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] + real :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) + ! [ nondim m^-3 ] + integer :: k + ! Calculate bulk averages of various quantities + phi_L_avg = bulk_average(h_L, hBLT_L, phi_L) + phi_R_avg = bulk_average(h_R, hBLT_R, phi_R) + do k=1,nk + h_u(k) = 0.5 * (h_L(k) + h_R(k)) + enddo + hblt_u = 0.5*(hBLT_L + hBLT_R) + khtr_avg = bulk_average(h_u, hBLT_u, khtr_u) + + ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities + heff = (hBLT_L*hBLT_R)/(hBLT_L+hBLT_R) + F_bulk = (khtr_avg * heff) * (phi_R_avg - phi_L_avg) + + ! Calculate the layerwise sum of the vertical effective thickness. This is different than the heff calculated + ! above, but is used as a way to decompose decompose the fluxes onto the individual layers + do k=1,nk + h_means(k) = harmonic_mean(h_L(k),h_R(k)) + enddo + inv_heff = 1./SUM(h_means) + do k=1,nk + F_layer(k) = F_bulk * (h_means(k)*inv_heff) + enddo + +end subroutine layer_fluxes_bulk_method + +!> Unit tests for near-surface horizontal mixing +logical function near_surface_unit_tests( verbose ) + logical, intent(in) :: verbose !< If true, output additional information for debugging unit tests + + ! Local variables + integer, parameter :: nk = 2 ! Number of layers + real, dimension(nk) :: phi_L, phi_R ! Tracer values (left and right column) [ nondim m^-3 ] + real, dimension(nk) :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) + ! [ nondim m^-3 ] + real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] + real, dimension(nk) :: khtr_u ! Horizontal diffusivities at U-point [m^2 s^-1] + real :: hBLT_L, hBLT_R ! Depth of the boundary layer (left and right) [m] + real :: F_bulk ! Total diffusive flux across the U point [nondim s^-1] + real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [nondim s^-1] + real :: h_u, hblt_u ! Thickness at the u-point [m] + real :: khtr_avg ! Thickness-weighted diffusivity at the u-point [m^2 s^-1] + real :: heff ! Harmonic mean of layer thicknesses [m] + real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] + + ! Equal bottom boundary layer depths and same layer thicknesses (gradient from right to left) + hBLT_l = 10; hBLT_r = 10 + h_L = (/5,5/) ; h_R = (/5,5/) + phi_L = (/0,0/) ; phi_R = (/1,1/) + khtr_u = (/1,1/) + +end function near_surface_unit_tests + +!!> Returns true if output of find_neutral_surface_positions() does not match correct values, +!!! and conditionally writes results to stream +!logical function test_nsp(verbose, ns, KoL, KoR, pL, pR, hEff, KoL0, KoR0, pL0, pR0, hEff0, title) +! logical, intent(in) :: verbose !< If true, write results to stdout +! integer, intent(in) :: ns !< Number of surfaces +! integer, dimension(ns), intent(in) :: KoL !< Index of first left interface above neutral surface +! integer, dimension(ns), intent(in) :: KoR !< Index of first right interface above neutral surface +! real, dimension(ns), intent(in) :: pL !< Fractional position of neutral surface within layer KoL +! real, dimension(ns), intent(in) :: pR !< Fractional position of neutral surface within layer KoR +! real, dimension(ns-1), intent(in) :: hEff !< Effective thickness between two neutral surfaces [Pa] +! integer, dimension(ns), intent(in) :: KoL0 !< Correct value for KoL +! integer, dimension(ns), intent(in) :: KoR0 !< Correct value for KoR +! real, dimension(ns), intent(in) :: pL0 !< Correct value for pL +! real, dimension(ns), intent(in) :: pR0 !< Correct value for pR +! real, dimension(ns-1), intent(in) :: hEff0 !< Correct value for hEff +! character(len=*), intent(in) :: title !< Title for messages +! +! ! Local variables +! integer :: k, stdunit +! logical :: this_row_failed +! +! test_nsp = .false. +! do k = 1,ns +! test_nsp = test_nsp .or. compare_nsp_row(KoL(k), KoR(k), pL(k), pR(k), KoL0(k), KoR0(k), pL0(k), pR0(k)) +! if (k < ns) then +! if (hEff(k) /= hEff0(k)) test_nsp = .true. +! endif +! enddo +! +! if (test_nsp .or. verbose) then +! stdunit = 6 +! if (test_nsp) stdunit = 0 ! In case of wrong results, write to error stream +! write(stdunit,'(a)') title +! do k = 1,ns +! this_row_failed = compare_nsp_row(KoL(k), KoR(k), pL(k), pR(k), KoL0(k), KoR0(k), pL0(k), pR0(k)) +! if (this_row_failed) then +! write(stdunit,10) k,KoL(k),pL(k),KoR(k),pR(k),' <-- WRONG!' +! write(stdunit,10) k,KoL0(k),pL0(k),KoR0(k),pR0(k),' <-- should be this' +! else +! write(stdunit,10) k,KoL(k),pL(k),KoR(k),pR(k) +! endif +! if (k < ns) then +! if (hEff(k) /= hEff0(k)) then +! write(stdunit,'(i3,8x,"layer hEff =",2(f20.16,a))') k,hEff(k)," .neq. ",hEff0(k),' <-- WRONG!' +! else +! write(stdunit,'(i3,8x,"layer hEff =",f20.16)') k,hEff(k) +! endif +! endif +! enddo +! endif +! if (test_nsp) call MOM_error(FATAL,"test_nsp failed") +! +!10 format("ks=",i3," kL=",i3," pL=",f20.16," kR=",i3," pR=",f20.16,a) +!end function test_nsp + +end module MOM_surface_mixing From 654a12c603b1f96318bec801d084dbbe01a6cfd1 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Sun, 8 Sep 2019 20:31:57 -0600 Subject: [PATCH 002/103] Add additional unit tests for bulk method Add more complex unit tests and begin work on improving the algorithm to deal with cases where the boundary layer intersects within a layer. --- .../{MOM_surface_mixing.F90 => MOM_boundary_lateral_mixing.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/tracer/{MOM_surface_mixing.F90 => MOM_boundary_lateral_mixing.F90} (100%) diff --git a/src/tracer/MOM_surface_mixing.F90 b/src/tracer/MOM_boundary_lateral_mixing.F90 similarity index 100% rename from src/tracer/MOM_surface_mixing.F90 rename to src/tracer/MOM_boundary_lateral_mixing.F90 From 838523136db96ff838e75b6ad467a1036855f530 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 9 Sep 2019 16:21:21 -0600 Subject: [PATCH 003/103] Add function and unit tests for boundary layer mixing For the near-boundary lateral mixing, the indices of the layers that are spanned by the boundary layer need to be returned. Additionally, in cases where the boundary layer intersects partway through a layer, the non-dimensional position also needs to be returned for polynomial reconstructions to be evaluated correctly. Six unit tests were added to test this new function. All unit tests currently pass --- src/core/MOM_unit_tests.F90 | 12 +- src/tracer/MOM_boundary_lateral_mixing.F90 | 403 +++++++++++++++------ 2 files changed, 309 insertions(+), 106 deletions(-) diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index ff5a93a62c..24e93ed1ed 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -5,10 +5,11 @@ module MOM_unit_tests use MOM_error_handler, only : MOM_error, FATAL, is_root_pe -use MOM_string_functions, only : string_functions_unit_tests -use MOM_remapping, only : remapping_unit_tests -use MOM_neutral_diffusion, only : neutral_diffusion_unit_tests -use MOM_diag_vkernels, only : diag_vkernels_unit_tests +use MOM_string_functions, only : string_functions_unit_tests +use MOM_remapping, only : remapping_unit_tests +use MOM_neutral_diffusion, only : neutral_diffusion_unit_tests +use MOM_diag_vkernels, only : diag_vkernels_unit_tests +use MOM_boundary_lateral_mixing, only : near_boundary_unit_tests implicit none ; private @@ -35,6 +36,9 @@ subroutine unit_tests(verbosity) "MOM_unit_tests: neutralDiffusionUnitTests FAILED") if (diag_vkernels_unit_tests(verbose)) call MOM_error(FATAL, & "MOM_unit_tests: diag_vkernels_unit_tests FAILED") + if (near_boundary_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: near_boundary_unit_tests FAILED") + endif end subroutine unit_tests diff --git a/src/tracer/MOM_boundary_lateral_mixing.F90 b/src/tracer/MOM_boundary_lateral_mixing.F90 index 4401b6749d..4ff8292403 100644 --- a/src/tracer/MOM_boundary_lateral_mixing.F90 +++ b/src/tracer/MOM_boundary_lateral_mixing.F90 @@ -1,5 +1,6 @@ -!> A column-wise toolbox for implementing neutral diffusion -module MOM_surface_mixing +!> Calculate and apply diffusive fluxes as a parameterization of lateral mixing (non-neutral) by +!! mesoscale eddies near the top and bottom boundary layers of the ocean. +module MOM_boundary_lateral_mixing ! This file is part of MOM6. See LICENSE.md for the license. @@ -17,14 +18,25 @@ module MOM_surface_mixing use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_verticalGrid, only : verticalGrid_type use polynomial_functions, only : evaluation_polynomial, first_derivative_polynomial -use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation -use regrid_edge_values, only : edge_values_implicit_h4 implicit none ; private +public near_boundary_unit_tests + +! Private parameters to avoid doing string comparisons for bottom or top boundary layer +integer, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface bopundary +integer, parameter :: BOTTOM = 1 !< Set a value that corresponds to the bottom boundary + #include contains +!> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. Two different methods +!! Method 1: Calculate fluxes from bulk layer integrated quantities +subroutine boundary_lateral_mixing() + + +end subroutine + !< Calculate bulk layer value of a scalar quantity as the thickness weighted average real function bulk_average(h, hBLT, phi) real, dimension(:), intent(in) :: h !< Layer thicknesses [m] @@ -35,7 +47,7 @@ real function bulk_average(h, hBLT, phi) real :: htot ! Running sum of the thicknesses (top to bottom) integer :: k - ! if ( len(h) .ne. len(phi ) call MOM_error(FATAL,"surface_mixing: tracer and thicknesses of different size") + ! if ( len(h) .ne. len(phi ) call MOM_error(FATAL,"boundary_mixing: tracer and thicknesses of different size") nk = SIZE(h) htot = 0. @@ -58,43 +70,103 @@ real function harmonic_mean(h1,h2) real :: h1 !< Scalar quantity real :: h2 !< Scalar quantity - harmonic_mean = (h1*h2)/(h1+h2) + harmonic_mean = 2.*(h1*h2)/(h1+h2) end function harmonic_mean -!> Calculate the near-surface diffusive fluxes calculated from a 'bulk model' -subroutine layer_fluxes_bulk_method(nk, h_L, h_R, phi_L, phi_R, hBLT_L, hBLT_R, khtr_u, F_layer) - integer , intent(in ) :: nk !< Number of layers [nondim] - real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [m] - real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [m] - real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [ nondim m^-3 ] - real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [ nondim m^-3 ] - real , intent(in ) :: hBLT_L !< Depth of the boundary layer (left) [m] - real , intent(in ) :: hBLT_R !< Depth of the boundary layer (right) [m] - real, dimension(nk), intent(in ) :: khtr_u !< Horizontal diffusivities at U-point [m^2 s^-1] - real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [tracer_units s^-1] +!> Find the k-index range corresponding to the layers that are within the boundary-layer region +subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_bot) + integer, intent(in ) :: boundary !< SURFACE or BOTTOM [nondim] + integer, intent(in ) :: nk !< Number of layers [nondim] + real, dimension(nk), intent(in ) :: h !< Layer thicknesses of the coluymn [m] + real, intent(in ) :: hbl !< Thickness of the boundary layer [m] + !! If surface, with respect to zbl_ref = 0. + !! If bottom, with respect to zbl_ref = SUM(h) + integer, intent( out) :: k_top !< Index of the first layer within the boundary + real, intent( out) :: zeta_top !< Distance from the top of a layer to the intersection of the + !! top extent of the boundary layer (0 at top, 1 at bottom) [nondim] + integer, intent( out) :: k_bot !< Index of the last layer within the boundary + real, intent( out) :: zeta_bot !< Distance of the lower layer to the boundary layer depth + !! (0 at top, 1 at bottom) [nondim] + ! Local variables + real :: htot + integer :: k + ! Surface boundary layer + if ( boundary == SURFACE ) then + k_top = 1 + zeta_top = 0. + htot = 0. + do k=1,nk + htot = htot + h(k) + if ( htot >= hbl) then + k_bot = k + zeta_bot = 1 - (htot - hbl)/h(k) + return + endif + enddo + ! Bottom boundary layer + elseif ( boundary == BOTTOM ) then + k_bot = nk + zeta_bot = 1. + htot = 0. + do k=nk,1,-1 + htot = htot + h(k) + if (htot >= hbl) then + k_top = k + zeta_top = 1 - (htot - hbl)/h(k) + return + endif + enddo + else + call MOM_error(FATAL,"Houston, we've had a problem in boundary_k_range") + endif + +end subroutine boundary_k_range + +!> Calculate the near-boundary diffusive fluxes calculated from a 'bulk model' +subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R, & + khtr_u, F_layer) + integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + integer, intent(in ) :: nk !< Number of layers [nondim] + integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] + real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [m] + real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [m] + real, intent(in ) :: hbl_L !< Thickness of the boundary boundary + !! layer (left) [m] + real, intent(in ) :: hbl_R !< Thickness of the boundary boundary + !! layer (left) [m] + real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [ nondim m^-3 ] + real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [ nondim m^-3 ] + real, dimension(nk,deg+1), intent(in ) :: phi_pp_L !< Tracer reconstruction (left) [ nondim m^-3 ] + real, dimension(nk,deg+1), intent(in ) :: phi_pp_R !< Tracer reconstruction (right) [ nondim m^-3 ] + real, dimension(nk), intent(in ) :: khtr_u !< Horizontal diffusivities at U-point [m^2 s^-1] + real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [trunit s^-1] ! Local variables - real :: F_bulk ! Total diffusive flux across the U point [nondim s^-1] + real :: F_bulk ! Total diffusive flux across the U point [trunit s^-1] real, dimension(nk) :: h_means ! Calculate the layer-wise harmonic means [m] real, dimension(nk) :: h_u ! Thickness at the u-point [m] - real :: hblt_u ! Boundary layer Thickness at the u-point [m] + real :: hbl_u ! Boundary layer Thickness at the u-point [m] real :: khtr_avg ! Thickness-weighted diffusivity at the u-point [m^2 s^-1] real :: heff ! Harmonic mean of layer thicknesses [m] real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] real :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) - ! [ nondim m^-3 ] + ! [trunit m^-3 ] + real :: htot ! Total column thickness [m] integer :: k + integer :: k_top_L, k_bot_L + integer :: k_top_R, k_bot_R + ! Calculate bulk averages of various quantities - phi_L_avg = bulk_average(h_L, hBLT_L, phi_L) - phi_R_avg = bulk_average(h_R, hBLT_R, phi_R) + phi_L_avg = bulk_average(h_L, hbl_L, phi_L) + phi_R_avg = bulk_average(h_R, hbl_R, phi_R) do k=1,nk h_u(k) = 0.5 * (h_L(k) + h_R(k)) enddo - hblt_u = 0.5*(hBLT_L + hBLT_R) - khtr_avg = bulk_average(h_u, hBLT_u, khtr_u) + hbl_u = 0.5*(hbl_L + hbl_R) + khtr_avg = bulk_average(h_u, hbl_u, khtr_u) ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities - heff = (hBLT_L*hBLT_R)/(hBLT_L+hBLT_R) - F_bulk = (khtr_avg * heff) * (phi_R_avg - phi_L_avg) + heff = harmonic_mean(hbl_L, hbl_R) + F_bulk = -(khtr_avg * heff) * (phi_R_avg - phi_L_avg) ! Calculate the layerwise sum of the vertical effective thickness. This is different than the heff calculated ! above, but is used as a way to decompose decompose the fluxes onto the individual layers @@ -108,86 +180,213 @@ subroutine layer_fluxes_bulk_method(nk, h_L, h_R, phi_L, phi_R, hBLT_L, hBLT_R, end subroutine layer_fluxes_bulk_method -!> Unit tests for near-surface horizontal mixing -logical function near_surface_unit_tests( verbose ) +!> Unit tests for near-boundary horizontal mixing +logical function near_boundary_unit_tests( verbose ) logical, intent(in) :: verbose !< If true, output additional information for debugging unit tests ! Local variables - integer, parameter :: nk = 2 ! Number of layers - real, dimension(nk) :: phi_L, phi_R ! Tracer values (left and right column) [ nondim m^-3 ] - real, dimension(nk) :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) - ! [ nondim m^-3 ] - real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] - real, dimension(nk) :: khtr_u ! Horizontal diffusivities at U-point [m^2 s^-1] - real :: hBLT_L, hBLT_R ! Depth of the boundary layer (left and right) [m] - real :: F_bulk ! Total diffusive flux across the U point [nondim s^-1] - real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [nondim s^-1] - real :: h_u, hblt_u ! Thickness at the u-point [m] - real :: khtr_avg ! Thickness-weighted diffusivity at the u-point [m^2 s^-1] - real :: heff ! Harmonic mean of layer thicknesses [m] - real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] + integer, parameter :: nk = 2 ! Number of layers + integer, parameter :: deg = 1 ! Degree of reconstruction (linear here) + real, dimension(nk) :: phi_L, phi_R ! Tracer values (left and right column) [ nondim m^-3 ] + real, dimension(nk) :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) + real, dimension(nk,2) :: phi_pp_L, phi_pp_R ! Coefficients for the linear pseudo-reconstructions + ! [ nondim m^-3 ] + real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] + real, dimension(nk) :: khtr_u ! Horizontal diffusivities at U-point [m^2 s^-1] + real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] + real :: F_bulk ! Total diffusive flux across the U point [nondim s^-1] + real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [nondim s^-1] + real :: h_u, hblt_u ! Thickness at the u-point [m] + real :: khtr_avg ! Thickness-weighted diffusivity at the u-point [m^2 s^-1] + real :: heff ! Harmonic mean of layer thicknesses [m] + real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] + character(len=120) :: test_name ! Title of the unit test + integer :: k_top ! Index of cell containing top of boundary + real :: zeta_top ! Nondimension position + integer :: k_bot ! Index of cell containing bottom of boundary + real :: zeta_bot ! Nondimension position - ! Equal bottom boundary layer depths and same layer thicknesses (gradient from right to left) - hBLT_l = 10; hBLT_r = 10 - h_L = (/5,5/) ; h_R = (/5,5/) - phi_L = (/0,0/) ; phi_R = (/1,1/) - khtr_u = (/1,1/) - -end function near_surface_unit_tests - -!!> Returns true if output of find_neutral_surface_positions() does not match correct values, -!!! and conditionally writes results to stream -!logical function test_nsp(verbose, ns, KoL, KoR, pL, pR, hEff, KoL0, KoR0, pL0, pR0, hEff0, title) -! logical, intent(in) :: verbose !< If true, write results to stdout -! integer, intent(in) :: ns !< Number of surfaces -! integer, dimension(ns), intent(in) :: KoL !< Index of first left interface above neutral surface -! integer, dimension(ns), intent(in) :: KoR !< Index of first right interface above neutral surface -! real, dimension(ns), intent(in) :: pL !< Fractional position of neutral surface within layer KoL -! real, dimension(ns), intent(in) :: pR !< Fractional position of neutral surface within layer KoR -! real, dimension(ns-1), intent(in) :: hEff !< Effective thickness between two neutral surfaces [Pa] -! integer, dimension(ns), intent(in) :: KoL0 !< Correct value for KoL -! integer, dimension(ns), intent(in) :: KoR0 !< Correct value for KoR -! real, dimension(ns), intent(in) :: pL0 !< Correct value for pL -! real, dimension(ns), intent(in) :: pR0 !< Correct value for pR -! real, dimension(ns-1), intent(in) :: hEff0 !< Correct value for hEff -! character(len=*), intent(in) :: title !< Title for messages -! -! ! Local variables -! integer :: k, stdunit -! logical :: this_row_failed -! -! test_nsp = .false. -! do k = 1,ns -! test_nsp = test_nsp .or. compare_nsp_row(KoL(k), KoR(k), pL(k), pR(k), KoL0(k), KoR0(k), pL0(k), pR0(k)) -! if (k < ns) then -! if (hEff(k) /= hEff0(k)) test_nsp = .true. -! endif -! enddo + near_boundary_unit_tests = .false. + + ! Unit tests for boundary_k_range + test_name = 'Surface boundary spans the entire top cell' + h_L = (/5.,5./) + call boundary_k_range(SURFACE, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 1., test_name, verbose) + + test_name = 'Surface boundary spans the entire column' + h_L = (/5.,5./) + call boundary_k_range(SURFACE, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) + + test_name = 'Bottom boundary spans the entire bottom cell' + h_L = (/5.,5./) + call boundary_k_range(BOTTOM, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0., 2, 1., test_name, verbose) + + test_name = 'Bottom boundary spans the entire column' + h_L = (/5.,5./) + call boundary_k_range(BOTTOM, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) + + test_name = 'Surface boundary intersects second layer' + h_L = (/10.,10./) + call boundary_k_range(SURFACE, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0.75, test_name, verbose) + + test_name = 'Surface boundary intersects first layer' + h_L = (/10.,10./) + call boundary_k_range(SURFACE, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 0.25, test_name, verbose) + + test_name = 'Bottom boundary intersects first layer' + h_L = (/10.,10./) + call boundary_k_range(BOTTOM, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0.75, 2, 1., test_name, verbose) + + test_name = 'Bottom boundary intersects second layer' + h_L = (/10.,10./) + call boundary_k_range(BOTTOM, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0.25, 2, 1., test_name, verbose) + + ! All cases in this section have hbl which are equal to the column thicknesses + test_name = 'Equal hbl and same layer thicknesses (gradient from right to left)' + hbl_L = 10; hbl_R = 10 + h_L = (/5.,5./) ; h_R = (/5.,5./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& + phi_pp_L, phi_pp_R, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) + + test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)' + hbl_L = 10.; hbl_R = 10. + h_L = (/5.,5./) ; h_R = (/5.,5./) + phi_L = (/1.,1./) ; phi_R = (/0.,0./) + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& + phi_pp_L, phi_pp_R, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) + + test_name = 'Equal hbl and same layer thicknesses (no gradient)' + hbl_L = 10; hbl_R = 10 + h_L = (/5.,5./) ; h_R = (/5.,5./) + phi_L = (/1.,1./) ; phi_R = (/1.,1./) + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& + phi_pp_L, phi_pp_R, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) + + test_name = 'Equal hbl and different layer thicknesses (gradient right to left)' + hbl_L = 16.; hbl_R = 16. + h_L = (/10.,6./) ; h_R = (/6.,10./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& + phi_pp_L, phi_pp_R, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) + + test_name = 'Equal hbl and same layer thicknesses (diagonal tracer values)' + hbl_L = 10.; hbl_R = 10. + h_L = (/5.,5./) ; h_R = (/5.,5./) + phi_L = (/1.,0./) ; phi_R = (/0.,1./) + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& + phi_pp_L, phi_pp_R, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) + + test_name = 'Different hbl and different column thicknesses (gradient from right to left)' + hbl_L = 12; hbl_R = 20 + h_L = (/6.,6./) ; h_R = (/10.,10./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& + phi_pp_L, phi_pp_R, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) + + test_name = 'Different hbl and different layer thicknesses (gradient from right to left)' + hbl_L = 12; hbl_R = 20 + h_L = (/6.,6./) ; h_R = (/10.,10./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& + phi_pp_L, phi_pp_R, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) ! -! if (test_nsp .or. verbose) then -! stdunit = 6 -! if (test_nsp) stdunit = 0 ! In case of wrong results, write to error stream -! write(stdunit,'(a)') title -! do k = 1,ns -! this_row_failed = compare_nsp_row(KoL(k), KoR(k), pL(k), pR(k), KoL0(k), KoR0(k), pL0(k), pR0(k)) -! if (this_row_failed) then -! write(stdunit,10) k,KoL(k),pL(k),KoR(k),pR(k),' <-- WRONG!' -! write(stdunit,10) k,KoL0(k),pL0(k),KoR0(k),pR0(k),' <-- should be this' -! else -! write(stdunit,10) k,KoL(k),pL(k),KoR(k),pR(k) -! endif -! if (k < ns) then -! if (hEff(k) /= hEff0(k)) then -! write(stdunit,'(i3,8x,"layer hEff =",2(f20.16,a))') k,hEff(k)," .neq. ",hEff0(k),' <-- WRONG!' -! else -! write(stdunit,'(i3,8x,"layer hEff =",f20.16)') k,hEff(k) -! endif -! endif -! enddo -! endif -! if (test_nsp) call MOM_error(FATAL,"test_nsp failed") +! ! Cases where hbl < column thickness (polynomial coefficients specified for pseudo-linear reconstruction) +! hbl_L = 2; hbl_R = 2 +! h_L = (/1.,2./) ; h_R = (/1.,2./) +! phi_L = (/0.,0./) ; phi_R = (/1.,1./) +! phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. +! phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. +! phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. +! phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. +! khtr_u = (/1.,1./) ! -!10 format("ks=",i3," kL=",i3," pL=",f20.16," kR=",i3," pR=",f20.16,a) -!end function test_nsp +! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R, khtr_u, F_layer) +! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) + + +end function near_boundary_unit_tests + +!> Returns true if output of near-boundary unit tests does not match correct computed values +!! and conditionally writes results to stream +logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=80), intent(in) :: test_name !< Brief description of the unit test + integer, intent(in) :: nk !< Number of layers + real, dimension(nk), intent(in) :: F_calc !< Fluxes of the unitless tracer from the algorithm [s^-1] + real, dimension(nk), intent(in) :: F_ans !< Fluxes of the unitless tracer calculated by hand [s^-1] + ! Local variables + integer :: k + integer, parameter :: stdunit = 6 + + test_layer_fluxes = .false. + do k=1,nk + if ( F_calc(k) /= F_ans(k) ) then + test_layer_fluxes = .true. + write(stdunit,*) "UNIT TEST FAILED: ", test_name + write(stdunit,10) k, F_calc(k), F_ans(k) + elseif (verbose) then + write(stdunit,10) k, F_calc(k), F_ans(k) + endif + enddo + +10 format("Layer=",i3," F_calc=",f20.16," F_ans",f20.16) +end function test_layer_fluxes + +!> Return true if output of unit tests for boundary_k_range does not match answers +logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_ans, zeta_top_ans,& + k_bot_ans, zeta_bot_ans, test_name, verbose) + integer :: k_top !< Index of cell containing top of boundary + real :: zeta_top !< Nondimension position + integer :: k_bot !< Index of cell containing bottom of boundary + real :: zeta_bot !< Nondimension position + integer :: k_top_ans !< Index of cell containing top of boundary + real :: zeta_top_ans !< Nondimension position + integer :: k_bot_ans !< Index of cell containing bottom of boundary + real :: zeta_bot_ans !< Nondimension position + character(len=80) :: test_name !< Name of the unit test + logical :: verbose !< If true always print output + + integer, parameter :: stdunit = 6 + + test_boundary_k_range = k_top .ne. k_top_ans + test_boundary_k_range = test_boundary_k_range .or. (zeta_top .ne. zeta_top_ans) + test_boundary_k_range = test_boundary_k_range .or. (k_bot .ne. k_bot_ans) + test_boundary_k_range = test_boundary_k_range .or. (zeta_bot .ne. zeta_bot_ans) + + if (test_boundary_k_range) write(stdunit,*) "UNIT TEST FAILED: ", test_name + if (test_boundary_k_range .or. verbose) then + write(stdunit,20) "k_top", k_top, "k_top_ans", k_top_ans + write(stdunit,20) "k_bot", k_bot, "k_bot_ans", k_bot_ans + write(stdunit,30) "zeta_top", zeta_top, "zeta_top_ans", zeta_top_ans + write(stdunit,30) "zeta_bot", zeta_bot, "zeta_bot_ans", zeta_bot_ans + endif + + 20 format(A,"=",i3,X,A,"=",i3) + 30 format(A,"=",f20.16,X,A,"=",f20.16) + -end module MOM_surface_mixing +end function test_boundary_k_range +end module MOM_boundary_lateral_mixing From 6677820431f5567f5f44acbe7ec6b76c6290aed0 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 10 Sep 2019 14:52:52 -0600 Subject: [PATCH 004/103] Updates layer_fluxes_bulk_method and bulk_average Many updates to allow the boundary layer to intersect a layer. Commented out some of the unit test previously added as the API has changed. These need to be revisited later. --- src/tracer/MOM_boundary_lateral_mixing.F90 | 241 ++++++++++++--------- 1 file changed, 144 insertions(+), 97 deletions(-) diff --git a/src/tracer/MOM_boundary_lateral_mixing.F90 b/src/tracer/MOM_boundary_lateral_mixing.F90 index 4ff8292403..b9c53e6655 100644 --- a/src/tracer/MOM_boundary_lateral_mixing.F90 +++ b/src/tracer/MOM_boundary_lateral_mixing.F90 @@ -17,7 +17,6 @@ module MOM_boundary_lateral_mixing use MOM_remapping, only : average_value_ppoly, remappingSchemesDoc, remappingDefaultScheme use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_verticalGrid, only : verticalGrid_type -use polynomial_functions, only : evaluation_polynomial, first_derivative_polynomial implicit none ; private @@ -38,29 +37,52 @@ subroutine boundary_lateral_mixing() end subroutine !< Calculate bulk layer value of a scalar quantity as the thickness weighted average -real function bulk_average(h, hBLT, phi) - real, dimension(:), intent(in) :: h !< Layer thicknesses [m] - real , intent(in) :: hBLT !< Depth of the mixing layer [m] - real, dimension(:), intent(in) :: phi !< Scalar quantity +real function bulk_average(boundary, h, hBLT, phi, ppoly0_E, ppoly0_coefs, method, k_top, zeta_top, k_bot, zeta_bot) + integer :: boundary !< SURFACE or BOTTOM [nondim] + integer :: nk !< Number of layers [nondim] + integer :: deg !< Degree of polynomial [nondim] + real, dimension(nk) :: h !< Layer thicknesses [m] + real :: hBLT !< Depth of the mixing layer [m] + real, dimension(nk) :: phi !< Scalar quantity + real, dimension(nk,2) :: ppoly0_E(:,:) !< Edge value of polynomial + real, dimension(nk,deg+1) :: ppoly0_coefs(:,:) !< Coefficients of polynomial + integer :: method !< Remapping scheme to use + + integer :: k_top !< Index of the first layer within the boundary + real :: zeta_top !< Distance from the top of a layer to the intersection of the + !! top extent of the boundary layer (0 at top 1 at bottom) [nondim] + integer :: k_bot !< Index of the last layer within the boundary + real :: zeta_bot !< Distance of the lower layer to the boundary layer depth + !! (0 at top, 1 at bottom) [nondim] ! Local variables - integer :: nk ! Number of layers real :: htot ! Running sum of the thicknesses (top to bottom) integer :: k - ! if ( len(h) .ne. len(phi ) call MOM_error(FATAL,"boundary_mixing: tracer and thicknesses of different size") - nk = SIZE(h) htot = 0. bulk_average = 0. - do k = 1,nk - bulk_average = bulk_average + phi(k)*h(k) - htot = htot + h(k) - enddo + if (boundary == SURFACE) then + htot = (h(k_bot) * zeta_bot) + bulk_average = average_value_ppoly( nk, phi, ppoly0_E, ppoly0_coefs, method, k_bot, 0., zeta_bot) * htot + do k = kbot-1,1,-1 + bulk_average = bulk_average + phi(k)*h(k) + htot = htot + h(k) + enddo + elseif (boundary == BOTTOM) then + htot = (h(k_top) * zeta_top) + bulk_average = average_value_ppoly( nk, phi, ppoly0_E, ppoly0_coefs, method, k_top, zeta_top, 1.) * htot + do k = k_top+1,nk + bulk_average = bulk_average + phi(k)*h(k) + htot = htot + h(k) + enddo + else + call MOM_error(FATAL, "bulk_average: a valid boundary type must be provided.") + endif if (htot > 0.) then bulk_average = bulk_average / hBLT else - call MOM_error(FATAL, "Column thickness is 0.") + bulk_average = 0. endif end function bulk_average @@ -123,21 +145,24 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b end subroutine boundary_k_range !> Calculate the near-boundary diffusive fluxes calculated from a 'bulk model' -subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R, & - khtr_u, F_layer) +subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, ppoly0_coefs_R, & + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [m] real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [m] real, intent(in ) :: hbl_L !< Thickness of the boundary boundary - !! layer (left) [m] + !! layer (left) [m] real, intent(in ) :: hbl_R !< Thickness of the boundary boundary !! layer (left) [m] real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [ nondim m^-3 ] real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [ nondim m^-3 ] - real, dimension(nk,deg+1), intent(in ) :: phi_pp_L !< Tracer reconstruction (left) [ nondim m^-3 ] - real, dimension(nk,deg+1), intent(in ) :: phi_pp_R !< Tracer reconstruction (right) [ nondim m^-3 ] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [ nondim m^-3 ] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [ nondim m^-3 ] + real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [ nondim ] + real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] + integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] real, dimension(nk), intent(in ) :: khtr_u !< Horizontal diffusivities at U-point [m^2 s^-1] real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [trunit s^-1] ! Local variables @@ -152,17 +177,35 @@ subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, p ! [trunit m^-3 ] real :: htot ! Total column thickness [m] integer :: k - integer :: k_top_L, k_bot_L - integer :: k_top_R, k_bot_R - + integer :: k_top_L, k_bot_L, k_top_u + integer :: k_top_R, k_bot_R, k_bot_u + real :: zeta_top_L, zeta_top_R, zeta_top_u + real :: zeta_bot_L, zeta_bot_R, zeta_bot_u + + ! Calculate vertical indices containing the boundary layer + call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) + call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) + ! Calculate bulk averages of various quantities - phi_L_avg = bulk_average(h_L, hbl_L, phi_L) - phi_R_avg = bulk_average(h_R, hbl_R, phi_R) + phi_L_avg = bulk_average(boundary, h_L, hbl_L, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, zeta_top_L, + k_bot_L, zeta_bot_L) + phi_R_avg = bulk_average(boundary, h_R, hbl_R, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, zeta_top_R, + k_bot_R, zeta_bot_R) do k=1,nk h_u(k) = 0.5 * (h_L(k) + h_R(k)) enddo + hbl_u = 0.5*(hbl_L + hbl_R) - khtr_avg = bulk_average(h_u, hbl_u, khtr_u) + + call boundary_k_range(boundary, nk, h_u, hbl_u, k_top_u, zeta_top_u, k_bot_u, zeta_bot_u) + + khtr_avg = (h_u(k_bot) * zeta_bot) * khtr_u(k_bot) + + do k=k_bot,1,-1 + khtr_avg = khtr_avg + h_u(k) * khtr_u(k) + enddo + + khtr_avg = khtr_avg / hbl_u ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities heff = harmonic_mean(hbl_L, hbl_R) @@ -249,84 +292,88 @@ logical function near_boundary_unit_tests( verbose ) call boundary_k_range(BOTTOM, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0.25, 2, 1., test_name, verbose) - ! All cases in this section have hbl which are equal to the column thicknesses - test_name = 'Equal hbl and same layer thicknesses (gradient from right to left)' - hbl_L = 10; hbl_R = 10 - h_L = (/5.,5./) ; h_R = (/5.,5./) - phi_L = (/0.,0./) ; phi_R = (/1.,1./) - khtr_u = (/1.,1./) - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& - phi_pp_L, phi_pp_R, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) - - test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)' - hbl_L = 10.; hbl_R = 10. - h_L = (/5.,5./) ; h_R = (/5.,5./) - phi_L = (/1.,1./) ; phi_R = (/0.,0./) - khtr_u = (/1.,1./) - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& - phi_pp_L, phi_pp_R, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) - - test_name = 'Equal hbl and same layer thicknesses (no gradient)' - hbl_L = 10; hbl_R = 10 - h_L = (/5.,5./) ; h_R = (/5.,5./) - phi_L = (/1.,1./) ; phi_R = (/1.,1./) - khtr_u = (/1.,1./) - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& - phi_pp_L, phi_pp_R, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) - - test_name = 'Equal hbl and different layer thicknesses (gradient right to left)' - hbl_L = 16.; hbl_R = 16. - h_L = (/10.,6./) ; h_R = (/6.,10./) - phi_L = (/0.,0./) ; phi_R = (/1.,1./) - khtr_u = (/1.,1./) - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& - phi_pp_L, phi_pp_R, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) - - test_name = 'Equal hbl and same layer thicknesses (diagonal tracer values)' - hbl_L = 10.; hbl_R = 10. - h_L = (/5.,5./) ; h_R = (/5.,5./) - phi_L = (/1.,0./) ; phi_R = (/0.,1./) - khtr_u = (/1.,1./) - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& - phi_pp_L, phi_pp_R, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) - - test_name = 'Different hbl and different column thicknesses (gradient from right to left)' - hbl_L = 12; hbl_R = 20 - h_L = (/6.,6./) ; h_R = (/10.,10./) - phi_L = (/0.,0./) ; phi_R = (/1.,1./) - khtr_u = (/1.,1./) - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& - phi_pp_L, phi_pp_R, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) - - test_name = 'Different hbl and different layer thicknesses (gradient from right to left)' - hbl_L = 12; hbl_R = 20 - h_L = (/6.,6./) ; h_R = (/10.,10./) - phi_L = (/0.,0./) ; phi_R = (/1.,1./) - khtr_u = (/1.,1./) - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& - phi_pp_L, phi_pp_R, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) +! ! All cases in this section have hbl which are equal to the column thicknesses +! test_name = 'Equal hbl and same layer thicknesses (gradient from right to left)' +! hbl_L = 10; hbl_R = 10 +! h_L = (/5.,5./) ; h_R = (/5.,5./) +! phi_L = (/0.,0./) ; phi_R = (/1.,1./) +! khtr_u = (/1.,1./) +! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& +! phi_pp_L, phi_pp_R, khtr_u, F_layer) +! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) +! +! test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)' +! hbl_L = 10.; hbl_R = 10. +! h_L = (/5.,5./) ; h_R = (/5.,5./) +! phi_L = (/1.,1./) ; phi_R = (/0.,0./) +! khtr_u = (/1.,1./) +! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& +! phi_pp_L, phi_pp_R, khtr_u, F_layer) +! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) +! +! test_name = 'Equal hbl and same layer thicknesses (no gradient)' +! hbl_L = 10; hbl_R = 10 +! h_L = (/5.,5./) ; h_R = (/5.,5./) +! phi_L = (/1.,1./) ; phi_R = (/1.,1./) +! khtr_u = (/1.,1./) +! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& +! phi_pp_L, phi_pp_R, khtr_u, F_layer) +! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) +! +! test_name = 'Equal hbl and different layer thicknesses (gradient right to left)' +! hbl_L = 16.; hbl_R = 16. +! h_L = (/10.,6./) ; h_R = (/6.,10./) +! phi_L = (/0.,0./) ; phi_R = (/1.,1./) +! khtr_u = (/1.,1./) +! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& +! phi_pp_L, phi_pp_R, khtr_u, F_layer) +! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) +! +! test_name = 'Equal hbl and same layer thicknesses (diagonal tracer values)' +! hbl_L = 10.; hbl_R = 10. +! h_L = (/5.,5./) ; h_R = (/5.,5./) +! phi_L = (/1.,0./) ; phi_R = (/0.,1./) +! khtr_u = (/1.,1./) +! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& +! phi_pp_L, phi_pp_R, khtr_u, F_layer) +! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) ! -! ! Cases where hbl < column thickness (polynomial coefficients specified for pseudo-linear reconstruction) -! hbl_L = 2; hbl_R = 2 -! h_L = (/1.,2./) ; h_R = (/1.,2./) +! test_name = 'Different hbl and different column thicknesses (gradient from right to left)' +! hbl_L = 12; hbl_R = 20 +! h_L = (/6.,6./) ; h_R = (/10.,10./) ! phi_L = (/0.,0./) ; phi_R = (/1.,1./) -! phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. -! phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. -! phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. -! phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. ! khtr_u = (/1.,1./) +! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& +! phi_pp_L, phi_pp_R, khtr_u, F_layer) +! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) ! -! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R, khtr_u, F_layer) +! test_name = 'Different hbl and different layer thicknesses (gradient from right to left)' +! hbl_L = 12; hbl_R = 20 +! h_L = (/6.,6./) ; h_R = (/10.,10./) +! phi_L = (/0.,0./) ; phi_R = (/1.,1./) +! khtr_u = (/1.,1./) +! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& +! phi_pp_L, phi_pp_R, khtr_u, F_layer) ! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) - - +! + ! Cases where hbl < column thickness (polynomial coefficients specified for pseudo-linear reconstruction) + hbl_L = 2; hbl_R = 2 + h_L = (/1.,2./) ; h_R = (/1.,2./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + khtr_u = (/1.,1./) + ppoly0_E_L(1,1) = 0; ppoly0_E_L(1,2) = 0 + ppoly0_E_L(2,1) = 0; ppoly0_E_L(2,2) = 0 + ppoly0_E_R(1,1) = 1; ppoly0_E_R(1,2) = 1 + ppoly0_E_R(2,1) = 1; ppoly0_E_R(2,2) = 1 + method = 1 + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, ppoly0_coefs_R, & + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) end function near_boundary_unit_tests !> Returns true if output of near-boundary unit tests does not match correct computed values From 17385cc864ff22441875a10e225599ea47ac24ad Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 10 Sep 2019 15:50:45 -0600 Subject: [PATCH 005/103] Removes trailing space and fixes line length exceeded --- src/core/MOM_unit_tests.F90 | 2 +- src/tracer/MOM_boundary_lateral_mixing.F90 | 38 +++++++++------------- 2 files changed, 17 insertions(+), 23 deletions(-) diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index 24e93ed1ed..1aace6c94f 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -9,7 +9,7 @@ module MOM_unit_tests use MOM_remapping, only : remapping_unit_tests use MOM_neutral_diffusion, only : neutral_diffusion_unit_tests use MOM_diag_vkernels, only : diag_vkernels_unit_tests -use MOM_boundary_lateral_mixing, only : near_boundary_unit_tests +use MOM_boundary_lateral_mixing, only : near_boundary_unit_tests implicit none ; private diff --git a/src/tracer/MOM_boundary_lateral_mixing.F90 b/src/tracer/MOM_boundary_lateral_mixing.F90 index b9c53e6655..afda1263ed 100644 --- a/src/tracer/MOM_boundary_lateral_mixing.F90 +++ b/src/tracer/MOM_boundary_lateral_mixing.F90 @@ -40,7 +40,7 @@ subroutine boundary_lateral_mixing() real function bulk_average(boundary, h, hBLT, phi, ppoly0_E, ppoly0_coefs, method, k_top, zeta_top, k_bot, zeta_bot) integer :: boundary !< SURFACE or BOTTOM [nondim] integer :: nk !< Number of layers [nondim] - integer :: deg !< Degree of polynomial [nondim] + integer :: deg !< Degree of polynomial [nondim] real, dimension(nk) :: h !< Layer thicknesses [m] real :: hBLT !< Depth of the mixing layer [m] real, dimension(nk) :: phi !< Scalar quantity @@ -82,7 +82,7 @@ real function bulk_average(boundary, h, hBLT, phi, ppoly0_E, ppoly0_coefs, metho if (htot > 0.) then bulk_average = bulk_average / hBLT else - bulk_average = 0. + bulk_average = 0. endif end function bulk_average @@ -145,8 +145,8 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b end subroutine boundary_k_range !> Calculate the near-boundary diffusive fluxes calculated from a 'bulk model' -subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, ppoly0_coefs_R, & - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) +subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, & + ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] @@ -158,10 +158,10 @@ subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, p !! layer (left) [m] real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [ nondim m^-3 ] real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [ nondim m^-3 ] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [ nondim m^-3 ] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [ nondim m^-3 ] - real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [ nondim ] - real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [ nondim m^-3 ] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [ nondim m^-3 ] + real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [ nondim ] + real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] real, dimension(nk), intent(in ) :: khtr_u !< Horizontal diffusivities at U-point [m^2 s^-1] real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [trunit s^-1] @@ -185,27 +185,22 @@ subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, p ! Calculate vertical indices containing the boundary layer call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) - ! Calculate bulk averages of various quantities - phi_L_avg = bulk_average(boundary, h_L, hbl_L, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, zeta_top_L, + phi_L_avg = bulk_average(boundary, h_L, hbl_L, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) - phi_R_avg = bulk_average(boundary, h_R, hbl_R, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, zeta_top_R, + phi_R_avg = bulk_average(boundary, h_R, hbl_R, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) do k=1,nk h_u(k) = 0.5 * (h_L(k) + h_R(k)) enddo - hbl_u = 0.5*(hbl_L + hbl_R) - call boundary_k_range(boundary, nk, h_u, hbl_u, k_top_u, zeta_top_u, k_bot_u, zeta_bot_u) - khtr_avg = (h_u(k_bot) * zeta_bot) * khtr_u(k_bot) - do k=k_bot,1,-1 khtr_avg = khtr_avg + h_u(k) * khtr_u(k) enddo - khtr_avg = khtr_avg / hbl_u + khtr_avg = khtr_avg / hbl_u ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities heff = harmonic_mean(hbl_L, hbl_R) @@ -365,14 +360,13 @@ logical function near_boundary_unit_tests( verbose ) phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. khtr_u = (/1.,1./) - ppoly0_E_L(1,1) = 0; ppoly0_E_L(1,2) = 0 - ppoly0_E_L(2,1) = 0; ppoly0_E_L(2,2) = 0 - ppoly0_E_R(1,1) = 1; ppoly0_E_R(1,2) = 1 + ppoly0_E_L(1,1) = 0; ppoly0_E_L(1,2) = 0 + ppoly0_E_L(2,1) = 0; ppoly0_E_L(2,2) = 0 + ppoly0_E_R(1,1) = 1; ppoly0_E_R(1,2) = 1 ppoly0_E_R(2,1) = 1; ppoly0_E_R(2,2) = 1 - method = 1 - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, ppoly0_coefs_R, & + method = 1 + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, ppoly0_coefs_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) end function near_boundary_unit_tests From a36f5d64cdf9b4f053fc67c4fb9cf0ba1a783ed0 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 10 Sep 2019 16:07:11 -0600 Subject: [PATCH 006/103] Removes more trailing space --- src/tracer/MOM_boundary_lateral_mixing.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_boundary_lateral_mixing.F90 b/src/tracer/MOM_boundary_lateral_mixing.F90 index afda1263ed..c8127ed474 100644 --- a/src/tracer/MOM_boundary_lateral_mixing.F90 +++ b/src/tracer/MOM_boundary_lateral_mixing.F90 @@ -145,7 +145,7 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b end subroutine boundary_k_range !> Calculate the near-boundary diffusive fluxes calculated from a 'bulk model' -subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, & +subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, & ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] From f87aaa22b99deb43f7eb70035df785b37690c4b1 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 11 Sep 2019 16:02:50 -0600 Subject: [PATCH 007/103] Fixes bulk_average calculation and takes into account partial cells when computing fluxes --- src/tracer/MOM_boundary_lateral_mixing.F90 | 82 ++++++++++++++++++---- 1 file changed, 68 insertions(+), 14 deletions(-) diff --git a/src/tracer/MOM_boundary_lateral_mixing.F90 b/src/tracer/MOM_boundary_lateral_mixing.F90 index c8127ed474..52c3ac4823 100644 --- a/src/tracer/MOM_boundary_lateral_mixing.F90 +++ b/src/tracer/MOM_boundary_lateral_mixing.F90 @@ -37,7 +37,7 @@ subroutine boundary_lateral_mixing() end subroutine !< Calculate bulk layer value of a scalar quantity as the thickness weighted average -real function bulk_average(boundary, h, hBLT, phi, ppoly0_E, ppoly0_coefs, method, k_top, zeta_top, k_bot, zeta_bot) +real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coefs, method, k_top, zeta_top, k_bot, zeta_bot) integer :: boundary !< SURFACE or BOTTOM [nondim] integer :: nk !< Number of layers [nondim] integer :: deg !< Degree of polynomial [nondim] @@ -64,7 +64,7 @@ real function bulk_average(boundary, h, hBLT, phi, ppoly0_E, ppoly0_coefs, metho if (boundary == SURFACE) then htot = (h(k_bot) * zeta_bot) bulk_average = average_value_ppoly( nk, phi, ppoly0_E, ppoly0_coefs, method, k_bot, 0., zeta_bot) * htot - do k = kbot-1,1,-1 + do k = k_bot-1,1,-1 bulk_average = bulk_average + phi(k)*h(k) htot = htot + h(k) enddo @@ -84,6 +84,7 @@ real function bulk_average(boundary, h, hBLT, phi, ppoly0_E, ppoly0_coefs, metho else bulk_average = 0. endif + write(*,*)'bulk_average:', bulk_average end function bulk_average @@ -176,27 +177,28 @@ subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, p real :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) ! [trunit m^-3 ] real :: htot ! Total column thickness [m] - integer :: k + integer :: k, k_min, k_max integer :: k_top_L, k_bot_L, k_top_u integer :: k_top_R, k_bot_R, k_bot_u real :: zeta_top_L, zeta_top_R, zeta_top_u real :: zeta_bot_L, zeta_bot_R, zeta_bot_u + real :: h_work_L, h_work_R ! dummy variables ! Calculate vertical indices containing the boundary layer call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) ! Calculate bulk averages of various quantities - phi_L_avg = bulk_average(boundary, h_L, hbl_L, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, zeta_top_L, + phi_L_avg = bulk_average(boundary, nk, deg, h_L, hbl_L, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, zeta_top_L,& k_bot_L, zeta_bot_L) - phi_R_avg = bulk_average(boundary, h_R, hbl_R, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, zeta_top_R, + phi_R_avg = bulk_average(boundary, nk, deg, h_R, hbl_R, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, zeta_top_R,& k_bot_R, zeta_bot_R) do k=1,nk h_u(k) = 0.5 * (h_L(k) + h_R(k)) enddo hbl_u = 0.5*(hbl_L + hbl_R) call boundary_k_range(boundary, nk, h_u, hbl_u, k_top_u, zeta_top_u, k_bot_u, zeta_bot_u) - khtr_avg = (h_u(k_bot) * zeta_bot) * khtr_u(k_bot) - do k=k_bot,1,-1 + khtr_avg = (h_u(k_bot_u) * zeta_bot_u) * khtr_u(k_bot_u) + do k=k_bot_u,1,-1 khtr_avg = khtr_avg + h_u(k) * khtr_u(k) enddo @@ -208,9 +210,57 @@ subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, p ! Calculate the layerwise sum of the vertical effective thickness. This is different than the heff calculated ! above, but is used as a way to decompose decompose the fluxes onto the individual layers - do k=1,nk - h_means(k) = harmonic_mean(h_L(k),h_R(k)) - enddo + h_means(:) = 0. + + if (boundary == SURFACE) then + k_min = MIN(k_bot_L, k_bot_R) + + ! left hand side + if (k_bot_L == k_min) then + h_work_L = h_L(k_min) * zeta_bot_L + else + h_work_L = h_L(k_min) + endif + + ! right hand side + if (k_bot_R == k_min) then + h_work_R = h_R(k_min) * zeta_bot_R + else + h_work_R = h_R(k_min) + endif + + h_means(k_min) = harmonic_mean(h_work_L,h_work_R) + + do k=1,k_min-1 + h_means(k) = harmonic_mean(h_L(k),h_R(k)) + enddo + endif + + + if (boundary == BOTTOM) then + k_max = MAX(k_top_L, k_top_R) + + ! left hand side + if (k_top_L == k_max) then + h_work_L = h_L(k_max) * zeta_top_L + else + h_work_L = h_L(k_max) + endif + + ! right hand side + if (k_top_R == k_max) then + h_work_R = h_R(k_max) * zeta_top_R + else + h_work_R = h_R(k_max) + endif + + h_means(k_max) = harmonic_mean(h_work_L,h_work_R) + + do k=nk,k_max+1,-1 + h_means(k) = harmonic_mean(h_L(k),h_R(k)) + enddo + endif + inv_heff = 1./SUM(h_means) do k=1,nk F_layer(k) = F_bulk * (h_means(k)*inv_heff) @@ -227,8 +277,10 @@ logical function near_boundary_unit_tests( verbose ) integer, parameter :: deg = 1 ! Degree of reconstruction (linear here) real, dimension(nk) :: phi_L, phi_R ! Tracer values (left and right column) [ nondim m^-3 ] real, dimension(nk) :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) - real, dimension(nk,2) :: phi_pp_L, phi_pp_R ! Coefficients for the linear pseudo-reconstructions + real, dimension(nk,deg+1) :: phi_pp_L, phi_pp_R ! Coefficients for the linear pseudo-reconstructions ! [ nondim m^-3 ] + + real, dimension(nk,2) :: ppoly0_E_L, ppoly0_E_R! Polynomial edge values (left and right) [concentration] real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] real, dimension(nk) :: khtr_u ! Horizontal diffusivities at U-point [m^2 s^-1] real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] @@ -243,7 +295,7 @@ logical function near_boundary_unit_tests( verbose ) real :: zeta_top ! Nondimension position integer :: k_bot ! Index of cell containing bottom of boundary real :: zeta_bot ! Nondimension position - + integer :: method ! Polynomial method near_boundary_unit_tests = .false. ! Unit tests for boundary_k_range @@ -352,6 +404,8 @@ logical function near_boundary_unit_tests( verbose ) ! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) ! ! Cases where hbl < column thickness (polynomial coefficients specified for pseudo-linear reconstruction) + + test_name = 'hbl < column thickness' hbl_L = 2; hbl_R = 2 h_L = (/1.,2./) ; h_R = (/1.,2./) phi_L = (/0.,0./) ; phi_R = (/1.,1./) @@ -365,9 +419,9 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1; ppoly0_E_R(1,2) = 1 ppoly0_E_R(2,1) = 1; ppoly0_E_R(2,2) = 1 method = 1 - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, ppoly0_coefs_R,& + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) end function near_boundary_unit_tests !> Returns true if output of near-boundary unit tests does not match correct computed values From 79bea687698f60b06ae8d7f1ad14a81b170216be Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 12 Sep 2019 10:22:00 -0600 Subject: [PATCH 008/103] New unit tests for surface boundary fluxes - Add two unit tests for cases where the surface boundary layer intersects partly through a cell. 1. Right column same BLT, same thicknesses, flux from right to left, constant in the vertical 2. Right column same BLT, same thicknesses, flux from right to left, linear profile on right TODO: 1. Uncomment out previous unit tests 2. Update API in those test cases 3. Need to add similar unit tests for the bottom boundary --- src/tracer/MOM_boundary_lateral_mixing.F90 | 145 ++++++++++++--------- 1 file changed, 85 insertions(+), 60 deletions(-) diff --git a/src/tracer/MOM_boundary_lateral_mixing.F90 b/src/tracer/MOM_boundary_lateral_mixing.F90 index 52c3ac4823..301535dae3 100644 --- a/src/tracer/MOM_boundary_lateral_mixing.F90 +++ b/src/tracer/MOM_boundary_lateral_mixing.F90 @@ -49,11 +49,13 @@ real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coe integer :: method !< Remapping scheme to use integer :: k_top !< Index of the first layer within the boundary - real :: zeta_top !< Distance from the top of a layer to the intersection of the - !! top extent of the boundary layer (0 at top 1 at bottom) [nondim] + real :: zeta_top !< Fraction of the layer encompassed by the bottom boundary layer + !! (0 if none, 1. if all). For the surface, this is always 0. because + !! integration starts at the surface [nondim] integer :: k_bot !< Index of the last layer within the boundary - real :: zeta_bot !< Distance of the lower layer to the boundary layer depth - !! (0 at top, 1 at bottom) [nondim] + real :: zeta_bot !< Fraction of the layer encompassed by the surface boundary layer + !! (0 if none, 1. if all). For the bottom boundary layer, this is always 1. + !! because integration starts at the bottom [nondim] ! Local variables real :: htot ! Running sum of the thicknesses (top to bottom) integer :: k @@ -70,7 +72,8 @@ real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coe enddo elseif (boundary == BOTTOM) then htot = (h(k_top) * zeta_top) - bulk_average = average_value_ppoly( nk, phi, ppoly0_E, ppoly0_coefs, method, k_top, zeta_top, 1.) * htot + ! (note 1-zeta_top because zeta_top is the fraction of the layer) + bulk_average = average_value_ppoly( nk, phi, ppoly0_E, ppoly0_coefs, method, k_top, (1.-zeta_top), 1.) * htot do k = k_top+1,nk bulk_average = bulk_average + phi(k)*h(k) htot = htot + h(k) @@ -84,7 +87,6 @@ real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coe else bulk_average = 0. endif - write(*,*)'bulk_average:', bulk_average end function bulk_average @@ -197,17 +199,23 @@ subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, p enddo hbl_u = 0.5*(hbl_L + hbl_R) call boundary_k_range(boundary, nk, h_u, hbl_u, k_top_u, zeta_top_u, k_bot_u, zeta_bot_u) - khtr_avg = (h_u(k_bot_u) * zeta_bot_u) * khtr_u(k_bot_u) - do k=k_bot_u,1,-1 - khtr_avg = khtr_avg + h_u(k) * khtr_u(k) - enddo + if ( boundary == SURFACE ) then + khtr_avg = (h_u(k_bot_u) * zeta_bot_u) * khtr_u(k_bot_u) + do k=k_bot_u-1,1,-1 + khtr_avg = khtr_avg + h_u(k) * khtr_u(k) + enddo + elseif ( boundary == BOTTOM ) then + khtr_avg = (h_u(k_top_u) * (1.-zeta_top_u)) * khtr_u(k_top_u) + do k=k_top_u+1,nk + khtr_avg = khtr_avg + h_u(k) * khtr_u(k) + enddo + endif khtr_avg = khtr_avg / hbl_u ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities heff = harmonic_mean(hbl_L, hbl_R) F_bulk = -(khtr_avg * heff) * (phi_R_avg - phi_L_avg) - ! Calculate the layerwise sum of the vertical effective thickness. This is different than the heff calculated ! above, but is used as a way to decompose decompose the fluxes onto the individual layers h_means(:) = 0. @@ -236,7 +244,6 @@ subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, p enddo endif - if (boundary == BOTTOM) then k_max = MAX(k_top_L, k_top_R) @@ -298,46 +305,46 @@ logical function near_boundary_unit_tests( verbose ) integer :: method ! Polynomial method near_boundary_unit_tests = .false. - ! Unit tests for boundary_k_range - test_name = 'Surface boundary spans the entire top cell' - h_L = (/5.,5./) - call boundary_k_range(SURFACE, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 1., test_name, verbose) - - test_name = 'Surface boundary spans the entire column' - h_L = (/5.,5./) - call boundary_k_range(SURFACE, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) - - test_name = 'Bottom boundary spans the entire bottom cell' - h_L = (/5.,5./) - call boundary_k_range(BOTTOM, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0., 2, 1., test_name, verbose) - - test_name = 'Bottom boundary spans the entire column' - h_L = (/5.,5./) - call boundary_k_range(BOTTOM, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) - - test_name = 'Surface boundary intersects second layer' - h_L = (/10.,10./) - call boundary_k_range(SURFACE, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0.75, test_name, verbose) - - test_name = 'Surface boundary intersects first layer' - h_L = (/10.,10./) - call boundary_k_range(SURFACE, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 0.25, test_name, verbose) - - test_name = 'Bottom boundary intersects first layer' - h_L = (/10.,10./) - call boundary_k_range(BOTTOM, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0.75, 2, 1., test_name, verbose) - - test_name = 'Bottom boundary intersects second layer' - h_L = (/10.,10./) - call boundary_k_range(BOTTOM, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0.25, 2, 1., test_name, verbose) +!! ! Unit tests for boundary_k_range +!! test_name = 'Surface boundary spans the entire top cell' +!! h_L = (/5.,5./) +!! call boundary_k_range(SURFACE, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) +!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 1., test_name, verbose) +!! +!! test_name = 'Surface boundary spans the entire column' +!! h_L = (/5.,5./) +!! call boundary_k_range(SURFACE, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) +!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) +!! +!! test_name = 'Bottom boundary spans the entire bottom cell' +!! h_L = (/5.,5./) +!! call boundary_k_range(BOTTOM, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) +!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0., 2, 1., test_name, verbose) +!! +!! test_name = 'Bottom boundary spans the entire column' +!! h_L = (/5.,5./) +!! call boundary_k_range(BOTTOM, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) +!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) +!! +!! test_name = 'Surface boundary intersects second layer' +!! h_L = (/10.,10./) +!! call boundary_k_range(SURFACE, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) +!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0.75, test_name, verbose) +!! +!! test_name = 'Surface boundary intersects first layer' +!! h_L = (/10.,10./) +!! call boundary_k_range(SURFACE, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) +!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 0.25, test_name, verbose) +!! +!! test_name = 'Bottom boundary intersects first layer' +!! h_L = (/10.,10./) +!! call boundary_k_range(BOTTOM, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) +!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0.75, 2, 1., test_name, verbose) +!! +!! test_name = 'Bottom boundary intersects second layer' +!! h_L = (/10.,10./) +!! call boundary_k_range(BOTTOM, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) +!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0.25, 2, 1., test_name, verbose) ! ! All cases in this section have hbl which are equal to the column thicknesses ! test_name = 'Equal hbl and same layer thicknesses (gradient from right to left)' @@ -405,19 +412,37 @@ logical function near_boundary_unit_tests( verbose ) ! ! Cases where hbl < column thickness (polynomial coefficients specified for pseudo-linear reconstruction) - test_name = 'hbl < column thickness' +! test_name = 'hbl < column thickness, hbl same, constant concentration each column' +! hbl_L = 2; hbl_R = 2 +! h_L = (/1.,2./) ; h_R = (/1.,2./) +! phi_L = (/0.,0./) ; phi_R = (/1.,1./) +! phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. +! phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. +! phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. +! phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. +! khtr_u = (/1.,1./) +! ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. +! ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. +! ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. +! ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. +! method = 1 +! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& +! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) +! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) + + test_name = 'hbl < column thickness, hbl same, linear profile right' hbl_L = 2; hbl_R = 2 h_L = (/1.,2./) ; h_R = (/1.,2./) - phi_L = (/0.,0./) ; phi_R = (/1.,1./) + phi_L = (/0.,0./) ; phi_R = (/0.5,2./) phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 1. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 2. khtr_u = (/1.,1./) - ppoly0_E_L(1,1) = 0; ppoly0_E_L(1,2) = 0 - ppoly0_E_L(2,1) = 0; ppoly0_E_L(2,2) = 0 - ppoly0_E_R(1,1) = 1; ppoly0_E_R(1,2) = 1 - ppoly0_E_R(2,1) = 1; ppoly0_E_R(2,2) = 1 + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. method = 1 call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) From 4e63c751cafd1d47e93a8bd83355ffd5b7c52375 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 12 Sep 2019 11:45:53 -0600 Subject: [PATCH 009/103] Update API for boundary_layer_fluxes unit tests This updates all the previously commented out unit tests to update the API. These changes were required to allow for cases where the boundary layer that intersects partway through a model layer. --- src/tracer/MOM_boundary_lateral_mixing.F90 | 296 ++++++++++++--------- 1 file changed, 173 insertions(+), 123 deletions(-) diff --git a/src/tracer/MOM_boundary_lateral_mixing.F90 b/src/tracer/MOM_boundary_lateral_mixing.F90 index 301535dae3..68a49014cf 100644 --- a/src/tracer/MOM_boundary_lateral_mixing.F90 +++ b/src/tracer/MOM_boundary_lateral_mixing.F90 @@ -302,133 +302,183 @@ logical function near_boundary_unit_tests( verbose ) real :: zeta_top ! Nondimension position integer :: k_bot ! Index of cell containing bottom of boundary real :: zeta_bot ! Nondimension position - integer :: method ! Polynomial method near_boundary_unit_tests = .false. -!! ! Unit tests for boundary_k_range -!! test_name = 'Surface boundary spans the entire top cell' -!! h_L = (/5.,5./) -!! call boundary_k_range(SURFACE, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) -!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 1., test_name, verbose) -!! -!! test_name = 'Surface boundary spans the entire column' -!! h_L = (/5.,5./) -!! call boundary_k_range(SURFACE, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) -!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) -!! -!! test_name = 'Bottom boundary spans the entire bottom cell' -!! h_L = (/5.,5./) -!! call boundary_k_range(BOTTOM, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) -!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0., 2, 1., test_name, verbose) -!! -!! test_name = 'Bottom boundary spans the entire column' -!! h_L = (/5.,5./) -!! call boundary_k_range(BOTTOM, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) -!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) -!! -!! test_name = 'Surface boundary intersects second layer' -!! h_L = (/10.,10./) -!! call boundary_k_range(SURFACE, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) -!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0.75, test_name, verbose) -!! -!! test_name = 'Surface boundary intersects first layer' -!! h_L = (/10.,10./) -!! call boundary_k_range(SURFACE, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) -!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 0.25, test_name, verbose) -!! -!! test_name = 'Bottom boundary intersects first layer' -!! h_L = (/10.,10./) -!! call boundary_k_range(BOTTOM, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) -!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0.75, 2, 1., test_name, verbose) -!! -!! test_name = 'Bottom boundary intersects second layer' -!! h_L = (/10.,10./) -!! call boundary_k_range(BOTTOM, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) -!! near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0.25, 2, 1., test_name, verbose) - -! ! All cases in this section have hbl which are equal to the column thicknesses -! test_name = 'Equal hbl and same layer thicknesses (gradient from right to left)' -! hbl_L = 10; hbl_R = 10 -! h_L = (/5.,5./) ; h_R = (/5.,5./) -! phi_L = (/0.,0./) ; phi_R = (/1.,1./) -! khtr_u = (/1.,1./) -! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& -! phi_pp_L, phi_pp_R, khtr_u, F_layer) -! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) -! -! test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)' -! hbl_L = 10.; hbl_R = 10. -! h_L = (/5.,5./) ; h_R = (/5.,5./) -! phi_L = (/1.,1./) ; phi_R = (/0.,0./) -! khtr_u = (/1.,1./) -! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& -! phi_pp_L, phi_pp_R, khtr_u, F_layer) -! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) -! -! test_name = 'Equal hbl and same layer thicknesses (no gradient)' -! hbl_L = 10; hbl_R = 10 -! h_L = (/5.,5./) ; h_R = (/5.,5./) -! phi_L = (/1.,1./) ; phi_R = (/1.,1./) -! khtr_u = (/1.,1./) -! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& -! phi_pp_L, phi_pp_R, khtr_u, F_layer) -! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) -! -! test_name = 'Equal hbl and different layer thicknesses (gradient right to left)' -! hbl_L = 16.; hbl_R = 16. -! h_L = (/10.,6./) ; h_R = (/6.,10./) -! phi_L = (/0.,0./) ; phi_R = (/1.,1./) -! khtr_u = (/1.,1./) -! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& -! phi_pp_L, phi_pp_R, khtr_u, F_layer) -! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) -! -! test_name = 'Equal hbl and same layer thicknesses (diagonal tracer values)' -! hbl_L = 10.; hbl_R = 10. -! h_L = (/5.,5./) ; h_R = (/5.,5./) -! phi_L = (/1.,0./) ; phi_R = (/0.,1./) -! khtr_u = (/1.,1./) -! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& -! phi_pp_L, phi_pp_R, khtr_u, F_layer) -! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) -! -! test_name = 'Different hbl and different column thicknesses (gradient from right to left)' -! hbl_L = 12; hbl_R = 20 -! h_L = (/6.,6./) ; h_R = (/10.,10./) -! phi_L = (/0.,0./) ; phi_R = (/1.,1./) -! khtr_u = (/1.,1./) -! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& -! phi_pp_L, phi_pp_R, khtr_u, F_layer) -! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) -! -! test_name = 'Different hbl and different layer thicknesses (gradient from right to left)' -! hbl_L = 12; hbl_R = 20 -! h_L = (/6.,6./) ; h_R = (/10.,10./) -! phi_L = (/0.,0./) ; phi_R = (/1.,1./) -! khtr_u = (/1.,1./) -! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R,& -! phi_pp_L, phi_pp_R, khtr_u, F_layer) -! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) -! + ! Unit tests for boundary_k_range + test_name = 'Surface boundary spans the entire top cell' + h_L = (/5.,5./) + call boundary_k_range(SURFACE, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 1., test_name, verbose) + + test_name = 'Surface boundary spans the entire column' + h_L = (/5.,5./) + call boundary_k_range(SURFACE, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) + + test_name = 'Bottom boundary spans the entire bottom cell' + h_L = (/5.,5./) + call boundary_k_range(BOTTOM, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0., 2, 1., test_name, verbose) + + test_name = 'Bottom boundary spans the entire column' + h_L = (/5.,5./) + call boundary_k_range(BOTTOM, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) + + test_name = 'Surface boundary intersects second layer' + h_L = (/10.,10./) + call boundary_k_range(SURFACE, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0.75, test_name, verbose) + + test_name = 'Surface boundary intersects first layer' + h_L = (/10.,10./) + call boundary_k_range(SURFACE, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 0.25, test_name, verbose) + + test_name = 'Bottom boundary intersects first layer' + h_L = (/10.,10./) + call boundary_k_range(BOTTOM, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0.75, 2, 1., test_name, verbose) + + test_name = 'Bottom boundary intersects second layer' + h_L = (/10.,10./) + call boundary_k_range(BOTTOM, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0.25, 2, 1., test_name, verbose) + + ! All cases in this section have hbl which are equal to the column thicknesses + test_name = 'Equal hbl and same layer thicknesses (gradient from right to left)' + hbl_L = 10; hbl_R = 10 + h_L = (/5.,5./) ; h_R = (/5.,5./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) + + test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)' + hbl_L = 10.; hbl_R = 10. + h_L = (/5.,5./) ; h_R = (/5.,5./) + phi_L = (/1.,1./) ; phi_R = (/0.,0./) + phi_pp_L(1,1) = 1.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 1.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 0.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 1. + ppoly0_E_L(2,1) = 1.; ppoly0_E_L(2,2) = 1. + ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. + ppoly0_E_R(2,1) = 0.; ppoly0_E_R(2,2) = 0. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) + + test_name = 'Equal hbl and same layer thicknesses (no gradient)' + hbl_L = 10; hbl_R = 10 + h_L = (/5.,5./) ; h_R = (/5.,5./) + phi_L = (/1.,1./) ; phi_R = (/1.,1./) + phi_pp_L(1,1) = 1.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 1.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 1.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) + + test_name = 'Equal hbl and different layer thicknesses (gradient right to left)' + hbl_L = 16.; hbl_R = 16. + h_L = (/10.,6./) ; h_R = (/6.,10./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) + + test_name = 'Equal hbl and same layer thicknesses (diagonal tracer values)' + hbl_L = 10.; hbl_R = 10. + h_L = (/5.,5./) ; h_R = (/5.,5./) + phi_L = (/1.,0./) ; phi_R = (/0.,1./) + phi_pp_L(1,1) = 1.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 1. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) + + test_name = 'Different hbl and different column thicknesses (gradient from right to left)' + hbl_L = 12; hbl_R = 20 + h_L = (/6.,6./) ; h_R = (/10.,10./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) + + test_name = 'Different hbl and different layer thicknesses (gradient from right to left)' + hbl_L = 12; hbl_R = 20 + h_L = (/6.,6./) ; h_R = (/10.,10./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) + ! Cases where hbl < column thickness (polynomial coefficients specified for pseudo-linear reconstruction) -! test_name = 'hbl < column thickness, hbl same, constant concentration each column' -! hbl_L = 2; hbl_R = 2 -! h_L = (/1.,2./) ; h_R = (/1.,2./) -! phi_L = (/0.,0./) ; phi_R = (/1.,1./) -! phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. -! phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. -! phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. -! phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. -! khtr_u = (/1.,1./) -! ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. -! ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. -! ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. -! ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. -! method = 1 -! call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& -! ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) -! near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) + test_name = 'hbl < column thickness, hbl same, constant concentration each column' + hbl_L = 2; hbl_R = 2 + h_L = (/1.,2./) ; h_R = (/1.,2./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) test_name = 'hbl < column thickness, hbl same, linear profile right' hbl_L = 2; hbl_R = 2 From 2b10a8bbcbb248e000a7bf19e17cc69e4aca3c07 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 12 Sep 2019 11:52:43 -0600 Subject: [PATCH 010/103] Skeleton for boundary layer mixing interfaces All the development in the boundary layer mixing scheme has focused on simple unit tests. This provides a skeleton for some of the interfaces that will need to be in place before using the new parameterization in a 'real' MOM6 simulation --- src/core/MOM_unit_tests.F90 | 2 +- src/tracer/MOM_boundary_lateral_mixing.F90 | 562 --------------------- src/tracer/MOM_tracer_hor_diff.F90 | 2 + 3 files changed, 3 insertions(+), 563 deletions(-) delete mode 100644 src/tracer/MOM_boundary_lateral_mixing.F90 diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index 1aace6c94f..844d0efb67 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -9,7 +9,7 @@ module MOM_unit_tests use MOM_remapping, only : remapping_unit_tests use MOM_neutral_diffusion, only : neutral_diffusion_unit_tests use MOM_diag_vkernels, only : diag_vkernels_unit_tests -use MOM_boundary_lateral_mixing, only : near_boundary_unit_tests +use MOM_lateral_boundary_mixing, only : near_boundary_unit_tests implicit none ; private diff --git a/src/tracer/MOM_boundary_lateral_mixing.F90 b/src/tracer/MOM_boundary_lateral_mixing.F90 deleted file mode 100644 index 68a49014cf..0000000000 --- a/src/tracer/MOM_boundary_lateral_mixing.F90 +++ /dev/null @@ -1,562 +0,0 @@ -!> Calculate and apply diffusive fluxes as a parameterization of lateral mixing (non-neutral) by -!! mesoscale eddies near the top and bottom boundary layers of the ocean. -module MOM_boundary_lateral_mixing - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE -use MOM_diag_mediator, only : diag_ctrl, time_type -use MOM_diag_mediator, only : post_data, register_diag_field -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_file_parser, only : openParameterBlock, closeParameterBlock -use MOM_grid, only : ocean_grid_type -use MOM_remapping, only : remapping_CS, initialize_remapping -use MOM_remapping, only : extract_member_remapping_CS, build_reconstructions_1d -use MOM_remapping, only : average_value_ppoly, remappingSchemesDoc, remappingDefaultScheme -use MOM_tracer_registry, only : tracer_registry_type, tracer_type -use MOM_verticalGrid, only : verticalGrid_type - -implicit none ; private - -public near_boundary_unit_tests - -! Private parameters to avoid doing string comparisons for bottom or top boundary layer -integer, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface bopundary -integer, parameter :: BOTTOM = 1 !< Set a value that corresponds to the bottom boundary - -#include -contains - -!> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. Two different methods -!! Method 1: Calculate fluxes from bulk layer integrated quantities -subroutine boundary_lateral_mixing() - - -end subroutine - -!< Calculate bulk layer value of a scalar quantity as the thickness weighted average -real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coefs, method, k_top, zeta_top, k_bot, zeta_bot) - integer :: boundary !< SURFACE or BOTTOM [nondim] - integer :: nk !< Number of layers [nondim] - integer :: deg !< Degree of polynomial [nondim] - real, dimension(nk) :: h !< Layer thicknesses [m] - real :: hBLT !< Depth of the mixing layer [m] - real, dimension(nk) :: phi !< Scalar quantity - real, dimension(nk,2) :: ppoly0_E(:,:) !< Edge value of polynomial - real, dimension(nk,deg+1) :: ppoly0_coefs(:,:) !< Coefficients of polynomial - integer :: method !< Remapping scheme to use - - integer :: k_top !< Index of the first layer within the boundary - real :: zeta_top !< Fraction of the layer encompassed by the bottom boundary layer - !! (0 if none, 1. if all). For the surface, this is always 0. because - !! integration starts at the surface [nondim] - integer :: k_bot !< Index of the last layer within the boundary - real :: zeta_bot !< Fraction of the layer encompassed by the surface boundary layer - !! (0 if none, 1. if all). For the bottom boundary layer, this is always 1. - !! because integration starts at the bottom [nondim] - ! Local variables - real :: htot ! Running sum of the thicknesses (top to bottom) - integer :: k - - - htot = 0. - bulk_average = 0. - if (boundary == SURFACE) then - htot = (h(k_bot) * zeta_bot) - bulk_average = average_value_ppoly( nk, phi, ppoly0_E, ppoly0_coefs, method, k_bot, 0., zeta_bot) * htot - do k = k_bot-1,1,-1 - bulk_average = bulk_average + phi(k)*h(k) - htot = htot + h(k) - enddo - elseif (boundary == BOTTOM) then - htot = (h(k_top) * zeta_top) - ! (note 1-zeta_top because zeta_top is the fraction of the layer) - bulk_average = average_value_ppoly( nk, phi, ppoly0_E, ppoly0_coefs, method, k_top, (1.-zeta_top), 1.) * htot - do k = k_top+1,nk - bulk_average = bulk_average + phi(k)*h(k) - htot = htot + h(k) - enddo - else - call MOM_error(FATAL, "bulk_average: a valid boundary type must be provided.") - endif - - if (htot > 0.) then - bulk_average = bulk_average / hBLT - else - bulk_average = 0. - endif - -end function bulk_average - -!> Calculate the harmonic mean of two quantities -real function harmonic_mean(h1,h2) - real :: h1 !< Scalar quantity - real :: h2 !< Scalar quantity - - harmonic_mean = 2.*(h1*h2)/(h1+h2) -end function harmonic_mean - -!> Find the k-index range corresponding to the layers that are within the boundary-layer region -subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_bot) - integer, intent(in ) :: boundary !< SURFACE or BOTTOM [nondim] - integer, intent(in ) :: nk !< Number of layers [nondim] - real, dimension(nk), intent(in ) :: h !< Layer thicknesses of the coluymn [m] - real, intent(in ) :: hbl !< Thickness of the boundary layer [m] - !! If surface, with respect to zbl_ref = 0. - !! If bottom, with respect to zbl_ref = SUM(h) - integer, intent( out) :: k_top !< Index of the first layer within the boundary - real, intent( out) :: zeta_top !< Distance from the top of a layer to the intersection of the - !! top extent of the boundary layer (0 at top, 1 at bottom) [nondim] - integer, intent( out) :: k_bot !< Index of the last layer within the boundary - real, intent( out) :: zeta_bot !< Distance of the lower layer to the boundary layer depth - !! (0 at top, 1 at bottom) [nondim] - ! Local variables - real :: htot - integer :: k - ! Surface boundary layer - if ( boundary == SURFACE ) then - k_top = 1 - zeta_top = 0. - htot = 0. - do k=1,nk - htot = htot + h(k) - if ( htot >= hbl) then - k_bot = k - zeta_bot = 1 - (htot - hbl)/h(k) - return - endif - enddo - ! Bottom boundary layer - elseif ( boundary == BOTTOM ) then - k_bot = nk - zeta_bot = 1. - htot = 0. - do k=nk,1,-1 - htot = htot + h(k) - if (htot >= hbl) then - k_top = k - zeta_top = 1 - (htot - hbl)/h(k) - return - endif - enddo - else - call MOM_error(FATAL,"Houston, we've had a problem in boundary_k_range") - endif - -end subroutine boundary_k_range - -!> Calculate the near-boundary diffusive fluxes calculated from a 'bulk model' -subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, & - ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] - integer, intent(in ) :: nk !< Number of layers [nondim] - integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] - real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [m] - real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [m] - real, intent(in ) :: hbl_L !< Thickness of the boundary boundary - !! layer (left) [m] - real, intent(in ) :: hbl_R !< Thickness of the boundary boundary - !! layer (left) [m] - real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [ nondim m^-3 ] - real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [ nondim m^-3 ] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [ nondim m^-3 ] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [ nondim m^-3 ] - real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [ nondim ] - real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] - integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] - real, dimension(nk), intent(in ) :: khtr_u !< Horizontal diffusivities at U-point [m^2 s^-1] - real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [trunit s^-1] - ! Local variables - real :: F_bulk ! Total diffusive flux across the U point [trunit s^-1] - real, dimension(nk) :: h_means ! Calculate the layer-wise harmonic means [m] - real, dimension(nk) :: h_u ! Thickness at the u-point [m] - real :: hbl_u ! Boundary layer Thickness at the u-point [m] - real :: khtr_avg ! Thickness-weighted diffusivity at the u-point [m^2 s^-1] - real :: heff ! Harmonic mean of layer thicknesses [m] - real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] - real :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) - ! [trunit m^-3 ] - real :: htot ! Total column thickness [m] - integer :: k, k_min, k_max - integer :: k_top_L, k_bot_L, k_top_u - integer :: k_top_R, k_bot_R, k_bot_u - real :: zeta_top_L, zeta_top_R, zeta_top_u - real :: zeta_bot_L, zeta_bot_R, zeta_bot_u - real :: h_work_L, h_work_R ! dummy variables - - ! Calculate vertical indices containing the boundary layer - call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) - call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) - ! Calculate bulk averages of various quantities - phi_L_avg = bulk_average(boundary, nk, deg, h_L, hbl_L, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, zeta_top_L,& - k_bot_L, zeta_bot_L) - phi_R_avg = bulk_average(boundary, nk, deg, h_R, hbl_R, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, zeta_top_R,& - k_bot_R, zeta_bot_R) - do k=1,nk - h_u(k) = 0.5 * (h_L(k) + h_R(k)) - enddo - hbl_u = 0.5*(hbl_L + hbl_R) - call boundary_k_range(boundary, nk, h_u, hbl_u, k_top_u, zeta_top_u, k_bot_u, zeta_bot_u) - if ( boundary == SURFACE ) then - khtr_avg = (h_u(k_bot_u) * zeta_bot_u) * khtr_u(k_bot_u) - do k=k_bot_u-1,1,-1 - khtr_avg = khtr_avg + h_u(k) * khtr_u(k) - enddo - elseif ( boundary == BOTTOM ) then - khtr_avg = (h_u(k_top_u) * (1.-zeta_top_u)) * khtr_u(k_top_u) - do k=k_top_u+1,nk - khtr_avg = khtr_avg + h_u(k) * khtr_u(k) - enddo - endif - - khtr_avg = khtr_avg / hbl_u - - ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities - heff = harmonic_mean(hbl_L, hbl_R) - F_bulk = -(khtr_avg * heff) * (phi_R_avg - phi_L_avg) - ! Calculate the layerwise sum of the vertical effective thickness. This is different than the heff calculated - ! above, but is used as a way to decompose decompose the fluxes onto the individual layers - h_means(:) = 0. - - if (boundary == SURFACE) then - k_min = MIN(k_bot_L, k_bot_R) - - ! left hand side - if (k_bot_L == k_min) then - h_work_L = h_L(k_min) * zeta_bot_L - else - h_work_L = h_L(k_min) - endif - - ! right hand side - if (k_bot_R == k_min) then - h_work_R = h_R(k_min) * zeta_bot_R - else - h_work_R = h_R(k_min) - endif - - h_means(k_min) = harmonic_mean(h_work_L,h_work_R) - - do k=1,k_min-1 - h_means(k) = harmonic_mean(h_L(k),h_R(k)) - enddo - endif - - if (boundary == BOTTOM) then - k_max = MAX(k_top_L, k_top_R) - - ! left hand side - if (k_top_L == k_max) then - h_work_L = h_L(k_max) * zeta_top_L - else - h_work_L = h_L(k_max) - endif - - ! right hand side - if (k_top_R == k_max) then - h_work_R = h_R(k_max) * zeta_top_R - else - h_work_R = h_R(k_max) - endif - - h_means(k_max) = harmonic_mean(h_work_L,h_work_R) - - do k=nk,k_max+1,-1 - h_means(k) = harmonic_mean(h_L(k),h_R(k)) - enddo - endif - - inv_heff = 1./SUM(h_means) - do k=1,nk - F_layer(k) = F_bulk * (h_means(k)*inv_heff) - enddo - -end subroutine layer_fluxes_bulk_method - -!> Unit tests for near-boundary horizontal mixing -logical function near_boundary_unit_tests( verbose ) - logical, intent(in) :: verbose !< If true, output additional information for debugging unit tests - - ! Local variables - integer, parameter :: nk = 2 ! Number of layers - integer, parameter :: deg = 1 ! Degree of reconstruction (linear here) - real, dimension(nk) :: phi_L, phi_R ! Tracer values (left and right column) [ nondim m^-3 ] - real, dimension(nk) :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) - real, dimension(nk,deg+1) :: phi_pp_L, phi_pp_R ! Coefficients for the linear pseudo-reconstructions - ! [ nondim m^-3 ] - - real, dimension(nk,2) :: ppoly0_E_L, ppoly0_E_R! Polynomial edge values (left and right) [concentration] - real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] - real, dimension(nk) :: khtr_u ! Horizontal diffusivities at U-point [m^2 s^-1] - real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] - real :: F_bulk ! Total diffusive flux across the U point [nondim s^-1] - real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [nondim s^-1] - real :: h_u, hblt_u ! Thickness at the u-point [m] - real :: khtr_avg ! Thickness-weighted diffusivity at the u-point [m^2 s^-1] - real :: heff ! Harmonic mean of layer thicknesses [m] - real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] - character(len=120) :: test_name ! Title of the unit test - integer :: k_top ! Index of cell containing top of boundary - real :: zeta_top ! Nondimension position - integer :: k_bot ! Index of cell containing bottom of boundary - real :: zeta_bot ! Nondimension position - near_boundary_unit_tests = .false. - - ! Unit tests for boundary_k_range - test_name = 'Surface boundary spans the entire top cell' - h_L = (/5.,5./) - call boundary_k_range(SURFACE, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 1., test_name, verbose) - - test_name = 'Surface boundary spans the entire column' - h_L = (/5.,5./) - call boundary_k_range(SURFACE, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) - - test_name = 'Bottom boundary spans the entire bottom cell' - h_L = (/5.,5./) - call boundary_k_range(BOTTOM, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0., 2, 1., test_name, verbose) - - test_name = 'Bottom boundary spans the entire column' - h_L = (/5.,5./) - call boundary_k_range(BOTTOM, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) - - test_name = 'Surface boundary intersects second layer' - h_L = (/10.,10./) - call boundary_k_range(SURFACE, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0.75, test_name, verbose) - - test_name = 'Surface boundary intersects first layer' - h_L = (/10.,10./) - call boundary_k_range(SURFACE, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 0.25, test_name, verbose) - - test_name = 'Bottom boundary intersects first layer' - h_L = (/10.,10./) - call boundary_k_range(BOTTOM, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0.75, 2, 1., test_name, verbose) - - test_name = 'Bottom boundary intersects second layer' - h_L = (/10.,10./) - call boundary_k_range(BOTTOM, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0.25, 2, 1., test_name, verbose) - - ! All cases in this section have hbl which are equal to the column thicknesses - test_name = 'Equal hbl and same layer thicknesses (gradient from right to left)' - hbl_L = 10; hbl_R = 10 - h_L = (/5.,5./) ; h_R = (/5.,5./) - phi_L = (/0.,0./) ; phi_R = (/1.,1./) - phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = (/1.,1./) - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) - - test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)' - hbl_L = 10.; hbl_R = 10. - h_L = (/5.,5./) ; h_R = (/5.,5./) - phi_L = (/1.,1./) ; phi_R = (/0.,0./) - phi_pp_L(1,1) = 1.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 1.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 0.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 1. - ppoly0_E_L(2,1) = 1.; ppoly0_E_L(2,2) = 1. - ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. - ppoly0_E_R(2,1) = 0.; ppoly0_E_R(2,2) = 0. - khtr_u = (/1.,1./) - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) - - test_name = 'Equal hbl and same layer thicknesses (no gradient)' - hbl_L = 10; hbl_R = 10 - h_L = (/5.,5./) ; h_R = (/5.,5./) - phi_L = (/1.,1./) ; phi_R = (/1.,1./) - phi_pp_L(1,1) = 1.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 1.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 1.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = (/1.,1./) - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) - - test_name = 'Equal hbl and different layer thicknesses (gradient right to left)' - hbl_L = 16.; hbl_R = 16. - h_L = (/10.,6./) ; h_R = (/6.,10./) - phi_L = (/0.,0./) ; phi_R = (/1.,1./) - phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = (/1.,1./) - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) - - test_name = 'Equal hbl and same layer thicknesses (diagonal tracer values)' - hbl_L = 10.; hbl_R = 10. - h_L = (/5.,5./) ; h_R = (/5.,5./) - phi_L = (/1.,0./) ; phi_R = (/0.,1./) - phi_pp_L(1,1) = 1.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 1. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = (/1.,1./) - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) - - test_name = 'Different hbl and different column thicknesses (gradient from right to left)' - hbl_L = 12; hbl_R = 20 - h_L = (/6.,6./) ; h_R = (/10.,10./) - phi_L = (/0.,0./) ; phi_R = (/1.,1./) - phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = (/1.,1./) - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) - - test_name = 'Different hbl and different layer thicknesses (gradient from right to left)' - hbl_L = 12; hbl_R = 20 - h_L = (/6.,6./) ; h_R = (/10.,10./) - phi_L = (/0.,0./) ; phi_R = (/1.,1./) - phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = (/1.,1./) - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) - - ! Cases where hbl < column thickness (polynomial coefficients specified for pseudo-linear reconstruction) - - test_name = 'hbl < column thickness, hbl same, constant concentration each column' - hbl_L = 2; hbl_R = 2 - h_L = (/1.,2./) ; h_R = (/1.,2./) - phi_L = (/0.,0./) ; phi_R = (/1.,1./) - phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - khtr_u = (/1.,1./) - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) - - test_name = 'hbl < column thickness, hbl same, linear profile right' - hbl_L = 2; hbl_R = 2 - h_L = (/1.,2./) ; h_R = (/1.,2./) - phi_L = (/0.,0./) ; phi_R = (/0.5,2./) - phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 1. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 2. - khtr_u = (/1.,1./) - ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 1. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. - method = 1 - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) -end function near_boundary_unit_tests - -!> Returns true if output of near-boundary unit tests does not match correct computed values -!! and conditionally writes results to stream -logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) - logical, intent(in) :: verbose !< If true, write results to stdout - character(len=80), intent(in) :: test_name !< Brief description of the unit test - integer, intent(in) :: nk !< Number of layers - real, dimension(nk), intent(in) :: F_calc !< Fluxes of the unitless tracer from the algorithm [s^-1] - real, dimension(nk), intent(in) :: F_ans !< Fluxes of the unitless tracer calculated by hand [s^-1] - ! Local variables - integer :: k - integer, parameter :: stdunit = 6 - - test_layer_fluxes = .false. - do k=1,nk - if ( F_calc(k) /= F_ans(k) ) then - test_layer_fluxes = .true. - write(stdunit,*) "UNIT TEST FAILED: ", test_name - write(stdunit,10) k, F_calc(k), F_ans(k) - elseif (verbose) then - write(stdunit,10) k, F_calc(k), F_ans(k) - endif - enddo - -10 format("Layer=",i3," F_calc=",f20.16," F_ans",f20.16) -end function test_layer_fluxes - -!> Return true if output of unit tests for boundary_k_range does not match answers -logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_ans, zeta_top_ans,& - k_bot_ans, zeta_bot_ans, test_name, verbose) - integer :: k_top !< Index of cell containing top of boundary - real :: zeta_top !< Nondimension position - integer :: k_bot !< Index of cell containing bottom of boundary - real :: zeta_bot !< Nondimension position - integer :: k_top_ans !< Index of cell containing top of boundary - real :: zeta_top_ans !< Nondimension position - integer :: k_bot_ans !< Index of cell containing bottom of boundary - real :: zeta_bot_ans !< Nondimension position - character(len=80) :: test_name !< Name of the unit test - logical :: verbose !< If true always print output - - integer, parameter :: stdunit = 6 - - test_boundary_k_range = k_top .ne. k_top_ans - test_boundary_k_range = test_boundary_k_range .or. (zeta_top .ne. zeta_top_ans) - test_boundary_k_range = test_boundary_k_range .or. (k_bot .ne. k_bot_ans) - test_boundary_k_range = test_boundary_k_range .or. (zeta_bot .ne. zeta_bot_ans) - - if (test_boundary_k_range) write(stdunit,*) "UNIT TEST FAILED: ", test_name - if (test_boundary_k_range .or. verbose) then - write(stdunit,20) "k_top", k_top, "k_top_ans", k_top_ans - write(stdunit,20) "k_bot", k_bot, "k_bot_ans", k_bot_ans - write(stdunit,30) "zeta_top", zeta_top, "zeta_top_ans", zeta_top_ans - write(stdunit,30) "zeta_bot", zeta_bot, "zeta_bot_ans", zeta_bot_ans - endif - - 20 format(A,"=",i3,X,A,"=",i3) - 30 format(A,"=",f20.16,X,A,"=",f20.16) - - -end function test_boundary_k_range -end module MOM_boundary_lateral_mixing diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 261d8d1315..4eb986bacd 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -22,6 +22,8 @@ module MOM_tracer_hor_diff use MOM_neutral_diffusion, only : neutral_diffusion_init, neutral_diffusion_end use MOM_neutral_diffusion, only : neutral_diffusion_CS use MOM_neutral_diffusion, only : neutral_diffusion_calc_coeffs, neutral_diffusion +use MOM_lateral_boundary_mixing, only : lateral_boundary_mixing_CS, lateral_boundary_mixing_init +use MOM_lateral_boundary_mixing, only : lateral_boundary_mixing use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chksum use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type From a4dbeb158d593744fd515a89c362196cba9cbf22 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 13 Sep 2019 14:32:26 -0600 Subject: [PATCH 011/103] Hook in lateral boundary mixing initialization - Pass diabatic CS through tracer_hor_diff_init and lateral_boundary_mixing_init. - Modify extract_diabatic_member to return KPP and ePBL CS - Finish initialization for lateral_boundary_mixing --- src/core/MOM.F90 | 2 +- .../vertical/MOM_diabatic_driver.F90 | 12 +- src/tracer/MOM_lateral_boundary_mixing.F90 | 667 ++++++++++++++++++ src/tracer/MOM_tracer_hor_diff.F90 | 14 +- 4 files changed, 688 insertions(+), 7 deletions(-) create mode 100644 src/tracer/MOM_lateral_boundary_mixing.F90 diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 301969ed50..fe170563a4 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2362,7 +2362,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif call tracer_advect_init(Time, G, param_file, diag, CS%tracer_adv_CSp) - call tracer_hor_diff_init(Time, G, param_file, diag, CS%tv%eqn_of_state, & + call tracer_hor_diff_init(Time, G, param_file, diag, CS%tv%eqn_of_state, CS%diabatic_CSp, & CS%tracer_diff_CSp) call lock_tracer_registry(CS%tracer_Reg) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 25d4eadb7d..1c2e23c9d8 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -2397,19 +2397,23 @@ end subroutine legacy_diabatic !> Returns pointers or values of members within the diabatic_CS type. For extensibility, !! each returned argument is an optional argument subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, & - evap_CFL_limit, minimum_forcing_depth) - type(diabatic_CS), intent(in ) :: CS !< module control structure + evap_CFL_limit, minimum_forcing_depth, KPP_CSp, energetic_PBL_CSp) + type(diabatic_CS), intent(in ) :: CS !< module control structure ! All output arguments are optional type(opacity_CS), optional, pointer :: opacity_CSp !< A pointer to be set to the opacity control structure type(optics_type), optional, pointer :: optics_CSp !< A pointer to be set to the optics control structure + type(KPP_CS), optional, pointer :: KPP_CSp !< A pointer to be set to the KPP CS + type(energetic_PBL_CS), optional, pointer :: energetic_PBL_CSp !< A pointer to be set to the ePBL CS real, optional, intent( out) :: evap_CFL_limit ! CS%opacity_CSp - if (present(optics_CSp)) optics_CSp => CS%optics + if (present(opacity_CSp)) opacity_CSp => CS%opacity_CSp + if (present(optics_CSp)) optics_CSp => CS%optics + if (present(KPP_CSp)) KPP_CSp => CS%KPP_CSp + if (present(energetic_PBL_CSp)) energetic_PBL_CSp => CS%energetic_PBL_CSp ! Constants within diabatic_CS if (present(evap_CFL_limit)) evap_CFL_limit = CS%evap_CFL_limit diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 new file mode 100644 index 0000000000..4e4cc9f455 --- /dev/null +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -0,0 +1,667 @@ +!> Calculate and apply diffusive fluxes as a parameterization of lateral mixing (non-neutral) by +!! mesoscale eddies near the top and bottom boundary layers of the ocean. +module MOM_lateral_boundary_mixing + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_diag_mediator, only : post_data, register_diag_field +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_grid, only : ocean_grid_type +use MOM_remapping, only : remapping_CS, initialize_remapping +use MOM_remapping, only : extract_member_remapping_CS, build_reconstructions_1d +use MOM_remapping, only : average_value_ppoly, remappingSchemesDoc, remappingDefaultScheme +use MOM_tracer_registry, only : tracer_registry_type, tracer_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS +use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS +use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member + +implicit none ; private + +public near_boundary_unit_tests, lateral_boundary_mixing, lateral_boundary_mixing_init + +! Private parameters to avoid doing string comparisons for bottom or top boundary layer +integer, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface bopundary +integer, parameter :: BOTTOM = 1 !< Set a value that corresponds to the bottom boundary +#include + +type, public :: lateral_boundary_mixing_CS ; private + integer :: method !< Determine which of the three methods calculate + !! and apply near boundary layer fluxes + !! 1. bulk-layer approach + !! 2. Along layer + !! 3. Decomposition onto pressure levels + integer :: deg !< Degree of polynomial reconstruction + integer :: surface_boundary_scheme !< Which boundary layer scheme to use + !! 1. ePBL; 2. KPP + type(remapping_CS) :: remap_CS !< Control structure to hold remapping configuration + type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to get BLD + type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure needed to get MLD + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. +end type lateral_boundary_mixing_CS + +! This include declares and sets the variable "version". +#include "version_variable.h" +character(len=40) :: mdl = "MOM_lateral_boundary_mixing" + +contains + +!> Initialization routine that reads runtime parameters and sets up pointers to other control structures that might be +!! needed for lateral boundary mixing +logical function lateral_boundary_mixing_init(Time, G, param_file, diag, diabatic_CSp, CS) + type(time_type), target, intent(in) :: Time !< Time structure + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(diabatic_CS), pointer :: diabatic_CSp !< KPP control structure needed to get BLD + type(lateral_boundary_mixing_CS), pointer :: CS !< Lateral boundary mixing control structure + + character(len=80) :: string ! Temporary strings + logical :: boundary_extrap + + if (ASSOCIATED(CS)) then + call MOM_error(FATAL, "lateral_boundary_mixing_init called with associated control structure.") + return + endif + + ! Log this module and master switch for turning it on/off + call log_version(param_file, mdl, version, & + "This module implements lateral boundary mixing of tracers") + call get_param(param_file, mdl, "USE_LATERAL_BOUNDARY_MIXING", lateral_boundary_mixing_init, & + "If true, enables the lateral boundary mixing module.", & + default=.false.) + + if (.not. lateral_boundary_mixing_init) then + return + endif + + allocate(CS) + CS%diag => diag + call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) + call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) + + CS%surface_boundary_scheme = -1 + if ( ASSOCIATED(CS%energetic_PBL_CSp) ) CS%surface_boundary_scheme = 1 + if ( ASSOCIATED(CS%KPP_CSp) ) CS%surface_boundary_scheme = 2 + if (CS%surface_boundary_scheme < 0) then + call MOM_error(FATAL,"Lateral boundary mixing is true, but no valid boundary layer scheme was found") + endif + + ! Read all relevant parameters and write them to the model log. + call get_param(param_file, mdl, "LATERAL_BOUNDARY_METHOD", CS%method, & + "Determine how to apply near-boundary lateral mixing of tracers"//& + "1. Bulk layer approach"//& + "2. Along layer approach"//& + "3. Decomposition on to pressure levels", default=1) + call get_param(param_file, mdl, "LBM_BOUNDARY_EXTRAP", boundary_extrap, & + "Use boundary extrapolation in LBM code", & + default=.false.) + call get_param(param_file, mdl, "LBM_REMAPPING_SCHEME", string, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: "//& + trim(remappingSchemesDoc), default=remappingDefaultScheme) + call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ) + call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) + +end function lateral_boundary_mixing_init + +!> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. Two different methods +!! Method 1: Calculate fluxes from bulk layer integrated quantities +subroutine lateral_boundary_mixing(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) + type(ocean_grid_type), intent(inout) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [m2] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [m2] + real, intent(in) :: dt !< Tracer time step * I_numitts + !! (I_numitts in tracer_hordiff) + type(tracer_registry_type), pointer :: Reg !< Tracer registry + type(lateral_boundary_mixing_CS), intent(in) :: CS !< Control structure for this module + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [m] + + + + + + + +end subroutine lateral_boundary_mixing + +!< Calculate bulk layer value of a scalar quantity as the thickness weighted average +real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coefs, method, k_top, zeta_top, k_bot, zeta_bot) + integer :: boundary !< SURFACE or BOTTOM [nondim] + integer :: nk !< Number of layers [nondim] + integer :: deg !< Degree of polynomial [nondim] + real, dimension(nk) :: h !< Layer thicknesses [m] + real :: hBLT !< Depth of the mixing layer [m] + real, dimension(nk) :: phi !< Scalar quantity + real, dimension(nk,2) :: ppoly0_E(:,:) !< Edge value of polynomial + real, dimension(nk,deg+1) :: ppoly0_coefs(:,:) !< Coefficients of polynomial + integer :: method !< Remapping scheme to use + + integer :: k_top !< Index of the first layer within the boundary + real :: zeta_top !< Fraction of the layer encompassed by the bottom boundary layer + !! (0 if none, 1. if all). For the surface, this is always 0. because + !! integration starts at the surface [nondim] + integer :: k_bot !< Index of the last layer within the boundary + real :: zeta_bot !< Fraction of the layer encompassed by the surface boundary layer + !! (0 if none, 1. if all). For the bottom boundary layer, this is always 1. + !! because integration starts at the bottom [nondim] + ! Local variables + real :: htot ! Running sum of the thicknesses (top to bottom) + integer :: k + + + htot = 0. + bulk_average = 0. + if (boundary == SURFACE) then + htot = (h(k_bot) * zeta_bot) + bulk_average = average_value_ppoly( nk, phi, ppoly0_E, ppoly0_coefs, method, k_bot, 0., zeta_bot) * htot + do k = k_bot-1,1,-1 + bulk_average = bulk_average + phi(k)*h(k) + htot = htot + h(k) + enddo + elseif (boundary == BOTTOM) then + htot = (h(k_top) * zeta_top) + ! (note 1-zeta_top because zeta_top is the fraction of the layer) + bulk_average = average_value_ppoly( nk, phi, ppoly0_E, ppoly0_coefs, method, k_top, (1.-zeta_top), 1.) * htot + do k = k_top+1,nk + bulk_average = bulk_average + phi(k)*h(k) + htot = htot + h(k) + enddo + else + call MOM_error(FATAL, "bulk_average: a valid boundary type must be provided.") + endif + + if (htot > 0.) then + bulk_average = bulk_average / hBLT + else + bulk_average = 0. + endif + +end function bulk_average + +!> Calculate the harmonic mean of two quantities +real function harmonic_mean(h1,h2) + real :: h1 !< Scalar quantity + real :: h2 !< Scalar quantity + + harmonic_mean = 2.*(h1*h2)/(h1+h2) +end function harmonic_mean + +!> Find the k-index range corresponding to the layers that are within the boundary-layer region +subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_bot) + integer, intent(in ) :: boundary !< SURFACE or BOTTOM [nondim] + integer, intent(in ) :: nk !< Number of layers [nondim] + real, dimension(nk), intent(in ) :: h !< Layer thicknesses of the coluymn [m] + real, intent(in ) :: hbl !< Thickness of the boundary layer [m] + !! If surface, with respect to zbl_ref = 0. + !! If bottom, with respect to zbl_ref = SUM(h) + integer, intent( out) :: k_top !< Index of the first layer within the boundary + real, intent( out) :: zeta_top !< Distance from the top of a layer to the intersection of the + !! top extent of the boundary layer (0 at top, 1 at bottom) [nondim] + integer, intent( out) :: k_bot !< Index of the last layer within the boundary + real, intent( out) :: zeta_bot !< Distance of the lower layer to the boundary layer depth + !! (0 at top, 1 at bottom) [nondim] + ! Local variables + real :: htot + integer :: k + ! Surface boundary layer + if ( boundary == SURFACE ) then + k_top = 1 + zeta_top = 0. + htot = 0. + do k=1,nk + htot = htot + h(k) + if ( htot >= hbl) then + k_bot = k + zeta_bot = 1 - (htot - hbl)/h(k) + return + endif + enddo + ! Bottom boundary layer + elseif ( boundary == BOTTOM ) then + k_bot = nk + zeta_bot = 1. + htot = 0. + do k=nk,1,-1 + htot = htot + h(k) + if (htot >= hbl) then + k_top = k + zeta_top = 1 - (htot - hbl)/h(k) + return + endif + enddo + else + call MOM_error(FATAL,"Houston, we've had a problem in boundary_k_range") + endif + +end subroutine boundary_k_range + +!> Calculate the near-boundary diffusive fluxes calculated from a 'bulk model' +subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, & + ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + integer, intent(in ) :: nk !< Number of layers [nondim] + integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] + real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [m] + real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [m] + real, intent(in ) :: hbl_L !< Thickness of the boundary boundary + !! layer (left) [m] + real, intent(in ) :: hbl_R !< Thickness of the boundary boundary + !! layer (left) [m] + real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [ nondim m^-3 ] + real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [ nondim m^-3 ] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [ nondim m^-3 ] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [ nondim m^-3 ] + real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [ nondim ] + real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] + integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] + real, dimension(nk), intent(in ) :: khtr_u !< Horizontal diffusivities at U-point [m^2 s^-1] + real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [trunit s^-1] + ! Local variables + real :: F_bulk ! Total diffusive flux across the U point [trunit s^-1] + real, dimension(nk) :: h_means ! Calculate the layer-wise harmonic means [m] + real, dimension(nk) :: h_u ! Thickness at the u-point [m] + real :: hbl_u ! Boundary layer Thickness at the u-point [m] + real :: khtr_avg ! Thickness-weighted diffusivity at the u-point [m^2 s^-1] + real :: heff ! Harmonic mean of layer thicknesses [m] + real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] + real :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) + ! [trunit m^-3 ] + real :: htot ! Total column thickness [m] + integer :: k, k_min, k_max + integer :: k_top_L, k_bot_L, k_top_u + integer :: k_top_R, k_bot_R, k_bot_u + real :: zeta_top_L, zeta_top_R, zeta_top_u + real :: zeta_bot_L, zeta_bot_R, zeta_bot_u + real :: h_work_L, h_work_R ! dummy variables + + ! Calculate vertical indices containing the boundary layer + call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) + call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) + ! Calculate bulk averages of various quantities + phi_L_avg = bulk_average(boundary, nk, deg, h_L, hbl_L, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, zeta_top_L,& + k_bot_L, zeta_bot_L) + phi_R_avg = bulk_average(boundary, nk, deg, h_R, hbl_R, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, zeta_top_R,& + k_bot_R, zeta_bot_R) + do k=1,nk + h_u(k) = 0.5 * (h_L(k) + h_R(k)) + enddo + hbl_u = 0.5*(hbl_L + hbl_R) + call boundary_k_range(boundary, nk, h_u, hbl_u, k_top_u, zeta_top_u, k_bot_u, zeta_bot_u) + if ( boundary == SURFACE ) then + khtr_avg = (h_u(k_bot_u) * zeta_bot_u) * khtr_u(k_bot_u) + do k=k_bot_u-1,1,-1 + khtr_avg = khtr_avg + h_u(k) * khtr_u(k) + enddo + elseif ( boundary == BOTTOM ) then + khtr_avg = (h_u(k_top_u) * (1.-zeta_top_u)) * khtr_u(k_top_u) + do k=k_top_u+1,nk + khtr_avg = khtr_avg + h_u(k) * khtr_u(k) + enddo + endif + + khtr_avg = khtr_avg / hbl_u + + ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities + heff = harmonic_mean(hbl_L, hbl_R) + F_bulk = -(khtr_avg * heff) * (phi_R_avg - phi_L_avg) + ! Calculate the layerwise sum of the vertical effective thickness. This is different than the heff calculated + ! above, but is used as a way to decompose decompose the fluxes onto the individual layers + h_means(:) = 0. + + if (boundary == SURFACE) then + k_min = MIN(k_bot_L, k_bot_R) + + ! left hand side + if (k_bot_L == k_min) then + h_work_L = h_L(k_min) * zeta_bot_L + else + h_work_L = h_L(k_min) + endif + + ! right hand side + if (k_bot_R == k_min) then + h_work_R = h_R(k_min) * zeta_bot_R + else + h_work_R = h_R(k_min) + endif + + h_means(k_min) = harmonic_mean(h_work_L,h_work_R) + + do k=1,k_min-1 + h_means(k) = harmonic_mean(h_L(k),h_R(k)) + enddo + endif + + if (boundary == BOTTOM) then + k_max = MAX(k_top_L, k_top_R) + + ! left hand side + if (k_top_L == k_max) then + h_work_L = h_L(k_max) * zeta_top_L + else + h_work_L = h_L(k_max) + endif + + ! right hand side + if (k_top_R == k_max) then + h_work_R = h_R(k_max) * zeta_top_R + else + h_work_R = h_R(k_max) + endif + + h_means(k_max) = harmonic_mean(h_work_L,h_work_R) + + do k=nk,k_max+1,-1 + h_means(k) = harmonic_mean(h_L(k),h_R(k)) + enddo + endif + + inv_heff = 1./SUM(h_means) + ! Decompose the bulk flux onto the individual layers + do k=1,nk + if ( SIGN(1.,F_bulk) == SIGN(1., -(phi_R(k)-phi_L(k))) ) then + F_layer(k) = F_bulk * (h_means(k)*inv_heff) + else + F_layer(k) = 0. + endif + enddo + +end subroutine layer_fluxes_bulk_method + +!> Unit tests for near-boundary horizontal mixing +logical function near_boundary_unit_tests( verbose ) + logical, intent(in) :: verbose !< If true, output additional information for debugging unit tests + + ! Local variables + integer, parameter :: nk = 2 ! Number of layers + integer, parameter :: deg = 1 ! Degree of reconstruction (linear here) + integer, parameter :: method = 1 ! Method used for integrating polynomials + real, dimension(nk) :: phi_L, phi_R ! Tracer values (left and right column) [ nondim m^-3 ] + real, dimension(nk) :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) + real, dimension(nk,deg+1) :: phi_pp_L, phi_pp_R ! Coefficients for the linear pseudo-reconstructions + ! [ nondim m^-3 ] + + real, dimension(nk,2) :: ppoly0_E_L, ppoly0_E_R! Polynomial edge values (left and right) [concentration] + real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] + real, dimension(nk) :: khtr_u ! Horizontal diffusivities at U-point [m^2 s^-1] + real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] + real :: F_bulk ! Total diffusive flux across the U point [nondim s^-1] + real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [nondim s^-1] + real :: h_u, hblt_u ! Thickness at the u-point [m] + real :: khtr_avg ! Thickness-weighted diffusivity at the u-point [m^2 s^-1] + real :: heff ! Harmonic mean of layer thicknesses [m] + real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] + character(len=120) :: test_name ! Title of the unit test + integer :: k_top ! Index of cell containing top of boundary + real :: zeta_top ! Nondimension position + integer :: k_bot ! Index of cell containing bottom of boundary + real :: zeta_bot ! Nondimension position + near_boundary_unit_tests = .false. + + ! Unit tests for boundary_k_range + test_name = 'Surface boundary spans the entire top cell' + h_L = (/5.,5./) + call boundary_k_range(SURFACE, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 1., test_name, verbose) + + test_name = 'Surface boundary spans the entire column' + h_L = (/5.,5./) + call boundary_k_range(SURFACE, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) + + test_name = 'Bottom boundary spans the entire bottom cell' + h_L = (/5.,5./) + call boundary_k_range(BOTTOM, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0., 2, 1., test_name, verbose) + + test_name = 'Bottom boundary spans the entire column' + h_L = (/5.,5./) + call boundary_k_range(BOTTOM, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) + + test_name = 'Surface boundary intersects second layer' + h_L = (/10.,10./) + call boundary_k_range(SURFACE, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0.75, test_name, verbose) + + test_name = 'Surface boundary intersects first layer' + h_L = (/10.,10./) + call boundary_k_range(SURFACE, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 0.25, test_name, verbose) + + test_name = 'Bottom boundary intersects first layer' + h_L = (/10.,10./) + call boundary_k_range(BOTTOM, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0.75, 2, 1., test_name, verbose) + + test_name = 'Bottom boundary intersects second layer' + h_L = (/10.,10./) + call boundary_k_range(BOTTOM, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0.25, 2, 1., test_name, verbose) + + ! All cases in this section have hbl which are equal to the column thicknesses + test_name = 'Equal hbl and same layer thicknesses (gradient from right to left)' + hbl_L = 10; hbl_R = 10 + h_L = (/5.,5./) ; h_R = (/5.,5./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) + + test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)' + hbl_L = 10.; hbl_R = 10. + h_L = (/5.,5./) ; h_R = (/5.,5./) + phi_L = (/1.,1./) ; phi_R = (/0.,0./) + phi_pp_L(1,1) = 1.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 1.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 0.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 1. + ppoly0_E_L(2,1) = 1.; ppoly0_E_L(2,2) = 1. + ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. + ppoly0_E_R(2,1) = 0.; ppoly0_E_R(2,2) = 0. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) + + test_name = 'Equal hbl and same layer thicknesses (no gradient)' + hbl_L = 10; hbl_R = 10 + h_L = (/5.,5./) ; h_R = (/5.,5./) + phi_L = (/1.,1./) ; phi_R = (/1.,1./) + phi_pp_L(1,1) = 1.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 1.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 1.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) + + test_name = 'Equal hbl and different layer thicknesses (gradient right to left)' + hbl_L = 16.; hbl_R = 16. + h_L = (/10.,6./) ; h_R = (/6.,10./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) + + test_name = 'Equal hbl and same layer thicknesses (diagonal tracer values)' + hbl_L = 10.; hbl_R = 10. + h_L = (/5.,5./) ; h_R = (/5.,5./) + phi_L = (/1.,0./) ; phi_R = (/0.,1./) + phi_pp_L(1,1) = 1.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 1. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) + + test_name = 'Different hbl and different column thicknesses (gradient from right to left)' + hbl_L = 12; hbl_R = 20 + h_L = (/6.,6./) ; h_R = (/10.,10./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) + + test_name = 'Different hbl and different layer thicknesses (gradient from right to left)' + hbl_L = 12; hbl_R = 20 + h_L = (/6.,6./) ; h_R = (/10.,10./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) + + ! Cases where hbl < column thickness (polynomial coefficients specified for pseudo-linear reconstruction) + + test_name = 'hbl < column thickness, hbl same, constant concentration each column' + hbl_L = 2; hbl_R = 2 + h_L = (/1.,2./) ; h_R = (/1.,2./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + khtr_u = (/1.,1./) + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) + + test_name = 'hbl < column thickness, hbl same, linear profile right' + hbl_L = 2; hbl_R = 2 + h_L = (/1.,2./) ; h_R = (/1.,2./) + phi_L = (/0.,0./) ; phi_R = (/0.5,2./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 1. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 2. + khtr_u = (/1.,1./) + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. + call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) +end function near_boundary_unit_tests + +!> Returns true if output of near-boundary unit tests does not match correct computed values +!! and conditionally writes results to stream +logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=80), intent(in) :: test_name !< Brief description of the unit test + integer, intent(in) :: nk !< Number of layers + real, dimension(nk), intent(in) :: F_calc !< Fluxes of the unitless tracer from the algorithm [s^-1] + real, dimension(nk), intent(in) :: F_ans !< Fluxes of the unitless tracer calculated by hand [s^-1] + ! Local variables + integer :: k + integer, parameter :: stdunit = 6 + + test_layer_fluxes = .false. + do k=1,nk + if ( F_calc(k) /= F_ans(k) ) then + test_layer_fluxes = .true. + write(stdunit,*) "UNIT TEST FAILED: ", test_name + write(stdunit,10) k, F_calc(k), F_ans(k) + elseif (verbose) then + write(stdunit,10) k, F_calc(k), F_ans(k) + endif + enddo + +10 format("Layer=",i3," F_calc=",f20.16," F_ans",f20.16) +end function test_layer_fluxes + +!> Return true if output of unit tests for boundary_k_range does not match answers +logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_ans, zeta_top_ans,& + k_bot_ans, zeta_bot_ans, test_name, verbose) + integer :: k_top !< Index of cell containing top of boundary + real :: zeta_top !< Nondimension position + integer :: k_bot !< Index of cell containing bottom of boundary + real :: zeta_bot !< Nondimension position + integer :: k_top_ans !< Index of cell containing top of boundary + real :: zeta_top_ans !< Nondimension position + integer :: k_bot_ans !< Index of cell containing bottom of boundary + real :: zeta_bot_ans !< Nondimension position + character(len=80) :: test_name !< Name of the unit test + logical :: verbose !< If true always print output + + integer, parameter :: stdunit = 6 + + test_boundary_k_range = k_top .ne. k_top_ans + test_boundary_k_range = test_boundary_k_range .or. (zeta_top .ne. zeta_top_ans) + test_boundary_k_range = test_boundary_k_range .or. (k_bot .ne. k_bot_ans) + test_boundary_k_range = test_boundary_k_range .or. (zeta_bot .ne. zeta_bot_ans) + + if (test_boundary_k_range) write(stdunit,*) "UNIT TEST FAILED: ", test_name + if (test_boundary_k_range .or. verbose) then + write(stdunit,20) "k_top", k_top, "k_top_ans", k_top_ans + write(stdunit,20) "k_bot", k_bot, "k_bot_ans", k_bot_ans + write(stdunit,30) "zeta_top", zeta_top, "zeta_top_ans", zeta_top_ans + write(stdunit,30) "zeta_bot", zeta_bot, "zeta_bot_ans", zeta_bot_ans + endif + + 20 format(A,"=",i3,X,A,"=",i3) + 30 format(A,"=",f20.16,X,A,"=",f20.16) + + +end function test_boundary_k_range +end module MOM_lateral_boundary_mixing diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 4eb986bacd..eb62a1e07d 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -11,6 +11,7 @@ module MOM_tracer_hor_diff use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : pass_vector use MOM_debugging, only : hchksum, uvchksum +use MOM_diabatic_driver, only : diabatic_CS use MOM_EOS, only : calculate_density, EOS_type use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery @@ -58,7 +59,11 @@ module MOM_tracer_hor_diff !! the CFL limit is not violated. logical :: use_neutral_diffusion !< If true, use the neutral_diffusion module from within !! tracer_hor_diff. + logical :: use_lateral_boundary_mixing !< If true, use the lateral_boundary_mixing module from within + !! tracer_hor_diff. type(neutral_diffusion_CS), pointer :: neutral_diffusion_CSp => NULL() !< Control structure for neutral diffusion. + type(lateral_boundary_mixing_CS), pointer :: lateral_boundary_mixing_CSp => NULL() !< Control structure for lateral + !! boundary mixing. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. logical :: debug !< If true, write verbose checksums for debugging purposes. @@ -1377,11 +1382,12 @@ end subroutine tracer_epipycnal_ML_diff !> Initialize lateral tracer diffusion module -subroutine tracer_hor_diff_init(Time, G, param_file, diag, EOS, CS) +subroutine tracer_hor_diff_init(Time, G, param_file, diag, EOS, diabatic_CSp, CS) type(time_type), target, intent(in) :: Time !< current model time type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(diag_ctrl), target, intent(inout) :: diag !< diagnostic control type(EOS_type), target, intent(in) :: EOS !< Equation of state CS + type(diabatic_CS), pointer, intent(in) :: diabatic_CSp !< Equation of state CS type(param_file_type), intent(in) :: param_file !< parameter file type(tracer_hor_diff_CS), pointer :: CS !< horz diffusion control structure @@ -1448,9 +1454,13 @@ subroutine tracer_hor_diff_init(Time, G, param_file, diag, EOS, CS) units="nondim", default=1.0) endif - CS%use_neutral_diffusion = neutral_diffusion_init(Time, G, param_file, diag, EOS, CS%neutral_diffusion_CSp) + CS%use_neutral_diffusion = neutral_diffusion_init(Time, G, param_file, diag, EOS, CS%neutral_diffusion_CSp ) if (CS%use_neutral_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & "USE_NEUTRAL_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") + CS%use_lateral_boundary_mixing = lateral_boundary_mixing_init(Time, G, param_file, diag, diabatic_CSp, & + CS%lateral_boundary_mixing_CSp) + if (CS%use_neutral_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & + "USE_LATERAL_BOUNDARY_MIXING and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) From ae6529ea82ccac5a656b051edabe789891fe19ce Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 13 Sep 2019 15:55:50 -0600 Subject: [PATCH 012/103] Hook lateral boundary mixing into tracer_hor_diff The new lateral boundary mixing routine has been added into tracer_hor_diff and needs to be tested in a 'real' configuration. This only works with KPP for now because ePBL needs US passed which is not currently implemented in the API for tracer_hor_diff --- src/tracer/MOM_lateral_boundary_mixing.F90 | 77 +++++++++++++++++----- src/tracer/MOM_tracer_hor_diff.F90 | 24 +++++++ 2 files changed, 84 insertions(+), 17 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 4e4cc9f455..585a4726fb 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -126,13 +126,56 @@ subroutine lateral_boundary_mixing(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) type(tracer_registry_type), pointer :: Reg !< Tracer registry type(lateral_boundary_mixing_CS), intent(in) :: CS !< Control structure for this module ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [m] - - - - - + real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [m] + real, dimension(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1) :: ppoly0_coefs !< Coefficients of polynomial + real, dimension(SZI_(G),SZJ_(G),SZK_(G),2) :: ppoly0_E !< Edge values from reconstructions + real, dimension(SZK_(G),CS%deg+1) :: ppoly_S !< Slopes from reconstruction (placeholder) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx ! Zonal flux of tracer [H conc ~> m conc or conc kg m-2] + real, dimension(SZI_(G),SZJ_(G)) :: uFLx_bulk ! Total calculated bulk-layer u-flux for the tracer + real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx ! Meridional flux of tracer + real, dimension(SZI_(G),SZJB_(G)) :: vFlx_bulk ! Total calculated bulk-layer v-flux for the tracer + type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer + integer :: remap_method !< Reconstruction method + integer :: i,j,k,m + + hbl(:,:) = 0. + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) +! if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%KPP_CSp, G, US, hbl) + + do m = 1,Reg%ntr + tracer => Reg%tr(m) + do j = G%jsc-1, G%jec+1 + ! Interpolate state to interface + do i = G%isc-1, G%iec+1 + call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), tracer%t(i,j,:), ppoly0_coefs(i,j,:,:), & + ppoly0_E(i,j,:,:), ppoly_S, remap_method, GV%H_subroundoff, GV%H_subroundoff) + enddo + enddo + ! Diffusive fluxes in the i-direction + uFlx(:,:,:) = 0. + vFlx(:,:,:) = 0. + if ( CS%method == 1 ) then + do j=G%jsc,G%jec + do i=G%isc-1,G%iec + call layer_fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,j,:), h(i+1,j,:), hbl(i,j), hbl(i+1,j), & + tracer%t(i,j,:), tracer%t(i+1,j,:), ppoly0_coefs(i,j,:,:), ppoly0_coefs(i+1,j,:,:), ppoly0_E(i,j,:,:), & + ppoly0_E(i+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:)) + enddo + enddo + do J=G%jsc-1,G%jec + do i=G%isc,G%iec + call layer_fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & + ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:)) + enddo + enddo + endif + ! Update the tracer fluxes + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + tracer%t(i,j,k) = tracer%t(i,j,k) + (( (uFlx(I-1,j,k)-uFlx(I,j,k)) ) + ( (vFlx(i,J,k)-vFlx(i,J+1,k) ) )) + enddo ; enddo ; enddo + enddo end subroutine lateral_boundary_mixing @@ -249,7 +292,7 @@ end subroutine boundary_k_range !> Calculate the near-boundary diffusive fluxes calculated from a 'bulk model' subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, & - ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] @@ -267,9 +310,9 @@ subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, p real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] real, dimension(nk), intent(in ) :: khtr_u !< Horizontal diffusivities at U-point [m^2 s^-1] + real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux [trunit s^-1] real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [trunit s^-1] ! Local variables - real :: F_bulk ! Total diffusive flux across the U point [trunit s^-1] real, dimension(nk) :: h_means ! Calculate the layer-wise harmonic means [m] real, dimension(nk) :: h_u ! Thickness at the u-point [m] real :: hbl_u ! Boundary layer Thickness at the u-point [m] @@ -466,7 +509,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = (/1.,1./) call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)' @@ -483,7 +526,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(2,1) = 0.; ppoly0_E_R(2,2) = 0. khtr_u = (/1.,1./) call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) test_name = 'Equal hbl and same layer thicknesses (no gradient)' @@ -500,7 +543,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = (/1.,1./) call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) test_name = 'Equal hbl and different layer thicknesses (gradient right to left)' @@ -517,7 +560,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = (/1.,1./) call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) test_name = 'Equal hbl and same layer thicknesses (diagonal tracer values)' @@ -534,7 +577,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = (/1.,1./) call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) test_name = 'Different hbl and different column thicknesses (gradient from right to left)' @@ -551,7 +594,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = (/1.,1./) call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) test_name = 'Different hbl and different layer thicknesses (gradient from right to left)' @@ -568,7 +611,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = (/1.,1./) call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) ! Cases where hbl < column thickness (polynomial coefficients specified for pseudo-linear reconstruction) @@ -583,7 +626,7 @@ logical function near_boundary_unit_tests( verbose ) phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. khtr_u = (/1.,1./) call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) test_name = 'hbl < column thickness, hbl same, linear profile right' @@ -600,7 +643,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) end function near_boundary_unit_tests diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index eb62a1e07d..8dc02c3a2a 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -383,6 +383,30 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_fla do J=js-1,je ; do i=is,ie ; Reg%Tr(m)%df2d_y(i,J) = 0.0 ; enddo ; enddo endif enddo + + if (CS%use_lateral_boundary_mixing) then + + if (CS%show_call_tree) call callTree_waypoint("Calling lateral boundary mixing (tracer_hordiff)") + + call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) + + do J=js-1,je ; do i=is,ie + Coef_y(i,J) = I_numitts * khdt_y(i,J) + enddo ; enddo + do j=js,je + do I=is-1,ie + Coef_x(I,j) = I_numitts * khdt_x(I,j) + enddo + enddo + + do itt=1,num_itts + if (CS%show_call_tree) call callTree_waypoint("Calling lateral boundary mixing (tracer_hordiff)",itt) + if (itt>1) then ! Update halos for subsequent iterations + call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) + endif + call lateral_boundary_mixing(G, GV, h, Coef_x, Coef_y, I_numitts*dt, Reg, CS%lateral_boundary_mixing_CSp) + enddo ! itt + endif if (CS%use_neutral_diffusion) then From df938a1bb3378a26a0d03fee78035fcbede02599 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 13 Sep 2019 16:33:32 -0600 Subject: [PATCH 013/103] Add masking in lateral_boundary_fluxes Calculation of fluxes needs to be masked otherwise NaNs will definitely be calcualted --- src/tracer/MOM_lateral_boundary_mixing.F90 | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 585a4726fb..7d9fd2f210 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -157,23 +157,29 @@ subroutine lateral_boundary_mixing(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) if ( CS%method == 1 ) then do j=G%jsc,G%jec do i=G%isc-1,G%iec - call layer_fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,j,:), h(i+1,j,:), hbl(i,j), hbl(i+1,j), & - tracer%t(i,j,:), tracer%t(i+1,j,:), ppoly0_coefs(i,j,:,:), ppoly0_coefs(i+1,j,:,:), ppoly0_E(i,j,:,:), & - ppoly0_E(i+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:)) + if (G%mask2dCu(I,j)>0.) then + call layer_fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,j,:), h(i+1,j,:), hbl(i,j), hbl(i+1,j), & + tracer%t(i,j,:), tracer%t(i+1,j,:), ppoly0_coefs(i,j,:,:), ppoly0_coefs(i+1,j,:,:), ppoly0_E(i,j,:,:), & + ppoly0_E(i+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:)) + endif enddo enddo do J=G%jsc-1,G%jec do i=G%isc,G%iec - call layer_fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & - tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & - ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:)) + if (G%mask2dCv(i,J)>0.) then + call layer_fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & + ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:)) + endif enddo enddo endif ! Update the tracer fluxes do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (G%mask2dT(i,j)>0.) then tracer%t(i,j,k) = tracer%t(i,j,k) + (( (uFlx(I-1,j,k)-uFlx(I,j,k)) ) + ( (vFlx(i,J,k)-vFlx(i,J+1,k) ) )) + endif enddo ; enddo ; enddo enddo From 8a4ed840dc9a9b0273f4c9a7cc31b923b07f7106 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 13 Sep 2019 16:43:05 -0600 Subject: [PATCH 014/103] Guard against case where the boundary layer is 0 on one column --- src/tracer/MOM_lateral_boundary_mixing.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 7d9fd2f210..e9e408326f 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -334,7 +334,11 @@ subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, p real :: zeta_top_L, zeta_top_R, zeta_top_u real :: zeta_bot_L, zeta_bot_R, zeta_bot_u real :: h_work_L, h_work_R ! dummy variables - + if (hbl_L == 0. .or. hbl_R == 0.) then + F_bulk = 0. + F_layer(:) = 0. + return + endif ! Calculate vertical indices containing the boundary layer call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) From 8ab7aa8ef3c9640432e78112554ce47ed2db8729 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 13 Sep 2019 16:47:51 -0600 Subject: [PATCH 015/103] Convert diffusive flux convergence to a change in tracer --- src/tracer/MOM_lateral_boundary_mixing.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index e9e408326f..6f0cc03f6b 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -178,7 +178,7 @@ subroutine lateral_boundary_mixing(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) ! Update the tracer fluxes do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec if (G%mask2dT(i,j)>0.) then - tracer%t(i,j,k) = tracer%t(i,j,k) + (( (uFlx(I-1,j,k)-uFlx(I,j,k)) ) + ( (vFlx(i,J,k)-vFlx(i,J+1,k) ) )) + tracer%t(i,j,k) = tracer%t(i,j,k) + (( (uFlx(I-1,j,k)-uFlx(I,j,k)) ) + ( (vFlx(i,J,k)-vFlx(i,J+1,k) ) ))*(G%IareaT(i,j)/( h(i,j,k) + GV%H_subroundoff)) endif enddo ; enddo ; enddo enddo From 9b4d2c2bb59390399146346aceb995617105f384 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Sat, 14 Sep 2019 07:30:18 -0600 Subject: [PATCH 016/103] Only allocate KPP_CS if requested The CVMix KPP module would allocate it's control structure regardless of wthether KPP was used or not. The allocate statement has been moved down after USE_KPP has been parsed. --- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index f281a7b927..3f8734946e 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -196,7 +196,6 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) !! False => compute G'(1) as in LMD94 if (associated(CS)) call MOM_error(FATAL, 'MOM_CVMix_KPP, KPP_init: '// & 'Control structure has already been initialized') - allocate(CS) ! Read parameters call log_version(paramFile, mdl, version, 'This is the MOM wrapper to CVMix:KPP\n' // & @@ -207,6 +206,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) default=.false.) ! Forego remainder of initialization if not using this scheme if (.not. KPP_init) return + allocate(CS) call openParameterBlock(paramFile,'KPP') call get_param(paramFile, mdl, 'PASSIVE', CS%passiveMode, & From e5f96f424c23b581c77db4fdac7462c4a2bfd377 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Sat, 14 Sep 2019 07:33:48 -0600 Subject: [PATCH 017/103] Fix minor bugs in lateral boundary mixing - Indexing error in the y-direction led to a non-conservation of tracer - Extra guards added to avoid divisions by zero - Pass US through to lateral_boundary_mixing to enable compatibility with ePBL --- src/core/MOM.F90 | 8 +- src/tracer/MOM_lateral_boundary_mixing.F90 | 111 ++++++++++----------- src/tracer/MOM_tracer_hor_diff.F90 | 8 +- 3 files changed, 64 insertions(+), 63 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index fe170563a4..3bc3ce7eb5 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1087,7 +1087,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, h, Time_local) call advect_tracer(h, CS%uhtr, CS%vhtr, CS%OBC, CS%t_dyn_rel_adv, G, GV, & CS%tracer_adv_CSp, CS%tracer_Reg) - call tracer_hordiff(h, CS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, G, GV, & + call tracer_hordiff(h, CS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, G, GV, CS%US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) if (showCallTree) call callTree_waypoint("finished tracer advection/diffusion (step_MOM)") call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) @@ -1407,7 +1407,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, US, CS%VarMix) endif - call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, & + call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif endif @@ -1432,7 +1432,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, US, CS%VarMix) endif - call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, & + call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif endif @@ -1467,7 +1467,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS CS%h, eatr, ebtr, uhtr, vhtr) ! Perform offline diffusion if requested if (.not. skip_diffusion) then - call tracer_hordiff(h_end, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, & + call tracer_hordiff(h_end, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 6f0cc03f6b..077178f8d8 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -16,10 +16,11 @@ module MOM_lateral_boundary_mixing use MOM_remapping, only : extract_member_remapping_CS, build_reconstructions_1d use MOM_remapping, only : average_value_ppoly, remappingSchemesDoc, remappingDefaultScheme use MOM_tracer_registry, only : tracer_registry_type, tracer_type +use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS -use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member +use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member implicit none ; private @@ -31,7 +32,7 @@ module MOM_lateral_boundary_mixing #include type, public :: lateral_boundary_mixing_CS ; private - integer :: method !< Determine which of the three methods calculate + integer :: method !< Determine which of the three methods calculate !! and apply near boundary layer fluxes !! 1. bulk-layer approach !! 2. Along layer @@ -85,11 +86,9 @@ logical function lateral_boundary_mixing_init(Time, G, param_file, diag, diabati CS%diag => diag call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) - + CS%surface_boundary_scheme = -1 - if ( ASSOCIATED(CS%energetic_PBL_CSp) ) CS%surface_boundary_scheme = 1 - if ( ASSOCIATED(CS%KPP_CSp) ) CS%surface_boundary_scheme = 2 - if (CS%surface_boundary_scheme < 0) then + if ( .not. ASSOCIATED(CS%energetic_PBL_CSp) .and. .not. ASSOCIATED(CS%KPP_CSp) ) then call MOM_error(FATAL,"Lateral boundary mixing is true, but no valid boundary layer scheme was found") endif @@ -114,9 +113,10 @@ end function lateral_boundary_mixing_init !> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. Two different methods !! Method 1: Calculate fluxes from bulk layer integrated quantities -subroutine lateral_boundary_mixing(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) +subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) type(ocean_grid_type), intent(inout) :: G !< Grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [m2] @@ -125,24 +125,24 @@ subroutine lateral_boundary_mixing(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) !! (I_numitts in tracer_hordiff) type(tracer_registry_type), pointer :: Reg !< Tracer registry type(lateral_boundary_mixing_CS), intent(in) :: CS !< Control structure for this module - ! Local variables + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [m] real, dimension(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1) :: ppoly0_coefs !< Coefficients of polynomial real, dimension(SZI_(G),SZJ_(G),SZK_(G),2) :: ppoly0_E !< Edge values from reconstructions real, dimension(SZK_(G),CS%deg+1) :: ppoly_S !< Slopes from reconstruction (placeholder) real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx ! Zonal flux of tracer [H conc ~> m conc or conc kg m-2] - real, dimension(SZI_(G),SZJ_(G)) :: uFLx_bulk ! Total calculated bulk-layer u-flux for the tracer + real, dimension(SZI_(G),SZJ_(G)) :: uFLx_bulk ! Total calculated bulk-layer u-flux for the tracer real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx ! Meridional flux of tracer - real, dimension(SZI_(G),SZJB_(G)) :: vFlx_bulk ! Total calculated bulk-layer v-flux for the tracer + real, dimension(SZI_(G),SZJB_(G)) :: vFlx_bulk ! Total calculated bulk-layer v-flux for the tracer type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer integer :: remap_method !< Reconstruction method integer :: i,j,k,m hbl(:,:) = 0. - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) -! if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%KPP_CSp, G, US, hbl) + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) + if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) - do m = 1,Reg%ntr + do m = 1,Reg%ntr tracer => Reg%tr(m) do j = G%jsc-1, G%jec+1 ! Interpolate state to interface @@ -178,9 +178,11 @@ subroutine lateral_boundary_mixing(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) ! Update the tracer fluxes do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec if (G%mask2dT(i,j)>0.) then - tracer%t(i,j,k) = tracer%t(i,j,k) + (( (uFlx(I-1,j,k)-uFlx(I,j,k)) ) + ( (vFlx(i,J,k)-vFlx(i,J+1,k) ) ))*(G%IareaT(i,j)/( h(i,j,k) + GV%H_subroundoff)) + tracer%t(i,j,k) = tracer%t(i,j,k) + (( (uFlx(I-1,j,k)-uFlx(I,j,k)) ) + ( (vFlx(i,J-1,k)-vFlx(i,J,k) ) ))*(G%IareaT(i,j)/( h(i,j,k) + GV%H_subroundoff)) endif enddo ; enddo ; enddo + + enddo end subroutine lateral_boundary_mixing @@ -212,6 +214,7 @@ real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coe htot = 0. bulk_average = 0. + if (hblt == 0.) return if (boundary == SURFACE) then htot = (h(k_bot) * zeta_bot) bulk_average = average_value_ppoly( nk, phi, ppoly0_E, ppoly0_coefs, method, k_bot, 0., zeta_bot) * htot @@ -231,11 +234,7 @@ real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coe call MOM_error(FATAL, "bulk_average: a valid boundary type must be provided.") endif - if (htot > 0.) then - bulk_average = bulk_average / hBLT - else - bulk_average = 0. - endif + bulk_average = bulk_average / hBLT end function bulk_average @@ -243,8 +242,11 @@ end function bulk_average real function harmonic_mean(h1,h2) real :: h1 !< Scalar quantity real :: h2 !< Scalar quantity - - harmonic_mean = 2.*(h1*h2)/(h1+h2) + if (h1 + h2 == 0.) then + harmonic_mean = 0. + else + harmonic_mean = 2.*(h1*h2)/(h1+h2) + endif end function harmonic_mean !> Find the k-index range corresponding to the layers that are within the boundary-layer region @@ -269,6 +271,9 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b k_top = 1 zeta_top = 0. htot = 0. + k_bot = 1 + zeta_bot = 0. + if (hbl == 0.) return do k=1,nk htot = htot + h(k) if ( htot >= hbl) then @@ -279,9 +284,12 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b enddo ! Bottom boundary layer elseif ( boundary == BOTTOM ) then + k_top = nk + zeta_top = 1. k_bot = nk zeta_bot = 1. htot = 0. + if (hbl == 0.) return do k=nk,1,-1 htot = htot + h(k) if (htot >= hbl) then @@ -315,7 +323,7 @@ subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, p real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [ nondim ] real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] - real, dimension(nk), intent(in ) :: khtr_u !< Horizontal diffusivities at U-point [m^2 s^-1] + real, intent(in ) :: khtr_u !< Horizontal diffusivities at U-point [m^2 s^-1] real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux [trunit s^-1] real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [trunit s^-1] ! Local variables @@ -352,23 +360,11 @@ subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, p enddo hbl_u = 0.5*(hbl_L + hbl_R) call boundary_k_range(boundary, nk, h_u, hbl_u, k_top_u, zeta_top_u, k_bot_u, zeta_bot_u) - if ( boundary == SURFACE ) then - khtr_avg = (h_u(k_bot_u) * zeta_bot_u) * khtr_u(k_bot_u) - do k=k_bot_u-1,1,-1 - khtr_avg = khtr_avg + h_u(k) * khtr_u(k) - enddo - elseif ( boundary == BOTTOM ) then - khtr_avg = (h_u(k_top_u) * (1.-zeta_top_u)) * khtr_u(k_top_u) - do k=k_top_u+1,nk - khtr_avg = khtr_avg + h_u(k) * khtr_u(k) - enddo - endif - - khtr_avg = khtr_avg / hbl_u ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities heff = harmonic_mean(hbl_L, hbl_R) - F_bulk = -(khtr_avg * heff) * (phi_R_avg - phi_L_avg) + F_bulk = -(khtr_u * heff) * (phi_R_avg - phi_L_avg) + if (F_bulk .ne. F_bulk) print *, khtr_avg, heff, phi_R_avg, phi_L_avg, hbl_L, hbl_R ! Calculate the layerwise sum of the vertical effective thickness. This is different than the heff calculated ! above, but is used as a way to decompose decompose the fluxes onto the individual layers h_means(:) = 0. @@ -420,16 +416,19 @@ subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, p h_means(k) = harmonic_mean(h_L(k),h_R(k)) enddo endif - - inv_heff = 1./SUM(h_means) - ! Decompose the bulk flux onto the individual layers - do k=1,nk - if ( SIGN(1.,F_bulk) == SIGN(1., -(phi_R(k)-phi_L(k))) ) then - F_layer(k) = F_bulk * (h_means(k)*inv_heff) - else - F_layer(k) = 0. - endif - enddo + if ( SUM(h_means) == 0. ) then + return + else + inv_heff = 1./SUM(h_means) + ! Decompose the bulk flux onto the individual layers + do k=1,nk + if ( SIGN(1.,F_bulk) == SIGN(1., -(phi_R(k)-phi_L(k))) ) then + F_layer(k) = F_bulk * (h_means(k)*inv_heff) + else + F_layer(k) = 0. + endif + enddo + endif end subroutine layer_fluxes_bulk_method @@ -448,7 +447,7 @@ logical function near_boundary_unit_tests( verbose ) real, dimension(nk,2) :: ppoly0_E_L, ppoly0_E_R! Polynomial edge values (left and right) [concentration] real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] - real, dimension(nk) :: khtr_u ! Horizontal diffusivities at U-point [m^2 s^-1] + real :: khtr_u ! Horizontal diffusivities at U-point [m^2 s^-1] real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] real :: F_bulk ! Total diffusive flux across the U point [nondim s^-1] real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [nondim s^-1] @@ -517,7 +516,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = (/1.,1./) + khtr_u = 1. call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) @@ -534,7 +533,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_L(2,1) = 1.; ppoly0_E_L(2,2) = 1. ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. ppoly0_E_R(2,1) = 0.; ppoly0_E_R(2,2) = 0. - khtr_u = (/1.,1./) + khtr_u = 1. call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) @@ -551,7 +550,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_L(2,1) = 1.; ppoly0_E_L(2,2) = 0. ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = (/1.,1./) + khtr_u = 1. call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) @@ -568,7 +567,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = (/1.,1./) + khtr_u = 1. call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) @@ -585,7 +584,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = (/1.,1./) + khtr_u = 1. call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) @@ -602,7 +601,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = (/1.,1./) + khtr_u = 1. call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) @@ -619,7 +618,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = (/1.,1./) + khtr_u = 1. call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) @@ -634,7 +633,7 @@ logical function near_boundary_unit_tests( verbose ) phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - khtr_u = (/1.,1./) + khtr_u = 1. call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) @@ -647,7 +646,7 @@ logical function near_boundary_unit_tests( verbose ) phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 1. phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 2. - khtr_u = (/1.,1./) + khtr_u = 1. ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 1. diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 8dc02c3a2a..13fba9dd6a 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -26,6 +26,7 @@ module MOM_tracer_hor_diff use MOM_lateral_boundary_mixing, only : lateral_boundary_mixing_CS, lateral_boundary_mixing_init use MOM_lateral_boundary_mixing, only : lateral_boundary_mixing use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chksum +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -101,7 +102,7 @@ module MOM_tracer_hor_diff !! using the diffusivity in CS%KhTr, or using space-dependent diffusivity. !! Multiple iterations are used (if necessary) so that there is no limit !! on the acceptable time increment. -subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_flag, read_khdt_x, read_khdt_y) +subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online_flag, read_khdt_x, read_khdt_y) type(ocean_grid_type), intent(inout) :: G !< Grid type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2] @@ -109,6 +110,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_fla type(MEKE_type), pointer :: MEKE !< MEKE type type(VarMix_CS), pointer :: VarMix !< Variable mixing type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_hor_diff_CS), pointer :: CS !< module control structure type(tracer_registry_type), pointer :: Reg !< registered tracers type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available @@ -383,7 +385,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_fla do J=js-1,je ; do i=is,ie ; Reg%Tr(m)%df2d_y(i,J) = 0.0 ; enddo ; enddo endif enddo - + if (CS%use_lateral_boundary_mixing) then if (CS%show_call_tree) call callTree_waypoint("Calling lateral boundary mixing (tracer_hordiff)") @@ -404,7 +406,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_fla if (itt>1) then ! Update halos for subsequent iterations call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) endif - call lateral_boundary_mixing(G, GV, h, Coef_x, Coef_y, I_numitts*dt, Reg, CS%lateral_boundary_mixing_CSp) + call lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, I_numitts*dt, Reg, CS%lateral_boundary_mixing_CSp) enddo ! itt endif From 332a2648de3412d80a497a5fcc92a09ad859d61a Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Sat, 14 Sep 2019 07:43:57 -0600 Subject: [PATCH 018/103] Try to restore commits from accidental move of file --- ...ateral_boundary_mixing.F90 => MOM_boundary_lateral_mixing.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/tracer/{MOM_lateral_boundary_mixing.F90 => MOM_boundary_lateral_mixing.F90} (100%) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_boundary_lateral_mixing.F90 similarity index 100% rename from src/tracer/MOM_lateral_boundary_mixing.F90 rename to src/tracer/MOM_boundary_lateral_mixing.F90 From 322aa77b876a4eac281e43dd8dd25ef7f7c313a7 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Sat, 14 Sep 2019 07:49:41 -0600 Subject: [PATCH 019/103] Rename MOM_boundary_lateral_mixing.F90 for consistency --- ...oundary_lateral_mixing.F90 => MOM_lateral_boundary_mixing.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/tracer/{MOM_boundary_lateral_mixing.F90 => MOM_lateral_boundary_mixing.F90} (100%) diff --git a/src/tracer/MOM_boundary_lateral_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 similarity index 100% rename from src/tracer/MOM_boundary_lateral_mixing.F90 rename to src/tracer/MOM_lateral_boundary_mixing.F90 From 915bcb19f289c1d69e3e60a8789a94fc286d267d Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Sat, 14 Sep 2019 13:00:48 -0600 Subject: [PATCH 020/103] Diagnostics for lateral boundary mixing scheme Diffusive fluxes calculated from the lateral boundary mixing scheme of tracers have been added as a diagnostic to the tracer registry. The total 'bulk' flux was added as well --- src/tracer/MOM_lateral_boundary_mixing.F90 | 5 ++++ src/tracer/MOM_tracer_registry.F90 | 35 +++++++++++++++++++++- 2 files changed, 39 insertions(+), 1 deletion(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 077178f8d8..d722f4aa8f 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -182,6 +182,11 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) endif enddo ; enddo ; enddo + ! Post the tracer diagnostics + if (tracer%id_lbm_bulk_dfx>0) call post_data(tracer%id_lbm_bulk_dfx, uFlx_bulk, CS%diag) + if (tracer%id_lbm_bulk_dfy>0) call post_data(tracer%id_lbm_bulk_dfy, vFlx_bulk, CS%diag) + if (tracer%id_lbm_dfx>0) call post_data(tracer%id_lbm_dfx, uFlx, CS%diag) + if (tracer%id_lbm_dfy>0) call post_data(tracer%id_lbm_dfy, vFlx, CS%diag) enddo diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index cbaf18d983..9557640abc 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -56,6 +56,14 @@ module MOM_tracer_registry !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: df_y => NULL() !< diagnostic array for y-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: lbm_df_x => NULL() !< diagnostic array for x-diffusive tracer flux + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: lbm_df_y => NULL() !< diagnostic array for y-diffusive tracer flux + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: lbm_bulk_df_x => NULL() !< diagnostic array for x-diffusive tracer flux + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: lbm_bulk_df_y => NULL() !< diagnostic array for y-diffusive tracer flux + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_x => NULL() !< diagnostic vertical sum x-diffusive flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_y => NULL() !< diagnostic vertical sum y-diffusive flux @@ -109,6 +117,7 @@ module MOM_tracer_registry !>@{ Diagnostic IDs integer :: id_tr = -1 integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_dfy = -1 + integer :: id_lbm_bulk_dfx = -1, id_lbm_bulk_dfy = -1, id_lbm_dfx = -1, id_lbm_dfy = -1 integer :: id_adx_2d = -1, id_ady_2d = -1, id_dfx_2d = -1, id_dfy_2d = -1 integer :: id_adv_xy = -1, id_adv_xy_2d = -1 integer :: id_dfxy_cont = -1, id_dfxy_cont_2d = -1, id_dfxy_conc = -1 @@ -398,7 +407,13 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux" , & trim(flux_units), v_extensive = .true., y_cell_method = 'sum') Tr%id_dfy = register_diag_field("ocean_model", trim(shortnm)//"_dfy", & - diag%axesCvL, Time, trim(flux_longname)//" diffusive zonal flux" , & + diag%axesCvL, Time, trim(flux_longname)//" diffusive merdional flux" , & + trim(flux_units), v_extensive = .true., x_cell_method = 'sum') + Tr%id_lbm_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbm_dfx", & + diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the near-boundary mixing scheme" , & + trim(flux_units), v_extensive = .true., y_cell_method = 'sum') + Tr%id_lbm_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbm_dfy", & + diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the near-boundary mixing scheme" , & trim(flux_units), v_extensive = .true., x_cell_method = 'sum') else Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & @@ -413,11 +428,19 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) Tr%id_dfy = register_diag_field("ocean_model", trim(shortnm)//"_diffy", & diag%axesCvL, Time, "Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=Tr%flux_scale, x_cell_method = 'sum') + Tr%id_lbm_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbm_diffx", & + diag%axesCuL, Time, "Boundary Diffusive Zonal Flux of "//trim(flux_longname), & + flux_units, v_extensive=.true., conversion=Tr%flux_scale, y_cell_method = 'sum') + Tr%id_lbm_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbm_diffy", & + diag%axesCvL, Time, "Boundary Diffusive Meridional Flux of "//trim(flux_longname), & + flux_units, v_extensive=.true., conversion=Tr%flux_scale, x_cell_method = 'sum') endif if (Tr%id_adx > 0) call safe_alloc_ptr(Tr%ad_x,IsdB,IedB,jsd,jed,nz) if (Tr%id_ady > 0) call safe_alloc_ptr(Tr%ad_y,isd,ied,JsdB,JedB,nz) if (Tr%id_dfx > 0) call safe_alloc_ptr(Tr%df_x,IsdB,IedB,jsd,jed,nz) if (Tr%id_dfy > 0) call safe_alloc_ptr(Tr%df_y,isd,ied,JsdB,JedB,nz) + if (Tr%id_lbm_dfx > 0) call safe_alloc_ptr(Tr%lbm_df_x,IsdB,IedB,jsd,jed,nz) + if (Tr%id_lbm_dfy > 0) call safe_alloc_ptr(Tr%lbm_df_y,isd,ied,JsdB,JedB,nz) Tr%id_adx_2d = register_diag_field("ocean_model", trim(shortnm)//"_adx_2d", & diag%axesCu1, Time, & @@ -435,11 +458,21 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) diag%axesCv1, Time, & "Vertically Integrated Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, conversion=Tr%flux_scale, x_cell_method = 'sum') + Tr%id_lbm_bulk_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbm_bulk_diffx", & + diag%axesCu1, Time, & + "Total Bulk Diffusive Zonal Flux of "//trim(flux_longname), & + flux_units, conversion=Tr%flux_scale, y_cell_method = 'sum') + Tr%id_lbm_bulk_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbm_bulk_diffy", & + diag%axesCv1, Time, & + "Vertically Integrated Diffusive Meridional Flux of "//trim(flux_longname), & + flux_units, conversion=Tr%flux_scale, x_cell_method = 'sum') if (Tr%id_adx_2d > 0) call safe_alloc_ptr(Tr%ad2d_x,IsdB,IedB,jsd,jed) if (Tr%id_ady_2d > 0) call safe_alloc_ptr(Tr%ad2d_y,isd,ied,JsdB,JedB) if (Tr%id_dfx_2d > 0) call safe_alloc_ptr(Tr%df2d_x,IsdB,IedB,jsd,jed) if (Tr%id_dfy_2d > 0) call safe_alloc_ptr(Tr%df2d_y,isd,ied,JsdB,JedB) + if (Tr%id_lbm_bulk_dfx > 0) call safe_alloc_ptr(Tr%lbm_bulk_df_x,IsdB,IedB,jsd,jed) + if (Tr%id_lbm_bulk_dfy > 0) call safe_alloc_ptr(Tr%lbm_bulk_df_y,isd,ied,JsdB,JedB) Tr%id_adv_xy = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy", & diag%axesTL, Time, & From f6800c2bc3e0a85b24bcecb64d20136efed1c958 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Sat, 14 Sep 2019 18:41:03 -0400 Subject: [PATCH 021/103] Update halos for hbl in LBM The get_MLD and get_BLD routines only return boundary layer depths on the T-grid's computational domain leading to striping when calculating the LBM fluxes. Adding a halo update for this variable fixes the problem --- src/tracer/MOM_lateral_boundary_mixing.F90 | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index d722f4aa8f..5e0fff7a3a 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -6,6 +6,7 @@ module MOM_lateral_boundary_mixing use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_domains, only : pass_var use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_diag_mediator, only : post_data, register_diag_field use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe @@ -142,6 +143,8 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) + call pass_var(hbl,G%Domain) + do m = 1,Reg%ntr tracer => Reg%tr(m) do j = G%jsc-1, G%jec+1 @@ -154,6 +157,8 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! Diffusive fluxes in the i-direction uFlx(:,:,:) = 0. vFlx(:,:,:) = 0. + uFlx_bulk(:,:) = 0. + vFlx_bulk(:,:) = 0. if ( CS%method == 1 ) then do j=G%jsc,G%jec do i=G%isc-1,G%iec @@ -183,10 +188,10 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) enddo ; enddo ; enddo ! Post the tracer diagnostics - if (tracer%id_lbm_bulk_dfx>0) call post_data(tracer%id_lbm_bulk_dfx, uFlx_bulk, CS%diag) - if (tracer%id_lbm_bulk_dfy>0) call post_data(tracer%id_lbm_bulk_dfy, vFlx_bulk, CS%diag) - if (tracer%id_lbm_dfx>0) call post_data(tracer%id_lbm_dfx, uFlx, CS%diag) - if (tracer%id_lbm_dfy>0) call post_data(tracer%id_lbm_dfy, vFlx, CS%diag) + if (tracer%id_lbm_bulk_dfx>0) call post_data(tracer%id_lbm_bulk_dfx, uFlx_bulk, CS%diag) + if (tracer%id_lbm_bulk_dfy>0) call post_data(tracer%id_lbm_bulk_dfy, vFlx_bulk, CS%diag) + if (tracer%id_lbm_dfx>0) call post_data(tracer%id_lbm_dfx, uFlx, CS%diag) + if (tracer%id_lbm_dfy>0) call post_data(tracer%id_lbm_dfy, vFlx, CS%diag) enddo From 4d0aed6b2da11708d4af2a22074ab23412ec3091 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 16 Sep 2019 16:09:07 -0600 Subject: [PATCH 022/103] Fixes units and moves bulk diags inside if statement --- src/tracer/MOM_lateral_boundary_mixing.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 5e0fff7a3a..57a39673f2 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -178,6 +178,9 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) endif enddo enddo + ! Post tracer bulk diags + if (tracer%id_lbm_bulk_dfx>0) call post_data(tracer%id_lbm_bulk_dfx, uFlx_bulk, CS%diag) + if (tracer%id_lbm_bulk_dfy>0) call post_data(tracer%id_lbm_bulk_dfy, vFlx_bulk, CS%diag) endif ! Update the tracer fluxes @@ -188,8 +191,6 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) enddo ; enddo ; enddo ! Post the tracer diagnostics - if (tracer%id_lbm_bulk_dfx>0) call post_data(tracer%id_lbm_bulk_dfx, uFlx_bulk, CS%diag) - if (tracer%id_lbm_bulk_dfy>0) call post_data(tracer%id_lbm_bulk_dfy, vFlx_bulk, CS%diag) if (tracer%id_lbm_dfx>0) call post_data(tracer%id_lbm_dfx, uFlx, CS%diag) if (tracer%id_lbm_dfy>0) call post_data(tracer%id_lbm_dfy, vFlx, CS%diag) @@ -333,9 +334,9 @@ subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, p real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [ nondim ] real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] - real, intent(in ) :: khtr_u !< Horizontal diffusivities at U-point [m^2 s^-1] - real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux [trunit s^-1] - real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [trunit s^-1] + real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t at U-point [m^2] + real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux [m^2 trunit] + real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [m^2 trunit] ! Local variables real, dimension(nk) :: h_means ! Calculate the layer-wise harmonic means [m] real, dimension(nk) :: h_u ! Thickness at the u-point [m] From 3bb1f55612e75d92409f4ea2dcc04457be3f9d86 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 16 Sep 2019 16:54:52 -0600 Subject: [PATCH 023/103] Adding first version of LBM method=2 TODO: * add code for boundary = BOTTOM * add unit tests --- src/tracer/MOM_lateral_boundary_mixing.F90 | 123 ++++++++++++++++++--- 1 file changed, 110 insertions(+), 13 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 57a39673f2..04a7804f31 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -163,7 +163,7 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) do j=G%jsc,G%jec do i=G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then - call layer_fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,j,:), h(i+1,j,:), hbl(i,j), hbl(i+1,j), & + call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,j,:), h(i+1,j,:), hbl(i,j), hbl(i+1,j), & tracer%t(i,j,:), tracer%t(i+1,j,:), ppoly0_coefs(i,j,:,:), ppoly0_coefs(i+1,j,:,:), ppoly0_E(i,j,:,:), & ppoly0_E(i+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:)) endif @@ -172,7 +172,7 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) do J=G%jsc-1,G%jec do i=G%isc,G%iec if (G%mask2dCv(i,J)>0.) then - call layer_fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:)) endif @@ -181,6 +181,26 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! Post tracer bulk diags if (tracer%id_lbm_bulk_dfx>0) call post_data(tracer%id_lbm_bulk_dfx, uFlx_bulk, CS%diag) if (tracer%id_lbm_bulk_dfy>0) call post_data(tracer%id_lbm_bulk_dfy, vFlx_bulk, CS%diag) + + elseif (CS%method == 2) then + do j=G%jsc,G%jec + do i=G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(i,j,:), h(i+1,j,:), hbl(i,j), hbl(i+1,j), & + tracer%t(i,j,:), tracer%t(i+1,j,:), ppoly0_coefs(i,j,:,:), ppoly0_coefs(i+1,j,:,:), ppoly0_E(i,j,:,:), & + ppoly0_E(i+1,j,:,:), remap_method, Coef_x(I,j), uFlx(I,j,:)) + endif + enddo + enddo + do J=G%jsc-1,G%jec + do i=G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & + ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx(i,J,:)) + endif + enddo + enddo endif ! Update the tracer fluxes @@ -315,8 +335,85 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b end subroutine boundary_k_range + +!> Calculate the near-boundary diffusive fluxes calculated using the layer by layer method. +subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, & + ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + integer, intent(in ) :: nk !< Number of layers [nondim] + integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] + real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [m] + real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [m] + real, intent(in ) :: hbl_L !< Thickness of the boundary boundary + !! layer (left) [m] + real, intent(in ) :: hbl_R !< Thickness of the boundary boundary + !! layer (left) [m] + real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [ nondim m^-3 ] + real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [ nondim m^-3 ] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [ nondim m^-3 ] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [ nondim m^-3 ] + real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [ nondim ] + real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] + integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] + real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t at U-point [m^2] + real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [m^2 trunit] + ! Local variables + real, dimension(nk) :: h_means ! Calculate the layer-wise harmonic means [m] + real, dimension(nk) :: h_u ! Thickness at the u-point [m] + real :: hbl_u ! Boundary layer Thickness at the u-point [m] + real :: khtr_avg ! Thickness-weighted diffusivity at the u-point [m^2 s^-1] + real :: heff ! Harmonic mean of layer thicknesses [m] + real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] + real :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) + ! [trunit m^-3 ] + real :: htot ! Total column thickness [m] + integer :: k, k_bot_min, k_top_max + integer :: k_top_L, k_bot_L, k_top_u + integer :: k_top_R, k_bot_R, k_bot_u + real :: zeta_top_L, zeta_top_R, zeta_top_u + real :: zeta_bot_L, zeta_bot_R, zeta_bot_u + real :: h_work_L, h_work_R ! dummy variables + real :: hbl_min ! minimum BLD (left and right) + + F_layer(:) = 0.0 + if (hbl_L == 0. .or. hbl_R == 0.) then + return + endif + hbl_min = MIN(hbl_L, hbl_R) + ! Calculate vertical indices containing the boundary layer + call boundary_k_range(boundary, nk, h_L, hbl_min, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) + call boundary_k_range(boundary, nk, h_R, hbl_min, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) + + if (boundary == SURFACE) then + k_bot_min = MIN(k_bot_L, k_bot_R) + ! make sure left and right k indices span same range + if (k_bot_min .ne. k_bot_L) then + k_bot_L = k_bot_min + zeta_bot_L = 1.0 + endif + if (k_bot_min .ne. k_bot_R) then + k_bot_R= k_bot_min + zeta_bot_R = 1.0 + endif + + h_work_L = (h_L(k_bot_L) * zeta_bot_L) + h_work_R = (h_R(k_bot_R) * zeta_bot_R) + + phi_L_avg = average_value_ppoly( nk, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_bot_L, 0., zeta_bot_L) + phi_R_avg = average_value_ppoly( nk, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_bot_R, 0., zeta_bot_R) + heff = harmonic_mean(h_work_L, h_work_R) + ! tracer flux where the minimum BLD intersets layer + F_layer(k_bot_min) = -heff * (phi_R_avg - phi_L_avg) + do k = k_bot_min-1,1,-1 + heff = harmonic_mean(h_L(k), h_R(k)) + F_layer(k) = -heff * (phi_R(k) - phi_L(k)) + enddo + endif + +end subroutine fluxes_layer_method + !> Calculate the near-boundary diffusive fluxes calculated from a 'bulk model' -subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, & +subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, & ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] @@ -441,7 +538,7 @@ subroutine layer_fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, p enddo endif -end subroutine layer_fluxes_bulk_method +end subroutine fluxes_bulk_method !> Unit tests for near-boundary horizontal mixing logical function near_boundary_unit_tests( verbose ) @@ -528,7 +625,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) @@ -545,7 +642,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. ppoly0_E_R(2,1) = 0.; ppoly0_E_R(2,2) = 0. khtr_u = 1. - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) @@ -562,7 +659,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) @@ -579,7 +676,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) @@ -596,7 +693,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) @@ -613,7 +710,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) @@ -630,7 +727,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) @@ -645,7 +742,7 @@ logical function near_boundary_unit_tests( verbose ) phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. khtr_u = 1. - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) @@ -662,7 +759,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. - call layer_fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) end function near_boundary_unit_tests From 62e32273517bbee6aa14d5a5833f2e470b495916 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Sep 2019 14:47:19 -0600 Subject: [PATCH 024/103] Adding layer by layer method for bottom boundary --- src/tracer/MOM_lateral_boundary_mixing.F90 | 33 ++++++++++++++++++---- 1 file changed, 28 insertions(+), 5 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 04a7804f31..5db1d72528 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -399,8 +399,8 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, h_work_L = (h_L(k_bot_L) * zeta_bot_L) h_work_R = (h_R(k_bot_R) * zeta_bot_R) - phi_L_avg = average_value_ppoly( nk, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_bot_L, 0., zeta_bot_L) - phi_R_avg = average_value_ppoly( nk, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_bot_R, 0., zeta_bot_R) + phi_L_avg = average_value_ppoly( nk, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_bot_L, 0., zeta_bot_L) + phi_R_avg = average_value_ppoly( nk, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_bot_R, 0., zeta_bot_R) heff = harmonic_mean(h_work_L, h_work_R) ! tracer flux where the minimum BLD intersets layer F_layer(k_bot_min) = -heff * (phi_R_avg - phi_L_avg) @@ -410,6 +410,31 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, enddo endif + if (boundary == BOTTOM) then + k_top_max = MAX(k_top_L, k_top_R) + ! make sure left and right k indices span same range + if (k_top_max .ne. k_top_L) then + k_top_L = k_top_max + zeta_top_L = 1.0 + endif + if (k_top_max .ne. k_top_R) then + k_top_R= k_top_max + zeta_top_R = 1.0 + endif + + h_work_L = (h_L(k_top_L) * zeta_top_L) + h_work_R = (h_R(k_top_R) * zeta_top_R) + + phi_L_avg = average_value_ppoly( nk, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, 1.0-zeta_top_L, 1.0) + phi_R_avg = average_value_ppoly( nk, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, 1.0-zeta_top_R, 1.0) + heff = harmonic_mean(h_work_L, h_work_R) + ! tracer flux where the minimum BLD intersets layer + F_layer(k_top_max) = -heff * (phi_R_avg - phi_L_avg) + do k = k_top_max+1,nk + heff = harmonic_mean(h_L(k), h_R(k)) + F_layer(k) = -heff * (phi_R(k) - phi_L(k)) + enddo + endif end subroutine fluxes_layer_method !> Calculate the near-boundary diffusive fluxes calculated from a 'bulk model' @@ -499,11 +524,9 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, do k=1,k_min-1 h_means(k) = harmonic_mean(h_L(k),h_R(k)) enddo - endif - if (boundary == BOTTOM) then + elseif (boundary == BOTTOM) then k_max = MAX(k_top_L, k_top_R) - ! left hand side if (k_top_L == k_max) then h_work_L = h_L(k_max) * zeta_top_L From 3cb68d34845bba2cc2e30cf8f33ac9710befd670 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Sep 2019 14:58:32 -0600 Subject: [PATCH 025/103] Adds missing arguments after merge --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 4 ++-- src/tracer/MOM_tracer_hor_diff.F90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 5b31f4da1e..4a99bb9b2b 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -2864,8 +2864,8 @@ end subroutine layered_diabatic !> Returns pointers or values of members within the diabatic_CS type. For extensibility, !! each returned argument is an optional argument -subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, & - evap_CFL_limit, minimum_forcing_depth, KPP_CSp, energetic_PBL_CSp) +subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, & + minimum_forcing_depth, KPP_CSp, energetic_PBL_CSp, diabatic_aux_CSp) type(diabatic_CS), intent(in ) :: CS !< module control structure ! All output arguments are optional type(opacity_CS), optional, pointer :: opacity_CSp !< A pointer to be set to the opacity control structure diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 9bb43bb03a..018ab38dea 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -1414,7 +1414,7 @@ end subroutine tracer_epipycnal_ML_diff !> Initialize lateral tracer diffusion module -subroutine tracer_hor_diff_init(Time, G, param_file, diag, EOS, diabatic_CSp, CS) +subroutine tracer_hor_diff_init(Time, G, US, param_file, diag, EOS, diabatic_CSp, CS) type(time_type), target, intent(in) :: Time !< current model time type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type From 6d6d3b8a417a04bb1fb443106a9273b0e28c227f Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Sep 2019 15:51:25 -0600 Subject: [PATCH 026/103] Adds two unit tests for layer by layer method --- src/tracer/MOM_lateral_boundary_mixing.F90 | 35 ++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 5db1d72528..a275ac7584 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -785,6 +785,41 @@ logical function near_boundary_unit_tests( verbose ) call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) + + ! unit tests for layer by layer method + test_name = 'Different hbl and different column thicknesses (gradient from right to left)' + hbl_L = 12; hbl_R = 20 + h_L = (/6.,6./) ; h_R = (/10.,10./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. + khtr_u = 1. + call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-3.75,0.0/) ) + + test_name = 'Different hbl and different column thicknesses (gradient from right to left)' + hbl_L = 15; hbl_R = 6 + h_L = (/10.,10./) ; h_R = (/12.,10./) + phi_L = (/0.,0./) ; phi_R = (/1.,3./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 2. + phi_pp_R(2,1) = 2.; phi_pp_R(2,2) = 2. + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 2. + ppoly0_E_R(2,1) = 2.; ppoly0_E_R(2,2) = 4. + khtr_u = 1. + call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-3.75,0.0/) ) end function near_boundary_unit_tests !> Returns true if output of near-boundary unit tests does not match correct computed values From c41b8b0c78c0593503f8505e822a6572c55a267f Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Sep 2019 15:51:25 -0600 Subject: [PATCH 027/103] Adds two unit tests for layer by layer method --- src/tracer/MOM_lateral_boundary_mixing.F90 | 35 ++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 5db1d72528..def102334b 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -785,6 +785,41 @@ logical function near_boundary_unit_tests( verbose ) call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) + + ! unit tests for layer by layer method + test_name = 'Different hbl and different column thicknesses (gradient from right to left)' + hbl_L = 12; hbl_R = 20 + h_L = (/6.,6./) ; h_R = (/10.,10./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. + khtr_u = 1. + call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,0.0/) ) + + test_name = 'Different hbl and different column thicknesses (gradient from right to left)' + hbl_L = 15; hbl_R = 6 + h_L = (/10.,10./) ; h_R = (/12.,10./) + phi_L = (/0.,0./) ; phi_R = (/1.,3./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 2. + phi_pp_R(2,1) = 2.; phi_pp_R(2,2) = 2. + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 2. + ppoly0_E_R(2,1) = 2.; ppoly0_E_R(2,2) = 4. + khtr_u = 1. + call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,0.0/) ) end function near_boundary_unit_tests !> Returns true if output of near-boundary unit tests does not match correct computed values From e5645b14c5c930a2e5c32c8ee8b71b57878826f9 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Sep 2019 16:40:17 -0600 Subject: [PATCH 028/103] Fixes line length exceeding 120 --- src/tracer/MOM_lateral_boundary_mixing.F90 | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index b09c455542..d4cd7b0302 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -206,7 +206,8 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! Update the tracer fluxes do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec if (G%mask2dT(i,j)>0.) then - tracer%t(i,j,k) = tracer%t(i,j,k) + (( (uFlx(I-1,j,k)-uFlx(I,j,k)) ) + ( (vFlx(i,J-1,k)-vFlx(i,J,k) ) ))*(G%IareaT(i,j)/( h(i,j,k) + GV%H_subroundoff)) + tracer%t(i,j,k) = tracer%t(i,j,k) + (( (uFlx(I-1,j,k)-uFlx(I,j,k)) ) + ( (vFlx(i,J-1,k)-vFlx(i,J,k) ) ))* & + (G%IareaT(i,j)/( h(i,j,k) + GV%H_subroundoff)) endif enddo ; enddo ; enddo @@ -219,7 +220,8 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) end subroutine lateral_boundary_mixing !< Calculate bulk layer value of a scalar quantity as the thickness weighted average -real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coefs, method, k_top, zeta_top, k_bot, zeta_bot) +real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coefs, method, k_top, zeta_top, k_bot, & + zeta_bot) integer :: boundary !< SURFACE or BOTTOM [nondim] integer :: nk !< Number of layers [nondim] integer :: deg !< Degree of polynomial [nondim] @@ -483,10 +485,10 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) ! Calculate bulk averages of various quantities - phi_L_avg = bulk_average(boundary, nk, deg, h_L, hbl_L, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, zeta_top_L,& - k_bot_L, zeta_bot_L) - phi_R_avg = bulk_average(boundary, nk, deg, h_R, hbl_R, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, zeta_top_R,& - k_bot_R, zeta_bot_R) + phi_L_avg = bulk_average(boundary, nk, deg, h_L, hbl_L, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, & + zeta_top_L, k_bot_L, zeta_bot_L) + phi_R_avg = bulk_average(boundary, nk, deg, h_R, hbl_R, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, & + zeta_top_R, k_bot_R, zeta_bot_R) do k=1,nk h_u(k) = 0.5 * (h_L(k) + h_R(k)) enddo From 4d5c7862f7e4064ed5d42adb75f447ff7a638d1c Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Sep 2019 16:43:41 -0600 Subject: [PATCH 029/103] Fixes undoxygenized LBM module variables --- src/tracer/MOM_lateral_boundary_mixing.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index d4cd7b0302..8f8e417b99 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -32,6 +32,7 @@ module MOM_lateral_boundary_mixing integer, parameter :: BOTTOM = 1 !< Set a value that corresponds to the bottom boundary #include +!> Sets parameters for lateral boundary mixing module. type, public :: lateral_boundary_mixing_CS ; private integer :: method !< Determine which of the three methods calculate !! and apply near boundary layer fluxes @@ -50,7 +51,7 @@ module MOM_lateral_boundary_mixing ! This include declares and sets the variable "version". #include "version_variable.h" -character(len=40) :: mdl = "MOM_lateral_boundary_mixing" +character(len=40) :: mdl = "MOM_lateral_boundary_mixing" !< Name of this module contains From 73d0d789565304c38989e003e7735ff905657c76 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 19 Sep 2019 15:24:24 -0600 Subject: [PATCH 030/103] Fixes a bug in method2 of LBM, where diffusivities were not used --- src/tracer/MOM_lateral_boundary_mixing.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 8f8e417b99..d915b06e30 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -431,10 +431,10 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R_avg = average_value_ppoly( nk, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, 1.0-zeta_top_R, 1.0) heff = harmonic_mean(h_work_L, h_work_R) ! tracer flux where the minimum BLD intersets layer - F_layer(k_top_max) = -heff * (phi_R_avg - phi_L_avg) + F_layer(k_top_max) = (-heff * khtr_u) * (phi_R_avg - phi_L_avg) do k = k_top_max+1,nk heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -heff * (phi_R(k) - phi_L(k)) + F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) enddo endif end subroutine fluxes_layer_method From a4f9550f909ffd93c952751853b8d4f93e4668f0 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 19 Sep 2019 16:50:12 -0600 Subject: [PATCH 031/103] Added new equilibrium formula for MEKE * Follow equation 1 of Jansen et al. (2015), balancing the GEOMETRIC GM coefficient against bottom drag (Equations 3 and 12); * Added limited for SN in this formula, to avoid extremely large values. TODO: * Increase GEOMETRIC_ALPHA in this calculation * Use GEOMETRIC_EPSILON as a limiter for SN --- src/parameterizations/lateral/MOM_MEKE.F90 | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 3688c3dfea..f24d549970 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -45,6 +45,8 @@ module MOM_MEKE logical :: visc_drag !< If true use the vertvisc_type to calculate bottom drag. logical :: MEKE_GEOMETRIC !< If true, uses the GM coefficient formulation from the GEOMETRIC !! framework (Marshall et al., 2012) + real :: MEKE_GEOMETRIC_alpha !< The nondimensional coefficient governing the efficiency of the + !! GEOMETRIC thickness diffusion. logical :: MEKE_equilibrium_alt !< If true, use an alternative calculation for the !! equilibrium value of MEKE. logical :: GM_src_alt !< If true, use the GM energy conversion form S^2*N^2*kappa rather @@ -747,7 +749,13 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m EKE = 0. endif if (CS%MEKE_equilibrium_alt) then - MEKE%MEKE(i,j) = (US%Z_to_m*G%bathyT(i,j)*SN / (8*CS%cdrag))**2 + if (CS%MEKE_GEOMETRIC) then + ! Equation 1 of Jansen et al. (2015), balancing the GEOMETRIC GM coefficient against + ! bottom drag (Equations 3 and 12) + MEKE%MEKE(i,j) = (CS%MEKE_GEOMETRIC_alpha * MIN(SN,1.0e-7))**2 / ((I_H * CS%cdrag)**2 * (bottomFac2**3)) + else + MEKE%MEKE(i,j) = (US%Z_to_m*G%bathyT(i,j)*SN / (8*CS%cdrag))**2 + endif else MEKE%MEKE(i,j) = EKE endif @@ -978,6 +986,9 @@ logical function MEKE_init(Time, G, param_file, diag, CS, MEKE, restart_CS) call get_param(param_file, mdl, "MEKE_GEOMETRIC", CS%MEKE_GEOMETRIC, & "If MEKE_GEOMETRIC is true, uses the GM coefficient formulation "//& "from the GEOMETRIC framework (Marshall et al., 2012).", default=.false.) + call get_param(param_file, mdl, "MEKE_GEOMETRIC_ALPHA", CS%MEKE_GEOMETRIC_alpha, & + "The nondimensional coefficient governing the efficiency of the GEOMETRIC \n"//& + "thickness diffusion.", units="nondim", default=0.05) call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_ALT", CS%MEKE_equilibrium_alt, & "If true, use an alternative formula for computing the (equilibrium)"//& "initial value of MEKE.", default=.false.) From 66a8f0afb9ca28e6b08c30acaf64e38aacea6d4d Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 19 Sep 2019 17:39:10 -0600 Subject: [PATCH 032/103] Fix bug in LBM diagnostics and add diags - uFlx_bulk was being defined on the T-grid even though it's on the U-grid - add Vertically integrated quantities for the uFlx, vFlx --- src/tracer/MOM_lateral_boundary_mixing.F90 | 18 +++++++++++++++++- src/tracer/MOM_tracer_registry.F90 | 21 +++++++++++++++++++++ 2 files changed, 38 insertions(+), 1 deletion(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index d915b06e30..f7ec2ad09d 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -133,9 +133,11 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(G),2) :: ppoly0_E !< Edge values from reconstructions real, dimension(SZK_(G),CS%deg+1) :: ppoly_S !< Slopes from reconstruction (placeholder) real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx ! Zonal flux of tracer [H conc ~> m conc or conc kg m-2] - real, dimension(SZI_(G),SZJ_(G)) :: uFLx_bulk ! Total calculated bulk-layer u-flux for the tracer + real, dimension(SZIB_(G),SZJ_(G)) :: uFLx_bulk ! Total calculated bulk-layer u-flux for the tracer real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx ! Meridional flux of tracer real, dimension(SZI_(G),SZJB_(G)) :: vFlx_bulk ! Total calculated bulk-layer v-flux for the tracer + real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d ! Layer summed u-flux transport + real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d ! Layer summed v-flux transport type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer integer :: remap_method !< Reconstruction method integer :: i,j,k,m @@ -215,7 +217,21 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! Post the tracer diagnostics if (tracer%id_lbm_dfx>0) call post_data(tracer%id_lbm_dfx, uFlx, CS%diag) if (tracer%id_lbm_dfy>0) call post_data(tracer%id_lbm_dfy, vFlx, CS%diag) + if (tracer%id_lbm_dfx_2d>0) then + uwork_2d(:,:) = 0. + do k=1,GV%ke; do j=G%jsc,G%jec; do I=G%isc-1,G%iec + uwork_2d(I,j) = uwork_2d(I,j) + uFlx(I,j,k) + enddo; enddo; enddo + endif + call post_data(tracer%id_lbm_dfx_2d, uwork_2d, CS%diag) + if (tracer%id_lbm_dfy_2d>0) then + vwork_2d(:,:) = 0. + do k=1,GV%ke; do J=G%jsc-1,G%jec; do i=G%isc,G%iec + vwork_2d(i,J) = vwork_2d(i,J) + vFlx(i,J,k) + enddo; enddo; enddo + endif + call post_data(tracer%id_lbm_dfy_2d, vwork_2d, CS%diag) enddo end subroutine lateral_boundary_mixing diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index fc16c7cc18..9ccd5f887a 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -60,6 +60,10 @@ module MOM_tracer_registry !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: lbm_df_y => NULL() !< diagnostic array for y-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: lbm_df_x_2d => NULL() !< diagnostic array for x-diffusive tracer flux + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: lbm_df_y_2d => NULL() !< diagnostic array for y-diffusive tracer flux + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: lbm_bulk_df_x => NULL() !< diagnostic array for x-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: lbm_bulk_df_y => NULL() !< diagnostic array for y-diffusive tracer flux @@ -118,6 +122,7 @@ module MOM_tracer_registry integer :: id_tr = -1 integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_dfy = -1 integer :: id_lbm_bulk_dfx = -1, id_lbm_bulk_dfy = -1, id_lbm_dfx = -1, id_lbm_dfy = -1 + integer :: id_lbm_dfx_2d, id_lbm_dfy_2d integer :: id_adx_2d = -1, id_ady_2d = -1, id_dfx_2d = -1, id_dfy_2d = -1 integer :: id_adv_xy = -1, id_adv_xy_2d = -1 integer :: id_dfxy_cont = -1, id_dfxy_cont_2d = -1, id_dfxy_conc = -1 @@ -415,6 +420,14 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) Tr%id_lbm_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbm_dfy", & diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the near-boundary mixing scheme" , & trim(flux_units), v_extensive = .true., x_cell_method = 'sum') + Tr%id_lbm_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbm_dfx_2d", & + diag%axesCu1, Time, trim(flux_longname)//& + " diffusive zonal flux from the near-boundary mixing scheme vertically integrated" , & + trim(flux_units), v_extensive = .true., y_cell_method = 'sum') + Tr%id_lbm_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbm_dfy_2d", & + diag%axesCv1, Time, trim(flux_longname)//& + " diffusive meridional flux from the near-boundary mixing scheme vertically integrated" , & + trim(flux_units), v_extensive = .true., x_cell_method = 'sum') else Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, "Advective (by residual mean) Zonal Flux of "//trim(flux_longname), & @@ -434,6 +447,12 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) Tr%id_lbm_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbm_diffy", & diag%axesCvL, Time, "Boundary Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=Tr%flux_scale, x_cell_method = 'sum') + Tr%id_lbm_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbm_diffx_2d", & + diag%axesCu1, Time, "Vertically integrated Boundary Diffusive Zonal Flux of "//trim(flux_longname), & + flux_units, v_extensive=.true., conversion=Tr%flux_scale, y_cell_method = 'sum') + Tr%id_lbm_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbm_diffy_2d", & + diag%axesCv1, Time, "Vertically integrated Boundary Diffusive Meridional Flux of "//trim(flux_longname), & + flux_units, v_extensive=.true., conversion=Tr%flux_scale, x_cell_method = 'sum') endif if (Tr%id_adx > 0) call safe_alloc_ptr(Tr%ad_x,IsdB,IedB,jsd,jed,nz) if (Tr%id_ady > 0) call safe_alloc_ptr(Tr%ad_y,isd,ied,JsdB,JedB,nz) @@ -441,6 +460,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) if (Tr%id_dfy > 0) call safe_alloc_ptr(Tr%df_y,isd,ied,JsdB,JedB,nz) if (Tr%id_lbm_dfx > 0) call safe_alloc_ptr(Tr%lbm_df_x,IsdB,IedB,jsd,jed,nz) if (Tr%id_lbm_dfy > 0) call safe_alloc_ptr(Tr%lbm_df_y,isd,ied,JsdB,JedB,nz) + if (Tr%id_lbm_dfx_2d > 0) call safe_alloc_ptr(Tr%lbm_df_x_2d,IsdB,IedB,jsd,jed) + if (Tr%id_lbm_dfy_2d > 0) call safe_alloc_ptr(Tr%lbm_df_y_2d,isd,ied,JsdB,JedB) Tr%id_adx_2d = register_diag_field("ocean_model", trim(shortnm)//"_adx_2d", & diag%axesCu1, Time, & From bb46c38d8f7de49fcdcc8944dd34f8ede67049ff Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 23 Sep 2019 14:59:25 -0600 Subject: [PATCH 033/103] Calculates bottomFac2 IF CS%MEKE_GEOMETRIC=True In this commit, bottomFac2 is calculated when CS%MEKE_GEOMETRIC is set to true. Previously, bottomFac2 was calculated in MEKE_lengthScales_0d but something else on that subroutine was returning Nan so we decided to pull out just the bottomFac2 calculation from that. --- src/parameterizations/lateral/MOM_MEKE.F90 | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index f24d549970..645dcc5e8a 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -623,6 +623,8 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m real, parameter :: tolerance = 1.e-12 ! Width of EKE bracket [m2 s-2]. logical :: useSecant, debugIteration + real :: Lgrid, Ldeform, Lfrict + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec debugIteration = .false. @@ -750,9 +752,18 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m endif if (CS%MEKE_equilibrium_alt) then if (CS%MEKE_GEOMETRIC) then + Lgrid = sqrt(G%areaT(i,j)) ! Grid scale + Ldeform =Lgrid * MIN(1.0,MEKE%Rd_dx_h(i,j)) ! Deformation scale + Lfrict = (US%Z_to_m * G%bathyT(i,j)) / CS%cdrag ! Frictional arrest scale + ! gamma_b^2 is the ratio of bottom eddy energy to mean column eddy energy + ! used in calculating bottom drag + bottomFac2 = CS%MEKE_CD_SCALE**2 + if (Lfrict*CS%MEKE_Cb>0.) bottomFac2 = bottomFac2 + 1./( 1. + CS%MEKE_Cb*(Ldeform/Lfrict) )**0.8 + bottomFac2 = max(bottomFac2, CS%MEKE_min_gamma) ! Equation 1 of Jansen et al. (2015), balancing the GEOMETRIC GM coefficient against ! bottom drag (Equations 3 and 12) - MEKE%MEKE(i,j) = (CS%MEKE_GEOMETRIC_alpha * MIN(SN,1.0e-7))**2 / ((I_H * CS%cdrag)**2 * (bottomFac2**3)) + ! TODO: create a run time parameter for limitting SN. + MEKE%MEKE(i,j) = (CS%MEKE_GEOMETRIC_alpha * MIN(SN,1.e-5) * US%Z_to_m*G%bathyT(i,j))**2 / (CS%cdrag**2 * bottomFac2**3) else MEKE%MEKE(i,j) = (US%Z_to_m*G%bathyT(i,j)*SN / (8*CS%cdrag))**2 endif From c8805391f88f2e9ca14f63df5f6a1104bab7d0a3 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 23 Sep 2019 16:34:53 -0600 Subject: [PATCH 034/103] Update LBM flux names and fix posting of 2d diags The 2d diagnostics associated with the lateral boundary mixing were occuring outside the `if (CS%id_lbm_dfx_2d)` statements and were thus leading to segfaults if the diagnostic was not requested. Additionally the array variable names were refactored to be consistent with the `id_` names and the diagnostic names. --- src/tracer/MOM_lateral_boundary_mixing.F90 | 4 ++-- src/tracer/MOM_tracer_registry.F90 | 16 ++++++++-------- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index f7ec2ad09d..a8aaa85452 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -222,16 +222,16 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) do k=1,GV%ke; do j=G%jsc,G%jec; do I=G%isc-1,G%iec uwork_2d(I,j) = uwork_2d(I,j) + uFlx(I,j,k) enddo; enddo; enddo + call post_data(tracer%id_lbm_dfx_2d, uwork_2d, CS%diag) endif - call post_data(tracer%id_lbm_dfx_2d, uwork_2d, CS%diag) if (tracer%id_lbm_dfy_2d>0) then vwork_2d(:,:) = 0. do k=1,GV%ke; do J=G%jsc-1,G%jec; do i=G%isc,G%iec vwork_2d(i,J) = vwork_2d(i,J) + vFlx(i,J,k) enddo; enddo; enddo + call post_data(tracer%id_lbm_dfy_2d, vwork_2d, CS%diag) endif - call post_data(tracer%id_lbm_dfy_2d, vwork_2d, CS%diag) enddo end subroutine lateral_boundary_mixing diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 9ccd5f887a..977e78cf99 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -56,13 +56,13 @@ module MOM_tracer_registry !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: df_y => NULL() !< diagnostic array for y-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:,:), pointer :: lbm_df_x => NULL() !< diagnostic array for x-diffusive tracer flux + real, dimension(:,:,:), pointer :: lbm_dfx => NULL() !< diagnostic array for x-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:,:), pointer :: lbm_df_y => NULL() !< diagnostic array for y-diffusive tracer flux + real, dimension(:,:,:), pointer :: lbm_dfy => NULL() !< diagnostic array for y-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: lbm_df_x_2d => NULL() !< diagnostic array for x-diffusive tracer flux + real, dimension(:,:), pointer :: lbm_dfx_2d => NULL() !< diagnostic array for x-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: lbm_df_y_2d => NULL() !< diagnostic array for y-diffusive tracer flux + real, dimension(:,:), pointer :: lbm_dfy_2d => NULL() !< diagnostic array for y-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: lbm_bulk_df_x => NULL() !< diagnostic array for x-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] @@ -458,10 +458,10 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) if (Tr%id_ady > 0) call safe_alloc_ptr(Tr%ad_y,isd,ied,JsdB,JedB,nz) if (Tr%id_dfx > 0) call safe_alloc_ptr(Tr%df_x,IsdB,IedB,jsd,jed,nz) if (Tr%id_dfy > 0) call safe_alloc_ptr(Tr%df_y,isd,ied,JsdB,JedB,nz) - if (Tr%id_lbm_dfx > 0) call safe_alloc_ptr(Tr%lbm_df_x,IsdB,IedB,jsd,jed,nz) - if (Tr%id_lbm_dfy > 0) call safe_alloc_ptr(Tr%lbm_df_y,isd,ied,JsdB,JedB,nz) - if (Tr%id_lbm_dfx_2d > 0) call safe_alloc_ptr(Tr%lbm_df_x_2d,IsdB,IedB,jsd,jed) - if (Tr%id_lbm_dfy_2d > 0) call safe_alloc_ptr(Tr%lbm_df_y_2d,isd,ied,JsdB,JedB) + if (Tr%id_lbm_dfx > 0) call safe_alloc_ptr(Tr%lbm_dfx,IsdB,IedB,jsd,jed,nz) + if (Tr%id_lbm_dfy > 0) call safe_alloc_ptr(Tr%lbm_dfy,isd,ied,JsdB,JedB,nz) + if (Tr%id_lbm_dfx_2d > 0) call safe_alloc_ptr(Tr%lbm_dfx_2d,IsdB,IedB,jsd,jed) + if (Tr%id_lbm_dfy_2d > 0) call safe_alloc_ptr(Tr%lbm_dfy_2d,isd,ied,JsdB,JedB) Tr%id_adx_2d = register_diag_field("ocean_model", trim(shortnm)//"_adx_2d", & diag%axesCu1, Time, & From 9f15e4f7af8e97990bc3d8885dcf1e80df0ee105 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 24 Sep 2019 10:17:28 -0600 Subject: [PATCH 035/103] Adds new unit test and fixes diagnostics * A new unit test with with khtr=2 has been added; * The lateral mixing diagnostics *were not being multipled by the inverse of the time step (Idt) which is wrong. This explains why the values were very large (> 1PW). This commit fixes that. --- src/tracer/MOM_lateral_boundary_mixing.F90 | 30 +++++++++++++++++----- 1 file changed, 24 insertions(+), 6 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index a8aaa85452..5da3d3924d 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -141,7 +141,9 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer integer :: remap_method !< Reconstruction method integer :: i,j,k,m + real :: Idt !< inverse of the time step [s-1] + Idt = 1./dt hbl(:,:) = 0. if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) @@ -182,8 +184,8 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) enddo enddo ! Post tracer bulk diags - if (tracer%id_lbm_bulk_dfx>0) call post_data(tracer%id_lbm_bulk_dfx, uFlx_bulk, CS%diag) - if (tracer%id_lbm_bulk_dfy>0) call post_data(tracer%id_lbm_bulk_dfy, vFlx_bulk, CS%diag) + if (tracer%id_lbm_bulk_dfx>0) call post_data(tracer%id_lbm_bulk_dfx, uFlx_bulk*Idt, CS%diag) + if (tracer%id_lbm_bulk_dfy>0) call post_data(tracer%id_lbm_bulk_dfy, vFlx_bulk*Idt, CS%diag) elseif (CS%method == 2) then do j=G%jsc,G%jec @@ -215,12 +217,12 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) enddo ; enddo ; enddo ! Post the tracer diagnostics - if (tracer%id_lbm_dfx>0) call post_data(tracer%id_lbm_dfx, uFlx, CS%diag) - if (tracer%id_lbm_dfy>0) call post_data(tracer%id_lbm_dfy, vFlx, CS%diag) + if (tracer%id_lbm_dfx>0) call post_data(tracer%id_lbm_dfx, uFlx*Idt, CS%diag) + if (tracer%id_lbm_dfy>0) call post_data(tracer%id_lbm_dfy, vFlx*Idt, CS%diag) if (tracer%id_lbm_dfx_2d>0) then uwork_2d(:,:) = 0. do k=1,GV%ke; do j=G%jsc,G%jec; do I=G%isc-1,G%iec - uwork_2d(I,j) = uwork_2d(I,j) + uFlx(I,j,k) + uwork_2d(I,j) = uwork_2d(I,j) + (uFlx(I,j,k) * Idt) enddo; enddo; enddo call post_data(tracer%id_lbm_dfx_2d, uwork_2d, CS%diag) endif @@ -228,7 +230,7 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) if (tracer%id_lbm_dfy_2d>0) then vwork_2d(:,:) = 0. do k=1,GV%ke; do J=G%jsc-1,G%jec; do i=G%isc,G%iec - vwork_2d(i,J) = vwork_2d(i,J) + vFlx(i,J,k) + vwork_2d(i,J) = vwork_2d(i,J) + (vFlx(i,J,k) * Idt) enddo; enddo; enddo call post_data(tracer%id_lbm_dfy_2d, vwork_2d, CS%diag) endif @@ -804,6 +806,22 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) + test_name = 'hbl < column thickness, hbl same, linear profile right, khtr=2' + hbl_L = 2; hbl_R = 2 + h_L = (/1.,2./) ; h_R = (/1.,2./) + phi_L = (/0.,0./) ; phi_R = (/0.5,2./) + phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. + phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. + phi_pp_R(1,1) = 0.; phi_pp_R(1,2) = 1. + phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 2. + khtr_u = 2. + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) + near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-2.,-2./) ) ! unit tests for layer by layer method test_name = 'Different hbl and different column thicknesses (gradient from right to left)' hbl_L = 12; hbl_R = 20 From 5aaf34b7f4791a37150dde01eac785d987030248 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 25 Sep 2019 10:29:08 -0600 Subject: [PATCH 036/103] Add flux limiter for bulk layer fluxes --- src/tracer/MOM_lateral_boundary_mixing.F90 | 60 +++++++++++++++++----- 1 file changed, 47 insertions(+), 13 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 5da3d3924d..e6d68af3a2 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -170,7 +170,7 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) if (G%mask2dCu(I,j)>0.) then call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,j,:), h(i+1,j,:), hbl(i,j), hbl(i+1,j), & tracer%t(i,j,:), tracer%t(i+1,j,:), ppoly0_coefs(i,j,:,:), ppoly0_coefs(i+1,j,:,:), ppoly0_E(i,j,:,:), & - ppoly0_E(i+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:)) + ppoly0_E(i+1,j,:,:), remap_method, Coef_x(I,j), G%areaT(I,j), G%areaT(I+1,j), uFlx_bulk(I,j), uFlx(I,j,:)) endif enddo enddo @@ -179,7 +179,7 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) if (G%mask2dCv(i,J)>0.) then call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & - ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:)) + ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), G%areaT(i,J), G%areaT(i,J+1), vFlx_bulk(i,J), vFlx(i,J,:)) endif enddo enddo @@ -458,7 +458,7 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, end subroutine fluxes_layer_method !> Calculate the near-boundary diffusive fluxes calculated from a 'bulk model' -subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, & +subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, ppoly0_coefs_L, & ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] @@ -469,6 +469,8 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, !! layer (left) [m] real, intent(in ) :: hbl_R !< Thickness of the boundary boundary !! layer (left) [m] + real, intent(in ) :: area_L !< Area of the horizontal grid (left) [m^2] + real, intent(in ) :: area_R !< Area of the horizontal grid (right) [m^2] real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [ nondim m^-3 ] real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [ nondim m^-3 ] real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [ nondim m^-3 ] @@ -479,6 +481,8 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t at U-point [m^2] real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux [m^2 trunit] real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [m^2 trunit] + real, optional, dimension(nk), intent( out) :: F_limit !< The amount of flux not applied due to limiter + !! F_layer(k) - F_max [m^2 trunit] ! Local variables real, dimension(nk) :: h_means ! Calculate the layer-wise harmonic means [m] real, dimension(nk) :: h_u ! Thickness at the u-point [m] @@ -495,6 +499,8 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, real :: zeta_top_L, zeta_top_R, zeta_top_u real :: zeta_bot_L, zeta_bot_R, zeta_bot_u real :: h_work_L, h_work_R ! dummy variables + real :: F_max !< The maximum amount of flux that can leave a cell + logical :: limited !< True if the flux limiter was applied if (hbl_L == 0. .or. hbl_R == 0.) then F_bulk = 0. F_layer(:) = 0. @@ -573,8 +579,33 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, inv_heff = 1./SUM(h_means) ! Decompose the bulk flux onto the individual layers do k=1,nk + ! Limit the tracer flux so that the donor cell with positive concentration can't go negative + ! If a tracer can go negative, it is unclear what the limiter should be. BOB ALISTAIR?! if ( SIGN(1.,F_bulk) == SIGN(1., -(phi_R(k)-phi_L(k))) ) then + if (F_bulk < 0. .and. phi_R(k) > 0.) then + F_max = 0.25 * (area_R*(phi_R(k)*h_R(k))) + elseif (F_bulk > 0. .and. phi_L(k) > 0.) then + F_max = 0.25 * (area_L*(phi_L(k)*h_L(k))) + else ! The above quantities are always positive, so we can use F_max < -1 to see if we don't need to limit + F_max = -1. + endif + ! Distribute bulk flux onto layers F_layer(k) = F_bulk * (h_means(k)*inv_heff) + ! Apply flux limiter calculated above + if (F_max > 0.) then + if (F_layer(k) > 0.) then + F_layer(k) = MIN(F_layer(k),F_max) + elseif (F_layer(k) < 0.) then + F_layer(k) = MAX(F_layer(k),F_max) + endif + endif + if (PRESENT(F_limiter)) then + if (limited) then + F_limiter(k) = F_layer(k) - F_max + else + F_limiter(k) = 0. + endif + endif else F_layer(k) = 0. endif @@ -611,6 +642,9 @@ logical function near_boundary_unit_tests( verbose ) real :: zeta_top ! Nondimension position integer :: k_bot ! Index of cell containing bottom of boundary real :: zeta_bot ! Nondimension position + real :: area_L,area_R ! Area of grid cell [m^2] + area_L = 1.; area_R = 1. ! Set to unity for all unit tests + near_boundary_unit_tests = .false. ! Unit tests for boundary_k_range @@ -668,7 +702,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R, & ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) @@ -685,7 +719,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. ppoly0_E_R(2,1) = 0.; ppoly0_E_R(2,2) = 0. khtr_u = 1. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) @@ -702,7 +736,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) @@ -719,7 +753,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) @@ -736,7 +770,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 0. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) @@ -753,7 +787,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) @@ -770,7 +804,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) @@ -785,7 +819,7 @@ logical function near_boundary_unit_tests( verbose ) phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. khtr_u = 1. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) @@ -802,7 +836,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) @@ -819,7 +853,7 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-2.,-2./) ) ! unit tests for layer by layer method From ca23e661b27120c09e29559bee1d0bdc77b4704c Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Wed, 25 Sep 2019 16:51:08 -0600 Subject: [PATCH 037/103] Make fluxes_bulk_method more roundoff safe Bulk fluxes were being decomposed onto layers using h/hsum which is not roundoff safe potentially leading to ABS(F_bulk)0.) then - call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,j,:), h(i+1,j,:), hbl(i,j), hbl(i+1,j), & - tracer%t(i,j,:), tracer%t(i+1,j,:), ppoly0_coefs(i,j,:,:), ppoly0_coefs(i+1,j,:,:), ppoly0_E(i,j,:,:), & - ppoly0_E(i+1,j,:,:), remap_method, Coef_x(I,j), G%areaT(I,j), G%areaT(I+1,j), uFlx_bulk(I,j), uFlx(I,j,:)) + call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), & + ppoly0_coefs(I,j,:,:), ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), & + ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:)) endif enddo enddo @@ -178,8 +179,9 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) do i=G%isc,G%iec if (G%mask2dCv(i,J)>0.) then call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & - tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & - ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), G%areaT(i,J), G%areaT(i,J+1), vFlx_bulk(i,J), vFlx(i,J,:)) + G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), & + ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & + ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:)) endif enddo enddo @@ -459,7 +461,7 @@ end subroutine fluxes_layer_method !> Calculate the near-boundary diffusive fluxes calculated from a 'bulk model' subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, ppoly0_coefs_L, & - ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) + ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, F_limit) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] @@ -501,6 +503,8 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real :: h_work_L, h_work_R ! dummy variables real :: F_max !< The maximum amount of flux that can leave a cell logical :: limited !< True if the flux limiter was applied + real :: hfrac, hremain + if (hbl_L == 0. .or. hbl_R == 0.) then F_bulk = 0. F_layer(:) = 0. @@ -576,6 +580,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, if ( SUM(h_means) == 0. ) then return else + hremain = 1. inv_heff = 1./SUM(h_means) ! Decompose the bulk flux onto the individual layers do k=1,nk @@ -589,8 +594,16 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, else ! The above quantities are always positive, so we can use F_max < -1 to see if we don't need to limit F_max = -1. endif + ! Initialize remaining thickness + hfrac = h_means(k)*inv_heff ! Distribute bulk flux onto layers - F_layer(k) = F_bulk * (h_means(k)*inv_heff) + if ( ((boundary == SURFACE) .and. (k == k_min)) .or. ((boundary == BOTTOM) .and. (k == nk)) ) then + F_layer(k) = F_bulk * hremain + else + F_layer(k) = F_bulk * hfrac + endif + hremain = MAX(0.,hremain-hfrac) + ! Apply flux limiter calculated above if (F_max > 0.) then if (F_layer(k) > 0.) then @@ -599,11 +612,11 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, F_layer(k) = MAX(F_layer(k),F_max) endif endif - if (PRESENT(F_limiter)) then + if (PRESENT(F_limit)) then if (limited) then - F_limiter(k) = F_layer(k) - F_max + F_limit(k) = F_layer(k) - F_max else - F_limiter(k) = 0. + F_limit(k) = 0. endif endif else From 91ca2d13ee6a95b1a7d5aa7c01d8fa952d7a961a Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 26 Sep 2019 10:17:06 -0600 Subject: [PATCH 038/103] Fix flux limiter in LBM when < 0 The previous flux limiter which doesn't allow the diffusive flux to be greater than a 1/4 of the tracer inventory was incorrect when the sign of the flux was negative. This has been fixed. Incidentally, an additional 'if' condition was placed at the top of the loop calculating the layer fluxes to avoid unnecessary evaluations when we don't expect to be calculating a flux. --- src/tracer/MOM_lateral_boundary_mixing.F90 | 67 ++++++++++++---------- 1 file changed, 36 insertions(+), 31 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 265a2ca8ee..1304505c1b 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -580,44 +580,49 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, if ( SUM(h_means) == 0. ) then return else + ! Initialize remaining thickness hremain = 1. inv_heff = 1./SUM(h_means) ! Decompose the bulk flux onto the individual layers do k=1,nk - ! Limit the tracer flux so that the donor cell with positive concentration can't go negative - ! If a tracer can go negative, it is unclear what the limiter should be. BOB ALISTAIR?! - if ( SIGN(1.,F_bulk) == SIGN(1., -(phi_R(k)-phi_L(k))) ) then - if (F_bulk < 0. .and. phi_R(k) > 0.) then - F_max = 0.25 * (area_R*(phi_R(k)*h_R(k))) - elseif (F_bulk > 0. .and. phi_L(k) > 0.) then - F_max = 0.25 * (area_L*(phi_L(k)*h_L(k))) - else ! The above quantities are always positive, so we can use F_max < -1 to see if we don't need to limit - F_max = -1. - endif - ! Initialize remaining thickness - hfrac = h_means(k)*inv_heff - ! Distribute bulk flux onto layers - if ( ((boundary == SURFACE) .and. (k == k_min)) .or. ((boundary == BOTTOM) .and. (k == nk)) ) then - F_layer(k) = F_bulk * hremain - else - F_layer(k) = F_bulk * hfrac - endif - hremain = MAX(0.,hremain-hfrac) - - ! Apply flux limiter calculated above - if (F_max > 0.) then - if (F_layer(k) > 0.) then - F_layer(k) = MIN(F_layer(k),F_max) - elseif (F_layer(k) < 0.) then - F_layer(k) = MAX(F_layer(k),F_max) + if (h_means(k) > 0.) then + ! Limit the tracer flux so that the donor cell with positive concentration can't go negative + ! If a tracer can go negative, it is unclear what the limiter should be. BOB ALISTAIR?! + if ( SIGN(1.,F_bulk) == SIGN(1., -(phi_R(k)-phi_L(k))) ) then + if (F_bulk < 0. .and. phi_R(k) > 0.) then + F_max = 0.25 * (area_R*(phi_R(k)*h_R(k))) + elseif (F_bulk > 0. .and. phi_L(k) > 0.) then + F_max = 0.25 * (area_L*(phi_L(k)*h_L(k))) + else ! The above quantities are always positive, so we can use F_max < -1 to see if we don't need to limit + F_max = -1. endif - endif - if (PRESENT(F_limit)) then - if (limited) then - F_limit(k) = F_layer(k) - F_max + hfrac = h_means(k)*inv_heff + ! Distribute bulk flux onto layers + if ( ((boundary == SURFACE) .and. (k == k_min)) .or. ((boundary == BOTTOM) .and. (k == nk)) ) then + F_layer(k) = F_bulk * hremain + hremain = 0. else - F_limit(k) = 0. + F_layer(k) = F_bulk * hfrac + hremain = MAX(0.,hremain-hfrac) endif + + ! Apply flux limiter calculated above + if (F_max > 0.) then + if (F_layer(k) > 0.) then + F_layer(k) = MIN(F_layer(k),F_max) + elseif (F_layer(k) < 0.) then + F_layer(k) = MAX(F_layer(k),-F_max) ! Note negative to make the sign of flux consistent + endif + endif + if (PRESENT(F_limit)) then + if (limited) then + F_limit(k) = F_layer(k) - F_max + else + F_limit(k) = 0. + endif + endif + else + F_layer(k) = 0. endif else F_layer(k) = 0. From 82c1bca137590dd6c7f8f869cfe3f94d69c98ad7 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 26 Sep 2019 13:19:37 -0600 Subject: [PATCH 039/103] First set of commits to limit neutral diffusion to the interior * Get hbl in neutral_diffusion_calc_coeffs * Calculate layer indices and positions of the boundary layer * Find neutral positions exclusing the boundary layer TODO: * Implement BOTTOM boundary layer * Test it --- src/tracer/MOM_lateral_boundary_mixing.F90 | 6 +- src/tracer/MOM_neutral_diffusion.F90 | 91 +++++++++++++++++++--- src/tracer/MOM_tracer_hor_diff.F90 | 7 +- 3 files changed, 86 insertions(+), 18 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 1304505c1b..4371fddcea 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -26,10 +26,10 @@ module MOM_lateral_boundary_mixing implicit none ; private public near_boundary_unit_tests, lateral_boundary_mixing, lateral_boundary_mixing_init - +public boundary_k_range ! Private parameters to avoid doing string comparisons for bottom or top boundary layer -integer, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface bopundary -integer, parameter :: BOTTOM = 1 !< Set a value that corresponds to the bottom boundary +integer, public, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface bopundary +integer, public, parameter :: BOTTOM = 1 !< Set a value that corresponds to the bottom boundary #include !> Sets parameters for lateral boundary mixing module. diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index ae17f8c9a8..25adcf3820 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -5,6 +5,7 @@ module MOM_neutral_diffusion use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_domains, only : pass_var use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_diag_mediator, only : post_data, register_diag_field use MOM_EOS, only : EOS_type, EOS_manual_init, calculate_compress, calculate_density_derivs @@ -23,7 +24,10 @@ module MOM_neutral_diffusion use polynomial_functions, only : evaluation_polynomial, first_derivative_polynomial use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation use regrid_edge_values, only : edge_values_implicit_h4 - +use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS +use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS +use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member +use MOM_lateral_boundary_mixing, only : boundary_k_range, SURFACE, BOTTOM implicit none ; private #include @@ -43,7 +47,8 @@ module MOM_neutral_diffusion real :: drho_tol !< Convergence criterion representing difference from true neutrality real :: x_tol !< Convergence criterion for how small an update of the position can be real :: ref_pres !< Reference pressure, negative if using locally referenced neutral density - + logical :: interior_only !< If true, only applies neutral diffusion in the ocean interior. + !! That is, the algorithm will exclude the surface and bottom boundary layers. ! Positions of neutral surfaces in both the u, v directions real, allocatable, dimension(:,:,:) :: uPoL !< Non-dimensional position with left layer uKoL-1, u-point real, allocatable, dimension(:,:,:) :: uPoR !< Non-dimensional position with right layer uKoR-1, u-point @@ -88,6 +93,8 @@ module MOM_neutral_diffusion real :: C_p !< heat capacity of seawater (J kg-1 K-1) type(EOS_type), pointer :: EOS !< Equation of state parameters type(remapping_CS) :: remap_CS !< Remapping control structure used to create sublayers + type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to get BLD + type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure needed to get MLD end type neutral_diffusion_CS ! This include declares and sets the variable "version". @@ -97,12 +104,13 @@ module MOM_neutral_diffusion contains !> Read parameters and allocate control structure for neutral_diffusion module. -logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) +logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic_CSp, CS) type(time_type), target, intent(in) :: Time !< Time structure type(ocean_grid_type), intent(in) :: G !< Grid structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), target, intent(in) :: EOS !< Equation of state + type(diabatic_CS), pointer :: diabatic_CSp!< KPP control structure needed to get BLD type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables @@ -115,6 +123,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) return endif + ! Log this module and master switch for turning it on/off call log_version(param_file, mdl, version, & "This module implements neutral diffusion of tracers") @@ -143,6 +152,15 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) "the equation of state. If negative (default), local "//& "pressure is used.", & default = -1.) + call get_param(param_file, mdl, "NDIFF_INTERIOR_ONLY", CS%interior_only, & + "If true, only applies neutral diffusion in the ocean interior."//& + "That is, the algorithm will exclude the surface and bottom"//& + "boundary layers.",default = .false.) + + if (CS%continuous_reconstruction == .true. .and. CS%interior_only) then + call MOM_error(FATAL,"NDIFF_INTERIOR_ONLY=True only works with discontinuous" //& + "reconstruction.") + endif ! Initialize and configure remapping if (CS%continuous_reconstruction .eqv. .false.) then call get_param(param_file, mdl, "NDIFF_BOUNDARY_EXTRAP", boundary_extrap, & @@ -193,6 +211,14 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) default = .false.) endif + if (CS%interior_only) then + call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) + call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) + if ( .not. ASSOCIATED(CS%energetic_PBL_CSp) .and. .not. ASSOCIATED(CS%KPP_CSp) ) then + call MOM_error(FATAL,"NDIFF_INTERIOR_ONLY is true, but no valid boundary layer scheme was found") + endif + endif + ! call get_param(param_file, mdl, "KHTR", CS%KhTr, & ! "The background along-isopycnal tracer diffusivity.", & ! units="m2 s-1", default=0.0) @@ -234,9 +260,10 @@ end function neutral_diffusion_init !> Calculate remapping factors for u/v columns used to map adjoining columns to !! a shared coordinate space. -subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) +subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T !< Potential temperature [degC] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S !< Salinity [ppt] @@ -247,14 +274,33 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) ! Variables used for reconstructions real, dimension(SZK_(G),2) :: ppoly_r_S ! Reconstruction slopes real, dimension(SZI_(G), SZJ_(G)) :: hEff_sum + real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [m] integer :: iMethod real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta - real, dimension(SZI_(G)) :: rho_tmp ! Routiine to calculate drho_dp, returns density which is not used + real, dimension(SZI_(G)) :: rho_tmp ! Routine to calculate drho_dp, returns density which is not used real :: h_neglect, h_neglect_edge + integer, dimension(SZI_(G), SZJ_(G)) :: k_top !< Index of the first layer within the boundary + real, dimension(SZI_(G), SZJ_(G)) :: zeta_top !< Distance from the top of a layer to the intersection of the + !! top extent of the boundary layer (0 at top, 1 at bottom) [nondim] + integer, dimension(SZI_(G), SZJ_(G)) :: k_bot !< Index of the last layer within the boundary + real, dimension(SZI_(G), SZJ_(G)) :: zeta_bot !< Distance of the lower layer to the boundary layer depth real :: pa_to_H pa_to_H = 1. / GV%H_to_pa + ! check if hbl needs to be extracted + if (CS%interior_only) then + hbl(:,:) = 0. + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) + if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) + call pass_var(hbl,G%Domain) + ! get k-indices and zeta + do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 + call boundary_k_range(SURFACE, G%ke, h(i,j,:), hbl(i,j), k_top(i,j), zeta_top(i,j), k_bot(i,j), zeta_bot(i,j)) + enddo; enddo + ! TODO: add similar code for BOTTOM boundary layer + endif + !### Try replacing both of these with GV%H_subroundoff if (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 @@ -346,7 +392,14 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) if (.not. CS%continuous_reconstruction) then do j = G%jsc-1, G%jec+1 ; do i = G%isc-1, G%iec+1 call mark_unstable_cells( CS, G%ke, CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%P_i(i,j,:,:), CS%stable_cell(i,j,:) ) - enddo ; enddo + if (CS%interior_only) then + if (.not. CS%stable_cell(i,j,k_bot(i,j))) zeta_bot(i,j) = -1. + ! set values in the surface and bottom boundary layer to false. + do k = 1, k_bot(i,j)-1 + CS%stable_cell(i,j,k) = .false. + enddo + endif + enddo ; enddo endif CS%uhEff(:,:,:) = 0. @@ -1055,7 +1108,8 @@ end function interpolate_for_nondim_position !! of T and S are optional to aid with unit testing, but will always be passed otherwise subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, Tl, Sl, ppoly_T_l, ppoly_S_l, stable_l,& Pres_r, hcol_r, Tr, Sr, ppoly_T_r, ppoly_S_r, stable_r,& - PoL, PoR, KoL, KoR, hEff) + PoL, PoR, KoL, KoR, hEff, zeta_bot_L, zeta_bot_R, & + k_bot_L, k_bot_R) type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure integer, intent(in) :: nk !< Number of levels @@ -1080,7 +1134,13 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, integer, dimension(4*nk), intent(inout) :: KoL !< Index of first left interface above neutral surface integer, dimension(4*nk), intent(inout) :: KoR !< Index of first right interface above neutral surface real, dimension(4*nk-1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces (Pa) + real, optional, intent(in) :: zeta_bot_L!< Non-dimensional distance to where the boundary layer + !! intersetcs the cell (left) [nondim] + real, optional, intent(in) :: zeta_bot_R!< Non-dimensional distance to where the boundary layer + !! intersetcs the cell (right) [nondim] + integer, optional, intent(in) :: k_bot_L !< k-index for the boundary layer (left) [nondim] + integer, optional, intent(in) :: k_bot_R !< k-index for the boundary layer (right) [nondim] ! Local variables integer :: ns ! Number of neutral surfaces integer :: k_surface ! Index of neutral surface @@ -1098,7 +1158,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, real :: dRdT_to_bot, dRdS_to_bot ! Density derivatives at the interfaces being searched real :: T_ref, S_ref, P_ref, P_top, P_bot real :: lastP_left, lastP_right - + integer :: k_init_L, k_init_R ! Starting indices layers for left and right + real :: p_init_L, p_init_R ! Starting positions for left and right ! Initialize variables for the search ns = 4*nk ki_right = 1 @@ -1111,6 +1172,12 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, searching_left_column = .false. searching_right_column = .false. + if (PRESENT(k_bot_L) .and. PRESENT(k_bot_R) .and. PRESENT(zeta_bot_L) .and. PRESENT(zeta_bot_R)) then + k_init_L = k_bot_L; k_init_R = k_bot_R + p_init_L = zeta_bot_L; p_init_R = zeta_bot_R + lastP_left = zeta_bot_L; lastP_right = zeta_bot_R + kl_left = k_bot_L; kl_right = k_bot_R + endif ! Loop over each neutral surface, working from top to bottom neutral_surfaces: do k_surface = 1, ns @@ -1127,10 +1194,10 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, PoR(k_surface) = PoR(k_surface-1) KoR(k_surface) = KoR(k_surface-1) else - PoR(k_surface) = 0. - KoR(k_surface) = 1 - PoL(k_surface) = 0. - KoL(k_Surface) = 1 + PoR(k_surface) = p_init_R + KoR(k_surface) = k_init_R + PoL(k_surface) = p_init_L + KoL(k_Surface) = k_init_L endif call increment_interface(nk, kl_left, ki_left, reached_bottom, searching_left_column, searching_right_column) searching_left_column = .true. diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 9f2fc39711..f5efea9b81 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -423,7 +423,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online ! lateral diffusion iterations. Otherwise the call to neutral_diffusion_calc_coeffs() ! would be inside the itt-loop. -AJA - call neutral_diffusion_calc_coeffs(G, GV, h, tv%T, tv%S, CS%neutral_diffusion_CSp) + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) do J=js-1,je ; do i=is,ie Coef_y(i,J) = I_numitts * khdt_y(i,J) enddo ; enddo @@ -438,7 +438,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (itt>1) then ! Update halos for subsequent iterations call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) if (CS%recalc_neutral_surf) then - call neutral_diffusion_calc_coeffs(G, GV, h, tv%T, tv%S, CS%neutral_diffusion_CSp) + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) endif endif call neutral_diffusion(G, GV, h, Coef_x, Coef_y, I_numitts*dt, Reg, US, CS%neutral_diffusion_CSp) @@ -1496,7 +1496,8 @@ subroutine tracer_hor_diff_init(Time, G, US, param_file, diag, EOS, diabatic_CSp units="nondim", default=1.0) endif - CS%use_neutral_diffusion = neutral_diffusion_init(Time, G, param_file, diag, EOS, CS%neutral_diffusion_CSp ) + CS%use_neutral_diffusion = neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic_CSp, & + CS%neutral_diffusion_CSp ) if (CS%use_neutral_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & "USE_NEUTRAL_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") CS%use_lateral_boundary_mixing = lateral_boundary_mixing_init(Time, G, param_file, diag, diabatic_CSp, & From d7da98270a4212b5ebcfb5eecb36d3fba46377c8 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 26 Sep 2019 13:43:27 -0600 Subject: [PATCH 040/103] Improves the calculation of F_bulk to minimize roundoff errors TODO: * Add a diagnostic for F_limiter, i.e., the amount of flux neglected due to the limiter. --- src/tracer/MOM_lateral_boundary_mixing.F90 | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 4371fddcea..3378409d4c 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -503,7 +503,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real :: h_work_L, h_work_R ! dummy variables real :: F_max !< The maximum amount of flux that can leave a cell logical :: limited !< True if the flux limiter was applied - real :: hfrac, hremain + real :: hfrac, F_bulk_remain if (hbl_L == 0. .or. hbl_R == 0.) then F_bulk = 0. @@ -527,7 +527,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities heff = harmonic_mean(hbl_L, hbl_R) F_bulk = -(khtr_u * heff) * (phi_R_avg - phi_L_avg) - if (F_bulk .ne. F_bulk) print *, khtr_avg, heff, phi_R_avg, phi_L_avg, hbl_L, hbl_R + F_bulk_remain = F_bulk ! Calculate the layerwise sum of the vertical effective thickness. This is different than the heff calculated ! above, but is used as a way to decompose decompose the fluxes onto the individual layers h_means(:) = 0. @@ -581,14 +581,15 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, return else ! Initialize remaining thickness - hremain = 1. inv_heff = 1./SUM(h_means) ! Decompose the bulk flux onto the individual layers do k=1,nk if (h_means(k) > 0.) then ! Limit the tracer flux so that the donor cell with positive concentration can't go negative ! If a tracer can go negative, it is unclear what the limiter should be. BOB ALISTAIR?! - if ( SIGN(1.,F_bulk) == SIGN(1., -(phi_R(k)-phi_L(k))) ) then + hfrac = h_means(k)*inv_heff + F_layer(k) = F_bulk * hfrac + if ( SIGN(1.,F_bulk) == SIGN(1., F_layer(k))) then if (F_bulk < 0. .and. phi_R(k) > 0.) then F_max = 0.25 * (area_R*(phi_R(k)*h_R(k))) elseif (F_bulk > 0. .and. phi_L(k) > 0.) then @@ -596,21 +597,18 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, else ! The above quantities are always positive, so we can use F_max < -1 to see if we don't need to limit F_max = -1. endif - hfrac = h_means(k)*inv_heff ! Distribute bulk flux onto layers if ( ((boundary == SURFACE) .and. (k == k_min)) .or. ((boundary == BOTTOM) .and. (k == nk)) ) then - F_layer(k) = F_bulk * hremain - hremain = 0. - else - F_layer(k) = F_bulk * hfrac - hremain = MAX(0.,hremain-hfrac) + F_layer(k) = F_bulk_remain endif - + F_bulk_remain = F_bulk_remain - F_layer(k) ! Apply flux limiter calculated above if (F_max > 0.) then if (F_layer(k) > 0.) then + limited = F_layer(k) > F_max F_layer(k) = MIN(F_layer(k),F_max) elseif (F_layer(k) < 0.) then + limited = F_layer(k) < -F_max F_layer(k) = MAX(F_layer(k),-F_max) ! Note negative to make the sign of flux consistent endif endif @@ -622,6 +620,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, endif endif else + F_bulk_remain = F_bulk_remain - F_layer(k) F_layer(k) = 0. endif else From e806fbabdf8a7cefa3423649eb03a2656bb05ec0 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 26 Sep 2019 14:48:56 -0600 Subject: [PATCH 041/103] Fixes a bug in the bulk_method When limiting the fluxes, we left out the case when tracer concentration is zero which can lead to negative tracer values. --- src/tracer/MOM_lateral_boundary_mixing.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_mixing.F90 index 3378409d4c..7eadfb7cb6 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_mixing.F90 @@ -590,9 +590,9 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, hfrac = h_means(k)*inv_heff F_layer(k) = F_bulk * hfrac if ( SIGN(1.,F_bulk) == SIGN(1., F_layer(k))) then - if (F_bulk < 0. .and. phi_R(k) > 0.) then + if (F_bulk < 0. .and. phi_R(k) >= 0.) then F_max = 0.25 * (area_R*(phi_R(k)*h_R(k))) - elseif (F_bulk > 0. .and. phi_L(k) > 0.) then + elseif (F_bulk > 0. .and. phi_L(k) >= 0.) then F_max = 0.25 * (area_L*(phi_L(k)*h_L(k))) else ! The above quantities are always positive, so we can use F_max < -1 to see if we don't need to limit F_max = -1. @@ -603,7 +603,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, endif F_bulk_remain = F_bulk_remain - F_layer(k) ! Apply flux limiter calculated above - if (F_max > 0.) then + if (F_max >= 0.) then if (F_layer(k) > 0.) then limited = F_layer(k) > F_max F_layer(k) = MIN(F_layer(k),F_max) From af410950e5baf70ec66f88d129ee8c9d4420dd78 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 26 Sep 2019 17:17:01 -0600 Subject: [PATCH 042/103] Fix uninitialized variables in find_surface when NDIFF_INTERIOR_ONLY = False --- src/tracer/MOM_neutral_diffusion.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 25adcf3820..4e7b87886a 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1177,6 +1177,9 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, p_init_L = zeta_bot_L; p_init_R = zeta_bot_R lastP_left = zeta_bot_L; lastP_right = zeta_bot_R kl_left = k_bot_L; kl_right = k_bot_R + else + k_init_L = 1 ; k_init_R = 1 + p_init_L = 0. ; p_init_R = 0. endif ! Loop over each neutral surface, working from top to bottom neutral_surfaces: do k_surface = 1, ns From 69ec18c3a93dc4fbe3734e01ca31ad65eb516022 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 27 Sep 2019 09:39:13 -0600 Subject: [PATCH 043/103] Removes redundant statement in netrual diffusion --- src/tracer/MOM_neutral_diffusion.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 4e7b87886a..47f346a9d1 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -157,7 +157,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic "That is, the algorithm will exclude the surface and bottom"//& "boundary layers.",default = .false.) - if (CS%continuous_reconstruction == .true. .and. CS%interior_only) then + if (CS%continuous_reconstruction .and. CS%interior_only) then call MOM_error(FATAL,"NDIFF_INTERIOR_ONLY=True only works with discontinuous" //& "reconstruction.") endif From 5583f84db36f03294196ea38e93f421269b06b31 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 27 Sep 2019 14:36:09 -0600 Subject: [PATCH 044/103] Renames lateral_boundary_mixing to lateral_boundary_diffusion We think this is a more appropriate name. --- src/core/MOM_unit_tests.F90 | 2 +- ...F90 => MOM_lateral_boundary_diffusion.F90} | 36 +++++++++---------- src/tracer/MOM_neutral_diffusion.F90 | 2 +- src/tracer/MOM_tracer_hor_diff.F90 | 18 +++++----- 4 files changed, 29 insertions(+), 29 deletions(-) rename src/tracer/{MOM_lateral_boundary_mixing.F90 => MOM_lateral_boundary_diffusion.F90} (97%) diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index 844d0efb67..4197cfea3f 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -9,7 +9,7 @@ module MOM_unit_tests use MOM_remapping, only : remapping_unit_tests use MOM_neutral_diffusion, only : neutral_diffusion_unit_tests use MOM_diag_vkernels, only : diag_vkernels_unit_tests -use MOM_lateral_boundary_mixing, only : near_boundary_unit_tests +use MOM_lateral_boundary_diffusion, only : near_boundary_unit_tests implicit none ; private diff --git a/src/tracer/MOM_lateral_boundary_mixing.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 similarity index 97% rename from src/tracer/MOM_lateral_boundary_mixing.F90 rename to src/tracer/MOM_lateral_boundary_diffusion.F90 index 7eadfb7cb6..c5967900a5 100644 --- a/src/tracer/MOM_lateral_boundary_mixing.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -1,6 +1,6 @@ !> Calculate and apply diffusive fluxes as a parameterization of lateral mixing (non-neutral) by !! mesoscale eddies near the top and bottom boundary layers of the ocean. -module MOM_lateral_boundary_mixing +module MOM_lateral_boundary_diffusion ! This file is part of MOM6. See LICENSE.md for the license. @@ -25,7 +25,7 @@ module MOM_lateral_boundary_mixing implicit none ; private -public near_boundary_unit_tests, lateral_boundary_mixing, lateral_boundary_mixing_init +public near_boundary_unit_tests, lateral_boundary_diffusion, lateral_boundary_diffusion_init public boundary_k_range ! Private parameters to avoid doing string comparisons for bottom or top boundary layer integer, public, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface bopundary @@ -33,7 +33,7 @@ module MOM_lateral_boundary_mixing #include !> Sets parameters for lateral boundary mixing module. -type, public :: lateral_boundary_mixing_CS ; private +type, public :: lateral_boundary_diffusion_CS ; private integer :: method !< Determine which of the three methods calculate !! and apply near boundary layer fluxes !! 1. bulk-layer approach @@ -47,40 +47,40 @@ module MOM_lateral_boundary_mixing type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure needed to get MLD type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. -end type lateral_boundary_mixing_CS +end type lateral_boundary_diffusion_CS ! This include declares and sets the variable "version". #include "version_variable.h" -character(len=40) :: mdl = "MOM_lateral_boundary_mixing" !< Name of this module +character(len=40) :: mdl = "MOM_lateral_boundary_diffusion" !< Name of this module contains !> Initialization routine that reads runtime parameters and sets up pointers to other control structures that might be !! needed for lateral boundary mixing -logical function lateral_boundary_mixing_init(Time, G, param_file, diag, diabatic_CSp, CS) +logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diabatic_CSp, CS) type(time_type), target, intent(in) :: Time !< Time structure type(ocean_grid_type), intent(in) :: G !< Grid structure type(param_file_type), intent(in) :: param_file !< Parameter file structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(diabatic_CS), pointer :: diabatic_CSp !< KPP control structure needed to get BLD - type(lateral_boundary_mixing_CS), pointer :: CS !< Lateral boundary mixing control structure + type(lateral_boundary_diffusion_CS), pointer :: CS !< Lateral boundary mixing control structure character(len=80) :: string ! Temporary strings logical :: boundary_extrap if (ASSOCIATED(CS)) then - call MOM_error(FATAL, "lateral_boundary_mixing_init called with associated control structure.") + call MOM_error(FATAL, "lateral_boundary_diffusion_init called with associated control structure.") return endif ! Log this module and master switch for turning it on/off call log_version(param_file, mdl, version, & "This module implements lateral boundary mixing of tracers") - call get_param(param_file, mdl, "USE_LATERAL_BOUNDARY_MIXING", lateral_boundary_mixing_init, & + call get_param(param_file, mdl, "USE_LATERAL_BOUNDARY_DIFFUSION", lateral_boundary_diffusion_init, & "If true, enables the lateral boundary mixing module.", & default=.false.) - if (.not. lateral_boundary_mixing_init) then + if (.not. lateral_boundary_diffusion_init) then return endif @@ -100,10 +100,10 @@ logical function lateral_boundary_mixing_init(Time, G, param_file, diag, diabati "1. Bulk layer approach"//& "2. Along layer approach"//& "3. Decomposition on to pressure levels", default=1) - call get_param(param_file, mdl, "LBM_BOUNDARY_EXTRAP", boundary_extrap, & - "Use boundary extrapolation in LBM code", & + call get_param(param_file, mdl, "LBD_BOUNDARY_EXTRAP", boundary_extrap, & + "Use boundary extrapolation in LBD code", & default=.false.) - call get_param(param_file, mdl, "LBM_REMAPPING_SCHEME", string, & + call get_param(param_file, mdl, "LBD_REMAPPING_SCHEME", string, & "This sets the reconstruction scheme used "//& "for vertical remapping for all variables. "//& "It can be one of the following schemes: "//& @@ -111,11 +111,11 @@ logical function lateral_boundary_mixing_init(Time, G, param_file, diag, diabati call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) -end function lateral_boundary_mixing_init +end function lateral_boundary_diffusion_init !> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. Two different methods !! Method 1: Calculate fluxes from bulk layer integrated quantities -subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) +subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) type(ocean_grid_type), intent(inout) :: G !< Grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -126,7 +126,7 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real, intent(in) :: dt !< Tracer time step * I_numitts !! (I_numitts in tracer_hordiff) type(tracer_registry_type), pointer :: Reg !< Tracer registry - type(lateral_boundary_mixing_CS), intent(in) :: CS !< Control structure for this module + type(lateral_boundary_diffusion_CS), intent(in) :: CS !< Control structure for this module ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [m] real, dimension(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1) :: ppoly0_coefs !< Coefficients of polynomial @@ -238,7 +238,7 @@ subroutine lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) endif enddo -end subroutine lateral_boundary_mixing +end subroutine lateral_boundary_diffusion !< Calculate bulk layer value of a scalar quantity as the thickness weighted average real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coefs, method, k_top, zeta_top, k_bot, & @@ -970,4 +970,4 @@ logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_a end function test_boundary_k_range -end module MOM_lateral_boundary_mixing +end module MOM_lateral_boundary_diffusion diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 47f346a9d1..8a048685d6 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -27,7 +27,7 @@ module MOM_neutral_diffusion use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member -use MOM_lateral_boundary_mixing, only : boundary_k_range, SURFACE, BOTTOM +use MOM_lateral_boundary_diffusion, only : boundary_k_range, SURFACE, BOTTOM implicit none ; private #include diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index f5efea9b81..0c108ceacb 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -23,8 +23,8 @@ module MOM_tracer_hor_diff use MOM_neutral_diffusion, only : neutral_diffusion_init, neutral_diffusion_end use MOM_neutral_diffusion, only : neutral_diffusion_CS use MOM_neutral_diffusion, only : neutral_diffusion_calc_coeffs, neutral_diffusion -use MOM_lateral_boundary_mixing, only : lateral_boundary_mixing_CS, lateral_boundary_mixing_init -use MOM_lateral_boundary_mixing, only : lateral_boundary_mixing +use MOM_lateral_boundary_diffusion, only : lateral_boundary_diffusion_CS, lateral_boundary_diffusion_init +use MOM_lateral_boundary_diffusion, only : lateral_boundary_diffusion use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chksum use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -60,12 +60,12 @@ module MOM_tracer_hor_diff !! the CFL limit is not violated. logical :: use_neutral_diffusion !< If true, use the neutral_diffusion module from within !! tracer_hor_diff. - logical :: use_lateral_boundary_mixing !< If true, use the lateral_boundary_mixing module from within + logical :: use_lateral_boundary_diffusion !< If true, use the lateral_boundary_diffusion module from within !! tracer_hor_diff. logical :: recalc_neutral_surf !< If true, recalculate the neutral surfaces if CFL has been !! exceeded type(neutral_diffusion_CS), pointer :: neutral_diffusion_CSp => NULL() !< Control structure for neutral diffusion. - type(lateral_boundary_mixing_CS), pointer :: lateral_boundary_mixing_CSp => NULL() !< Control structure for lateral + type(lateral_boundary_diffusion_CS), pointer :: lateral_boundary_diffusion_CSp => NULL() !< Control structure for lateral !! boundary mixing. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. @@ -390,7 +390,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online endif enddo - if (CS%use_lateral_boundary_mixing) then + if (CS%use_lateral_boundary_diffusion) then if (CS%show_call_tree) call callTree_waypoint("Calling lateral boundary mixing (tracer_hordiff)") @@ -410,7 +410,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (itt>1) then ! Update halos for subsequent iterations call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) endif - call lateral_boundary_mixing(G, GV, US, h, Coef_x, Coef_y, I_numitts*dt, Reg, CS%lateral_boundary_mixing_CSp) + call lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, I_numitts*dt, Reg, CS%lateral_boundary_diffusion_CSp) enddo ! itt endif @@ -1500,10 +1500,10 @@ subroutine tracer_hor_diff_init(Time, G, US, param_file, diag, EOS, diabatic_CSp CS%neutral_diffusion_CSp ) if (CS%use_neutral_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & "USE_NEUTRAL_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") - CS%use_lateral_boundary_mixing = lateral_boundary_mixing_init(Time, G, param_file, diag, diabatic_CSp, & - CS%lateral_boundary_mixing_CSp) + CS%use_lateral_boundary_diffusion = lateral_boundary_diffusion_init(Time, G, param_file, diag, diabatic_CSp, & + CS%lateral_boundary_diffusion_CSp) if (CS%use_neutral_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & - "USE_LATERAL_BOUNDARY_MIXING and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") + "USE_LATERAL_BOUNDARY_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) From 8f3cf968d04a6814588c21d8fc5f501f8c0bb505 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 27 Sep 2019 15:40:32 -0600 Subject: [PATCH 045/103] Add placeholders for adding method3 and applying filter on method1 --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 186 ++++++++++++++++++ 1 file changed, 186 insertions(+) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index c5967900a5..52262a8271 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -189,6 +189,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) if (tracer%id_lbm_bulk_dfx>0) call post_data(tracer%id_lbm_bulk_dfx, uFlx_bulk*Idt, CS%diag) if (tracer%id_lbm_bulk_dfy>0) call post_data(tracer%id_lbm_bulk_dfy, vFlx_bulk*Idt, CS%diag) + ! TODO: this is where we would filter vFlx and uFlux to get rid of checkerboard noise + elseif (CS%method == 2) then do j=G%jsc,G%jec do i=G%isc-1,G%iec @@ -631,6 +633,190 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, end subroutine fluxes_bulk_method +! TODO: GMM, this is a placeholder for the pressure reconstruction. +! get rid of all the T/S related variables below. We need to use the +! continuous version since pressure will be continuous. However, +! for tracer we will need to use a discontinuous reconstruction. +! Mimic the neutral diffusion driver to calculate and apply sub-layer +! fluxes. + +!> Returns positions within left/right columns of combined interfaces using continuous reconstructions of T/S +!subroutine find_neutral_surface_positions_continuous(nk, Pl, Pr, PoL, PoR, KoL, KoR, hEff) +! integer, intent(in) :: nk !< Number of levels +! real, dimension(nk+1), intent(in) :: Pl !< Left-column interface pressure [Pa] +! real, dimension(2*nk+2), intent(inout) :: PoL !< Fractional position of neutral surface within +! !! layer KoL of left column +! real, dimension(2*nk+2), intent(inout) :: PoR !< Fractional position of neutral surface within +! !! layer KoR of right column +! integer, dimension(2*nk+2), intent(inout) :: KoL !< Index of first left interface above neutral surface +! integer, dimension(2*nk+2), intent(inout) :: KoR !< Index of first right interface above neutral surface +! real, dimension(2*nk+1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces [Pa] +! +! ! Local variables +! integer :: ns ! Number of neutral surfaces +! integer :: k_surface ! Index of neutral surface +! integer :: kl ! Index of left interface +! integer :: kr ! Index of right interface +! real :: dRdT, dRdS ! dRho/dT and dRho/dS for the neutral surface +! logical :: searching_left_column ! True if searching for the position of a right interface in the left column +! logical :: searching_right_column ! True if searching for the position of a left interface in the right column +! logical :: reached_bottom ! True if one of the bottom-most interfaces has been used as the target +! integer :: krm1, klm1 +! real :: dRho, dRhoTop, dRhoBot, hL, hR +! integer :: lastK_left, lastK_right +! real :: lastP_left, lastP_right +! +! ns = 2*nk+2 +! ! Initialize variables for the search +! kr = 1 ; lastK_right = 1 ; lastP_right = 0. +! kl = 1 ; lastK_left = 1 ; lastP_left = 0. +! reached_bottom = .false. +! +! ! Loop over each neutral surface, working from top to bottom +! neutral_surfaces: do k_surface = 1, ns +! klm1 = max(kl-1, 1) +! if (klm1>nk) stop 'find_neutral_surface_positions(): klm1 went out of bounds!' +! krm1 = max(kr-1, 1) +! if (krm1>nk) stop 'find_neutral_surface_positions(): krm1 went out of bounds!' +! +! ! TODO: GMM, instead of dRho we need dP (pressure at right - pressure at left) +! +! ! Potential density difference, rho(kr) - rho(kl) +! dRho = 0.5 * ( ( dRdTr(kr) + dRdTl(kl) ) * ( Tr(kr) - Tl(kl) ) & +! + ( dRdSr(kr) + dRdSl(kl) ) * ( Sr(kr) - Sl(kl) ) ) +! ! Which column has the lighter surface for the current indexes, kr and kl +! if (.not. reached_bottom) then +! if (dRho < 0.) then +! searching_left_column = .true. +! searching_right_column = .false. +! elseif (dRho > 0.) then +! searching_right_column = .true. +! searching_left_column = .false. +! else ! dRho == 0. +! if (kl + kr == 2) then ! Still at surface +! searching_left_column = .true. +! searching_right_column = .false. +! else ! Not the surface so we simply change direction +! searching_left_column = .not. searching_left_column +! searching_right_column = .not. searching_right_column +! endif +! endif +! endif +! +! if (searching_left_column) then +! ! Interpolate for the neutral surface position within the left column, layer klm1 +! ! Potential density difference, rho(kl-1) - rho(kr) (should be negative) +! dRhoTop = 0.5 * ( ( dRdTl(klm1) + dRdTr(kr) ) * ( Tl(klm1) - Tr(kr) ) & +! + ( dRdSl(klm1) + dRdSr(kr) ) * ( Sl(klm1) - Sr(kr) ) ) +! ! Potential density difference, rho(kl) - rho(kr) (will be positive) +! dRhoBot = 0.5 * ( ( dRdTl(klm1+1) + dRdTr(kr) ) * ( Tl(klm1+1) - Tr(kr) ) & +! + ( dRdSl(klm1+1) + dRdSr(kr) ) * ( Sl(klm1+1) - Sr(kr) ) ) +! +! ! Because we are looking left, the right surface, kr, is lighter than klm1+1 and should be denser than klm1 +! ! unless we are still at the top of the left column (kl=1) +! if (dRhoTop > 0. .or. kr+kl==2) then +! PoL(k_surface) = 0. ! The right surface is lighter than anything in layer klm1 +! elseif (dRhoTop >= dRhoBot) then ! Left layer is unstratified +! PoL(k_surface) = 1. +! else +! ! Linearly interpolate for the position between Pl(kl-1) and Pl(kl) where the density difference +! ! between right and left is zero. +! +! ! TODO: GMM, write the linear solution instead of using interpolate_for_nondim_position +! PoL(k_surface) = interpolate_for_nondim_position( dRhoTop, Pl(klm1), dRhoBot, Pl(klm1+1) ) +! endif +! if (PoL(k_surface)>=1. .and. klm1= is really ==, when PoL==1 we point to the bottom of the cell +! klm1 = klm1 + 1 +! PoL(k_surface) = PoL(k_surface) - 1. +! endif +! if (real(klm1-lastK_left)+(PoL(k_surface)-lastP_left)<0.) then +! PoL(k_surface) = lastP_left +! klm1 = lastK_left +! endif +! KoL(k_surface) = klm1 +! if (kr <= nk) then +! PoR(k_surface) = 0. +! KoR(k_surface) = kr +! else +! PoR(k_surface) = 1. +! KoR(k_surface) = nk +! endif +! if (kr <= nk) then +! kr = kr + 1 +! else +! reached_bottom = .true. +! searching_right_column = .true. +! searching_left_column = .false. +! endif +! elseif (searching_right_column) then +! ! Interpolate for the neutral surface position within the right column, layer krm1 +! ! Potential density difference, rho(kr-1) - rho(kl) (should be negative) +! dRhoTop = 0.5 * ( ( dRdTr(krm1) + dRdTl(kl) ) * ( Tr(krm1) - Tl(kl) ) & +! + ( dRdSr(krm1) + dRdSl(kl) ) * ( Sr(krm1) - Sl(kl) ) ) +! ! Potential density difference, rho(kr) - rho(kl) (will be positive) +! dRhoBot = 0.5 * ( ( dRdTr(krm1+1) + dRdTl(kl) ) * ( Tr(krm1+1) - Tl(kl) ) & +! + ( dRdSr(krm1+1) + dRdSl(kl) ) * ( Sr(krm1+1) - Sl(kl) ) ) +! +! ! Because we are looking right, the left surface, kl, is lighter than krm1+1 and should be denser than krm1 +! ! unless we are still at the top of the right column (kr=1) +! if (dRhoTop >= 0. .or. kr+kl==2) then +! PoR(k_surface) = 0. ! The left surface is lighter than anything in layer krm1 +! elseif (dRhoTop >= dRhoBot) then ! Right layer is unstratified +! PoR(k_surface) = 1. +! else +! ! Linearly interpolate for the position between Pr(kr-1) and Pr(kr) where the density difference +! ! between right and left is zero. +! PoR(k_surface) = interpolate_for_nondim_position( dRhoTop, Pr(krm1), dRhoBot, Pr(krm1+1) ) +! endif +! if (PoR(k_surface)>=1. .and. krm1= is really ==, when PoR==1 we point to the bottom of the cell +! krm1 = krm1 + 1 +! PoR(k_surface) = PoR(k_surface) - 1. +! endif +! if (real(krm1-lastK_right)+(PoR(k_surface)-lastP_right)<0.) then +! PoR(k_surface) = lastP_right +! krm1 = lastK_right +! endif +! KoR(k_surface) = krm1 +! if (kl <= nk) then +! PoL(k_surface) = 0. +! KoL(k_surface) = kl +! else +! PoL(k_surface) = 1. +! KoL(k_surface) = nk +! endif +! if (kl <= nk) then +! kl = kl + 1 +! else +! reached_bottom = .true. +! searching_right_column = .false. +! searching_left_column = .true. +! endif +! else +! stop 'Else what?' +! endif +! +! lastK_left = KoL(k_surface) ; lastP_left = PoL(k_surface) +! lastK_right = KoR(k_surface) ; lastP_right = PoR(k_surface) +! +! ! Effective thickness +! ! NOTE: This would be better expressed in terms of the layers thicknesses rather +! ! than as differences of position - AJA +! +! ! TODO: GMM, we need to import absolute_position from neutral diffusion. This gives us the depth of the interface on the left and right side. +! +! if (k_surface>1) then +! hL = absolute_position(nk,ns,Pl,KoL,PoL,k_surface) - absolute_position(nk,ns,Pl,KoL,PoL,k_surface-1) +! hR = absolute_position(nk,ns,Pr,KoR,PoR,k_surface) - absolute_position(nk,ns,Pr,KoR,PoR,k_surface-1) +! if ( hL + hR > 0.) then +! hEff(k_surface-1) = 2. * hL * hR / ( hL + hR ) ! Harmonic mean of layer thicknesses +! else +! hEff(k_surface-1) = 0. +! endif +! endif +! +! enddo neutral_surfaces +!end subroutine find_neutral_surface_positions_continuous + !> Unit tests for near-boundary horizontal mixing logical function near_boundary_unit_tests( verbose ) logical, intent(in) :: verbose !< If true, output additional information for debugging unit tests From 15c9f06463f1db23afd383b653f26dd10255d50a Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 2 Oct 2019 15:39:11 -0600 Subject: [PATCH 046/103] Hard-code min of SN to be 1.0e-7 --- src/parameterizations/lateral/MOM_MEKE.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index bb825cdd2d..a64a73ae4c 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -775,7 +775,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m ! Equation 1 of Jansen et al. (2015), balancing the GEOMETRIC GM coefficient against ! bottom drag (Equations 3 and 12) ! TODO: create a run time parameter for limitting SN. - MEKE%MEKE(i,j) = (CS%MEKE_GEOMETRIC_alpha * MIN(SN,1.e-5) * US%Z_to_m*G%bathyT(i,j))**2 / (CS%cdrag**2 * bottomFac2**3) + MEKE%MEKE(i,j) = (CS%MEKE_GEOMETRIC_alpha * MIN(SN,1.e-7) * US%Z_to_m*G%bathyT(i,j))**2 / (CS%cdrag**2 * bottomFac2**3) else MEKE%MEKE(i,j) = (US%Z_to_m*G%bathyT(i,j)*SN / (8*CS%cdrag))**2 endif From 486da1dfc0f2d01b3b115fd1917095b9422a6435 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 4 Oct 2019 16:57:22 -0600 Subject: [PATCH 047/103] Replaces trunit to conc in the documentation --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 52262a8271..1a8935ab67 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -381,7 +381,7 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t at U-point [m^2] - real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [m^2 trunit] + real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [m^2 conc] ! Local variables real, dimension(nk) :: h_means ! Calculate the layer-wise harmonic means [m] real, dimension(nk) :: h_u ! Thickness at the u-point [m] @@ -390,7 +390,7 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, real :: heff ! Harmonic mean of layer thicknesses [m] real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] real :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) - ! [trunit m^-3 ] + ! [conc m^-3 ] real :: htot ! Total column thickness [m] integer :: k, k_bot_min, k_top_max integer :: k_top_L, k_bot_L, k_top_u @@ -483,10 +483,10 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t at U-point [m^2] - real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux [m^2 trunit] - real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [m^2 trunit] + real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux [m^2 conc] + real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [m^2 conc] real, optional, dimension(nk), intent( out) :: F_limit !< The amount of flux not applied due to limiter - !! F_layer(k) - F_max [m^2 trunit] + !! F_layer(k) - F_max [m^2 conc] ! Local variables real, dimension(nk) :: h_means ! Calculate the layer-wise harmonic means [m] real, dimension(nk) :: h_u ! Thickness at the u-point [m] @@ -495,7 +495,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real :: heff ! Harmonic mean of layer thicknesses [m] real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] real :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) - ! [trunit m^-3 ] + ! [conc m^-3 ] real :: htot ! Total column thickness [m] integer :: k, k_min, k_max integer :: k_top_L, k_bot_L, k_top_u From 839217d9d26f97580a6586697aed7de36ad440cc Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 15 Oct 2019 15:35:02 -0600 Subject: [PATCH 048/103] Rearranged MEKE_EQUILIBRIUM subroutine * Moved MEKE_equilibrium_alt toward top of subroutine to avoid unnecessary calculations. --- src/parameterizations/lateral/MOM_MEKE.F90 | 221 ++++++++++----------- 1 file changed, 103 insertions(+), 118 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index a64a73ae4c..d6ec7814ce 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -658,128 +658,113 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m ! This avoids extremes values in equilibrium solution due to bad values in SN_u, SN_v SN = min(SN_u(I,j), SN_u(I-1,j), SN_v(i,J), SN_v(i,J-1)) - FatH = 0.25*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & - (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1))) ! Coriolis parameter at h points - - ! Since zero-bathymetry cells are masked, this avoids calculations on land - if (CS%MEKE_topographic_beta == 0. .or. G%bathyT(i,j) == 0.) then - beta_topo_x = 0. ; beta_topo_y = 0. + if (CS%MEKE_equilibrium_alt) then + MEKE%MEKE(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * US%Z_to_m*G%bathyT(i,j))**2 / cd2 else - !### Consider different combinations of these estimates of topographic beta, and the use - ! of the water column thickness instead of the bathymetric depth. - beta_topo_x = CS%MEKE_topographic_beta * FatH * 0.5 * ( & - (G%bathyT(i+1,j)-G%bathyT(i,j)) * G%IdxCu(I,j) & - / max(G%bathyT(i+1,j),G%bathyT(i,j), GV%H_subroundoff) & - + (G%bathyT(i,j)-G%bathyT(i-1,j)) * G%IdxCu(I-1,j) & - / max(G%bathyT(i,j),G%bathyT(i-1,j), GV%H_subroundoff) ) - !### There is a bug in the 4th lne below, where IdxCu should be IdyCv. - beta_topo_y = CS%MEKE_topographic_beta * FatH * 0.5 * ( & - (G%bathyT(i,j+1)-G%bathyT(i,j)) * G%IdyCv(i,J) & - / max(G%bathyT(i,j+1),G%bathyT(i,j), GV%H_subroundoff) + & - (G%bathyT(i,j)-G%bathyT(i,j-1)) * G%IdxCu(i,J-1) & - / max(G%bathyT(i,j),G%bathyT(i,j-1), GV%H_subroundoff) ) - endif - beta = sqrt((G%dF_dx(i,j) - beta_topo_x)**2 + & - (G%dF_dy(i,j) - beta_topo_y)**2 ) - - I_H = US%L_to_m*GV%Rho0 * I_mass(i,j) - - if (KhCoeff*SN*I_H>0.) then - ! Solve resid(E) = 0, where resid = Kh(E) * (SN)^2 - damp_rate(E) E - EKEmin = 0. ! Use the trivial root as the left bracket - ResMin = 0. ! Need to detect direction of left residual - EKEmax = 0.01*US%m_s_to_L_T**2 ! First guess at right bracket - useSecant = .false. ! Start using a bisection method - - ! First find right bracket for which resid<0 - resid = 1.0*US%m_to_L**2*US%T_to_s**3 ; n1 = 0 - do while (resid>0.) - n1 = n1 + 1 - EKE = EKEmax - call MEKE_lengthScales_0d(CS, US, G%areaT(i,j), beta, G%bathyT(i,j), & - MEKE%Rd_dx_h(i,j), SN, EKE, & - bottomFac2, barotrFac2, LmixScale, LRhines, LEady) - ! TODO: Should include resolution function in Kh - Kh = (KhCoeff * sqrt(2.*barotrFac2*EKE) * LmixScale) - src = Kh * (SN * SN) - drag_rate = I_H * sqrt(drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) - ldamping = CS%MEKE_damping + drag_rate * bottomFac2 - resid = src - ldamping * EKE - ! if (debugIteration) then - ! write(0,*) n1, 'EKE=',EKE,'resid=',resid - ! write(0,*) 'EKEmin=',EKEmin,'ResMin=',ResMin - ! write(0,*) 'src=',src,'ldamping=',ldamping - ! write(0,*) 'gamma-b=',bottomFac2,'gamma-t=',barotrFac2 - ! write(0,*) 'drag_visc=',drag_rate_visc(i,j),'Ubg2=',Ubg2 - ! endif - if (resid>0.) then ! EKE is to the left of the root - EKEmin = EKE ! so we move the left bracket here - EKEmax = 10. * EKE ! and guess again for the right bracket - if (resid 2.e17) then - if (debugIteration) stop 'Something has gone very wrong' - debugIteration = .true. - resid = 1. ; n1 = 0 - EKEmin = 0. ; ResMin = 0. - EKEmax = 0.01*US%m_s_to_L_T**2 - useSecant = .false. - endif - endif - enddo ! while(resid>0.) searching for right bracket - ResMax = resid - - ! Bisect the bracket - n2 = 0 ; EKEerr = EKEmax - EKEmin - do while (US%L_T_to_m_s**2*EKEerr>tolerance) - n2 = n2 + 1 - if (useSecant) then - EKE = EKEmin + (EKEmax - EKEmin) * (ResMin / (ResMin - ResMax)) - else - EKE = 0.5 * (EKEmin + EKEmax) - endif - EKEerr = min( EKE-EKEmin, EKEmax-EKE ) - ! TODO: Should include resolution function in Kh - Kh = (KhCoeff * sqrt(2.*barotrFac2*EKE) * LmixScale) - src = Kh * (SN * SN) - drag_rate = I_H * sqrt( drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) - ldamping = CS%MEKE_damping + drag_rate * bottomFac2 - resid = src - ldamping * EKE - if (useSecant .and. resid>ResMin) useSecant = .false. - if (resid>0.) then ! EKE is to the left of the root - EKEmin = EKE ! so we move the left bracket here - if (resid EKE is exactly at the root - endif - if (n2>200) stop 'Failing to converge?' - enddo ! while(EKEmax-EKEmin>tolerance) - else - EKE = 0. - endif - if (CS%MEKE_equilibrium_alt) then - if (CS%MEKE_GEOMETRIC) then - Lgrid = sqrt(G%areaT(i,j)) ! Grid scale - Ldeform =Lgrid * MIN(1.0,MEKE%Rd_dx_h(i,j)) ! Deformation scale - Lfrict = (US%Z_to_m * G%bathyT(i,j)) / CS%cdrag ! Frictional arrest scale - ! gamma_b^2 is the ratio of bottom eddy energy to mean column eddy energy - ! used in calculating bottom drag - bottomFac2 = CS%MEKE_CD_SCALE**2 - if (Lfrict*CS%MEKE_Cb>0.) bottomFac2 = bottomFac2 + 1./( 1. + CS%MEKE_Cb*(Ldeform/Lfrict) )**0.8 - bottomFac2 = max(bottomFac2, CS%MEKE_min_gamma) - ! Equation 1 of Jansen et al. (2015), balancing the GEOMETRIC GM coefficient against - ! bottom drag (Equations 3 and 12) - ! TODO: create a run time parameter for limitting SN. - MEKE%MEKE(i,j) = (CS%MEKE_GEOMETRIC_alpha * MIN(SN,1.e-7) * US%Z_to_m*G%bathyT(i,j))**2 / (CS%cdrag**2 * bottomFac2**3) + FatH = 0.25*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1))) ! Coriolis parameter at h points + + ! Since zero-bathymetry cells are masked, this avoids calculations on land + if (CS%MEKE_topographic_beta == 0. .or. G%bathyT(i,j) == 0.) then + beta_topo_x = 0. ; beta_topo_y = 0. + else + !### Consider different combinations of these estimates of topographic beta, and the use + ! of the water column thickness instead of the bathymetric depth. + beta_topo_x = CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (G%bathyT(i+1,j)-G%bathyT(i,j)) * G%IdxCu(I,j) & + / max(G%bathyT(i+1,j),G%bathyT(i,j), GV%H_subroundoff) & + + (G%bathyT(i,j)-G%bathyT(i-1,j)) * G%IdxCu(I-1,j) & + / max(G%bathyT(i,j),G%bathyT(i-1,j), GV%H_subroundoff) ) + !### There is a bug in the 4th lne below, where IdxCu should be IdyCv. + beta_topo_y = CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (G%bathyT(i,j+1)-G%bathyT(i,j)) * G%IdyCv(i,J) & + / max(G%bathyT(i,j+1),G%bathyT(i,j), GV%H_subroundoff) + & + (G%bathyT(i,j)-G%bathyT(i,j-1)) * G%IdxCu(i,J-1) & + / max(G%bathyT(i,j),G%bathyT(i,j-1), GV%H_subroundoff) ) + endif + beta = sqrt((G%dF_dx(i,j) - beta_topo_x)**2 + & + (G%dF_dy(i,j) - beta_topo_y)**2 ) + + I_H = US%L_to_m*GV%Rho0 * I_mass(i,j) + + if (KhCoeff*SN*I_H>0.) then + ! Solve resid(E) = 0, where resid = Kh(E) * (SN)^2 - damp_rate(E) E + EKEmin = 0. ! Use the trivial root as the left bracket + ResMin = 0. ! Need to detect direction of left residual + EKEmax = 0.01*US%m_s_to_L_T**2 ! First guess at right bracket + useSecant = .false. ! Start using a bisection method + + ! First find right bracket for which resid<0 + resid = 1.0*US%m_to_L**2*US%T_to_s**3 ; n1 = 0 + do while (resid>0.) + n1 = n1 + 1 + EKE = EKEmax + call MEKE_lengthScales_0d(CS, US, G%areaT(i,j), beta, G%bathyT(i,j), & + MEKE%Rd_dx_h(i,j), SN, EKE, & + bottomFac2, barotrFac2, LmixScale, LRhines, LEady) + ! TODO: Should include resolution function in Kh + Kh = (KhCoeff * sqrt(2.*barotrFac2*EKE) * LmixScale) + src = Kh * (SN * SN) + drag_rate = I_H * sqrt(drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) + ldamping = CS%MEKE_damping + drag_rate * bottomFac2 + resid = src - ldamping * EKE + ! if (debugIteration) then + ! write(0,*) n1, 'EKE=',EKE,'resid=',resid + ! write(0,*) 'EKEmin=',EKEmin,'ResMin=',ResMin + ! write(0,*) 'src=',src,'ldamping=',ldamping + ! write(0,*) 'gamma-b=',bottomFac2,'gamma-t=',barotrFac2 + ! write(0,*) 'drag_visc=',drag_rate_visc(i,j),'Ubg2=',Ubg2 + ! endif + if (resid>0.) then ! EKE is to the left of the root + EKEmin = EKE ! so we move the left bracket here + EKEmax = 10. * EKE ! and guess again for the right bracket + if (resid 2.e17) then + if (debugIteration) stop 'Something has gone very wrong' + debugIteration = .true. + resid = 1. ; n1 = 0 + EKEmin = 0. ; ResMin = 0. + EKEmax = 0.01*US%m_s_to_L_T**2 + useSecant = .false. + endif + endif + enddo ! while(resid>0.) searching for right bracket + ResMax = resid + + ! Bisect the bracket + n2 = 0 ; EKEerr = EKEmax - EKEmin + do while (US%L_T_to_m_s**2*EKEerr>tolerance) + n2 = n2 + 1 + if (useSecant) then + EKE = EKEmin + (EKEmax - EKEmin) * (ResMin / (ResMin - ResMax)) + else + EKE = 0.5 * (EKEmin + EKEmax) + endif + EKEerr = min( EKE-EKEmin, EKEmax-EKE ) + ! TODO: Should include resolution function in Kh + Kh = (KhCoeff * sqrt(2.*barotrFac2*EKE) * LmixScale) + src = Kh * (SN * SN) + drag_rate = I_H * sqrt( drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) + ldamping = CS%MEKE_damping + drag_rate * bottomFac2 + resid = src - ldamping * EKE + if (useSecant .and. resid>ResMin) useSecant = .false. + if (resid>0.) then ! EKE is to the left of the root + EKEmin = EKE ! so we move the left bracket here + if (resid EKE is exactly at the root + endif + if (n2>200) stop 'Failing to converge?' + enddo ! while(EKEmax-EKEmin>tolerance) else - MEKE%MEKE(i,j) = (US%Z_to_m*G%bathyT(i,j)*SN / (8*CS%cdrag))**2 + EKE = 0. endif - else MEKE%MEKE(i,j) = EKE endif enddo ; enddo From bb785a8e042532a1eb16c2a86026676133f912c9 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 14 Oct 2019 16:32:46 -0600 Subject: [PATCH 049/103] Adds option to scale KHTH with depth This commit adds the option to scale KHTH with depth by setting DEPTH_SCALED_KHTH = True. The scalling is applied as follows: KHTH = MIN(1,H/H_0)**N * KHTH, where H_0 is defined by DEPTH_SCALED_KHTH_H0, and N by DEPTH_SCALED_KHTH_EXP. --- src/core/MOM.F90 | 9 ++- .../lateral/MOM_lateral_mixing_coeffs.F90 | 72 ++++++++++++++++++- .../lateral/MOM_thickness_diffuse.F90 | 37 +++++++--- 3 files changed, 103 insertions(+), 15 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 23c11cc05b..6d5df84ea7 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -77,7 +77,7 @@ module MOM use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_interface_heights, only : find_eta use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init -use MOM_lateral_mixing_coeffs, only : calc_resoln_function, VarMix_CS +use MOM_lateral_mixing_coeffs, only : calc_resoln_function, calc_depth_function, VarMix_CS use MOM_MEKE, only : MEKE_init, MEKE_alloc_register_restart, step_forward_MEKE, MEKE_CS use MOM_MEKE_types, only : MEKE_type use MOM_mixed_layer_restrat, only : mixedlayer_restrat, mixedlayer_restrat_init, mixedlayer_restrat_CS @@ -565,6 +565,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & call enable_averaging(cycle_time, Time_start + real_to_time(cycle_time), & CS%diag) call calc_resoln_function(h, CS%tv, G, GV, US, CS%VarMix) + call calc_depth_function(h, CS%tv, G, GV, US, CS%VarMix) call disable_averaging(CS%diag) endif endif @@ -1403,6 +1404,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (associated(CS%VarMix)) then call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) + call calc_depth_function(CS%h, CS%tv, G, GV, US, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, US, CS%VarMix) endif call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & @@ -1428,6 +1430,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (associated(CS%VarMix)) then call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) + call calc_depth_function(CS%h, CS%tv, G, GV, US, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, US, CS%VarMix) endif call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & @@ -1674,8 +1677,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "faster by eliminating subroutine calls.", default=.false.) call get_param(param_file, "MOM", "DO_DYNAMICS", CS%do_dynamics, & "If False, skips the dynamics calls that update u & v, as well as "//& - "the gravity wave adjustment to h. This is a fragile feature and "//& - "thus undocumented.", default=.true., do_not_log=.true. ) + "the gravity wave adjustment to h. This may be a fragile feature, "//& + "but can be useful during development", default=.true.) call get_param(param_file, "MOM", "ADVECT_TS", advect_TS, & "If True, advect temperature and salinity horizontally "//& "If False, T/S are registered for advection. "//& diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 1582b23615..9b579b108f 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -29,6 +29,8 @@ module MOM_lateral_mixing_coeffs !! when the deformation radius is well resolved. logical :: Resoln_scaled_KhTh !< If true, scale away the thickness diffusivity !! when the deformation radius is well resolved. + logical :: Depth_scaled_KhTh !< If true, the interface depth diffusivity is scaled away + !! when the depth is shallower than a reference depth. logical :: Resoln_scaled_KhTr !< If true, scale away the tracer diffusivity !! when the deformation radius is well resolved. logical :: interpolate_Res_fn !< If true, interpolate the resolution function @@ -48,6 +50,8 @@ module MOM_lateral_mixing_coeffs !! This parameter is set depending on other parameters. logical :: calculate_res_fns !< If true, calculate all the resolution factors. !! This parameter is set depending on other parameters. + logical :: calculate_depth_fns !< If true, calculate all the depth factors. + !! This parameter is set depending on other parameters. logical :: calculate_Eady_growth_rate !< If true, calculate all the Eady growth rate. !! This parameter is set depending on other parameters. real, dimension(:,:), pointer :: & @@ -64,6 +68,10 @@ module MOM_lateral_mixing_coeffs !! deformation radius to the grid spacing at u points [nondim]. Res_fn_v => NULL(), & !< Non-dimensional function of the ratio the first baroclinic !! deformation radius to the grid spacing at v points [nondim]. + Depth_fn_u => NULL(), & !< Non-dimensional function of the ratio of the depth to + !! a reference depth (maximum 1) at u points [nondim] + Depth_fn_v => NULL(), & !< Non-dimensional function of the ratio of the depth to + !! a reference depth (maximum 1) at v points [nondim] beta_dx2_h => NULL(), & !< The magnitude of the gradient of the Coriolis parameter !! times the grid spacing squared at h points [L T-1 ~> m s-1]. beta_dx2_q => NULL(), & !< The magnitude of the gradient of the Coriolis parameter @@ -111,6 +119,8 @@ module MOM_lateral_mixing_coeffs real :: Res_coef_visc !< A non-dimensional number that determines the function !! of resolution, used for lateral viscosity, as: !! F = 1 / (1 + (Res_coef_visc*Ld/dx)^Res_fn_power) + real :: depth_scaled_khth_h0 !< The depth above which KHTH is linearly scaled away [Z ~> m] + real :: depth_scaled_khth_exp !< The exponent used in the depth dependent scaling function for KHTH [nondim] real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [Z2 T-1 ~> m2 s-1] integer :: Res_fn_power_khth !< The power of dx/Ld in the KhTh resolution function. Any !! positive integer power may be used, but even powers @@ -140,10 +150,48 @@ module MOM_lateral_mixing_coeffs end type VarMix_CS public VarMix_init, calc_slope_functions, calc_resoln_function -public calc_QG_Leith_viscosity +public calc_QG_Leith_viscosity, calc_depth_function contains +!> Calculates and stires the non-dimensional depth functions. +subroutine calc_depth_function(h, tv, G, GV, US, CS) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(VarMix_CS), pointer :: CS !< Variable mixing coefficients + + ! Local variables + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k + real :: H0 ! local variable for reference depth + real :: expo ! exponent used in the depth dependent scaling + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + if (.not. associated(CS)) call MOM_error(FATAL, "calc_depth_function:"// & + "Module must be initialized before it is used.") + if (.not. CS%calculate_depth_fns) return + if (.not. associated(CS%Depth_fn_u)) call MOM_error(FATAL, & + "calc_depth_function: %Depth_fn_u is not associated with Depth_scaled_KhTh.") + if (.not. associated(CS%Depth_fn_v)) call MOM_error(FATAL, & + "calc_depth_function: %Depth_fn_v is not associated with Depth_scaled_KhTh.") + + H0 = CS%depth_scaled_khth_h0 + expo = CS%depth_scaled_khth_exp +!$OMP do + do j=js,je ; do I=is-1,Ieq + CS%Depth_fn_u(I,j) = (MIN(1.0, 0.5*(G%bathyT(i,j) + G%bathyT(i+1,j))/H0))**expo + enddo ; enddo +!$OMP do + do J=js-1,Jeq ; do i=is,ie + CS%Depth_fn_v(i,J) = (MIN(1.0, 0.5*(G%bathyT(i,j) + G%bathyT(i,j+1))/H0))**expo + enddo ; enddo + +end subroutine calc_depth_function + !> Calculates and stores the non-dimensional resolution functions subroutine calc_resoln_function(h, tv, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure @@ -913,7 +961,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) CS%calculate_Rd_dx = .false. CS%calculate_res_fns = .false. CS%calculate_Eady_growth_rate = .false. - + CS%calculate_depth_fns = .false. ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USE_VARIABLE_MIXING", CS%use_variable_mixing,& @@ -929,6 +977,13 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "If true, the Laplacian lateral viscosity is scaled away "//& "when the first baroclinic deformation radius is well "//& "resolved.", default=.false.) + call get_param(param_file, mdl, "DEPTH_SCALED_KHTH", CS%Depth_scaled_KhTh, & + "If true, the interface depth diffusivity is scaled away "//& + "when the depth is shallower than a reference depth: "//& + "KHTH = MIN(1,H/H0)**N * KHTH, where H0 is a reference"//& + "depth, controlled via DEPTH_SCALED_KHTH_H0, and the"//& + "exponent (N) is controlled via DEPTH_SCALED_KHTH_EXP.",& + default=.false.) call get_param(param_file, mdl, "RESOLN_SCALED_KHTH", CS%Resoln_scaled_KhTh, & "If true, the interface depth diffusivity is scaled away "//& "when the first baroclinic deformation radius is well "//& @@ -978,6 +1033,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false., do_not_log=.true.) + if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct) then in_use = .true. call get_param(param_file, mdl, "RESOLN_N2_FILTER_DEPTH", N2_filter_depth, & @@ -1160,6 +1216,18 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) endif + if (CS%Depth_scaled_KhTh) then + CS%calculate_depth_fns = .true. + allocate(CS%Depth_fn_u(IsdB:IedB,jsd:jed)) ; CS%Depth_fn_u(:,:) = 0.0 + allocate(CS%Depth_fn_v(isd:ied,JsdB:JedB)) ; CS%Depth_fn_v(:,:) = 0.0 + call get_param(param_file, mdl, "DEPTH_SCALED_KHTH_H0", CS%depth_scaled_khth_h0, & + "The depth above which KHTH is scaled away.",& + units="m", default=1000.) + call get_param(param_file, mdl, "DEPTH_SCALED_KHTH_EXP", CS%depth_scaled_khth_exp, & + "The exponent used in the depth dependent scaling function for KHTH.",& + units="nondim", default=3.0) + endif + ! Resolution %Rd_dx_h CS%id_Rd_dx = register_diag_field('ocean_model', 'Rd_dx', diag%axesT1, Time, & 'Ratio between deformation radius and grid spacing', 'm m-1') diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index d639a986bf..eb31a45cc3 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -137,12 +137,13 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp real, dimension(SZI_(G), SZJB_(G)) :: & KH_v_CFL ! The maximum stable interface height diffusivity at v grid points [L2 T-1 ~> m2 s-1] real :: Khth_Loc_u(SZIB_(G), SZJ_(G)) + real :: Khth_Loc_v(SZI_(G), SZJB_(G)) real :: Khth_Loc(SZIB_(G), SZJB_(G)) ! locally calculated thickness diffusivity [L2 T-1 ~> m2 s-1] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real, dimension(:,:), pointer :: cg1 => null() !< Wave speed [L T-1 ~> m s-1] real :: dt_in_T ! Time increment [T ~> s] - logical :: use_VarMix, Resoln_scaled, use_stored_slopes, khth_use_ebt_struct, use_Visbeck + logical :: use_VarMix, Resoln_scaled, Depth_scaled, use_stored_slopes, khth_use_ebt_struct, use_Visbeck logical :: use_QG_Leith integer :: i, j, k, is, ie, js, je, nz real :: hu(SZI_(G), SZJ_(G)) ! u-thickness [H ~> m or kg m-2] @@ -168,10 +169,12 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp use_VarMix = .false. ; Resoln_scaled = .false. ; use_stored_slopes = .false. khth_use_ebt_struct = .false. ; use_Visbeck = .false. ; use_QG_Leith = .false. + Depth_scaled = .false. if (associated(VarMix)) then use_VarMix = VarMix%use_variable_mixing .and. (CS%KHTH_Slope_Cff > 0.) Resoln_scaled = VarMix%Resoln_scaled_KhTh + Depth_scaled = VarMix%Depth_scaled_KhTh use_stored_slopes = VarMix%use_stored_slopes khth_use_ebt_struct = VarMix%khth_use_ebt_struct use_Visbeck = VarMix%use_Visbeck @@ -238,6 +241,13 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp enddo ; enddo endif + if (Depth_scaled) then +!$OMP do + do j=js,je; do I=is-1,ie + Khth_loc_u(I,j) = Khth_loc_u(I,j) * VarMix%Depth_fn_u(I,j) + enddo ; enddo + endif + if (CS%Khth_Max > 0) then !$OMP do do j=js,je; do I=is-1,ie @@ -284,55 +294,62 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp !$OMP do do J=js-1,je ; do i=is,ie - Khth_loc(i,j) = CS%Khth + Khth_loc_v(i,J) = CS%Khth enddo ; enddo if (use_VarMix) then !$OMP do if (use_Visbeck) then do J=js-1,je ; do i=is,ie - Khth_loc(i,j) = Khth_loc(i,j) + CS%KHTH_Slope_Cff*VarMix%L2v(i,J)*VarMix%SN_v(i,J) + Khth_loc_v(i,J) = Khth_loc_v(i,J) + CS%KHTH_Slope_Cff*VarMix%L2v(i,J)*VarMix%SN_v(i,J) enddo ; enddo endif endif if (associated(MEKE)) then ; if (associated(MEKE%Kh)) then !$OMP do if (CS%MEKE_GEOMETRIC) then - do j=js-1,je ; do I=is,ie - Khth_loc(I,j) = Khth_loc(I,j) + G%mask2dCv(i,J) * CS%MEKE_GEOMETRIC_alpha * & + do J=js-1,je ; do i=is,ie + Khth_loc_v(i,J) = Khth_loc_v(i,J) + G%mask2dCv(i,J) * CS%MEKE_GEOMETRIC_alpha * & 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i,j+1)) / & (VarMix%SN_v(i,J) + CS%MEKE_GEOMETRIC_epsilon) enddo ; enddo else do J=js-1,je ; do i=is,ie - Khth_loc(i,j) = Khth_loc(i,j) + MEKE%KhTh_fac*sqrt(MEKE%Kh(i,j)*MEKE%Kh(i,j+1)) + Khth_loc_v(i,J) = Khth_loc_v(i,J) + MEKE%KhTh_fac*sqrt(MEKE%Kh(i,j)*MEKE%Kh(i,j+1)) enddo ; enddo endif endif ; endif if (Resoln_scaled) then +!$OMP do + do J=js-1,je; do i=is,ie + Khth_loc_v(i,J) = Khth_loc_v(i,J) * VarMix%Res_fn_v(i,J) + enddo ; enddo + endif + + if (Depth_scaled) then !$OMP do do J=js-1,je ; do i=is,ie - Khth_loc(i,j) = Khth_loc(i,j) * VarMix%Res_fn_v(i,J) + Khth_loc_v(i,J) = Khth_loc_v(i,J) * VarMix%Depth_fn_v(i,J) enddo ; enddo endif if (CS%Khth_Max > 0) then !$OMP do do J=js-1,je ; do i=is,ie - Khth_loc(i,j) = max(CS%Khth_Min, min(Khth_loc(i,j), CS%Khth_Max)) + Khth_loc_v(i,J) = max(CS%Khth_Min, min(Khth_loc_v(i,J), CS%Khth_Max)) enddo ; enddo else !$OMP do do J=js-1,je ; do i=is,ie - Khth_loc(i,j) = max(CS%Khth_Min, Khth_loc(i,j)) + Khth_loc_v(i,J) = max(CS%Khth_Min, Khth_loc_v(i,J)) enddo ; enddo endif if (CS%max_Khth_CFL > 0.0) then !$OMP do do J=js-1,je ; do i=is,ie - KH_v(i,J,1) = min(KH_v_CFL(i,J), Khth_loc(i,j)) + KH_v(i,J,1) = min(KH_v_CFL(i,J), Khth_loc_v(i,J)) enddo ; enddo endif From 67016eba918ca380c4177300184c3a534bcc73a7 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 16 Oct 2019 11:04:36 -0600 Subject: [PATCH 050/103] Reverts description in DO_DYNAMICS to older version as this was changed by mistake. --- src/core/MOM.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 6d5df84ea7..2e2a2177c0 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1677,8 +1677,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "faster by eliminating subroutine calls.", default=.false.) call get_param(param_file, "MOM", "DO_DYNAMICS", CS%do_dynamics, & "If False, skips the dynamics calls that update u & v, as well as "//& - "the gravity wave adjustment to h. This may be a fragile feature, "//& - "but can be useful during development", default=.true.) + "the gravity wave adjustment to h. This is a fragile feature and "//& + "thus undocumented.", default=.true., do_not_log=.true. ) call get_param(param_file, "MOM", "ADVECT_TS", advect_TS, & "If True, advect temperature and salinity horizontally "//& "If False, T/S are registered for advection. "//& From 223037c76f00e53ff0cf25b76ac6c3f38b798e33 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 16 Oct 2019 11:58:18 -0600 Subject: [PATCH 051/103] Deletes unneeded variables from calc_depth_function --- src/core/MOM.F90 | 6 +++--- .../lateral/MOM_lateral_mixing_coeffs.F90 | 14 +++++--------- 2 files changed, 8 insertions(+), 12 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 2e2a2177c0..06634753e6 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -565,7 +565,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & call enable_averaging(cycle_time, Time_start + real_to_time(cycle_time), & CS%diag) call calc_resoln_function(h, CS%tv, G, GV, US, CS%VarMix) - call calc_depth_function(h, CS%tv, G, GV, US, CS%VarMix) + call calc_depth_function(G, CS%VarMix) call disable_averaging(CS%diag) endif endif @@ -1404,7 +1404,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (associated(CS%VarMix)) then call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) - call calc_depth_function(CS%h, CS%tv, G, GV, US, CS%VarMix) + call calc_depth_function(G, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, US, CS%VarMix) endif call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & @@ -1430,7 +1430,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (associated(CS%VarMix)) then call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) - call calc_depth_function(CS%h, CS%tv, G, GV, US, CS%VarMix) + call calc_depth_function(G, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, US, CS%VarMix) endif call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 9b579b108f..16d4ca6540 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -155,20 +155,16 @@ module MOM_lateral_mixing_coeffs contains !> Calculates and stires the non-dimensional depth functions. -subroutine calc_depth_function(h, tv, G, GV, US, CS) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type +subroutine calc_depth_function(G, CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(VarMix_CS), pointer :: CS !< Variable mixing coefficients ! Local variables - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - integer :: i, j, k + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: i, j real :: H0 ! local variable for reference depth real :: expo ! exponent used in the depth dependent scaling - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB if (.not. associated(CS)) call MOM_error(FATAL, "calc_depth_function:"// & From 1522ad0d7134b2dd0df589cab132f30f6b0cc1e0 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 16 Oct 2019 14:30:07 -0600 Subject: [PATCH 052/103] Minor changes in the doxygen comments --- .../lateral/MOM_lateral_mixing_coeffs.F90 | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 16d4ca6540..caa84325ce 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -29,8 +29,8 @@ module MOM_lateral_mixing_coeffs !! when the deformation radius is well resolved. logical :: Resoln_scaled_KhTh !< If true, scale away the thickness diffusivity !! when the deformation radius is well resolved. - logical :: Depth_scaled_KhTh !< If true, the interface depth diffusivity is scaled away - !! when the depth is shallower than a reference depth. + logical :: Depth_scaled_KhTh !< If true, KHTH is scaled away when the depth is + !! shallower than a reference depth. logical :: Resoln_scaled_KhTr !< If true, scale away the tracer diffusivity !! when the deformation radius is well resolved. logical :: interpolate_Res_fn !< If true, interpolate the resolution function @@ -154,7 +154,7 @@ module MOM_lateral_mixing_coeffs contains -!> Calculates and stires the non-dimensional depth functions. +!> Calculates the non-dimensional depth functions. subroutine calc_depth_function(G, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(VarMix_CS), pointer :: CS !< Variable mixing coefficients @@ -974,11 +974,10 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "when the first baroclinic deformation radius is well "//& "resolved.", default=.false.) call get_param(param_file, mdl, "DEPTH_SCALED_KHTH", CS%Depth_scaled_KhTh, & - "If true, the interface depth diffusivity is scaled away "//& - "when the depth is shallower than a reference depth: "//& - "KHTH = MIN(1,H/H0)**N * KHTH, where H0 is a reference"//& - "depth, controlled via DEPTH_SCALED_KHTH_H0, and the"//& - "exponent (N) is controlled via DEPTH_SCALED_KHTH_EXP.",& + "If true, KHTH is scaled away when the depth is shallower"//& + "than a reference depth: KHTH = MIN(1,H/H0)**N * KHTH, "//& + "where H0 is a reference depth, controlled via DEPTH_SCALED_KHTH_H0, "//& + "and the exponent (N) is controlled via DEPTH_SCALED_KHTH_EXP.",& default=.false.) call get_param(param_file, mdl, "RESOLN_SCALED_KHTH", CS%Resoln_scaled_KhTh, & "If true, the interface depth diffusivity is scaled away "//& From ebf5ee0d37f1e57dfaed0c56492369dfd0a1249d Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 15 Oct 2019 16:42:37 -0600 Subject: [PATCH 053/103] Adds MEKE_equilibrium_restoring This commit adds a subroutine that calculates a new equilibrium value for MEKE at each time step. This is not copied into MEKE%MEKE; rather, it is used as a restoring term to nudge MEKE%MEKE back to an equilibrium value. To select this option one needs to set MEKE_EQUILIBRIUM_RESTORING=True. The timescale for nudging is controlled via MEKE_RESTORING_TIMESCALE. --- src/parameterizations/lateral/MOM_MEKE.F90 | 65 ++++++++++++++++++++++ 1 file changed, 65 insertions(+) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index d6ec7814ce..853f3a8613 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -30,6 +30,8 @@ module MOM_MEKE !> Control structure that contains MEKE parameters and diagnostics handles type, public :: MEKE_CS ; private ! Parameters + real, dimension(:,:), pointer :: equilibrium_value => NULL() !< The equilbrium value + !! of MEKE to be calculated at each time step [L2 T-2 ~> m2 s-2] real :: MEKE_FrCoeff !< Efficiency of conversion of ME into MEKE [nondim] real :: MEKE_GMcoeff !< Efficiency of conversion of PE into MEKE [nondim] real :: MEKE_GMECoeff !< Efficiency of conversion of MEKE into ME by GME [nondim] @@ -47,6 +49,8 @@ module MOM_MEKE !! GEOMETRIC thickness diffusion. logical :: MEKE_equilibrium_alt !< If true, use an alternative calculation for the !! equilibrium value of MEKE. + logical :: MEKE_equilibrium_restoring !< If true, restore MEKE back to its equilibrium value, + !! which is calculated at each time step. logical :: GM_src_alt !< If true, use the GM energy conversion form S^2*N^2*kappa rather !! than the streamfunction for the MEKE GM source term. logical :: Rd_as_max_scale !< If true the length scale can not exceed the @@ -77,6 +81,8 @@ module MOM_MEKE real :: MEKE_advection_factor !< A scaling in front of the advection of MEKE [nondim] real :: MEKE_topographic_beta !< Weight for how much topographic beta is considered !! when computing beta in Rhines scale [nondim] + real :: MEKE_restoring_rate !< Inverse of the timescale used to nudge MEKE toward its equilibrium value [s-1]. + logical :: kh_flux_enabled !< If true, lateral diffusive MEKE flux is enabled. logical :: initialize !< If True, invokes a steady state solver to calculate MEKE. logical :: debug !< If true, write out checksums of data for debugging @@ -89,6 +95,7 @@ module MOM_MEKE integer :: id_KhMEKE_u = -1, id_KhMEKE_v = -1, id_Ku = -1, id_Au = -1 integer :: id_Le = -1, id_gamma_b = -1, id_gamma_t = -1 integer :: id_Lrhines = -1, id_Leady = -1 + integer :: id_MEKE_equilibrium = -1 !!@} ! Infrastructure @@ -325,6 +332,13 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif endif + if (CS%MEKE_equilibrium_restoring) then + call MEKE_equilibrium_restoring(CS, MEKE, G, GV, US, SN_u, SN_v) + do j=js,je ; do i=is,ie + src(i,j) = src(i,j) - CS%MEKE_restoring_rate*(MEKE%MEKE(i,j) - CS%equilibrium_value(i,j)) + enddo ; enddo + endif + ! Increase EKE by a full time-steps worth of source !$OMP parallel do default(shared) do j=js,je ; do i=is,ie @@ -772,6 +786,38 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m end subroutine MEKE_equilibrium +!< This subroutine calculates a new equilibrium value for MEKE at each time step. This is not copied into +!! MEKE%MEKE; rather, it is used as a restoring term to nudge MEKE%MEKE back to an equilibrium value +subroutine MEKE_equilibrium_restoring(CS, MEKE, G, GV, US, SN_u, SN_v) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(MEKE_CS), pointer :: CS !< MEKE control structure. + type(MEKE_type), pointer :: MEKE !< A structure with MEKE data. + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. + ! Local variables + real :: SN ! The local Eady growth rate [T-1 ~> s-1] + integer :: i, j, is, ie, js, je, n1, n2 + real :: cd2 + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + cd2 = CS%cdrag**2 + +!$OMP do + do j=js,je ; do i=is,ie + ! SN = 0.25*max( (SN_u(I,j) + SN_u(I-1,j)) + (SN_v(i,J) + SN_v(i,J-1)), 0.) + ! This avoids extremes values in equilibrium solution due to bad values in SN_u, SN_v + SN = min(SN_u(I,j), SN_u(I-1,j), SN_v(i,J), SN_v(i,J-1)) + + CS%equilibrium_value(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * US%Z_to_m*G%bathyT(i,j))**2 / cd2 + enddo ; enddo + + if (CS%id_MEKE_equilibrium>0) call post_data(CS%id_MEKE_equilibrium, CS%equilibrium_value, CS%diag) + +end subroutine MEKE_equilibrium_restoring + + !> Calculates the eddy mixing length scale and \f$\gamma_b\f$ and \f$\gamma_t\f$ !! functions that are ratios of either bottom or barotropic eddy energy to the !! column eddy energy, respectively. See \ref section_MEKE_equations. @@ -937,6 +983,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) ! run to the representation in a restart file. real :: L_rescale ! A rescaling factor for length from the internal representation in this ! run to the representation in a restart file. + real :: MEKE_restoring_timescale ! The timescale used to nudge MEKE toward its equilibrium value. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed logical :: laplacian, biharmonic, useVarMix, coldStart ! This include declares and sets the variable "version". @@ -1002,6 +1049,19 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_ALT", CS%MEKE_equilibrium_alt, & "If true, use an alternative formula for computing the (equilibrium)"//& "initial value of MEKE.", default=.false.) + if (CS%MEKE_equilibrium_alt) then + call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_RESTORING", CS%MEKE_equilibrium_restoring, & + "If true, restore MEKE back to its equilibrium value, which is calculated at"//& + "each time step.", default=.false.) + if (CS%MEKE_equilibrium_restoring) then + call get_param(param_file, mdl, "MEKE_RESTORING_TIMESCALE", MEKE_restoring_timescale, & + "The timescale used to nudge MEKE toward its equilibrium value.", units="s", & + default=1e6, scale=US%T_to_s) + allocate(CS%equilibrium_value(isd:ied,jsd:jed)) ; CS%equilibrium_value(:,:) = 0.0 + CS%MEKE_restoring_rate = 1.0 / MEKE_restoring_timescale + endif + + endif call get_param(param_file, mdl, "MEKE_FRCOEFF", CS%MEKE_FrCoeff, & "The efficiency of the conversion of mean energy into "//& "MEKE. If MEKE_FRCOEFF is negative, this conversion "//& @@ -1193,6 +1253,11 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) 'Meridional diffusivity of MEKE', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) endif + if (CS%MEKE_equilibrium_restoring) then + CS%id_MEKE_equilibrium = register_diag_field('ocean_model', 'MEKE_equilibrium', diag%axesT1, Time, & + 'Equilibrated Mesoscale Eddy Kinetic Energy', 'm2 s-2', conversion=US%L_T_to_m_s**2) + endif + CS%id_clock_pass = cpu_clock_id('(Ocean continuity halo updates)', grain=CLOCK_ROUTINE) ! Detect whether this instance of MEKE_init() is at the beginning of a run From 3f041d93fbb784b420456ca2e6b60df647133426 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 3 Oct 2019 18:24:14 -0400 Subject: [PATCH 054/103] MEKE diagnostic array fixes This patch fixes the following MEKE diagnostics: - MEKE_Ue, MEKE_Ub, MEKE_Ut The diagnostics were computed as inline operations inside post_data, e.g.: post_data(..., sqrt(0, max(0., MEKE*bottomFac2))) rather than computing the fields explicitly inside of array loops. This case causing floating point exceptions in Intel compilers, possibly likely due to evaluations inside of halos. We resolve these diagnostics by computing the values into a scratch array which is then passed to post_data. --- src/parameterizations/lateral/MOM_MEKE.F90 | 28 ++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 853f3a8613..8d3e78262c 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -139,7 +139,8 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h del4MEKE, & ! Time-integrated MEKE tendency arising from the biharmonic of MEKE [L2 T-2 ~> m2 s-2]. LmixScale, & ! Eddy mixing length [L ~> m]. barotrFac2, & ! Ratio of EKE_barotropic / EKE [nondim] - bottomFac2 ! Ratio of EKE_bottom / EKE [nondim] + bottomFac2, & ! Ratio of EKE_bottom / EKE [nondim] + tmp ! Temporary variable for diagnostic computation real, dimension(SZIB_(G),SZJ_(G)) :: & MEKE_uflux, & ! The zonal advective and diffusive flux of MEKE with different units in different @@ -593,10 +594,29 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif ! Offer fields for averaging. + + if (any([CS%id_Ue, CS%id_Ub, CS%id_Ut] > 0)) & + tmp(:,:) = 0. + if (CS%id_MEKE>0) call post_data(CS%id_MEKE, MEKE%MEKE, CS%diag) - if (CS%id_Ue>0) call post_data(CS%id_Ue, sqrt(max(0.,2.0*MEKE%MEKE)), CS%diag) - if (CS%id_Ub>0) call post_data(CS%id_Ub, sqrt(max(0.,2.0*MEKE%MEKE*bottomFac2)), CS%diag) - if (CS%id_Ut>0) call post_data(CS%id_Ut, sqrt(max(0.,2.0*MEKE%MEKE*barotrFac2)), CS%diag) + if (CS%id_Ue>0) then + do j=js,je ; do i=is,ie + tmp(i,j) = sqrt(max(0., 2. * MEKE%MEKE(i,j))) + enddo ; enddo + call post_data(CS%id_Ue, tmp, CS%diag) + endif + if (CS%id_Ub>0) then + do j=js,je ; do i=is,ie + tmp(i,j) = sqrt(max(0., 2. * MEKE%MEKE(i,j) * bottomFac2(i,j))) + enddo ; enddo + call post_data(CS%id_Ub, tmp, CS%diag) + endif + if (CS%id_Ut>0) then + do j=js,je ; do i=is,ie + tmp(i,j) = sqrt(max(0., 2. * MEKE%MEKE(i,j) * barotrFac2(i,j))) + enddo ; enddo + call post_data(CS%id_Ut, tmp, CS%diag) + endif if (CS%id_Kh>0) call post_data(CS%id_Kh, MEKE%Kh, CS%diag) if (CS%id_Ku>0) call post_data(CS%id_Ku, MEKE%Ku, CS%diag) if (CS%id_Au>0) call post_data(CS%id_Au, MEKE%Au, CS%diag) From 050aa31b38f78861a330cd871c1cdb3c11e3f689 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 22 Oct 2019 18:14:01 -0600 Subject: [PATCH 055/103] Moves allocation of CS%equilibrium_value inside subroutine MEKE_equilibrium_restoring * Also deletes unneeded variables from subroutine MEKE_equilibrium_restoring. --- src/parameterizations/lateral/MOM_MEKE.F90 | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 8d3e78262c..a009aea1f6 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -334,7 +334,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif if (CS%MEKE_equilibrium_restoring) then - call MEKE_equilibrium_restoring(CS, MEKE, G, GV, US, SN_u, SN_v) + call MEKE_equilibrium_restoring(CS, G, US, SN_u, SN_v) do j=js,je ; do i=is,ie src(i,j) = src(i,j) - CS%MEKE_restoring_rate*(MEKE%MEKE(i,j) - CS%equilibrium_value(i,j)) enddo ; enddo @@ -808,28 +808,28 @@ end subroutine MEKE_equilibrium !< This subroutine calculates a new equilibrium value for MEKE at each time step. This is not copied into !! MEKE%MEKE; rather, it is used as a restoring term to nudge MEKE%MEKE back to an equilibrium value -subroutine MEKE_equilibrium_restoring(CS, MEKE, G, GV, US, SN_u, SN_v) +subroutine MEKE_equilibrium_restoring(CS, G, US, SN_u, SN_v) type(ocean_grid_type), intent(inout) :: G !< Ocean grid. - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type. type(MEKE_CS), pointer :: CS !< MEKE control structure. - type(MEKE_type), pointer :: MEKE !< A structure with MEKE data. real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. ! Local variables - real :: SN ! The local Eady growth rate [T-1 ~> s-1] - integer :: i, j, is, ie, js, je, n1, n2 - real :: cd2 + real :: SN ! The local Eady growth rate [T-1 ~> s-1] + integer :: i, j, is, ie, js, je ! local indices + real :: cd2 ! bottom drag is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec cd2 = CS%cdrag**2 + if (.not. associated(CS%equilibrium_value)) allocate(CS%equilibrium_value(SZI_(G),SZJ_(G))) + CS%equilibrium_value(:,:) = 0.0 + !$OMP do do j=js,je ; do i=is,ie ! SN = 0.25*max( (SN_u(I,j) + SN_u(I-1,j)) + (SN_v(i,J) + SN_v(i,J-1)), 0.) ! This avoids extremes values in equilibrium solution due to bad values in SN_u, SN_v SN = min(SN_u(I,j), SN_u(I-1,j), SN_v(i,J), SN_v(i,J-1)) - CS%equilibrium_value(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * US%Z_to_m*G%bathyT(i,j))**2 / cd2 enddo ; enddo @@ -837,7 +837,6 @@ subroutine MEKE_equilibrium_restoring(CS, MEKE, G, GV, US, SN_u, SN_v) end subroutine MEKE_equilibrium_restoring - !> Calculates the eddy mixing length scale and \f$\gamma_b\f$ and \f$\gamma_t\f$ !! functions that are ratios of either bottom or barotropic eddy energy to the !! column eddy energy, respectively. See \ref section_MEKE_equations. @@ -1077,7 +1076,6 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) call get_param(param_file, mdl, "MEKE_RESTORING_TIMESCALE", MEKE_restoring_timescale, & "The timescale used to nudge MEKE toward its equilibrium value.", units="s", & default=1e6, scale=US%T_to_s) - allocate(CS%equilibrium_value(isd:ied,jsd:jed)) ; CS%equilibrium_value(:,:) = 0.0 CS%MEKE_restoring_rate = 1.0 / MEKE_restoring_timescale endif From 7f2b93e4cddbb044662e9eef3e3e355e6c025031 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 18 Nov 2019 10:22:07 -0700 Subject: [PATCH 056/103] Replace lbm to lbd (lateral boundary diffusion) --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 24 +++---- src/tracer/MOM_tracer_registry.F90 | 64 +++++++++---------- 2 files changed, 44 insertions(+), 44 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 1a8935ab67..83c49f8f5e 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -75,9 +75,9 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab ! Log this module and master switch for turning it on/off call log_version(param_file, mdl, version, & - "This module implements lateral boundary mixing of tracers") + "This module implements lateral diffusion of tracers near boundaries") call get_param(param_file, mdl, "USE_LATERAL_BOUNDARY_DIFFUSION", lateral_boundary_diffusion_init, & - "If true, enables the lateral boundary mixing module.", & + "If true, enables the lateral boundary tracer's diffusion module.", & default=.false.) if (.not. lateral_boundary_diffusion_init) then @@ -91,12 +91,12 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab CS%surface_boundary_scheme = -1 if ( .not. ASSOCIATED(CS%energetic_PBL_CSp) .and. .not. ASSOCIATED(CS%KPP_CSp) ) then - call MOM_error(FATAL,"Lateral boundary mixing is true, but no valid boundary layer scheme was found") + call MOM_error(FATAL,"Lateral boundary diffusion is true, but no valid boundary layer scheme was found") endif ! Read all relevant parameters and write them to the model log. call get_param(param_file, mdl, "LATERAL_BOUNDARY_METHOD", CS%method, & - "Determine how to apply near-boundary lateral mixing of tracers"//& + "Determine how to apply near-boundary lateral diffusion of tracers"//& "1. Bulk layer approach"//& "2. Along layer approach"//& "3. Decomposition on to pressure levels", default=1) @@ -186,8 +186,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) enddo enddo ! Post tracer bulk diags - if (tracer%id_lbm_bulk_dfx>0) call post_data(tracer%id_lbm_bulk_dfx, uFlx_bulk*Idt, CS%diag) - if (tracer%id_lbm_bulk_dfy>0) call post_data(tracer%id_lbm_bulk_dfy, vFlx_bulk*Idt, CS%diag) + if (tracer%id_lbd_bulk_dfx>0) call post_data(tracer%id_lbd_bulk_dfx, uFlx_bulk*Idt, CS%diag) + if (tracer%id_lbd_bulk_dfy>0) call post_data(tracer%id_lbd_bulk_dfy, vFlx_bulk*Idt, CS%diag) ! TODO: this is where we would filter vFlx and uFlux to get rid of checkerboard noise @@ -221,22 +221,22 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) enddo ; enddo ; enddo ! Post the tracer diagnostics - if (tracer%id_lbm_dfx>0) call post_data(tracer%id_lbm_dfx, uFlx*Idt, CS%diag) - if (tracer%id_lbm_dfy>0) call post_data(tracer%id_lbm_dfy, vFlx*Idt, CS%diag) - if (tracer%id_lbm_dfx_2d>0) then + if (tracer%id_lbd_dfx>0) call post_data(tracer%id_lbd_dfx, uFlx*Idt, CS%diag) + if (tracer%id_lbd_dfy>0) call post_data(tracer%id_lbd_dfy, vFlx*Idt, CS%diag) + if (tracer%id_lbd_dfx_2d>0) then uwork_2d(:,:) = 0. do k=1,GV%ke; do j=G%jsc,G%jec; do I=G%isc-1,G%iec uwork_2d(I,j) = uwork_2d(I,j) + (uFlx(I,j,k) * Idt) enddo; enddo; enddo - call post_data(tracer%id_lbm_dfx_2d, uwork_2d, CS%diag) + call post_data(tracer%id_lbd_dfx_2d, uwork_2d, CS%diag) endif - if (tracer%id_lbm_dfy_2d>0) then + if (tracer%id_lbd_dfy_2d>0) then vwork_2d(:,:) = 0. do k=1,GV%ke; do J=G%jsc-1,G%jec; do i=G%isc,G%iec vwork_2d(i,J) = vwork_2d(i,J) + (vFlx(i,J,k) * Idt) enddo; enddo; enddo - call post_data(tracer%id_lbm_dfy_2d, vwork_2d, CS%diag) + call post_data(tracer%id_lbd_dfy_2d, vwork_2d, CS%diag) endif enddo diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 977e78cf99..318a7cfce2 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -56,17 +56,17 @@ module MOM_tracer_registry !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: df_y => NULL() !< diagnostic array for y-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:,:), pointer :: lbm_dfx => NULL() !< diagnostic array for x-diffusive tracer flux + real, dimension(:,:,:), pointer :: lbd_dfx => NULL() !< diagnostic array for x-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:,:), pointer :: lbm_dfy => NULL() !< diagnostic array for y-diffusive tracer flux + real, dimension(:,:,:), pointer :: lbd_dfy => NULL() !< diagnostic array for y-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: lbm_dfx_2d => NULL() !< diagnostic array for x-diffusive tracer flux + real, dimension(:,:), pointer :: lbd_dfx_2d => NULL() !< diagnostic array for x-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: lbm_dfy_2d => NULL() !< diagnostic array for y-diffusive tracer flux + real, dimension(:,:), pointer :: lbd_dfy_2d => NULL() !< diagnostic array for y-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: lbm_bulk_df_x => NULL() !< diagnostic array for x-diffusive tracer flux + real, dimension(:,:), pointer :: lbd_bulk_df_x => NULL() !< diagnostic array for x-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: lbm_bulk_df_y => NULL() !< diagnostic array for y-diffusive tracer flux + real, dimension(:,:), pointer :: lbd_bulk_df_y => NULL() !< diagnostic array for y-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_x => NULL() !< diagnostic vertical sum x-diffusive flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] @@ -121,8 +121,8 @@ module MOM_tracer_registry !>@{ Diagnostic IDs integer :: id_tr = -1 integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_dfy = -1 - integer :: id_lbm_bulk_dfx = -1, id_lbm_bulk_dfy = -1, id_lbm_dfx = -1, id_lbm_dfy = -1 - integer :: id_lbm_dfx_2d, id_lbm_dfy_2d + integer :: id_lbd_bulk_dfx = -1, id_lbd_bulk_dfy = -1, id_lbd_dfx = -1, id_lbd_dfy = -1 + integer :: id_lbd_dfx_2d, id_lbd_dfy_2d integer :: id_adx_2d = -1, id_ady_2d = -1, id_dfx_2d = -1, id_dfy_2d = -1 integer :: id_adv_xy = -1, id_adv_xy_2d = -1 integer :: id_dfxy_cont = -1, id_dfxy_cont_2d = -1, id_dfxy_conc = -1 @@ -414,19 +414,19 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) Tr%id_dfy = register_diag_field("ocean_model", trim(shortnm)//"_dfy", & diag%axesCvL, Time, trim(flux_longname)//" diffusive merdional flux" , & trim(flux_units), v_extensive = .true., x_cell_method = 'sum') - Tr%id_lbm_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbm_dfx", & - diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the near-boundary mixing scheme" , & + Tr%id_lbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_dfx", & + diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the near-boundary diffusion scheme" , & trim(flux_units), v_extensive = .true., y_cell_method = 'sum') - Tr%id_lbm_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbm_dfy", & - diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the near-boundary mixing scheme" , & + Tr%id_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_dfy", & + diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the near-boundary diffusion scheme" , & trim(flux_units), v_extensive = .true., x_cell_method = 'sum') - Tr%id_lbm_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbm_dfx_2d", & + Tr%id_lbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_dfx_2d", & diag%axesCu1, Time, trim(flux_longname)//& - " diffusive zonal flux from the near-boundary mixing scheme vertically integrated" , & + " diffusive zonal flux from the near-boundary diffusion scheme vertically integrated" , & trim(flux_units), v_extensive = .true., y_cell_method = 'sum') - Tr%id_lbm_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbm_dfy_2d", & + Tr%id_lbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_dfy_2d", & diag%axesCv1, Time, trim(flux_longname)//& - " diffusive meridional flux from the near-boundary mixing scheme vertically integrated" , & + " diffusive meridional flux from the near-boundary diffusion scheme vertically integrated" , & trim(flux_units), v_extensive = .true., x_cell_method = 'sum') else Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & @@ -441,27 +441,27 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) Tr%id_dfy = register_diag_field("ocean_model", trim(shortnm)//"_diffy", & diag%axesCvL, Time, "Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=Tr%flux_scale, x_cell_method = 'sum') - Tr%id_lbm_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbm_diffx", & - diag%axesCuL, Time, "Boundary Diffusive Zonal Flux of "//trim(flux_longname), & + Tr%id_lbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx", & + diag%axesCuL, Time, "Lateral Boundary Diffusive Zonal Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=Tr%flux_scale, y_cell_method = 'sum') - Tr%id_lbm_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbm_diffy", & - diag%axesCvL, Time, "Boundary Diffusive Meridional Flux of "//trim(flux_longname), & + Tr%id_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy", & + diag%axesCvL, Time, "Lateral Boundary Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=Tr%flux_scale, x_cell_method = 'sum') - Tr%id_lbm_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbm_diffx_2d", & - diag%axesCu1, Time, "Vertically integrated Boundary Diffusive Zonal Flux of "//trim(flux_longname), & + Tr%id_lbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx_2d", & + diag%axesCu1, Time, "Vertically integrated Lateral Boundary Diffusive Zonal Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=Tr%flux_scale, y_cell_method = 'sum') - Tr%id_lbm_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbm_diffy_2d", & - diag%axesCv1, Time, "Vertically integrated Boundary Diffusive Meridional Flux of "//trim(flux_longname), & + Tr%id_lbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy_2d", & + diag%axesCv1, Time, "Vertically integrated Lateral Boundary Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=Tr%flux_scale, x_cell_method = 'sum') endif if (Tr%id_adx > 0) call safe_alloc_ptr(Tr%ad_x,IsdB,IedB,jsd,jed,nz) if (Tr%id_ady > 0) call safe_alloc_ptr(Tr%ad_y,isd,ied,JsdB,JedB,nz) if (Tr%id_dfx > 0) call safe_alloc_ptr(Tr%df_x,IsdB,IedB,jsd,jed,nz) if (Tr%id_dfy > 0) call safe_alloc_ptr(Tr%df_y,isd,ied,JsdB,JedB,nz) - if (Tr%id_lbm_dfx > 0) call safe_alloc_ptr(Tr%lbm_dfx,IsdB,IedB,jsd,jed,nz) - if (Tr%id_lbm_dfy > 0) call safe_alloc_ptr(Tr%lbm_dfy,isd,ied,JsdB,JedB,nz) - if (Tr%id_lbm_dfx_2d > 0) call safe_alloc_ptr(Tr%lbm_dfx_2d,IsdB,IedB,jsd,jed) - if (Tr%id_lbm_dfy_2d > 0) call safe_alloc_ptr(Tr%lbm_dfy_2d,isd,ied,JsdB,JedB) + if (Tr%id_lbd_dfx > 0) call safe_alloc_ptr(Tr%lbd_dfx,IsdB,IedB,jsd,jed,nz) + if (Tr%id_lbd_dfy > 0) call safe_alloc_ptr(Tr%lbd_dfy,isd,ied,JsdB,JedB,nz) + if (Tr%id_lbd_dfx_2d > 0) call safe_alloc_ptr(Tr%lbd_dfx_2d,IsdB,IedB,jsd,jed) + if (Tr%id_lbd_dfy_2d > 0) call safe_alloc_ptr(Tr%lbd_dfy_2d,isd,ied,JsdB,JedB) Tr%id_adx_2d = register_diag_field("ocean_model", trim(shortnm)//"_adx_2d", & diag%axesCu1, Time, & @@ -479,11 +479,11 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) diag%axesCv1, Time, & "Vertically Integrated Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, conversion=Tr%flux_scale, x_cell_method = 'sum') - Tr%id_lbm_bulk_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbm_bulk_diffx", & + Tr%id_lbd_bulk_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_bulk_diffx", & diag%axesCu1, Time, & "Total Bulk Diffusive Zonal Flux of "//trim(flux_longname), & flux_units, conversion=Tr%flux_scale, y_cell_method = 'sum') - Tr%id_lbm_bulk_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbm_bulk_diffy", & + Tr%id_lbd_bulk_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_bulk_diffy", & diag%axesCv1, Time, & "Vertically Integrated Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, conversion=Tr%flux_scale, x_cell_method = 'sum') @@ -492,8 +492,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) if (Tr%id_ady_2d > 0) call safe_alloc_ptr(Tr%ad2d_y,isd,ied,JsdB,JedB) if (Tr%id_dfx_2d > 0) call safe_alloc_ptr(Tr%df2d_x,IsdB,IedB,jsd,jed) if (Tr%id_dfy_2d > 0) call safe_alloc_ptr(Tr%df2d_y,isd,ied,JsdB,JedB) - if (Tr%id_lbm_bulk_dfx > 0) call safe_alloc_ptr(Tr%lbm_bulk_df_x,IsdB,IedB,jsd,jed) - if (Tr%id_lbm_bulk_dfy > 0) call safe_alloc_ptr(Tr%lbm_bulk_df_y,isd,ied,JsdB,JedB) + if (Tr%id_lbd_bulk_dfx > 0) call safe_alloc_ptr(Tr%lbd_bulk_df_x,IsdB,IedB,jsd,jed) + if (Tr%id_lbd_bulk_dfy > 0) call safe_alloc_ptr(Tr%lbd_bulk_df_y,isd,ied,JsdB,JedB) Tr%id_adv_xy = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy", & diag%axesTL, Time, & From 6bce8ab9efa79ba928536207b254f591dc3e7144 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 18 Nov 2019 13:02:27 -0700 Subject: [PATCH 057/103] Clean the code and fix line length exceeding 120 --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 80 +++++++++++-------- src/tracer/MOM_tracer_hor_diff.F90 | 9 ++- src/tracer/MOM_tracer_registry.F90 | 30 +++---- 3 files changed, 69 insertions(+), 50 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 83c49f8f5e..ac52c1fc18 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -1,5 +1,5 @@ !> Calculate and apply diffusive fluxes as a parameterization of lateral mixing (non-neutral) by -!! mesoscale eddies near the top and bottom boundary layers of the ocean. +!! mesoscale eddies near the top and bottom (to be implemented) boundary layers of the ocean. module MOM_lateral_boundary_diffusion ! This file is part of MOM6. See LICENSE.md for the license. @@ -27,6 +27,7 @@ module MOM_lateral_boundary_diffusion public near_boundary_unit_tests, lateral_boundary_diffusion, lateral_boundary_diffusion_init public boundary_k_range + ! Private parameters to avoid doing string comparisons for bottom or top boundary layer integer, public, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface bopundary integer, public, parameter :: BOTTOM = 1 !< Set a value that corresponds to the bottom boundary @@ -36,7 +37,7 @@ module MOM_lateral_boundary_diffusion type, public :: lateral_boundary_diffusion_CS ; private integer :: method !< Determine which of the three methods calculate !! and apply near boundary layer fluxes - !! 1. bulk-layer approach + !! 1. Bulk-layer approach !! 2. Along layer !! 3. Decomposition onto pressure levels integer :: deg !< Degree of polynomial reconstruction @@ -44,27 +45,28 @@ module MOM_lateral_boundary_diffusion !! 1. ePBL; 2. KPP type(remapping_CS) :: remap_CS !< Control structure to hold remapping configuration type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to get BLD - type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure needed to get MLD + type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure needed to get BLD type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. end type lateral_boundary_diffusion_CS ! This include declares and sets the variable "version". #include "version_variable.h" -character(len=40) :: mdl = "MOM_lateral_boundary_diffusion" !< Name of this module +character(len=40) :: mdl = "MOM_lateral_boundary_diffusion" !< Name of this module contains !> Initialization routine that reads runtime parameters and sets up pointers to other control structures that might be -!! needed for lateral boundary mixing +!! needed for lateral boundary diffusion. logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diabatic_CSp, CS) - type(time_type), target, intent(in) :: Time !< Time structure - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(param_file_type), intent(in) :: param_file !< Parameter file structure - type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure - type(diabatic_CS), pointer :: diabatic_CSp !< KPP control structure needed to get BLD + type(time_type), target, intent(in) :: Time !< Time structure + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(diabatic_CS), pointer :: diabatic_CSp !< KPP control structure needed to get BLD type(lateral_boundary_diffusion_CS), pointer :: CS !< Lateral boundary mixing control structure + ! local variables character(len=80) :: string ! Temporary strings logical :: boundary_extrap @@ -116,32 +118,33 @@ end function lateral_boundary_diffusion_init !> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. Two different methods !! Method 1: Calculate fluxes from bulk layer integrated quantities subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) - type(ocean_grid_type), intent(inout) :: G !< Grid type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ocean_grid_type), intent(inout) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [m2] real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [m2] real, intent(in) :: dt !< Tracer time step * I_numitts !! (I_numitts in tracer_hordiff) type(tracer_registry_type), pointer :: Reg !< Tracer registry - type(lateral_boundary_diffusion_CS), intent(in) :: CS !< Control structure for this module + type(lateral_boundary_diffusion_CS), intent(in) :: CS !< Control structure for this module + ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [m] + real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [m] real, dimension(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1) :: ppoly0_coefs !< Coefficients of polynomial real, dimension(SZI_(G),SZJ_(G),SZK_(G),2) :: ppoly0_E !< Edge values from reconstructions - real, dimension(SZK_(G),CS%deg+1) :: ppoly_S !< Slopes from reconstruction (placeholder) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx ! Zonal flux of tracer [H conc ~> m conc or conc kg m-2] - real, dimension(SZIB_(G),SZJ_(G)) :: uFLx_bulk ! Total calculated bulk-layer u-flux for the tracer - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx ! Meridional flux of tracer - real, dimension(SZI_(G),SZJB_(G)) :: vFlx_bulk ! Total calculated bulk-layer v-flux for the tracer - real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d ! Layer summed u-flux transport - real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d ! Layer summed v-flux transport - type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer + real, dimension(SZK_(G),CS%deg+1) :: ppoly_S !< Slopes from reconstruction (placeholder) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx !< Zonal flux of tracer [H conc ~> m conc or conc kg m-2] + real, dimension(SZIB_(G),SZJ_(G)) :: uFLx_bulk !< Total calculated bulk-layer u-flux for the tracer + real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx !< Meridional flux of tracer + real, dimension(SZI_(G),SZJB_(G)) :: vFlx_bulk !< Total calculated bulk-layer v-flux for the tracer + real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d !< Layer summed u-flux transport + real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d !< Layer summed v-flux transport + type(tracer_type), pointer :: Tracer => NULL() !< Pointer to the current tracer integer :: remap_method !< Reconstruction method - integer :: i,j,k,m - real :: Idt !< inverse of the time step [s-1] + integer :: i,j,k,m !< indices to loop over + real :: Idt !< inverse of the time step [s-1] Idt = 1./dt hbl(:,:) = 0. @@ -164,6 +167,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) vFlx(:,:,:) = 0. uFlx_bulk(:,:) = 0. vFlx_bulk(:,:) = 0. + + ! Method #1 if ( CS%method == 1 ) then do j=G%jsc,G%jec do i=G%isc-1,G%iec @@ -191,6 +196,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! TODO: this is where we would filter vFlx and uFlux to get rid of checkerboard noise + ! Method #2 elseif (CS%method == 2) then do j=G%jsc,G%jec do i=G%isc-1,G%iec @@ -251,9 +257,9 @@ real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coe real, dimension(nk) :: h !< Layer thicknesses [m] real :: hBLT !< Depth of the mixing layer [m] real, dimension(nk) :: phi !< Scalar quantity - real, dimension(nk,2) :: ppoly0_E(:,:) !< Edge value of polynomial + real, dimension(nk,2) :: ppoly0_E(:,:) !< Edge value of polynomial real, dimension(nk,deg+1) :: ppoly0_coefs(:,:) !< Coefficients of polynomial - integer :: method !< Remapping scheme to use + integer :: method !< Remapping scheme to use integer :: k_top !< Index of the first layer within the boundary real :: zeta_top !< Fraction of the layer encompassed by the bottom boundary layer @@ -265,7 +271,7 @@ real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coe !! because integration starts at the bottom [nondim] ! Local variables real :: htot ! Running sum of the thicknesses (top to bottom) - integer :: k + integer :: k ! k indice htot = 0. @@ -364,6 +370,7 @@ end subroutine boundary_k_range !> Calculate the near-boundary diffusive fluxes calculated using the layer by layer method. subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, & ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] @@ -404,6 +411,7 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, if (hbl_L == 0. .or. hbl_R == 0.) then return endif + ! Calculate vertical indices containing the boundary layer call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) @@ -452,6 +460,7 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_L_avg = average_value_ppoly( nk, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, 1.0-zeta_top_L, 1.0) phi_R_avg = average_value_ppoly( nk, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, 1.0-zeta_top_R, 1.0) heff = harmonic_mean(h_work_L, h_work_R) + ! tracer flux where the minimum BLD intersets layer F_layer(k_top_max) = (-heff * khtr_u) * (phi_R_avg - phi_L_avg) do k = k_top_max+1,nk @@ -459,11 +468,13 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) enddo endif + end subroutine fluxes_layer_method !> Calculate the near-boundary diffusive fluxes calculated from a 'bulk model' subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, ppoly0_coefs_L, & ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, F_limit) + integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] @@ -503,7 +514,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real :: zeta_top_L, zeta_top_R, zeta_top_u real :: zeta_bot_L, zeta_bot_R, zeta_bot_u real :: h_work_L, h_work_R ! dummy variables - real :: F_max !< The maximum amount of flux that can leave a cell + real :: F_max !< The maximum amount of flux that can leave a cell logical :: limited !< True if the flux limiter was applied real :: hfrac, F_bulk_remain @@ -512,9 +523,11 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, F_layer(:) = 0. return endif + ! Calculate vertical indices containing the boundary layer call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) + ! Calculate bulk averages of various quantities phi_L_avg = bulk_average(boundary, nk, deg, h_L, hbl_L, phi_L, ppoly0_E_L, ppoly0_coefs_L, method, k_top_L, & zeta_top_L, k_bot_L, zeta_bot_L) @@ -531,7 +544,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, F_bulk = -(khtr_u * heff) * (phi_R_avg - phi_L_avg) F_bulk_remain = F_bulk ! Calculate the layerwise sum of the vertical effective thickness. This is different than the heff calculated - ! above, but is used as a way to decompose decompose the fluxes onto the individual layers + ! above, but is used as a way to decompose the fluxes onto the individual layers h_means(:) = 0. if (boundary == SURFACE) then @@ -579,6 +592,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, h_means(k) = harmonic_mean(h_L(k),h_R(k)) enddo endif + if ( SUM(h_means) == 0. ) then return else @@ -802,7 +816,8 @@ end subroutine fluxes_bulk_method ! ! NOTE: This would be better expressed in terms of the layers thicknesses rather ! ! than as differences of position - AJA ! -! ! TODO: GMM, we need to import absolute_position from neutral diffusion. This gives us the depth of the interface on the left and right side. +! ! TODO: GMM, we need to import absolute_position from neutral diffusion. This gives us +! !! the depth of the interface on the left and right side. ! ! if (k_surface>1) then ! hL = absolute_position(nk,ns,Pl,KoL,PoL,k_surface) - absolute_position(nk,ns,Pl,KoL,PoL,k_surface-1) @@ -1156,4 +1171,5 @@ logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_a end function test_boundary_k_range + end module MOM_lateral_boundary_diffusion diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 0c108ceacb..848841caf6 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -65,8 +65,8 @@ module MOM_tracer_hor_diff logical :: recalc_neutral_surf !< If true, recalculate the neutral surfaces if CFL has been !! exceeded type(neutral_diffusion_CS), pointer :: neutral_diffusion_CSp => NULL() !< Control structure for neutral diffusion. - type(lateral_boundary_diffusion_CS), pointer :: lateral_boundary_diffusion_CSp => NULL() !< Control structure for lateral - !! boundary mixing. + type(lateral_boundary_diffusion_CS), pointer :: lateral_boundary_diffusion_CSp => NULL() !< Control structure for + !! lateral boundary mixing. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. logical :: debug !< If true, write verbose checksums for debugging purposes. @@ -406,11 +406,12 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online enddo do itt=1,num_itts - if (CS%show_call_tree) call callTree_waypoint("Calling lateral boundary mixing (tracer_hordiff)",itt) + if (CS%show_call_tree) call callTree_waypoint("Calling lateral boundary diffusion (tracer_hordiff)",itt) if (itt>1) then ! Update halos for subsequent iterations call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) endif - call lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, I_numitts*dt, Reg, CS%lateral_boundary_diffusion_CSp) + call lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, I_numitts*dt, Reg, & + CS%lateral_boundary_diffusion_CSp) enddo ! itt endif diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 318a7cfce2..f5971f8abd 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -56,9 +56,9 @@ module MOM_tracer_registry !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: df_y => NULL() !< diagnostic array for y-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:,:), pointer :: lbd_dfx => NULL() !< diagnostic array for x-diffusive tracer flux + real, dimension(:,:,:), pointer :: lbd_dfx => NULL() !< diagnostic array for x-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:,:), pointer :: lbd_dfy => NULL() !< diagnostic array for y-diffusive tracer flux + real, dimension(:,:,:), pointer :: lbd_dfy => NULL() !< diagnostic array for y-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: lbd_dfx_2d => NULL() !< diagnostic array for x-diffusive tracer flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] @@ -122,7 +122,7 @@ module MOM_tracer_registry integer :: id_tr = -1 integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_dfy = -1 integer :: id_lbd_bulk_dfx = -1, id_lbd_bulk_dfy = -1, id_lbd_dfx = -1, id_lbd_dfy = -1 - integer :: id_lbd_dfx_2d, id_lbd_dfy_2d + integer :: id_lbd_dfx_2d = -1 , id_lbd_dfy_2d = -1 integer :: id_adx_2d = -1, id_ady_2d = -1, id_dfx_2d = -1, id_dfy_2d = -1 integer :: id_adv_xy = -1, id_adv_xy_2d = -1 integer :: id_dfxy_cont = -1, id_dfxy_cont_2d = -1, id_dfxy_conc = -1 @@ -415,18 +415,18 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) diag%axesCvL, Time, trim(flux_longname)//" diffusive merdional flux" , & trim(flux_units), v_extensive = .true., x_cell_method = 'sum') Tr%id_lbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_dfx", & - diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the near-boundary diffusion scheme" , & - trim(flux_units), v_extensive = .true., y_cell_method = 'sum') + diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the lateral boundary diffusion "& + "scheme", trim(flux_units), v_extensive = .true., y_cell_method = 'sum') Tr%id_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_dfy", & - diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the near-boundary diffusion scheme" , & - trim(flux_units), v_extensive = .true., x_cell_method = 'sum') + diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the lateral boundary diffusion"& + " scheme", trim(flux_units), v_extensive = .true., x_cell_method = 'sum') Tr%id_lbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_dfx_2d", & diag%axesCu1, Time, trim(flux_longname)//& - " diffusive zonal flux from the near-boundary diffusion scheme vertically integrated" , & + "Vertically-integrated zonal diffusive flux from the lateral boundary diffusion scheme" , & trim(flux_units), v_extensive = .true., y_cell_method = 'sum') Tr%id_lbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_dfy_2d", & diag%axesCv1, Time, trim(flux_longname)//& - " diffusive meridional flux from the near-boundary diffusion scheme vertically integrated" , & + "Vertically-integrated meridional diffusive flux from the lateral boundary diffusion scheme" , & trim(flux_units), v_extensive = .true., x_cell_method = 'sum') else Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & @@ -448,11 +448,13 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) diag%axesCvL, Time, "Lateral Boundary Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=Tr%flux_scale, x_cell_method = 'sum') Tr%id_lbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx_2d", & - diag%axesCu1, Time, "Vertically integrated Lateral Boundary Diffusive Zonal Flux of "//trim(flux_longname), & - flux_units, v_extensive=.true., conversion=Tr%flux_scale, y_cell_method = 'sum') + diag%axesCu1, Time, "Vertically-integrated zonal diffusive flux from the lateral boundary diffusion "//& + "scheme for" //trim(flux_longname), flux_units, v_extensive=.true., conversion=Tr%flux_scale, & + y_cell_method = 'sum') Tr%id_lbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy_2d", & - diag%axesCv1, Time, "Vertically integrated Lateral Boundary Diffusive Meridional Flux of "//trim(flux_longname), & - flux_units, v_extensive=.true., conversion=Tr%flux_scale, x_cell_method = 'sum') + diag%axesCv1, Time, "Vertically-integrated meridional diffusive flux from the lateral boundary diffusion "//& + "scheme for "//trim(flux_longname), flux_units, v_extensive=.true., conversion=Tr%flux_scale, & + x_cell_method = 'sum') endif if (Tr%id_adx > 0) call safe_alloc_ptr(Tr%ad_x,IsdB,IedB,jsd,jed,nz) if (Tr%id_ady > 0) call safe_alloc_ptr(Tr%ad_y,isd,ied,JsdB,JedB,nz) @@ -485,7 +487,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) flux_units, conversion=Tr%flux_scale, y_cell_method = 'sum') Tr%id_lbd_bulk_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_bulk_diffy", & diag%axesCv1, Time, & - "Vertically Integrated Diffusive Meridional Flux of "//trim(flux_longname), & + "Total Bulk Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, conversion=Tr%flux_scale, x_cell_method = 'sum') if (Tr%id_adx_2d > 0) call safe_alloc_ptr(Tr%ad2d_x,IsdB,IedB,jsd,jed) From 0a89aaca92570118e6eb5b7705883cf74a165f3d Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 19 Nov 2019 13:36:58 -0700 Subject: [PATCH 058/103] Fix registry of lbd diagnostics * remove v_extensive=.true. from 2D diagnostics and group them with other 2D fields; * changes names (_lbd_dfx_2d) to be consistent between diag_types 1 and 2.They all have _lbd_diffx_2d now. --- src/tracer/MOM_tracer_registry.F90 | 30 ++++++++++-------------------- 1 file changed, 10 insertions(+), 20 deletions(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index f5971f8abd..f71760d361 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -414,20 +414,12 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) Tr%id_dfy = register_diag_field("ocean_model", trim(shortnm)//"_dfy", & diag%axesCvL, Time, trim(flux_longname)//" diffusive merdional flux" , & trim(flux_units), v_extensive = .true., x_cell_method = 'sum') - Tr%id_lbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_dfx", & + Tr%id_lbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx", & diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the lateral boundary diffusion "& "scheme", trim(flux_units), v_extensive = .true., y_cell_method = 'sum') - Tr%id_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_dfy", & + Tr%id_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy", & diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the lateral boundary diffusion"& " scheme", trim(flux_units), v_extensive = .true., x_cell_method = 'sum') - Tr%id_lbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_dfx_2d", & - diag%axesCu1, Time, trim(flux_longname)//& - "Vertically-integrated zonal diffusive flux from the lateral boundary diffusion scheme" , & - trim(flux_units), v_extensive = .true., y_cell_method = 'sum') - Tr%id_lbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_dfy_2d", & - diag%axesCv1, Time, trim(flux_longname)//& - "Vertically-integrated meridional diffusive flux from the lateral boundary diffusion scheme" , & - trim(flux_units), v_extensive = .true., x_cell_method = 'sum') else Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, "Advective (by residual mean) Zonal Flux of "//trim(flux_longname), & @@ -447,14 +439,6 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) Tr%id_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy", & diag%axesCvL, Time, "Lateral Boundary Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=Tr%flux_scale, x_cell_method = 'sum') - Tr%id_lbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx_2d", & - diag%axesCu1, Time, "Vertically-integrated zonal diffusive flux from the lateral boundary diffusion "//& - "scheme for" //trim(flux_longname), flux_units, v_extensive=.true., conversion=Tr%flux_scale, & - y_cell_method = 'sum') - Tr%id_lbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy_2d", & - diag%axesCv1, Time, "Vertically-integrated meridional diffusive flux from the lateral boundary diffusion "//& - "scheme for "//trim(flux_longname), flux_units, v_extensive=.true., conversion=Tr%flux_scale, & - x_cell_method = 'sum') endif if (Tr%id_adx > 0) call safe_alloc_ptr(Tr%ad_x,IsdB,IedB,jsd,jed,nz) if (Tr%id_ady > 0) call safe_alloc_ptr(Tr%ad_y,isd,ied,JsdB,JedB,nz) @@ -462,8 +446,6 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) if (Tr%id_dfy > 0) call safe_alloc_ptr(Tr%df_y,isd,ied,JsdB,JedB,nz) if (Tr%id_lbd_dfx > 0) call safe_alloc_ptr(Tr%lbd_dfx,IsdB,IedB,jsd,jed,nz) if (Tr%id_lbd_dfy > 0) call safe_alloc_ptr(Tr%lbd_dfy,isd,ied,JsdB,JedB,nz) - if (Tr%id_lbd_dfx_2d > 0) call safe_alloc_ptr(Tr%lbd_dfx_2d,IsdB,IedB,jsd,jed) - if (Tr%id_lbd_dfy_2d > 0) call safe_alloc_ptr(Tr%lbd_dfy_2d,isd,ied,JsdB,JedB) Tr%id_adx_2d = register_diag_field("ocean_model", trim(shortnm)//"_adx_2d", & diag%axesCu1, Time, & @@ -489,6 +471,12 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) diag%axesCv1, Time, & "Total Bulk Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, conversion=Tr%flux_scale, x_cell_method = 'sum') + Tr%id_lbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx_2d", & + diag%axesCu1, Time, "Vertically-integrated zonal diffusive flux from the lateral boundary diffusion "//& + "scheme for "//trim(flux_longname), flux_units, conversion=Tr%flux_scale, y_cell_method = 'sum') + Tr%id_lbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy_2d", & + diag%axesCv1, Time, "Vertically-integrated meridional diffusive flux from the lateral boundary diffusion "//& + "scheme for "//trim(flux_longname), flux_units, conversion=Tr%flux_scale, x_cell_method = 'sum') if (Tr%id_adx_2d > 0) call safe_alloc_ptr(Tr%ad2d_x,IsdB,IedB,jsd,jed) if (Tr%id_ady_2d > 0) call safe_alloc_ptr(Tr%ad2d_y,isd,ied,JsdB,JedB) @@ -496,6 +484,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) if (Tr%id_dfy_2d > 0) call safe_alloc_ptr(Tr%df2d_y,isd,ied,JsdB,JedB) if (Tr%id_lbd_bulk_dfx > 0) call safe_alloc_ptr(Tr%lbd_bulk_df_x,IsdB,IedB,jsd,jed) if (Tr%id_lbd_bulk_dfy > 0) call safe_alloc_ptr(Tr%lbd_bulk_df_y,isd,ied,JsdB,JedB) + if (Tr%id_lbd_dfx_2d > 0) call safe_alloc_ptr(Tr%lbd_dfx_2d,IsdB,IedB,jsd,jed) + if (Tr%id_lbd_dfy_2d > 0) call safe_alloc_ptr(Tr%lbd_dfy_2d,isd,ied,JsdB,JedB) Tr%id_adv_xy = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy", & diag%axesTL, Time, & From b1ce184a3c003305af3fec04e9c9076c9f97a1c4 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 19 Nov 2019 18:26:42 -0700 Subject: [PATCH 059/103] Documentation and minor improvements * Remove duplicated unit test * First draft of documentation --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 91 ++++++++++++++----- 1 file changed, 67 insertions(+), 24 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index ac52c1fc18..54642083bd 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -1,5 +1,6 @@ -!> Calculate and apply diffusive fluxes as a parameterization of lateral mixing (non-neutral) by +!> Calculates and applies diffusive fluxes as a parameterization of lateral mixing (non-neutral) by !! mesoscale eddies near the top and bottom (to be implemented) boundary layers of the ocean. + module MOM_lateral_boundary_diffusion ! This file is part of MOM6. See LICENSE.md for the license. @@ -98,9 +99,9 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab ! Read all relevant parameters and write them to the model log. call get_param(param_file, mdl, "LATERAL_BOUNDARY_METHOD", CS%method, & - "Determine how to apply near-boundary lateral diffusion of tracers"//& - "1. Bulk layer approach"//& - "2. Along layer approach"//& + "Determine how to apply boundary lateral diffusion of tracers: \n"//& + "1. Bulk layer approach \n"//& + "2. Along layer approach \n"//& "3. Decomposition on to pressure levels", default=1) call get_param(param_file, mdl, "LBD_BOUNDARY_EXTRAP", boundary_extrap, & "Use boundary extrapolation in LBD code", & @@ -255,7 +256,7 @@ real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coe integer :: nk !< Number of layers [nondim] integer :: deg !< Degree of polynomial [nondim] real, dimension(nk) :: h !< Layer thicknesses [m] - real :: hBLT !< Depth of the mixing layer [m] + real :: hBLT !< Depth of the boundary layer [m] real, dimension(nk) :: phi !< Scalar quantity real, dimension(nk,2) :: ppoly0_E(:,:) !< Edge value of polynomial real, dimension(nk,deg+1) :: ppoly0_coefs(:,:) !< Coefficients of polynomial @@ -301,6 +302,7 @@ real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coe end function bulk_average !> Calculate the harmonic mean of two quantities +!! See \ref section_harmonic_mean. real function harmonic_mean(h1,h2) real :: h1 !< Scalar quantity real :: h2 !< Scalar quantity @@ -367,7 +369,8 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b end subroutine boundary_k_range -!> Calculate the near-boundary diffusive fluxes calculated using the layer by layer method. +!> Calculate the lateral boundary diffusive fluxes using the layer by layer method. +!! See \ref LBD_method2 subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, & ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) @@ -471,7 +474,8 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, end subroutine fluxes_layer_method -!> Calculate the near-boundary diffusive fluxes calculated from a 'bulk model' +!> Apply the lateral boundary diffusive fluxes calculated from a 'bulk model' +!! See \ref LBD_method1 subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, ppoly0_coefs_L, & ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, F_limit) @@ -606,6 +610,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, hfrac = h_means(k)*inv_heff F_layer(k) = F_bulk * hfrac if ( SIGN(1.,F_bulk) == SIGN(1., F_layer(k))) then + ! limit the flux to 0.25 of the total tracer in the cell if (F_bulk < 0. .and. phi_R(k) >= 0.) then F_max = 0.25 * (area_R*(phi_R(k)*h_R(k))) elseif (F_bulk > 0. .and. phi_L(k) >= 0.) then @@ -618,6 +623,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, F_layer(k) = F_bulk_remain endif F_bulk_remain = F_bulk_remain - F_layer(k) + ! Apply flux limiter calculated above if (F_max >= 0.) then if (F_layer(k) > 0.) then @@ -628,6 +634,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, F_layer(k) = MAX(F_layer(k),-F_max) ! Note negative to make the sign of flux consistent endif endif + if (PRESENT(F_limit)) then if (limited) then F_limit(k) = F_layer(k) - F_max @@ -992,23 +999,6 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) - test_name = 'Different hbl and different column thicknesses (gradient from right to left)' - hbl_L = 12; hbl_R = 20 - h_L = (/6.,6./) ; h_R = (/10.,10./) - phi_L = (/0.,0./) ; phi_R = (/1.,1./) - phi_pp_L(1,1) = 0.; phi_pp_L(1,2) = 0. - phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. - phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. - phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. - ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. - ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. - khtr_u = 1. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) - test_name = 'Different hbl and different layer thicknesses (gradient from right to left)' hbl_L = 12; hbl_R = 20 h_L = (/6.,6./) ; h_R = (/10.,10./) @@ -1074,6 +1064,7 @@ logical function near_boundary_unit_tests( verbose ) call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-2.,-2./) ) + ! unit tests for layer by layer method test_name = 'Different hbl and different column thicknesses (gradient from right to left)' hbl_L = 12; hbl_R = 20 @@ -1172,4 +1163,56 @@ logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_a end function test_boundary_k_range +!> \namespace mom_lbd +!! +!! \section section_LBD The Lateral Boundary Diffusion (LBD) framework +!! +!! The LBD framework accounts for the effects of diabatic mesoscale fluxes +!! within surface and bottom boundary layers. Unlike the equivalent adiabatic +!! fluxes, which is applied along neutral density surfaces, LBD is purely +!! horizontal. +!! +!! The bottom boundary layer fluxes remain to be implemented, although most +!! of the steps needed to do so have already been added and tested. +!! +!! Boundary lateral diffusion can be applied using one of the three methods: +!! +!! * [Method #1: Bulk layer](@ref section_method1) (default); +!! * [Method #2: Along layer](ref section_method2); +!! * [Method #3: Decomposition on to pressure levels](@ref section_method3). +!! +!! A brief summary of these methods is provided below. +!! +!! \subsection section_method1 Bulk layer approach (Method #1) +!! +!! Apply the lateral boundary diffusive fluxes calculated from a 'bulk model' +!! +!! Step #1: get vertical indices containing the boundary layer depth. These are +!! k_top, k_bot, zeta_top, zeta_bot +!! +!! Step #2: compute bulk averages (thickness weighted). phi_L and phi_R +!! +!! Step #3: compute a diffusive bulk flux +!! \f[ F_{bulk} = -(KHTR \times heff) \times (\phi_R - \phi_L), \f] +!! where heff is the harmonic mean of the boundary layer depth in the left and +!! right columns (\f[ HBL_L \f] and \f[ HBL_R \f], respectively). +!! +!! Step #4: limit the tracer flux so that the donor cell, with positive +!! concentration, cannot go negative. If a tracer can go negative (e.g., +!! temperature at high latitudes) it is unclear what limiter should be used. +!! (TODO: ask Bob and Alistair). +!! +!! Step #5: decompose the bulk flux into individual layers and keep track of +!! the remaining flux. The limiter described above is also applied during +!! this step. +!! +!! \subsection section_method2 Along layer approach (Method #2) +!! +!! \subsection section_method3 Decomposition on to pressure levels (Method #3) +!! +!! To be implemented +!! +!! \subsection section_harmonic_mean Harmonic Mean +!! +!! end module MOM_lateral_boundary_diffusion From 2c6bdf9256e1324b5c4c5eafcb94676e283e06c8 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 20 Nov 2019 13:45:29 -0700 Subject: [PATCH 060/103] Create a separate param for MEKE bottom drag (CDRAG_MEKE) --- src/parameterizations/lateral/MOM_MEKE.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index a009aea1f6..c03764395a 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1197,10 +1197,10 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) units="nondim", default=0.0) ! Nonlocal module parameters - call get_param(param_file, mdl, "CDRAG", CS%cdrag, & + call get_param(param_file, mdl, "CDRAG_MEKE", CS%cdrag, & "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the bottom stress.", units="nondim", & - default=0.003) + default=0.001) call get_param(param_file, mdl, "LAPLACIAN", laplacian, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "BIHARMONIC", biharmonic, default=.false., do_not_log=.true.) From f3dba1609d42e0b58e2dc862911eaf93a38b799c Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 3 Dec 2019 11:06:27 -0800 Subject: [PATCH 061/103] Add new option to avoid negative thicknesses --- src/tracer/MOM_neutral_diffusion.F90 | 32 +++++++++++++++++++++++----- 1 file changed, 27 insertions(+), 5 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 8a048685d6..0ab5b37131 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -43,6 +43,7 @@ module MOM_neutral_diffusion integer :: deg = 2 !< Degree of polynomial used for reconstructions logical :: continuous_reconstruction = .true. !< True if using continuous PPM reconstruction at interfaces logical :: debug = .false. !< If true, write verbose debugging messages + logical :: hard_fail_heff !< Bring down the model if a problem with heff is detected integer :: max_iter !< Maximum number of iterations if refine_position is defined real :: drho_tol !< Convergence criterion representing difference from true neutrality real :: x_tol !< Convergence criterion for how small an update of the position can be @@ -209,6 +210,9 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic "Turns on verbose output for discontinuous neutral "//& "diffusion routines.", & default = .false.) + call get_param(param_file, mdl, "HARD_FAIL_HEFF", CS%hard_fail_heff, & + "Bring down the model if a problem with heff is detected", + default = .true.) endif if (CS%interior_only) then @@ -426,8 +430,9 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & CS%ppoly_coeffs_S(i,j,:,:),CS%stable_cell(i,j,:), & CS%P_i(i+1,j,:,:), h(i+1,j,:), CS%T_i(i+1,j,:,:), CS%S_i(i+1,j,:,:), CS%ppoly_coeffs_T(i+1,j,:,:), & - CS%ppoly_coeffs_S(i+1,j,:,:), CS%stable_cell(i+1,j,:), & - CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:)) + CS%ppoly_coeffs_S(i+1,j,:,:), CS%stable_cell(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:), & + hard_fail_heff = CS%hard_fail_heff) endif endif enddo ; enddo @@ -446,7 +451,8 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) CS%ppoly_coeffs_S(i,j,:,:),CS%stable_cell(i,j,:), & CS%P_i(i,j+1,:,:), h(i,j+1,:), CS%T_i(i,j+1,:,:), CS%S_i(i,j+1,:,:), CS%ppoly_coeffs_T(i,j+1,:,:), & CS%ppoly_coeffs_S(i,j+1,:,:), CS%stable_cell(i,j+1,:), & - CS%vPoL(I,j,:), CS%vPoR(I,j,:), CS%vKoL(I,j,:), CS%vKoR(I,j,:), CS%vhEff(I,j,:)) + CS%vPoL(I,j,:), CS%vPoR(I,j,:), CS%vKoL(I,j,:), CS%vKoR(I,j,:), CS%vhEff(I,j,:), + hard_fail_heff = CS%hard_fail_heff) endif endif enddo ; enddo @@ -1109,7 +1115,7 @@ end function interpolate_for_nondim_position subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, Tl, Sl, ppoly_T_l, ppoly_S_l, stable_l,& Pres_r, hcol_r, Tr, Sr, ppoly_T_r, ppoly_S_r, stable_r,& PoL, PoR, KoL, KoR, hEff, zeta_bot_L, zeta_bot_R, & - k_bot_L, k_bot_R) + k_bot_L, k_bot_R, hard_fail_heff) type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure integer, intent(in) :: nk !< Number of levels @@ -1141,6 +1147,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, integer, optional, intent(in) :: k_bot_L !< k-index for the boundary layer (left) [nondim] integer, optional, intent(in) :: k_bot_R !< k-index for the boundary layer (right) [nondim] + logical, optional, intent(in) :: fail_heff_in !< If true (default) bring down the model if the + !! neutral surfaces ever cross [logical] ! Local variables integer :: ns ! Number of neutral surfaces integer :: k_surface ! Index of neutral surface @@ -1150,6 +1158,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, logical :: searching_right_column ! True if searching for the position of a left interface in the right column logical :: reached_bottom ! True if one of the bottom-most interfaces has been used as the target logical :: search_layer + logical :: fail_heff ! By default, real :: dRho, dRhoTop, dRhoBot, hL, hR real :: z0, pos real :: dRdT_from_top, dRdS_from_top ! Density derivatives at the searched from interface @@ -1171,6 +1180,9 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, reached_bottom = .false. searching_left_column = .false. searching_right_column = .false. + + fail_heff = .true. + if (PRESENT(fail_heff_in)) fail_heff = fail_heff_in if (PRESENT(k_bot_L) .and. PRESENT(k_bot_R) .and. PRESENT(zeta_bot_L) .and. PRESENT(zeta_bot_R)) then k_init_L = k_bot_L; k_init_R = k_bot_R @@ -1305,7 +1317,17 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, hL = (PoL(k_surface) - PoL(k_surface-1))*hcol_l(KoL(k_surface)) hR = (PoR(k_surface) - PoR(k_surface-1))*hcol_r(KoR(k_surface)) if (hL < 0. .or. hR < 0.) then - call MOM_error(FATAL,"Negative thicknesses in neutral diffusion") + if (fail_heff) then + call MOM_error(FATAL,"Negative thicknesses in neutral diffusion") + else + if (searching_left_column) then + PoL(k_surface) = PoL(k_surface-1) + KoL(k_surface) = KoL(k_surface-1) + elseif (searcing_right_column) then + PoR(k_surface) = PoR(k_surface-1) + KoR(k_surface) = KoR(k_surface-1) + endif + endif elseif ( hL + hR == 0. ) then hEff(k_surface-1) = 0. else From 9303e994636995b6a5785022312ca1a20b001628 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 3 Dec 2019 17:26:23 -0700 Subject: [PATCH 062/103] Fix typos and bugs --- src/tracer/MOM_neutral_diffusion.F90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 0ab5b37131..3bffad677e 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -211,7 +211,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic "diffusion routines.", & default = .false.) call get_param(param_file, mdl, "HARD_FAIL_HEFF", CS%hard_fail_heff, & - "Bring down the model if a problem with heff is detected", + "Bring down the model if a problem with heff is detected",& default = .true.) endif @@ -431,7 +431,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) CS%ppoly_coeffs_S(i,j,:,:),CS%stable_cell(i,j,:), & CS%P_i(i+1,j,:,:), h(i+1,j,:), CS%T_i(i+1,j,:,:), CS%S_i(i+1,j,:,:), CS%ppoly_coeffs_T(i+1,j,:,:), & CS%ppoly_coeffs_S(i+1,j,:,:), CS%stable_cell(i+1,j,:), & - CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:), & hard_fail_heff = CS%hard_fail_heff) endif endif @@ -451,7 +451,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) CS%ppoly_coeffs_S(i,j,:,:),CS%stable_cell(i,j,:), & CS%P_i(i,j+1,:,:), h(i,j+1,:), CS%T_i(i,j+1,:,:), CS%S_i(i,j+1,:,:), CS%ppoly_coeffs_T(i,j+1,:,:), & CS%ppoly_coeffs_S(i,j+1,:,:), CS%stable_cell(i,j+1,:), & - CS%vPoL(I,j,:), CS%vPoR(I,j,:), CS%vKoL(I,j,:), CS%vKoR(I,j,:), CS%vhEff(I,j,:), + CS%vPoL(I,j,:), CS%vPoR(I,j,:), CS%vKoL(I,j,:), CS%vKoR(I,j,:), CS%vhEff(I,j,:), & hard_fail_heff = CS%hard_fail_heff) endif endif @@ -1147,8 +1147,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, integer, optional, intent(in) :: k_bot_L !< k-index for the boundary layer (left) [nondim] integer, optional, intent(in) :: k_bot_R !< k-index for the boundary layer (right) [nondim] - logical, optional, intent(in) :: fail_heff_in !< If true (default) bring down the model if the - !! neutral surfaces ever cross [logical] + logical, optional, intent(in) :: hard_fail_heff !< If true (default) bring down the model if the + !! neutral surfaces ever cross [logical] ! Local variables integer :: ns ! Number of neutral surfaces integer :: k_surface ! Index of neutral surface @@ -1158,7 +1158,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, logical :: searching_right_column ! True if searching for the position of a left interface in the right column logical :: reached_bottom ! True if one of the bottom-most interfaces has been used as the target logical :: search_layer - logical :: fail_heff ! By default, + logical :: fail_heff ! By default, real :: dRho, dRhoTop, dRhoBot, hL, hR real :: z0, pos real :: dRdT_from_top, dRdS_from_top ! Density derivatives at the searched from interface @@ -1180,9 +1180,9 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, reached_bottom = .false. searching_left_column = .false. searching_right_column = .false. - + fail_heff = .true. - if (PRESENT(fail_heff_in)) fail_heff = fail_heff_in + if (PRESENT(hard_fail_heff)) fail_heff = hard_fail_heff if (PRESENT(k_bot_L) .and. PRESENT(k_bot_R) .and. PRESENT(zeta_bot_L) .and. PRESENT(zeta_bot_R)) then k_init_L = k_bot_L; k_init_R = k_bot_R @@ -1323,7 +1323,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, if (searching_left_column) then PoL(k_surface) = PoL(k_surface-1) KoL(k_surface) = KoL(k_surface-1) - elseif (searcing_right_column) then + elseif (searching_right_column) then PoR(k_surface) = PoR(k_surface-1) KoR(k_surface) = KoR(k_surface-1) endif From e71a5736ae8a132b67d2ee420ec8b16adcb69461 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 4 Dec 2019 11:25:31 -0700 Subject: [PATCH 063/103] Fix doxygen references --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 54642083bd..07f062d1d2 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -370,7 +370,7 @@ end subroutine boundary_k_range !> Calculate the lateral boundary diffusive fluxes using the layer by layer method. -!! See \ref LBD_method2 +!! See \ref section_method2 subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, & ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) @@ -475,7 +475,7 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, end subroutine fluxes_layer_method !> Apply the lateral boundary diffusive fluxes calculated from a 'bulk model' -!! See \ref LBD_method1 +!! See \ref section_method1 subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, ppoly0_coefs_L, & ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, F_limit) From 02c986a7727df3599f863cccf5ce708462abcfe9 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 4 Dec 2019 15:33:42 -0700 Subject: [PATCH 064/103] Set default value to 0.003 --- src/parameterizations/lateral/MOM_MEKE.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index c03764395a..c1ef01fe47 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1200,7 +1200,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) call get_param(param_file, mdl, "CDRAG_MEKE", CS%cdrag, & "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the bottom stress.", units="nondim", & - default=0.001) + default=0.003) call get_param(param_file, mdl, "LAPLACIAN", laplacian, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "BIHARMONIC", biharmonic, default=.false., do_not_log=.true.) From 97d07bcb4c51f72a2142ecc360b743ab0d11ceec Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 4 Dec 2019 17:25:54 -0700 Subject: [PATCH 065/103] Set the default for CDRAG_MEKE to CDRAG --- src/parameterizations/lateral/MOM_MEKE.F90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index c1ef01fe47..877502929a 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1003,6 +1003,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) real :: L_rescale ! A rescaling factor for length from the internal representation in this ! run to the representation in a restart file. real :: MEKE_restoring_timescale ! The timescale used to nudge MEKE toward its equilibrium value. + real :: cdrag ! The default bottom drag coefficient [nondim]. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed logical :: laplacian, biharmonic, useVarMix, coldStart ! This include declares and sets the variable "version". @@ -1197,10 +1198,14 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) units="nondim", default=0.0) ! Nonlocal module parameters - call get_param(param_file, mdl, "CDRAG_MEKE", CS%cdrag, & + call get_param(param_file, mdl, "CDRAG", cdrag, & "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the bottom stress.", units="nondim", & default=0.003) + call get_param(param_file, mdl, "CDRAG_MEKE", CS%cdrag, & + "CDRAG is the drag coefficient relating the magnitude of "//& + "the velocity field to the bottom stress.", units="nondim", & + default=cdrag) call get_param(param_file, mdl, "LAPLACIAN", laplacian, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "BIHARMONIC", biharmonic, default=.false., do_not_log=.true.) From 20d076b4dc25a84de24c178e24c5f20c01f05af2 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 6 Dec 2019 22:48:11 +0000 Subject: [PATCH 066/103] Modify continuous neutral diffusion to account for boundary layer New options are now passed into the neutral_diffusion continuous to bypass all layers within the bottom boundary. This is done by checking to see whether the calculated positions of the neutral surfaces are within the boundary layer. If so, they are set to the bottom of the BL --- src/tracer/MOM_neutral_diffusion.F90 | 28 ++++++++++++++++++++++------ 1 file changed, 22 insertions(+), 6 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 3bffad677e..49786bb391 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -424,7 +424,8 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) call find_neutral_surface_positions_continuous(G%ke, & CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & CS%Pint(i+1,j,:), CS%Tint(i+1,j,:), CS%Sint(i+1,j,:), CS%dRdT(i+1,j,:), CS%dRdS(i+1,j,:), & - CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:) ) + CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:), & + k_bot(I,j), k_bot(I+1,j), zeta_bot(I,j), zeta_bot(I+1,j)) else call find_neutral_surface_positions_discontinuous(CS, G%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & @@ -441,10 +442,11 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) do J = G%jsc-1, G%jec ; do i = G%isc, G%iec if (G%mask2dCv(i,J) > 0.) then if (CS%continuous_reconstruction) then - call find_neutral_surface_positions_continuous(G%ke, & + call find_neutral_surface_positions_continuous(G%ke, & CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & CS%Pint(i,j+1,:), CS%Tint(i,j+1,:), CS%Sint(i,j+1,:), CS%dRdT(i,j+1,:), CS%dRdS(i,j+1,:), & - CS%vPoL(i,J,:), CS%vPoR(i,J,:), CS%vKoL(i,J,:), CS%vKoR(i,J,:), CS%vhEff(i,J,:) ) + CS%vPoL(i,J,:), CS%vPoR(i,J,:), CS%vKoL(i,J,:), CS%vKoR(i,J,:), CS%vhEff(i,J,:), & + k_bot(i,J), k_bot(i,J+1), zeta_bot(i,J), zeta_bot(i,J+1)) else call find_neutral_surface_positions_discontinuous(CS, G%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & @@ -894,7 +896,7 @@ end function fvlsq_slope !> Returns positions within left/right columns of combined interfaces using continuous reconstructions of T/S subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdSl, Pr, Tr, Sr, & - dRdTr, dRdSr, PoL, PoR, KoL, KoR, hEff) + dRdTr, dRdSr, PoL, PoR, KoL, KoR, hEff, bl_kl, bl_kr, bl_zl, bl_zr) integer, intent(in) :: nk !< Number of levels real, dimension(nk+1), intent(in) :: Pl !< Left-column interface pressure [Pa] real, dimension(nk+1), intent(in) :: Tl !< Left-column interface potential temperature [degC] @@ -913,6 +915,10 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS integer, dimension(2*nk+2), intent(inout) :: KoL !< Index of first left interface above neutral surface integer, dimension(2*nk+2), intent(inout) :: KoR !< Index of first right interface above neutral surface real, dimension(2*nk+1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces [Pa] + integer, optional, intent(in) :: bl_kl !< Layer index of the boundary layer (left) + integer, optional, intent(in) :: bl_kr !< Layer index of the boundary layer (right) + integer, optional, intent(in) :: bl_zl !< Nondimensional position of the boundary layer (left) + integer, optional, intent(in) :: bl_zr !< Nondimensional position of the boundary layer (right) ! Local variables integer :: ns ! Number of neutral surfaces @@ -929,9 +935,19 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS real :: lastP_left, lastP_right ns = 2*nk+2 + kr = 1 ; + kl = 1 ; + lastP_right = 0. + lastP_left = 0. + + if (PRESENT(bl_kl)) kl = bl_kl + if (PRESENT(bl_kr)) kr = bl_kr + if (PRESENT(bl_zl)) lastP_left = bl_zl + if (PRESENT(bl_zr)) lastP_right = bl_zr + ! Initialize variables for the search - kr = 1 ; lastK_right = 1 ; lastP_right = 0. - kl = 1 ; lastK_left = 1 ; lastP_left = 0. + lastK_right = kr + lastK_left = kl reached_bottom = .false. ! Loop over each neutral surface, working from top to bottom From 89eaede6c8ed3e0a63fa17767b522a0453ec849b Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 9 Dec 2019 08:52:24 -0700 Subject: [PATCH 067/103] Delete ocean_model_data_get* from all the caps These calls are not used anywhere and, therefore, they should be deleted to avoid confusion. --- config_src/coupled_driver/ocean_model_MOM.F90 | 81 -------------- config_src/mct_driver/mom_ocean_model_mct.F90 | 100 ----------------- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 101 ------------------ 3 files changed, 282 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index c5d10c7aaf..d7c78dec66 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -76,14 +76,6 @@ module ocean_model_mod public ocean_model_restart public ice_ocn_bnd_type_chksum public ocean_public_type_chksum -public ocean_model_data_get - -!> This interface extracts a named scalar field or array from the ocean surface or public type -interface ocean_model_data_get - module procedure ocean_model_data1D_get - module procedure ocean_model_data2D_get -end interface - !> This type is used for communication with other components via the FMS coupler. !! The element names and types can be changed only with great deliberation, hence @@ -1008,79 +1000,6 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) end subroutine Ocean_stock_pe -!> This subroutine extracts a named 2-D field from the ocean surface or public type -subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) - use MOM_constants, only : CELSIUS_KELVIN_OFFSET - type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the - !! internal ocean state (intent in). - type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly - !! visible ocean surface fields. - character(len=*) , intent(in) :: name !< The name of the field to extract - real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must - !! cover only the computational domain - integer , intent(in) :: isc !< The starting i-index of array2D - integer , intent(in) :: jsc !< The starting j-index of array2D - - integer :: g_isc, g_iec, g_jsc, g_jec,g_isd, g_ied, g_jsd, g_jed, i, j - - if (.not.associated(OS)) return - if (.not.OS%is_ocean_pe) return - -! The problem is %areaT is on MOM domain but Ice_Ocean_Boundary%... is on mpp domain. -! We want to return the MOM data on the mpp (compute) domain -! Get MOM domain extents - call mpp_get_compute_domain(OS%grid%Domain%mpp_domain, g_isc, g_iec, g_jsc, g_jec) - call mpp_get_data_domain (OS%grid%Domain%mpp_domain, g_isd, g_ied, g_jsd, g_jed) - - g_isc = g_isc-g_isd+1 ; g_iec = g_iec-g_isd+1 ; g_jsc = g_jsc-g_jsd+1 ; g_jec = g_jec-g_jsd+1 - - - select case(name) - case('area') - array2D(isc:,jsc:) = OS%US%L_to_m**2*OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) - case('mask') - array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) -!OR same result -! do j=g_jsc,g_jec ; do i=g_isc,g_iec -! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) -! enddo ; enddo - case('t_surf') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_pme') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_runoff') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_calving') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('btfHeat') - array2D(isc:,jsc:) = 0 - case default - call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) - end select - -end subroutine ocean_model_data2D_get - -!> This subroutine extracts a named scalar field from the ocean surface or public type -subroutine ocean_model_data1D_get(OS, Ocean, name, value) - type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the - !! internal ocean state (intent in). - type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly - !! visible ocean surface fields. - character(len=*) , intent(in) :: name !< The name of the field to extract - real , intent(out):: value !< The value of the named field - - if (.not.associated(OS)) return - if (.not.OS%is_ocean_pe) return - - select case(name) - case('c_p') - value = OS%C_p - case default - call MOM_error(FATAL,'get_ocean_grid_data1D: unknown argument name='//name) - end select - -end subroutine ocean_model_data1D_get - !> Write out FMS-format checsums on fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index e6c3556d59..49345e2ab5 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -80,16 +80,8 @@ module MOM_ocean_model_mct public ocean_model_restart public ice_ocn_bnd_type_chksum public ocean_public_type_chksum -public ocean_model_data_get public get_ocean_grid -!> This interface extracts a named scalar field or array from the ocean surface or public type -interface ocean_model_data_get - module procedure ocean_model_data1D_get - module procedure ocean_model_data2D_get -end interface - - !> This type is used for communication with other components via the FMS coupler. !! The element names and types can be changed only with great deliberation, hence !! the persistnce of things like the cutsy element name "avg_kount". @@ -1061,98 +1053,6 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) end subroutine Ocean_stock_pe -!> This subroutine extracts a named 2-D field from the ocean surface or public type -subroutine ocean_model_data2D_get(OS,Ocean, name, array2D,isc,jsc) - use MOM_constants, only : CELSIUS_KELVIN_OFFSET - type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the - !! internal ocean state (intent in). - type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly - !! visible ocean surface fields. - character(len=*) , intent(in) :: name !< The name of the field to extract - real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must - !! cover only the computational domain - integer , intent(in) :: isc !< The starting i-index of array2D - integer , intent(in) :: jsc !< The starting j-index of array2D - - integer :: g_isc, g_iec, g_jsc, g_jec,g_isd, g_ied, g_jsd, g_jed, i, j - - if (.not.associated(OS)) return - if (.not.OS%is_ocean_pe) return - -! The problem is %areaT is on MOM domain but Ice_Ocean_Boundary%... is on mpp domain. -! We want to return the MOM data on the mpp (compute) domain -! Get MOM domain extents - call mpp_get_compute_domain(OS%grid%Domain%mpp_domain, g_isc, g_iec, g_jsc, g_jec) - call mpp_get_data_domain (OS%grid%Domain%mpp_domain, g_isd, g_ied, g_jsd, g_jed) - - g_isc = g_isc-g_isd+1 ; g_iec = g_iec-g_isd+1 ; g_jsc = g_jsc-g_jsd+1 ; g_jec = g_jec-g_jsd+1 - - - select case(name) - case('area') - array2D(isc:,jsc:) = OS%US%L_to_m**2*OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) - case('mask') - array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) -!OR same result -! do j=g_jsc,g_jec ; do i=g_isc,g_iec -! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) -! enddo ; enddo - case('t_surf') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_pme') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_runoff') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_calving') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('btfHeat') - array2D(isc:,jsc:) = 0 - case('tlat') - array2D(isc:,jsc:) = OS%grid%geoLatT(g_isc:g_iec,g_jsc:g_jec) - case('tlon') - array2D(isc:,jsc:) = OS%grid%geoLonT(g_isc:g_iec,g_jsc:g_jec) - case('ulat') - array2D(isc:,jsc:) = OS%grid%geoLatCu(g_isc:g_iec,g_jsc:g_jec) - case('ulon') - array2D(isc:,jsc:) = OS%grid%geoLonCu(g_isc:g_iec,g_jsc:g_jec) - case('vlat') - array2D(isc:,jsc:) = OS%grid%geoLatCv(g_isc:g_iec,g_jsc:g_jec) - case('vlon') - array2D(isc:,jsc:) = OS%grid%geoLonCv(g_isc:g_iec,g_jsc:g_jec) - case('geoLatBu') - array2D(isc:,jsc:) = OS%grid%geoLatBu(g_isc:g_iec,g_jsc:g_jec) - case('geoLonBu') - array2D(isc:,jsc:) = OS%grid%geoLonBu(g_isc:g_iec,g_jsc:g_jec) - case('cos_rot') - array2D(isc:,jsc:) = OS%grid%cos_rot(g_isc:g_iec,g_jsc:g_jec) ! =1 - case('sin_rot') - array2D(isc:,jsc:) = OS%grid%sin_rot(g_isc:g_iec,g_jsc:g_jec) ! =0 - case default - call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) - end select -end subroutine ocean_model_data2D_get - -!> This subroutine extracts a named scalar field from the ocean surface or public type -subroutine ocean_model_data1D_get(OS, Ocean, name, value) - type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the - !! internal ocean state (intent in). - type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly - !! visible ocean surface fields. - character(len=*) , intent(in) :: name !< The name of the field to extract - real , intent(out):: value !< The value of the named field - - if (.not.associated(OS)) return - if (.not.OS%is_ocean_pe) return - - select case(name) - case('c_p') - value = OS%C_p - case default - call MOM_error(FATAL,'get_ocean_grid_data1D: unknown argument name='//name) - end select - -end subroutine ocean_model_data1D_get - !> Write out FMS-format checsums on fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index 6f155e13d6..e0466fc527 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -77,17 +77,9 @@ module MOM_ocean_model_nuopc public ocean_model_restart public ice_ocn_bnd_type_chksum public ocean_public_type_chksum -public ocean_model_data_get public get_ocean_grid public get_eps_omesh -!> This interface extracts a named scalar field or array from the ocean surface or public type -interface ocean_model_data_get - module procedure ocean_model_data1D_get - module procedure ocean_model_data2D_get -end interface - - !> This type is used for communication with other components via the FMS coupler. !! The element names and types can be changed only with great deliberation, hence !! the persistnce of things like the cutsy element name "avg_kount". @@ -1055,99 +1047,6 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) end subroutine Ocean_stock_pe -!> This subroutine extracts a named 2-D field from the ocean surface or public type -subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) - use MOM_constants, only : CELSIUS_KELVIN_OFFSET - type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the - !! internal ocean state (intent in). - type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly - !! visible ocean surface fields. - character(len=*) , intent(in) :: name !< The name of the field to extract - real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must - !! cover only the computational domain - integer , intent(in) :: isc !< The starting i-index of array2D - integer , intent(in) :: jsc !< The starting j-index of array2D - - integer :: g_isc, g_iec, g_jsc, g_jec,g_isd, g_ied, g_jsd, g_jed, i, j - - if (.not.associated(OS)) return - if (.not.OS%is_ocean_pe) return - -! The problem is %areaT is on MOM domain but Ice_Ocean_Boundary%... is on mpp domain. -! We want to return the MOM data on the mpp (compute) domain -! Get MOM domain extents - call mpp_get_compute_domain(OS%grid%Domain%mpp_domain, g_isc, g_iec, g_jsc, g_jec) - call mpp_get_data_domain (OS%grid%Domain%mpp_domain, g_isd, g_ied, g_jsd, g_jed) - - g_isc = g_isc-g_isd+1 ; g_iec = g_iec-g_isd+1 ; g_jsc = g_jsc-g_jsd+1 ; g_jec = g_jec-g_jsd+1 - - - select case(name) - case('area') - array2D(isc:,jsc:) = OS%US%L_to_m**2*OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) - case('mask') - array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) -!OR same result -! do j=g_jsc,g_jec ; do i=g_isc,g_iec -! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) -! enddo ; enddo - case('t_surf') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_pme') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_runoff') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_calving') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('btfHeat') - array2D(isc:,jsc:) = 0 - case('tlat') - array2D(isc:,jsc:) = OS%grid%geoLatT(g_isc:g_iec,g_jsc:g_jec) - case('tlon') - array2D(isc:,jsc:) = OS%grid%geoLonT(g_isc:g_iec,g_jsc:g_jec) - case('ulat') - array2D(isc:,jsc:) = OS%grid%geoLatCu(g_isc:g_iec,g_jsc:g_jec) - case('ulon') - array2D(isc:,jsc:) = OS%grid%geoLonCu(g_isc:g_iec,g_jsc:g_jec) - case('vlat') - array2D(isc:,jsc:) = OS%grid%geoLatCv(g_isc:g_iec,g_jsc:g_jec) - case('vlon') - array2D(isc:,jsc:) = OS%grid%geoLonCv(g_isc:g_iec,g_jsc:g_jec) - case('geoLatBu') - array2D(isc:,jsc:) = OS%grid%geoLatBu(g_isc:g_iec,g_jsc:g_jec) - case('geoLonBu') - array2D(isc:,jsc:) = OS%grid%geoLonBu(g_isc:g_iec,g_jsc:g_jec) - case('cos_rot') - array2D(isc:,jsc:) = OS%grid%cos_rot(g_isc:g_iec,g_jsc:g_jec) ! =1 - case('sin_rot') - array2D(isc:,jsc:) = OS%grid%sin_rot(g_isc:g_iec,g_jsc:g_jec) ! =0 - case default - call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) - end select - -end subroutine ocean_model_data2D_get - -!> This subroutine extracts a named scalar field from the ocean surface or public type -subroutine ocean_model_data1D_get(OS, Ocean, name, value) - type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the - !! internal ocean state (intent in). - type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly - !! visible ocean surface fields. - character(len=*) , intent(in) :: name !< The name of the field to extract - real , intent(out):: value !< The value of the named field - - if (.not.associated(OS)) return - if (.not.OS%is_ocean_pe) return - - select case(name) - case('c_p') - value = OS%C_p - case default - call MOM_error(FATAL,'get_ocean_grid_data1D: unknown argument name='//name) - end select - -end subroutine ocean_model_data1D_get - !> Write out FMS-format checsums on fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) From c50a97891eb383201a925af2f635b6a40ef5eb25 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 9 Dec 2019 18:24:53 +0000 Subject: [PATCH 068/103] Toggle continuous neutral diffusion in interior only The option to limit neutral diffusion to below the boundary layer is now implemented by checking to see if the neutral surface position is within the boundary layer. If so, then put the position of the neutral position at the nondimensional position and layer of the bottom boundary layer. This effectively collapses all 'neutral' surfaces so that layers are only constructed in the ocean interior. --- src/tracer/MOM_neutral_diffusion.F90 | 49 +++++++++++++++++----------- 1 file changed, 30 insertions(+), 19 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 49786bb391..841ab56981 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -158,10 +158,6 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic "That is, the algorithm will exclude the surface and bottom"//& "boundary layers.",default = .false.) - if (CS%continuous_reconstruction .and. CS%interior_only) then - call MOM_error(FATAL,"NDIFF_INTERIOR_ONLY=True only works with discontinuous" //& - "reconstruction.") - endif ! Initialize and configure remapping if (CS%continuous_reconstruction .eqv. .false.) then call get_param(param_file, mdl, "NDIFF_BOUNDARY_EXTRAP", boundary_extrap, & @@ -292,6 +288,9 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) pa_to_H = 1. / GV%H_to_pa + k_top(:,:) = 1 ; k_bot(:,:) = 1 + zeta_top(:,:) = 0. ; zeta_bot(:,:) = 1. + ! check if hbl needs to be extracted if (CS%interior_only) then hbl(:,:) = 0. @@ -425,7 +424,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & CS%Pint(i+1,j,:), CS%Tint(i+1,j,:), CS%Sint(i+1,j,:), CS%dRdT(i+1,j,:), CS%dRdS(i+1,j,:), & CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:), & - k_bot(I,j), k_bot(I+1,j), zeta_bot(I,j), zeta_bot(I+1,j)) + k_bot(I,j), k_bot(I+1,j), 1.-zeta_bot(I,j), 1.-zeta_bot(I+1,j)) else call find_neutral_surface_positions_discontinuous(CS, G%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & @@ -446,7 +445,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & CS%Pint(i,j+1,:), CS%Tint(i,j+1,:), CS%Sint(i,j+1,:), CS%dRdT(i,j+1,:), CS%dRdS(i,j+1,:), & CS%vPoL(i,J,:), CS%vPoR(i,J,:), CS%vKoL(i,J,:), CS%vKoR(i,J,:), CS%vhEff(i,J,:), & - k_bot(i,J), k_bot(i,J+1), zeta_bot(i,J), zeta_bot(i,J+1)) + k_bot(i,J), k_bot(i,J+1), 1.-zeta_bot(i,J), 1.-zeta_bot(i,J+1)) else call find_neutral_surface_positions_discontinuous(CS, G%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & @@ -917,8 +916,8 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS real, dimension(2*nk+1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces [Pa] integer, optional, intent(in) :: bl_kl !< Layer index of the boundary layer (left) integer, optional, intent(in) :: bl_kr !< Layer index of the boundary layer (right) - integer, optional, intent(in) :: bl_zl !< Nondimensional position of the boundary layer (left) - integer, optional, intent(in) :: bl_zr !< Nondimensional position of the boundary layer (right) + real, optional, intent(in) :: bl_zl !< Nondimensional position of the boundary layer (left) + real, optional, intent(in) :: bl_zr !< Nondimensional position of the boundary layer (right) ! Local variables integer :: ns ! Number of neutral surfaces @@ -933,23 +932,22 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS real :: dRho, dRhoTop, dRhoBot, hL, hR integer :: lastK_left, lastK_right real :: lastP_left, lastP_right + logical :: interior_limit ns = 2*nk+2 - kr = 1 ; + + ! Initialize variables for the search + kr = 1 ; kl = 1 ; lastP_right = 0. lastP_left = 0. - - if (PRESENT(bl_kl)) kl = bl_kl - if (PRESENT(bl_kr)) kr = bl_kr - if (PRESENT(bl_zl)) lastP_left = bl_zl - if (PRESENT(bl_zr)) lastP_right = bl_zr - - ! Initialize variables for the search - lastK_right = kr - lastK_left = kl + lastK_right = 1 + lastK_left = 1 reached_bottom = .false. + ! Check to see if we should limit the diffusion to the interior + interior_limit = PRESENT(bl_kl) .and. PRESENT(bl_kr) .and. PRESENT(bl_zr) .and. PRESENT(bl_zl) + ! Loop over each neutral surface, working from top to bottom neutral_surfaces: do k_surface = 1, ns klm1 = max(kl-1, 1) @@ -1068,10 +1066,23 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS else stop 'Else what?' endif + if (interior_limit) then + if (KoL(k_surface)<=bl_kl) then + KoL(k_surface) = bl_kl + if (PoL(k_surface) Date: Tue, 10 Dec 2019 10:16:15 -0700 Subject: [PATCH 069/103] Fix bugs in Leith add new input parameter This PR fixes a few bugs in MOM_hor_visc when using Leith and Modified_Leith.These are: 1) deletes unecessary call to pass_var; 2) changes the j indices to loop over when computing divergence gradient (div_xx_d?) and its magnitude (grad_div_mag_?) A runtime parameter (ADD_LES_VISCOSITY) to control if the viscosity from Smagorinsky and Leith should be added to the background value, rather than taking the maximum value, has also been added. --- .../lateral/MOM_hor_visc.F90 | 48 ++++++++++--------- 1 file changed, 26 insertions(+), 22 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 4208bc1642..d5a14c933e 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -75,6 +75,8 @@ module MOM_hor_visc !! Default is False to maintain answers with legacy experiments !! but should be changed to True for new experiments. logical :: anisotropic !< If true, allow anisotropic component to the viscosity. + logical :: add_LES_viscosity !< "If true, adds the viscosity from Smagorinsky and Leith to + !! the background viscosity instead of taking the maximum. real :: Kh_aniso !< The anisotropic viscosity [L2 T-1 ~> m2 s-1]. logical :: dynamic_aniso !< If true, the anisotropic viscosity is recomputed as a function !! of state. This is set depending on ANISOTROPIC_MODE. @@ -679,8 +681,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif - call pass_var(vort_xy, G%Domain, position=CORNER, complete=.true.) - ! Vorticity gradient do J=js-2,Jeq+1 ; do i=is-1,Ieq+1 DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) @@ -692,23 +692,17 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, vort_xy_dy(I,j) = DX_dyBu * (vort_xy(I,J) * G%IdxCv(i,J) - vort_xy(I,J-1) * G%IdxCv(i,J-1)) enddo ; enddo - call pass_vector(vort_xy_dy, vort_xy_dx, G%Domain) - if (CS%modified_Leith) then ! Divergence do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - div_xx(i,j) = 0.5*((G%dyCu(I,j) * u(I,j,k) * (h(i+1,j,k)+h(i,j,k)) - & - G%dyCu(I-1,j) * u(I-1,j,k) * (h(i-1,j,k)+h(i,j,k)) ) + & - (G%dxCv(i,J) * v(i,J,k) * (h(i,j,k)+h(i,j+1,k)) - & - G%dxCv(i,J-1)*v(i,J-1,k)*(h(i,j,k)+h(i,j-1,k))))*G%IareaT(i,j) / & - (h(i,j,k) + GV%H_subroundoff) + div_xx(i,j) = dudx(i,j) + dvdy(i,j) enddo ; enddo ! Divergence gradient - do j=Jsq,Jeq+1 ; do I=Isq-1,Ieq+1 + do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 div_xx_dx(I,j) = G%IdxCu(I,j)*(div_xx(i+1,j) - div_xx(i,j)) enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=Isq,Ieq+1 + do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 div_xx_dy(i,J) = G%IdyCv(i,J)*(div_xx(i,j+1) - div_xx(i,j)) enddo ; enddo @@ -717,7 +711,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_div_mag_h(i,j) =sqrt((0.5*(div_xx_dx(I,j) + div_xx_dx(I-1,j)))**2 + & (0.5 * (div_xx_dy(i,J) + div_xx_dy(i,J-1)))**2) enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq + !do J=js-1,Jeq ; do I=is-1,Ieq + do j=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+1 grad_div_mag_q(I,J) =sqrt((0.5*(div_xx_dx(I,j) + div_xx_dx(I,j+1)))**2 + & (0.5 * (div_xx_dy(i,J) + div_xx_dy(i+1,J)))**2) enddo ; enddo @@ -727,13 +722,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, do j=Jsq-1,Jeq+2 ; do I=is-2,Ieq+1 div_xx_dx(I,j) = 0.0 enddo ; enddo - do J=js-2,Jeq+1 ; do i=Isq-1,Ieq+2 + do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 div_xx_dy(i,J) = 0.0 enddo ; enddo do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 grad_div_mag_h(i,j) = 0.0 enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 grad_div_mag_q(I,J) = 0.0 enddo ; enddo @@ -802,8 +797,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Determine the Laplacian viscosity at h points, using the ! largest value from several parameterizations. Kh = CS%Kh_bg_xx(i,j) ! Static (pre-computed) background viscosity - if (CS%Smagorinsky_Kh) Kh = max( Kh, CS%Laplac2_const_xx(i,j) * Shear_mag ) - if (CS%Leith_Kh) Kh = max( Kh, CS%Laplac3_const_xx(i,j) * vert_vort_mag*inv_PI3) + if (CS%add_LES_viscosity) then + if (CS%Smagorinsky_Kh) Kh = Kh + CS%Laplac2_const_xx(i,j) * Shear_mag + if (CS%Leith_Kh) Kh = Kh + CS%Laplac3_const_xx(i,j) * vert_vort_mag*inv_PI3 + else + if (CS%Smagorinsky_Kh) Kh = max( Kh, CS%Laplac2_const_xx(i,j) * Shear_mag ) + if (CS%Leith_Kh) Kh = max( Kh, CS%Laplac3_const_xx(i,j) * vert_vort_mag*inv_PI3) + endif ! All viscosity contributions above are subject to resolution scaling if (rescale_Kh) Kh = VarMix%Res_fn_h(i,j) * Kh if (CS%res_scale_MEKE) meke_res_fn = VarMix%Res_fn_h(i,j) @@ -827,7 +827,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if ((CS%id_Kh_h>0) .or. find_FrictWork .or. CS%debug) Kh_h(i,j,k) = Kh if (CS%id_div_xx_h>0) div_xx_h(i,j,k) = div_xx(i,j) -! if (CS%debug) sh_xx_3d(i,j,k) = sh_xx(i,j) str_xx(i,j) = -Kh * sh_xx(i,j) else ! not Laplacian @@ -965,8 +964,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Determine the Laplacian viscosity at q points, using the ! largest value from several parameterizations. Kh = CS%Kh_bg_xy(i,j) ! Static (pre-computed) background viscosity - if (CS%Smagorinsky_Kh) Kh = max( Kh, CS%Laplac2_const_xy(I,J) * Shear_mag ) - if (CS%Leith_Kh) Kh = max( Kh, CS%Laplac3_const_xy(I,J) * vert_vort_mag*inv_PI3) + if (CS%add_LES_viscosity) then + if (CS%Smagorinsky_Kh) Kh = Kh + CS%Laplac2_const_xx(i,j) * Shear_mag + if (CS%Leith_Kh) Kh = Kh + CS%Laplac3_const_xx(i,j) * vert_vort_mag*inv_PI3 + else + if (CS%Smagorinsky_Kh) Kh = max( Kh, CS%Laplac2_const_xy(I,J) * Shear_mag ) + if (CS%Leith_Kh) Kh = max( Kh, CS%Laplac3_const_xy(I,J) * vert_vort_mag*inv_PI3) + endif ! All viscosity contributions above are subject to resolution scaling if (rescale_Kh) Kh = VarMix%Res_fn_q(i,j) * Kh if (CS%res_scale_MEKE) meke_res_fn = VarMix%Res_fn_q(i,j) @@ -993,7 +997,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_Kh_q>0 .or. CS%debug) Kh_q(I,J,k) = Kh if (CS%id_vort_xy_q>0) vort_xy_q(I,J,k) = vort_xy(I,J) -! if (CS%debug) sh_xy_3d(I,J,k) = sh_xy(I,J) str_xy(I,J) = -Kh * sh_xy(I,J) else ! not Laplacian @@ -1294,8 +1297,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%Laplacian) then call hchksum(Kh_h, "Kh_h", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) call Bchksum(Kh_q, "Kh_q", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) -! call Bchksum(sh_xy_3d, "shear_xy", G%HI, haloshift=0, scale=US%s_to_T) -! call hchksum(sh_xx_3d, "shear_xx", G%HI, haloshift=0, scale=US%s_to_T) endif if (CS%biharmonic) call hchksum(Ah_h, "Ah_h", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) if (CS%biharmonic) call Bchksum(Ah_q, "Ah_q", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) @@ -1504,6 +1505,9 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) call get_param(param_file, mdl, "ANISOTROPIC_VISCOSITY", CS%anisotropic, & "If true, allow anistropic viscosity in the Laplacian "//& "horizontal viscosity.", default=.false.) + call get_param(param_file, mdl, "ADD_LES_VISCOSITY", CS%add_LES_viscosity, & + "If true, adds the viscosity from Smagorinsky and Leith to the "//& + "background viscosity instead of taking the maximum.", default=.false.) endif if (CS%anisotropic .or. get_all) then call get_param(param_file, mdl, "KH_ANISO", CS%Kh_aniso, & From 78bb4c14c0f6632ed9c21eae6c27da83a74de439 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 11 Dec 2019 08:55:57 -0700 Subject: [PATCH 070/103] Delete quotes from doxygen comment --- src/parameterizations/lateral/MOM_hor_visc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index d5a14c933e..f104353c1f 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -75,7 +75,7 @@ module MOM_hor_visc !! Default is False to maintain answers with legacy experiments !! but should be changed to True for new experiments. logical :: anisotropic !< If true, allow anisotropic component to the viscosity. - logical :: add_LES_viscosity !< "If true, adds the viscosity from Smagorinsky and Leith to + logical :: add_LES_viscosity!< If true, adds the viscosity from Smagorinsky and Leith to !! the background viscosity instead of taking the maximum. real :: Kh_aniso !< The anisotropic viscosity [L2 T-1 ~> m2 s-1]. logical :: dynamic_aniso !< If true, the anisotropic viscosity is recomputed as a function From e53814498bd12a5da30023b79734b6aed306df5e Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 11 Dec 2019 17:17:33 -0700 Subject: [PATCH 071/103] remove duplicate fld_list_add calls --- config_src/nuopc_driver/mom_cap.F90 | 5 ----- 1 file changed, 5 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 5977189476..219245e473 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -763,11 +763,6 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) end if if (cesm_coupled) then - !TODO: check if still needed - if (len_trim(scalar_field_name) > 0) then - call fld_list_add(fldsToOcn_num, fldsToOcn, trim(scalar_field_name), "will_provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, trim(scalar_field_name), "will_provide") - endif !call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_lamult" , "will provide") !call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_ustokes" , "will provide") !call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_vstokes" , "will provide") From a12abd6dbb88d0e85e46a285ee31d737f0cba728 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 6 Jan 2020 12:13:13 -0700 Subject: [PATCH 072/103] Revert "Merge pull request #133 from gustavo-marques/clean_caps" This reverts commit 3d17e0390ed355497b1b74e8ef24a32847404c17, reversing changes made to e53814498bd12a5da30023b79734b6aed306df5e. --- config_src/coupled_driver/ocean_model_MOM.F90 | 81 ++++++++++++++ config_src/mct_driver/mom_ocean_model_mct.F90 | 100 +++++++++++++++++ .../nuopc_driver/mom_ocean_model_nuopc.F90 | 101 ++++++++++++++++++ 3 files changed, 282 insertions(+) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index d7c78dec66..c5d10c7aaf 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -76,6 +76,14 @@ module ocean_model_mod public ocean_model_restart public ice_ocn_bnd_type_chksum public ocean_public_type_chksum +public ocean_model_data_get + +!> This interface extracts a named scalar field or array from the ocean surface or public type +interface ocean_model_data_get + module procedure ocean_model_data1D_get + module procedure ocean_model_data2D_get +end interface + !> This type is used for communication with other components via the FMS coupler. !! The element names and types can be changed only with great deliberation, hence @@ -1000,6 +1008,79 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) end subroutine Ocean_stock_pe +!> This subroutine extracts a named 2-D field from the ocean surface or public type +subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) + use MOM_constants, only : CELSIUS_KELVIN_OFFSET + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (intent in). + type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly + !! visible ocean surface fields. + character(len=*) , intent(in) :: name !< The name of the field to extract + real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must + !! cover only the computational domain + integer , intent(in) :: isc !< The starting i-index of array2D + integer , intent(in) :: jsc !< The starting j-index of array2D + + integer :: g_isc, g_iec, g_jsc, g_jec,g_isd, g_ied, g_jsd, g_jed, i, j + + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + +! The problem is %areaT is on MOM domain but Ice_Ocean_Boundary%... is on mpp domain. +! We want to return the MOM data on the mpp (compute) domain +! Get MOM domain extents + call mpp_get_compute_domain(OS%grid%Domain%mpp_domain, g_isc, g_iec, g_jsc, g_jec) + call mpp_get_data_domain (OS%grid%Domain%mpp_domain, g_isd, g_ied, g_jsd, g_jed) + + g_isc = g_isc-g_isd+1 ; g_iec = g_iec-g_isd+1 ; g_jsc = g_jsc-g_jsd+1 ; g_jec = g_jec-g_jsd+1 + + + select case(name) + case('area') + array2D(isc:,jsc:) = OS%US%L_to_m**2*OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) + case('mask') + array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) +!OR same result +! do j=g_jsc,g_jec ; do i=g_isc,g_iec +! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) +! enddo ; enddo + case('t_surf') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_pme') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_runoff') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_calving') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('btfHeat') + array2D(isc:,jsc:) = 0 + case default + call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) + end select + +end subroutine ocean_model_data2D_get + +!> This subroutine extracts a named scalar field from the ocean surface or public type +subroutine ocean_model_data1D_get(OS, Ocean, name, value) + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (intent in). + type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly + !! visible ocean surface fields. + character(len=*) , intent(in) :: name !< The name of the field to extract + real , intent(out):: value !< The value of the named field + + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + + select case(name) + case('c_p') + value = OS%C_p + case default + call MOM_error(FATAL,'get_ocean_grid_data1D: unknown argument name='//name) + end select + +end subroutine ocean_model_data1D_get + !> Write out FMS-format checsums on fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index 49345e2ab5..e6c3556d59 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -80,8 +80,16 @@ module MOM_ocean_model_mct public ocean_model_restart public ice_ocn_bnd_type_chksum public ocean_public_type_chksum +public ocean_model_data_get public get_ocean_grid +!> This interface extracts a named scalar field or array from the ocean surface or public type +interface ocean_model_data_get + module procedure ocean_model_data1D_get + module procedure ocean_model_data2D_get +end interface + + !> This type is used for communication with other components via the FMS coupler. !! The element names and types can be changed only with great deliberation, hence !! the persistnce of things like the cutsy element name "avg_kount". @@ -1053,6 +1061,98 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) end subroutine Ocean_stock_pe +!> This subroutine extracts a named 2-D field from the ocean surface or public type +subroutine ocean_model_data2D_get(OS,Ocean, name, array2D,isc,jsc) + use MOM_constants, only : CELSIUS_KELVIN_OFFSET + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (intent in). + type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly + !! visible ocean surface fields. + character(len=*) , intent(in) :: name !< The name of the field to extract + real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must + !! cover only the computational domain + integer , intent(in) :: isc !< The starting i-index of array2D + integer , intent(in) :: jsc !< The starting j-index of array2D + + integer :: g_isc, g_iec, g_jsc, g_jec,g_isd, g_ied, g_jsd, g_jed, i, j + + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + +! The problem is %areaT is on MOM domain but Ice_Ocean_Boundary%... is on mpp domain. +! We want to return the MOM data on the mpp (compute) domain +! Get MOM domain extents + call mpp_get_compute_domain(OS%grid%Domain%mpp_domain, g_isc, g_iec, g_jsc, g_jec) + call mpp_get_data_domain (OS%grid%Domain%mpp_domain, g_isd, g_ied, g_jsd, g_jed) + + g_isc = g_isc-g_isd+1 ; g_iec = g_iec-g_isd+1 ; g_jsc = g_jsc-g_jsd+1 ; g_jec = g_jec-g_jsd+1 + + + select case(name) + case('area') + array2D(isc:,jsc:) = OS%US%L_to_m**2*OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) + case('mask') + array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) +!OR same result +! do j=g_jsc,g_jec ; do i=g_isc,g_iec +! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) +! enddo ; enddo + case('t_surf') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_pme') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_runoff') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_calving') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('btfHeat') + array2D(isc:,jsc:) = 0 + case('tlat') + array2D(isc:,jsc:) = OS%grid%geoLatT(g_isc:g_iec,g_jsc:g_jec) + case('tlon') + array2D(isc:,jsc:) = OS%grid%geoLonT(g_isc:g_iec,g_jsc:g_jec) + case('ulat') + array2D(isc:,jsc:) = OS%grid%geoLatCu(g_isc:g_iec,g_jsc:g_jec) + case('ulon') + array2D(isc:,jsc:) = OS%grid%geoLonCu(g_isc:g_iec,g_jsc:g_jec) + case('vlat') + array2D(isc:,jsc:) = OS%grid%geoLatCv(g_isc:g_iec,g_jsc:g_jec) + case('vlon') + array2D(isc:,jsc:) = OS%grid%geoLonCv(g_isc:g_iec,g_jsc:g_jec) + case('geoLatBu') + array2D(isc:,jsc:) = OS%grid%geoLatBu(g_isc:g_iec,g_jsc:g_jec) + case('geoLonBu') + array2D(isc:,jsc:) = OS%grid%geoLonBu(g_isc:g_iec,g_jsc:g_jec) + case('cos_rot') + array2D(isc:,jsc:) = OS%grid%cos_rot(g_isc:g_iec,g_jsc:g_jec) ! =1 + case('sin_rot') + array2D(isc:,jsc:) = OS%grid%sin_rot(g_isc:g_iec,g_jsc:g_jec) ! =0 + case default + call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) + end select +end subroutine ocean_model_data2D_get + +!> This subroutine extracts a named scalar field from the ocean surface or public type +subroutine ocean_model_data1D_get(OS, Ocean, name, value) + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (intent in). + type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly + !! visible ocean surface fields. + character(len=*) , intent(in) :: name !< The name of the field to extract + real , intent(out):: value !< The value of the named field + + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + + select case(name) + case('c_p') + value = OS%C_p + case default + call MOM_error(FATAL,'get_ocean_grid_data1D: unknown argument name='//name) + end select + +end subroutine ocean_model_data1D_get + !> Write out FMS-format checsums on fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index e0466fc527..6f155e13d6 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -77,9 +77,17 @@ module MOM_ocean_model_nuopc public ocean_model_restart public ice_ocn_bnd_type_chksum public ocean_public_type_chksum +public ocean_model_data_get public get_ocean_grid public get_eps_omesh +!> This interface extracts a named scalar field or array from the ocean surface or public type +interface ocean_model_data_get + module procedure ocean_model_data1D_get + module procedure ocean_model_data2D_get +end interface + + !> This type is used for communication with other components via the FMS coupler. !! The element names and types can be changed only with great deliberation, hence !! the persistnce of things like the cutsy element name "avg_kount". @@ -1047,6 +1055,99 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) end subroutine Ocean_stock_pe +!> This subroutine extracts a named 2-D field from the ocean surface or public type +subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) + use MOM_constants, only : CELSIUS_KELVIN_OFFSET + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (intent in). + type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly + !! visible ocean surface fields. + character(len=*) , intent(in) :: name !< The name of the field to extract + real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must + !! cover only the computational domain + integer , intent(in) :: isc !< The starting i-index of array2D + integer , intent(in) :: jsc !< The starting j-index of array2D + + integer :: g_isc, g_iec, g_jsc, g_jec,g_isd, g_ied, g_jsd, g_jed, i, j + + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + +! The problem is %areaT is on MOM domain but Ice_Ocean_Boundary%... is on mpp domain. +! We want to return the MOM data on the mpp (compute) domain +! Get MOM domain extents + call mpp_get_compute_domain(OS%grid%Domain%mpp_domain, g_isc, g_iec, g_jsc, g_jec) + call mpp_get_data_domain (OS%grid%Domain%mpp_domain, g_isd, g_ied, g_jsd, g_jed) + + g_isc = g_isc-g_isd+1 ; g_iec = g_iec-g_isd+1 ; g_jsc = g_jsc-g_jsd+1 ; g_jec = g_jec-g_jsd+1 + + + select case(name) + case('area') + array2D(isc:,jsc:) = OS%US%L_to_m**2*OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) + case('mask') + array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) +!OR same result +! do j=g_jsc,g_jec ; do i=g_isc,g_iec +! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) +! enddo ; enddo + case('t_surf') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_pme') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_runoff') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_calving') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('btfHeat') + array2D(isc:,jsc:) = 0 + case('tlat') + array2D(isc:,jsc:) = OS%grid%geoLatT(g_isc:g_iec,g_jsc:g_jec) + case('tlon') + array2D(isc:,jsc:) = OS%grid%geoLonT(g_isc:g_iec,g_jsc:g_jec) + case('ulat') + array2D(isc:,jsc:) = OS%grid%geoLatCu(g_isc:g_iec,g_jsc:g_jec) + case('ulon') + array2D(isc:,jsc:) = OS%grid%geoLonCu(g_isc:g_iec,g_jsc:g_jec) + case('vlat') + array2D(isc:,jsc:) = OS%grid%geoLatCv(g_isc:g_iec,g_jsc:g_jec) + case('vlon') + array2D(isc:,jsc:) = OS%grid%geoLonCv(g_isc:g_iec,g_jsc:g_jec) + case('geoLatBu') + array2D(isc:,jsc:) = OS%grid%geoLatBu(g_isc:g_iec,g_jsc:g_jec) + case('geoLonBu') + array2D(isc:,jsc:) = OS%grid%geoLonBu(g_isc:g_iec,g_jsc:g_jec) + case('cos_rot') + array2D(isc:,jsc:) = OS%grid%cos_rot(g_isc:g_iec,g_jsc:g_jec) ! =1 + case('sin_rot') + array2D(isc:,jsc:) = OS%grid%sin_rot(g_isc:g_iec,g_jsc:g_jec) ! =0 + case default + call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) + end select + +end subroutine ocean_model_data2D_get + +!> This subroutine extracts a named scalar field from the ocean surface or public type +subroutine ocean_model_data1D_get(OS, Ocean, name, value) + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (intent in). + type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly + !! visible ocean surface fields. + character(len=*) , intent(in) :: name !< The name of the field to extract + real , intent(out):: value !< The value of the named field + + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + + select case(name) + case('c_p') + value = OS%C_p + case default + call MOM_error(FATAL,'get_ocean_grid_data1D: unknown argument name='//name) + end select + +end subroutine ocean_model_data1D_get + !> Write out FMS-format checsums on fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) From f7debedda91f13de7218a9283da8e990df091b93 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 6 Jan 2020 12:22:56 -0700 Subject: [PATCH 073/103] Delete ocean_model_data_get from MCT and NUOPC caps --- config_src/mct_driver/mom_ocean_model_mct.F90 | 100 ----------------- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 101 ------------------ 2 files changed, 201 deletions(-) diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index e6c3556d59..49345e2ab5 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -80,16 +80,8 @@ module MOM_ocean_model_mct public ocean_model_restart public ice_ocn_bnd_type_chksum public ocean_public_type_chksum -public ocean_model_data_get public get_ocean_grid -!> This interface extracts a named scalar field or array from the ocean surface or public type -interface ocean_model_data_get - module procedure ocean_model_data1D_get - module procedure ocean_model_data2D_get -end interface - - !> This type is used for communication with other components via the FMS coupler. !! The element names and types can be changed only with great deliberation, hence !! the persistnce of things like the cutsy element name "avg_kount". @@ -1061,98 +1053,6 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) end subroutine Ocean_stock_pe -!> This subroutine extracts a named 2-D field from the ocean surface or public type -subroutine ocean_model_data2D_get(OS,Ocean, name, array2D,isc,jsc) - use MOM_constants, only : CELSIUS_KELVIN_OFFSET - type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the - !! internal ocean state (intent in). - type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly - !! visible ocean surface fields. - character(len=*) , intent(in) :: name !< The name of the field to extract - real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must - !! cover only the computational domain - integer , intent(in) :: isc !< The starting i-index of array2D - integer , intent(in) :: jsc !< The starting j-index of array2D - - integer :: g_isc, g_iec, g_jsc, g_jec,g_isd, g_ied, g_jsd, g_jed, i, j - - if (.not.associated(OS)) return - if (.not.OS%is_ocean_pe) return - -! The problem is %areaT is on MOM domain but Ice_Ocean_Boundary%... is on mpp domain. -! We want to return the MOM data on the mpp (compute) domain -! Get MOM domain extents - call mpp_get_compute_domain(OS%grid%Domain%mpp_domain, g_isc, g_iec, g_jsc, g_jec) - call mpp_get_data_domain (OS%grid%Domain%mpp_domain, g_isd, g_ied, g_jsd, g_jed) - - g_isc = g_isc-g_isd+1 ; g_iec = g_iec-g_isd+1 ; g_jsc = g_jsc-g_jsd+1 ; g_jec = g_jec-g_jsd+1 - - - select case(name) - case('area') - array2D(isc:,jsc:) = OS%US%L_to_m**2*OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) - case('mask') - array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) -!OR same result -! do j=g_jsc,g_jec ; do i=g_isc,g_iec -! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) -! enddo ; enddo - case('t_surf') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_pme') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_runoff') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_calving') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('btfHeat') - array2D(isc:,jsc:) = 0 - case('tlat') - array2D(isc:,jsc:) = OS%grid%geoLatT(g_isc:g_iec,g_jsc:g_jec) - case('tlon') - array2D(isc:,jsc:) = OS%grid%geoLonT(g_isc:g_iec,g_jsc:g_jec) - case('ulat') - array2D(isc:,jsc:) = OS%grid%geoLatCu(g_isc:g_iec,g_jsc:g_jec) - case('ulon') - array2D(isc:,jsc:) = OS%grid%geoLonCu(g_isc:g_iec,g_jsc:g_jec) - case('vlat') - array2D(isc:,jsc:) = OS%grid%geoLatCv(g_isc:g_iec,g_jsc:g_jec) - case('vlon') - array2D(isc:,jsc:) = OS%grid%geoLonCv(g_isc:g_iec,g_jsc:g_jec) - case('geoLatBu') - array2D(isc:,jsc:) = OS%grid%geoLatBu(g_isc:g_iec,g_jsc:g_jec) - case('geoLonBu') - array2D(isc:,jsc:) = OS%grid%geoLonBu(g_isc:g_iec,g_jsc:g_jec) - case('cos_rot') - array2D(isc:,jsc:) = OS%grid%cos_rot(g_isc:g_iec,g_jsc:g_jec) ! =1 - case('sin_rot') - array2D(isc:,jsc:) = OS%grid%sin_rot(g_isc:g_iec,g_jsc:g_jec) ! =0 - case default - call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) - end select -end subroutine ocean_model_data2D_get - -!> This subroutine extracts a named scalar field from the ocean surface or public type -subroutine ocean_model_data1D_get(OS, Ocean, name, value) - type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the - !! internal ocean state (intent in). - type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly - !! visible ocean surface fields. - character(len=*) , intent(in) :: name !< The name of the field to extract - real , intent(out):: value !< The value of the named field - - if (.not.associated(OS)) return - if (.not.OS%is_ocean_pe) return - - select case(name) - case('c_p') - value = OS%C_p - case default - call MOM_error(FATAL,'get_ocean_grid_data1D: unknown argument name='//name) - end select - -end subroutine ocean_model_data1D_get - !> Write out FMS-format checsums on fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index 6f155e13d6..e0466fc527 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -77,17 +77,9 @@ module MOM_ocean_model_nuopc public ocean_model_restart public ice_ocn_bnd_type_chksum public ocean_public_type_chksum -public ocean_model_data_get public get_ocean_grid public get_eps_omesh -!> This interface extracts a named scalar field or array from the ocean surface or public type -interface ocean_model_data_get - module procedure ocean_model_data1D_get - module procedure ocean_model_data2D_get -end interface - - !> This type is used for communication with other components via the FMS coupler. !! The element names and types can be changed only with great deliberation, hence !! the persistnce of things like the cutsy element name "avg_kount". @@ -1055,99 +1047,6 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) end subroutine Ocean_stock_pe -!> This subroutine extracts a named 2-D field from the ocean surface or public type -subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) - use MOM_constants, only : CELSIUS_KELVIN_OFFSET - type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the - !! internal ocean state (intent in). - type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly - !! visible ocean surface fields. - character(len=*) , intent(in) :: name !< The name of the field to extract - real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must - !! cover only the computational domain - integer , intent(in) :: isc !< The starting i-index of array2D - integer , intent(in) :: jsc !< The starting j-index of array2D - - integer :: g_isc, g_iec, g_jsc, g_jec,g_isd, g_ied, g_jsd, g_jed, i, j - - if (.not.associated(OS)) return - if (.not.OS%is_ocean_pe) return - -! The problem is %areaT is on MOM domain but Ice_Ocean_Boundary%... is on mpp domain. -! We want to return the MOM data on the mpp (compute) domain -! Get MOM domain extents - call mpp_get_compute_domain(OS%grid%Domain%mpp_domain, g_isc, g_iec, g_jsc, g_jec) - call mpp_get_data_domain (OS%grid%Domain%mpp_domain, g_isd, g_ied, g_jsd, g_jed) - - g_isc = g_isc-g_isd+1 ; g_iec = g_iec-g_isd+1 ; g_jsc = g_jsc-g_jsd+1 ; g_jec = g_jec-g_jsd+1 - - - select case(name) - case('area') - array2D(isc:,jsc:) = OS%US%L_to_m**2*OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) - case('mask') - array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) -!OR same result -! do j=g_jsc,g_jec ; do i=g_isc,g_iec -! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) -! enddo ; enddo - case('t_surf') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_pme') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_runoff') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('t_calving') - array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET - case('btfHeat') - array2D(isc:,jsc:) = 0 - case('tlat') - array2D(isc:,jsc:) = OS%grid%geoLatT(g_isc:g_iec,g_jsc:g_jec) - case('tlon') - array2D(isc:,jsc:) = OS%grid%geoLonT(g_isc:g_iec,g_jsc:g_jec) - case('ulat') - array2D(isc:,jsc:) = OS%grid%geoLatCu(g_isc:g_iec,g_jsc:g_jec) - case('ulon') - array2D(isc:,jsc:) = OS%grid%geoLonCu(g_isc:g_iec,g_jsc:g_jec) - case('vlat') - array2D(isc:,jsc:) = OS%grid%geoLatCv(g_isc:g_iec,g_jsc:g_jec) - case('vlon') - array2D(isc:,jsc:) = OS%grid%geoLonCv(g_isc:g_iec,g_jsc:g_jec) - case('geoLatBu') - array2D(isc:,jsc:) = OS%grid%geoLatBu(g_isc:g_iec,g_jsc:g_jec) - case('geoLonBu') - array2D(isc:,jsc:) = OS%grid%geoLonBu(g_isc:g_iec,g_jsc:g_jec) - case('cos_rot') - array2D(isc:,jsc:) = OS%grid%cos_rot(g_isc:g_iec,g_jsc:g_jec) ! =1 - case('sin_rot') - array2D(isc:,jsc:) = OS%grid%sin_rot(g_isc:g_iec,g_jsc:g_jec) ! =0 - case default - call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) - end select - -end subroutine ocean_model_data2D_get - -!> This subroutine extracts a named scalar field from the ocean surface or public type -subroutine ocean_model_data1D_get(OS, Ocean, name, value) - type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the - !! internal ocean state (intent in). - type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly - !! visible ocean surface fields. - character(len=*) , intent(in) :: name !< The name of the field to extract - real , intent(out):: value !< The value of the named field - - if (.not.associated(OS)) return - if (.not.OS%is_ocean_pe) return - - select case(name) - case('c_p') - value = OS%C_p - case default - call MOM_error(FATAL,'get_ocean_grid_data1D: unknown argument name='//name) - end select - -end subroutine ocean_model_data1D_get - !> Write out FMS-format checsums on fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) From e2bafc51c93837fed15dd26e79953be3f1275761 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 9 Jan 2020 14:07:22 -0700 Subject: [PATCH 074/103] fix omp directives in MOM_thickness_diffuse --- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 6dca8648b3..7a8e8da126 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -201,7 +201,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp !$OMP parallel default(none) shared(is,ie,js,je,Khth_Loc_u,CS,use_VarMix,VarMix, & !$OMP MEKE,Resoln_scaled,KH_u,G,use_QG_Leith,use_Visbeck,& !$OMP KH_u_CFL,nz,Khth_Loc,KH_v,KH_v_CFL,int_slope_u, & -!$OMP int_slope_v,khth_use_ebt_struct) +!$OMP int_slope_v,khth_use_ebt_struct, Depth_scaled, & +!$OMP Khth_loc_v) !$OMP do do j=js,je; do I=is-1,ie Khth_loc_u(I,j) = CS%Khth From 4fe019156dec13b9f652b8a8732ed37a221e1371 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 9 Jan 2020 16:55:35 -0700 Subject: [PATCH 075/103] Compute tracer tendency due to lateral diffusion This commit adds the option to compute the tracer tendency due to lateral boundary diffusion. Three new diagnostics have been added: 1) Lateral diffusion tracer content tendency (*_lbd_xycont_tendency) 2) Depth integrated lateral diffusion tracer content (*_lbdxy_cont_tendency_2d) 3) Lateral diffusion tracer concentration tendency (*_lbdxy_conc_tendency) --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 40 ++++++++++++++++++ src/tracer/MOM_tracer_registry.F90 | 42 +++++++++++++++---- 2 files changed, 73 insertions(+), 9 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 07f062d1d2..6485d16c59 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -142,6 +142,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real, dimension(SZI_(G),SZJB_(G)) :: vFlx_bulk !< Total calculated bulk-layer v-flux for the tracer real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d !< Layer summed u-flux transport real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d !< Layer summed v-flux transport + real, dimension(SZI_(G),SZJ_(G),G%ke) :: tendency ! tendency array for diagn + real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d ! depth integrated content tendency for diagn type(tracer_type), pointer :: Tracer => NULL() !< Pointer to the current tracer integer :: remap_method !< Reconstruction method integer :: i,j,k,m !< indices to loop over @@ -156,6 +158,12 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) do m = 1,Reg%ntr tracer => Reg%tr(m) + + ! for diagnostics + if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0) then + tendency(:,:,:) = 0.0 + endif + do j = G%jsc-1, G%jec+1 ! Interpolate state to interface do i = G%isc-1, G%iec+1 @@ -224,6 +232,11 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) if (G%mask2dT(i,j)>0.) then tracer%t(i,j,k) = tracer%t(i,j,k) + (( (uFlx(I-1,j,k)-uFlx(I,j,k)) ) + ( (vFlx(i,J-1,k)-vFlx(i,J,k) ) ))* & (G%IareaT(i,j)/( h(i,j,k) + GV%H_subroundoff)) + + if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0 ) then + tendency(i,j,k) = (( (uFlx(I-1,j,k)-uFlx(I,j,k)) ) + ( (vFlx(i,J-1,k)-vFlx(i,J,k) ) )) * G%IareaT(i,j) * Idt + endif + endif enddo ; enddo ; enddo @@ -245,6 +258,33 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) enddo; enddo; enddo call post_data(tracer%id_lbd_dfy_2d, vwork_2d, CS%diag) endif + + ! post tendency of tracer content + if (tracer%id_lbdxy_cont > 0) then + call post_data(tracer%id_lbdxy_cont, tendency(:,:,:), CS%diag) + endif + + ! post depth summed tendency for tracer content + if (tracer%id_lbdxy_cont_2d > 0) then + tendency_2d(:,:) = 0. + do j = G%jsc,G%jec ; do i = G%isc,G%iec + do k = 1, GV%ke + tendency_2d(i,j) = tendency_2d(i,j) + tendency(i,j,k) + enddo + enddo ; enddo + call post_data(tracer%id_lbdxy_cont_2d, tendency_2d(:,:), CS%diag) + endif + + ! post tendency of tracer concentration; this step must be + ! done after posting tracer content tendency, since we alter + ! the tendency array. + if (tracer%id_lbdxy_conc > 0) then + do k = 1, GV%ke ; do j = G%jsc,G%jec ; do i = G%isc,G%iec + tendency(i,j,k) = tendency(i,j,k) / ( h(i,j,k) + GV%H_subroundoff ) + enddo ; enddo ; enddo + call post_data(tracer%id_lbdxy_conc, tendency, CS%diag) + endif + enddo end subroutine lateral_boundary_diffusion diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index cb3e7d13af..9229074099 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -127,6 +127,7 @@ module MOM_tracer_registry integer :: id_adx_2d = -1, id_ady_2d = -1, id_dfx_2d = -1, id_dfy_2d = -1 integer :: id_adv_xy = -1, id_adv_xy_2d = -1 integer :: id_dfxy_cont = -1, id_dfxy_cont_2d = -1, id_dfxy_conc = -1 + integer :: id_lbdxy_cont = -1, id_lbdxy_cont_2d = -1, id_lbdxy_conc = -1 integer :: id_remap_conc = -1, id_remap_cont = -1, id_remap_cont_2d = -1 integer :: id_tendency = -1, id_trxh_tendency = -1, id_trxh_tendency_2d = -1 integer :: id_tr_vardec = -1 @@ -532,37 +533,60 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) enddo ; enddo ; enddo endif - ! Lateral diffusion convergence tendencies + ! Neutral/Lateral diffusion convergence tendencies if (Tr%diag_form == 1) then Tr%id_dfxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency', & - diag%axesTL, Time, "Lateral or neutral diffusion tracer content tendency for "//trim(shortnm), & + diag%axesTL, Time, "Neutral diffusion tracer content tendency for "//trim(shortnm), & conv_units, conversion=Tr%conv_scale*US%s_to_T, x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) Tr%id_dfxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency_2d', & - diag%axesT1, Time, "Depth integrated lateral or neutral diffusion tracer concentration "//& + diag%axesT1, Time, "Depth integrated neutral diffusion tracer content "//& + "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & + x_cell_method='sum', y_cell_method= 'sum') + + Tr%id_lbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency', & + diag%axesTL, Time, "Lateral diffusion tracer content tendency for "//trim(shortnm), & + conv_units, conversion=Tr%conv_scale*US%s_to_T, x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) + + Tr%id_lbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency_2d', & + diag%axesT1, Time, "Depth integrated lateral diffusion tracer content "//& "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & x_cell_method='sum', y_cell_method= 'sum') else cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//& ' expressed as '//trim(lowercase(flux_longname))//& - ' content due to parameterized mesoscale diffusion' + ' content due to parameterized mesoscale neutral diffusion' Tr%id_dfxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency', & - diag%axesTL, Time, "Lateral or neutral diffusion tracer concentration tendency for "//trim(shortnm), & + diag%axesTL, Time, "Neutral diffusion tracer content tendency for "//trim(shortnm), & conv_units, conversion=Tr%conv_scale*US%s_to_T, cmor_field_name = trim(Tr%cmor_tendprefix)//'pmdiff', & cmor_long_name = trim(cmor_var_lname), cmor_standard_name = trim(cmor_long_std(cmor_var_lname)), & x_cell_method = 'sum', y_cell_method = 'sum', v_extensive = .true.) cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//' expressed as '//& - trim(lowercase(flux_longname))//' content due to parameterized mesoscale diffusion' + trim(lowercase(flux_longname))//' content due to parameterized mesoscale neutral diffusion' Tr%id_dfxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency_2d', & - diag%axesT1, Time, "Depth integrated lateral or neutral diffusion tracer "//& - "concentration tendency for "//trim(shortnm), conv_units, & + diag%axesT1, Time, "Depth integrated neutral diffusion tracer "//& + "content tendency for "//trim(shortnm), conv_units, & conversion=Tr%conv_scale*US%s_to_T, cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff_2d', & cmor_long_name=trim(cmor_var_lname), cmor_standard_name=trim(cmor_long_std(cmor_var_lname)), & x_cell_method='sum', y_cell_method='sum') + + Tr%id_lbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency', & + diag%axesTL, Time, "Lateral diffusion tracer content tendency for "//trim(shortnm), & + conv_units, conversion=Tr%conv_scale*US%s_to_T, & + x_cell_method = 'sum', y_cell_method = 'sum', v_extensive = .true.) + + Tr%id_lbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency_2d', & + diag%axesT1, Time, "Depth integrated lateral diffusion tracer "//& + "content tendency for "//trim(shortnm), conv_units, & + conversion=Tr%conv_scale*US%s_to_T, x_cell_method='sum', y_cell_method='sum') endif Tr%id_dfxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_conc_tendency', & - diag%axesTL, Time, "Lateral (neutral) tracer concentration tendency for "//trim(shortnm), & + diag%axesTL, Time, "Neutral diffusion tracer concentration tendency for "//trim(shortnm), & + trim(units)//' s-1', conversion=US%s_to_T) + + Tr%id_lbdxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_conc_tendency', & + diag%axesTL, Time, "Lateral diffusion tracer concentration tendency for "//trim(shortnm), & trim(units)//' s-1', conversion=US%s_to_T) var_lname = "Net time tendency for "//lowercase(flux_longname) From 31d2941d0bc23973d06f45f0a596cb48dc3cb79f Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 10 Jan 2020 00:59:53 +0000 Subject: [PATCH 076/103] Fix bug in boundary_k_range if hbl > htot In cases where the boundary layer depth is larger than the column thickness, the returned indices of the layer would point to the top of the column. This behavior is fixed such that if hbl > htot, k_bot and z_bot point to the bottom of the column. --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 07f062d1d2..83b981f04b 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -338,6 +338,11 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b k_bot = 1 zeta_bot = 0. if (hbl == 0.) return + if ( hbl >= htot ); then + k_bot = nk + zeta_bot = 0. + return + endif do k=1,nk htot = htot + h(k) if ( htot >= hbl) then @@ -354,10 +359,15 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b zeta_bot = 1. htot = 0. if (hbl == 0.) return + if (hbl >= htot) then + k_top = 1 + zeta_top = 0. + return + endif do k=nk,1,-1 htot = htot + h(k) if (htot >= hbl) then - k_top = k + k_top = k zeta_top = 1 - (htot - hbl)/h(k) return endif From 5c8b32fb1b0971d7820b3d237a3a2681d2ecb679 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 10 Jan 2020 13:52:33 -0700 Subject: [PATCH 077/103] Fix a bug when checking if hbl > htot --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 1df84ad130..d16ea81291 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -155,7 +155,6 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) call pass_var(hbl,G%Domain) - do m = 1,Reg%ntr tracer => Reg%tr(m) @@ -378,7 +377,7 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b k_bot = 1 zeta_bot = 0. if (hbl == 0.) return - if ( hbl >= htot ); then + if (hbl >= SUM(h(:))) then k_bot = nk zeta_bot = 0. return @@ -399,7 +398,7 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b zeta_bot = 1. htot = 0. if (hbl == 0.) return - if (hbl >= htot) then + if (hbl >= SUM(h(:))) then k_top = 1 zeta_top = 0. return From dce59f430dfc1cc9bc2d9524af0993f843c42c90 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 15 Jan 2020 15:19:18 -0700 Subject: [PATCH 078/103] Fix a bug in the LBD method 2 khtr_u was missing in the F_layer calculations for the surface in method 2. --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index d16ea81291..edd7cf597c 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -209,9 +209,9 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) do j=G%jsc,G%jec do i=G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then - call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(i,j,:), h(i+1,j,:), hbl(i,j), hbl(i+1,j), & - tracer%t(i,j,:), tracer%t(i+1,j,:), ppoly0_coefs(i,j,:,:), ppoly0_coefs(i+1,j,:,:), ppoly0_E(i,j,:,:), & - ppoly0_E(i+1,j,:,:), remap_method, Coef_x(I,j), uFlx(I,j,:)) + call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), & + ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx(I,j,:)) endif enddo enddo @@ -356,7 +356,7 @@ end function harmonic_mean subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_bot) integer, intent(in ) :: boundary !< SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] - real, dimension(nk), intent(in ) :: h !< Layer thicknesses of the coluymn [m] + real, dimension(nk), intent(in ) :: h !< Layer thicknesses of the column [m] real, intent(in ) :: hbl !< Thickness of the boundary layer [m] !! If surface, with respect to zbl_ref = 0. !! If bottom, with respect to zbl_ref = SUM(h) @@ -431,7 +431,7 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, real, intent(in ) :: hbl_L !< Thickness of the boundary boundary !! layer (left) [m] real, intent(in ) :: hbl_R !< Thickness of the boundary boundary - !! layer (left) [m] + !! layer (right) [m] real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [ nondim m^-3 ] real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [ nondim m^-3 ] real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [ nondim m^-3 ] @@ -487,10 +487,10 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R_avg = average_value_ppoly( nk, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_bot_R, 0., zeta_bot_R) heff = harmonic_mean(h_work_L, h_work_R) ! tracer flux where the minimum BLD intersets layer - F_layer(k_bot_min) = -heff * (phi_R_avg - phi_L_avg) + F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) do k = k_bot_min-1,1,-1 heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -heff * (phi_R(k) - phi_L(k)) + F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) enddo endif From c8361e799817da00481f0410bcb7ee7a0fcc401d Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 15 Jan 2020 15:39:30 -0700 Subject: [PATCH 079/103] Add a note saying khtr_avg should be computed once khtr is 3D --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index edd7cf597c..b4c0b9b9ac 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -446,6 +446,8 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, real, dimension(nk) :: h_u ! Thickness at the u-point [m] real :: hbl_u ! Boundary layer Thickness at the u-point [m] real :: khtr_avg ! Thickness-weighted diffusivity at the u-point [m^2 s^-1] + ! This is just to remind developers that khtr_avg should be + ! computed once khtr is 3D. real :: heff ! Harmonic mean of layer thicknesses [m] real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] real :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) @@ -487,6 +489,7 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R_avg = average_value_ppoly( nk, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_bot_R, 0., zeta_bot_R) heff = harmonic_mean(h_work_L, h_work_R) ! tracer flux where the minimum BLD intersets layer + ! GMM, khtr_avg should be computed once khtr is 3D F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) do k = k_bot_min-1,1,-1 heff = harmonic_mean(h_L(k), h_R(k)) @@ -556,6 +559,8 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real, dimension(nk) :: h_u ! Thickness at the u-point [m] real :: hbl_u ! Boundary layer Thickness at the u-point [m] real :: khtr_avg ! Thickness-weighted diffusivity at the u-point [m^2 s^-1] + ! This is just to remind developers that khtr_avg should be + ! computed once khtr is 3D. real :: heff ! Harmonic mean of layer thicknesses [m] real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] real :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) @@ -593,6 +598,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, call boundary_k_range(boundary, nk, h_u, hbl_u, k_top_u, zeta_top_u, k_bot_u, zeta_bot_u) ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities + ! GMM, khtr_avg should be computed once khtr is 3D heff = harmonic_mean(hbl_L, hbl_R) F_bulk = -(khtr_u * heff) * (phi_R_avg - phi_L_avg) F_bulk_remain = F_bulk From 248a87ca467f124526cc0c6680250af456e58275 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 22 Jan 2020 16:15:49 -0700 Subject: [PATCH 080/103] Fix units description and delete placeholder for the pressure reconstruction --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 219 ++---------------- 1 file changed, 17 insertions(+), 202 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index b4c0b9b9ac..22a82ecad5 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -136,9 +136,9 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1) :: ppoly0_coefs !< Coefficients of polynomial real, dimension(SZI_(G),SZJ_(G),SZK_(G),2) :: ppoly0_E !< Edge values from reconstructions real, dimension(SZK_(G),CS%deg+1) :: ppoly_S !< Slopes from reconstruction (placeholder) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx !< Zonal flux of tracer [H conc ~> m conc or conc kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: uFlx !< Zonal flux of tracer [conc m^3] real, dimension(SZIB_(G),SZJ_(G)) :: uFLx_bulk !< Total calculated bulk-layer u-flux for the tracer - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx !< Meridional flux of tracer + real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vFlx !< Meridional flux of tracer [conc m^3] real, dimension(SZI_(G),SZJB_(G)) :: vFlx_bulk !< Total calculated bulk-layer v-flux for the tracer real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d !< Layer summed u-flux transport real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d !< Layer summed v-flux transport @@ -432,15 +432,15 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, !! layer (left) [m] real, intent(in ) :: hbl_R !< Thickness of the boundary boundary !! layer (right) [m] - real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [ nondim m^-3 ] - real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [ nondim m^-3 ] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [ nondim m^-3 ] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [ nondim m^-3 ] + real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] + real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [ nondim ] real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t at U-point [m^2] - real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [m^2 conc] + real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point [m^3 conc] ! Local variables real, dimension(nk) :: h_means ! Calculate the layer-wise harmonic means [m] real, dimension(nk) :: h_u ! Thickness at the u-point [m] @@ -542,18 +542,18 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, !! layer (left) [m] real, intent(in ) :: area_L !< Area of the horizontal grid (left) [m^2] real, intent(in ) :: area_R !< Area of the horizontal grid (right) [m^2] - real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [ nondim m^-3 ] - real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [ nondim m^-3 ] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [ nondim m^-3 ] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [ nondim m^-3 ] - real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [ nondim ] - real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] - integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] + real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] + real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] + real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [nondim] + real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [nondim] + integer, intent(in ) :: method !< Method of polynomial integration [nondim] real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t at U-point [m^2] - real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux [m^2 conc] - real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [m^2 conc] + real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux [m^3 conc] + real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [m^3 conc] real, optional, dimension(nk), intent( out) :: F_limit !< The amount of flux not applied due to limiter - !! F_layer(k) - F_max [m^2 conc] + !! F_layer(k) - F_max [m^3 conc] ! Local variables real, dimension(nk) :: h_means ! Calculate the layer-wise harmonic means [m] real, dimension(nk) :: h_u ! Thickness at the u-point [m] @@ -709,191 +709,6 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, end subroutine fluxes_bulk_method -! TODO: GMM, this is a placeholder for the pressure reconstruction. -! get rid of all the T/S related variables below. We need to use the -! continuous version since pressure will be continuous. However, -! for tracer we will need to use a discontinuous reconstruction. -! Mimic the neutral diffusion driver to calculate and apply sub-layer -! fluxes. - -!> Returns positions within left/right columns of combined interfaces using continuous reconstructions of T/S -!subroutine find_neutral_surface_positions_continuous(nk, Pl, Pr, PoL, PoR, KoL, KoR, hEff) -! integer, intent(in) :: nk !< Number of levels -! real, dimension(nk+1), intent(in) :: Pl !< Left-column interface pressure [Pa] -! real, dimension(2*nk+2), intent(inout) :: PoL !< Fractional position of neutral surface within -! !! layer KoL of left column -! real, dimension(2*nk+2), intent(inout) :: PoR !< Fractional position of neutral surface within -! !! layer KoR of right column -! integer, dimension(2*nk+2), intent(inout) :: KoL !< Index of first left interface above neutral surface -! integer, dimension(2*nk+2), intent(inout) :: KoR !< Index of first right interface above neutral surface -! real, dimension(2*nk+1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces [Pa] -! -! ! Local variables -! integer :: ns ! Number of neutral surfaces -! integer :: k_surface ! Index of neutral surface -! integer :: kl ! Index of left interface -! integer :: kr ! Index of right interface -! real :: dRdT, dRdS ! dRho/dT and dRho/dS for the neutral surface -! logical :: searching_left_column ! True if searching for the position of a right interface in the left column -! logical :: searching_right_column ! True if searching for the position of a left interface in the right column -! logical :: reached_bottom ! True if one of the bottom-most interfaces has been used as the target -! integer :: krm1, klm1 -! real :: dRho, dRhoTop, dRhoBot, hL, hR -! integer :: lastK_left, lastK_right -! real :: lastP_left, lastP_right -! -! ns = 2*nk+2 -! ! Initialize variables for the search -! kr = 1 ; lastK_right = 1 ; lastP_right = 0. -! kl = 1 ; lastK_left = 1 ; lastP_left = 0. -! reached_bottom = .false. -! -! ! Loop over each neutral surface, working from top to bottom -! neutral_surfaces: do k_surface = 1, ns -! klm1 = max(kl-1, 1) -! if (klm1>nk) stop 'find_neutral_surface_positions(): klm1 went out of bounds!' -! krm1 = max(kr-1, 1) -! if (krm1>nk) stop 'find_neutral_surface_positions(): krm1 went out of bounds!' -! -! ! TODO: GMM, instead of dRho we need dP (pressure at right - pressure at left) -! -! ! Potential density difference, rho(kr) - rho(kl) -! dRho = 0.5 * ( ( dRdTr(kr) + dRdTl(kl) ) * ( Tr(kr) - Tl(kl) ) & -! + ( dRdSr(kr) + dRdSl(kl) ) * ( Sr(kr) - Sl(kl) ) ) -! ! Which column has the lighter surface for the current indexes, kr and kl -! if (.not. reached_bottom) then -! if (dRho < 0.) then -! searching_left_column = .true. -! searching_right_column = .false. -! elseif (dRho > 0.) then -! searching_right_column = .true. -! searching_left_column = .false. -! else ! dRho == 0. -! if (kl + kr == 2) then ! Still at surface -! searching_left_column = .true. -! searching_right_column = .false. -! else ! Not the surface so we simply change direction -! searching_left_column = .not. searching_left_column -! searching_right_column = .not. searching_right_column -! endif -! endif -! endif -! -! if (searching_left_column) then -! ! Interpolate for the neutral surface position within the left column, layer klm1 -! ! Potential density difference, rho(kl-1) - rho(kr) (should be negative) -! dRhoTop = 0.5 * ( ( dRdTl(klm1) + dRdTr(kr) ) * ( Tl(klm1) - Tr(kr) ) & -! + ( dRdSl(klm1) + dRdSr(kr) ) * ( Sl(klm1) - Sr(kr) ) ) -! ! Potential density difference, rho(kl) - rho(kr) (will be positive) -! dRhoBot = 0.5 * ( ( dRdTl(klm1+1) + dRdTr(kr) ) * ( Tl(klm1+1) - Tr(kr) ) & -! + ( dRdSl(klm1+1) + dRdSr(kr) ) * ( Sl(klm1+1) - Sr(kr) ) ) -! -! ! Because we are looking left, the right surface, kr, is lighter than klm1+1 and should be denser than klm1 -! ! unless we are still at the top of the left column (kl=1) -! if (dRhoTop > 0. .or. kr+kl==2) then -! PoL(k_surface) = 0. ! The right surface is lighter than anything in layer klm1 -! elseif (dRhoTop >= dRhoBot) then ! Left layer is unstratified -! PoL(k_surface) = 1. -! else -! ! Linearly interpolate for the position between Pl(kl-1) and Pl(kl) where the density difference -! ! between right and left is zero. -! -! ! TODO: GMM, write the linear solution instead of using interpolate_for_nondim_position -! PoL(k_surface) = interpolate_for_nondim_position( dRhoTop, Pl(klm1), dRhoBot, Pl(klm1+1) ) -! endif -! if (PoL(k_surface)>=1. .and. klm1= is really ==, when PoL==1 we point to the bottom of the cell -! klm1 = klm1 + 1 -! PoL(k_surface) = PoL(k_surface) - 1. -! endif -! if (real(klm1-lastK_left)+(PoL(k_surface)-lastP_left)<0.) then -! PoL(k_surface) = lastP_left -! klm1 = lastK_left -! endif -! KoL(k_surface) = klm1 -! if (kr <= nk) then -! PoR(k_surface) = 0. -! KoR(k_surface) = kr -! else -! PoR(k_surface) = 1. -! KoR(k_surface) = nk -! endif -! if (kr <= nk) then -! kr = kr + 1 -! else -! reached_bottom = .true. -! searching_right_column = .true. -! searching_left_column = .false. -! endif -! elseif (searching_right_column) then -! ! Interpolate for the neutral surface position within the right column, layer krm1 -! ! Potential density difference, rho(kr-1) - rho(kl) (should be negative) -! dRhoTop = 0.5 * ( ( dRdTr(krm1) + dRdTl(kl) ) * ( Tr(krm1) - Tl(kl) ) & -! + ( dRdSr(krm1) + dRdSl(kl) ) * ( Sr(krm1) - Sl(kl) ) ) -! ! Potential density difference, rho(kr) - rho(kl) (will be positive) -! dRhoBot = 0.5 * ( ( dRdTr(krm1+1) + dRdTl(kl) ) * ( Tr(krm1+1) - Tl(kl) ) & -! + ( dRdSr(krm1+1) + dRdSl(kl) ) * ( Sr(krm1+1) - Sl(kl) ) ) -! -! ! Because we are looking right, the left surface, kl, is lighter than krm1+1 and should be denser than krm1 -! ! unless we are still at the top of the right column (kr=1) -! if (dRhoTop >= 0. .or. kr+kl==2) then -! PoR(k_surface) = 0. ! The left surface is lighter than anything in layer krm1 -! elseif (dRhoTop >= dRhoBot) then ! Right layer is unstratified -! PoR(k_surface) = 1. -! else -! ! Linearly interpolate for the position between Pr(kr-1) and Pr(kr) where the density difference -! ! between right and left is zero. -! PoR(k_surface) = interpolate_for_nondim_position( dRhoTop, Pr(krm1), dRhoBot, Pr(krm1+1) ) -! endif -! if (PoR(k_surface)>=1. .and. krm1= is really ==, when PoR==1 we point to the bottom of the cell -! krm1 = krm1 + 1 -! PoR(k_surface) = PoR(k_surface) - 1. -! endif -! if (real(krm1-lastK_right)+(PoR(k_surface)-lastP_right)<0.) then -! PoR(k_surface) = lastP_right -! krm1 = lastK_right -! endif -! KoR(k_surface) = krm1 -! if (kl <= nk) then -! PoL(k_surface) = 0. -! KoL(k_surface) = kl -! else -! PoL(k_surface) = 1. -! KoL(k_surface) = nk -! endif -! if (kl <= nk) then -! kl = kl + 1 -! else -! reached_bottom = .true. -! searching_right_column = .false. -! searching_left_column = .true. -! endif -! else -! stop 'Else what?' -! endif -! -! lastK_left = KoL(k_surface) ; lastP_left = PoL(k_surface) -! lastK_right = KoR(k_surface) ; lastP_right = PoR(k_surface) -! -! ! Effective thickness -! ! NOTE: This would be better expressed in terms of the layers thicknesses rather -! ! than as differences of position - AJA -! -! ! TODO: GMM, we need to import absolute_position from neutral diffusion. This gives us -! !! the depth of the interface on the left and right side. -! -! if (k_surface>1) then -! hL = absolute_position(nk,ns,Pl,KoL,PoL,k_surface) - absolute_position(nk,ns,Pl,KoL,PoL,k_surface-1) -! hR = absolute_position(nk,ns,Pr,KoR,PoR,k_surface) - absolute_position(nk,ns,Pr,KoR,PoR,k_surface-1) -! if ( hL + hR > 0.) then -! hEff(k_surface-1) = 2. * hL * hR / ( hL + hR ) ! Harmonic mean of layer thicknesses -! else -! hEff(k_surface-1) = 0. -! endif -! endif -! -! enddo neutral_surfaces -!end subroutine find_neutral_surface_positions_continuous - !> Unit tests for near-boundary horizontal mixing logical function near_boundary_unit_tests( verbose ) logical, intent(in) :: verbose !< If true, output additional information for debugging unit tests From 0525a4c106df3d32503610a9e6413594c96a469e Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 22 Jan 2020 17:42:11 -0700 Subject: [PATCH 081/103] Change flux limiting calculation Previously, F_max was calculated based on the sign of F_bulk, F_layer and phi_*, as follows: F_max = 0.25 * (area_R*(phi_R(k)*h_R(k))) or F_max = 0.25 * (area_L*(phi_L(k)*h_L(k))), This is only based on the concentration at the donor cell and can be problematic (i.e., create new extrema). In addition, this limitor was not being applied in the layer by layer method. This commit adds the following limitor to both methods: F_max = -0.2 * ((area_R*(phi_R(k)*h_R(k)))-(area_L*(phi_L(k)*h_R(k)))) In this case, F_max is based on the tracer *gradient* and, therefore, should not create new extrema. The 0.2 comes from the following: Imagine you have a tracer extrema in the center of the domain at time = 0: t=0 0 0 1 0 0 If diffusion acts on this tracer in all directions (EWNS), the final result should look like the following: t=inf .2 .2.2.2 .2 --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 110 ++++++++++++------ 1 file changed, 75 insertions(+), 35 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 22a82ecad5..48d813faa3 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -202,16 +202,14 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) if (tracer%id_lbd_bulk_dfx>0) call post_data(tracer%id_lbd_bulk_dfx, uFlx_bulk*Idt, CS%diag) if (tracer%id_lbd_bulk_dfy>0) call post_data(tracer%id_lbd_bulk_dfy, vFlx_bulk*Idt, CS%diag) - ! TODO: this is where we would filter vFlx and uFlux to get rid of checkerboard noise - ! Method #2 elseif (CS%method == 2) then do j=G%jsc,G%jec do i=G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & - tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), & - ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx(I,j,:)) + G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & + ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx(I,j,:)) endif enddo enddo @@ -219,8 +217,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) do i=G%isc,G%iec if (G%mask2dCv(i,J)>0.) then call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & - tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & - ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx(i,J,:)) + G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & + ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx(i,J,:)) endif enddo enddo @@ -420,8 +418,8 @@ end subroutine boundary_k_range !> Calculate the lateral boundary diffusive fluxes using the layer by layer method. !! See \ref section_method2 -subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, ppoly0_coefs_L, & - ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) +subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, & + ppoly0_coefs_L, ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] @@ -432,6 +430,8 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, !! layer (left) [m] real, intent(in ) :: hbl_R !< Thickness of the boundary boundary !! layer (right) [m] + real, intent(in ) :: area_L !< Area of the horizontal grid (left) [m^2] + real, intent(in ) :: area_R !< Area of the horizontal grid (right) [m^2] real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] @@ -452,7 +452,8 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] real :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) ! [conc m^-3 ] - real :: htot ! Total column thickness [m] + real :: htot ! Total column thickness [m] + real :: F_max ! The maximum amount of flux that can leave a cell integer :: k, k_bot_min, k_top_max integer :: k_top_L, k_bot_L, k_top_u integer :: k_top_R, k_bot_R, k_bot_u @@ -491,9 +492,32 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, ! tracer flux where the minimum BLD intersets layer ! GMM, khtr_avg should be computed once khtr is 3D F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) + + ! limit the flux to 0.2 of the tracer *gradient* + ! Why 0.2? + ! t=0 t=inf + ! 0 .2 + ! 0 1 0 .2.2.2 + ! 0 .2 + + F_max = -0.2 * ((area_R*(phi_R_avg*h_work_R))-(area_L*(phi_L_avg*h_work_L))) + ! Apply flux limiter calculated above + if (F_max >= 0.) then + F_layer(k_bot_min) = MIN(F_layer(k_bot_min),F_max) + else + F_layer(k_bot_min) = MAX(F_layer(k_bot_min),F_max) + endif + do k = k_bot_min-1,1,-1 heff = harmonic_mean(h_L(k), h_R(k)) F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) + F_max = -0.2 * ((area_R*(phi_R(k)*h_R(k)))-(area_L*(phi_L(k)*h_R(k)))) + ! Apply flux limiter calculated above + if (F_max >= 0.) then + F_layer(k) = MIN(F_layer(k),F_max) + else + F_layer(k) = MAX(F_layer(k),F_max) + endif enddo endif @@ -518,9 +542,25 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, ! tracer flux where the minimum BLD intersets layer F_layer(k_top_max) = (-heff * khtr_u) * (phi_R_avg - phi_L_avg) + + F_max = -0.2 * ((area_R*(phi_R_avg*h_work_R))-(area_L*(phi_L_avg*h_work_L))) + ! Apply flux limiter calculated above + if (F_max >= 0.) then + F_layer(k_top_max) = MIN(F_layer(k_top_max),F_max) + else + F_layer(k_top_max) = MAX(F_layer(k_top_max),F_max) + endif + do k = k_top_max+1,nk heff = harmonic_mean(h_L(k), h_R(k)) F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) + F_max = -0.2 * ((area_R*(phi_R(k)*h_R(k)))-(area_L*(phi_L(k)*h_R(k)))) + ! Apply flux limiter calculated above + if (F_max >= 0.) then + F_layer(k) = MIN(F_layer(k),F_max) + else + F_layer(k) = MAX(F_layer(k),F_max) + endif enddo endif @@ -654,42 +694,41 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, if ( SUM(h_means) == 0. ) then return + ! Decompose the bulk flux onto the individual layers else ! Initialize remaining thickness inv_heff = 1./SUM(h_means) - ! Decompose the bulk flux onto the individual layers do k=1,nk if (h_means(k) > 0.) then - ! Limit the tracer flux so that the donor cell with positive concentration can't go negative - ! If a tracer can go negative, it is unclear what the limiter should be. BOB ALISTAIR?! hfrac = h_means(k)*inv_heff F_layer(k) = F_bulk * hfrac - if ( SIGN(1.,F_bulk) == SIGN(1., F_layer(k))) then - ! limit the flux to 0.25 of the total tracer in the cell - if (F_bulk < 0. .and. phi_R(k) >= 0.) then - F_max = 0.25 * (area_R*(phi_R(k)*h_R(k))) - elseif (F_bulk > 0. .and. phi_L(k) >= 0.) then - F_max = 0.25 * (area_L*(phi_L(k)*h_L(k))) - else ! The above quantities are always positive, so we can use F_max < -1 to see if we don't need to limit - F_max = -1. - endif + ! limit the flux to 0.2 of the tracer *gradient* + ! Why 0.2? + ! t=0 t=inf + ! 0 .2 + ! 0 1 0 .2.2.2 + ! 0 .2 + ! + F_max = -0.2 * ((area_R*(phi_R(k)*h_R(k)))-(area_L*(phi_L(k)*h_R(k)))) + + ! check if bulk flux (or F_layer) and F_max have same direction + if ( SIGN(1.,F_bulk) == SIGN(1., F_max)) then ! Distribute bulk flux onto layers if ( ((boundary == SURFACE) .and. (k == k_min)) .or. ((boundary == BOTTOM) .and. (k == nk)) ) then - F_layer(k) = F_bulk_remain + F_layer(k) = F_bulk_remain ! GMM, are not using F_bulk_remain for now. Should we keep it? endif F_bulk_remain = F_bulk_remain - F_layer(k) ! Apply flux limiter calculated above if (F_max >= 0.) then - if (F_layer(k) > 0.) then - limited = F_layer(k) > F_max - F_layer(k) = MIN(F_layer(k),F_max) - elseif (F_layer(k) < 0.) then - limited = F_layer(k) < -F_max - F_layer(k) = MAX(F_layer(k),-F_max) ! Note negative to make the sign of flux consistent - endif + limited = F_layer(k) > F_max + F_layer(k) = MIN(F_layer(k),F_max) + else + limited = F_layer(k) < F_max + F_layer(k) = MAX(F_layer(k),F_max) endif + ! GMM, again we are not using F_limit. Should we delete it? if (PRESENT(F_limit)) then if (limited) then F_limit(k) = F_layer(k) - F_max @@ -698,6 +737,7 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, endif endif else + ! do not apply a flux on this layer F_bulk_remain = F_bulk_remain - F_layer(k) F_layer(k) = 0. endif @@ -931,8 +971,8 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. - call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) + call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & + phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-2.,-2./) ) ! unit tests for layer by layer method @@ -949,8 +989,8 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. - call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & + phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,0.0/) ) test_name = 'Different hbl and different column thicknesses (linear profile right)' @@ -967,8 +1007,8 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 0.; ppoly0_E_R(1,2) = 2. ppoly0_E_R(2,1) = 2.; ppoly0_E_R(2,2) = 4. khtr_u = 1. - call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& - ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & + phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-3.75,0.0/) ) end function near_boundary_unit_tests From 9db5ba14a0c4b2f5ec68655b04fc3e47bc0d4f83 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 7 Feb 2020 10:21:56 -0700 Subject: [PATCH 082/103] Improve documentation and unit tests * Fix broken unit tests * Add new unit tests (Surface boundary is deeper than column thickness) * Update documentation * Delete unneeded code --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 218 +++++++++--------- 1 file changed, 108 insertions(+), 110 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 48d813faa3..4fda621abc 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -40,7 +40,6 @@ module MOM_lateral_boundary_diffusion !! and apply near boundary layer fluxes !! 1. Bulk-layer approach !! 2. Along layer - !! 3. Decomposition onto pressure levels integer :: deg !< Degree of polynomial reconstruction integer :: surface_boundary_scheme !< Which boundary layer scheme to use !! 1. ePBL; 2. KPP @@ -65,7 +64,7 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab type(param_file_type), intent(in) :: param_file !< Parameter file structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(diabatic_CS), pointer :: diabatic_CSp !< KPP control structure needed to get BLD - type(lateral_boundary_diffusion_CS), pointer :: CS !< Lateral boundary mixing control structure + type(lateral_boundary_diffusion_CS), pointer :: CS !< Lateral boundary mixing control structure ! local variables character(len=80) :: string ! Temporary strings @@ -101,8 +100,7 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab call get_param(param_file, mdl, "LATERAL_BOUNDARY_METHOD", CS%method, & "Determine how to apply boundary lateral diffusion of tracers: \n"//& "1. Bulk layer approach \n"//& - "2. Along layer approach \n"//& - "3. Decomposition on to pressure levels", default=1) + "2. Along layer approach", default=1) call get_param(param_file, mdl, "LBD_BOUNDARY_EXTRAP", boundary_extrap, & "Use boundary extrapolation in LBD code", & default=.false.) @@ -116,8 +114,11 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab end function lateral_boundary_diffusion_init -!> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. Two different methods -!! Method 1: Calculate fluxes from bulk layer integrated quantities +!> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. +!! Two different methods are available: +!! Method 1: lower order representation, calculate fluxes from bulk layer integrated quantities. +!! Method 2: more straight forward, diffusion is applied layer by layer using only information +!! from neighboring cells. subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) type(ocean_grid_type), intent(inout) :: G !< Grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -142,8 +143,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real, dimension(SZI_(G),SZJB_(G)) :: vFlx_bulk !< Total calculated bulk-layer v-flux for the tracer real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d !< Layer summed u-flux transport real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d !< Layer summed v-flux transport - real, dimension(SZI_(G),SZJ_(G),G%ke) :: tendency ! tendency array for diagn - real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d ! depth integrated content tendency for diagn + real, dimension(SZI_(G),SZJ_(G),G%ke) :: tendency !< tendency array for diagn + real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d !< depth integrated content tendency for diagn type(tracer_type), pointer :: Tracer => NULL() !< Pointer to the current tracer integer :: remap_method !< Reconstruction method integer :: i,j,k,m !< indices to loop over @@ -308,8 +309,8 @@ real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coe !! (0 if none, 1. if all). For the bottom boundary layer, this is always 1. !! because integration starts at the bottom [nondim] ! Local variables - real :: htot ! Running sum of the thicknesses (top to bottom) - integer :: k ! k indice + real :: htot !< Running sum of the thicknesses (top to bottom) + integer :: k !< k indice htot = 0. @@ -404,7 +405,7 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b do k=nk,1,-1 htot = htot + h(k) if (htot >= hbl) then - k_top = k + k_top = k zeta_top = 1 - (htot - hbl)/h(k) return endif @@ -441,26 +442,26 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t at U-point [m^2] real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point [m^3 conc] + ! Local variables - real, dimension(nk) :: h_means ! Calculate the layer-wise harmonic means [m] - real, dimension(nk) :: h_u ! Thickness at the u-point [m] - real :: hbl_u ! Boundary layer Thickness at the u-point [m] - real :: khtr_avg ! Thickness-weighted diffusivity at the u-point [m^2 s^-1] - ! This is just to remind developers that khtr_avg should be - ! computed once khtr is 3D. - real :: heff ! Harmonic mean of layer thicknesses [m] - real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] - real :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) - ! [conc m^-3 ] - real :: htot ! Total column thickness [m] - real :: F_max ! The maximum amount of flux that can leave a cell - integer :: k, k_bot_min, k_top_max - integer :: k_top_L, k_bot_L, k_top_u - integer :: k_top_R, k_bot_R, k_bot_u - real :: zeta_top_L, zeta_top_R, zeta_top_u - real :: zeta_bot_L, zeta_bot_R, zeta_bot_u - real :: h_work_L, h_work_R ! dummy variables - real :: hbl_min ! minimum BLD (left and right) + real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [m] + real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] + !! This is just to remind developers that khtr_avg should be + !! computed once khtr is 3D. + real :: heff !< Harmonic mean of layer thicknesses [m] + real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses [m^[-1] + real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) + !! [conc m^-3 ] + real :: htot !< Total column thickness [m] + integer :: k, k_bot_min, k_top_max !< k-indices, min and max for top and bottom, respectively + integer :: k_top_L, k_bot_L !< k-indices left + integer :: k_top_R, k_bot_R !< k-indices right + real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the boundary + !! layer depth [nondim] + real :: zeta_bot_L, zeta_bot_R !< distance from the bottom of a layer to the boundary + !!layer depth [nondim] + real :: h_work_L, h_work_R !< dummy variables + real :: hbl_min !< minimum BLD (left and right) [m] F_layer(:) = 0.0 if (hbl_L == 0. .or. hbl_R == 0.) then @@ -493,31 +494,9 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L ! GMM, khtr_avg should be computed once khtr is 3D F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) - ! limit the flux to 0.2 of the tracer *gradient* - ! Why 0.2? - ! t=0 t=inf - ! 0 .2 - ! 0 1 0 .2.2.2 - ! 0 .2 - - F_max = -0.2 * ((area_R*(phi_R_avg*h_work_R))-(area_L*(phi_L_avg*h_work_L))) - ! Apply flux limiter calculated above - if (F_max >= 0.) then - F_layer(k_bot_min) = MIN(F_layer(k_bot_min),F_max) - else - F_layer(k_bot_min) = MAX(F_layer(k_bot_min),F_max) - endif - do k = k_bot_min-1,1,-1 heff = harmonic_mean(h_L(k), h_R(k)) F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) - F_max = -0.2 * ((area_R*(phi_R(k)*h_R(k)))-(area_L*(phi_L(k)*h_R(k)))) - ! Apply flux limiter calculated above - if (F_max >= 0.) then - F_layer(k) = MIN(F_layer(k),F_max) - else - F_layer(k) = MAX(F_layer(k),F_max) - endif enddo endif @@ -543,24 +522,9 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L ! tracer flux where the minimum BLD intersets layer F_layer(k_top_max) = (-heff * khtr_u) * (phi_R_avg - phi_L_avg) - F_max = -0.2 * ((area_R*(phi_R_avg*h_work_R))-(area_L*(phi_L_avg*h_work_L))) - ! Apply flux limiter calculated above - if (F_max >= 0.) then - F_layer(k_top_max) = MIN(F_layer(k_top_max),F_max) - else - F_layer(k_top_max) = MAX(F_layer(k_top_max),F_max) - endif - do k = k_top_max+1,nk heff = harmonic_mean(h_L(k), h_R(k)) F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) - F_max = -0.2 * ((area_R*(phi_R(k)*h_R(k)))-(area_L*(phi_L(k)*h_R(k)))) - ! Apply flux limiter calculated above - if (F_max >= 0.) then - F_layer(k) = MIN(F_layer(k),F_max) - else - F_layer(k) = MAX(F_layer(k),F_max) - endif enddo endif @@ -595,25 +559,26 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real, optional, dimension(nk), intent( out) :: F_limit !< The amount of flux not applied due to limiter !! F_layer(k) - F_max [m^3 conc] ! Local variables - real, dimension(nk) :: h_means ! Calculate the layer-wise harmonic means [m] - real, dimension(nk) :: h_u ! Thickness at the u-point [m] - real :: hbl_u ! Boundary layer Thickness at the u-point [m] - real :: khtr_avg ! Thickness-weighted diffusivity at the u-point [m^2 s^-1] - ! This is just to remind developers that khtr_avg should be - ! computed once khtr is 3D. - real :: heff ! Harmonic mean of layer thicknesses [m] - real :: inv_heff ! Inverse of the harmonic mean of layer thicknesses [m^[-1] - real :: phi_L_avg, phi_R_avg ! Bulk, thickness-weighted tracer averages (left and right column) - ! [conc m^-3 ] - real :: htot ! Total column thickness [m] - integer :: k, k_min, k_max - integer :: k_top_L, k_bot_L, k_top_u - integer :: k_top_R, k_bot_R, k_bot_u - real :: zeta_top_L, zeta_top_R, zeta_top_u - real :: zeta_bot_L, zeta_bot_R, zeta_bot_u - real :: h_work_L, h_work_R ! dummy variables - real :: F_max !< The maximum amount of flux that can leave a cell - logical :: limited !< True if the flux limiter was applied + real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [m] + real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] + !! This is just to remind developers that khtr_avg should be + !! computed once khtr is 3D. + real :: heff !< Harmonic mean of layer thicknesses [m] + real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses [m^[-1] + real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) + !! [conc m^-3 ] + real :: htot ! Total column thickness [m] + integer :: k, k_min, k_max !< k-indices, min and max for top and bottom, respectively + integer :: k_top_L, k_bot_L !< k-indices left + integer :: k_top_R, k_bot_R !< k-indices right + real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the + !! boundary layer [nondim] + real :: zeta_bot_L, zeta_bot_R !< distance from the bottom of a layer to the + !! boundary layer [nondim] + real :: h_work_L, h_work_R !< dummy variables + real :: F_max !< The maximum amount of flux that can leave a + !! cell [m^3 conc] + logical :: limited !< True if the flux limiter was applied real :: hfrac, F_bulk_remain if (hbl_L == 0. .or. hbl_R == 0.) then @@ -631,11 +596,6 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, zeta_top_L, k_bot_L, zeta_bot_L) phi_R_avg = bulk_average(boundary, nk, deg, h_R, hbl_R, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, & zeta_top_R, k_bot_R, zeta_bot_R) - do k=1,nk - h_u(k) = 0.5 * (h_L(k) + h_R(k)) - enddo - hbl_u = 0.5*(hbl_L + hbl_R) - call boundary_k_range(boundary, nk, h_u, hbl_u, k_top_u, zeta_top_u, k_bot_u, zeta_bot_u) ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities ! GMM, khtr_avg should be computed once khtr is 3D @@ -791,7 +751,7 @@ logical function near_boundary_unit_tests( verbose ) test_name = 'Surface boundary spans the entire column' h_L = (/5.,5./) call boundary_k_range(SURFACE, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0., test_name, verbose) test_name = 'Bottom boundary spans the entire bottom cell' h_L = (/5.,5./) @@ -813,6 +773,11 @@ logical function near_boundary_unit_tests( verbose ) call boundary_k_range(SURFACE, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 0.25, test_name, verbose) + test_name = 'Surface boundary is deeper than column thickness' + h_L = (/10.,10./) + call boundary_k_range(SURFACE, nk, h_L, 21.0, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0., test_name, verbose) + test_name = 'Bottom boundary intersects first layer' h_L = (/10.,10./) call boundary_k_range(BOTTOM, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) @@ -1088,41 +1053,74 @@ end function test_boundary_k_range !! Boundary lateral diffusion can be applied using one of the three methods: !! !! * [Method #1: Bulk layer](@ref section_method1) (default); -!! * [Method #2: Along layer](ref section_method2); -!! * [Method #3: Decomposition on to pressure levels](@ref section_method3). +!! * [Method #2: Along layer](@ref section_method2); !! !! A brief summary of these methods is provided below. !! !! \subsection section_method1 Bulk layer approach (Method #1) !! -!! Apply the lateral boundary diffusive fluxes calculated from a 'bulk model' +!! Apply the lateral boundary diffusive fluxes calculated from a 'bulk model'.This +!! is a lower order representation (Kraus-Turner like approach) which assumes that +!! eddies are acting along well mixed layers (i.e., eddies do not know care about +!! vertical tracer gradients within the boundary layer). +!! +!! Step #1: compute vertical indices containing boundary layer (boundary_k_range). +!! For the TOP boundary layer, these are: !! -!! Step #1: get vertical indices containing the boundary layer depth. These are !! k_top, k_bot, zeta_top, zeta_bot !! -!! Step #2: compute bulk averages (thickness weighted). phi_L and phi_R +!! Step #2: compute bulk averages (thickness weighted) tracer averages (phi_L and phi_R), +!! then calculate the bulk diffusive flux (F_{bulk}): +!! +!! \f[ F_{bulk} = -KHTR \times h_{eff} \times (\phi_R - \phi_L), \f] +!! where h_eff is the [harmonic mean](@ref section_harmonic_mean) of the boundary layer depth +!! in the left and right columns (\f[ HBL_L \f] and \f[ HBL_R \f], respectively). +!! +!! Step #3: decompose F_bulk onto individual layers: +!! +!! \f[ F_{layer}(k) = F_{bulk} \times h_{frac}(k) , \f] +!! +!! where h_{frac} is !! -!! Step #3: compute a diffusive bulk flux -!! \f[ F_{bulk} = -(KHTR \times heff) \times (\phi_R - \phi_L), \f] -!! where heff is the harmonic mean of the boundary layer depth in the left and -!! right columns (\f[ HBL_L \f] and \f[ HBL_R \f], respectively). +!! \f[ h_{frac}(k) = h_u(k) \times \frac{1}{\sum(h_u)}. \f] !! -!! Step #4: limit the tracer flux so that the donor cell, with positive -!! concentration, cannot go negative. If a tracer can go negative (e.g., -!! temperature at high latitudes) it is unclear what limiter should be used. -!! (TODO: ask Bob and Alistair). +!! h_u is the [harmonic mean](@ref section_harmonic_mean) of thicknesses at each layer. +!! Special care (layer reconstruction) must be taken at k_min = min(k_botL, k_bot_R). !! -!! Step #5: decompose the bulk flux into individual layers and keep track of -!! the remaining flux. The limiter described above is also applied during -!! this step. +!! Step #4: limit the tracer flux so that 1) only down-gradient fluxes are applied, +!! and 2) the flux cannot be larger than F_max, which is defined using the tracer +!! gradient: +!! +!! \f[ F_{max} = -0.2 \times [(V_R(k) \times \phi_R(k)) - (V_L(k) \times \phi_L(k))], \f] +!! where V is the cell volume. Why 0.2? +!! t=0 t=inf +!! 0 .2 +!! 0 1 0 .2.2.2 +!! 0 .2 !! !! \subsection section_method2 Along layer approach (Method #2) !! -!! \subsection section_method3 Decomposition on to pressure levels (Method #3) +!! This is a more straight forward method where diffusion is applied layer by layer using +!! only information from neighboring cells. +!! +!! Step #1: compute vertical indices containing boundary layer (boundary_k_range). +!! For the TOP boundary layer, these are: +!! +!! k_top, k_bot, zeta_top, zeta_bot +!! +!! Step #2: calculate the diffusive flux at each layer: !! -!! To be implemented +!! \f[ F_{k} = -KHTR \times h_{eff}(k) \times (\phi_R(k) - \phi_L(k)), \f] +!! where h_eff is the [harmonic mean](@ref section_harmonic_mean) of the layer thickness +!! in the left and right columns. Special care (layer reconstruction) must be taken at +!! k_min = min(k_botL, k_bot_R). This method does not require a limiter since KHTR +!! is already limted based on a diffusive CFL condition prior to the call of this +!! module. !! !! \subsection section_harmonic_mean Harmonic Mean !! +!! The harmonic mean (HM) betwen h1 and h2 is defined as: +!! +!! \f[ HM = \frac{2 \times h1 \times h2}{h1 + h2} \f] !! end module MOM_lateral_boundary_diffusion From 63cf741f4cc76ecd89f9f1d660145bd0002bf721 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 9 Jan 2020 14:10:59 -0700 Subject: [PATCH 083/103] fix kpp omp directives --- .../vertical/MOM_CVMix_KPP.F90 | 22 +++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index bc9d5552df..3524580dc1 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -640,7 +640,12 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & buoy_scale = US%L_to_m**2*US%s_to_T**3 - !$OMP parallel do default(shared) firstprivate(nonLocalTrans) + !$OMP parallel do default(none) firstprivate(nonLocalTrans) & + !$OMP private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & + !$OMP surfBuoyFlux, Kdiffusivity, Kviscosity, LangEnhK, sigma, & + !$OMP sigmaRatio) & + !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, Kt, & + !$OMP Ks, Kv, nonLocalTransHeat, nonLocalTransScalar, waves) ! loop over horizontal points on processor do j = G%jsc, G%jec do i = G%isc, G%iec @@ -957,7 +962,16 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF buoy_scale = US%L_to_m**2*US%s_to_T**3 ! loop over horizontal points on processor - !$OMP parallel do default(shared) + !$OMP parallel do default(none) private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & + !$OMP surfBuoyFlux, U_H, V_H, u, v, Coriolis, pRef, SLdepth_0d, & + !$OMP ksfc, surfHtemp, surfHsalt, surfHu, surfHv, surfHuS, & + !$OMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & + !$OMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, & + !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_GUESS, LA, rho_1D, & + !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & + !$OMP BulkRi_1d, zBottomMinusOffset) & + !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & + !$OMP Temp, Salt, waves, EOS, GoRho) do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1463,7 +1477,7 @@ subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & dtracer(:,:,:) = 0.0 - !$OMP parallel do default(shared) + !$OMP parallel do default(none) shared(dtracer, nonLocalTrans, h, G, GV, surfFlux) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1522,7 +1536,7 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, dtracer(:,:,:) = 0.0 - !$OMP parallel do default(shared) + !$OMP parallel do default(none) shared(dtracer, nonLocalTrans, h, G, GV, surfFlux) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec From 3540446d56b8906f1292459cacc1da053d9ca97e Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Mon, 10 Feb 2020 15:42:24 -0700 Subject: [PATCH 084/103] fix unitialized logical var in MOM_MEKE --- src/parameterizations/lateral/MOM_MEKE.F90 | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 2f21bb579d..3ea1659c92 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1058,18 +1058,16 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_ALT", CS%MEKE_equilibrium_alt, & "If true, use an alternative formula for computing the (equilibrium)"//& "initial value of MEKE.", default=.false.) - if (CS%MEKE_equilibrium_alt) then - call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_RESTORING", CS%MEKE_equilibrium_restoring, & - "If true, restore MEKE back to its equilibrium value, which is calculated at"//& - "each time step.", default=.false.) - if (CS%MEKE_equilibrium_restoring) then - call get_param(param_file, mdl, "MEKE_RESTORING_TIMESCALE", MEKE_restoring_timescale, & - "The timescale used to nudge MEKE toward its equilibrium value.", units="s", & - default=1e6, scale=US%T_to_s) - CS%MEKE_restoring_rate = 1.0 / MEKE_restoring_timescale - endif - + call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_RESTORING", CS%MEKE_equilibrium_restoring, & + "If true, restore MEKE back to its equilibrium value, which is calculated at"//& + "each time step.", default=CS%MEKE_equilibrium_alt) + if (CS%MEKE_equilibrium_restoring) then + call get_param(param_file, mdl, "MEKE_RESTORING_TIMESCALE", MEKE_restoring_timescale, & + "The timescale used to nudge MEKE toward its equilibrium value.", units="s", & + default=1e6, scale=US%T_to_s) + CS%MEKE_restoring_rate = 1.0 / MEKE_restoring_timescale endif + call get_param(param_file, mdl, "MEKE_FRCOEFF", CS%MEKE_FrCoeff, & "The efficiency of the conversion of mean energy into "//& "MEKE. If MEKE_FRCOEFF is negative, this conversion "//& From a9c896e659945b1d82b8fd08d6532119168accd9 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Mon, 10 Feb 2020 16:00:35 -0700 Subject: [PATCH 085/103] set CS%MEKE_equilibrium_restoring, to false by default --- src/parameterizations/lateral/MOM_MEKE.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 3ea1659c92..c1bb35e9ee 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1060,7 +1060,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) "initial value of MEKE.", default=.false.) call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_RESTORING", CS%MEKE_equilibrium_restoring, & "If true, restore MEKE back to its equilibrium value, which is calculated at"//& - "each time step.", default=CS%MEKE_equilibrium_alt) + "each time step.", default=.false.) if (CS%MEKE_equilibrium_restoring) then call get_param(param_file, mdl, "MEKE_RESTORING_TIMESCALE", MEKE_restoring_timescale, & "The timescale used to nudge MEKE toward its equilibrium value.", units="s", & From 435a7412c6934510f37eb3d3b0f173a819617839 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 12 Feb 2020 15:17:39 -0700 Subject: [PATCH 086/103] Close param file before it gets opened by ocean_model_init again. --- config_src/mct_driver/ocn_comp_mct.F90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index a6aebade08..b1ce9a60c0 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -36,7 +36,7 @@ module ocn_comp_mct use MOM_time_manager, only: time_type, set_date, set_time, set_calendar_type, NOLEAP use MOM_time_manager, only: operator(+), operator(-), operator(*), operator(/) use MOM_time_manager, only: operator(==), operator(/=), operator(>), get_time -use MOM_file_parser, only: get_param, log_version, param_file_type +use MOM_file_parser, only: get_param, log_version, param_file_type, close_param_file use MOM_get_input, only: Get_MOM_Input, directories use MOM_EOS, only: gsw_sp_from_sr, gsw_pt_from_ct use MOM_constants, only: CELSIUS_KELVIN_OFFSET @@ -281,6 +281,9 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) glb%c1 = 0.0; glb%c2 = 0.0; glb%c3 = 0.0; glb%c4 = 0.0 endif + ! Close param file before it gets opened by ocean_model_init again. + call close_param_file(param_file) + ! Initialize the MOM6 model runtype = get_runtype() if (runtype == "initial") then From ba5a442712491a562db3e36965966174cfef43a1 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 12 Feb 2020 15:54:59 -0700 Subject: [PATCH 087/103] if not allocated, do not assign R_rho --- src/parameterizations/vertical/MOM_CVMix_ddiff.F90 | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index 57400e31bf..6abd126ea2 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -145,8 +145,11 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) CS%id_R_rho = register_diag_field('ocean_model','R_rho',diag%axesTi,Time, & 'Double-diffusion density ratio', 'nondim') - if (CS%id_R_rho > 0) & - allocate(CS%R_rho( SZI_(G), SZJ_(G), SZK_(G)+1)); CS%R_rho(:,:,:) = 0.0 + + if (CS%id_R_rho > 0) then + allocate(CS%R_rho( SZI_(G), SZJ_(G), SZK_(G)+1)) + CS%R_rho(:,:,:) = 0.0 + endif call cvmix_init_ddiff(strat_param_max=CS%strat_param_max, & kappa_ddiff_s=CS%kappa_ddiff_s, & From 46b1f34a0c996603ef8174357966179ed58e34fe Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 26 Feb 2020 16:14:32 -0700 Subject: [PATCH 088/103] correct namespace name for doxygen --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 4fda621abc..82e0d6a559 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -1038,7 +1038,7 @@ logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_a end function test_boundary_k_range -!> \namespace mom_lbd +!> \namespace mom_lateral_boundary_diffusion !! !! \section section_LBD The Lateral Boundary Diffusion (LBD) framework !! From 67e5481df8296ee090fb97c8cbe21d006c19333b Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 4 Mar 2020 16:18:02 -0700 Subject: [PATCH 089/103] fix omp directive for melt_potential --- src/core/MOM.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 3348cc1212..0926867cce 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2897,7 +2897,7 @@ subroutine extract_surface_state(CS, sfc_state) if (allocated(sfc_state%melt_potential)) then - !$OMP parallel do default(shared) + !$OMP parallel do default(shared) private(depth_ml, dh, T_freeze, depth, delT) do j=js,je do i=is,ie depth(i) = 0.0 From 049abb03267089e8bc3be7eced2c58ecf906e537 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 5 Mar 2020 14:37:31 -0700 Subject: [PATCH 090/103] fix omp directives in set_viscous_BBL --- src/parameterizations/vertical/MOM_set_viscosity.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 0aaba9d3cf..921769091b 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -365,10 +365,11 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) if (.not.use_BBL_EOS) Rml_vel(:,:) = 0.0 - !$OMP parallel do default(private) shared(u,v,h,tv,visc,G,GV,US,CS,Rml,is,ie,js,je,nz,nkmb, & + !$OMP parallel do default(private) shared(u,v,h,tv,visc,G,GV,US,CS,Rml,nz,nkmb, & !$OMP nkml,Isq,Ieq,Jsq,Jeq,h_neglect,Rho0x400_G,C2pi_3, & !$OMP U_bg_sq,cdrag_sqrt_Z,cdrag_sqrt,K2,use_BBL_EOS, & - !$OMP OBC,maxitt,Vol_quit,D_u,D_v,mask_u,mask_v) + !$OMP OBC,maxitt,D_u,D_v,mask_u,mask_v) & + !$OMP firstprivate(Vol_quit) do j=Jsq,Jeq ; do m=1,2 if (m==1) then From 21918b4514c8379c80bc1769287fe7ec393c0460 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Fri, 6 Mar 2020 10:13:34 -0700 Subject: [PATCH 091/103] comment out OMP directives in KPP_compute_BLD temporarily --- .../vertical/MOM_CVMix_KPP.F90 | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 3524580dc1..5ed9e2a7a4 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -962,16 +962,16 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF buoy_scale = US%L_to_m**2*US%s_to_T**3 ! loop over horizontal points on processor - !$OMP parallel do default(none) private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & - !$OMP surfBuoyFlux, U_H, V_H, u, v, Coriolis, pRef, SLdepth_0d, & - !$OMP ksfc, surfHtemp, surfHsalt, surfHu, surfHv, surfHuS, & - !$OMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & - !$OMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, & - !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_GUESS, LA, rho_1D, & - !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & - !$OMP BulkRi_1d, zBottomMinusOffset) & - !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & - !$OMP Temp, Salt, waves, EOS, GoRho) + !GOMP parallel do default(none) private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & + !GOMP surfBuoyFlux, U_H, V_H, u, v, Coriolis, pRef, SLdepth_0d, & + !GOMP ksfc, surfHtemp, surfHsalt, surfHu, surfHv, surfHuS, & + !GOMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & + !GOMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, & + !GOMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_GUESS, LA, rho_1D, & + !GOMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & + !GOMP BulkRi_1d, zBottomMinusOffset) & + !GOMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & + !GOMP Temp, Salt, waves, EOS, GoRho) do j = G%jsc, G%jec do i = G%isc, G%iec From 75334543b62d8ebb08d2e3afb7fa510776eb6cf0 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Fri, 6 Mar 2020 16:27:27 -0700 Subject: [PATCH 092/103] fix omp in calculate_diagnostic_fields --- src/diagnostics/MOM_diagnostics.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 95c3ad6916..77b36f85db 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -600,7 +600,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if (CS%id_rhopot2 > 0) call post_data(CS%id_rhopot2, Rcv, CS%diag) endif if (CS%id_rhoinsitu > 0) then -!$OMP parallel do default(none) shared(tv,Rcv,is,ie,js,je,nz,pressure_1d,h,GV) +!$OMP parallel do default(none) shared(tv,Rcv,is,ie,js,je,nz,h,GV) private(pressure_1d) do j=js,je pressure_1d(:) = 0. ! Start at p=0 Pa at surface do k=1,nz From 44780667862bb767c7a344d190a05995a66b602b Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Fri, 6 Mar 2020 16:28:18 -0700 Subject: [PATCH 093/103] uncomment omp do block in advect_tracer --- src/tracer/MOM_tracer_advect.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index e425629c77..8e129b9edc 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -250,9 +250,9 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & isv = isv + stencil ; iev = iev - stencil jsv = jsv + stencil ; jev = jev - stencil -!$OMP parallel do default(none) shared(nz,domore_k,x_first,Tr,hprev,uhr,uh_neglect, & -!$OMP OBC,domore_u,ntr,Idt,isv,iev,jsv,jev,stencil, & -!$OMP G,GV,CS,vhr,vh_neglect,domore_v,US) +!GOMP parallel do default(none) shared(nz,domore_k,x_first,Tr,hprev,uhr,uh_neglect, & +!GOMP OBC,domore_u,ntr,Idt,isv,iev,jsv,jev,stencil, & +!GOMP G,GV,CS,vhr,vh_neglect,domore_v,US) ! To ensure positive definiteness of the thickness at each iteration, the ! mass fluxes out of each layer are checked each step, and limited to keep From 276c6b4d206d91833c8ab2103ba19e639fe595cf Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Fri, 6 Mar 2020 16:29:33 -0700 Subject: [PATCH 094/103] call chksum for drag_vel if its allocated --- src/parameterizations/lateral/MOM_MEKE.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index c1bb35e9ee..892fc996e7 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -286,7 +286,8 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Calculates bottomFac2, barotrFac2 and LmixScale call MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, MEKE%MEKE, bottomFac2, barotrFac2, LmixScale) if (CS%debug) then - call uvchksum("MEKE drag_vel_[uv]", drag_vel_u, drag_vel_v, G%HI, scale=US%Z_to_m*US%s_to_T) + if (CS%visc_drag) & + call uvchksum("MEKE drag_vel_[uv]", drag_vel_u, drag_vel_v, G%HI, scale=US%Z_to_m*US%s_to_T) call hchksum(mass, 'MEKE mass',G%HI,haloshift=1, scale=US%R_to_kg_m3*US%Z_to_m) call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, scale=US%L_T_to_m_s) call hchksum(bottomFac2, 'MEKE bottomFac2', G%HI) From f83292592dd2a2d892274ca22d00d389d997aba5 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Fri, 6 Mar 2020 16:33:06 -0700 Subject: [PATCH 095/103] initialize fluid entrainment arrays --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 2830135540..38cecf0425 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -1332,6 +1332,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, nkmb = GV%nk_rho_varies h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect*h_neglect Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 + ea_s(:,:,:) = 0.0; eb_s(:,:,:) = 0.0; ea_t(:,:,:) = 0.0; eb_t(:,:,:) = 0.0 showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("diabatic_ALE(), MOM_diabatic_driver.F90") From c429824190a769dbb638f1a3407ef61e8dde3b20 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 10 Mar 2020 16:11:22 -0600 Subject: [PATCH 096/103] Fix a bug in the vmGM field when using GEOMETRIC --- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 7a8e8da126..53250b7023 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -307,8 +307,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (associated(MEKE)) then ; if (associated(MEKE%Kh)) then if (CS%MEKE_GEOMETRIC) then !$OMP do - do J=js-1,je ; do I=is,ie - Khth_loc(I,j) = Khth_loc(I,j) + G%mask2dCv(i,J) * CS%MEKE_GEOMETRIC_alpha * & + do J=js-1,je ; do i=is,ie + Khth_loc_v(i,J) = Khth_loc_v(i,J) + G%mask2dCv(i,J) * CS%MEKE_GEOMETRIC_alpha * & 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i,j+1)) / & (VarMix%SN_v(i,J) + CS%MEKE_GEOMETRIC_epsilon) enddo ; enddo From 1ecade5e02026017c6616870d94a723ab80b684d Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 13 Mar 2020 14:38:06 -0600 Subject: [PATCH 097/103] Updates GME by removing dependency on MEKE Following changes have been made: * add new argument (thickness_diffuse_CS) to horizontal_viscosity; this is needed so that the GM coeff can be called from MOM_hor_visc. * Deletes unnecessary calls to pass_vector * Simplifies GME by removing dependecy on MEKE. GME is now set to be some multiple of the GM coeff. A new runtime parameter (GME_efficiency) can be used to control the strength of GME. --- src/core/MOM_dynamics_split_RK2.F90 | 5 +- .../lateral/MOM_hor_visc.F90 | 74 ++++--------------- 2 files changed, 16 insertions(+), 63 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 8c016b11b0..ca94af2225 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -681,7 +681,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & MEKE, Varmix, G, GV, US, CS%hor_visc_CSp, & - OBC=CS%OBC, BT=CS%barotropic_CSp) + OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2)") @@ -1149,7 +1149,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param .not. query_initialized(CS%diffv,"diffv",restart_CS)) then call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, VarMix, & G, GV, US, CS%hor_visc_CSp, & - OBC=CS%OBC, BT=CS%barotropic_CSp) + OBC=CS%OBC, BT=CS%barotropic_CSp, & + TD=thickness_diffuse_CSp) else if ( (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & (US%m_to_L * US%s_to_T_restart**2 /= US%m_to_L_restart * US%s_to_T**2) ) then diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index ffd3b1ac63..96239e049a 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -203,7 +203,7 @@ module MOM_hor_visc !! v[is-2:ie+2,js-2:je+2] !! h[is-1:ie+1,js-1:je+1] subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, & - CS, OBC, BT) + CS, OBC, BT, TD) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & @@ -228,7 +228,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, type(ocean_OBC_type), optional, pointer :: OBC !< Pointer to an open boundary condition type type(barotropic_CS), optional, pointer :: BT !< Pointer to a structure containing !! barotropic velocities. - + type(thickness_diffuse_CS), optional, pointer :: TD !< Pointer to a structure containing + !! thickness diffusivities. ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & Del2u, & ! The u-compontent of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] @@ -418,8 +419,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, G%IdxCv(i,J-1) * vbtav(i,J-1)) enddo; enddo - call pass_vector(dudx_bt, dvdy_bt, G%Domain, stagger=BGRID_NE) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 sh_xx_bt(i,j) = dudx_bt(i,j) - dvdy_bt(i,j) enddo ; enddo @@ -432,8 +431,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, - ubtav(I,j)*G%IdxCu(I,j)) enddo ; enddo - call pass_vector(dvdx_bt, dudy_bt, G%Domain, stagger=AGRID) - if (CS%no_slip) then do J=js-1,Jeq ; do I=is-1,Ieq sh_xy_bt(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_bt(I,J) + dudy_bt(I,J) ) @@ -1063,48 +1060,14 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo if (CS%use_GME) then - if (CS%answers_2018) then - do j=js,je ; do i=is,ie - grad_vel_mag_h(i,j) = boundary_mask_h(i,j) * (dudx(i,j)**2 + dvdy(i,j)**2 + & - (0.25*((dvdx(I,J) + dvdx(I-1,J-1)) + (dvdx(I,J-1) + dvdx(I-1,J))) )**2 + & - (0.25*((dudy(I,J) + dudy(I-1,J-1)) + (dudy(I,J-1) + dudy(I-1,J))) )**2) - max_diss_rate_h(i,j,k) = 2.0 * MEKE%MEKE(i,j) * sqrt(grad_vel_mag_h(i,j)) - enddo ; enddo - else ! This form is invariant to 90-degree rotations. - do j=js,je ; do i=is,ie - grad_vel_mag_h(i,j) = boundary_mask_h(i,j) * ((dudx(i,j)**2 + dvdy(i,j)**2) + & - ((0.25*((dvdx(I,J) + dvdx(I-1,J-1)) + (dvdx(I,J-1) + dvdx(I-1,J))) )**2 + & - (0.25*((dudy(I,J) + dudy(I-1,J-1)) + (dudy(I,J-1) + dudy(I-1,J))) )**2)) - max_diss_rate_h(i,j,k) = 2.0 * MEKE%MEKE(i,j) * sqrt(grad_vel_mag_h(i,j)) - enddo ; enddo - endif - - if (CS%answers_2018) then - do J = G%JscB, G%JecB ; do I = G%IscB, G%IecB - grad_vel_mag_q(I,J) = boundary_mask_q(I,J) * (dudx(i,j)**2 + dvdy(i,j)**2 + & - (0.25*((dvdx(I,J)+dvdx(I-1,J-1)) + (dvdx(I,J-1)+dvdx(I-1,J))) )**2 + & - (0.25*((dudy(I,J)+dudy(I-1,J-1)) + (dudy(I,J-1)+dudy(I-1,J))) )**2) + call thickness_diffuse_get_KH(TD, KH_u_GME, KH_v_GME, G) - max_diss_rate_q(I,J,k) = 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i+1,j)+ & - MEKE%MEKE(i,j+1)+MEKE%MEKE(i+1,j+1)) * sqrt(grad_vel_mag_q(I,J)) - enddo ; enddo - else ! This form is rotationally invariant - do J = G%JscB, G%JecB ; do I = G%IscB, G%IecB - grad_vel_mag_q(I,J) = boundary_mask_q(I,J) * ((dudx(i,j)**2 + dvdy(i,j)**2) + & - ((0.25*((dvdx(I,J)+dvdx(I-1,J-1)) + (dvdx(I,J-1)+dvdx(I-1,J))) )**2 + & - (0.25*((dudy(I,J)+dudy(I-1,J-1)) + (dudy(I,J-1)+dudy(I-1,J))) )**2)) - - max_diss_rate_q(I,J,k) = 0.5*((MEKE%MEKE(i,j) + MEKE%MEKE(i+1,j+1)) + & - (MEKE%MEKE(i+1,j) + MEKE%MEKE(i,j+1))) * sqrt(grad_vel_mag_q(I,J)) - enddo ; enddo - endif - - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - if ((grad_vel_mag_bt_h(i,j)>0) .and. (max_diss_rate_h(i,j,k)>0)) then - GME_coeff = (MIN(G%bathyT(i,j)/CS%GME_h0,1.0)**2) * CS%GME_efficiency*max_diss_rate_h(i,j,k) / & - grad_vel_mag_bt_h(i,j) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (grad_vel_mag_bt_h(i,j)>0) then + GME_coeff = CS%GME_efficiency * (MIN(G%bathyT(i,j)/CS%GME_h0,1.0)**2) * & + (0.25*(KH_u_GME(I,j,k)+KH_u_GME(I-1,j,k)+KH_v_GME(i,J,k)+KH_v_GME(i,J-1,k))) else - GME_coeff = 1.0 + GME_coeff = 0.0 endif ! apply mask @@ -1117,10 +1080,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo do J=js-1,Jeq ; do I=is-1,Ieq - - if ((grad_vel_mag_bt_q(I,J)>0) .and. (max_diss_rate_q(I,J,k)>0)) then - GME_coeff = (MIN(G%bathyT(i,j)/CS%GME_h0,1.0)**2) * CS%GME_efficiency*max_diss_rate_q(I,J,k) / & - grad_vel_mag_bt_q(I,J) + if (grad_vel_mag_bt_q(i,j)>0) then + GME_coeff = CS%GME_efficiency * (MIN(G%bathyT(i,j)/CS%GME_h0,1.0)**2) * & + (0.25*(KH_u_GME(I,j,k)+KH_u_GME(I,j+1,k)+KH_v_GME(i,J,k)+KH_v_GME(i+1,J,k))) else GME_coeff = 0.0 endif @@ -1153,7 +1115,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (associated(MEKE%GME_snk)) then do j=js,je ; do i=is,ie - FrictWork_GME(i,j,k) = GME_coeff_h(i,j,k) * h(i,j,k) * GV%H_to_RZ * grad_vel_mag_bt_h(i,j) + FrictWork_GME(i,j,k) = GME_coeff_h(i,j,k) * h(i,j,k) * GV%H_to_kg_m2 * grad_vel_mag_bt_h(i,j) enddo ; enddo endif @@ -1395,8 +1357,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) ! valid parameters. logical :: split ! If true, use the split time stepping scheme. ! If false and USE_GME = True, issue a FATAL error. - logical :: use_MEKE ! If true, use the MEKE module for calculating eddy kinetic energy. - ! If false and USE_GME = True, issue a FATAL error. logical :: default_2018_answers character(len=64) :: inputdir, filename @@ -1667,14 +1627,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) if (.not. split) call MOM_error(FATAL,"ERROR: Currently, USE_GME = True "// & "cannot be used with SPLIT=False.") - call get_param(param_file, mdl, "USE_MEKE", use_MEKE, & - "If true, turns on the MEKE scheme which calculates\n"// & - "a sub-grid mesoscale eddy kinetic energy budget.", & - default=.false.) - - if (.not. use_MEKE) call MOM_error(FATAL,"ERROR: Currently, USE_GME = True "// & - "cannot be used with USE_MEKE=False.") - call get_param(param_file, mdl, "GME_H0", CS%GME_h0, & "The strength of GME tapers quadratically to zero when the bathymetric "//& "depth is shallower than GME_H0.", units="m", scale=US%m_to_Z, & From 1f308a02f53da836b34e1c5314ac23cff9acd83b Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 18 Mar 2020 17:37:35 -0600 Subject: [PATCH 098/103] Extend loop indices and add calls to pass_vector --- src/parameterizations/lateral/MOM_hor_visc.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 96239e049a..d9b465ee0a 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -412,7 +412,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, call barotropic_get_tav(BT, ubtav, vbtav, G, US) call pass_vector(ubtav, vbtav, G%Domain) - do j=js-1,je+1 ; do i=is-1,ie+1 + do j=js-1,je+2 ; do i=is-1,ie+2 dudx_bt(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * ubtav(I,j) - & G%IdyCu(I-1,j) * ubtav(I-1,j)) dvdy_bt(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * vbtav(i,J) - & @@ -431,6 +431,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, - ubtav(I,j)*G%IdxCu(I,j)) enddo ; enddo + call pass_vector(dudx_bt, dvdy_bt, G%Domain, stagger=BGRID_NE) + call pass_vector(dvdx_bt, dudy_bt, G%Domain, stagger=AGRID) + if (CS%no_slip) then do J=js-1,Jeq ; do I=is-1,Ieq sh_xy_bt(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_bt(I,J) + dudy_bt(I,J) ) @@ -1061,6 +1064,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%use_GME) then call thickness_diffuse_get_KH(TD, KH_u_GME, KH_v_GME, G) + call pass_vector(KH_u_GME, KH_v_GME, G%Domain) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 if (grad_vel_mag_bt_h(i,j)>0) then From 6636e0f43a580e92e8e3cb604268787be4777f9a Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 19 Mar 2020 09:07:13 -0600 Subject: [PATCH 099/103] fix OMP directive variable list --- src/parameterizations/lateral/MOM_hor_visc.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index d9b465ee0a..c3ec878bc1 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -468,7 +468,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI5, H0_GME, & !$OMP diffu, diffv, max_diss_rate_h, max_diss_rate_q, & !$OMP Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & - !$OMP div_xx_h, vort_xy_q, GME_coeff_h, GME_coeff_q & + !$OMP div_xx_h, vort_xy_q, GME_coeff_h, GME_coeff_q, & + !$OMP TD, KH_u_GME, KH_v_GME & !$OMP ) & !$OMP private( & !$OMP i, j, k, n, & From 3d05d853775e1a8cfb9a99128b4b46da2897b850 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 24 Mar 2020 16:06:12 -0600 Subject: [PATCH 100/103] make T_adx_2d diagnostics thread-safe --- src/tracer/MOM_tracer_advect.F90 | 80 +++++++++++++++++++------------- 1 file changed, 48 insertions(+), 32 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 8e129b9edc..c06e2b3e51 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -250,9 +250,9 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & isv = isv + stencil ; iev = iev - stencil jsv = jsv + stencil ; jev = jev - stencil -!GOMP parallel do default(none) shared(nz,domore_k,x_first,Tr,hprev,uhr,uh_neglect, & -!GOMP OBC,domore_u,ntr,Idt,isv,iev,jsv,jev,stencil, & -!GOMP G,GV,CS,vhr,vh_neglect,domore_v,US) +!$OMP parallel do ordered default(private) shared(nz,domore_k,x_first,Tr,hprev,uhr,uh_neglect, & +!$OMP OBC,domore_u,ntr,Idt,isv,iev,jsv,jev,stencil, & +!$OMP G,GV,CS,vhr,vh_neglect,domore_v,US) ! To ensure positive definiteness of the thickness at each iteration, the ! mass fluxes out of each layer are checked each step, and limited to keep @@ -334,7 +334,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & !! tracer change [H L2 ~> m3 or kg] real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhr !< accumulated volume/mass flux through !! the zonal face [H L2 ~> m3 or kg] - real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: uh_neglect !< A tiny zonal mass flux that can + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: uh_neglect !< A tiny zonal mass flux that can !! be neglected [H L2 ~> m3 or kg] type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used logical, dimension(SZJ_(G),SZK_(G)), intent(inout) :: domore_u !< If true, there is more advection to be @@ -353,7 +353,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & real, dimension(SZI_(G),ntr) :: & slope_x ! The concentration slope per grid point [conc]. - real, dimension(SZIB_(G),ntr) :: & + real, dimension(SZIB_(G),SZJ_(G),ntr) :: & flux_x ! The tracer flux across a boundary [H L2 conc ~> m3 conc or kg conc]. real, dimension(SZI_(G),ntr) :: & T_tmp ! The copy of the tracer concentration at constant i,k [H m2 conc ~> m3 conc or kg conc]. @@ -374,13 +374,16 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! any of the passes [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - logical :: do_i(SZIB_(G)) ! If true, work on given points. + logical :: do_i(SZIB_(G),SZJ_(G)) ! If true, work on given points. logical :: do_any_i integer :: i, j, m, n, i_up, stencil real :: aR, aL, dMx, dMn, Tp, Tc, Tm, dA, mA, a6 real :: fac1,u_L_in,u_L_out ! terms used for time-stepping OBC reservoirs type(OBC_segment_type), pointer :: segment=>NULL() logical :: usePLMslope + logical, dimension(SZJ_(G),SZK_(G)) :: domore_u_initial + + domore_u_initial = domore_u usePLMslope = .not. (usePPM .and. useHuynh) ! stencil for calculating slope values @@ -537,10 +540,10 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & a6 = 6.*Tc - 3. * (aR + aL) ! Curvature if (uhh(I) >= 0.0) then - flux_x(I,m) = uhh(I)*( aR - 0.5 * CFL(I) * ( & + flux_x(I,j,m) = uhh(I)*( aR - 0.5 * CFL(I) * ( & ( aR - aL ) - a6 * ( 1. - 2./3. * CFL(I) ) ) ) else - flux_x(I,m) = uhh(I)*( aL + 0.5 * CFL(I) * ( & + flux_x(I,j,m) = uhh(I)*( aL + 0.5 * CFL(I) * ( & ( aR - aL ) + a6 * ( 1. - 2./3. * CFL(I) ) ) ) endif enddo ; enddo @@ -550,28 +553,28 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! Indirect implementation of PLM !aL = Tr(m)%t(i,j,k) - 0.5 * slope_x(i,m) !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) - !flux_x(I,m) = uhh(I)*( aR - 0.5 * (aR-aL) * CFL(I) ) + !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * (aR-aL) * CFL(I) ) ! Alternative implementation of PLM !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) - !flux_x(I,m) = uhh(I)*( aR - 0.5 * slope_x(i,m) * CFL(I) ) + !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * slope_x(i,m) * CFL(I) ) ! Alternative implementation of PLM Tc = T_tmp(i,m) - flux_x(I,m) = uhh(I)*( Tc + 0.5 * slope_x(i,m) * ( 1. - CFL(I) ) ) + flux_x(I,j,m) = uhh(I)*( Tc + 0.5 * slope_x(i,m) * ( 1. - CFL(I) ) ) ! Original implementation of PLM - !flux_x(I,m) = uhh(I)*(Tr(m)%t(i,j,k) + slope_x(i,m)*ts2(I)) + !flux_x(I,j,m) = uhh(I)*(Tr(m)%t(i,j,k) + slope_x(i,m)*ts2(I)) else ! Indirect implementation of PLM !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) !aR = Tr(m)%t(i+1,j,k) + 0.5 * slope_x(i+1,m) - !flux_x(I,m) = uhh(I)*( aL + 0.5 * (aR-aL) * CFL(I) ) + !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * (aR-aL) * CFL(I) ) ! Alternative implementation of PLM !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) - !flux_x(I,m) = uhh(I)*( aL + 0.5 * slope_x(i+1,m) * CFL(I) ) + !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * slope_x(i+1,m) * CFL(I) ) ! Alternative implementation of PLM Tc = T_tmp(i+1,m) - flux_x(I,m) = uhh(I)*( Tc - 0.5 * slope_x(i+1,m) * ( 1. - CFL(I) ) ) + flux_x(I,j,m) = uhh(I)*( Tc - 0.5 * slope_x(i+1,m) * ( 1. - CFL(I) ) ) ! Original implementation of PLM - !flux_x(I,m) = uhh(I)*(Tr(m)%t(i+1,j,k) - slope_x(i+1,m)*ts2(I)) + !flux_x(I,j,m) = uhh(I)*(Tr(m)%t(i+1,j,k) - slope_x(i+1,m)*ts2(I)) endif !ts2(I) = 0.5*(1.0 - uhh(I)/(hprev(i,j,k)+h_neglect*G%areaT(i,j))) enddo ; enddo @@ -593,8 +596,8 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! should the reservoir evolve for this case Kate ?? - Nope do m=1,ntr if (associated(segment%tr_Reg%Tr(m)%tres)) then - flux_x(I,m) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) - else ; flux_x(I,m) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) + else ; flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif enddo endif endif @@ -616,8 +619,8 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & uhh(I) = uhr(I,j,k) do m=1,ntr if (associated(segment%tr_Reg%Tr(m)%tres)) then - flux_x(I,m) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) - else; flux_x(I,m) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc; endif + flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) + else; flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc; endif enddo endif endif @@ -633,16 +636,16 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & enddo do i=is,ie if ((uhh(I) /= 0.0) .or. (uhh(I-1) /= 0.0)) then - do_i(i) = .true. + do_i(i,j) = .true. hlst(i) = hprev(i,j,k) hprev(i,j,k) = hprev(i,j,k) - (uhh(I) - uhh(I-1)) - if (hprev(i,j,k) <= 0.0) then ; do_i(i) = .false. + if (hprev(i,j,k) <= 0.0) then ; do_i(i,j) = .false. elseif (hprev(i,j,k) < h_neglect*G%areaT(i,j)) then hlst(i) = hlst(i) + (h_neglect*G%areaT(i,j) - hprev(i,j,k)) Ihnew(i) = 1.0 / (h_neglect*G%areaT(i,j)) else ; Ihnew(i) = 1.0 / hprev(i,j,k) ; endif else - do_i(i) = .false. + do_i(i,j) = .false. endif enddo @@ -651,34 +654,47 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! update tracer do i=is,ie - if (do_i(i)) then + if (do_i(i,j)) then if (Ihnew(i) > 0.0) then Tr(m)%t(i,j,k) = (Tr(m)%t(i,j,k) * hlst(i) - & - (flux_x(I,m) - flux_x(I-1,m))) * Ihnew(i) + (flux_x(I,j,m) - flux_x(I-1,j,m))) * Ihnew(i) endif endif enddo ! diagnostics - if (associated(Tr(m)%ad_x)) then ; do i=is,ie ; if (do_i(i)) then - Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + flux_x(I,m)*Idt - endif ; enddo ; endif - if (associated(Tr(m)%ad2d_x)) then ; do i=is,ie ; if (do_i(i)) then - Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + flux_x(I,m)*Idt + if (associated(Tr(m)%ad_x)) then ; do i=is,ie ; if (do_i(i,j)) then + Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + flux_x(I,j,m)*Idt endif ; enddo ; endif + !!if (associated(Tr(m)%ad2d_x)) then ; do i=is,ie ; if (do_i(i,j)) then + !! Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + flux_x(I,j,m)*Idt + !!endif ; enddo ; endif ! diagnose convergence of flux_x (do not use the Ihnew(i) part of the logic). ! division by areaT to get into W/m2 for heat and kg/(s*m2) for salt. if (associated(Tr(m)%advection_xy)) then - do i=is,ie ; if (do_i(i)) then - Tr(m)%advection_xy(i,j,k) = Tr(m)%advection_xy(i,j,k) - (flux_x(I,m) - flux_x(I-1,m)) * & + do i=is,ie ; if (do_i(i,j)) then + Tr(m)%advection_xy(i,j,k) = Tr(m)%advection_xy(i,j,k) - (flux_x(I,j,m) - flux_x(I-1,j,m)) * & Idt * G%IareaT(i,j) endif ; enddo endif enddo + endif + + + enddo ! End of j-loop. + + !$OMP ordered + do j=js,je ; if (domore_u_initial(j,k)) then + do m=1,ntr + if (associated(Tr(m)%ad2d_x)) then ; do i=is,ie ; if (do_i(i,j)) then + Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + flux_x(I,j,m)*Idt + endif ; enddo ; endif + enddo endif ; enddo ! End of j-loop. + !$OMP end ordered end subroutine advect_x From 3768a118d5704988f9fe09a66c0c91e68f8ee40f Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 24 Mar 2020 19:42:56 -0600 Subject: [PATCH 101/103] make advect_y thread-safe --- src/tracer/MOM_tracer_advect.F90 | 33 ++++++++++++++++++++++---------- 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index c06e2b3e51..010f6bfc8a 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -383,6 +383,8 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & logical :: usePLMslope logical, dimension(SZJ_(G),SZK_(G)) :: domore_u_initial + ! keep a local copy of the initial values of domore_u, which is to be used when computing ad2d_x + ! diagnostic at the end of this subroutine. domore_u_initial = domore_u usePLMslope = .not. (usePPM .and. useHuynh) @@ -686,6 +688,8 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & enddo ! End of j-loop. + ! compute ad2d_x diagnostic outside above j-loop so as to make the summation ordered when OMP is active. + !$OMP ordered do j=js,je ; if (domore_u_initial(j,k)) then do m=1,ntr @@ -749,7 +753,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. logical :: do_j_tr(SZJ_(G)) ! If true, calculate the tracer profiles. - logical :: do_i(SZIB_(G)) ! If true, work on given points. + logical :: do_i(SZIB_(G), SZJ_(G)) ! If true, work on given points. logical :: do_any_i integer :: i, j, j2, m, n, j_up, stencil real :: aR, aL, dMx, dMn, Tp, Tc, Tm, dA, mA, a6 @@ -1026,36 +1030,33 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & do j=js,je ; if (do_j_tr(j)) then do i=is,ie if ((vhh(i,J) /= 0.0) .or. (vhh(i,J-1) /= 0.0)) then - do_i(i) = .true. + do_i(i,j) = .true. hlst(i) = hprev(i,j,k) hprev(i,j,k) = max(hprev(i,j,k) - (vhh(i,J) - vhh(i,J-1)), 0.0) - if (hprev(i,j,k) <= 0.0) then ; do_i(i) = .false. + if (hprev(i,j,k) <= 0.0) then ; do_i(i,j) = .false. elseif (hprev(i,j,k) < h_neglect*G%areaT(i,j)) then hlst(i) = hlst(i) + (h_neglect*G%areaT(i,j) - hprev(i,j,k)) Ihnew(i) = 1.0 / (h_neglect*G%areaT(i,j)) else ; Ihnew(i) = 1.0 / hprev(i,j,k) ; endif - else ; do_i(i) = .false. ; endif + else ; do_i(i,j) = .false. ; endif enddo ! update tracer and save some diagnostics do m=1,ntr - do i=is,ie ; if (do_i(i)) then + do i=is,ie ; if (do_i(i,j)) then Tr(m)%t(i,j,k) = (Tr(m)%t(i,j,k) * hlst(i) - & (flux_y(i,m,J) - flux_y(i,m,J-1))) * Ihnew(i) endif ; enddo ! diagnostics - if (associated(Tr(m)%ad_y)) then ; do i=is,ie ; if (do_i(i)) then + if (associated(Tr(m)%ad_y)) then ; do i=is,ie ; if (do_i(i,j)) then Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + flux_y(i,m,J)*Idt endif ; enddo ; endif - if (associated(Tr(m)%ad2d_y)) then ; do i=is,ie ; if (do_i(i)) then - Tr(m)%ad2d_y(i,J) = Tr(m)%ad2d_y(i,J) + flux_y(i,m,J)*Idt - endif ; enddo ; endif ! diagnose convergence of flux_y and add to convergence of flux_x. ! division by areaT to get into W/m2 for heat and kg/(s*m2) for salt. if (associated(Tr(m)%advection_xy)) then - do i=is,ie ; if (do_i(i)) then + do i=is,ie ; if (do_i(i,j)) then Tr(m)%advection_xy(i,j,k) = Tr(m)%advection_xy(i,j,k) - (flux_y(i,m,J) - flux_y(i,m,J-1))* Idt * & G%IareaT(i,j) endif ; enddo @@ -1064,6 +1065,18 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & enddo endif ; enddo ! End of j-loop. + ! compute ad2d_y diagnostic outside above j-loop so as to make the summation ordered when OMP is active. + + !$OMP ordered + do j=js,je ; if (do_j_tr(j)) then + do m=1,ntr + if (associated(Tr(m)%ad2d_y)) then ; do i=is,ie ; if (do_i(i,j)) then + Tr(m)%ad2d_y(i,J) = Tr(m)%ad2d_y(i,J) + flux_y(i,m,J)*Idt + endif ; enddo ; endif + enddo + endif ; enddo ! End of j-loop. + !$OMP end ordered + end subroutine advect_y !> Initialize lateral tracer advection module From 8025fd4d705fd91a5de05813ce68519b422ae6dc Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 24 Mar 2020 20:16:59 -0600 Subject: [PATCH 102/103] refactor advect_x and advect_y calls --- src/tracer/MOM_tracer_advect.F90 | 36 ++++++++++++++++++++------------ 1 file changed, 23 insertions(+), 13 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 010f6bfc8a..49fb27ff7a 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -250,49 +250,62 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & isv = isv + stencil ; iev = iev - stencil jsv = jsv + stencil ; jev = jev - stencil -!$OMP parallel do ordered default(private) shared(nz,domore_k,x_first,Tr,hprev,uhr,uh_neglect, & -!$OMP OBC,domore_u,ntr,Idt,isv,iev,jsv,jev,stencil, & -!$OMP G,GV,CS,vhr,vh_neglect,domore_v,US) - ! To ensure positive definiteness of the thickness at each iteration, the ! mass fluxes out of each layer are checked each step, and limited to keep ! the thicknesses positive. This means that several iterations may be required ! for all the transport to happen. The sum over domore_k keeps the processors ! synchronized. This may not be very efficient, but it should be reliable. - do k=1,nz ; if (domore_k(k) > 0) then - if (x_first) then +!$OMP parallel default(private) shared(nz,domore_k,x_first,Tr,hprev,uhr,uh_neglect, & +!$OMP OBC,domore_u,ntr,Idt,isv,iev,jsv,jev,stencil, & +!$OMP G,GV,CS,vhr,vh_neglect,domore_v,US) + + if (x_first) then + !$OMP do ordered + do k=1,nz ; if (domore_k(k) > 0) then ! First, advect zonally. call advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & isv, iev, jsv-stencil, jev+stencil, k, G, GV, US, CS%usePPM, CS%useHuynh) + endif ; enddo + !$OMP do ordered + do k=1,nz ; if (domore_k(k) > 0) then ! Next, advect meridionally. call advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & isv, iev, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) + ! Update domore_k(k) for the next iteration domore_k(k) = 0 do j=jsv-stencil,jev+stencil ; if (domore_u(j,k)) domore_k(k) = 1 ; enddo do J=jsv-1,jev ; if (domore_v(J,k)) domore_k(k) = 1 ; enddo - else + endif ; enddo + + else + !$OMP do ordered + do k=1,nz ; if (domore_k(k) > 0) then ! First, advect meridionally. call advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & isv-stencil, iev+stencil, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) + endif ; enddo + !$OMP do ordered + do k=1,nz ; if (domore_k(k) > 0) then ! Next, advect zonally. call advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & isv, iev, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) + ! Update domore_k(k) for the next iteration domore_k(k) = 0 do j=jsv,jev ; if (domore_u(j,k)) domore_k(k) = 1 ; enddo do J=jsv-1,jev ; if (domore_v(J,k)) domore_k(k) = 1 ; enddo + endif ; enddo - endif - + endif ! x_first - endif ; enddo ! End of k-loop +!$OMP end parallel ! If the advection just isn't finishing after max_iter, move on. if (itt >= max_iter) then @@ -668,9 +681,6 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if (associated(Tr(m)%ad_x)) then ; do i=is,ie ; if (do_i(i,j)) then Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + flux_x(I,j,m)*Idt endif ; enddo ; endif - !!if (associated(Tr(m)%ad2d_x)) then ; do i=is,ie ; if (do_i(i,j)) then - !! Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + flux_x(I,j,m)*Idt - !!endif ; enddo ; endif ! diagnose convergence of flux_x (do not use the Ihnew(i) part of the logic). ! division by areaT to get into W/m2 for heat and kg/(s*m2) for salt. From 6ce3dd9b730a2f75884d9159cd48ad6895eccc73 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 30 Mar 2020 09:58:02 -0600 Subject: [PATCH 103/103] Change CDRAG_MEKE to MEKE_CDRAG --- src/parameterizations/lateral/MOM_MEKE.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 892fc996e7..1e785fa930 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1190,9 +1190,9 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the bottom stress.", units="nondim", & default=0.003) - call get_param(param_file, mdl, "CDRAG_MEKE", CS%cdrag, & - "CDRAG is the drag coefficient relating the magnitude of "//& - "the velocity field to the bottom stress.", units="nondim", & + call get_param(param_file, mdl, "MEKE_CDRAG", CS%cdrag, & + "Drag coefficient relating the magnitude of the velocity "//& + "field to the bottom stress in MEKE.", units="nondim", & default=cdrag) call get_param(param_file, mdl, "LAPLACIAN", laplacian, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "BIHARMONIC", biharmonic, default=.false., do_not_log=.true.)